./PaxHeaders/control-4.1.20000644000000000000000000000013115012430707012332 xustar0029 mtime=1747595719.94909952 30 atime=1747595720.869132739 30 ctime=1747595720.869132739 control-4.1.2/0000755000175000017500000000000015012430707013447 5ustar00lilgelilge00000000000000control-4.1.2/PaxHeaders/CONTRIBUTING.md0000644000000000000000000000007415012430645014512 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.869132739 control-4.1.2/CONTRIBUTING.md0000644000175000017500000001211415012430645015700 0ustar00lilgelilge00000000000000# How to Contribute ## Ways to contribute There are many ways to help improving the **control** package for GNU Octave. ### Improving the documentation If you find a function or feature with missing, erroneous, incomplete or incomprehensible help text, you can help us by contributing changes to address the issues. For writing help texts using the [Texinfo](https://www.gnu.org/software/texinfo/) format, please refer to [License and Documentation](#license-and-documentation). ### Reporting and/or fixing bugs Bugs and feature requests for GNU Octave including the packages are tracked on [Github](https://github.com/gnu-octave/pkg-control/issues). Please feel free to start working on a fix or to help by testing. Patches for fixing the bug can be attached to a comment to the issue or - preferably - by opening a pull request in the package's repository (see [Contribution Workflow](#contribution-workflow)). If you would like to report a new bug, please go over existing bugs before in order to avoid duplicate reports. ### Discussions If you have any questions or suggestions on how to extend or improve the package, please feel free to participate the community on [GNU Octave Discourse](https://octave.discourse.group/). ## License and Documentation The **control** package is distributed under [GNU General Public License (GPL)](https://www.gnu.org/licenses/gpl-3.0.en.html) (except for the used SLICOT files). If you are submitting a few function, it should be licensed under GPLv3+ with the following header (use appropriate year, name, etc.) as shown below: ```bash ## Copyright (C) YEAR NAME ## ## This file is part of the statistics package for GNU Octave. ## ## Octave 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. ## ## Octave 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 Octave; see the file COPYING. If not, ## see . ``` New functions or features should be properly documented with the embedded help file in [Texinfo](https://www.gnu.org/software/texinfo/) format. This part should be placed outside (before) the function's main body and after the License block. The Texinfo manual can be found [here](https://www.gnu.org/software/texinfo/manual/texinfo/) although reading through existing function files should do the trick. ```bash ## -*- texinfo -*- ## @deftypefn {Function File} {} pzmap (@var{sys}) ## ## Help file goes here. ## ## @end deftypefn ``` The texinfo is not printed on the command window screen as it appears in the source file. ## Coding style ### General rules The general coding style for GNU Octave given in the [GNU Octave Wiki](https://wiki.octave.org/Octave_style_guide) should be used with the following additions: - Limit the line length to 80 characters - Use `LF` (unix) for end of lines, and NOT `CRLF` (windows) ### Tests It is very helpful that function files contain tests for correct output. The tests are located at the end of the file with lines beginning with `%!`. As example, please finde a test for `pzmap ()` below. ``` %!test %! s = tf('s'); %! g = (s-1)/(s-2)/(s-3); %! [pol zer] = pzmap(g); %! assert(sort(pol), [2 3]', 2*eps); %! assert(zer, 1, eps); ``` ### Demos Although examples of using a function should already be provided in the documentation, it is always useful to have examples embedded as demos, which the user can invoke with the `demo` command. ``` >> demo pzmap ``` Like test, demos are also located at the end of the file. A small demo for `pzmap ()` is shown below. ``` %!demo %! s = tf('s'); %! g = (s-1)/(s-2)/(s-3); %! pzmap(g); ``` ## Contribution Workflow As in many other open-source projects the usual way to contribute to the control package is to - fork the repository, - make changes, like, e.g., fix a bug or add a new feature in your fork, and - send pull requests to the original repository. Please also refer to this [detailed description on collaborating with pull requests](https://docs.github.com/en/pull-requests/collaborating-with-pull-requests). ### Fork and build [Fork](https://github.com/gnu-octave/pkg-control/fork) the pkg-control repository to your own account and clone the resulting repository. Refer to the [README](README.md) file for information about how to build the package archive which can be installed in GNU Octave. ### Pull request When your changes are finished, commit and push the change to your forked repository on Github (make sure your fork is up to date) and create a pull request. ### Option for very small changes If the changes are small and only affect one file, you can make the changes directly in the web interface of Github, select *Commit changes* and *Create a new branch for this commit and start a pull request*. control-4.1.2/PaxHeaders/doc0000644000000000000000000000007415012430645012751 xustar0030 atime=1747595720.869132739 30 ctime=1747595720.869132739 control-4.1.2/doc/0000755000175000017500000000000015012430645014215 5ustar00lilgelilge00000000000000control-4.1.2/doc/PaxHeaders/references.txt0000644000000000000000000000007415012430645015710 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.869132739 control-4.1.2/doc/references.txt0000644000175000017500000000210115012430645017071 0ustar00lilgelilge00000000000000REFERENCES ********** German ****** Geering, H.P. Regelungstechnik Springer 2004 Meyer, M. Signalverarbeitung Vieweg & Teubner 2009 English ******* Anderson, B.D.O. and Moore, J.B. Optimal Control Linear Quadratic Methods Dover Publications 1990 Åström, K. and Hägglund, T. PID Controllers Theory, Design and Tuning Second Edition Instrument Society of America 1995 Doyle, J.C., Francis, B.A. and Tannenbaum, A.R. Feedback Control Theory Dover Publications 1992 Geering, H.P. Optimal Control with Engineering Applications Springer 2007 Gu, D.W., Petkov, P.Hr. and Konstantinov, M.M. Robust Control with MATLAB Springer 2005 Guzzella, L. Analysis and Design of SISO Control Systems VDF Hochschulverlag ETH Zurich 2007 Kailath, T. Linear Systems Prentice Hall 1980 Leigh, J.R. Applied Digital Control Theory, Design and Implementation Second Edition Dover Publications 1992 Ljung, L. System Identification Theory for the User Second Edition Prentice Hall 1999 Skogestad, S. and Postlethwaite, I. Multivariable Feedback Control Analysis and Design Second Edition Wiley 2005 control-4.1.2/doc/PaxHeaders/octave_forge_specific_api.txt0000644000000000000000000000007415012430645020730 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.869132739 control-4.1.2/doc/octave_forge_specific_api.txt0000644000175000017500000000147615012430645022127 0ustar00lilgelilge00000000000000isstable (sys, tol) # feedback (sys) # equivalent to feedback (sys, eye (size (sys))) feedback (sys, "+") # equivalent to feedback (sys, eye (size (sys)), +1) H = sys(w) # equivalent to H = freqresp (sys, w) where w is a frequency vector place (sys, p, alpha) # If parameter alpha is specified, poles with real parts place (a, b, p, alpha) # (continuous time) or moduli (discrete time) below alpha # are left untouched. sminreal (sys, tol) # Optional tolerance for controllability and observability. # Entries of the state-space matrices whose moduli are less or # equal to TOL are assumed to be zero. Default value is 0. frd (sys) # calculate interesting frequency range by the zeros and poles of SYS.control-4.1.2/doc/PaxHeaders/control.png0000644000000000000000000000007415012430645015214 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.869132739 control-4.1.2/doc/control.png0000644000175000017500000001173515012430645016412 0ustar00lilgelilge00000000000000PNG  IHDRddpTgAMA a cHRMz&u0`:pQ<bKGD pHYsodtIME *uavIDATx{PT?}a/,aerV1c1c3ig2$LgLgjMLfND֨ѢBWp*"\VXXveoKzμ~fp}<< ID }IDa$QIAFRDa$QIAFRDa$QIAFRDaP?tFA>@fA?paF,P(Dii)?HII9!==o|XJ… >}ie |'//)|>K,A~8=EQ$??'xBF;w3h4hBzmrBFFF裏z=z۷os%B'OdhhoT$Ǐ?񏌎 ׿EKK x| z裏8t@E8?l6)kC*I3::Joo/'O$33>_l6\.~29hcǎF Fdrr4V+FFΞ=d" 299455a6`||P(`s,$044Ķm(**l6399Inn.x rss|X,HZ-.ׯd"%%l](.c6oތ`chh/lܸՊ$IWvaÆ +WǑ$ ^?u<'IIIA׺hdǎ`ZٱcGv]va6Z=tR2331ôFQQ JNNRycوlذ@(X, $i3{h4JB8xl6f>ί~+Μ9C]]֭Ӊj] H+W b0*cǎq1, Nr9|0_WJKK w$?s RRR(..[nQSSQk׮aXhiil6sU> MUU\paDQ Ñ#GUV%JqQ~:yyy,YdP(۷y79pvIUU;wjA]]'HP(4Xl@@ ƘNBnź(bSSSձk.Xf H֯_O4ի,] 6P__֭[dddPUU$IYv-Ỻ-?OCIHhx5·~Hss3_زe eee|rDQDRop9^Jcc# :X,Ƒ#G8}4[laӦMs{jٲel߾@8FV#?~{Tjjj8{,>XRz{{),,dҥtww˗ett,n7h41J`Ϟ=lE7\GG{Ι|>~billf~mHMM7(k_fo>yo%,% b~ %%e ŰZ<쳉Rլ_łfCRxxYd 6[nQQQf`0H~~>Ν;c^__/#jZݎgaϞ=A}c=ZlܸzVZ+Vd2%Y,|Oici)/+Ix _!qJgϨIYRgH4ˑWQ^FEyٝL[RRBIIH>jnnSO=uW?̼͂fW I.\`zzSN ' EW<*sxh vpu,!eR-rV̙3fDeI蠤H$d^x.yJ2<03(( --g'?&`כp|*S*ĥ U%`gM)W&JJw 9,$. ܃DRB ```ߏZ^tx0C)bP鵔rqI&O5(wt8,g3"N'm/e @h:LEʄGn?^ϙ3gtΫt"---x^$ItRVV˗9<>{f͚< B!v;oO>$tuu1555DZ)(`ht& 'vYf<'i8ڵk(V$y댒n?|zg!˘ ry{߸q~ŒH!.,,$ PDQ"H{W>JJJOͦL&zzztH~~>`FV%wvseDQg!-- .|M\.oؽ{$ILLR/}iQ G&H,!1_?O?癜ĉ\.L&6mLMMRXr% ƍq݌RRRBZZZŠb477ºu8t999ddd ILMMNSSJ,cxx ~ӟb0wÑ#Gxسgpӧq\ƾ}F 'jy(0_򗁙$y5v܉lfڵ"ICCC`ݜ8q7o7vrss~v믿ΪU|h4(l6z{{)//^z+W~jkk9z(===A$IBVSQQAvvvN@ß' 8uGrƍDZl* I_7!x$b6yWtBy`&IUV4$aa4YdIb th4z=v۷o9.IݝlLtuuHMM >}(k.-[MMML&֭[LXXww7èjvEnnn"^El6ۂ_HjyMMM_Qo( vZ\.͆fcrr2:m0M$Vh4r bFÑT* a۶m|pZ[[:E_:t/Lmm-A8ummmB!(,k֌y'ˑEcӃf###e˖aXhhh@P^^h,[ AE@ww7ZVu* ٌltDs֭[q: ;g@WXVV+ab6tWf#HL~SzcHbE֙Y9vv{"^wg0+Ny=1gh4wE.f*j[t;.H2x=ud!-~FIJJhS Ҍ aDY{/dDB"\ZrD_ bqːA%H$n EK Computer-Aided Control System Design: Documentation

Control Package for GNU Octave

Links to documentation and license information:

control-4.1.2/PaxHeaders/ONEWS0000644000000000000000000000007415012430645013077 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.869132739 control-4.1.2/ONEWS0000644000175000017500000010537515012430645014301 0ustar00lilgelilge00000000000000Summary of important user-visible changes for older releases of the control package =============================================================================== control-2.8.5 Release Date: 2015-10-01 Release Manager: Lukas Reichlin =============================================================================== ** nyquist, nichols Specifying a frequency range no longer errors out, i.e. nyquist (sys, {wmin, wmax}) ** pid, pidstd New functions for improved Matlab compatibility. ** ss Support ss (a, b, c, 0) for Matlab compatibility. (Thanks to Thomas Vasileiou) ** tf Fixed a problem which caused the expression below to fail. tf (Boeing707) \ tf (Boeing707) =============================================================================== control-2.8.4 Release Date: 2015-09-02 Release Manager: Lukas Reichlin =============================================================================== ** tf Fixed a bug which affected interconnections of MIMO transfer functions. (Reported by Piet Wertelaers) ** VLFamp Included new demo created by Thomas D. Dean. =============================================================================== control-2.8.3 Release Date: 2015-07-01 Release Manager: Lukas Reichlin =============================================================================== ** LTI models & iddata datasets Support partial matching of property names. ** mpower Fixed bug #45336. Improved reliability for the power computation of MIMO transfer functions. (Reported by Nick Jankowski) ** set Fixed bug #45371. The iddata properties 'name', 'notes' and 'userdata' are now stored as expected. (Thanks to Petr Ledvina) =============================================================================== control-2.8.2 Release Date: 2015-06-15 Release Manager: Lukas Reichlin =============================================================================== ** tf Fixed a problem when converting certain MIMO descriptor state-space systems to transfer function models. ** minreal Fixed bug #43263. Affected were transfer function models. (Thanks to Endre Kozma) ** n4sid, moesp, moen4 Fixed bug #41716. Display a meaningful error message when the iddata dataset contains not enough samples per experiment. (Reported by John W. Eaton) ** rlocus Fixed bug #44949. Fixed a problem with discontinuous plots for systems like the one below. (Thanks to Doug Stewart) sys = tf ([1 0 0 0 0 0 1], [1 0 0 0 1 0 0 0 0 1]) rlocus (sys) =============================================================================== control-2.8.1 Release Date: 2015-05-03 Release Manager: Lukas Reichlin =============================================================================== ** tf -- Revamped the modifications of TB01ZD from control version 2.8.0. The function now uses LAPACK routines to find the maximum norm element. (Thanks to Thomas Vasileiou) -- Improved error handling when converting state-space models. =============================================================================== control-2.8.0 Release Date: 2015-03-22 Release Manager: Lukas Reichlin =============================================================================== ** zero Compatibility fix in the C++ oct-file to support the upcoming Octave 4.0. (Thanks to Andreas Weber) ** isminimumphase Reverted changes from control-2.6.6. According to the definition of Byrnes/Isidori, the function tests whether the system has asymptotically stable zero dynamics. The poles are not tested. Note that the definition from Wikipedia is mixed up. For details, see the help text of the function (help @lti/isminimumphase) and the papers referenced therein. (Thanks to Ulf Schaper) ** series Fixed a bug which gave unnecessary error messages when the function is called with 4 arguments. (Thanks to Ulf Schaper) ** tf Resolved issues in MIMO state-space to transfer function conversion by implementing a more robust algorithm in SLICOT routine TB01ZD. The same algorithm is used in Octave's krylov function. (Thanks to Thomas Vasileiou) ** It is now possible to cross-compile the control package. (Thanks to John Donoghue) ** Support for 64bit indexing, i.e. Octave versions built with the --enable-64 option. (Thanks to Mike Miller) ** The control package now depends on Octave version 3.8.0 or beyond. ** In order to comply with modified Octave Forge rules, the package no longer auto-loads by default. See "help pkg" for details on auto-loading. =============================================================================== control-2.6.6 Release Date: 2014-10-11 Release Manager: Lukas Reichlin =============================================================================== ** isminimumphase According to , both the zeros and the poles of a minimum-phase system must be strictly inside the left complex half-plane (continuous-time case) or inside the unit circle (discrete-time case). Previously, the poles were not tested. (Thanks to Endre Kozma) =============================================================================== control-2.6.5 Release Date: 2014-06-16 Release Manager: Lukas Reichlin =============================================================================== ** LTI models -- The operator "times" (.*) no longer errors out when it is called with one SISO and one MIMO LTI system. The operator behaves now the same way as Octave's built-in "times" for one scalar and one matrix. -- The function "repmat" is now overloaded for LTI systems. -- Added function "repsys" as an alias for "repmat" for the sake of Matlab compatibility. ** zero Fix crash in case of empty state-space models, e.g. zero (ss) =============================================================================== control-2.6.4 Release Date: 2014-05-05 Release Manager: Lukas Reichlin =============================================================================== ** LTI models -- Fixed bug #42082. The operators mtimes (*), mldivide (\) and mrdivide (/) no longer error out when they are called with one SISO and one MIMO LTI system. They now behave the same way as they do with one scalar and one matrix. -- Refuse struct arrays as input and output groups. -- Display non-empty properties of type 'name'. ** TF models -- Added TF-specific horzcat ([tf1, tf2]) and vertcat ([tf1; tf2]) operators which override the general LTI operators. Their introduction avoids the conversion to state-space and back when MIMO transfer functions are concatenated horizontally and/or vertically. -- Added operator times (.*) to compute Hadamard/Schur product of two transfer function matrices. This operator is useful to compute the Relative-Gain Array (RGA), e.g. G = tf (Boeing707) RGA = G .* inv (G).' RGA(0) =============================================================================== control-2.6.3 Release Date: 2014-04-22 Release Manager: Lukas Reichlin =============================================================================== ** SS models For interconnections, support special case where the internal matrix (I - D*M) is singular, e.g. feedback (ss (-1, 1, 4, 1), '+') ** FRD models Fixed bug which let frequency response plots fail, e.g. bode (frd (tf (1, [1, 1]))) ** tf Refuse denominators which are zero. ** c2d For zero-order hold approximation, use SLICOT MB05ND instead of Octave's "expm" to compute the matrix exponential. Better accuracy is to be expected. ** connect -- Improved argument checking for legacy connection matrix. -- Document usage of index-based interconnections. ** inv -- Handle i/o names and groups correctly. -- Conserve the meaning of states by using the Matlab-compatible formula instead of the SLICOT-compatible one. -- Always use conversion to state-space and back for the inversion of MIMO transfer functions, even for 2x2 systems. ** pole Compute poles of descriptor state-space models with SLICOT AG08BD instead of Octave's built-in "eig" function. ** zero The gain of descriptor state-space models is now computed correctly. (Special thanks to Thomas Vasileiou for all the fixes above) ** rlocus -- Function "rlocus" now supports the fltk graphics toolkit. (Thanks to Doug Stewart) -- Fixed bug #41820. Function "rlocus" no longer errors out for certain systems like rlocus (tf ([1, 4, 4], [1, 8, 1, 8, 0])) ** transpose, ctranspose Delete i/o groups of transposed (sys.') or conjugate transposed (sys') LTI models. ** IDDATA identification datasets Raise an error if non-real-valued input or output matrices are assigned to time-domain datasets via the "set" function or subscripted assignment. =============================================================================== control-2.6.2 Release Date: 2014-02-02 Release Manager: Lukas Reichlin =============================================================================== ** hinfsyn, mixsyn By default, hinfsyn and mixsyn compute now an optimal instead of a suboptimal controller. Furthermore, Matlab compatibility is improved if hinfsyn/mixsyn is called with more than three/four input arguments. (Thanks to Thomas Vasileiou for the gamma iteration) The old behavior (sub-optimal controller) can be restored by the expressions hinfsyn (P, nmeas, ncont, 'method', 'sub') mixsyn (G, W1, W2, W3, 'method', 'sub') ** h2syn, hinfsyn, mixsyn, ncfsyn For Matlab compatibility, the third return argument is now norm "gamma". The info struct is now returned as fourth argument. [K, N, gamma, info] = *syn (G, …) ** mktito New function to partition plant for robust control. "mktito" is also used by function "augw". If a plant is partitioned that way, one can omit the inputs "nmeas" and "ncon" when calling the functions "hinfsyn" and "h2syn". ** ss The conversion of realizable descriptor systems to regular state-space form is now possible, even when the descriptor matrix "E" is singular. (Thanks to Thomas Vasileiou and Bruce Minaker) =============================================================================== control-2.6.1 Release Date: 2013-12-10 Release Manager: Lukas Reichlin =============================================================================== ** LTI models Raise an error if the user tries to create an ingroup or outgroup with indices larger than the number of inputs m or outputs p. ** thiran New function to approximate a continuous-time delay by a discrete-time allpass Thiran filter. (Thanks to Thomas Vasileiou and Spencer Jackson) ** end "end" indexing for LTI and IDDATA objects works now as expected. =============================================================================== control-2.6.0 Release Date: 2013-10-24 Release Manager: Lukas Reichlin =============================================================================== ** LTI models -- Support for name-based channel selection in various commands. Example: sys = Boeing707, sys('pitch', {'rudder', 'thrust'}) instead of sys(2, [2, 1]). -- New properties "ingroup" and "outgroup" to pool several channels: sys.ingroup.controls = [3, 1], sys.outgroup.measurements = [1, 2] sys('measurements', 'controls') instead of sys([1, 2], [3, 1]). -- Support names instead of indices in commands like "feedback" and "xperm". ** connect Support name-based interconnections. This means that the LTI models passed to "connect" will be interconnected automatically if they have their inputs and outputs named accordingly. ** sumblk New function to build summing junctions for name-based interconnections by "connect". Example: Sum = sumblk ('e = r - y + n') ** tf State-space to transfer function conversions of static gains, e.g. "tf (ss (5))", no longer error out. (Thanks to Thomas Vasileiou) ** IDDATA identification datasets Support for name-based output, input and experiment selection similar to LTI models. =============================================================================== control-2.4.5 Release Date: 2013-10-07 Release Manager: Lukas Reichlin =============================================================================== ** Compatibility to GNU Octave 3.8 Replaced line continuation marker "\" by "..." to avoid deprecated syntax warning. (Thanks to John W. Eaton) ** db2mag, mag2db New functions to convert Decibels to Magnitude and vice versa. ** d2d New function for resampling of discrete-time models. =============================================================================== control-2.4.4 Release Date: 2013-08-11 Release Manager: Lukas Reichlin =============================================================================== ** zero -- Fix documentation. Function "zero" computes the invariant zeros, not the transmission zeros when it is called with one input argument. -- Added new options to compute the system, transmission, input decoupling and output decoupling zeros besides the already existing invariant zeros. Examples: z = zero (sys, 'system'), z = zero (sys, 'transmission') -- Return an "info" struct as third output argument. It contains additional rank information as well as Kronecker indices and the numbers of infinite elementary divisors. Example: [z, k, info] = zero (sys) (Special thanks to Ferdinand Svaricek) ** resample The "resample" function for "iddata" identification datasets now handles unspecified sampling times (tsam = -1) correctly. ** Time response functions (impulse, initial, lsim, ramp, step) Fix a thinko introduced with control-2.4.3. In some cases, several responses were mistakingly plotted on the same subplot. (Thanks to Thomas Vasileiou) ** Various documentation enhancements and fixes. =============================================================================== control-2.4.3 Release Date: 2013-07-12 Release Manager: Lukas Reichlin =============================================================================== ** resample The resample function for iddata sets now adjusts the sampling time correctly after resampling. ** Time response functions (impulse, initial, lsim, ramp, step) Don't use subplot for SISO models. This allows the user to plot different responses on a single figure by calling subplot. (Thanks to Matthias Meier) ** h2syn, hinfsyn, mixsyn, ncfsyn Third return argument is now an info struct. [K, N, info] = *syn (G, …) ** optiPID Beef up documentation. =============================================================================== control-2.4.2 Release Date: 2013-02-16 Release Manager: Lukas Reichlin =============================================================================== ** Transfer function to state-space conversion (Thanks to Thomas Vasileiou): -- Fix crash. -- Fix bug if denominators are zero. ** minreal Fix crash in minreal for state-space systems. (Thanks to Thomas Vasileiou) ** sigma The plot types 1, 2, 3 were no longer supported since the introduction of multi-system plots in control-2.3.54. The help text is now updated accordingly and cruft is removed from the codebase. ** mixsyn, ncfsyn, Madievski Beef up help text. =============================================================================== control-2.4.1 Release Date: 2012-11-01 Release Manager: Lukas Reichlin =============================================================================== ** impulse, initial, lsim, step These time response functions now error out correctly when the user tries to plot multiple systems in one window with mismatching numbers of inputs and outputs. The problem was caused by Octave's built-in function "size_equal" which gave false positives for LTI objects. The problem is solved by overloading the built-in function with a new LTI method "size_equal". ** ramp Added a new time domain analysis function "ramp" which plots/computes the system's response to a ramp signal. ** c2d, d2c Added matched pole/zero discretization method "matched". Usage: Gd = c2d (Gc, Ts, 'matched'), Gc = d2c (Gd, 'matched') ** doc/control.pdf Revised PDF manual. There is now a function index at the end of the manual. Improved docstrings in several functions. =============================================================================== control-2.4.0 Release Date: 2012-09-26 Release Manager: Lukas Reichlin =============================================================================== ** Multiplot feature for time-domain plotting: impulse lsim initial step Supported are now function calls like impulse (sys1, sys2, ...), step (sys1, 'b', sys2, 'r', ...) lsim (sys1, '-k', sys2, '--k', u), initial (sys, sys2, x0) The multiplot feature for frequency-domain plotting has already been introduced with control-2.3.54. ** Anderson, Madievski, MDSSystem, optiPID Updated example scripts to use new multiplot feature. ** sensitivity Fixed a problem with plotting, introduced with control-2.3.54. ** doc/control.pdf Updated PDF manual. =============================================================================== control-2.3.54 Release Date: 2012-09-15 Release Manager: Lukas Reichlin =============================================================================== ** Multiplot feature for frequency-domain plotting: bode nichols pzmap bodemag nyquist sigma The functions above support calls like sigma (sys1, sys2, ...), nyquist (sys1, 'b', sys2, 'r', ...), bode (sys1, '-k', sys2, '-.k', sys3, ':k', {wmin, wmax}). Time domain functions are not yet multiplot ready, but they will follow in control-2.4.0. ** plot A selection of experiments from iddata identification datasets can be plotted by plot (dat, exp) instead of plot (dat(:,:,:,exp)). ** sensitivity Fixed a problem where an error was raised about an undefined function "issiso". ** All SLICOT function names have now leading and trailing underscores to emphasize their private nature. =============================================================================== control-2.3.53 Release Date: 2012-08-27 Release Manager: Lukas Reichlin =============================================================================== ** Added new functions for system identification, including: arx iddata ifft moen4 detrend nkshift moesp fft plot n4sid filter resample ** sensitivity Added new function to compute and plot the sensitivity margin Ms. ** feedback Fixed an argument check which caused false positive error messages. It was a copy-paste mistake affecting non-square systems. (Thanks to Tony Olivo) =============================================================================== control-2.3.52 Release Date: 2012-06-25 Release Manager: Lukas Reichlin =============================================================================== ** Fixed a silly mistake in MIMO transfer function to state-space conversion. The bug has been introduced with control-2.3.51. (Thanks to Jim Rawlings for providing the test case) ** dlqe, lqe Added new functions for linear quadratic estimators. (Thanks to Megan Zagrobelny) ** Upon request of the Debian maintainers, the tex-files control.tex and functions.texi for generating control.pdf are included in the doc folder, next to control.pdf. Note that functions.texi is generated automatically by the scripts in the control/devel folder and the package generate_html. They are not included in the control package and can be found on the OctaveForge SVN server. ** Minor improvements in various help texts. =============================================================================== control-2.3.51 Release Date: 2012-06-03 Release Manager: Lukas Reichlin =============================================================================== ** filt, filtdata, tf -- Added function "filt" to specify disrete-time transfer functions in DSP format, i.e. z^-1. -- Added function "filtdata" to return any type of discrete-time LTI model in DSP format. -- tf models have a new property "inv". To display a discrete-time TF sys in z^-1, set sys.inv=true. In order to switch to z, set sys.inv=false. "filt" sets property "inv" to true (z^-1) by default, while "tf" uses false (z) as default value. ** ctranspose Conjugate transpose or pertransposition of LTI objects. Used by Octave for "sys'". For a transfer-function matrix G, G' denotes the conjugate of G given by G.'(-s) for a continuous-time system or G.'(1/z) for a discrete-time system. The frequency response of the pertransposition of G is the Hermitian (conjugate) transpose of G(jw), i.e. freqresp (G', w) = freqresp (G, w)'. WARNING: Do NOT use this for dual problems, use the transpose "sys.'" (note the dot) instead. ** test_control Add a few remarks to the help text regarding the severity of failing tests. ** Makefile fixed to work with non-standard linker options e.g on Apple. ** The conversion to state-space of multi-input transfer functions with common row denominators is now handled more efficiently. =============================================================================== control-2.3.50 Release Date: 2012-03-06 Release Manager: Lukas Reichlin =============================================================================== ** Added new functions for frequency-weighted model and controller order reduction: bstmodred btaconred btamodred cfconred hnamodred fwcfconred spamodred spaconred ** Anderson, Madievski -- Added two examples for controller reduction. The m-files are named after the authors of the corresponding papers. ** fitfrd -- Added function to fit frequency response data with a state-space model. ** set -- The set command doesn't need a return argument anymore in order to save the modified values. set (sys, "key", value) is now equivalent to sys = set (sys, "key", value). ** Require Octave version 3.6.0 or better. (The frequency response plotting commands have been simplified. They now use the fixed "axis tight" command. This is a first step towards multiple systems in one plot, e.g. bode (sys1, sys2, sys3). Furthermore, the code takes advantage of the new "arrayfun" function which became a faster oct-file instead of an m-file) ** Revised package installation and cleanup efforts under the hood. The new solution compiles the SLICOT library in a less barbaric way and creates only a single oct-file containing all the SLICOT routines. This also brings along faster compile times. (Special thanks to Hans Buchmann, Carlo De Falco and Michael Goffioul for their advice) ** doc/control.pdf -- Extended PDF manual. =============================================================================== control-2.2.5 Release Date: 2012-02-09 Release Manager: Lukas Reichlin =============================================================================== ** Improved Matlab compatibility for frequency response commands. It is now possible to specify a frequency range. Example: bode (sys, {wmin, wmax}) where wmin and wmax denote frequencies in rad/s. ** margin -- Fixed a variable name such that discrete-time models are plotted without an error. (Thanks to Renato Caldas) =============================================================================== control-2.2.4 Release Date: 2012-01-07 Release Manager: Lukas Reichlin =============================================================================== ** Compatibility with Octave 3.6.0. (The makefile must specify the libraries that mkoctfile needs to link. Thanks to Marco Atzeri and Carlo De Falco) ** ctrbf, obsvf -- Added new functions to compute controllable and observable block Hessenberg realizations based on SLICOT TB01UD. (Thanks to Benjamin Fernandez and Alexandre Felipe) =============================================================================== control-2.2.3 Release Date: 2011-12-07 Release Manager: Lukas Reichlin =============================================================================== ** Improved performance when computing the frequency response of transfer function models by orders of magnitude. (I realized that "polyval" can evaluate a polynomial at several values at once in a vectorized manner.) ** bode, bodemag, nichols, sigma -- Fixed a hang when plotting pairs of purely imaginary poles or zeros. The hang was caused by nonsensical (Inf, NaN) axis values. (Reported by Laurent Tissier) ** Use single instead of double quotes when displaying names of TF and FRD models. =============================================================================== control-2.2.2 Release Date: 2011-12-04 Release Manager: Lukas Reichlin =============================================================================== ** Improved error messages for place, ARE solvers and robust control commands. ** minreal, ss -- Fixed a crash for descriptor models. minreal for dss models as well as conversion from non-proper transfer functions to descriptor state-space models should work now as expected. ** ss -- Revised default tolerance for transfer function to state-space conversion by SLICOT TD04AD. ** Better performance when computing the frequency response of SISO transfer function models. ** Reorganized tests. Most tests have been moved from "ltimodels" to the files of the LTI methods being tested. All available tests can be executed by "test_control". ** The NEWS file is handled correctly when using Octave version 3.6. Type "news("control")" or "news control" to display the news (3.6 only). =============================================================================== control-2.2.1 Release Date: 2011-10-24 Release Manager: Lukas Reichlin =============================================================================== ** tf -- Fixed a nasty bug that prevented shortening of numerator and denominator polynomials consisting solely of zeros. -- MIMO support for descriptor state-space to transfer function conversion. Usage: tf_sys = tf (dss_sys) -- MIMO support for interconnections of non-proper transfer functions via internal conversion to state-space. ** ss -- Support conversion from non-proper transfer function to descriptor state- space. Usage: dss_sys = ss (tf_sys) ** c2d, d2c -- Support bilinear transformation of descriptor state-space models. ** inv -- Support the inversion of MIMO transfer functions. Inverses of 2x2 TFs are computed directly, larger models are computed internally in state-space. ** place -- Return the number of fixed, assigned and uncontrollable poles in a single "info" struct instead of three individual output arguments. ** rlocus -- Clarify usage statement in help string. -- Check whether system is SISO. ** MDSSystem -- Display bode plots of controllers instead of singular value plots of the closed loops. ** hsvd -- Added option "alpha" to specify the alpha-stability boundary for the eigenvalues of the state dynamics matrix A. ** isctrb, isobsv -- Return number of controllable/observable states as a second output argument. ** doc/control.pdf -- Added preface to PDF manual. =============================================================================== control-2.2.0 Release Date: 2011-09-26 Release Manager: Lukas Reichlin =============================================================================== ** ss -- Transfer function to state-space conversion uses now SLICOT TD04AD. Conversion of MIMO models is now supported. Usage: ss_sys = ss (tf_sys) ** tf -- Support for interconnections of MIMO transfer functions. This is done by an internal conversion to a minimal state-space representation. With the current tf2ss and ss2tf conversions, only proper transfer function are supported. This limitation does not exist for SISO transfer functions. -- Fixed a cellfun statement that caused problems on MinGW32 builds and possibly some others. (Reported by Bernhard Weller) ** pole, zero -- Computation of poles and zeros of MIMO transfer functions is now possible via conversion to state-space. Please note that the state-space realization of SLICOT TD04AD is a minimal one. Therefore certain poles and zeros might be missing. ** zpk, zpkdata -- Included wrappers that create transfer function models from zero-pole-gain data (zpk) and zero-pole-gain data from lti models (zpkdata). They are stop-gap measures for compatibility until ZPK models are implemented. ** tfdata -- "vector" option added. For SISO models, it returns numerator and denominator directly as column vectors instead of cells containing a single column vector. ** doc/control.pdf -- Revised PDF manual. =============================================================================== control-2.1.55 Release Date: 2011-09-07 Release Manager: Lukas Reichlin =============================================================================== ** c2d -- Support for "tustin" and "prewarp" method added. -- Transfer functions are now supported via the state-space methods. -- Improved Texinfo string. ** d2c -- Discrete to continuous-time conversion added. However, support is limited to the zero-order hold, tustin and pre-warping methods. ** Conversion from descriptor to regular state-space is now performed by SLICOT routine SB10JD. Better numerical results are to be expected over the previous naive inversion formula. This conversion is used internally for ssdata and some other functions. =============================================================================== control-2.1.54 Release Date: 2011-08-22 Release Manager: Lukas Reichlin =============================================================================== ** tf -- State-space to transfer function conversion uses now SLICOT TB04BD. Conversion of MIMO models is now supported. Usage: tf_sys = tf (ss_sys) -- Display an empty line between title and numerator for better readability. -- Display whether model is static, continuous- or discrete-time. ** A PDF manual is included for the first time. It is located inside the "doc" folder. It has been generated automatically from the Texinfo help strings and is not yet completely sorted out. =============================================================================== control-2.1.53 Release Date: 2011-08-08 Release Manager: Lukas Reichlin =============================================================================== ** ncfsyn -- Added support for McFarlane/Glover loop shaping design procedure. "ncfsyn" stands for Normalized Coprime Factor Synthesis. ** MDSSystem -- Added example script which demonstrates the usage of the robust control commands "mixsyn" and "ncfsyn". ** Texinfo help strings of several functions have been extended, although documentation still leaves a lot to be desired. =============================================================================== control-2.1.52 Release Date: 2011-07-27 Release Manager: Lukas Reichlin =============================================================================== ** hsvd -- Use scaling unless state-space model property "scaled" is set to true. ** norm -- Use scaling for computation of L-infinity norm unless state-space model property "scaled" is set to true. ** minreal -- Use scaling for state-space and descriptor state-space models unless property "scaled" is set to true. -- More accurate results are to be expected for descriptor state-space models by performing only those reduction phases where effective order reduction occurs. This is achieved by saving the system matrices before each phase and restoring them if no order reduction took place. ** zero -- Use scaling for state-space and descriptor state-space models unless property "scaled" is set to true. ** frdata -- The frequency response is now returned correctly as an array and not as a vector, unless the "vector" option is set and the system is single-input single-output. -- Added help text. =============================================================================== control-2.1.51 Release Date: 2011-07-21 Release Manager: Lukas Reichlin =============================================================================== ** frd -- Support for Frequency Response Data (frd) measurement "models". =============================================================================== control-2.1.50 Release Date: 2011-07-06 Release Manager: Lukas Reichlin =============================================================================== ** ss -- Support for property "scaled". By default, it is set to "false". ** prescale -- Scaling for state-space models (SLICOT TB01ID) and descriptor models (SLICOT TG01AD). ** freqresp -- Scale state-space models using @lti/prescale.m if property "scaled" is set to "false". Frequency response commands now perform automatic scaling unless model property "scaled" is set to "true". =============================================================================== control-2.0.2 Release Date: 2011-03-18 Release Manager: Lukas Reichlin =============================================================================== ** lsim -- Fixed a logical error that refused valid initial state vectors. It was due to a thinko introduced with the changes in control-2.0.1. (Thanks to Rob Frohne) =============================================================================== control-2.0.1 Release Date: 2011-03-06 Release Manager: Lukas Reichlin =============================================================================== ** lsim -- Support time vectors not starting at zero. (Thanks to Rob Frohne) -- Improved help text. ** zero -- The gain of descriptor state-space models is now computed correctly. (fingers crossed) =============================================================================== control-2.0.0 Release Date: 2011-02-08 Release Manager: Lukas Reichlin =============================================================================== ** First official release. =============================================================================== control-4.1.2/PaxHeaders/INDEX0000644000000000000000000000007415012430645013053 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.869132739 control-4.1.2/INDEX0000644000175000017500000000453515012430645014251 0ustar00lilgelilge00000000000000control >> Control Theory Examples MDSSystem optiPID Anderson Madievski VLFamp Linear Time Invariant Models dss filt @frd/frd @ss/ss @tf/tf zpk Model Data Access @lti/dssdata @lti/filtdata @lti/frdata @lti/get @lti/set @lti/ssdata @lti/tfdata @lti/zpkdata Model Conversions @lti/c2d @lti/d2c @lti/d2d @lti/prescale @lti/xperm @ss/ss2ss Model Interconnections append @lti/blkdiag @lti/connect @lti/feedback @lti/lft @lti/mconnect @lti/parallel @lti/series sumblk Model Characteristics ctrb ctrbf damp dsort esort @lti/dcgain gram hsvd @lti/isct isctrb isdetectable @lti/isdt @lti/isminimumphase isobsv @lti/issiso isstabilizable @lti/isstable @lti/norm obsv obsvf @lti/pole pzmap @lti/size @lti/zero Model Simplification @lti/minreal @lti/sminreal Time Domain Analysis covar gensig impulse imp_invar initial lsim ramp step Frequency Domain Analysis bode bodemag @lti/freqresp margin nichols nyquist sensitivity sgrid sigma zgrid Pole Placement acker place reg rlocus rlocusx Optimal Control augstate dlqe dlqr estim kalman lqe lqg lqgreg lqgtrack lqi lqr lqry Robust Control augw fitfrd h2syn hinfsyn mixsyn mktito ncfsyn Matrix Equation Solvers care dare dlyap dlyapchol lyap lyapchol Model Reduction bstmodred btamodred hnamodred spamodred Controller Reduction btaconred cfconred fwcfconred spaconred Experimental Data Handling @iddata/iddata @iddata/cat @iddata/detrend @iddata/diff @iddata/fft @iddata/filter @iddata/get @iddata/ifft @iddata/merge @iddata/nkshift @iddata/plot @iddata/resample @iddata/set @iddata/size System Identification arx moen4 moesp n4sid Overloaded LTI Operators @lti/ctranspose @lti/end @lti/horzcat @lti/inv @lti/minus @lti/mldivide @lti/mpower @lti/mrdivide @lti/mtimes @lti/plus @lti/repmat @lti/subsasgn @lti/subsref @lti/times @lti/transpose @lti/uminus @lti/uplus @lti/vertcat Overloaded IDDATA Operators @iddata/end @iddata/horzcat @iddata/subsasgn @iddata/subsref @iddata/vertcat Miscellaneous @ss/display db2mag doc_control mag2db options pid pidstd repsys strseq test_control thiran BMWengine Boeing707 WestlandLynx control-4.1.2/PaxHeaders/src0000644000000000000000000000013215012430710012757 xustar0030 mtime=1747595720.869132739 30 atime=1747595720.869132739 30 ctime=1747595720.869132739 control-4.1.2/src/0000755000175000017500000000000015012430710014230 5ustar00lilgelilge00000000000000control-4.1.2/src/PaxHeaders/sl_tg04bx.cc0000644000000000000000000000007315012430645015164 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_tg04bx.cc0000644000175000017500000000737715012430645016372 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Gain of descriptor state-space models. Based on SLICOT TB04BX.f. Author: Lukas Reichlin Created: March 2011 Version: 0.2 */ #include #include "common.h" #include #include extern "C" { int F77_FUNC (tg04bx, TG04BX) (F77_INT& IP, F77_INT& IZ, double* A, F77_INT& LDA, double* E, double* B, double* C, double* D, double* PR, double* PI, double* ZR, double* ZI, double& GAIN, F77_INT* IWORK); } // PKG_ADD: autoload ("__sl_tg04bx__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_tg04bx__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_tg04bx__ (@dots{})\n" "Wrapper for SLICOT function TG04BX.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 9) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix e = args(1).matrix_value (); Matrix b = args(2).matrix_value (); Matrix c = args(3).matrix_value (); Matrix d = args(4).matrix_value (); ColumnVector pr = args(5).column_vector_value (); ColumnVector pi = args(6).column_vector_value (); ColumnVector zr = args(7).column_vector_value (); ColumnVector zi = args(8).column_vector_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan () || e.any_element_is_inf_or_nan ()) error ("__sl_tg04bx__: inputs must not contain NaN or Inf\n"); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT ip = TO_F77_INT (pr.numel ()); // ip: number of finite poles F77_INT iz = TO_F77_INT (zr.numel ()); // iz: number of zeros // For ss, IP = n is always true. // However, dss models with poles at infinity // (filtered by pole.m) may have IP <= n // Take pr.length == pi.length == ip for granted, // and the same for iz, zr and zi. F77_INT lda = max (1, n); // arguments out double gain; // workspace OCTAVE_LOCAL_BUFFER (F77_INT, iwork, lda); F77_XFCN (tg04bx, TG04BX, (ip, iz, a.fortran_vec (), lda, e.fortran_vec (), b.fortran_vec (), c.fortran_vec (), d.fortran_vec (), pr.fortran_vec (), pi.fortran_vec (), zr.fortran_vec (), zi.fortran_vec (), gain, iwork)); if (f77_exception_encountered) error ("dss: zero: __sl_tg04bx__: exception in TG04BX"); // return values retval(0) = octave_value (gain); } return retval; } control-4.1.2/src/PaxHeaders/sl_ab09id.cc0000644000000000000000000000007415012430645015125 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_ab09id.cc0000644000175000017500000003256515012430645016327 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Model reduction based on Balance & Truncate (B&T) or Singular Perturbation Approximation (SPA) method. Uses SLICOT AB09ID by courtesy of NICONET e.V. Author: Lukas Reichlin Created: October 2011 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (ab09id, AB09ID) (char& DICO, char& JOBC, char& JOBO, char& JOB, char& WEIGHT, char& EQUIL, char& ORDSEL, F77_INT& N, F77_INT& M, F77_INT& P, F77_INT& NV, F77_INT& PV, F77_INT& NW, F77_INT& MW, F77_INT& NR, double& ALPHA, double& ALPHAC, double& ALPHAO, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* AV, F77_INT& LDAV, double* BV, F77_INT& LDBV, double* CV, F77_INT& LDCV, double* DV, F77_INT& LDDV, double* AW, F77_INT& LDAW, double* BW, F77_INT& LDBW, double* CW, F77_INT& LDCW, double* DW, F77_INT& LDDW, F77_INT& NS, double* HSV, double& TOL1, double& TOL2, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ab09id__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ab09id__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ab09id__ (@dots{})\n" "Wrapper for SLICOT function AB09ID.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 25) { print_usage (); } else { // arguments in char dico; char jobc; char jobo; char job; char weight; char equil; char ordsel; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_ab09id__: inputs must not contain NaN or Inf\n"); const F77_INT idico = args(4).int_value (); const F77_INT iequil = args(5).int_value (); F77_INT nr = args(6).int_value (); const F77_INT iordsel = args(7).int_value (); double alpha = args(8).double_value (); const F77_INT ijob = args(9).int_value (); Matrix av = args(10).matrix_value (); Matrix bv = args(11).matrix_value (); Matrix cv = args(12).matrix_value (); Matrix dv = args(13).matrix_value (); if (av.any_element_is_inf_or_nan () || bv.any_element_is_inf_or_nan () || cv.any_element_is_inf_or_nan () || dv.any_element_is_inf_or_nan ()) error ("__sl_ab09id__: inputs must not contain NaN or Inf\n"); Matrix aw = args(14).matrix_value (); Matrix bw = args(15).matrix_value (); Matrix cw = args(16).matrix_value (); Matrix dw = args(17).matrix_value (); if (aw.any_element_is_inf_or_nan () || bw.any_element_is_inf_or_nan () || cw.any_element_is_inf_or_nan () || dw.any_element_is_inf_or_nan ()) error ("__sl_ab09id__: inputs must not contain NaN or Inf\n"); const F77_INT iweight = args(18).int_value (); const F77_INT ijobc = args(19).int_value (); double alphac = args(20).double_value (); const F77_INT ijobo = args(21).int_value (); double alphao = args(22).double_value (); double tol1 = args(23).double_value (); double tol2 = args(24).double_value (); if (idico == 0) dico = 'C'; else dico = 'D'; if (iequil == 0) equil = 'S'; else equil = 'N'; if (iordsel == 0) ordsel = 'F'; else ordsel = 'A'; if (ijobc == 0) jobc = 'S'; else jobc = 'E'; if (ijobo == 0) jobo = 'S'; else jobo = 'E'; switch (ijob) { case 0: job = 'B'; break; case 1: job = 'F'; break; case 2: job = 'S'; break; case 3: job = 'P'; break; default: error ("__sl_ab09id__: argument job invalid"); } switch (iweight) { case 0: weight = 'N'; break; case 1: weight = 'L'; break; case 2: weight = 'R'; break; case 3: weight = 'B'; break; default: error ("__sl_ab09id__: argument weight invalid"); } F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT nv = TO_F77_INT (av.rows ()); F77_INT pv = TO_F77_INT (cv.rows ()); F77_INT nw = TO_F77_INT (aw.rows ()); F77_INT mw = TO_F77_INT (bw.columns ()); F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); F77_INT ldd = max (1, p); F77_INT ldav = max (1, nv); F77_INT ldbv = max (1, nv); F77_INT ldcv = max (1, pv); F77_INT lddv = max (1, pv); F77_INT ldaw = max (1, nw); F77_INT ldbw = max (1, nw); F77_INT ldcw = max (1, m); F77_INT lddw = max (1, m); // arguments out F77_INT ns; ColumnVector hsv (n); // workspace F77_INT liwork; F77_INT liwrk1; F77_INT liwrk2; F77_INT liwrk3; switch (job) { case 'B': liwrk1 = 0; break; case 'F': liwrk1 = n; break; default: liwrk1 = 2*n; } if (nv == 0 || weight == 'R' || weight == 'N') liwrk2 = 0; else liwrk2 = nv + max (p, pv); if (nw == 0 || weight == 'L' || weight == 'N') liwrk3 = 0; else liwrk3 = nw + max (m, mw); liwork = max (3, liwrk1, liwrk2, liwrk3); F77_INT ldwork; F77_INT lminl; F77_INT lrcf; F77_INT lminr; F77_INT llcf; F77_INT lleft; F77_INT lright; if (nw == 0 || weight == 'L' || weight == 'N') { lrcf = 0; lminr = 0; } else { lrcf = mw*(nw+mw) + max (nw*(nw+5), mw*(mw+2), 4*mw, 4*m); if (m == mw) lminr = nw + max (nw, 3*m); else lminr = 2*nw*max (m, mw) + nw + max (nw, 3*m, 3*mw); } llcf = pv*(nv+pv) + pv*nv + max (nv*(nv+5), pv*(pv+2), 4*pv, 4*p); if (nv == 0 || weight == 'R' || weight == 'N') lminl = 0; else if (p == pv) lminl = max (llcf, nv + max (nv, 3*p)); else lminl = max (p, pv) * (2*nv + max (p, pv)) + max (llcf, nv + max (nv, 3*p, 3*pv)); if (pv == 0 || weight == 'R' || weight == 'N') lleft = n*(p+5); else lleft = (n+nv) * (n + nv + max (n+nv, pv) + 5); if (mw == 0 || weight == 'L' || weight == 'N') lright = n*(m+5); else lright = (n+nw) * (n + nw + max (n+nw, mw) + 5); ldwork = max (lminl, lminr, lrcf, 2*n*n + max (1, lleft, lright, 2*n*n+5*n, n*max (m, p))); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT iwarn = 0; F77_INT info = 0; // SLICOT routine AB09ID F77_XFCN (ab09id, AB09ID, (dico, jobc, jobo, job, weight, equil, ordsel, n, m, p, nv, pv, nw, mw, nr, alpha, alphac, alphao, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, av.fortran_vec (), ldav, bv.fortran_vec (), ldbv, cv.fortran_vec (), ldcv, dv.fortran_vec (), lddv, aw.fortran_vec (), ldaw, bw.fortran_vec (), ldbw, cw.fortran_vec (), ldcw, dw.fortran_vec (), lddw, ns, hsv.fortran_vec (), tol1, tol2, iwork, dwork, ldwork, iwarn, info)); if (f77_exception_encountered) error ("modred: exception in SLICOT subroutine AB09ID"); static const char* err_msg[] = { "0: OK", "1: the computation of the ordered real Schur form of A " "failed", "2: the separation of the ALPHA-stable/unstable " "diagonal blocks failed because of very close " "eigenvalues", "3: the reduction to a real Schur form of the state " "matrix of a minimal realization of V failed", "4: a failure was detected during the ordering of the " "real Schur form of the state matrix of a minimal " "realization of V or in the iterative process to " "compute a left coprime factorization with inner " "denominator", "5: if DICO = 'C' and the matrix AV has an observable " "eigenvalue on the imaginary axis, or DICO = 'D' and " "AV has an observable eigenvalue on the unit circle", "6: the reduction to a real Schur form of the state " "matrix of a minimal realization of W failed", "7: a failure was detected during the ordering of the " "real Schur form of the state matrix of a minimal " "realization of W or in the iterative process to " "compute a right coprime factorization with inner " "denominator", "8: if DICO = 'C' and the matrix AW has a controllable " "eigenvalue on the imaginary axis, or DICO = 'D' and " "AW has a controllable eigenvalue on the unit circle", "9: the computation of eigenvalues failed", "10: the computation of Hankel singular values failed"}; static const char* warn_msg[] = { "0: OK", "1: with ORDSEL = 'F', the selected order NR is greater " "than NSMIN, the sum of the order of the " "ALPHA-unstable part and the order of a minimal " "realization of the ALPHA-stable part of the given " "system; in this case, the resulting NR is set equal " "to NSMIN.", "2: with ORDSEL = 'F', the selected order NR corresponds " "to repeated singular values for the ALPHA-stable " "part, which are neither all included nor all " "excluded from the reduced model; in this case, the " "resulting NR is automatically decreased to exclude " "all repeated singular values.", "3: with ORDSEL = 'F', the selected order NR is less " "than the order of the ALPHA-unstable part of the " "given system; in this case NR is set equal to the " "order of the ALPHA-unstable part.", /* 10+%d: %d */ "violations of the numerical stability condition " "occurred during the assignment of eigenvalues in the " "SLICOT Library routines SB08CD and/or SB08DD."}; error_msg ("modred", info, 10, err_msg); warning_msg ("modred", iwarn, 3, warn_msg, 10); // resize a.resize (nr, nr); b.resize (nr, m); c.resize (p, nr); hsv.resize (ns); // return values retval(0) = a; retval(1) = b; retval(2) = c; retval(3) = d; retval(4) = octave_value (nr); retval(5) = hsv; retval(6) = octave_value (ns); } return retval; } control-4.1.2/src/PaxHeaders/sl_ab13dd.cc0000644000000000000000000000007415012430645015113 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_ab13dd.cc0000644000175000017500000001245115012430645016305 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . L-infinity norm of a SS model. Uses SLICOT AB13DD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: November 2009 Version: 0.5 */ #include #include #include "common.h" extern "C" { int F77_FUNC (ab13dd, AB13DD) (char& DICO, char& JOBE, char& EQUIL, char& JOBD, F77_INT& N, F77_INT& M, F77_INT& P, double* FPEAK, double* A, F77_INT& LDA, double* E, F77_INT& LDE, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* GPEAK, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, Complex* CWORK, F77_INT& LCWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ab13dd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ab13dd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ab13dd__ (@dots{})\n" "Wrapper for SLICOT function AB13DD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 9) { print_usage (); } else { // arguments in char dico; char jobe; char equil; char jobd = 'D'; Matrix a = args(0).matrix_value (); Matrix e = args(1).matrix_value (); Matrix b = args(2).matrix_value (); Matrix c = args(3).matrix_value (); Matrix d = args(4).matrix_value (); F77_INT discrete = args(5).int_value (); F77_INT descriptor = args(6).int_value (); double tol = args(7).double_value (); const F77_INT scaled = args(8).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan () || e.any_element_is_inf_or_nan ()) error ("__sl_ab13dd__: inputs must not contain NaN or Inf\n"); if (discrete == 0) dico = 'C'; else dico = 'D'; if (descriptor == 0) jobe = 'I'; else jobe = 'G'; if (scaled == 0) equil = 'S'; else equil = 'N'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT lde = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); F77_INT ldd = max (1, p); ColumnVector fpeak (2); ColumnVector gpeak (2); fpeak(0) = 0; fpeak(1) = 1; // workspace F77_INT ldwork = max (1, 15*n*n + p*p + m*m + (6*n+3)*(p+m) + 4*p*m + n*m + 22*n + 7*min(p,m)); F77_INT lcwork = max (1, (n+m)*(n+p) + 2*min(p,m) + max(p,m)); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, n); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (Complex, cwork, lcwork); // error indicator F77_INT info; // SLICOT routine AB13DD F77_XFCN (ab13dd, AB13DD, (dico, jobe, equil, jobd, n, m, p, fpeak.fortran_vec (), a.fortran_vec (), lda, e.fortran_vec (), lde, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, gpeak.fortran_vec (), tol, iwork, dwork, ldwork, cwork, lcwork, info)); if (f77_exception_encountered) error ("lti: norm: __sl_ab13dd__: exception in SLICOT subroutine AB13DD"); static const char* err_msg[] = { "0: OK", "1: the matrix E is (numerically) singular", "2: the (periodic) QR (or QZ) algorithm for computing " "eigenvalues did not converge", "3: the SVD algorithm for computing singular values did " "not converge", "4: the tolerance is too small and the algorithm did " "not converge"}; error_msg ("__sl_ab13dd__", info, 4, err_msg); // return values retval(0) = fpeak; retval(1) = gpeak; } return retval; } control-4.1.2/src/PaxHeaders/m40000644000000000000000000000007415012430645013313 xustar0030 atime=1747595720.869132739 30 ctime=1747595720.869132739 control-4.1.2/src/m4/0000755000175000017500000000000015012430645014557 5ustar00lilgelilge00000000000000control-4.1.2/src/m4/PaxHeaders/octave-forge.m40000644000000000000000000000007415012430645016213 xustar0030 atime=1747595720.257110641 30 ctime=1747595720.869132739 control-4.1.2/src/m4/octave-forge.m40000644000175000017500000000575315012430645017414 0ustar00lilgelilge00000000000000# Copyright (C) 2017 Olaf Till # Modifications to print what is searching for by JohnD # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, see . # arguments of OF_OCTAVE_ALT_SYMS (see also description of # OF_OCTAVE_LIST_ALT_SYMS below): # # $1: symbol version 1 # $2: symbol version 2 # $3: test for symbol version 2 # $4: macro name to access alternative symbols # $5: include directives for symbol version 1 # $6: include directives for symbol version 2 # (a list of lists of args 1--6 is $1 of OF_OCTAVE_LIST_ALT_SYMS) # $7: name of generated include file with alternatives of Octave headers # (arg7 is $2 of OF_OCTAVE_LIST_ALT_SYMS) AC_DEFUN([OF_OCTAVE_ALT_SYMS], [ AC_MSG_CHECKING([$1 or $2]) AC_COMPILE_IFELSE( [AC_LANG_PROGRAM([[#include ] $6], [$3])], [AC_DEFINE($4, [[$2]], [macro for alternative Octave symbols]) AC_MSG_RESULT([$2]) echo '$6' >> $7], [AC_DEFINE($4, [[$1]], [macro for alternative Octave symbols]) AC_MSG_RESULT([$1]) echo '$5' >> $7] ) ]) # OF_OCTAVE_LIST_ALT_SYMS is called in the following way: # # OF_OCTAVE_LIST_ALT_SYMS([ # [dnl # [old_octave_symbol], # [new_octave_symbol], # [[compilation test] # [for new_octave_symbol]], # [NAME_OF_GENERATED_MACRO____WILL_EXPAND_TO_OLD_OR_NEW_SYMBOL], # [[include directives] # [except #include ] # [necessary to compile with old_octave_symbol]], # [[include directives] # [except #include ] # [nessary to compile with new_octave_symbol] # [and to compile the test]] # ], # # ... further such lists as the above # # ], # # [name-of-header-file-for-alternative-octave-iclude-directives.h]) # # # This file should be put into src/m4/, and the line # # AC_CONFIG_MACRO_DIRS([m4]) # # should be put into src/configure.ac. The package should use # autoheader to generate config.h.in (src/bootstrap should contain the # lines 'aclocal', 'autoconf', and 'autoheader -f'). Package code # should include config.h and use the generated macros to access the # alternative symbols of Octave. An example of a call to # OF_OCTAVE_LIST_ALT_SYMS in src/configure.ac is available together # with this file. AC_DEFUN([OF_OCTAVE_LIST_ALT_SYMS], [ echo '/* generated by configure */' > $2 m4_foreach([it], [$1], [m4_apply([OF_OCTAVE_ALT_SYMS], [it, $2])]) AH_BOTTOM([#include "$2"]) ]) control-4.1.2/src/PaxHeaders/sl_tg01jd.cc0000644000000000000000000000007315012430645015145 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_tg01jd.cc0000644000175000017500000001463015012430645016341 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Minimal realization of descriptor state-space models. Uses SLICOT TG01JD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: September 2010 Version: 0.5 */ #include #include "common.h" extern "C" { int F77_FUNC (tg01jd, TG01JD) (char& JOB, char& SYSTYP, char& EQUIL, F77_INT& N, F77_INT& M, F77_INT& P, double* A, F77_INT& LDA, double* E, F77_INT& LDE, double* B, F77_INT& LDB, double* C, F77_INT& LDC, F77_INT& NR, F77_INT* INFRED, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_tg01jd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_tg01jd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_tg01jd__ (@dots{})\n" "Wrapper for SLICOT function TG01JD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 8) { print_usage (); } else { // arguments in char job; char systyp; char equil; Matrix a = args(0).matrix_value (); Matrix e = args(1).matrix_value (); Matrix b = args(2).matrix_value (); Matrix c = args(3).matrix_value (); double tol = args(4).double_value (); const F77_INT scaled = args(5).int_value (); const F77_INT ijob = args(6).int_value (); const F77_INT isystyp = args(7).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || e.any_element_is_inf_or_nan ()) error ("__sl_tg01jd__: inputs must not contain NaN or Inf\n"); F77_INT c_factor = 1; if (scaled == 0) equil = 'S'; else equil = 'N'; switch (ijob) { case 0: job = 'I'; c_factor = 2; break; case 1: job = 'C'; break; case 2: job = 'O'; break; default: error ("__sl_tg01jd__: argument job invalid"); } switch (isystyp) { case 0: systyp = 'R'; c_factor = 2; break; case 1: systyp = 'S'; break; case 2: systyp = 'P'; break; default: error ("__sl_tg01jd__: argument systyp invalid"); } F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT lde = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc; if (n == 0) ldc = 1; else ldc = max (1, m, p); a.resize (lda, n); e.resize (lde, n); if (job == 'C') b.resize (ldb, m); else b.resize (ldb, max (m, p)); c.resize (ldc, n); // arguments out F77_INT nr; F77_INT infred[7]; // workspace F77_INT liwork = c_factor*n + max (m, p); F77_INT ldwork; // F77_INT ldwork = max (n, 2*m, 2*p); // F77_INT ldwork = n * (2*n + m + p) + max (n, 2*m, 2*p); if (equil == 'S') ldwork = max (8*n, 2*m, 2*p); else // if EQUIL = 'N' ldwork = max (n, 2*m, 2*p); // FIXME: larger ldwork should give better results, // but it breaks the test that Slicot provides. /* LDWORK INTEGER The length of the array DWORK. LDWORK >= MAX(8*N,2*M,2*P), if EQUIL = 'S'; LDWORK >= MAX(N,2*M,2*P), if EQUIL = 'N'. If LDWORK >= MAX(2*N*N+N*M+N*P)+MAX(N,2*M,2*P) then more accurate results are to be expected by performing only those reductions phases (see METHOD), where effective order reduction occurs. This is achieved by saving the system matrices before each phase and restoring them if no order reduction took place. */ OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT info = 0; // SLICOT routine TG01JD F77_XFCN (tg01jd, TG01JD, (job, systyp, equil, n, m, p, a.fortran_vec (), lda, e.fortran_vec (), lde, b.fortran_vec (), ldb, c.fortran_vec (), ldc, nr, infred, tol, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("dss: minreal: __sl_tg01jd__: exception in SLICOT subroutine TG01JD"); if (info != 0) error ("dss: minreal: __sl_tg01jd__: TG01JD returned info = %d", static_cast (info)); // resize a.resize (nr, nr); e.resize (nr, nr); b.resize (nr, m); c.resize (p, nr); // return values retval(0) = a; retval(1) = e; retval(2) = b; retval(3) = c; retval(4) = octave_value (nr); } return retval; } control-4.1.2/src/PaxHeaders/is_real_square_matrix.cc0000644000000000000000000000007415012430645017741 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/is_real_square_matrix.cc0000644000175000017500000000361215012430645021132 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Return true if all arguments are real-valued, square matrices and false otherwise. Author: Lukas Reichlin Created: September 2010 Version: 0.2 */ #include #include "config.h" // PKG_ADD: autoload ("is_real_square_matrix", "__control_helper_functions__.oct"); DEFUN_DLD (is_real_square_matrix, args, nargout, "-*- texinfo -*-\n" "@deftypefn {Loadable Function} {} is_real_square_matrix (@var{a}, @dots{})@*\n" "Return true if all arguments are real-valued, square matrices and false otherwise.@*\n" "@var{[]} is a valid square matrix.@*\n" "Avoid nasty stuff like @code{true = isreal (\"a\")}@*\n" "@seealso{is_real_matrix, is_real_vector, is_real_scalar}@*\n" "@end deftypefn") { octave_value retval = true; octave_idx_type nargin = args.length (); if (nargin == 0) { print_usage (); } else { for (octave_idx_type i = 0; i < nargin; i++) { if (args(i).ndims () != 2 || args(i).rows () != args(i).columns () || ! args(i).OV_ISNUMERIC () || ! args(i).OV_ISREAL ()) { retval = false; break; } } } return retval; } control-4.1.2/src/PaxHeaders/sl_ab01od.cc0000644000000000000000000000007415012430645015123 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_ab01od.cc0000644000175000017500000000777415012430645016331 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Staircase controllability form. Uses SLICOT AB01OD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: August 2010 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (ab01od, AB01OD) (char& STAGES, char& JOBU, char& JOBV, F77_INT& N, F77_INT& M, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* U, F77_INT& LDU, double* V, F77_INT& LDV, F77_INT& NCONT, F77_INT& INDCON, F77_INT* KSTAIR, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ab01od__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ab01od__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ab01od__ (@dots{})\n" "Wrapper for SLICOT function AB01OD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 3) { print_usage (); } else { // arguments in char stages = 'F'; char jobu = 'I'; char jobv = 'N'; // not referenced because stages = 'F' Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); double tol = args(2).double_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan ()) error ("__sl_ab01od__: inputs must not contain NaN or Inf\n"); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldu = max (1, n); F77_INT ldv = 1; // arguments out Matrix u (ldu, n); double* v = 0; // not referenced because stages = 'F' F77_INT ncont; F77_INT indcon; OCTAVE_LOCAL_BUFFER (F77_INT, kstair, n); // workspace F77_INT ldwork = max (1, n + max (n, 3*m)); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, m); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT info; // SLICOT routine AB01OD F77_XFCN (ab01od, AB01OD, (stages, jobu, jobv, n, m, a.fortran_vec (), lda, b.fortran_vec (), ldb, u.fortran_vec (), ldu, v, ldv, ncont, indcon, kstair, tol, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("__sl_ab01od__: exception in SLICOT subroutine AB01OD"); if (info != 0) error ("__sl_ab01od__: AB01OD returned info = %d", static_cast (info)); // resize a.resize (n, n); b.resize (n, m); u.resize (n, n); // return values retval(0) = a; retval(1) = b; retval(2) = u; retval(3) = octave_value (ncont); } return retval; } control-4.1.2/src/PaxHeaders/sl_tb04bd.cc0000644000000000000000000000007315012430645015133 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_tb04bd.cc0000644000175000017500000001142115012430645016322 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Transfer matrix of a given state-space representation (A,B,C,D), using the pole-zeros method. Uses SLICOT TB04BD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: October 2010 Version: 0.3 */ #include #include "common.h" extern "C" { int F77_FUNC (tb04bd, TB04BD) (char& JOBD, char& ORDER, char& EQUIL, F77_INT& N, F77_INT& M, F77_INT& P, F77_INT& MD, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, F77_INT* IGN, F77_INT& LDIGN, F77_INT* IGD, F77_INT& LDIGD, double* GN, double* GD, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_tb04bd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_tb04bd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_tb04bd__ (@dots{})\n" "Wrapper for SLICOT function TB04BD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 5) { print_usage (); } else { // arguments in // char jobd = 'D'; char order = 'D'; char equil; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); const F77_INT scaled = args(4).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_tb04bd__: inputs must not contain NaN or Inf\n"); if (scaled == 0) equil = 'S'; else equil = 'N'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT md = n + 1; F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); F77_INT ldd = max (1, p); // arguments out F77_INT ldign = max (1, p); F77_INT ldigd = max (1, p); F77_INT lg = p * m * md; OCTAVE_LOCAL_BUFFER (F77_INT, ign, ldign*m); OCTAVE_LOCAL_BUFFER (F77_INT, igd, ldigd*m); RowVector gn (lg); RowVector gd (lg); // tolerance double tol = 0; // use default value // workspace F77_INT ldwork = max (1, n*(n + p) + max (n + max (n, p), n*(2*n + 5))); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, n); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT info; // SLICOT routine TB04BD F77_XFCN (tb04bd, TB04BD, (jobd, order, equil, n, m, p, md, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, ign, ldign, igd, ldigd, gn.fortran_vec (), gd.fortran_vec (), tol, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("ss2tf: __sl_tb04bd__: exception in SLICOT subroutine TB04BD"); if (info != 0) error ("ss2tf: __sl_tb04bd__: TB04BD returned info = %d", static_cast (info)); // return values Cell num(p, m); Cell den(p, m); F77_INT ik, istr; for (ik = 0; ik < p*m; ik++) { istr = ik*md; num.xelem (ik) = gn.extract_n (istr, ign[ik]+1); den.xelem (ik) = gd.extract_n (istr, igd[ik]+1); } retval(0) = num; retval(1) = den; } return retval; } control-4.1.2/src/PaxHeaders/bootstrap0000644000000000000000000000007415012430645015010 xustar0030 atime=1747595719.997101252 30 ctime=1747595720.869132739 control-4.1.2/src/bootstrap0000755000175000017500000000005515012430645016202 0ustar00lilgelilge00000000000000#! /bin/sh aclocal autoconf autoheader -f control-4.1.2/src/PaxHeaders/sl_ab08nd.cc0000644000000000000000000000007415012430645015131 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_ab08nd.cc0000644000175000017500000001753715012430645016335 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Invariant zeros of state-space models. Uses SLICOT AB08ND by courtesy of NICONET e.V. Author: Lukas Reichlin Created: November 2009 Version: 0.8 */ #include #include "common.h" #include #include extern "C" { int F77_FUNC (ab08nd, AB08ND) (char& EQUIL, F77_INT& N, F77_INT& M, F77_INT& P, const double* A, F77_INT& LDA, const double* B, F77_INT& LDB, const double* C, F77_INT& LDC, const double* D, F77_INT& LDD, F77_INT& NU, F77_INT& RANK, F77_INT& DINFZ, F77_INT& NKROR, F77_INT& NKROL, F77_INT* INFZ, F77_INT* KRONR, F77_INT* KRONL, double* AF, F77_INT& LDAF, double* BF, F77_INT& LDBF, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); int F77_FUNC (dggev, DGGEV) (char& JOBVL, char& JOBVR, F77_INT& N, double* AF, F77_INT& LDAF, double* BF, F77_INT& LDBF, double* ALPHAR, double* ALPHAI, double* BETA, double* VL, F77_INT& LDVL, double* VR, F77_INT& LDVR, double* WORK, F77_INT& LWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ab08nd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ab08nd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ab08nd__ (@dots{})\n" "Wrapper for SLICOT function AB08ND.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 5) { print_usage (); } else { // arguments in char equil; const Matrix a = args(0).matrix_value (); const Matrix b = args(1).matrix_value (); const Matrix c = args(2).matrix_value (); const Matrix d = args(3).matrix_value (); const F77_INT scaled = args(4).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_ab08nd__: inputs must not contain NaN or Inf\n"); if (scaled == 0) equil = 'S'; else equil = 'N'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, TO_F77_INT (a.rows ())); F77_INT ldb = max (1, TO_F77_INT (b.rows ())); F77_INT ldc = max (1, TO_F77_INT (c.rows ())); F77_INT ldd = max (1, TO_F77_INT (d.rows ())); // arguments out F77_INT nu; F77_INT rank; F77_INT dinfz; F77_INT nkror; F77_INT nkrol; F77_INT ldaf = max (1, n + m); F77_INT ldbf = max (1, n + p); OCTAVE_LOCAL_BUFFER (F77_INT, infz, n); OCTAVE_LOCAL_BUFFER (F77_INT, kronr, 1 + max (n, m)); OCTAVE_LOCAL_BUFFER (F77_INT, kronl, 1 + max (n, p)); OCTAVE_LOCAL_BUFFER (double, af, ldaf * (n + min (p, m))); OCTAVE_LOCAL_BUFFER (double, bf, ldbf * (n + m)); // workspace F77_INT s = max (m, p); F77_INT ldwork = max (1, max (s, n) + max (3*s-1, n+s)); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, s); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT info; // tolerance double tol = 0; // AB08ND uses DLAMCH for default tolerance // SLICOT routine AB08ND F77_XFCN (ab08nd, AB08ND, (equil, n, m, p, a.data (), lda, b.data (), ldb, c.data (), ldc, d.data (), ldd, nu, rank, dinfz, nkror, nkrol, infz, kronr, kronl, af, ldaf, bf, ldbf, tol, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("ss: zero: __sl_ab08nd__: exception in SLICOT subroutine AB08ND"); if (info != 0) error ("ss: zero: __sl_ab08nd__: AB08ND returned info = %d", static_cast (info)); // DGGEV Part char jobvl = 'N'; char jobvr = 'N'; double* vl = 0; // not referenced because jobvl = 'N' F77_INT ldvl = 1; double* vr = 0; // not referenced because jobvr = 'N' F77_INT ldvr = 1; F77_INT lwork = max (1, 8*nu); OCTAVE_LOCAL_BUFFER (double, work, lwork); ColumnVector alphar (nu); ColumnVector alphai (nu); ColumnVector beta (nu); F77_INT info2; F77_XFCN (dggev, DGGEV, (jobvl, jobvr, nu, af, ldaf, bf, ldbf, alphar.fortran_vec (), alphai.fortran_vec (), beta.fortran_vec (), vl, ldvl, vr, ldvr, work, lwork, info2)); if (f77_exception_encountered) error ("ss: zero: __sl_ab08nd__: exception in LAPACK subroutine DGGEV"); if (info2 != 0) error ("ss: zero: __sl_ab08nd__: DGGEV returned info = %d", static_cast (info2)); // calculate gain octave_value gain = Matrix (0, 0);; if (m == 1 && p == 1) { if (nu < n) #if OCTAVE_MAJOR_VERSION > 6 gain = c * octave::xpow (a, double (n-1-nu)).matrix_value() * b; #else gain = c * xpow (a, double (n-1-nu)).matrix_value() * b; #endif else gain = d; } // assemble complex vector - adapted from DEFUN complex in data.cc ColumnVector zeror (nu); ColumnVector zeroi (nu); zeror = quotient (alphar, beta); zeroi = quotient (alphai, beta); ComplexColumnVector zero (nu, Complex ()); for (F77_INT i = 0; i < nu; i++) zero.xelem (i) = Complex (zeror(i), zeroi(i)); // prepare additional outputs for info struct RowVector infzr (dinfz); RowVector kronrr (nkror); RowVector kronlr (nkrol); for (F77_INT i = 0; i < dinfz; i++) infzr.xelem (i) = infz[i]; for (F77_INT i = 0; i < nkror; i++) kronrr.xelem (i) = kronr[i]; for (F77_INT i = 0; i < nkrol; i++) kronlr.xelem (i) = kronl[i]; // return values retval(0) = zero; retval(1) = gain; retval(2) = octave_value (rank); retval(3) = infzr; retval(4) = kronrr; retval(5) = kronlr; } return retval; } control-4.1.2/src/PaxHeaders/sl_tb01pd.cc0000644000000000000000000000007315012430645015146 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_tb01pd.cc0000644000175000017500000001010015012430645016326 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Minimal realization of state-space models. Uses SLICOT TB01PD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: September 2010 Version: 0.5 */ #include #include "common.h" extern "C" { int F77_FUNC (tb01pd, TB01PD) (char& JOB, char& EQUIL, F77_INT& N, F77_INT& M, F77_INT& P, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, F77_INT& NR, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_tb01pd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_tb01pd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_tb01pd__ (@dots{})\n" "Wrapper for SLICOT function TB01PD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 5) { print_usage (); } else { // arguments in char job = 'M'; char equil; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); double tol = args(3).double_value (); const F77_INT scaled = args(4).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan ()) error ("__sl_tb01pd__: inputs must not contain NaN or Inf\n"); if (scaled == 0) equil = 'S'; else equil = 'N'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc; if (n == 0) ldc = 1; else ldc = max (1, m, p); b.resize (ldb, max (m, p)); c.resize (ldc, n); // arguments out F77_INT nr = 0; // workspace F77_INT liwork = n + max (m, p); F77_INT ldwork = max (1, n + max (n, 3*m, 3*p)); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT info = 0; // SLICOT routine TB01PD F77_XFCN (tb01pd, TB01PD, (job, equil, n, m, p, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, nr, tol, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("ss: minreal: __sl_tb01pd__: exception in SLICOT subroutine TB01PD"); if (info != 0) error ("ss: minreal: __sl_tb01pd__: TB01PD returned info = %d", static_cast (info)); // resize a.resize (nr, nr); b.resize (nr, m); c.resize (p, nr); // return values retval(0) = a; retval(1) = b; retval(2) = c; retval(3) = octave_value (nr); } return retval; } control-4.1.2/src/PaxHeaders/is_zp_vector.cc0000644000000000000000000000007415012430645016065 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/is_zp_vector.cc0000644000175000017500000000366315012430645017264 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Return true if all arguments zero-pole vectors and false otherwise. Author: Lukas Reichlin Created: October 2015 Version: 0.1 */ #include #include "config.h" // PKG_ADD: autoload ("is_zp_vector", "__control_helper_functions__.oct"); DEFUN_DLD (is_zp_vector, args, nargout, "-*- texinfo -*-\n" "@deftypefn {Loadable Function} {} is_zp_vector (@var{a}, @dots{})@*\n" "Return true if all arguments are zero-pole vectors and false otherwise.@*\n" "@var{[]} is a valid zero-pole vector.@*\n" "Avoid nasty stuff like @code{true = isreal (\"a\")}@*\n" "@seealso{is_real_matrix, is_real_square_matrix, is_real_vector, is_real_scalar}@*\n" "@end deftypefn") { octave_value retval = true; octave_idx_type nargin = args.length (); if (nargin == 0) { print_usage (); } else { for (octave_idx_type i = 0; i < nargin; i++) { if (args(i).ndims () != 2 || (args(i).rows () > 1 && args(i).columns () > 1) || ! args(i).OV_ISNUMERIC () || ! (args(i).OV_ISCOMPLEX () || args(i).OV_ISREAL())) { retval = false; break; } } } return retval; } control-4.1.2/src/PaxHeaders/sl_sb10id.cc0000644000000000000000000000007315012430645015136 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sb10id.cc0000644000175000017500000001226115012430645016330 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Positive feedback controller for a continuous-time system. Uses SLICOT SB10ID by courtesy of NICONET e.V. Author: Lukas Reichlin Created: July 2011 Version: 0.4 */ #include #include "common.h" extern "C" { int F77_FUNC (sb10id, SB10ID) (F77_INT& N, F77_INT& M, F77_INT& NP, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double& FACTOR, F77_INT& NK, double* AK, F77_INT& LDAK, double* BK, F77_INT& LDBK, double* CK, F77_INT& LDCK, double* DK, F77_INT& LDDK, double* RCOND, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb10id__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb10id__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb10id__ (@dots{})\n" "Wrapper for SLICOT function SB10ID.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 5) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_sb10id__: inputs must not contain NaN or Inf\n"); double factor = args(4).double_value (); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT np = TO_F77_INT (c.rows ()); // np: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, np); F77_INT ldd = max (1, np); F77_INT ldak = max (1, n); F77_INT ldbk = max (1, n); F77_INT ldck = max (1, m); F77_INT lddk = max (1, m); // arguments out F77_INT nk; Matrix ak (ldak, n); Matrix bk (ldbk, np); Matrix ck (ldck, n); Matrix dk (lddk, np); ColumnVector rcond (2); // workspace F77_INT liwork = max (2*n, n*n, m, np); F77_INT ldwork = 10*n*n + m*m + np*np + 2*m*n + 2*n*np + 4*n + 5 + max (1, 4*n*n + 8*n); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, 2*n); // error indicator F77_INT info; // SLICOT routine SB10ID F77_XFCN (sb10id, SB10ID, (n, m, np, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, factor, nk, ak.fortran_vec (), ldak, bk.fortran_vec (), ldbk, ck.fortran_vec (), ldck, dk.fortran_vec (), lddk, rcond.fortran_vec (), iwork, dwork, ldwork, bwork, info)); if (f77_exception_encountered) error ("ncfsyn: __sl_sb10id__: exception in SLICOT subroutine SB10ID"); static const char* err_msg[] = { "0: OK", "1: the X-Riccati equation is not solved successfully", "2: the Z-Riccati equation is not solved successfully", "3: the iteration to compute eigenvalues or singular " "values failed to converge", "4: the matrix Ip - D*Dk is singular", "5: the matrix Im - Dk*D is singular", "6: the closed-loop system is unstable"}; error_msg ("ncfsyn", info, 6, err_msg); // resizing ak.resize (nk, nk); bk.resize (nk, np); ck.resize (m, nk); dk.resize (m, np); // return values retval(0) = ak; retval(1) = bk; retval(2) = ck; retval(3) = dk; retval(4) = rcond; } return retval; } control-4.1.2/src/PaxHeaders/sl_sb04md.cc0000644000000000000000000000007415012430645015146 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sb04md.cc0000644000175000017500000000644015012430645016341 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Solution of continuous-time Sylvester equations. Uses SLICOT SB04MD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: January 2010 Version: 0.3 */ #include #include "common.h" extern "C" { int F77_FUNC (sb04md, SB04MD) (F77_INT& N, F77_INT& M, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* Z, F77_INT& LDZ, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb04md__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb04md__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb04md__ (@dots{})\n" "Wrapper for SLICOT function SB04MD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 3) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan ()) error ("__sl_sb04md__: inputs must not contain NaN or Inf\n"); F77_INT n = TO_F77_INT (a.rows ()); F77_INT m = TO_F77_INT (b.rows ()); F77_INT lda = max (1, n); F77_INT ldb = max (1, m); F77_INT ldc = max (1, n); F77_INT ldz = max (1, m); // arguments out Matrix z (ldz, m); // workspace F77_INT ldwork = max (1, 2*n*n + 8*n, 5*m, n + m); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, 4*n); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT info; // SLICOT routine SB04MD F77_XFCN (sb04md, SB04MD, (n, m, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, z.fortran_vec (), ldz, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("lyap: __sl_sb04md__: exception in SLICOT subroutine SB04MD"); if (info != 0) error ("lyap: __sl_sb04md__: SB04MD returned info = %d", static_cast (info)); // return values retval(0) = c; } return retval; } control-4.1.2/src/PaxHeaders/sl_sb10ad.cc0000644000000000000000000000007415012430645015127 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sb10ad.cc0000644000175000017500000002201615012430645016317 0ustar00lilgelilge00000000000000/* Copyright (C) 2014-2015 Thomas Vasileiou 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 LTI Syncope. If not, see . H-infinity optimal controller using modified Glover's and Doyle's formulas (continuous-time). Uses SLICOT SB10AD by courtesy of NICONET e.V. Author: Thomas Vasileiou Created: January 2014 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (sb10ad, SB10AD) (F77_INT& JOB, F77_INT& N, F77_INT& M, F77_INT& NP, F77_INT& NCON, F77_INT& NMEAS, double& GAMMA, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* AK, F77_INT& LDAK, double* BK, F77_INT& LDBK, double* CK, F77_INT& LDCK, double* DK, F77_INT& LDDK, double* AC, F77_INT& LDAC, double* BC, F77_INT& LDBC, double* CC, F77_INT& LDCC, double* DC, F77_INT& LDDC, double* RCOND, double& GTOL, double& ACTOL, F77_INT* IWORK, F77_INT& LIWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& LBWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb10ad__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb10ad__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb10ad__ (@dots{})\n" "Wrapper for SLICOT function SB10AD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 9) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_sb10ad__: inputs must not contain NaN or Inf\n"); F77_INT ncon = args(4).int_value (); F77_INT nmeas = args(5).int_value (); double gamma = args(6).double_value (); double gtol = args(7).double_value (); double actol = args(8).double_value (); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT np = TO_F77_INT (c.rows ()); // np: number of outputs F77_INT lda = max (1, TO_F77_INT (a.rows ())); F77_INT ldb = max (1, TO_F77_INT (b.rows ())); F77_INT ldc = max (1, TO_F77_INT (c.rows ())); F77_INT ldd = max (1, TO_F77_INT (d.rows ())); F77_INT ldak = max (1, n); F77_INT ldbk = max (1, n); F77_INT ldck = max (1, ncon); F77_INT lddk = max (1, ncon); F77_INT ldac = max (1, 2*n); F77_INT ldbc = max (1, 2*n); F77_INT ldcc = max (1, np-nmeas); F77_INT lddc = max (1, np-nmeas); F77_INT job = 1; // arguments out Matrix ak (ldak, n); Matrix bk (ldbk, nmeas); Matrix ck (ldck, n); Matrix dk (lddk, nmeas); Matrix ac (ldac, 2*n); Matrix bc (ldbc, m-ncon); Matrix cc (ldcc, 2*n); Matrix dc (lddc, m-ncon); ColumnVector rcond (4); // workspace F77_INT m2 = ncon; F77_INT m1 = m - m2; F77_INT np2 = nmeas; F77_INT np1 = np - np2; F77_INT nd1 = np1 - m2; F77_INT nd2 = m1 - np2; F77_INT liwork = max (2*max (n, m-ncon, np-nmeas, ncon, nmeas), n*n); F77_INT lw1 = n*m + np*n + np*m + m2*m2 + np2*np2; F77_INT lw2 = max ((n + np1 + 1)*(n + m2) + max (3*(n + m2) + n + np1, 5*(n + m2)), (n + np2)*(n + m1 + 1) + max (3*(n + np2) + n + m1, 5*(n + np2)), m2 + np1*np1 + max (np1*max (n, m1), 3*m2 + np1, 5*m2), np2 + m1*m1 + max (max (n, np1)*m1, 3*np2 + m1, 5*np2)); F77_INT lw3 = max (nd1*m1 + max (4*min (nd1, m1) + max (nd1,m1), 6*min (nd1, m1)), np1*nd2 + max (4*min (np1, nd2) + max (np1, nd2), 6*min (np1, nd2))); F77_INT lw4 = 2*m*m + np*np + 2*m*n + m*np + 2*n*np; F77_INT lw5 = 2*n*n + m*n + n*np; F77_INT lw6 = max (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))); F77_INT lw7 = 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))))); F77_INT ldwork = lw1 + max (1, lw2, lw3, lw4, lw5 + max (lw6,lw7)); F77_INT lbwork = 2*n; OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, lbwork); // error indicator F77_INT info; // SLICOT routine SB10AD F77_XFCN (sb10ad, SB10AD, (job, n, m, np, ncon, nmeas, gamma, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, ak.fortran_vec (), ldak, bk.fortran_vec (), ldbk, ck.fortran_vec (), ldck, dk.fortran_vec (), lddk, ac.fortran_vec (), ldac, bc.fortran_vec (), ldbc, cc.fortran_vec (), ldcc, dc.fortran_vec (), lddc, rcond.fortran_vec (), gtol, actol, iwork, liwork, dwork, ldwork, bwork, lbwork, info)); if (f77_exception_encountered) error ("hinfsyn: __sl_sb10ad__: exception in SLICOT subroutine SB10AD"); static const char* err_msg[] = { "0: successful exit", "1: the matrix [A-j*omega*I, B2; C1, D12] had " "not full column rank in respect to the tolerance EPS", "2: the matrix [A-j*omega*I, B1; C2, D21] " "had not full row rank in respect to the tolerance EPS", "3: the matrix D12 had not full column rank in " "respect to the tolerance SQRT(EPS)", "4: the matrix D21 had not full row rank in respect " "to the tolerance SQRT(EPS)", "5: the singular value decomposition (SVD) algorithm " "did not converge (when computing the SVD of one of the matrices " "[A, B2; C1, D12], [A, B1; C2, D21], D12 or D21)", "6: the controller is not admissible (too small value " "of gamma)", "7: the X-Riccati equation was not solved " "successfully (the controller is not admissible or " "there are numerical difficulties)", "8: the Y-Riccati equation was not solved " "successfully (the controller is not admissible or " "there are numerical difficulties)", "9: the determinant of Im2 + Tu*D11HAT*Ty*D22 is " "zero [3]", "10: there was numerical problems when estimating" "the singular values of D1111, D1112, D1111', D1121'", "11: the matrices Inp2 - D22*DK or Im2 - DK*D22" "are singular to working precision", "12: a stabilizing controller cannot be found"}; error_msg ("hinfsyn", info, 12, err_msg); // return values retval(0) = ak; retval(1) = bk; retval(2) = ck; retval(3) = dk; retval(4) = ac; retval(5) = bc; retval(6) = cc; retval(7) = dc; retval(8) = gamma; retval(9) = rcond; } return retval; } control-4.1.2/src/PaxHeaders/sl_ib01ad.cc0000644000000000000000000000007415012430645015115 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_ib01ad.cc0000644000175000017500000003206615012430645016313 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . SLICOT system identification Uses SLICOT IB01AD, IB01BD and IB01CD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: March 2012 Version: 0.2 */ #include #include #include "common.h" extern "C" { int F77_FUNC (ib01ad, IB01AD) (char& METH, char& ALG, char& JOBD, char& BATCH, char& CONCT, char& CTRL, F77_INT& NOBR, F77_INT& M, F77_INT& L, F77_INT& NSMP, double* U, F77_INT& LDU, double* Y, F77_INT& LDY, F77_INT& N, double* R, F77_INT& LDR, double* SV, double& RCOND, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ib01ad__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ib01ad__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ib01ad__ (@dots{})\n" "Wrapper for SLICOT function IB01AD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 10) { print_usage (); } else { //////////////////////////////////////////////////////////////////////////////////// // SLICOT IB01AD - preprocess the input-output data // //////////////////////////////////////////////////////////////////////////////////// // arguments in char meth_a; char alg; char jobd; char batch; char conct; char ctrl = 'N'; const Cell y_cell = args(0).cell_value (); const Cell u_cell = args(1).cell_value (); F77_INT nobr = args(2).int_value (); // F77_INT nuser = args(3).int_value (); const F77_INT imeth = args(4).int_value (); const F77_INT ialg = args(5).int_value (); const F77_INT iconct = args(6).int_value (); // const F77_INT ictrl = args(7).int_value (); // ignored double rcond = args(8).double_value (); double tol_a = args(9).double_value (); // double tol_b = rcond; // doublet ol_c = rcond; switch (imeth) { case 0: meth_a = 'M'; break; case 1: meth_a = 'N'; break; case 2: meth_a = 'N'; // no typo here break; default: error ("__sl_ib01ad__: argument 'meth' invalid"); } switch (ialg) { case 0: alg = 'C'; break; case 1: alg = 'F'; break; case 2: alg = 'Q'; break; default: error ("__sl_ib01ad__: argument 'alg' invalid"); } if (meth_a == 'M') jobd = 'M'; else // meth_a == 'N' jobd = 'N'; // IB01AD.f says: This parameter is not relevant for METH = 'N' if (iconct == 0) conct = 'C'; else conct = 'N'; /* if (ictrl == 0) ctrl = 'C'; else ctrl = 'N'; */ // m and l are equal for all experiments, checked by iddata class F77_INT n_exp = TO_F77_INT (y_cell.numel ()); // number of experiments F77_INT m = TO_F77_INT (u_cell.elem(0).columns ()); // m: number of inputs F77_INT l = TO_F77_INT (y_cell.elem(0).columns ()); // l: number of outputs // arguments out F77_INT n; F77_INT ldr; if (meth_a == 'M' && jobd == 'M') ldr = max (2*(m+l)*nobr, 3*m*nobr); else if (meth_a == 'N' || (meth_a == 'M' && jobd == 'N')) ldr = 2*(m+l)*nobr; else error ("__sl_ib01ad__: could not handle 'ldr' case"); Matrix r (ldr, 2*(m+l)*nobr); ColumnVector sv (l*nobr); // repeat for every experiment in the dataset for (F77_INT i = 0; i < n_exp; i++) { if (n_exp == 1) batch = 'O'; // one block only else if (i == 0) batch = 'F'; // first block else if (i == n_exp-1) batch = 'L'; // last block else batch = 'I'; // intermediate block Matrix y = y_cell.elem(i).matrix_value (); Matrix u = u_cell.elem(i).matrix_value (); if (y.any_element_is_inf_or_nan () || u.any_element_is_inf_or_nan ()) error ("__sl_ib01ad__: inputs must not contain NaN or Inf\n"); // y.rows == u.rows is checked by iddata class // F77_INT m = TO_F77_INT (u.columns ()); // m: number of inputs // F77_INT l = TO_F77_INT (y.columns ()); // l: number of outputs F77_INT nsmp = TO_F77_INT (y.rows ()); // nsmp: number of samples in the current experiment // minimal nsmp size checked by __slicot_identification__.m if (batch == 'O') { if (nsmp < 2*(m+l+1)*nobr - 1) error ("__sl_ident__: require NSMP >= 2*(M+L+1)*NOBR - 1"); } else { if (nsmp < 2*nobr) error ("__sl_ident__: require NSMP >= 2*NOBR"); } F77_INT ldu; if (m == 0) ldu = 1; else // m > 0 ldu = nsmp; F77_INT ldy = nsmp; // workspace F77_INT liwork_a; if (meth_a == 'N') // if METH = 'N' liwork_a = (m+l)*nobr; else if (alg == 'F') // if METH = 'M' and ALG = 'F' liwork_a = m+l; else // if METH = 'M' and ALG = 'C' or 'Q' liwork_a = 0; // TODO: Handle 'k' for DWORK F77_INT ldwork_a; F77_INT ns = nsmp - 2*nobr + 1; if (alg == 'C') { if (batch == 'F' || batch == 'I') { if (conct == 'C') ldwork_a = (4*nobr-2)*(m+l); else // (conct == 'N') ldwork_a = 1; } else if (meth_a == 'M') // && (batch == 'L' || batch == 'O') { if (conct == 'C' && batch == 'L') ldwork_a = max ((4*nobr-2)*(m+l), 5*l*nobr); else if (jobd == 'M') ldwork_a = max ((2*m-1)*nobr, (m+l)*nobr, 5*l*nobr); else // (jobd == 'N') ldwork_a = 5*l*nobr; } else // meth_a == 'N' && (batch == 'L' || batch == 'O') { ldwork_a = 5*(m+l)*nobr + 1; } } else if (alg == 'F') { if (batch != 'O' && conct == 'C') ldwork_a = (m+l)*2*nobr*(m+l+3); else if (batch == 'F' || batch == 'I') // && conct == 'N' ldwork_a = (m+l)*2*nobr*(m+l+1); else // (batch == 'L' || '0' && conct == 'N') ldwork_a = (m+l)*4*nobr*(m+l+1)+(m+l)*2*nobr; } else // (alg == 'Q') { // F77_INT ns = nsmp - 2*nobr + 1; if (ldr >= ns && batch == 'F') { ldwork_a = 4*(m+l)*nobr; } else if (ldr >= ns && batch == 'O') { if (meth_a == 'M') ldwork_a = max (4*(m+l)*nobr, 5*l*nobr); else // (meth == 'N') ldwork_a = 5*(m+l)*nobr + 1; } else if (conct == 'C' && (batch == 'I' || batch == 'L')) { ldwork_a = 4*(nobr+1)*(m+l)*nobr; } else // if ALG = 'Q', (BATCH = 'F' or 'O', and LDR < NS), or (BATCH = 'I' or 'L' and CONCT = 'N') { ldwork_a = 6*(m+l)*nobr; } } /* IB01AD.f Lines 438-445 C FURTHER COMMENTS C C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the C calculations could be rather inefficient if only minimal workspace C (see argument LDWORK) is provided. It is advisable to provide as C much workspace as possible. Almost optimal efficiency can be C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the C cache size is large enough to accommodate R, U, Y, and DWORK. */ ldwork_a = max (ldwork_a, (ns+2)*(2*(m+l)*nobr)); /* IB01AD.f Lines 291-195: c the workspace used for alg = 'q' is c ldrwrk*2*(m+l)*nobr + 4*(m+l)*nobr, c where ldrwrk = ldwork/(2*(m+l)*nobr) - 2; recommended c value ldrwrk = ns, assuming a large enough cache size. c for good performance, ldwork should be larger. somehow ldrwrk and ldwork must have been mixed up here */ OCTAVE_LOCAL_BUFFER (F77_INT, iwork_a, liwork_a); OCTAVE_LOCAL_BUFFER (double, dwork_a, ldwork_a); // error indicators F77_INT iwarn_a = 0; F77_INT info_a = 0; // SLICOT routine IB01AD F77_XFCN (ib01ad, IB01AD, (meth_a, alg, jobd, batch, conct, ctrl, nobr, m, l, nsmp, u.fortran_vec (), ldu, y.fortran_vec (), ldy, n, r.fortran_vec (), ldr, sv.fortran_vec (), rcond, tol_a, iwork_a, dwork_a, ldwork_a, iwarn_a, info_a)); if (f77_exception_encountered) error ("ident: exception in SLICOT subroutine IB01AD"); static const char* err_msg[] = { "0: OK", "1: a fast algorithm was requested (ALG = 'C', or 'F') " "in sequential data processing, but it failed; the " "routine can be repeatedly called again using the " "standard QR algorithm", "2: the singular value decomposition (SVD) algorithm did " "not converge"}; static const char* warn_msg[] = { "0: OK", "1: the number of 100 cycles in sequential data " "processing has been exhausted without signaling " "that the last block of data was get; the cycle " "counter was reinitialized", "2: a fast algorithm was requested (ALG = 'C' or 'F'), " "but it failed, and the QR algorithm was then used " "(non-sequential data processing)", "3: all singular values were exactly zero, hence N = 0 " "(both input and output were identically zero)", "4: the least squares problems with coefficient matrix " "U_f, used for computing the weighted oblique " "projection (for METH = 'N'), have a rank-deficient " "coefficient matrix", "5: the least squares problem with coefficient matrix " "r_1 [6], used for computing the weighted oblique " "projection (for METH = 'N'), has a rank-deficient " "coefficient matrix"}; error_msg ("ident: IB01AD", info_a, 2, err_msg); warning_msg ("ident: IB01AD", iwarn_a, 5, warn_msg); } // resize F77_INT rs = 2*(m+l)*nobr; r.resize (rs, rs); // return values retval(0) = sv; retval(1) = octave_value (n); } return retval; } control-4.1.2/src/PaxHeaders/sl_ident.cc0000644000000000000000000000007415012430645015160 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_ident.cc0000644000175000017500000006246315012430645016362 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . SLICOT system identification Uses SLICOT IB01AD, IB01BD and IB01CD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: March 2012 Version: 0.2 */ #include #include #include "common.h" extern "C" { int F77_FUNC (ib01ad, IB01AD) (char& METH, char& ALG, char& JOBD, char& BATCH, char& CONCT, char& CTRL, F77_INT& NOBR, F77_INT& M, F77_INT& L, F77_INT& NSMP, double* U, F77_INT& LDU, double* Y, F77_INT& LDY, F77_INT& N, double* R, F77_INT& LDR, double* SV, double& RCOND, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& IWARN, F77_INT& INFO); int F77_FUNC (ib01bd, IB01BD) (char& METH, char& JOB, char& JOBCK, F77_INT& NOBR, F77_INT& N, F77_INT& M, F77_INT& L, F77_INT& NSMPL, double* R, F77_INT& LDR, double* A, F77_INT& LDA, double* C, F77_INT& LDC, double* B, F77_INT& LDB, double* D, F77_INT& LDD, double* Q, F77_INT& LDQ, double* RY, F77_INT& LDRY, double* S, F77_INT& LDS, double* K, F77_INT& LDK, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& IWARN, F77_INT& INFO); int F77_FUNC (ib01cd, IB01CD) (char& JOBX0, char& COMUSE, char& JOB, F77_INT& N, F77_INT& M, F77_INT& L, F77_INT& NSMP, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* U, F77_INT& LDU, double* Y, F77_INT& LDY, double* X0, double* V, F77_INT& LDV, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ident__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ident__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ib01ad__ (@dots{})\n" "Wrapper for SLICOT function IB01AD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 10) { print_usage (); } else { //////////////////////////////////////////////////////////////////////////////////// // SLICOT IB01AD - preprocess the input-output data // //////////////////////////////////////////////////////////////////////////////////// // arguments in char meth_a; char meth_b; char alg; char jobd; char batch; char conct; char ctrl; const Cell y_cell = args(0).cell_value (); const Cell u_cell = args(1).cell_value (); F77_INT nobr = args(2).int_value (); F77_INT nuser = args(3).int_value (); const F77_INT imeth = args(4).int_value (); const F77_INT ialg = args(5).int_value (); const F77_INT iconct = args(6).int_value (); const F77_INT ictrl = args(7).int_value (); double rcond = args(8).double_value (); double tol_a = args(9).double_value (); double tol_b = rcond; double tol_c = rcond; switch (imeth) { case 0: meth_a = 'M'; meth_b = 'M'; break; case 1: meth_a = 'N'; meth_b = 'N'; break; case 2: meth_a = 'N'; // no typo here meth_b = 'C'; break; default: error ("__sl_ib01ad__: argument 'meth' invalid"); } switch (ialg) { case 0: alg = 'C'; break; case 1: alg = 'F'; break; case 2: alg = 'Q'; break; default: error ("__sl_ib01ad__: argument 'alg' invalid"); } if (meth_a == 'M') jobd = 'M'; else // meth_a == 'N' jobd = 'N'; // IB01AD.f says: This parameter is not relevant for METH = 'N' if (iconct == 0) conct = 'C'; else conct = 'N'; if (ictrl == 0) ctrl = 'C'; else ctrl = 'N'; // m and l are equal for all experiments, checked by iddata class F77_INT n_exp = TO_F77_INT (y_cell.numel ()); // number of experiments F77_INT m = TO_F77_INT (u_cell.elem(0).columns ()); // m: number of inputs F77_INT l = TO_F77_INT (y_cell.elem(0).columns ()); // l: number of outputs F77_INT nsmpl = 0; // total number of samples // arguments out F77_INT n; F77_INT ldr; if (meth_a == 'M' && jobd == 'M') ldr = max (2*(m+l)*nobr, 3*m*nobr); else if (meth_a == 'N' || (meth_a == 'M' && jobd == 'N')) ldr = 2*(m+l)*nobr; else error ("__sl_ident__: could not handle 'ldr' case"); Matrix r (ldr, 2*(m+l)*nobr); ColumnVector sv (l*nobr); // repeat for every experiment in the dataset for (F77_INT i = 0; i < n_exp; i++) { if (n_exp == 1) batch = 'O'; // one block only else if (i == 0) batch = 'F'; // first block else if (i == n_exp-1) batch = 'L'; // last block else batch = 'I'; // intermediate block Matrix y = y_cell.elem(i).matrix_value (); Matrix u = u_cell.elem(i).matrix_value (); if (y.any_element_is_inf_or_nan () || u.any_element_is_inf_or_nan ()) error ("__sl_ident__: inputs must not contain NaN or Inf\n"); // y.rows == u.rows is checked by iddata class // F77_INT m = TO_F77_INT (u.columns ()); // m: number of inputs // F77_INT l = TO_F77_INT (y.columns ()); // l: number of outputs F77_INT nsmp = TO_F77_INT (y.rows ()); // nsmp: number of samples in the current experiment nsmpl += nsmp; // nsmpl: total number of samples of all experiments // minimal nsmp size checked by __slicot_identification__.m if (batch == 'O') { if (nsmp < 2*(m+l+1)*nobr - 1) error ("__sl_ident__: require NSMP >= 2*(M+L+1)*NOBR - 1"); } else { if (nsmp < 2*nobr) error ("__sl_ident__: require NSMP >= 2*NOBR"); } F77_INT ldu; if (m == 0) ldu = 1; else // m > 0 ldu = nsmp; F77_INT ldy = nsmp; // workspace F77_INT liwork_a; if (meth_a == 'N') // if METH = 'N' liwork_a = (m+l)*nobr; else if (alg == 'F') // if METH = 'M' and ALG = 'F' liwork_a = m+l; else // if METH = 'M' and ALG = 'C' or 'Q' liwork_a = 0; // TODO: Handle 'k' for DWORK F77_INT ldwork_a; F77_INT ns = nsmp - 2*nobr + 1; if (alg == 'C') { if (batch == 'F' || batch == 'I') { if (conct == 'C') ldwork_a = (4*nobr-2)*(m+l); else // (conct == 'N') ldwork_a = 1; } else if (meth_a == 'M') // && (batch == 'L' || batch == 'O') { if (conct == 'C' && batch == 'L') ldwork_a = max ((4*nobr-2)*(m+l), 5*l*nobr); else if (jobd == 'M') ldwork_a = max ((2*m-1)*nobr, (m+l)*nobr, 5*l*nobr); else // (jobd == 'N') ldwork_a = 5*l*nobr; } else // meth_b == 'N' && (batch == 'L' || batch == 'O') { ldwork_a = 5*(m+l)*nobr + 1; } } else if (alg == 'F') { if (batch != 'O' && conct == 'C') ldwork_a = (m+l)*2*nobr*(m+l+3); else if (batch == 'F' || batch == 'I') // && conct == 'N' ldwork_a = (m+l)*2*nobr*(m+l+1); else // (batch == 'L' || '0' && conct == 'N') ldwork_a = (m+l)*4*nobr*(m+l+1)+(m+l)*2*nobr; } else // (alg == 'Q') { // F77_INT ns = nsmp - 2*nobr + 1; if (ldr >= ns && batch == 'F') { ldwork_a = 4*(m+l)*nobr; } else if (ldr >= ns && batch == 'O') { if (meth_a == 'M') ldwork_a = max (4*(m+l)*nobr, 5*l*nobr); else // (meth == 'N') ldwork_a = 5*(m+l)*nobr + 1; } else if (conct == 'C' && (batch == 'I' || batch == 'L')) { ldwork_a = 4*(nobr+1)*(m+l)*nobr; } else // if ALG = 'Q', (BATCH = 'F' or 'O', and LDR < NS), or (BATCH = 'I' or 'L' and CONCT = 'N') { ldwork_a = 6*(m+l)*nobr; } } /* IB01AD.f Lines 438-445 C FURTHER COMMENTS C C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the C calculations could be rather inefficient if only minimal workspace C (see argument LDWORK) is provided. It is advisable to provide as C much workspace as possible. Almost optimal efficiency can be C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the C cache size is large enough to accommodate R, U, Y, and DWORK. */ ldwork_a = max (ldwork_a, (ns+2)*(2*(m+l)*nobr)); /* IB01AD.f Lines 291-195: c the workspace used for alg = 'q' is c ldrwrk*2*(m+l)*nobr + 4*(m+l)*nobr, c where ldrwrk = ldwork/(2*(m+l)*nobr) - 2; recommended c value ldrwrk = ns, assuming a large enough cache size. c for good performance, ldwork should be larger. somehow ldrwrk and ldwork must have been mixed up here */ OCTAVE_LOCAL_BUFFER (F77_INT, iwork_a, liwork_a); OCTAVE_LOCAL_BUFFER (double, dwork_a, ldwork_a); // error indicators F77_INT iwarn_a = 0; F77_INT info_a = 0; // SLICOT routine IB01AD F77_XFCN (ib01ad, IB01AD, (meth_a, alg, jobd, batch, conct, ctrl, nobr, m, l, nsmp, u.fortran_vec (), ldu, y.fortran_vec (), ldy, n, r.fortran_vec (), ldr, sv.fortran_vec (), rcond, tol_a, iwork_a, dwork_a, ldwork_a, iwarn_a, info_a)); if (f77_exception_encountered) error ("ident: exception in SLICOT subroutine IB01AD"); static const char* err_msg[] = { "0: OK", "1: a fast algorithm was requested (ALG = 'C', or 'F') " "in sequential data processing, but it failed; the " "routine can be repeatedly called again using the " "standard QR algorithm", "2: the singular value decomposition (SVD) algorithm did " "not converge"}; static const char* warn_msg[] = { "0: OK", "1: the number of 100 cycles in sequential data " "processing has been exhausted without signaling " "that the last block of data was get; the cycle " "counter was reinitialized", "2: a fast algorithm was requested (ALG = 'C' or 'F'), " "but it failed, and the QR algorithm was then used " "(non-sequential data processing)", "3: all singular values were exactly zero, hence N = 0 " "(both input and output were identically zero)", "4: the least squares problems with coefficient matrix " "U_f, used for computing the weighted oblique " "projection (for METH = 'N'), have a rank-deficient " "coefficient matrix", "5: the least squares problem with coefficient matrix " "r_1 [6], used for computing the weighted oblique " "projection (for METH = 'N'), has a rank-deficient " "coefficient matrix"}; error_msg ("ident: IB01AD", info_a, 2, err_msg); warning_msg ("ident: IB01AD", iwarn_a, 5, warn_msg); } // resize F77_INT rs = 2*(m+l)*nobr; r.resize (rs, rs); if (nuser > 0) { if (nuser < nobr) { n = nuser; // warning ("ident: nuser (%d) < nobr (%d), n = nuser", nuser, nobr); } else error ("ident: 'nuser' invalid"); } //////////////////////////////////////////////////////////////////////////////////// // SLICOT IB01BD - estimating system matrices, Kalman gain, and covariances // //////////////////////////////////////////////////////////////////////////////////// // arguments in char job = 'A'; char jobck = 'K'; //F77_INT nsmpl = nsmp; if (nsmpl < 2*(m+l)*nobr) error ("__sl_ident__: nsmpl (%d) < 2*(m+l)*nobr (%d)", static_cast (nsmpl), static_cast (nobr)); // arguments out F77_INT lda = max (1, n); F77_INT ldc = max (1, l); F77_INT ldb = max (1, n); F77_INT ldd = max (1, l); F77_INT ldq = n; // if JOBCK = 'C' or 'K' F77_INT ldry = l; // if JOBCK = 'C' or 'K' F77_INT lds = n; // if JOBCK = 'C' or 'K' F77_INT ldk = n; // if JOBCK = 'K' Matrix a (lda, n); Matrix c (ldc, n); Matrix b (ldb, m); Matrix d (ldd, m); Matrix q (ldq, n); Matrix ry (ldry, l); Matrix s (lds, l); Matrix k (ldk, l); // workspace F77_INT liwork_b; F77_INT liw1; F77_INT liw2; liw1 = max (n, m*nobr+n, l*nobr, m*(n+l)); liw2 = n*n; // if JOBCK = 'K' liwork_b = max (liw1, liw2); F77_INT ldwork_b; F77_INT ldw1; F77_INT ldw2; F77_INT ldw3; if (meth_b == 'M') { F77_INT ldw1a = max (2*(l*nobr-l)*n+2*n, (l*nobr-l)*n+n*n+7*n); F77_INT ldw1b = max (2*(l*nobr-l)*n+n*n+7*n, (l*nobr-l)*n+n+6*m*nobr, (l*nobr-l)*n+n+max (l+m*nobr, l*nobr + max (3*l*nobr+1, m))); ldw1 = max (ldw1a, ldw1b); F77_INT aw; if (m == 0 || job == 'C') aw = n + n*n; else aw = 0; ldw2 = l*nobr*n + max ((l*nobr-l)*n+aw+2*n+max(5*n,(2*m+l)*nobr+l), 4*(m*nobr+n)+1, m*nobr+2*n+l ); } else if (meth_b == 'N') { ldw1 = l*nobr*n + max ((l*nobr-l)*n+2*n+(2*m+l)*nobr+l, 2*(l*nobr-l)*n+n*n+8*n, n+4*(m*nobr+n)+1, m*nobr+3*n+l); if (m == 0 || job == 'C') ldw2 = 0; else ldw2 = l*nobr*n+m*nobr*(n+l)*(m*(n+l)+1)+ max ((n+l)*(n+l), 4*m*(n+l)+1); } else // (meth_b == 'C') { F77_INT ldw1a = max (2*(l*nobr-l)*n+2*n, (l*nobr-l)*n+n*n+7*n); F77_INT ldw1b = l*nobr*n + max ((l*nobr-l)*n+2*n+(2*m+l)*nobr+l, 2*(l*nobr-l)*n+n*n+8*n, n+4*(m*nobr+n)+1, m*nobr+3*n+l); ldw1 = max (ldw1a, ldw1b); ldw2 = l*nobr*n+m*nobr*(n+l)*(m*(n+l)+1)+ max ((n+l)*(n+l), 4*m*(n+l)+1); } ldw3 = max(4*n*n + 2*n*l + l*l + max (3*l, n*l), 14*n*n + 12*n + 5); ldwork_b = max (ldw1, ldw2, ldw3); OCTAVE_LOCAL_BUFFER (F77_INT, iwork_b, liwork_b); OCTAVE_LOCAL_BUFFER (double, dwork_b, ldwork_b); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, 2*n); // error indicators F77_INT iwarn_b = 0; F77_INT info_b = 0; // SLICOT routine IB01BD F77_XFCN (ib01bd, IB01BD, (meth_b, job, jobck, nobr, n, m, l, nsmpl, r.fortran_vec (), ldr, a.fortran_vec (), lda, c.fortran_vec (), ldc, b.fortran_vec (), ldb, d.fortran_vec (), ldd, q.fortran_vec (), ldq, ry.fortran_vec (), ldry, s.fortran_vec (), lds, k.fortran_vec (), ldk, tol_b, iwork_b, dwork_b, ldwork_b, bwork, iwarn_b, info_b)); if (f77_exception_encountered) error ("ident: exception in SLICOT subroutine IB01BD"); static const char* err_msg_b[] = { "0: OK", "1: error message not specified", "2: the singular value decomposition (SVD) algorithm did " "not converge", "3: a singular upper triangular matrix was found", "4: matrix A is (numerically) singular in discrete-" "time case", "5: the Hamiltonian or symplectic matrix H cannot be " "reduced to real Schur form", "6: the real Schur form of the Hamiltonian or " "symplectic matrix H cannot be appropriately ordered", "7: the Hamiltonian or symplectic matrix H has less " "than N stable eigenvalues", "8: the N-th order system of linear algebraic " "equations, from which the solution matrix X would " "be obtained, is singular to working precision", "9: the QR algorithm failed to complete the reduction " "of the matrix Ac to Schur canonical form, T", "10: the QR algorithm did not converge"}; static const char* warn_msg_b[] = { "0: OK", "1: warning message not specified", "2: warning message not specified", "3: warning message not specified", "4: a least squares problem to be solved has a " "rank-deficient coefficient matrix", "5: the computed covariance matrices are too small. " "The problem seems to be a deterministic one; the " "gain matrix is set to zero"}; error_msg ("ident: IB01BD", info_b, 10, err_msg_b); warning_msg ("ident: IB01BD", iwarn_b, 5, warn_msg_b); // resize a.resize (n, n); c.resize (l, n); b.resize (n, m); d.resize (l, m); q.resize (n, n); ry.resize (l, l); s.resize (n, l); k.resize (n, l); //////////////////////////////////////////////////////////////////////////////////// // SLICOT IB01CD - estimating the initial state // //////////////////////////////////////////////////////////////////////////////////// // arguments in char jobx0 = 'X'; char comuse = 'U'; char jobbd = 'D'; // arguments out Cell x0_cell (n_exp, 1); // cell of initial state vectors x0 // repeat for every experiment in the dataset // compute individual initial state vector x0 for every experiment for (F77_INT i = 0; i < n_exp; i++) { Matrix y = y_cell.elem(i).matrix_value (); Matrix u = u_cell.elem(i).matrix_value (); F77_INT nsmp = TO_F77_INT (y.rows ()); // nsmp: number of samples F77_INT ldv = max (1, n); F77_INT ldu; if (m == 0) ldu = 1; else // m > 0 ldu = nsmp; F77_INT ldy = nsmp; // arguments out ColumnVector x0 (n); Matrix v (ldv, n); // workspace F77_INT liwork_c = n; // if JOBX0 = 'X' and COMUSE <> 'C' F77_INT ldwork_c; F77_INT t = nsmp; F77_INT ldw1_c = 2; F77_INT ldw2_c = t*l*(n + 1) + 2*n + max (2*n*n, 4*n); F77_INT ldw3_c = n*(n + 1) + 2*n + max (n*l*(n + 1) + 2*n*n + l*n, 4*n); ldwork_c = ldw1_c + n*( n + m + l ) + max (5*n, ldw1_c, min (ldw2_c, ldw3_c)); OCTAVE_LOCAL_BUFFER (F77_INT, iwork_c, liwork_c); OCTAVE_LOCAL_BUFFER (double, dwork_c, ldwork_c); // error indicators F77_INT iwarn_c = 0; F77_INT info_c = 0; // SLICOT routine IB01CD F77_XFCN (ib01cd, IB01CD, (jobx0, comuse, jobbd, n, m, l, nsmp, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, u.fortran_vec (), ldu, y.fortran_vec (), ldy, x0.fortran_vec (), v.fortran_vec (), ldv, tol_c, iwork_c, dwork_c, ldwork_c, iwarn_c, info_c)); if (f77_exception_encountered) error ("ident: exception in SLICOT subroutine IB01CD"); static const char* err_msg_c[] = { "0: OK", "1: the QR algorithm failed to compute all the " "eigenvalues of the matrix A (see LAPACK Library " "routine DGEES); the locations DWORK(i), for " "i = g+1:g+N*N, contain the partially converged " "Schur form", "2: the singular value decomposition (SVD) algorithm did " "not converge"}; static const char* warn_msg_c[] = { "0: OK", "1: warning message not specified", "2: warning message not specified", "3: warning message not specified", "4: the least squares problem to be solved has a " "rank-deficient coefficient matrix", "5: warning message not specified", "6: the matrix A is unstable; the estimated x(0) " "and/or B and D could be inaccurate"}; error_msg ("ident: IB01CD", info_c, 2, err_msg_c); warning_msg ("ident: IB01CD", iwarn_c, 6, warn_msg_c); x0_cell.elem(i) = x0; // add x0 from the current experiment to cell of initial state vectors } // return values retval(0) = a; retval(1) = b; retval(2) = c; retval(3) = d; retval(4) = q; retval(5) = ry; retval(6) = s; retval(7) = k; retval(8) = x0_cell; } return retval; } control-4.1.2/src/PaxHeaders/sl_sb10fd.cc0000644000000000000000000000007315012430645015133 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sb10fd.cc0000644000175000017500000001514215012430645016326 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . H-infinity (sub)optimal state controller for a continuous-time system. Uses SLICOT SB10FD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: December 2009 Version: 0.6 */ #include #include "common.h" extern "C" { int F77_FUNC (sb10fd, SB10FD) (F77_INT& N, F77_INT& M, F77_INT& NP, F77_INT& NCON, F77_INT& NMEAS, double& GAMMA, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* AK, F77_INT& LDAK, double* BK, F77_INT& LDBK, double* CK, F77_INT& LDCK, double* DK, F77_INT& LDDK, double* RCOND, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb10fd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb10fd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb10fd__ (@dots{})\n" "Wrapper for SLICOT function SB10FD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 7) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_sb10fd__: inputs must not contain NaN or Inf\n"); F77_INT ncon = args(4).int_value (); F77_INT nmeas = args(5).int_value (); double gamma = args(6).double_value (); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT np = TO_F77_INT (c.rows ()); // np: number of outputs F77_INT lda = max (1, TO_F77_INT (a.rows ())); F77_INT ldb = max (1, TO_F77_INT (b.rows ())); F77_INT ldc = max (1, TO_F77_INT (c.rows ())); F77_INT ldd = max (1, TO_F77_INT (d.rows ())); F77_INT ldak = max (1, n); F77_INT ldbk = max (1, n); F77_INT ldck = max (1, ncon); F77_INT lddk = max (1, ncon); double tol = 0; // arguments out Matrix ak (ldak, n); Matrix bk (ldbk, nmeas); Matrix ck (ldck, n); Matrix dk (lddk, nmeas); ColumnVector rcond (4); // workspace F77_INT m2 = ncon; F77_INT m1 = m - m2; F77_INT np1 = np - nmeas; F77_INT np2 = nmeas; F77_INT liwork = max (2*max (n, m-ncon, np-nmeas, ncon), n*n); F77_INT q = max (m1, m2, np1, np2); F77_INT ldwork = 2*q*(3*q+2*n) + max (1, (n+q)*(n+q+6), q*(q + max (n, q, 5) + 1), 2*n*(n+2*q) + max (1, 4*q*q + max (2*q, 3*n*n + max (2*n*q, 10*n*n+12*n+5)), q*(3*n + 3*q + max (2*n, 4*q + max (n, q))))); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, 2*n); // error indicator F77_INT info; // SLICOT routine SB10FD F77_XFCN (sb10fd, SB10FD, (n, m, np, ncon, nmeas, gamma, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, ak.fortran_vec (), ldak, bk.fortran_vec (), ldbk, ck.fortran_vec (), ldck, dk.fortran_vec (), lddk, rcond.fortran_vec (), tol, iwork, dwork, ldwork, bwork, info)); if (f77_exception_encountered) error ("hinfsyn: __sl_sb10fd__: exception in SLICOT subroutine SB10FD"); static const char* err_msg[] = { "0: OK", "1: the matrix [A-j*omega*I, B2; C1, D12] had " "not full column rank in respect to the tolerance EPS", "2: the matrix [A-j*omega*I, B1; C2, D21] " "had not full row rank in respect to the tolerance EPS", "3: the matrix D12 had not full column rank in " "respect to the tolerance TOL", "4: the matrix D21 had not full row rank in respect " "to the tolerance TOL", "5: the singular value decomposition (SVD) algorithm " "did not converge (when computing the SVD of one of the matrices " "[A, B2; C1, D12], [A, B1; C2, D21], D12 or D21)", "6: the controller is not admissible (too small value " "of gamma)", "7: the X-Riccati equation was not solved " "successfully (the controller is not admissible or " "there are numerical difficulties)", "8: the Y-Riccati equation was not solved " "successfully (the controller is not admissible or " "there are numerical difficulties)", "9: the determinant of Im2 + Tu*D11HAT*Ty*D22 is " "zero [3]"}; error_msg ("hinfsyn", info, 9, err_msg); // return values retval(0) = ak; retval(1) = bk; retval(2) = ck; retval(3) = dk; retval(4) = rcond; } return retval; } control-4.1.2/src/PaxHeaders/Makefile0000644000000000000000000000007415012430645014510 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/Makefile0000644000175000017500000000503115012430645015676 0ustar00lilgelilge00000000000000-include ./Makefile.conf MKOCTFILE ?= mkoctfile ifndef LAPACK_LIBS LAPACK_LIBS := $(shell $(MKOCTFILE) -p LAPACK_LIBS) endif ifndef BLAS_LIBS BLAS_LIBS := $(shell $(MKOCTFILE) -p BLAS_LIBS) endif ifndef FLIBS FLIBS := $(shell $(MKOCTFILE) -p FLIBS) endif LDFLAGS := $(shell $(MKOCTFILE) -p LDFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) # slicot relative to src directory, SC_SRC is the build directory SC := slicot SC_SRC := $(SC)/src SC_SMOD := ../slicot-reference # own and auxilary sources relative to build directory SRC := ../.. SRC_AUX := $(SRC)/src_aux # other definitions AR := $(shell $(MKOCTFILE) -p AR) PKG_CXXFLAGS := -Wall $(PKG_CXXFLAGS_APPEND) all: __control_slicot_functions__.oct \ __control_helper_functions__.oct # if directly called from repository instead of distributed file structure, # copy required files into the slicot source directory. # MA02ID.f : One exemplary file from SLICOT, if not present, other files # are most probably missing as well. Copy all files from the # src directories of the SLICOT submodule. $(SC_SRC)/MA02ID.f: mkdir -p $(SC_SRC) cp $(SC_SMOD)/src/*.f $(SC_SRC) cp $(SC_SMOD)/src_aux/*.f $(SC_SRC) ./bootstrap && $(RM) -r "autom4te.cache" # TODO: Private oct-files for control package. # Compile SLICOT library # # Compile: $(SC_SRC)/*.f (SLICOT files) # ./TG04BX.f own derived file # $(SRC_AUX)/*.f external sources like deprecated # LAPACK files # # MA02ID.f is compiled by an extra command # suppressing warnings on indexing errors # slicotlibrary.a: slicot $(SC_SRC)/MA02ID.f cd $(SC_SRC) && \ $(MKOCTFILE) -w -c MA02ID.f; mv MA02ID.f x && \ $(MKOCTFILE) -c *.f $(SRC)/TG04BX.f $(SRC_AUX)/*.f && \ mv x MA02ID.f $(AR) -rc slicotlibrary.a $(SC_SRC)/*.o # slicot functions __control_slicot_functions__.oct: __control_slicot_functions__.cc common.cc slicotlibrary.a LDFLAGS="$(LDFLAGS)" \ $(MKOCTFILE) $(PKG_CXXFLAGS) __control_slicot_functions__.cc common.cc slicotlibrary.a # helper functions __control_helper_functions__.oct: __control_helper_functions__.cc $(MKOCTFILE) $(PKG_CXXFLAGS) __control_helper_functions__.cc clean: $(RM) -r *.o core octave-core *.oct *~ $(SC_SRC)/*.o $(RM) -rf $(SC_SRC) realclean: clean $(RM) -r *.a ## This should also remove any configure cache which clean should not ## remove according to GNU guidelines. ## https://www.gnu.org/prep/standards/html_node/Standard-Targets.html distclean: clean realclean rm -f Makefile.conf config.h config.log config.status oct-alt-includes.h control-4.1.2/src/PaxHeaders/undef-ah-octave.h0000644000000000000000000000007315012430645016166 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/undef-ah-octave.h0000644000175000017500000000070615012430645017361 0ustar00lilgelilge00000000000000/* To be included at the top of config.h (by autoheader). Avoid warnings for redefining AH-generated preprocessor symbols of Octave. */ #ifdef PACKAGE_BUGREPORT #undef PACKAGE_BUGREPORT #endif #ifdef PACKAGE_NAME #undef PACKAGE_NAME #endif #ifdef PACKAGE_STRING #undef PACKAGE_STRING #endif #ifdef PACKAGE_TARNAME #undef PACKAGE_TARNAME #endif #ifdef PACKAGE_URL #undef PACKAGE_URL #endif #ifdef PACKAGE_VERSION #undef PACKAGE_VERSION #endif control-4.1.2/src/PaxHeaders/sl_sb10kd.cc0000644000000000000000000000007315012430645015140 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sb10kd.cc0000644000175000017500000001200515012430645016326 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Positive feedback controller for a discrete-time system (D == 0). Uses SLICOT SB10KD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: July 2011 Version: 0.4 */ #include #include "common.h" extern "C" { int F77_FUNC (sb10kd, SB10KD) (F77_INT& N, F77_INT& M, F77_INT& NP, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double& FACTOR, double* AK, F77_INT& LDAK, double* BK, F77_INT& LDBK, double* CK, F77_INT& LDCK, double* DK, F77_INT& LDDK, double* RCOND, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb10kd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb10kd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb10kd__ (@dots{})\n" "Wrapper for SLICOT function SB10KD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 4) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan ()) error ("__sl_sb10kd__: inputs must not contain NaN or Inf\n"); double factor = args(3).double_value (); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT np = TO_F77_INT (c.rows ()); // np: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, np); F77_INT ldak = max (1, n); F77_INT ldbk = max (1, n); F77_INT ldck = max (1, m); F77_INT lddk = max (1, m); // arguments out Matrix ak (ldak, n); Matrix bk (ldbk, np); Matrix ck (ldck, n); Matrix dk (lddk, np); ColumnVector rcond (4); // workspace F77_INT liwork = 2 * max (n, np+m); F77_INT ldwork = 15*n*n + 6*n + max (14*n+23, 16*n, 2*n+np+m, 3*(np+m)) + max (n*n, 11*n*np + 2*m*m + 8*np*np + 8*m*n + 4*m*np + np); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, 2*n); // error indicator F77_INT info; // SLICOT routine SB10KD F77_XFCN (sb10kd, SB10KD, (n, m, np, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, factor, ak.fortran_vec (), ldak, bk.fortran_vec (), ldbk, ck.fortran_vec (), ldck, dk.fortran_vec (), lddk, rcond.fortran_vec (), iwork, dwork, ldwork, bwork, info)); if (f77_exception_encountered) error ("ncfsyn: slsb10kd: exception in SLICOT subroutine SB10KD"); static const char* err_msg[] = { "0: OK", "1: the P-Riccati equation is not solved successfully", "2: the Q-Riccati equation is not solved successfully", "3: the X-Riccati equation is not solved successfully", "4: the iteration to compute eigenvalues failed to " "converge", "5: the matrix Rx + Bx'*X*Bx is singular", "6: the closed-loop system is unstable"}; error_msg ("ncfsyn", info, 6, err_msg); // resizing ak.resize (n, n); bk.resize (n, np); ck.resize (m, n); dk.resize (m, np); // return values retval(0) = ak; retval(1) = bk; retval(2) = ck; retval(3) = dk; retval(4) = rcond; } return retval; } control-4.1.2/src/PaxHeaders/sl_sb16cd.cc0000644000000000000000000000007315012430645015136 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sb16cd.cc0000644000175000017500000001615315012430645016334 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . TODO Uses SLICOT SB16CD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: November 2011 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (sb16cd, SB16CD) (char& DICO, char& JOBD, char& JOBMR, char& JOBCF, char& ORDSEL, F77_INT& N, F77_INT& M, F77_INT& P, F77_INT& NCR, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* F, F77_INT& LDF, double* G, F77_INT& LDG, double* HSV, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb16cd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb16cd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb16cd__ (@dots{})\n" "Wrapper for SLICOT function SB16CD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 13) { print_usage (); } else { // arguments in char dico; char jobd; char jobmr; char jobcf; char ordsel; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); const F77_INT idico = args(4).int_value (); F77_INT ncr = args(5).int_value (); const F77_INT iordsel = args(6).int_value (); const F77_INT ijobd = args(7).int_value (); const F77_INT ijobmr = args(8).int_value (); Matrix f = args(9).matrix_value (); Matrix g = args(10).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan () || f.any_element_is_inf_or_nan () || g.any_element_is_inf_or_nan ()) error ("__sl_sb16cd__: inputs must not contain NaN or Inf\n"); const F77_INT ijobcf = args(11).int_value (); double tol = args(12).double_value (); if (idico == 0) dico = 'C'; else dico = 'D'; if (iordsel == 0) ordsel = 'F'; else ordsel = 'A'; if (ijobd == 0) jobd = 'Z'; else jobd = 'D'; if (ijobcf == 0) jobcf = 'L'; else jobcf = 'R'; switch (ijobmr) { case 0: jobmr = 'B'; break; case 1: jobmr = 'F'; break; default: error ("__sl_sb16cd__: argument jobmr invalid"); } F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); F77_INT ldd; if (jobd == 'Z') ldd = 1; else ldd = max (1, p); F77_INT ldf = max (1, m); F77_INT ldg = max (1, n); // arguments out ColumnVector hsv (n); // workspace F77_INT liwork; if (jobmr == 'B') liwork = 0; else // if JOBMR = 'F' liwork = n; F77_INT ldwork; F77_INT mp; if (jobcf == 'L') mp = m; else // if JOBCF = 'R' mp = p; ldwork = 2*n*n + max (1, 2*n*n + 5*n, n*max(m,p), n*(n + max(n,mp) + min(n,mp) + 6)); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT iwarn = 0; F77_INT info = 0; // SLICOT routine SB16CD F77_XFCN (sb16cd, SB16CD, (dico, jobd, jobmr, jobcf, ordsel, n, m, p, ncr, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, f.fortran_vec (), ldf, g.fortran_vec (), ldg, hsv.fortran_vec (), tol, iwork, dwork, ldwork, iwarn, info)); if (f77_exception_encountered) error ("fwcfconred: exception in SLICOT subroutine SB16CD"); static const char* err_msg[] = { "0: OK", "1: eigenvalue computation failure", "2: the matrix A-L*C is not stable", "3: the matrix A-B*F is not stable", "4: the Lyapunov equation for computing the " "observability Grammian is (nearly) singular", "5: the Lyapunov equation for computing the " "controllability Grammian is (nearly) singular", "6: the computation of Hankel singular values failed"}; static const char* warn_msg[] = { "0: OK", "1: with ORDSEL = 'F', the selected order NCR is " "greater than the order of a minimal realization " "of the controller.", "2: with ORDSEL = 'F', the selected order NCR " "corresponds to repeated singular values, which are " "neither all included nor all excluded from the " "reduced controller. In this case, the resulting NCR " "is set automatically to the largest value such that " "HSV(NCR) > HSV(NCR+1)."}; error_msg ("fwcfconred", info, 6, err_msg); warning_msg ("fwcfconred", iwarn, 2, warn_msg); // resize a.resize (ncr, ncr); // Ac g.resize (ncr, p); // Bc f.resize (m, ncr); // Cc // Dc = 0 // return values retval(0) = a; retval(1) = g; retval(2) = f; retval(3) = octave_value (ncr); retval(4) = hsv; } return retval; } control-4.1.2/src/PaxHeaders/sl_mb05nd.cc0000644000000000000000000000007415012430645015142 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_mb05nd.cc0000644000175000017500000001007115012430645016330 0ustar00lilgelilge00000000000000/* Copyright (C) 2014-2015 Thomas Vasileiou 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 LTI Syncope. If not, see . Matrix exponential and integral for a real matrix. Uses SLICOT MB05ND by courtesy of NICONET e.V. Author: Thomas Vasileiou Created: March 2014 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (mb05nd, MB05ND) (F77_INT& N, double& DELTA, double* A, F77_INT& LDA, double* EX, F77_INT& LDEX, double* EXINT, F77_INT& LDEXINT, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_mb05nd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_mb05nd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_mb05nd__ (@dots{})\n" "Wrapper for SLICOT function MB05N.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 3) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); double delta = args(1).double_value (); double tol = args(2).double_value (); if (a.any_element_is_inf_or_nan ()) error ("__sl_mb05nd__: inputs must not contain NaN or Inf\n"); if (a.numel () == 0) { // given matrix is empty, just return the empty matrix, // otherise mb05d would make a [](1x0) matrix from it retval(0) = a; retval(1) = a; return retval; } F77_INT n = TO_F77_INT (a.rows ()); F77_INT lda = max (1, n); F77_INT ldex = max (1, n); F77_INT ldexin = max (1, n); // arguments out Matrix ex (ldex, n); Matrix exint (ldexin, n); // workspace F77_INT ldwork = max (1, 2*n*n); // optimum performance OCTAVE_LOCAL_BUFFER (F77_INT, iwork, n); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT info = 0; // SLICOT routine MB05ND F77_XFCN (mb05nd, MB05ND, (n, delta, a.fortran_vec (), lda, ex.fortran_vec (), ldex, exint.fortran_vec (), ldexin, tol, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("__sl_mb05nd__: exception in SLICOT subroutine MB05ND"); if (info > 0) { if (info == n+1) info = 2; else info = 1; } static const char* err_msg[] = { "0: OK", "1: some element of the denominator of the Pade " "approximation is zero, so the denominator " "is exactly singular.", "2: DELTA = (delta * frobenius norm of matrix A) is " "probably too large to permit meaningful computation. " "That is, DELTA > SQRT(BIG), where BIG is a " "representable number near the overflow threshold of " "the machine."}; error_msg ("__sl_mb05nd__", info, 2, err_msg); // return values retval(0) = ex; retval(1) = exint; } return retval; } control-4.1.2/src/PaxHeaders/sl_sb10ed.cc0000644000000000000000000000007415012430645015133 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sb10ed.cc0000644000175000017500000001470215012430645016326 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . H2 optimal state controller for a discrete-time system. Uses SLICOT SB10ED by courtesy of NICONET e.V. Author: Lukas Reichlin Created: November 2009 Version: 0.6 */ #include #include "common.h" extern "C" { int F77_FUNC (sb10ed, SB10ED) (F77_INT& N, F77_INT& M, F77_INT& NP, F77_INT& NCON, F77_INT& NMEAS, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* AK, F77_INT& LDAK, double* BK, F77_INT& LDBK, double* CK, F77_INT& LDCK, double* DK, F77_INT& LDDK, double* RCOND, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb10ed__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb10ed__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb10ed__ (@dots{})\n" "Wrapper for SLICOT function SB10ED.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 6) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_sb10ed__: inputs must not contain NaN or Inf\n"); F77_INT ncon = args(4).int_value (); F77_INT nmeas = args(5).int_value (); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT np = TO_F77_INT (c.rows ()); // np: number of outputs F77_INT lda = max (1, TO_F77_INT (a.rows ())); F77_INT ldb = max (1, TO_F77_INT (b.rows ())); F77_INT ldc = max (1, TO_F77_INT (c.rows ())); F77_INT ldd = max (1, TO_F77_INT (d.rows ())); F77_INT ldak = max (1, n); F77_INT ldbk = max (1, n); F77_INT ldck = max (1, ncon); F77_INT lddk = max (1, ncon); double tol = 0; // arguments out Matrix ak (ldak, n); Matrix bk (ldbk, nmeas); Matrix ck (ldck, n); Matrix dk (lddk, nmeas); ColumnVector rcond (7); // workspace F77_INT m2 = ncon; F77_INT m1 = m - m2; F77_INT np1 = np - nmeas; F77_INT np2 = nmeas; F77_INT q = max (m1, m2, np1, np2); F77_INT ldwork = 2*q*(3*q+2*n)+max(1,(n+q)*(n+q+6),q*(q+max(n,q,5)+1), 2*n*n+max(1,14*n*n+6*n+max(14*n+23,16*n), q*(n+q+max(q,3)))); F77_INT liwork = max (2*m2, 2*n, n*n, np2); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, 2*n); // error indicator F77_INT info; // SLICOT routine SB10ED F77_XFCN (sb10ed, SB10ED, (n, m, np, ncon, nmeas, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, ak.fortran_vec (), ldak, bk.fortran_vec (), ldbk, ck.fortran_vec (), ldck, dk.fortran_vec (), lddk, rcond.fortran_vec (), tol, iwork, dwork, ldwork, bwork, info)); if (f77_exception_encountered) error ("h2syn: __sl_sb10ed__: exception in SLICOT subroutine SB10ED"); static const char* err_msg[] = { "0: OK", "1: the matrix [A-exp(j*Theta)*I, B2; C1, D12] " "had not full column rank in respect to the tolerance EPS", "2: the matrix [A-exp(j*Theta)*I, B1; C2, D21] " "had not full row rank in respect to the tolerance EPS", "3: the matrix D12 had not full column rank in " "respect to the tolerance TOL", "4: the matrix D21 had not full row rank in respect " "to the tolerance TOL", "5: the singular value decomposition (SVD) algorithm " "did not converge (when computing the SVD of one of the matrices " "[A-I, B2; C1, D12], [A-I, B1; C2, D21], D12 or D21)", "6: the X-Riccati equation was not solved successfully", "7: the matrix Im2 + B2'*X2*B2 is not positive " "definite, or it is numerically singular (with " "respect to the tolerance TOL)", "8: the Y-Riccati equation was not solved successfully", "9: the matrix Ip2 + C2*Y2*C2' is not positive " "definite, or it is numerically singular (with " "respect to the tolerance TOL)", "10: the matrix Im2 + DKHAT*D22 is singular, or its " "estimated condition number is larger than or equal " "to 1/TOL"}; error_msg ("h2syn", info, 10, err_msg); // return values retval(0) = ak; retval(1) = bk; retval(2) = ck; retval(3) = dk; retval(4) = rcond; } return retval; } control-4.1.2/src/PaxHeaders/sl_sb04qd.cc0000644000000000000000000000007415012430645015152 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sb04qd.cc0000644000175000017500000000644015012430645016345 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Solution of discrete-time Sylvester equations. Uses SLICOT SB04QD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: January 2010 Version: 0.3 */ #include #include "common.h" extern "C" { int F77_FUNC (sb04qd, SB04QD) (F77_INT& N, F77_INT& M, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* Z, F77_INT& LDZ, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb04qd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb04qd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb04qd__ (@dots{})\n" "Wrapper for SLICOT function SB04QD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 3) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan ()) error ("__sl_sb04qd__: inputs must not contain NaN or Inf\n"); F77_INT n = TO_F77_INT (a.rows ()); F77_INT m = TO_F77_INT (b.rows ()); F77_INT lda = max (1, n); F77_INT ldb = max (1, m); F77_INT ldc = max (1, n); F77_INT ldz = max (1, m); // arguments out Matrix z (ldz, m); // workspace F77_INT ldwork = max (1, 2*n*n + 9*n, 5*m, n + m); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, 4*n); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT info; // SLICOT routine SB04QD F77_XFCN (sb04qd, SB04QD, (n, m, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, z.fortran_vec (), ldz, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("dlyap: __sl_sb04qd__: exception in SLICOT subroutine SB04QD"); if (info != 0) error ("dlyap: __sl_sb04qd__: SB04QD returned info = %d", static_cast (info)); // return values retval(0) = c; } return retval; } control-4.1.2/src/PaxHeaders/sl_tb01id.cc0000644000000000000000000000007315012430645015137 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_tb01id.cc0000644000175000017500000000652615012430645016340 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Balance state-space model. Uses SLICOT TB01ID by courtesy of NICONET e.V. Author: Lukas Reichlin Created: May 2011 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (tb01id, TB01ID) (char& JOB, F77_INT& N, F77_INT& M, F77_INT& P, double& MAXRED, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* SCALE, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_tb01id__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_tb01id__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_tb01id__ (@dots{})\n" "Wrapper for SLICOT function TB01ID.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 4) { print_usage (); } else { // arguments in char job = 'A'; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); double maxred = args(3).double_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan ()) error ("__sl_tb01id__: inputs must not contain NaN or Inf\n"); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); // arguments out ColumnVector scale (n); // error indicators F77_INT info = 0; // SLICOT routine TB01ID F77_XFCN (tb01id, TB01ID, (job, n, m, p, maxred, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, scale.fortran_vec (), info)); if (f77_exception_encountered) error ("ss: prescale: __sl_tb01id__: exception in SLICOT subroutine TB01ID"); if (info != 0) error ("ss: prescale: __sl_tb01id__: TB01ID returned info = %d", static_cast (info)); // return values retval(0) = a; retval(1) = b; retval(2) = c; retval(3) = octave_value (maxred); retval(4) = scale; } return retval; } control-4.1.2/src/PaxHeaders/aclocal.m40000644000000000000000000000013215012430710014674 xustar0030 mtime=1747595720.449117574 30 atime=1747595720.549121184 30 ctime=1747595720.869132739 control-4.1.2/src/aclocal.m40000644000175000017500000000127315012430710016073 0ustar00lilgelilge00000000000000# generated automatically by aclocal 1.16.5 -*- Autoconf -*- # Copyright (C) 1996-2021 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])]) m4_include([m4/octave-forge.m4]) control-4.1.2/src/PaxHeaders/sl_sg02ad.cc0000644000000000000000000000007315012430645015134 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sg02ad.cc0000644000175000017500000001711415012430645016330 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Solution of algebraic Riccati equations for descriptor systems. Uses SLICOT SG02AD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: October 2010 Version: 0.4 */ #include #include "common.h" #include extern "C" { int F77_FUNC (sg02ad, SG02AD) (char& DICO, char& JOBB, char& FACT, char& UPLO, char& JOBL, char& SCAL, char& SORT, char& ACC, F77_INT& N, F77_INT& M, F77_INT& P, double* A, F77_INT& LDA, double* E, F77_INT& LDE, double* B, F77_INT& LDB, double* Q, F77_INT& LDQ, double* R, F77_INT& LDR, double* L, F77_INT& LDL, double& RCONDU, double* X, F77_INT& LDX, double* ALFAR, double* ALFAI, double* BETA, double* S, F77_INT& LDS, double* T, F77_INT& LDT, double* U, F77_INT& LDU, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sg02ad__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sg02ad__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sg02ad__ (@dots{})\n" "Wrapper for SLICOT function SG02AD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 8) { print_usage (); } else { // arguments in char dico; char jobb = 'B'; char fact = 'N'; char uplo = 'U'; char jobl; char scal = 'N'; char sort = 'S'; char acc = 'N'; Matrix a = args(0).matrix_value (); Matrix e = args(1).matrix_value (); Matrix b = args(2).matrix_value (); Matrix q = args(3).matrix_value (); Matrix r = args(4).matrix_value (); Matrix l = args(5).matrix_value (); F77_INT discrete = args(6).int_value (); F77_INT ijobl = args(7).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || e.any_element_is_inf_or_nan () || q.any_element_is_inf_or_nan () || r.any_element_is_inf_or_nan () || l.any_element_is_inf_or_nan ()) error ("__sl_sg02ad__: inputs must not contain NaN or Inf\n"); if (discrete == 0) dico = 'C'; else dico = 'D'; if (ijobl == 0) jobl = 'Z'; else jobl = 'N'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = 0; // p: number of outputs, not used because FACT = 'N' F77_INT lda = max (1, n); F77_INT lde = max (1, n); F77_INT ldb = max (1, n); F77_INT ldq = max (1, n); F77_INT ldr = max (1, m); F77_INT ldl = max (1, n); // arguments out double rcondu; F77_INT ldx = max (1, n); Matrix x (ldx, n); F77_INT nu = 2*n; ColumnVector alfar (nu); ColumnVector alfai (nu); ColumnVector beta (nu); // unused output arguments F77_INT lds = max (1, 2*n + m); OCTAVE_LOCAL_BUFFER (double, s, lds * lds); F77_INT ldt = max (1, 2*n + m); OCTAVE_LOCAL_BUFFER (double, t, ldt * 2*n); F77_INT ldu = max (1, 2*n); OCTAVE_LOCAL_BUFFER (double, u, ldu * 2*n); // tolerance double tol = 0; // use default value // workspace F77_INT liwork = max (1, m, 2*n); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); F77_INT ldwork = max (7*(2*n + 1) + 16, 16*n, 2*n + m, 3*m); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, 2*n); // error indicator F77_INT iwarn; F77_INT info; // SLICOT routine SG02AD F77_XFCN (sg02ad, SG02AD, (dico, jobb, fact, uplo, jobl, scal, sort, acc, n, m, p, a.fortran_vec (), lda, e.fortran_vec (), lde, b.fortran_vec (), ldb, q.fortran_vec (), ldq, r.fortran_vec (), ldr, l.fortran_vec (), ldl, rcondu, x.fortran_vec (), ldx, alfar.fortran_vec (), alfai.fortran_vec (), beta.fortran_vec (), s, lds, t, ldt, u, ldu, tol, iwork, dwork, ldwork, bwork, iwarn, info)); if (f77_exception_encountered) error ("are: __sl_sg02ad__: exception in SLICOT subroutine SG02AD"); static const char* err_msg[] = { "0: OK", "1: the computed extended matrix pencil is singular, " "possibly due to rounding errors", "2: the QZ algorithm failed", "3: reordering of the generalized eigenvalues failed", "4: after reordering, roundoff changed values of " "some complex eigenvalues so that leading eigenvalues " "in the generalized Schur form no longer satisfy the " "stability condition; this could also be caused due " "to scaling", "5: the computed dimension of the solution does not " "equal N", "6: the spectrum is too close to the boundary of " "the stability domain", "7: a singular matrix was encountered during the " "computation of the solution matrix X"}; static const char* warn_msg[] = { "0: OK", "1: solution may be inaccurate due to poor scaling " "or eigenvalues too close to the boundary of the stability domain " "(the imaginary axis, if DICO = 'C', or the unit circle, if DICO = 'D')"}; error_msg ("are", info, 7, err_msg); warning_msg ("are", iwarn, 1, warn_msg); // assemble complex vector - adapted from DEFUN complex in data.cc alfar.resize (n); alfai.resize (n); beta.resize (n); ColumnVector poler (n); ColumnVector polei (n); poler = quotient (alfar, beta); polei = quotient (alfai, beta); ComplexColumnVector pole (n, Complex ()); for (F77_INT i = 0; i < n; i++) pole.xelem (i) = Complex (poler(i), polei(i)); // return value retval(0) = x; retval(1) = pole; } return retval; } control-4.1.2/src/PaxHeaders/sl_ag08bd.cc0000644000000000000000000000007415012430645015122 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_ag08bd.cc0000644000175000017500000002026615012430645016317 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Finite Smith zeros of descriptor state-space models. Uses SLICOT AG08BD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: September 2010 Version: 0.5 */ #include #include "common.h" #include #include extern "C" { int F77_FUNC (ag08bd, AG08BD) (char& EQUIL, F77_INT& L, F77_INT& N, F77_INT& M, F77_INT& P, double* A, F77_INT& LDA, double* E, F77_INT& LDE, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, F77_INT& NFZ, F77_INT& NRANK, F77_INT& NIZ, F77_INT& DINFZ, F77_INT& NKROR, F77_INT& NINFE, F77_INT& NKROL, F77_INT* INFZ, F77_INT* KRONR, F77_INT* INFE, F77_INT* KRONL, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); int F77_FUNC (dggev, DGGEV) (char& JOBVL, char& JOBVR, F77_INT& N, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* ALPHAR, double* ALPHAI, double* BETA, double* VL, F77_INT& LDVL, double* VR, F77_INT& LDVR, double* WORK, F77_INT& LWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ag08bd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ag08bd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ag08bd__ (@dots{})\n" "Wrapper for SLICOT function AG08BD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 6) { print_usage (); } else { // arguments in char equil; Matrix a = args(0).matrix_value (); Matrix e = args(1).matrix_value (); Matrix b = args(2).matrix_value (); Matrix c = args(3).matrix_value (); Matrix d = args(4).matrix_value (); const F77_INT scaled = args(5).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan () || e.any_element_is_inf_or_nan ()) error ("__sl_ag08bdd__: inputs must not contain NaN or Inf\n"); if (scaled == 0) equil = 'S'; else equil = 'N'; F77_INT l = TO_F77_INT (a.rows ()); // l: number of states F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, l); F77_INT lde = max (1, l); F77_INT ldb = max (1, l); if (m == 0) ldb = 1; F77_INT ldc = max (1, p); F77_INT ldd = max (1, p); // arguments out F77_INT nfz; F77_INT nrank; F77_INT niz; F77_INT dinfz; F77_INT nkror; F77_INT ninfe; F77_INT nkrol; OCTAVE_LOCAL_BUFFER (F77_INT, infz, n+1); OCTAVE_LOCAL_BUFFER (F77_INT, kronr, n+m+1); OCTAVE_LOCAL_BUFFER (F77_INT, infe, 1 + min (l+p, n+m)); OCTAVE_LOCAL_BUFFER (F77_INT, kronl, l+p+1); // workspace F77_INT ldwork = max (l+p, m+n) * (m+n) + max (1, 5 * max (l+p, m+n)); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, n + max (1, m)); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT info; // tolerance double tol = 0; // AG08BD uses DLAMCH for default tolerance // SLICOT routine AG08BD F77_XFCN (ag08bd, AG08BD, (equil, l, n, m, p, a.fortran_vec (), lda, e.fortran_vec (), lde, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, nfz, nrank, niz, dinfz, nkror, ninfe, nkrol, infz, kronr, infe, kronl, tol, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("dss: zero: __sl_ag08bd__: exception in SLICOT subroutine AG08BD"); if (info != 0) error ("dss: zero: __sl_ag08bd__: AG08BD returned info = %d", static_cast (info)); // DGGEV Part a.resize (nfz, nfz); // Af e.resize (nfz, nfz); // Ef lda = max (1, nfz); lde = max (1, nfz); char jobvl = 'N'; char jobvr = 'N'; ColumnVector alphar (nfz); ColumnVector alphai (nfz); ColumnVector beta (nfz); double* vl = 0; // not referenced because jobvl = 'N' F77_INT ldvl = 1; double* vr = 0; // not referenced because jobvr = 'N' F77_INT ldvr = 1; F77_INT lwork = max (1, 8*nfz); OCTAVE_LOCAL_BUFFER (double, work, lwork); F77_INT info2; F77_XFCN (dggev, DGGEV, (jobvl, jobvr, nfz, a.fortran_vec (), lda, e.fortran_vec (), lde, alphar.fortran_vec (), alphai.fortran_vec (), beta.fortran_vec (), vl, ldvl, vr, ldvr, work, lwork, info2)); if (f77_exception_encountered) error ("dss: zero: __sl_ag08bd__: exception in LAPACK subroutine DGGEV"); if (info2 != 0) error ("dss: zero: __sl_ag08bd__: DGGEV returned info = %d", static_cast (info2)); // assemble complex vector - adapted from DEFUN complex in data.cc // LAPACK DGGEV.f says: // // Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) // may easily over- or underflow, and BETA(j) may even be zero. // Thus, the user should avoid naively computing the ratio // alpha/beta. However, ALPHAR and ALPHAI will be always less // than and usually comparable with norm(A) in magnitude, and // BETA always less than and usually comparable with norm(B). // // Since we need the zeros explicitly ... ColumnVector zeror (nfz); ColumnVector zeroi (nfz); zeror = quotient (alphar, beta); zeroi = quotient (alphai, beta); ComplexColumnVector zero (nfz, Complex ()); for (F77_INT i = 0; i < nfz; i++) zero.xelem (i) = Complex (zeror(i), zeroi(i)); // prepare additional outputs for info struct RowVector infzr (dinfz); RowVector kronrr (nkror); RowVector kronlr (nkrol); for (F77_INT i = 0; i < dinfz; i++) infzr.xelem (i) = infz[i]; for (F77_INT i = 0; i < nkror; i++) kronrr.xelem (i) = kronr[i]; for (F77_INT i = 0; i < nkrol; i++) kronlr.xelem (i) = kronl[i]; // return values retval(0) = zero; retval(1) = octave_value (nrank); retval(2) = infzr; retval(3) = kronrr; retval(4) = kronlr; } return retval; } control-4.1.2/src/PaxHeaders/sl_sb03md.cc0000644000000000000000000000007415012430645015145 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sb03md.cc0000644000175000017500000000747215012430645016346 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Solution of Lyapunov equations. Uses SLICOT SB03MD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: December 2009 Version: 0.4 */ #include #include "common.h" extern "C" { int F77_FUNC (sb03md, SB03MD) (char& DICO, char& JOB, char& FACT, char& TRANA, F77_INT& N, double* A, F77_INT& LDA, double* U, F77_INT& LDU, double* C, F77_INT& LDC, double& SCALE, double& SEP, double& FERR, double* WR, double* WI, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb03md__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb03md__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb03md__ (@dots{})\n" "Wrapper for SLICOT function SB03MD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type 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'; Matrix a = args(0).matrix_value (); Matrix c = args(1).matrix_value (); F77_INT discrete = args(2).int_value (); if (a.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan ()) error ("__sl_sb03md__: inputs must not contain NaN or Inf\n"); if (discrete == 0) dico = 'C'; else dico = 'D'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT lda = max (1, n); F77_INT ldu = max (1, n); F77_INT ldc = max (1, n); // arguments out double scale; double sep = 0; double ferr = 0; Matrix u (ldu, n); ColumnVector wr (n); ColumnVector wi (n); // workspace F77_INT* iwork = 0; // not referenced because job = X F77_INT ldwork = max (n*n, 3*n); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_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: __sl_sb03md__: exception in SLICOT subroutine SB03MD"); if (info != 0) error ("lyap: __sl_sb03md__: SB03MD returned info = %d", static_cast (info)); // return values retval(0) = c; retval(1) = octave_value (scale); } return retval; } control-4.1.2/src/PaxHeaders/is_real_matrix.cc0000644000000000000000000000007415012430645016361 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/is_real_matrix.cc0000644000175000017500000000347415012430645017560 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Return true if all arguments are real-valued matrices and false otherwise. Author: Lukas Reichlin Created: September 2010 Version: 0.2 */ #include #include "config.h" // PKG_ADD: autoload ("is_real_matrix", "__control_helper_functions__.oct"); DEFUN_DLD (is_real_matrix, args, nargout, "-*- texinfo -*-\n" "@deftypefn {Loadable Function} {} is_real_matrix (@var{a}, @dots{})@*\n" "Return true if all arguments are real-valued matrices and false otherwise.@*\n" "@var{[]} is a valid matrix.@*\n" "Avoid nasty stuff like @code{true = isreal (\"a\")}@*\n" "@seealso{is_real_square_matrix, is_real_vector, is_real_scalar}@*\n" "@end deftypefn") { octave_value retval = true; octave_idx_type nargin = args.length (); if (nargin == 0) { print_usage (); } else { for (octave_idx_type i = 0; i < nargin; i++) { if (args(i).ndims () != 2 || ! args(i).OV_ISNUMERIC () || ! args(i).OV_ISREAL ()) { retval = false; break; } } } return retval; } control-4.1.2/src/PaxHeaders/__control_slicot_functions__.cc0000644000000000000000000000007415012430645021300 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/__control_slicot_functions__.cc0000644000175000017500000000744615012430645022502 0ustar00lilgelilge00000000000000#include "sl_ab08nd.cc" // invariant zeros of state-space models #include "sl_ab13dd.cc" // L-infinity norm #include "sl_sb10hd.cc" // H-2 controller synthesis - continuous-time #include "sl_sb10ed.cc" // H-2 controller synthesis - discrete-time #include "sl_ab13bd.cc" // H-2 norm #include "sl_sb01bd.cc" // pole assignment #include "sl_sb10fd.cc" // H-infinity controller synthesis - continuous-time #include "sl_sb10dd.cc" // H-infinity controller synthesis - discrete-time #include "sl_sb03md.cc" // Lyapunov equations #include "sl_sb04md.cc" // Sylvester equations - continuous-time #include "sl_sb04qd.cc" // Sylvester equations - discrete-time #include "sl_sg03ad.cc" // generalized Lyapunov equations #include "sl_sb02od.cc" // algebraic Riccati equations #include "sl_ab13ad.cc" // Hankel singular values #include "sl_ab01od.cc" // staircase form using orthogonal transformations #include "sl_tb01pd.cc" // minimal realization of state-space models #include "sl_sb03od.cc" // Cholesky factor of Lyapunov equations #include "sl_sg03bd.cc" // Cholesky factor of generalized Lyapunov equations #include "sl_ag08bd.cc" // finite Smith zeros of descriptor state-space models #include "sl_tg01jd.cc" // minimal realization of descriptor state-space models #include "sl_tg01hd.cc" // controllability staircase form of descriptor state-space models #include "sl_tg01id.cc" // observability staircase form of descriptor state-space models #include "sl_sg02ad.cc" // solution of algebraic Riccati equations for descriptor systems #include "sl_tg04bx.cc" // gain of descriptor state-space models #include "sl_tb01id.cc" // scaling of state-space models #include "sl_tg01ad.cc" // scaling of descriptor state-space models #include "sl_sb10id.cc" // H-infinity loop shaping - continuous-time #include "sl_sb10kd.cc" // H-infinity loop shaping - discrete-time - strictly proper case #include "sl_sb10zd.cc" // H-infinity loop shaping - discrete-time - proper case #include "sl_tb04bd.cc" // state-space to transfer function conversion #include "sl_ab04md.cc" // bilinear transformation #include "sl_sb10jd.cc" // descriptor to regular state-space conversion #include "sl_td04ad.cc" // transfer function to state-space conversion #include "sl_tb01ud.cc" // controllable block Hessenberg realization #include "sl_ab09hd.cc" // balanced stochastic truncation model reduction #include "sl_ab09id.cc" // balanced truncation & singular perturbation approximation model reduction #include "sl_ab09jd.cc" // Hankel-norm approximation model reduction #include "sl_sb16ad.cc" // balanced truncation & singular perturbation approximation controller reduction #include "sl_sb16bd.cc" // coprime factorization state-feedback controller reduction #include "sl_sb16cd.cc" // frequency-weighted coprime factorization state-feedback controller reduction #include "sl_sb10yd.cc" // fit state-space model to frequency response data #include "sl_ident.cc" // system identification #include "sl_ib01cd.cc" // compute initial state vector #include "sl_ib01ad.cc" // compute singular values // #include "sl_are.cc" // solve ARE with Schur vector approach and scaling #include "sl_tg01fd.cc" // orthogonal reduction of dss to a SVD-like coordinate form #include "sl_sb10ad.cc" // H-infinity optimal controller using modified Glover's and Doyle's formulas (continuous-time) #include "sl_mb05nd.cc" // matrix exponential and integral for a real matrix // stub function to avoid gen_doc_cache warning upon package installation DEFUN_DLD (__control_slicot_functions__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __control_slicot_functions__ (@dots{})\n" "Wrappers for SLICOT functions.@*" "For internal use only.\n") { octave_value_list retval; error ("__control_slicot_functions__: for internal use only"); return retval; } control-4.1.2/src/PaxHeaders/is_real_scalar.cc0000644000000000000000000000007415012430645016322 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/is_real_scalar.cc0000644000175000017500000000350615012430645017515 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Return true if all arguments are real-valued scalars and false otherwise. Author: Lukas Reichlin Created: September 2010 Version: 0.2 */ #include #include "config.h" // PKG_ADD: autoload ("is_real_scalar", "__control_helper_functions__.oct"); DEFUN_DLD (is_real_scalar, args, nargout, "-*- texinfo -*-\n" "@deftypefn {Loadable Function} {} is_real_scalar (@var{a}, @dots{})@*\n" "Return true if all arguments are real-valued scalars and false otherwise.@*\n" "@var{[]} is not a valid scalar.@*\n" "Avoid nasty stuff like @code{true = isreal (\"a\")}@*\n" "@seealso{is_real_matrix, is_real_vector}@*\n" "@end deftypefn") { octave_value retval = true; octave_idx_type nargin = args.length (); if (nargin == 0) { print_usage (); } else { for (octave_idx_type i = 0; i < nargin; i++) { if (args(i).ndims () != 2 || ! args(i).is_scalar_type () || ! args(i).OV_ISNUMERIC () || ! args(i).OV_ISREAL ()) { retval = false; break; } } } return retval; } control-4.1.2/src/PaxHeaders/sl_ab13bd.cc0000644000000000000000000000007415012430645015111 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_ab13bd.cc0000644000175000017500000001047115012430645016303 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . H-2 norm of a SS model. Uses SLICOT AB13BD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: November 2009 Version: 0.5 */ #include #include "common.h" extern "C" { double F77_FUNC (ab13bd, AB13BD) (char& DICO, char& JOBN, F77_INT& N, F77_INT& M, F77_INT& P, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, F77_INT& NQ, double& TOL, double* DWORK, F77_INT& LDWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ab13bd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ab13bd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ab13bd__ (@dots{})\n" "Wrapper for SLICOT function AB13BD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 5) { print_usage (); } else { // arguments in char dico; char jobn = 'H'; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); F77_INT discrete = args(4).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_ab13bd__: inputs must not contain NaN or Inf\n"); if (discrete == 0) dico = 'C'; else dico = 'D'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, TO_F77_INT (a.rows ())); F77_INT ldb = max (1, TO_F77_INT (b.rows ())); F77_INT ldc = max (1, TO_F77_INT (c.rows ())); F77_INT ldd = max (1, TO_F77_INT (d.rows ())); // arguments out double norm; F77_INT nq; // tolerance double tol = 0; // workspace F77_INT ldwork = max (1, m*(n+m) + max (n*(n+5), m*(m+2), 4*p ), n*(max (n, p) + 4 ) + min (n, p)); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT iwarn; F77_INT info; // SLICOT routine AB13BD norm = F77_FUNC (ab13bd, AB13BD) (dico, jobn, n, m, p, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, nq, tol, dwork, ldwork, iwarn, info); if (f77_exception_encountered) error ("lti: norm: __sl_ab13bd__: exception in SLICOT subroutine AB13BD"); if (info != 0) error ("lti: norm: __sl_ab13bd__: AB13BD returned info = %d", static_cast (info)); if (iwarn != 0) warning ("lti: norm: __sl_ab13bd__: AB13BD returned iwarn = %d", static_cast (iwarn)); // return value retval(0) = octave_value (norm); } return retval; } control-4.1.2/src/PaxHeaders/sl_td04ad.cc0000644000000000000000000000007315012430645015134 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_td04ad.cc0000644000175000017500000001134615012430645016331 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Minimal state-space representation (A,B,C,D) for a proper transfer matrix T(s) given as either row or column polynomial vectors over denominator polynomials, possibly with uncancelled common terms. Uses SLICOT TD04AD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: August 2011 Version: 0.3 */ #include #include "common.h" extern "C" { int F77_FUNC (td04ad, TD04AD) (char& ROWCOL, F77_INT& M, F77_INT& P, F77_INT* INDEX, double* DCOEFF, F77_INT& LDDCOE, double* UCOEFF, F77_INT& LDUCO1, F77_INT& LDUCO2, F77_INT& NR, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_td04ad__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_td04ad__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_td04ad__ (@dots{})\n" "Wrapper for SLICOT function TD04AD.@*" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 4) { print_usage (); } else { // arguments in char rowcol = 'R'; NDArray ucoeff = args(0).array_value (); Matrix dcoeff = args(1).matrix_value (); Matrix indexd = args(2).matrix_value (); double tol = args(3).double_value (); if (ucoeff.any_element_is_inf_or_nan () || dcoeff.any_element_is_inf_or_nan () || indexd.any_element_is_inf_or_nan ()) error ("__sl_td04ad__: inputs must not contain NaN or Inf\n"); F77_INT p = TO_F77_INT (ucoeff.rows ()); // p: number of outputs F77_INT m = TO_F77_INT (ucoeff.columns ()); // m: number of inputs F77_INT lddcoe = max (1, p); // TODO: handle case ucoeff.rows = 0 F77_INT lduco1 = max (1, p); F77_INT lduco2 = max (1, m); F77_INT n = 0; OCTAVE_LOCAL_BUFFER (F77_INT, index, p); for (F77_INT i = 0; i < p; i++) { index[i] = TO_F77_INT (indexd.xelem (i)); n += index[i]; } // arguments out F77_INT nr = max (1, n); // initialize to prevent crash if info != 0 F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, m, p); F77_INT ldd = max (1, p); Matrix a (lda, n); Matrix b (ldb, max (m, p)); Matrix c (ldc, n); Matrix d (ldd, m); // workspace F77_INT ldwork = max (1, n + max (n, 3*m, 3*p)); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, n + max (m, p)); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT info; // SLICOT routine TD04AD F77_XFCN (td04ad, TD04AD, (rowcol, m, p, index, dcoeff.fortran_vec (), lddcoe, ucoeff.fortran_vec (), lduco1, lduco2, nr, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, tol, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("tf2ss: __sl_td04ad__: exception in SLICOT subroutine TD04AD"); if (info != 0) error ("tf2ss: __sl_td04ad__: TD04AD returned info = %d", static_cast (info)); // resize a.resize (nr, nr); b.resize (nr, m); c.resize (p, nr); d.resize (p, m); // return values retval(0) = a; retval(1) = b; retval(2) = c; retval(3) = d; } return retval; } control-4.1.2/src/PaxHeaders/sl_sb10dd.cc0000644000000000000000000000007415012430645015132 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sb10dd.cc0000644000175000017500000001510515012430645016323 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . H-infinity (sub)optimal state controller for a discrete-time system. Uses SLICOT SB10DD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: December 2009 Version: 0.6 */ #include #include "common.h" extern "C" { int F77_FUNC (sb10dd, SB10DD) (F77_INT& N, F77_INT& M, F77_INT& NP, F77_INT& NCON, F77_INT& NMEAS, double& GAMMA, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* AK, F77_INT& LDAK, double* BK, F77_INT& LDBK, double* CK, F77_INT& LDCK, double* DK, F77_INT& LDDK, double* X, F77_INT& LDX, double* Z, F77_INT& LDZ, double* RCOND, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb10dd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb10dd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb10dd__ (@dots{})\n" "Wrapper for SLICOT function SB10DD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 7) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_sb10dd__: inputs must not contain NaN or Inf\n"); F77_INT ncon = args(4).int_value (); F77_INT nmeas = args(5).int_value (); double gamma = args(6).double_value (); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT np = TO_F77_INT (c.rows ()); // np: number of outputs F77_INT lda = max (1, TO_F77_INT (a.rows ())); F77_INT ldb = max (1, TO_F77_INT (b.rows ())); F77_INT ldc = max (1, TO_F77_INT (c.rows ())); F77_INT ldd = max (1, TO_F77_INT (d.rows ())); F77_INT ldak = max (1, n); F77_INT ldbk = max (1, n); F77_INT ldck = max (1, ncon); F77_INT lddk = max (1, ncon); F77_INT ldx = max (1, n); F77_INT ldz = max (1, n); double tol = 0; // arguments out Matrix ak (ldak, n); Matrix bk (ldbk, nmeas); Matrix ck (ldck, n); Matrix dk (lddk, nmeas); Matrix x (ldx, n); Matrix z (ldz, n); ColumnVector rcond (8); // workspace F77_INT m2 = ncon; F77_INT m1 = m - m2; F77_INT np1 = np - nmeas; F77_INT np2 = nmeas; F77_INT liwork = max (2*max (m2, n), m, m2+np2, n*n); F77_INT q = max (m1, m2, np1, np2); F77_INT ldwork = max ((n+q)*(n+q+6), 13*n*n + m*m + 2*q*q + n*(m+q) + max (m*(m+7*n), 2*q*(8*n+m+2*q)) + 6*n + max (14*n+23, 16*n, 2*n + max (m, 2*q), 3*max (m, 2*q))); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, 2*n); // error indicator F77_INT info; // SLICOT routine SB10DD F77_XFCN (sb10dd, SB10DD, (n, m, np, ncon, nmeas, gamma, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, ak.fortran_vec (), ldak, bk.fortran_vec (), ldbk, ck.fortran_vec (), ldck, dk.fortran_vec (), lddk, x.fortran_vec (), ldx, z.fortran_vec (), ldz, rcond.fortran_vec (), tol, iwork, dwork, ldwork, bwork, info)); if (f77_exception_encountered) error ("hinfsyn: __sl_sb10dd__: exception in SLICOT subroutine SB10DD"); static const char* err_msg[] = { "0: OK", "1: the matrix [A-exp(j*Theta)*I, B2; C1, D12] " "had not full column rank", "2: the matrix | A-exp(j*Theta)*I, B1; C2, D21] " "had not full row rank", "3: the matrix D12 had not full column rank", "4: the matrix D21 had not full row rank", "5: the controller is not admissible " "(too small value of gamma)", "6: the X-Riccati equation was not solved " "successfully (the controller is not admissible or " "there are numerical difficulties)", "7: the Z-Riccati equation was not solved " "successfully (the controller is not admissible or " "there are numerical difficulties)", "8: the matrix Im2 + DKHAT*D22 is singular", "9: the singular value decomposition (SVD) algorithm " "did not converge (when computing the SVD of one of " "the matrices [A, B2; C1, D12], [A, B1; C2, D21], D12 or D21)"}; error_msg ("hinfsyn", info, 9, err_msg); // return values retval(0) = ak; retval(1) = bk; retval(2) = ck; retval(3) = dk; retval(4) = rcond; } return retval; } control-4.1.2/src/PaxHeaders/common.cc0000644000000000000000000000007415012430645014647 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/common.cc0000644000175000017500000000522015012430645016035 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Common code for oct-files. Author: Lukas Reichlin Created: April 2010 Version: 0.4 */ #include #include #include "common.h" F77_INT max (F77_INT a, F77_INT b) { if (a > b) return a; else return b; } F77_INT max (F77_INT a, F77_INT b, F77_INT c) { return max (max (a, b), c); } F77_INT max (F77_INT a, F77_INT b, F77_INT c, F77_INT d) { return max (max (a, b), max (c, d)); } F77_INT max (F77_INT a, F77_INT b, F77_INT c, F77_INT d, F77_INT e) { return max (max (a, b, c, d), e); } F77_INT min (F77_INT a, F77_INT b) { if (a < b) return a; else return b; } void error_msg (const char name[], octave_idx_type index, octave_idx_type max, const char* msg[]) { if (index == 0) return; std::ostringstream os; if (index < 0) os << name << ": the " << index << "-th argument had an invalid value"; else if (index <= max) os << name << ": " << msg[index]; else os << name << ": unknown error, info = " << index; error ("%s", os.str ().c_str ()); } void warning_msg (const char name[], octave_idx_type index, octave_idx_type max, const char* msg[]) { if (index == 0) return; std::ostringstream os; if (index > 0 && index <= max) os << name << ": " << msg[index]; else os << name << ": unknown warning, iwarn = " << index; warning ("%s", os.str ().c_str ()); } void warning_msg (const char name[], octave_idx_type index, octave_idx_type max, const char* msg[], octave_idx_type offset) { if (index == 0) return; std::ostringstream os; if (index > 0 && index <= max) os << name << ": " << msg[index]; else if (index > offset) os << name << ": " << offset << "+" << (index - offset) << ": " << (index - offset) << " " << msg[max+1]; else os << name << ": unknown warning, iwarn = " << index; warning ("%s", os.str ().c_str ()); } control-4.1.2/src/PaxHeaders/sl_sg03bd.cc0000644000000000000000000000007315012430645015136 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sg03bd.cc0000644000175000017500000001024415012430645016327 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Square-root solver for generalized Lyapunov equations. Uses SLICOT SG03BD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: September 2010 Version: 0.3 */ #include #include "common.h" extern "C" { int F77_FUNC (sg03bd, SG03BD) (char& DICO, char& FACT, char& TRANS, F77_INT& N, F77_INT& M, double* A, F77_INT& LDA, double* E, F77_INT& LDE, double* Q, F77_INT& LDQ, double* Z, F77_INT& LDZ, double* B, F77_INT& LDB, double& SCALE, double* ALPHAR, double* ALPHAI, double* BETA, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sg03bd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sg03bd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sg03bd__ (@dots{})\n" "Wrapper for SLICOT function SG03BD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 4) { print_usage (); } else { // arguments in char dico; char fact = 'N'; char trans = 'N'; Matrix a = args(0).matrix_value (); Matrix e = args(1).matrix_value (); Matrix b = args(2).matrix_value (); F77_INT discrete = args(3).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || e.any_element_is_inf_or_nan ()) error ("__sl_sg03bd__: inputs must not contain NaN or Inf\n"); if (discrete == 0) dico = 'C'; else dico = 'D'; F77_INT n = TO_F77_INT (a.rows ()); F77_INT m = TO_F77_INT (b.rows ()); F77_INT lda = max (1, n); F77_INT lde = max (1, n); F77_INT ldq = max (1, n); F77_INT ldz = max (1, n); F77_INT ldb = max (1, m, n); F77_INT n1 = max (m, n); b.resize (ldb, n1); // arguments out double scale; Matrix q (ldq, n); Matrix z (ldz, n); ColumnVector alphar (n); ColumnVector alphai (n); ColumnVector beta (n); // workspace F77_INT ldwork = 8*n + 16; OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT info; // SLICOT routine SG03BD F77_XFCN (sg03bd, SG03BD, (dico, fact, trans, n, m, a.fortran_vec (), lda, e.fortran_vec (), lde, q.fortran_vec (), ldq, z.fortran_vec (), ldz, b.fortran_vec (), ldb, scale, alphar.fortran_vec (), alphai.fortran_vec (), beta.fortran_vec (), dwork, ldwork, info)); if (f77_exception_encountered) error ("lyap: __sl_sg03bd__: exception in SLICOT subroutine SG03BD"); if (info != 0) error ("lyap: __sl_sg03bd__: SG03BD returned info = %d", static_cast (info)); // resize b.resize (n, n); // return values retval(0) = b; // b has been overwritten by cholesky factor u retval(1) = octave_value (scale); } return retval; } control-4.1.2/src/PaxHeaders/sl_sb10yd.cc0000644000000000000000000000007315012430645015156 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.869132739 control-4.1.2/src/sl_sb10yd.cc0000644000175000017500000001125415012430645016351 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Fit FRD with SS model. Uses SLICOT SB10YD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: October 2011 Version: 0.2 */ #include #include #include "common.h" extern "C" { int F77_FUNC (sb10yd, SB10YD) (F77_INT& DISCFL, F77_INT& FLAG, F77_INT& LENDAT, double* RFRDAT, double* IFRDAT, double* OMEGA, F77_INT& N, double* A, F77_INT& LDA, double* B, double* C, double* D, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, Complex* ZWORK, F77_INT& LZWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb10yd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb10yd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb10yd__ (@dots{})\n" "Wrapper for SLICOT function SB10YD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 6) { print_usage (); } else { // arguments in Matrix rfrdat = args(0).matrix_value (); Matrix ifrdat = args(1).matrix_value (); Matrix omega = args(2).matrix_value (); F77_INT n = args(3).int_value (); F77_INT discfl = args(4).int_value (); F77_INT flag = args(5).int_value (); if (rfrdat.any_element_is_inf_or_nan () || ifrdat.any_element_is_inf_or_nan () || omega.any_element_is_inf_or_nan ()) error ("__sl_sb10yd__: inputs must not contain NaN or Inf\n"); F77_INT lendat = TO_F77_INT (omega.rows ()); // number of frequencies F77_INT lda = max (1, n); // arguments out Matrix a (lda, n); Matrix b (n, 1); Matrix c (1, n); Matrix d (1, 1); // workspace F77_INT liwork = max (2, 2*n + 1); F77_INT ldwork; F77_INT lzwork; F77_INT hnpts = 2048; F77_INT lw1 = 2*lendat + 4*hnpts; F77_INT lw2 = lendat + 6*hnpts; F77_INT mn = min (2*lendat, 2*n+1); F77_INT lw3; F77_INT lw4; if (n > 0) { lw3 = 2*lendat*(2*n+1) + max (2*lendat, 2*n+1) + max (mn + 6*n + 4, 2*mn + 1); lzwork = lendat*(2*n+3); } else { lw3 = 4*lendat + 5; lzwork = lendat; } if (flag == 1) lw4 = max (n*n + 5*n, 6*n + 1 + min (1, n)); else lw4 = 0; ldwork = max (2, lw1, lw2, lw3, lw4); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (Complex, zwork, lzwork); // tolerance double tol = 0; // error indicator F77_INT info; // SLICOT routine SB10YD F77_XFCN (sb10yd, SB10YD, (discfl, flag, lendat, rfrdat.fortran_vec (), ifrdat.fortran_vec (), omega.fortran_vec (), n, a.fortran_vec (), lda, b.fortran_vec (), c.fortran_vec (), d.fortran_vec (), tol, iwork, dwork, ldwork, zwork, lzwork, info)); if (f77_exception_encountered) error ("fitfrd: __sl_sb10yd__: exception in SLICOT subroutine SB10YD"); if (info != 0) error ("fitfrd: __sl_sb10yd__: SB10YD returned info = %d", static_cast (info)); // return values retval(0) = a; retval(1) = b; retval(2) = c; retval(3) = d; retval(4) = octave_value (n); } return retval; } control-4.1.2/src/PaxHeaders/configure0000644000000000000000000000013115012430710014737 xustar0029 mtime=1747595720.64512465 30 atime=1747595720.613123495 30 ctime=1747595720.869132739 control-4.1.2/src/configure0000755000175000017500000040204315012430710016142 0ustar00lilgelilge00000000000000#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.71 for control 4.1.2. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation, # Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else $as_nop case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac test -r "$as_dir$0" && as_myself=$as_dir$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="as_nop=: if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else \$as_nop case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ) then : else \$as_nop exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 blah=\$(echo \$(echo blah)) test x\"\$blah\" = xblah || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null then : as_have_required=yes else $as_nop as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null then : else $as_nop as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$as_shell as_have_required=yes if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null then : break 2 fi fi done;; esac as_found=false done IFS=$as_save_IFS if $as_found then : else $as_nop if { test -f "$SHELL" || test -f "$SHELL.exe"; } && as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$SHELL as_have_required=yes fi fi if test "x$CONFIG_SHELL" != x then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno then : printf "%s\n" "$0: This script requires a shell more modern than all" printf "%s\n" "$0: the shells that I found on your system." if test ${ZSH_VERSION+y} ; then printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should" printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later." else printf "%s\n" "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_nop # --------- # Do nothing but, unlike ":", preserve the value of $?. as_fn_nop () { return $? } as_nop=as_fn_nop # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null then : eval 'as_fn_append () { eval $1+=\$2 }' else $as_nop as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null then : eval 'as_fn_arith () { as_val=$(( $* )) }' else $as_nop as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_nop # --------- # Do nothing but, unlike ":", preserve the value of $?. as_fn_nop () { return $? } as_nop=as_fn_nop # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='control' PACKAGE_TARNAME='control' PACKAGE_VERSION='4.1.2' PACKAGE_STRING='control 4.1.2' PACKAGE_BUGREPORT='' PACKAGE_URL='' ac_unique_file="sl_ab01od.cc" ac_subst_vars='LTLIBOBJS LIBOBJS HAVE_DGGES ac_ct_F77 FFLAGS F77 OBJEXT EXEEXT ac_ct_CXX CPPFLAGS LDFLAGS CXXFLAGS CXX OCTAVE_CONFIG MKOCTFILE target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir runstatedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking ' ac_precious_vars='build_alias host_alias target_alias CXX CXXFLAGS LDFLAGS LIBS CPPFLAGS CCC F77 FFLAGS' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -runstatedir | --runstatedir | --runstatedi | --runstated \ | --runstate | --runstat | --runsta | --runst | --runs \ | --run | --ru | --r) ac_prev=runstatedir ;; -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ | --run=* | --ru=* | --r=*) runstatedir=$ac_optarg ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures control 4.1.2 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/control] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of control 4.1.2:";; esac cat <<\_ACEOF Some influential environment variables: CXX C++ compiler command CXXFLAGS C++ compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory F77 Fortran 77 compiler command FFLAGS Fortran 77 compiler flags Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to the package provider. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for configure.gnu first; this name is used for a wrapper for # Metaconfig's "Configure" on case-insensitive file systems. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF control configure 4.1.2 generated by GNU Autoconf 2.71 Copyright (C) 2021 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_cxx_try_compile LINENO # ---------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_cxx_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest.beam if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_cxx_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext then : ac_retval=0 else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_cxx_try_compile # ac_fn_f77_try_compile LINENO # ---------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_f77_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest.beam if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_f77_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext then : ac_retval=0 else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_f77_try_compile # ac_fn_f77_try_link LINENO # ------------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. ac_fn_f77_try_link () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_f77_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || test -x conftest$ac_exeext } then : ac_retval=0 else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_f77_try_link ac_configure_args_raw= for ac_arg do case $ac_arg in *\'*) ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append ac_configure_args_raw " '$ac_arg'" done case $ac_configure_args_raw in *$as_nl*) ac_safe_unquote= ;; *) ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab. ac_unsafe_a="$ac_unsafe_z#~" ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g" ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;; esac cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by control $as_me 4.1.2, which was generated by GNU Autoconf 2.71. Invocation command line was $ $0$ac_configure_args_raw _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac printf "%s\n" "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Sanitize IFS. IFS=" "" $as_nl" # Save into config.log some information that might help in debugging. { echo printf "%s\n" "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo printf "%s\n" "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then printf "%s\n" "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then printf "%s\n" "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && printf "%s\n" "$as_me: caught signal $ac_signal" printf "%s\n" "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h printf "%s\n" "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. if test -n "$CONFIG_SITE"; then ac_site_files="$CONFIG_SITE" elif test "x$prefix" != xNONE; then ac_site_files="$prefix/share/config.site $prefix/etc/config.site" else ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" fi for ac_site_file in $ac_site_files do case $ac_site_file in #( */*) : ;; #( *) : ac_site_file=./$ac_site_file ;; esac if test -f "$ac_site_file" && test -r "$ac_site_file"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 printf "%s\n" "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 printf "%s\n" "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Test code for whether the C++ compiler supports C++98 (global declarations) ac_cxx_conftest_cxx98_globals=' // Does the compiler advertise C++98 conformance? #if !defined __cplusplus || __cplusplus < 199711L # error "Compiler does not advertise C++98 conformance" #endif // These inclusions are to reject old compilers that // lack the unsuffixed header files. #include #include // and are *not* freestanding headers in C++98. extern void assert (int); namespace std { extern int strcmp (const char *, const char *); } // Namespaces, exceptions, and templates were all added after "C++ 2.0". using std::exception; using std::strcmp; namespace { void test_exception_syntax() { try { throw "test"; } catch (const char *s) { // Extra parentheses suppress a warning when building autoconf itself, // due to lint rules shared with more typical C programs. assert (!(strcmp) (s, "test")); } } template struct test_template { T const val; explicit test_template(T t) : val(t) {} template T add(U u) { return static_cast(u) + val; } }; } // anonymous namespace ' # Test code for whether the C++ compiler supports C++98 (body of main) ac_cxx_conftest_cxx98_main=' assert (argc); assert (! argv[0]); { test_exception_syntax (); test_template tt (2.0); assert (tt.add (4) == 6.0); assert (true && !false); } ' # Test code for whether the C++ compiler supports C++11 (global declarations) ac_cxx_conftest_cxx11_globals=' // Does the compiler advertise C++ 2011 conformance? #if !defined __cplusplus || __cplusplus < 201103L # error "Compiler does not advertise C++11 conformance" #endif namespace cxx11test { constexpr int get_val() { return 20; } struct testinit { int i; double d; }; class delegate { public: delegate(int n) : n(n) {} delegate(): delegate(2354) {} virtual int getval() { return this->n; }; protected: int n; }; class overridden : public delegate { public: overridden(int n): delegate(n) {} virtual int getval() override final { return this->n * 2; } }; class nocopy { public: nocopy(int i): i(i) {} nocopy() = default; nocopy(const nocopy&) = delete; nocopy & operator=(const nocopy&) = delete; private: int i; }; // for testing lambda expressions template Ret eval(Fn f, Ret v) { return f(v); } // for testing variadic templates and trailing return types template auto sum(V first) -> V { return first; } template auto sum(V first, Args... rest) -> V { return first + sum(rest...); } } ' # Test code for whether the C++ compiler supports C++11 (body of main) ac_cxx_conftest_cxx11_main=' { // Test auto and decltype auto a1 = 6538; auto a2 = 48573953.4; auto a3 = "String literal"; int total = 0; for (auto i = a3; *i; ++i) { total += *i; } decltype(a2) a4 = 34895.034; } { // Test constexpr short sa[cxx11test::get_val()] = { 0 }; } { // Test initializer lists cxx11test::testinit il = { 4323, 435234.23544 }; } { // Test range-based for int array[] = {9, 7, 13, 15, 4, 18, 12, 10, 5, 3, 14, 19, 17, 8, 6, 20, 16, 2, 11, 1}; for (auto &x : array) { x += 23; } } { // Test lambda expressions using cxx11test::eval; assert (eval ([](int x) { return x*2; }, 21) == 42); double d = 2.0; assert (eval ([&](double x) { return d += x; }, 3.0) == 5.0); assert (d == 5.0); assert (eval ([=](double x) mutable { return d += x; }, 4.0) == 9.0); assert (d == 5.0); } { // Test use of variadic templates using cxx11test::sum; auto a = sum(1); auto b = sum(1, 2); auto c = sum(1.0, 2.0, 3.0); } { // Test constructor delegation cxx11test::delegate d1; cxx11test::delegate d2(); cxx11test::delegate d3(45); } { // Test override and final cxx11test::overridden o1(55464); } { // Test nullptr char *c = nullptr; } { // Test template brackets test_template<::test_template> v(test_template(12)); } { // Unicode literals char const *utf8 = u8"UTF-8 string \u2500"; char16_t const *utf16 = u"UTF-8 string \u2500"; char32_t const *utf32 = U"UTF-32 string \u2500"; } ' # Test code for whether the C compiler supports C++11 (complete). ac_cxx_conftest_cxx11_program="${ac_cxx_conftest_cxx98_globals} ${ac_cxx_conftest_cxx11_globals} int main (int argc, char **argv) { int ok = 0; ${ac_cxx_conftest_cxx98_main} ${ac_cxx_conftest_cxx11_main} return ok; } " # Test code for whether the C compiler supports C++98 (complete). ac_cxx_conftest_cxx98_program="${ac_cxx_conftest_cxx98_globals} int main (int argc, char **argv) { int ok = 0; ${ac_cxx_conftest_cxx98_main} return ok; } " # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 printf "%s\n" "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_config_headers="$ac_config_headers config.h" # Avoid warnings for redefining AH-generated preprocessor symbols of # Octave. # Checks for programs. # Extract the first word of "mkoctfile", so it can be a program name with args. set dummy mkoctfile; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_MKOCTFILE+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$MKOCTFILE"; then ac_cv_prog_MKOCTFILE="$MKOCTFILE" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_MKOCTFILE="mkoctfile" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi MKOCTFILE=$ac_cv_prog_MKOCTFILE if test -n "$MKOCTFILE"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MKOCTFILE" >&5 printf "%s\n" "$MKOCTFILE" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test -z "$MKOCTFILE"; then as_fn_error 1 "mkoctfile not found" "$LINENO" 5; fi # Extract the first word of "octave-config", so it can be a program name with args. set dummy octave-config; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_OCTAVE_CONFIG+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$OCTAVE_CONFIG"; then ac_cv_prog_OCTAVE_CONFIG="$OCTAVE_CONFIG" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_OCTAVE_CONFIG="octave-config" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi OCTAVE_CONFIG=$ac_cv_prog_OCTAVE_CONFIG if test -n "$OCTAVE_CONFIG"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $OCTAVE_CONFIG" >&5 printf "%s\n" "$OCTAVE_CONFIG" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test -z "$OCTAVE_CONFIG"; then as_fn_error 1 "octave-config not found" "$LINENO" 5; fi ac_ext=cpp ac_cpp='$CXXCPP $CPPFLAGS' ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_cxx_compiler_gnu if test -z "$CXX"; then if test -n "$CCC"; then CXX=$CCC else if test -n "$ac_tool_prefix"; then for ac_prog in g++ c++ gpp aCC CC cxx cc++ cl.exe FCC KCC RCC xlC_r xlC clang++ do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CXX+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CXX"; then ac_cv_prog_CXX="$CXX" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CXX="$ac_tool_prefix$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CXX=$ac_cv_prog_CXX if test -n "$CXX"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CXX" >&5 printf "%s\n" "$CXX" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$CXX" && break done fi if test -z "$CXX"; then ac_ct_CXX=$CXX for ac_prog in g++ c++ gpp aCC CC cxx cc++ cl.exe FCC KCC RCC xlC_r xlC clang++ do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CXX+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$ac_ct_CXX"; then ac_cv_prog_ac_ct_CXX="$ac_ct_CXX" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CXX="$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CXX=$ac_cv_prog_ac_ct_CXX if test -n "$ac_ct_CXX"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CXX" >&5 printf "%s\n" "$ac_ct_CXX" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$ac_ct_CXX" && break done if test "x$ac_ct_CXX" = x; then CXX="g++" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CXX=$ac_ct_CXX fi fi fi fi # Provide some information about the compiler. printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C++ compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C++ compiler works" >&5 printf %s "checking whether the C++ compiler works... " >&6; } ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else $as_nop ac_file='' fi if test -z "$ac_file" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "C++ compiler cannot create executables See \`config.log' for more details" "$LINENO" 5; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C++ compiler default output file name" >&5 printf %s "checking for C++ compiler default output file name... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 printf "%s\n" "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 printf %s "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else $as_nop { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 printf "%s\n" "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { FILE *f = fopen ("conftest.out", "w"); return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 printf %s "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot run C++ compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 printf "%s\n" "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 printf %s "checking for suffix of object files... " >&6; } if test ${ac_cv_objext+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 printf "%s\n" "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C++" >&5 printf %s "checking whether the compiler supports GNU C++... " >&6; } if test ${ac_cv_cxx_compiler_gnu+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : ac_compiler_gnu=yes else $as_nop ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_cxx_compiler_gnu=$ac_compiler_gnu fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cxx_compiler_gnu" >&5 printf "%s\n" "$ac_cv_cxx_compiler_gnu" >&6; } ac_compiler_gnu=$ac_cv_cxx_compiler_gnu if test $ac_compiler_gnu = yes; then GXX=yes else GXX= fi ac_test_CXXFLAGS=${CXXFLAGS+y} ac_save_CXXFLAGS=$CXXFLAGS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CXX accepts -g" >&5 printf %s "checking whether $CXX accepts -g... " >&6; } if test ${ac_cv_prog_cxx_g+y} then : printf %s "(cached) " >&6 else $as_nop ac_save_cxx_werror_flag=$ac_cxx_werror_flag ac_cxx_werror_flag=yes ac_cv_prog_cxx_g=no CXXFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : ac_cv_prog_cxx_g=yes else $as_nop CXXFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : else $as_nop ac_cxx_werror_flag=$ac_save_cxx_werror_flag CXXFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : ac_cv_prog_cxx_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cxx_werror_flag=$ac_save_cxx_werror_flag fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_g" >&5 printf "%s\n" "$ac_cv_prog_cxx_g" >&6; } if test $ac_test_CXXFLAGS; then CXXFLAGS=$ac_save_CXXFLAGS elif test $ac_cv_prog_cxx_g = yes; then if test "$GXX" = yes; then CXXFLAGS="-g -O2" else CXXFLAGS="-g" fi else if test "$GXX" = yes; then CXXFLAGS="-O2" else CXXFLAGS= fi fi ac_prog_cxx_stdcxx=no if test x$ac_prog_cxx_stdcxx = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CXX option to enable C++11 features" >&5 printf %s "checking for $CXX option to enable C++11 features... " >&6; } if test ${ac_cv_prog_cxx_cxx11+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cxx_cxx11=no ac_save_CXX=$CXX cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_cxx_conftest_cxx11_program _ACEOF for ac_arg in '' -std=gnu++11 -std=gnu++0x -std=c++11 -std=c++0x -qlanglvl=extended0x -AA do CXX="$ac_save_CXX $ac_arg" if ac_fn_cxx_try_compile "$LINENO" then : ac_cv_prog_cxx_cxx11=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cxx_cxx11" != "xno" && break done rm -f conftest.$ac_ext CXX=$ac_save_CXX fi if test "x$ac_cv_prog_cxx_cxx11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cxx_cxx11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_cxx11" >&5 printf "%s\n" "$ac_cv_prog_cxx_cxx11" >&6; } CXX="$CXX $ac_cv_prog_cxx_cxx11" fi ac_cv_prog_cxx_stdcxx=$ac_cv_prog_cxx_cxx11 ac_prog_cxx_stdcxx=cxx11 fi fi if test x$ac_prog_cxx_stdcxx = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CXX option to enable C++98 features" >&5 printf %s "checking for $CXX option to enable C++98 features... " >&6; } if test ${ac_cv_prog_cxx_cxx98+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cxx_cxx98=no ac_save_CXX=$CXX cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_cxx_conftest_cxx98_program _ACEOF for ac_arg in '' -std=gnu++98 -std=c++98 -qlanglvl=extended -AA do CXX="$ac_save_CXX $ac_arg" if ac_fn_cxx_try_compile "$LINENO" then : ac_cv_prog_cxx_cxx98=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cxx_cxx98" != "xno" && break done rm -f conftest.$ac_ext CXX=$ac_save_CXX fi if test "x$ac_cv_prog_cxx_cxx98" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cxx_cxx98" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_cxx98" >&5 printf "%s\n" "$ac_cv_prog_cxx_cxx98" >&6; } CXX="$CXX $ac_cv_prog_cxx_cxx98" fi ac_cv_prog_cxx_stdcxx=$ac_cv_prog_cxx_cxx98 ac_prog_cxx_stdcxx=cxx98 fi fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # Start of checks for Octave features, preparations for checks. OCTLIBDIR=${OCTLIBDIR:-`$OCTAVE_CONFIG -p OCTLIBDIR`} ## We need Octaves include path both with and without '/octave' ## appended. The path without '/octave' is needed to selectively test ## for Octave headers, like octave/....h. The path with '/octave' is ## needed since some Octave headers contain include directives for ## other Octave headers with <> instead of "". OCTINCLUDEDIR=${OCTINCLUDEDIR:-`$MKOCTFILE -p INCFLAGS`} ac_ext=cpp ac_cpp='$CXXCPP $CPPFLAGS' ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_cxx_compiler_gnu TCXXFLAGS=$CXXFLAGS TLDFLAGS=$LDFLAGS TLIBS=$LIBS TCPPFLAGS=$CPPFLAGS LDFLAGS="-L$OCTLIBDIR $LDFLAGS" LIBS="-loctinterp $LIBS" # CXXFLAGS= CPPFLAGS="$OCTINCLUDEDIR $CPPFLAGS" ## Simple symbol alternatives of different Octave versions. echo '/* generated by configure */' > oct-alt-includes.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking is_real_type or isreal" >&5 printf %s "checking is_real_type or isreal... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { octave_value ().isreal (); ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : printf "%s\n" "#define OV_ISREAL isreal" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: isreal" >&5 printf "%s\n" "isreal" >&6; } echo ' ' >> oct-alt-includes.h else $as_nop printf "%s\n" "#define OV_ISREAL is_real_type" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: is_real_type" >&5 printf "%s\n" " is_real_type" >&6; } echo '' >> oct-alt-includes.h fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking is_cell or iscell" >&5 printf %s "checking is_cell or iscell... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { octave_value ().iscell (); ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : printf "%s\n" "#define OV_ISCELL iscell" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: iscell" >&5 printf "%s\n" "iscell" >&6; } echo ' ' >> oct-alt-includes.h else $as_nop printf "%s\n" "#define OV_ISCELL is_cell" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: is_cell" >&5 printf "%s\n" " is_cell" >&6; } echo '' >> oct-alt-includes.h fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking is_object or isobject" >&5 printf %s "checking is_object or isobject... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { octave_value ().isobject (); ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : printf "%s\n" "#define OV_ISOBJECT isobject" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: isobject" >&5 printf "%s\n" "isobject" >&6; } echo ' ' >> oct-alt-includes.h else $as_nop printf "%s\n" "#define OV_ISOBJECT is_object" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: is_object" >&5 printf "%s\n" " is_object" >&6; } echo '' >> oct-alt-includes.h fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking is_complex_type or iscomplex" >&5 printf %s "checking is_complex_type or iscomplex... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { octave_value ().iscomplex (); ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : printf "%s\n" "#define OV_ISCOMPLEX iscomplex" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: iscomplex" >&5 printf "%s\n" "iscomplex" >&6; } echo ' ' >> oct-alt-includes.h else $as_nop printf "%s\n" "#define OV_ISCOMPLEX is_complex_type" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: is_complex_type" >&5 printf "%s\n" " is_complex_type" >&6; } echo '' >> oct-alt-includes.h fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking is_numeric_type or isnumeric" >&5 printf %s "checking is_numeric_type or isnumeric... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { octave_value ().isnumeric (); ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : printf "%s\n" "#define OV_ISNUMERIC isnumeric" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: isnumeric" >&5 printf "%s\n" "isnumeric" >&6; } echo ' ' >> oct-alt-includes.h else $as_nop printf "%s\n" "#define OV_ISNUMERIC is_numeric_type" >>confdefs.h { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: is_numeric_type" >&5 printf "%s\n" " is_numeric_type" >&6; } echo '' >> oct-alt-includes.h fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext LIBS=$TLIBS LDFLAGS=$TLDFLAGS CXXFLAGS=$TCXXFLAGS CPPFLAGS=$TCPPFLAGS ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # End of checks for Octave features. # Test for newer DGGES routine in LAPACK ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_f77_compiler_gnu ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_f77_compiler_gnu if test -n "$ac_tool_prefix"; then for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_F77+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$F77"; then ac_cv_prog_F77="$F77" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_F77="$ac_tool_prefix$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi F77=$ac_cv_prog_F77 if test -n "$F77"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $F77" >&5 printf "%s\n" "$F77" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$F77" && break done fi if test -z "$F77"; then ac_ct_F77=$F77 for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn nagfor do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_F77+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$ac_ct_F77"; then ac_cv_prog_ac_ct_F77="$ac_ct_F77" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_F77="$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_F77=$ac_cv_prog_ac_ct_F77 if test -n "$ac_ct_F77"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_F77" >&5 printf "%s\n" "$ac_ct_F77" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$ac_ct_F77" && break done if test "x$ac_ct_F77" = x; then F77="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac F77=$ac_ct_F77 fi fi # Provide some information about the compiler. printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Fortran 77 compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done rm -f a.out # If we don't use `.F' as extension, the preprocessor is not run on the # input file. (Note that this only needs to work for GNU compilers.) ac_save_ext=$ac_ext ac_ext=F { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU Fortran 77" >&5 printf %s "checking whether the compiler supports GNU Fortran 77... " >&6; } if test ${ac_cv_f77_compiler_gnu+y} then : printf %s "(cached) " >&6 else $as_nop cat > conftest.$ac_ext <<_ACEOF program main #ifndef __GNUC__ choke me #endif end _ACEOF if ac_fn_f77_try_compile "$LINENO" then : ac_compiler_gnu=yes else $as_nop ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_f77_compiler_gnu=$ac_compiler_gnu fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_f77_compiler_gnu" >&5 printf "%s\n" "$ac_cv_f77_compiler_gnu" >&6; } ac_compiler_gnu=$ac_cv_f77_compiler_gnu ac_ext=$ac_save_ext ac_test_FFLAGS=${FFLAGS+y} ac_save_FFLAGS=$FFLAGS FFLAGS= { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $F77 accepts -g" >&5 printf %s "checking whether $F77 accepts -g... " >&6; } if test ${ac_cv_prog_f77_g+y} then : printf %s "(cached) " >&6 else $as_nop FFLAGS=-g cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF if ac_fn_f77_try_compile "$LINENO" then : ac_cv_prog_f77_g=yes else $as_nop ac_cv_prog_f77_g=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_f77_g" >&5 printf "%s\n" "$ac_cv_prog_f77_g" >&6; } if test $ac_test_FFLAGS; then FFLAGS=$ac_save_FFLAGS elif test $ac_cv_prog_f77_g = yes; then if test "x$ac_cv_f77_compiler_gnu" = xyes; then FFLAGS="-g -O2" else FFLAGS="-g" fi else if test "x$ac_cv_f77_compiler_gnu" = xyes; then FFLAGS="-O2" else FFLAGS= fi fi if test $ac_compiler_gnu = yes; then G77=yes else G77= fi ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_f77_compiler_gnu { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for library containing dgges" >&5 printf %s "checking for library containing dgges... " >&6; } if test ${ac_cv_search_dgges+y} then : printf %s "(cached) " >&6 else $as_nop ac_func_search_save_LIBS=$LIBS cat > conftest.$ac_ext <<_ACEOF program main call dgges end _ACEOF for ac_lib in '' lapack do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi if ac_fn_f77_try_link "$LINENO" then : ac_cv_search_dgges=$ac_res fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext if test ${ac_cv_search_dgges+y} then : break fi done if test ${ac_cv_search_dgges+y} then : else $as_nop ac_cv_search_dgges=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_dgges" >&5 printf "%s\n" "$ac_cv_search_dgges" >&6; } ac_res=$ac_cv_search_dgges if test "$ac_res" != no then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" HAVE_DGGES=1 else $as_nop HAVE_DGGES=0 fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # Output results and subst variables in Makefile.conf.in ac_config_files="$ac_config_files Makefile.conf" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 printf "%s\n" "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' DEFS=-DHAVE_CONFIG_H ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`printf "%s\n" "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else $as_nop case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac test -r "$as_dir$0" && as_myself=$as_dir$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null then : eval 'as_fn_append () { eval $1+=\$2 }' else $as_nop as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null then : eval 'as_fn_arith () { as_val=$(( $* )) }' else $as_nop as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by control $as_me 4.1.2, which was generated by GNU Autoconf 2.71. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac case $ac_config_headers in *" "*) set x $ac_config_headers; shift; ac_config_headers=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" config_headers="$ac_config_headers" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE --header=FILE[:TEMPLATE] instantiate the configuration header FILE Configuration files: $config_files Configuration headers: $config_headers Report bugs to the package provider." _ACEOF ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ control config.status 4.1.2 configured by $0, generated by GNU Autoconf 2.71, with options \\"\$ac_cs_config\\" Copyright (C) 2021 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) printf "%s\n" "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) printf "%s\n" "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append CONFIG_HEADERS " '$ac_optarg'" ac_need_defaults=false;; --he | --h) # Conflict between --help and --header as_fn_error $? "ambiguous option: \`$1' Try \`$0 --help' for more information.";; --help | --hel | -h ) printf "%s\n" "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX printf "%s\n" "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; "Makefile.conf") CONFIG_FILES="$CONFIG_FILES Makefile.conf" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test ${CONFIG_FILES+y} || CONFIG_FILES=$config_files test ${CONFIG_HEADERS+y} || CONFIG_HEADERS=$config_headers fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$ac_tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF # Transform confdefs.h into an awk script `defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. # Create a delimiter string that does not exist in confdefs.h, to ease # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do ac_tt=`sed -n "/$ac_delim/p" confdefs.h` if test -z "$ac_tt"; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done # For the awk script, D is an array of macro values keyed by name, # likewise P contains macro parameters if any. Preserve backslash # newline sequences. ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* sed -n ' s/.\{148\}/&'"$ac_delim"'/g t rset :rset s/^[ ]*#[ ]*define[ ][ ]*/ / t def d :def s/\\$// t bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3"/p s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p d :bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3\\\\\\n"\\/p t cont s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p t cont d :cont n s/.\{148\}/&'"$ac_delim"'/g t clear :clear s/\\$// t bsnlc s/["\\]/\\&/g; s/^/"/; s/$/"/p d :bsnlc s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p b cont ' >$CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 for (key in D) D_is_set[key] = 1 FS = "" } /^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { line = \$ 0 split(line, arg, " ") if (arg[1] == "#") { defundef = arg[2] mac1 = arg[3] } else { defundef = substr(arg[1], 2) mac1 = arg[2] } split(mac1, mac2, "(") #) macro = mac2[1] prefix = substr(line, 1, index(line, defundef) - 1) if (D_is_set[macro]) { # Preserve the white space surrounding the "#". print prefix "define", macro P[macro] D[macro] next } else { # Replace #undef with comments. This is necessary, for example, # in the case of _POSIX_SOURCE, which is predefined and required # on some systems where configure will not decide to define it. if (defundef == "undef") { print "/*", prefix defundef, macro, "*/" next } } } { print } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 fi # test -n "$CONFIG_HEADERS" eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 printf "%s\n" "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`printf "%s\n" "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; :H) # # CONFIG_HEADER # if test x"$ac_file" != x-; then { printf "%s\n" "/* $configure_input */" >&1 \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" } >"$ac_tmp/config.h" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 printf "%s\n" "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" mv "$ac_tmp/config.h" "$ac_file" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 fi else printf "%s\n" "/* $configure_input */" >&1 \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ || as_fn_error $? "could not create -" "$LINENO" 5 fi ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi control-4.1.2/src/PaxHeaders/sl_ab09jd.cc0000644000000000000000000000007415012430645015126 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/sl_ab09jd.cc0000644000175000017500000003237015012430645016322 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Model reduction based on Hankel-norm approximation method. Uses SLICOT AB09JD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: July 2011 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (ab09jd, AB09JD) (char& JOBV, char& JOBW, char& JOBINV, char& DICO, char& EQUIL, char& ORDSEL, F77_INT& N, F77_INT& NV, F77_INT& NW, F77_INT& M, F77_INT& P, F77_INT& NR, double& ALPHA, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* AV, F77_INT& LDAV, double* BV, F77_INT& LDBV, double* CV, F77_INT& LDCV, double* DV, F77_INT& LDDV, double* AW, F77_INT& LDAW, double* BW, F77_INT& LDBW, double* CW, F77_INT& LDCW, double* DW, F77_INT& LDDW, F77_INT& NS, double* HSV, double& TOL1, double& TOL2, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ab09jd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ab09jd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ab09jd__ (@dots{})\n" "Wrapper for SLICOT function AB09JD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 22) { print_usage (); } else { // arguments in char jobv; char jobw; char jobinv; char dico; char equil; char ordsel; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_ab09jd__: inputs must not contain NaN or Inf\n"); const F77_INT idico = args(4).int_value (); const F77_INT iequil = args(5).int_value (); F77_INT nr = args(6).int_value (); const F77_INT iordsel = args(7).int_value (); double alpha = args(8).double_value (); const F77_INT ijobv = args(9).int_value (); Matrix av = args(10).matrix_value (); Matrix bv = args(11).matrix_value (); Matrix cv = args(12).matrix_value (); Matrix dv = args(13).matrix_value (); if (av.any_element_is_inf_or_nan () || bv.any_element_is_inf_or_nan () || cv.any_element_is_inf_or_nan () || dv.any_element_is_inf_or_nan ()) error ("__sl_ab09jd__: inputs must not contain NaN or Inf\n"); const F77_INT ijobw = args(14).int_value (); Matrix aw = args(15).matrix_value (); Matrix bw = args(16).matrix_value (); Matrix cw = args(17).matrix_value (); Matrix dw = args(18).matrix_value (); if (aw.any_element_is_inf_or_nan () || bw.any_element_is_inf_or_nan () || cw.any_element_is_inf_or_nan () || dw.any_element_is_inf_or_nan ()) error ("__sl_ab09jd__: inputs must not contain NaN or Inf\n"); const F77_INT ijobinv = args(19).int_value (); double tol1 = args(20).double_value (); double tol2 = args(21).double_value (); switch (ijobv) { case 0: jobv = 'N'; break; case 1: jobv = 'V'; break; case 2: jobv = 'I'; break; case 3: jobv = 'C'; break; case 4: jobv = 'R'; break; default: error ("__sl_ab09jd__: argument jobv invalid"); } switch (ijobw) { case 0: jobw = 'N'; break; case 1: jobw = 'W'; break; case 2: jobw = 'I'; break; case 3: jobw = 'C'; break; case 4: jobw = 'R'; break; default: error ("__sl_ab09jd__: argument jobw invalid"); } switch (ijobinv) { case 0: jobinv = 'N'; break; case 1: jobinv = 'I'; break; case 2: jobinv = 'A'; break; default: error ("__sl_ab09jd__: argument jobinv invalid"); } if (idico == 0) dico = 'C'; else dico = 'D'; if (iequil == 0) equil = 'S'; else equil = 'N'; if (iordsel == 0) ordsel = 'F'; else ordsel = 'A'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT nv = TO_F77_INT (av.rows ()); F77_INT nw = TO_F77_INT (aw.rows ()); F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); F77_INT ldd = max (1, p); F77_INT ldav = max (1, nv); F77_INT ldbv = max (1, nv); F77_INT ldcv = max (1, p); F77_INT lddv = max (1, p); F77_INT ldaw = max (1, nw); F77_INT ldbw = max (1, nw); F77_INT ldcw = max (1, m); F77_INT lddw = max (1, m); // arguments out F77_INT ns; ColumnVector hsv (n); // workspace F77_INT liwork; F77_INT tmpc; F77_INT tmpd; if (jobv == 'N') tmpc = 0; else tmpc = max (2*p, nv+p+n+6, 2*nv+p+2); if (jobw == 'N') tmpd = 0; else tmpd = max (2*m, nw+m+n+6, 2*nw+m+2); if (dico == 'C') liwork = max (1, m, tmpc, tmpd); else liwork = max (1, n, m, tmpc, tmpd); F77_INT ldwork; F77_INT nvp = nv + p; F77_INT nwm = nw + m; F77_INT ldw1; F77_INT ldw2; F77_INT ldw3 = n*(2*n + max (n, m, p) + 5) + n*(n+1)/2; F77_INT ldw4 = n*(m+p+2) + 2*m*p + min (n, m) + max (3*m+1, min (n, m) + p); if (jobv == 'N') { ldw1 = 0; } else { ldw1 = 2*nvp*(nvp+p) + p*p + max (2*nvp*nvp + max (11*nvp+16, p*nvp), nvp*n + max (nvp*n+n*n, p*n, p*m)); } if (jobw == 'N') { ldw2 = 0; } else { ldw2 = 2*nwm*(nwm+m) + m*m + max (2*nwm*nwm + max (11*nwm+16, m*nwm), nwm*n + max (nwm*n+n*n, m*n, p*m)); } ldwork = max (ldw1, ldw2, ldw3, ldw4); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT iwarn = 0; F77_INT info = 0; // SLICOT routine AB09JD F77_XFCN (ab09jd, AB09JD, (jobv, jobw, jobinv, dico, equil, ordsel, n, nv, nw, m, p, nr, alpha, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, av.fortran_vec (), ldav, bv.fortran_vec (), ldbv, cv.fortran_vec (), ldcv, dv.fortran_vec (), lddv, aw.fortran_vec (), ldaw, bw.fortran_vec (), ldbw, cw.fortran_vec (), ldcw, dw.fortran_vec (), lddw, ns, hsv.fortran_vec (), tol1, tol2, iwork, dwork, ldwork, iwarn, info)); if (f77_exception_encountered) error ("hnamodred: exception in SLICOT subroutine AB09JD"); static const char* err_msg[] = { "0: OK", "1: the computation of the ordered real Schur form of A " "failed", "2: the separation of the ALPHA-stable/unstable " "diagonal blocks failed because of very close eigenvalues", "3: the reduction of AV to a real Schur form failed", "4: the reduction of AW to a real Schur form failed", "5: the reduction to generalized Schur form of the " "descriptor pair corresponding to the inverse of V " "failed", "6: the reduction to generalized Schur form of the " "descriptor pair corresponding to the inverse of W " "failed", "7: the computation of Hankel singular values failed", "8: the computation of stable projection in the " "Hankel-norm approximation algorithm failed", "9: the order of computed stable projection in the " "Hankel-norm approximation algorithm differs " "from the order of Hankel-norm approximation", "10: the reduction of AV-BV*inv(DV)*CV to a " "real Schur form failed", "11: the reduction of AW-BW*inv(DW)*CW to a " "real Schur form failed", "12: the solution of the Sylvester equation failed " "because the poles of V (if JOBV = 'V') or of " "conj(V) (if JOBV = 'C') are not distinct from " "the poles of G1 (see METHOD)", "13: the solution of the Sylvester equation failed " "because the poles of W (if JOBW = 'W') or of " "conj(W) (if JOBW = 'C') are not distinct from " "the poles of G1 (see METHOD)", "14: the solution of the Sylvester equation failed " "because the zeros of V (if JOBV = 'I') or of " "conj(V) (if JOBV = 'R') are not distinct from " "the poles of G1sr (see METHOD)", "15: the solution of the Sylvester equation failed " "because the zeros of W (if JOBW = 'I') or of " "conj(W) (if JOBW = 'R') are not distinct from " "the poles of G1sr (see METHOD)", "16: the solution of the generalized Sylvester system " "failed because the zeros of V (if JOBV = 'I') or " "of conj(V) (if JOBV = 'R') are not distinct from " "the poles of G1sr (see METHOD)", "17: the solution of the generalized Sylvester system " "failed because the zeros of W (if JOBW = 'I') or " "of conj(W) (if JOBW = 'R') are not distinct from " "the poles of G1sr (see METHOD)", "18: op(V) is not antistable", "19: op(W) is not antistable", "20: V is not invertible", "21: W is not invertible"}; static const char* warn_msg[] = { "0: OK", "1: with ORDSEL = 'F', the selected order NR is greater " "than NSMIN, the sum of the order of the " "ALPHA-unstable part and the order of a minimal " "realization of the ALPHA-stable part of the given " "system. In this case, the resulting NR is set equal " "to NSMIN.", "2: with ORDSEL = 'F', the selected order NR is less " "than the order of the ALPHA-unstable part of the " "given system. In this case NR is set equal to the " "order of the ALPHA-unstable part."}; error_msg ("hnamodred", info, 21, err_msg); warning_msg ("hnamodred", iwarn, 2, warn_msg); // resize a.resize (nr, nr); b.resize (nr, m); c.resize (p, nr); hsv.resize (ns); // return values retval(0) = a; retval(1) = b; retval(2) = c; retval(3) = d; retval(4) = octave_value (nr); retval(5) = hsv; retval(6) = octave_value (ns); } return retval; } control-4.1.2/src/PaxHeaders/TG04BX.f0000644000000000000000000000007415012430645014127 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.869132739 control-4.1.2/src/TG04BX.f0000644000175000017500000002066415012430645015326 0ustar00lilgelilge00000000000000 SUBROUTINE TG04BX( IP, IZ, A, LDA, E, B, C, D, PR, PI, ZR, ZI, $ GAIN, IWORK ) C C WARNING C C This routine is a modified version of TB04BX. It is intended C for the Octave Control Systems Package and supports Descriptor C State-Space models. TG04BX is *NOT* part of SLICOT and the C authors from NICONET e.V. are *NOT* responsible for it. C See file DESCRIPTION for the current maintainer of the Octave C control package. 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 . C C PURPOSE C C To compute the gain of a single-input single-output linear system, C given its state-space representation (A,b,c,d), and its poles and C zeros. The matrix A is assumed to be in an upper Hessenberg form. C The gain is computed using the formula C C -1 IP IZ C g = (c*( S0*E - A ) *b + d)*Prod( S0 - Pi )/Prod( S0 - Zi ) , C i=1 i=1 (1) C C where Pi, i = 1 : IP, and Zj, j = 1 : IZ, are the poles and zeros, C respectively, and S0 is a real scalar different from all poles and C zeros. C C ARGUMENTS C C Input/Output Parameters C C IP (input) INTEGER C The number of the system poles. IP >= 0. C C IZ (input) INTEGER C The number of the system zeros. IZ >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,IP) C On entry, the leading IP-by-IP part of this array must C contain the state dynamics matrix A in an upper Hessenberg C form. The elements below the second diagonal are not C referenced. C On exit, the leading IP-by-IP upper Hessenberg part of C this array contains the LU factorization of the matrix C A - S0*I, as computed by SLICOT Library routine MB02SD. C C LDA INTEGER C The leading dimension of array A. LDA >= max(1,IP). C C B (input/output) DOUBLE PRECISION array, dimension (IP) C On entry, this array must contain the system input C vector b. C On exit, this array contains the solution of the linear C system ( A - S0*I )x = b . C C C (input) DOUBLE PRECISION array, dimension (IP) C This array must contain the system output vector c. C C D (input) DOUBLE PRECISION C The variable must contain the system feedthrough scalar d. C C PR (input) DOUBLE PRECISION array, dimension (IP) C This array must contain the real parts of the system C poles. Pairs of complex conjugate poles must be stored in C consecutive memory locations. C C PI (input) DOUBLE PRECISION array, dimension (IP) C This array must contain the imaginary parts of the system C poles. C C ZR (input) DOUBLE PRECISION array, dimension (IZ) C This array must contain the real parts of the system C zeros. Pairs of complex conjugate zeros must be stored in C consecutive memory locations. C C ZI (input) DOUBLE PRECISION array, dimension (IZ) C This array must contain the imaginary parts of the system C zeros. C C GAIN (output) DOUBLE PRECISION C The gain of the linear system (A,b,c,d), given by (1). C C Workspace C C IWORK INTEGER array, dimension (IP) C On exit, it contains the pivot indices; for 1 <= i <= IP, C row i of the matrix A - S0*I was interchanged with C row IWORK(i). C C METHOD C C The routine implements the method presented in [1]. A suitable C value of S0 is chosen based on the system poles and zeros. C Then, the LU factorization of the upper Hessenberg, nonsingular C matrix A - S0*I is computed and used to solve the linear system C in (1). C C REFERENCES C C [1] Varga, A. and Sima, V. C Numerically Stable Algorithm for Transfer Function Matrix C Evaluation. C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. C C NUMERICAL ASPECTS C C The algorithm is numerically stable in practice and requires C O(IP*IP) floating point operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, May 2002. C Partly based on the BIMASC Library routine GAIN by A. Varga. C C REVISIONS C C 2011-02-08 (Lukas Reichlin) Modifications for Descriptor Systems. C C KEYWORDS C C Eigenvalue, state-space representation, transfer function, zeros. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, P1, ONEP1 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ P1 = 0.1D0, ONEP1 = 1.1D0 ) C .. Scalar Arguments .. DOUBLE PRECISION D, GAIN INTEGER IP, IZ, LDA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), E(LDA,*), B(*), C(*), PI(*), PR(*), $ ZI(*), ZR(*) INTEGER IWORK(*) C .. Local Scalars .. INTEGER I, J, INFO DOUBLE PRECISION S0, S C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. External Subroutines .. C EXTERNAL MB02RD, MB02SD EXTERNAL DGETRF, DGETRS C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. C .. Executable Statements .. C C For efficiency, the input scalar parameters are not checked. C C Quick return if possible. C C IF( IP.EQ.0 ) THEN C GAIN = ZERO C RETURN C END IF C C Compute a suitable value for S0 . C S0 = ZERO C DO 10 I = 1, IP S = ABS( PR(I) ) IF ( PI(I).NE.ZERO ) $ S = S + ABS( PI(I) ) S0 = MAX( S0, S ) 10 CONTINUE C DO 20 I = 1, IZ S = ABS( ZR(I) ) IF ( ZI(I).NE.ZERO ) $ S = S + ABS( ZI(I) ) S0 = MAX( S0, S ) 20 CONTINUE C S0 = TWO*S0 + P1 IF ( S0.LE.ONE ) $ S0 = ONEP1 C C Form A - S0*E . C DO 30 J = 1, LDA DO 25 I = 1, LDA A(I,J) = A(I,J) - S0*E(I,J) 25 CONTINUE 30 CONTINUE C C Compute the LU factorization of the matrix A - S0*E C (guaranteed to be nonsingular). C C CALL MB02SD( IP, A, LDA, IWORK, INFO ) C CALL MB02SD( LDA, A, LDA, IWORK, INFO )oo CALL DGETRF( LDA, LDA, A, LDA, IWORK, INFO) C C Solve the linear system (A - S0*E)*x = b . C C CALL MB02RD( 'No Transpose', IP, 1, A, LDA, IWORK, B, IP, INFO ) C CALL MB02RD( 'No Transpose', IP, 1, A, LDA, IWORK, B, LDA, INFO ) C CALL MB02RD( 'No Transpose', LDA, 1, A, LDA, IWORK, B, LDA, INFO ) CALL DGETRS( 'No Transpose', LDA, 1, A, LDA, IWORK, B, LDA, INFO ) C -1 C Compute c*(S0*E - A) *b + d . C C GAIN = D - DDOT( IP, C, 1, B, 1 ) GAIN = D - DDOT( LDA, C, 1, B, 1 ) C C Multiply by the products in terms of poles and zeros in (1). C I = 1 C C WHILE ( I <= IP ) DO C 40 IF ( I.LE.IP ) THEN IF ( PI(I).EQ.ZERO ) THEN GAIN = GAIN*( S0 - PR(I) ) I = I + 1 ELSE GAIN = GAIN*( S0*( S0 - TWO*PR(I) ) + PR(I)**2 + PI(I)**2 ) I = I + 2 END IF GO TO 40 END IF C C END WHILE 40 C I = 1 C C WHILE ( I <= IZ ) DO C 50 IF ( I.LE.IZ ) THEN IF ( ZI(I).EQ.ZERO ) THEN GAIN = GAIN/( S0 - ZR(I) ) I = I + 1 ELSE GAIN = GAIN/( S0*( S0 - TWO*ZR(I) ) + ZR(I)**2 + ZI(I)**2 ) I = I + 2 END IF GO TO 50 END IF C C END WHILE 50 C RETURN C *** Last line of TG04BX *** END control-4.1.2/src/PaxHeaders/slicot0000644000000000000000000000013215012430707014262 xustar0030 mtime=1747595719.993101108 30 atime=1747595720.869132739 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/0000755000175000017500000000000015012430707015533 5ustar00lilgelilge00000000000000control-4.1.2/src/slicot/PaxHeaders/src0000644000000000000000000000013215012430707015051 xustar0030 mtime=1747595719.993101108 30 atime=1747595720.869132739 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/0000755000175000017500000000000015012430707016322 5ustar00lilgelilge00000000000000control-4.1.2/src/slicot/src/PaxHeaders/AB08MD.f0000644000000000000000000000013215012430707016150 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB08MD.f0000644000175000017500000002233415012430707017350 0ustar00lilgelilge00000000000000 SUBROUTINE AB08MD( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ RANK, TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the normal rank of the transfer-function matrix of a C state-space model (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 RANK (output) INTEGER C The normal rank of the transfer-function matrix. 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 (2*N+MAX(M,P)+1) 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 >= (N+P)*(N+M) + C MAX( MIN(P,M) + MAX(3*M-1,N), 1, 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 METHOD C C The routine reduces the (N+P)-by-(M+N) compound matrix (B A) C (D C) C C to one with the same invariant zeros and with D of full row rank. C The normal rank of the transfer-function matrix is the rank of D. 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 CONTRIBUTOR C C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, June 2001, C Dec. 2003, Jan. 2009, Mar. 2009, Apr. 2009. C C KEYWORDS C C Multivariable system, orthogonal transformation, C structural invariant. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P, RANK DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) C .. Local Scalars .. LOGICAL LEQUIL, LQUERY INTEGER I, KW, MU, NINFZ, NKROL, NM, NP, NU, RO, $ SIGMA, WRKOPT DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL AB08NX, DLACPY, TB01ID, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C NP = N + P NM = N + M INFO = 0 LEQUIL = LSAME( EQUIL, 'S' ) LQUERY = ( LDWORK.EQ.-1 ) WRKOPT = NP*NM 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 KW = WRKOPT + MAX( MIN( P, M ) + MAX( 3*M-1, N ), 1, $ MIN( P, N ) + MAX( 3*P-1, NP, NM ) ) IF( LQUERY ) THEN SVLMAX = ZERO NINFZ = 0 CALL AB08NX( N, M, P, P, 0, SVLMAX, DWORK, MAX( 1, NP ), $ NINFZ, IWORK, IWORK, MU, NU, NKROL, TOL, IWORK, $ DWORK, -1, INFO ) WRKOPT = MAX( KW, WRKOPT + INT( DWORK(1) ) ) ELSE IF( LDWORK.LT.KW ) THEN INFO = -17 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB08MD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF ( MIN( M, P ).EQ.0 ) THEN RANK = 0 DWORK(1) = ONE RETURN END IF C DO 10 I = 1, 2*N+1 IWORK(I) = 0 10 CONTINUE 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 C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). C ( D C ) C Workspace: need (N+P)*(N+M). C CALL DLACPY( 'Full', N, M, B, LDB, DWORK, NP ) CALL DLACPY( 'Full', P, M, D, LDD, DWORK(N+1), NP ) CALL DLACPY( 'Full', N, N, A, LDA, DWORK(NP*M+1), NP ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK(NP*M+N+1), NP ) C C If required, balance the compound matrix (default MAXRED). C Workspace: need N. C KW = WRKOPT + 1 IF ( LEQUIL ) THEN MAXRED = ZERO CALL TB01ID( 'A', N, M, P, MAXRED, DWORK(NP*M+1), NP, DWORK, $ NP, DWORK(NP*M+N+1), NP, DWORK(KW), INFO ) WRKOPT = WRKOPT + N END IF C C If required, set tolerance. C THRESH = SQRT( DBLE( NP*NM ) )*DLAMCH( 'Precision' ) TOLER = TOL IF ( TOLER.LT.THRESH ) TOLER = THRESH SVLMAX = DLANGE( 'Frobenius', NP, NM, DWORK, NP, DWORK(KW) ) C C Reduce this system to one with the same invariant zeros and with C D full row rank MU (the normal rank of the original system). C Real workspace: need (N+P)*(N+M) + C 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 Integer workspace: 2*N+MAX(M,P)+1. C RO = P SIGMA = 0 NINFZ = 0 CALL AB08NX( N, M, P, RO, SIGMA, SVLMAX, DWORK, NP, NINFZ, IWORK, $ IWORK(N+1), MU, NU, NKROL, TOLER, IWORK(2*N+2), $ DWORK(KW), LDWORK-KW+1, INFO ) RANK = MU C DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) RETURN C *** Last line of AB08MD *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BA.f0000644000000000000000000000013015012430707016142 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/NF01BA.f0000644000175000017500000000613215012430707017342 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BA( IFLAG, NSMP, N, IPAR, LIPAR, Z, LDZ, Y, LDY, X, $ NFEVL, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) C C PURPOSE C C This is the FCN routine for optimizing the parameters of the C nonlinear part of a Wiener system (initialization phase), using C SLICOT Library routine MD03AD. See the argument FCN in the C routine MD03AD for the description of parameters. Note that C NF01BA is called for each output of the Wiener system. C C ****************************************************************** C C .. Parameters .. C .. CJTE is initialized to activate the calculation of J'*e .. C .. NOUT is the unit number for printing intermediate results .. CHARACTER CJTE PARAMETER ( CJTE = 'C' ) INTEGER NOUT PARAMETER ( NOUT = 6 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER IFLAG, INFO, LDJ, LDWORK, LDY, LDZ, LIPAR, N, $ NFEVL, NSMP C .. Array Arguments .. INTEGER IPAR(*) DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), X(*), $ Y(LDY,*), Z(LDZ,*) C .. Local Scalars .. DOUBLE PRECISION ERR C .. External Functions .. DOUBLE PRECISION DNRM2 EXTERNAL DNRM2 C .. External Subroutines .. EXTERNAL DAXPY, NF01AY, NF01BY C C .. Executable Statements .. C INFO = 0 IF ( IFLAG.EQ.1 ) THEN C C Call NF01AY to compute the output y of the Wiener system (in E) C and then the error functions (also in E). The array Z must C contain the output of the linear part of the Wiener system, and C Y must contain the original output Y of the Wiener system. C IPAR(2) must contain the number of outputs. C Workspace: need: 2*NN, NN = IPAR(3) (number of neurons); C prefer: larger. C CALL NF01AY( NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, LDZ, $ E, NSMP, DWORK, LDWORK, INFO ) CALL DAXPY( NSMP, -ONE, Y, 1, E, 1 ) DWORK(1) = 2*IPAR(3) C ELSE IF ( IFLAG.EQ.2 ) THEN C C Call NF01BY to compute the Jacobian in a compressed form. C IPAR(2), IPAR(3) must have the same content as for IFLAG = 1. C Workspace: need: 0. C CALL NF01BY( CJTE, NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, $ LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) NFEVL = 0 DWORK(1) = ZERO C ELSE IF ( IFLAG.EQ.3 ) THEN C C Set the parameter LDJ, the length of the array J, and the sizes C of the workspace for FCN (IFLAG = 1 or 2), and JPJ. C LDJ = NSMP IPAR(1) = NSMP*N IPAR(2) = 2*IPAR(3) IPAR(3) = 0 IPAR(4) = NSMP C ELSE IF ( IFLAG.EQ.0 ) THEN C C Special call for printing intermediate results. C ERR = DNRM2( NSMP, E, 1 ) WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR END IF RETURN C C *** Last line of NF01BA *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01OO.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01OO.f0000644000175000017500000001301315012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE MB01OO( UPLO, TRANS, N, H, LDH, X, LDX, E, LDE, P, LDP, $ INFO ) C C PURPOSE C C To compute either P or P', with P defined by the matrix formula C C P = op( H )*X*op( E )', C C where H is an upper Hessenberg matrix, X is a symmetric matrix, C E is an upper triangular matrix, and op( M ) is one of C C op( M ) = M or op( M ) = M'. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies which triangle of the symmetric matrix X is C 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 operation to be performed as follows: C = 'N': compute P = H*X*E'; C = 'T' or 'C': compute P' = E'*X*H. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices H, X, E, and P. N >= 0. C C H (input) DOUBLE PRECISION array, dimension (LDH,N) C On entry, the leading N-by-N upper Hessenberg part of this C array must contain the upper Hessenberg matrix H. C The remaining part of this array is not referenced. C C LDH INTEGER C The leading dimension of the array H. LDH >= MAX(1,N). 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 C LDX INTEGER C The leading dimension of the array X. LDX >= MAX(1,N). C C E (input) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the upper triangular matrix E. C The remaining part of this array is not referenced. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). C C P (output) DOUBLE PRECISION array, dimension (LDP,N) C On exit, the leading N-by-N part of this array contains C the computed matrix P = H*X*E', if TRANS = 'N', or C the computed matrix P' = E'*X*H, if TRANS = 'T'. C C LDP INTEGER C The leading dimension of the array P. LDP >= MAX(1,N). 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 C structure into account, and using BLAS and SLICOT routines. C Let W = H*X, or W = X*H, computed using SLICOT Library routine C MB01OS. The result is then obtained calling BLAS 3 routine DTRMM. C C NUMERICAL ASPECTS C C The algorithm requires approximately N**3 operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2019. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, matrix algebra, matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDE, LDH, LDP, LDX, N CHARACTER TRANS, UPLO C .. Array Arguments .. DOUBLE PRECISION E(LDE,*), H(LDH,*), P(LDP,*), X(LDX,*) C .. Local Scalars .. LOGICAL LTRANS, LUPLO CHARACTER SIDE C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DTRMM, MB01OS, 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 ( N.LT.0 ) THEN INFO = -3 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF ( LDX.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF ( LDE.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF ( LDP.LT.MAX( 1, N ) ) THEN INFO = -11 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01OO', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C C Compute W := H*X, if TRANS = 'N'. C Compute W := X*H, if TRANS = 'T'. C CALL MB01OS( UPLO, TRANS, N, H, LDH, X, LDX, P, LDP, INFO ) C C Compute P = W*E' = H*X*E', if TRANS = 'N', or C compute P = E'*W = E'*X*H, if TRANS = 'T'. C IF ( LTRANS ) THEN SIDE = 'Left' ELSE SIDE = 'Right' END IF C CALL DTRMM( SIDE, 'Upper', 'Tran', 'NoDiag', N, N, ONE, E, LDE, P, $ LDP ) C RETURN C *** Last line of MB01OO *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01OH.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01OH.f0000644000175000017500000002112615012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE MB01OH( UPLO, TRANS, N, ALPHA, BETA, R, LDR, H, LDH, A, $ LDA ) C C PURPOSE C C To compute one of the symmetric rank 2k operations C C R := alpha*R + beta*H*A' + beta*A*H', C C or C C R := alpha*R + beta*H'*A + beta*A'*H, C C where alpha and beta are scalars, R, A, and H are N-by-N matrices, C with A and H upper Hessenberg. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies which triangle of the symmetric matrix R is C 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 H to be used in the matrix C multiplication as follows: C = 'N': R := alpha*R + beta*H*A' + beta*A*H'; C = 'T': R := alpha*R + beta*H'*A + beta*A'*H; C = 'C': R := alpha*R + beta*H'*A + beta*A'*H. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices R, A, and H. 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 H are not C referenced. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) C On entry with 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 R. C On entry with 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 R. C In both cases, the other strictly triangular part is not C referenced. C On exit, the leading N-by-N 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 the computed matrix R. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C H (input) DOUBLE PRECISION array, dimension (LDH,N) C On entry, the leading N-by-N upper Hessenberg part of this C array must contain the upper Hessenberg matrix H. C The remaining part of this array is not referenced. C C LDH INTEGER C The leading dimension of array H. LDH >= MAX(1,N) C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading N-by-N upper Hessenberg part of this C array must contain the upper Hessenberg matrix A. C The remaining part of this array is not referenced. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N) C C METHOD C C A particularization of the algorithm used in the BLAS 3 routine C DSYR2K is used. C C NUMERICAL ASPECTS C C The algorithm requires approximately N**3/3 operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2019. C C REVISIONS C C V. Sima, Apr. 2019. C C KEYWORDS C C Elementary matrix operations, matrix algebra, matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. C .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER LDA, LDH, LDR, N CHARACTER TRANS, UPLO C .. C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), H(LDH,*), R(LDR,*) C .. C .. Local Scalars .. DOUBLE PRECISION BETA2, TEMP INTEGER I, INFO, J, J1 LOGICAL LTRANS, UPPER C .. C .. Local Arrays .. DOUBLE PRECISION TMP(1) C .. C .. External Functions .. DOUBLE PRECISION DDOT LOGICAL LSAME EXTERNAL DDOT, LSAME C .. C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input parameters. C UPPER = LSAME( UPLO, 'U' ) LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) C INFO = 0 IF ( .NOT.UPPER .AND. .NOT. LSAME( UPLO, 'L' ) ) THEN INFO = 1 ELSE IF ( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LTRANS ) THEN INFO = 2 ELSE IF ( N.LT.0 ) THEN INFO = 3 ELSE IF ( LDR.LT.MAX( 1,N ) ) THEN INFO = 7 ELSE IF ( LDH.LT.MAX( 1,N ) ) THEN INFO = 9 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = 11 END IF IF ( INFO.NE.0) THEN CALL XERBLA( 'MB01OH', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. ( BETA.EQ.ZERO .AND. ALPHA.EQ.ONE ) ) $ RETURN C IF ( BETA.EQ.ZERO ) THEN IF ( ALPHA.EQ.ZERO ) THEN C C Special case alpha = 0. C CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) ELSE C C Special case beta = 0. C IF ( ALPHA.NE.ONE ) $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, N, N, R, LDR, INFO ) END IF RETURN END IF C C Start the operations. C IF ( .NOT.LTRANS ) THEN C C Form R := alpha*R + beta*H*A' + beta*A*H'. C IF ( UPPER ) THEN C DO 20 J = 1, N IF ( ALPHA.EQ.ZERO ) THEN TMP(1) = ZERO CALL DCOPY( J, TMP, 0, R(1,J), 1 ) ELSE IF ( ALPHA.NE.ONE ) THEN CALL DSCAL( J, ALPHA, R(1,J), 1 ) END IF C DO 10 I = MAX( 1, J-1 ), N CALL DAXPY( J, BETA*A(J,I), H(1,I), 1, R(1,J), 1 ) CALL DAXPY( J, BETA*H(J,I), A(1,I), 1, R(1,J), 1 ) 10 CONTINUE C 20 CONTINUE C ELSE C DO 40 J = 1, N IF ( ALPHA.EQ.ZERO ) THEN TMP(1) = ZERO CALL DCOPY( N-J+1, TMP, 0, R(J,J), 1 ) ELSE IF ( ALPHA.NE.ONE ) THEN CALL DSCAL( N-J+1, ALPHA, R(J,J), 1 ) END IF C DO 30 I = MAX( 1, J-1 ), N - 1 CALL DAXPY( I-J+2, BETA*A(J,I), H(J,I), 1, R(J,J), 1 ) CALL DAXPY( I-J+2, BETA*H(J,I), A(J,I), 1, R(J,J), 1 ) 30 CONTINUE C CALL DAXPY( N-J+1, BETA*A(J,N), H(J,N), 1, R(J,J), 1 ) CALL DAXPY( N-J+1, BETA*H(J,N), A(J,N), 1, R(J,J), 1 ) 40 CONTINUE C END IF C ELSE C C Form R := alpha*R + beta*H'*A + beta*A'*H. C BETA2 = TWO*BETA C IF ( UPPER ) THEN C DO 60 J = 1, N - 1 C DO 50 I = 1, J TEMP = BETA*( DDOT( I+1, H(1,I), 1, A(1,J), 1 ) + $ DDOT( I+1, A(1,I), 1, H(1,J), 1 ) ) IF ( ALPHA.EQ.ZERO ) THEN R(I,J) = TEMP ELSE R(I,J) = ALPHA*R(I,J) + TEMP END IF 50 CONTINUE C 60 CONTINUE C DO 70 I = 1, N - 1 TEMP = BETA*( DDOT( I+1, H(1,I), 1, A(1,N), 1 ) + $ DDOT( I+1, A(1,I), 1, H(1,N), 1 ) ) IF ( ALPHA.EQ.ZERO ) THEN R(I,N) = TEMP ELSE R(I,N) = ALPHA*R(I,N) + TEMP END IF 70 CONTINUE C TEMP = BETA2*DDOT( N, H(1,N), 1, A(1,N), 1 ) IF ( ALPHA.EQ.ZERO ) THEN R(N,N) = TEMP ELSE R(N,N) = ALPHA*R(N,N) + TEMP END IF C ELSE C DO 90 J = 1, N - 1 J1 = J + 1 C DO 80 I = J, N TEMP = BETA*( DDOT( J1, H(1,I), 1, A(1,J), 1 ) + $ DDOT( J1, A(1,I), 1, H(1,J), 1 ) ) IF ( ALPHA.EQ.ZERO ) THEN R(I,J) = TEMP ELSE R(I,J) = ALPHA*R(I,J) + TEMP END IF 80 CONTINUE C 90 CONTINUE C TEMP = BETA2*DDOT( N, H(1,N), 1, A(1,N), 1 ) IF ( ALPHA.EQ.ZERO ) THEN R(N,N) = TEMP ELSE R(N,N) = ALPHA*R(N,N) + TEMP END IF C END IF C END IF C RETURN C *** Last line of MB01OH *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09GD.f0000644000000000000000000000013215012430707016143 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB09GD.f0000644000175000017500000006241515012430707017347 0ustar00lilgelilge00000000000000 SUBROUTINE AB09GD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M, $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, $ NQ, HSV, TOL1, TOL2, TOL3, IWORK, DWORK, $ LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for an original C state-space representation (A,B,C,D) by using either the C square-root or the balancing-free square-root Singular C Perturbation Approximation (SPA) model reduction method in C conjunction with stable coprime factorization techniques. 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 JOBCF CHARACTER*1 C Specifies whether left or right coprime factorization is C to be used as follows: C = 'L': use left coprime factorization; C = 'R': use right coprime factorization. C C FACT CHARACTER*1 C Specifies the type of coprime factorization to be computed C as follows: C = 'S': compute a coprime factorization with prescribed C stability degree ALPHA; C = 'I': compute a coprime factorization with inner C denominator. C C JOBMR CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root Balance & Truncate method; C = 'N': use the balancing-free square-root C Balance & Truncate method. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of the C resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. NR is set as follows: C if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR C is the desired order on entry, NQ is the order of the C computed coprime factorization of the given system, and C NMIN is the order of a minimal realization of the extended C system (see METHOD); NMIN is determined as the number of C Hankel singular values greater than NQ*EPS*HNORM(Ge), C where EPS is the machine precision (see LAPACK Library C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the C extended system (computed in HSV(1)); C if ORDSEL = 'A', NR is equal to the number of Hankel C singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)). C C ALPHA (input) DOUBLE PRECISION C If FACT = 'S', the desired stability degree for the C factors of the coprime factorization (see SLICOT Library C routines SB08ED/SB08FD). C ALPHA < 0 for a continuous-time system (DICO = 'C'), and C 0 <= ALPHA < 1 for a discrete-time system (DICO = 'D'). C If FACT = 'I', ALPHA is not used. 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 original state dynamics matrix A. C On exit, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the reduced C order system. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. 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 computed extended system Ge (see METHOD). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, it contains the NQ Hankel singular values of C the extended system Ge ordered decreasingly (see METHOD). C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced extended system. C For model reduction, the recommended value is C TOL1 = c*HNORM(Ge), where c is a constant in the C interval [0.00001,0.001], and HNORM(Ge) is the C Hankel-norm of the extended system (computed in HSV(1)). C The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if C TOL1 <= 0 on entry, where EPS is the machine precision C (see LAPACK Library Routine DLAMCH). C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the extended system Ge (see METHOD). C The recommended value is TOL2 = NQ*EPS*HNORM(Ge). C This value is used by default if TOL2 <= 0 on entry. C If TOL2 > 0, then TOL2 <= TOL1. C C TOL3 DOUBLE PRECISION C The absolute tolerance level below which the elements of C B or C are considered zero (used for controllability or C observability tests by the coprime factorization method). C If the user sets TOL3 <= 0, then an implicitly computed, C default tolerance TOLDEF is used: C TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or C TOLDEF = N*EPS*NORM(B), if JOBCF = 'R', C where EPS is the machine precision, and NORM(.) denotes C the 1-norm of a matrix. C C Workspace C C IWORK INTEGER array, dimension (MAX(1,2*N,PM)) C where PM = P, if JOBCF = 'L', C PM = M, if JOBCF = 'R'. C On exit with INFO = 0, IWORK(1) contains the order of the C minimal realization of the system. 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,LW1) if JOBCF = 'L' and FACT = 'S', C LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I', C LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S', C LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where C LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + C MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ), C LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + C MAX( N*P+MAX(N*(N+5), P*(P+2), 4*P, 4*M), LWR ), C LW3 = (N+M)*(M+P) + MAX( 5*M, 4*P, LWR ), C LW4 = (N+M)*(M+P) + MAX( M*(M+2), 4*M, 4*P, LWR ), and C LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2. C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 10*K+I: C I = 1: with ORDSEL = 'F', the selected order NR is C greater than the order of the computed coprime C factorization of the given system. In this case, C the resulting NR is set automatically to a value C corresponding to the order of a minimal C realization of the system; C K > 0: K violations of the numerical stability C condition occured when computing the coprime C factorization using pole assignment (see SLICOT C Library routines SB08CD/SB08ED, SB08DD/SB08FD). 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 + H*C)*Z C (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT C Library routines SB08CD/SB08ED (or SB08DD/SB08FD); C = 3: the matrix A has an observable or controllable C eigenvalue on the imaginary axis if DICO = 'C' or C on the unit circle if DICO = 'D'; C = 4: the computation of Hankel singular values failed. C C METHOD C C Let be the linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system, and let G be the corresponding C transfer-function matrix. The subroutine AB09GD determines C the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t) (2) C C with the transfer-function matrix Gr, by using the C singular perturbation approximation (SPA) method in conjunction C with a left coprime factorization (LCF) or a right coprime C factorization (RCF) technique: C C 1. Compute the appropriate stable coprime factorization of G: C -1 -1 C G = R *Q (LCF) or G = Q*R (RCF). C C 2. Perform the model reduction algorithm on the extended system C ( Q ) C Ge = ( Q R ) (LCF) or Ge = ( R ) (RCF) C C to obtain a reduced extended system with reduced factors C ( Qr ) C Ger = ( Qr Rr ) (LCF) or Ger = ( Rr ) (RCF). C C 3. Recover the reduced system from the reduced factors as C -1 -1 C Gr = Rr *Qr (LCF) or Gr = Qr*Rr (RCF). C C The approximation error for the extended system satisfies C C HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)], C C where INFNORM(G) is the infinity-norm of G. C C If JOBMR = 'B', the balancing-based square-root SPA method of [1] C is used for model reduction. C If JOBMR = 'N', the balancing-free square-root SPA method of [2] C is used for model reduction. C By setting TOL1 = TOL2, the routine can be used to compute C Balance & Truncate approximations. C C If FACT = 'S', the stable coprime factorization with prescribed C stability degree ALPHA is computed by using the algorithm of [3]. C If FACT = 'I', the stable coprime factorization with inner C denominator is computed by using the algorithm of [4]. C C REFERENCES C C [1] Liu Y. and Anderson B.D.O. C Singular Perturbation Approximation of Balanced Systems. C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. C C [2] Varga A. C Balancing-free square-root algorithm for computing singular C perturbation approximations. C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, Vol. 2, C pp. 1062-1065. C C [3] Varga A. C Coprime factors model reduction method based on square-root C balancing-free techniques. C System Analysis, Modelling and Simulation, Vol. 11, C pp. 303-311, 1993. C C [4] 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 C The implemented methods rely on accuracy enhancing square-root or C balancing-free square-root techniques. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C August 1998. C C REVISIONS C C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. C C KEYWORDS C C Balancing, coprime factorization, minimal realization, C model reduction, multivariable system, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, C100, ZERO PARAMETER ( ONE = 1.0D0, C100 = 100.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M, N, $ NQ, NR, P DOUBLE PRECISION ALPHA, TOL1, TOL2, TOL3 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), HSV(*) C .. Local Scalars .. LOGICAL DISCR, FIXORD, LEFT, STABD INTEGER IERR, IWARNK, KB, KBR, KBT, KC, KCR, KD, KDR, $ KDT, KT, KTI, KW, LW1, LW2, LW3, LW4, LWR, $ MAXMP, MP, NDR, NMINR, PM, WRKOPT DOUBLE PRECISION MAXRED C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB09BX, DLACPY, SB08CD, SB08DD, SB08ED, SB08FD, $ SB08GD, SB08HD, TB01ID, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) FIXORD = LSAME( ORDSEL, 'F' ) LEFT = LSAME( JOBCF, 'L' ) STABD = LSAME( FACT, 'S' ) MAXMP = MAX( M, P ) C LWR = 2*N*N + N*( MAX( N, M + P ) + 5 ) + ( N*( N + 1 ) )/2 LW1 = N*( 2*MAXMP + P ) + MAXMP*( MAXMP + P ) LW2 = LW1 + $ MAX( N*P + MAX( N*( N + 5 ), P*( P+2 ), 4*P, 4*M ), LWR ) LW1 = LW1 + MAX( N*P + MAX( N*( N + 5 ), 5*P, 4*M ), LWR ) LW3 = ( N + M )*( M + P ) + MAX( 5*M, 4*P, LWR ) LW4 = ( N + M )*( M + P ) + MAX( M*( M + 2 ), 4*M, 4*P, LWR ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( STABD .OR. LSAME( FACT, 'I' ) ) ) THEN INFO = -3 ELSE IF( .NOT. ( LSAME( JOBMR, 'B' ) .OR. $ LSAME( JOBMR, 'N' ) ) ) THEN INFO = -4 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -5 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -6 ELSE IF( STABD .AND. ( ( .NOT.DISCR .AND. ALPHA.GE.ZERO ) .OR. $ ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GE.ONE ) ) ) ) $ THEN INFO = -7 ELSE IF( N.LT.0 ) THEN INFO = -8 ELSE IF( M.LT.0 ) THEN INFO = -9 ELSE IF( P.LT.0 ) THEN INFO = -10 ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -11 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -17 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -19 ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN INFO = -23 ELSE IF( ( LDWORK.LT.1 ) .OR. $ ( STABD .AND. LEFT .AND. LDWORK.LT.LW1 ) .OR. $ ( .NOT.STABD .AND. LEFT .AND. LDWORK.LT.LW2 ) .OR. $ ( STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW3 ) .OR. $ ( .NOT.STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW4 ) ) THEN INFO = -27 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09GD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 NQ = 0 IWORK(1) = 0 DWORK(1) = ONE RETURN END IF C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C MAXRED = C100 CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Perform the coprime factor model reduction procedure. C KD = 1 IF( LEFT ) THEN C -1 C Compute a LCF G = R *Q. C MP = M + P KDR = KD + MAXMP*MAXMP KC = KDR + MAXMP*P KB = KC + MAXMP*N KBR = KB + N*MAXMP KW = KBR + N*P LWR = LDWORK - KW + 1 CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KB), N ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), MAXMP ) CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), MAXMP ) C IF( STABD ) THEN C C Compute a LCF with prescribed stability degree. C C Workspace needed: N*(2*MAX(M,P)+P) + C MAX(M,P)*(MAX(M,P)+P); C Additional workspace: need N*P+MAX(N*(N+5),5*P,4*M); C prefer larger. C CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, DWORK(KB), N, $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3, $ DWORK(KW), LWR, IWARN, INFO ) ELSE C C Compute a LCF with inner denominator. C C Workspace needed: N*(2*MAX(M,P)+P) + C MAX(M,P)*(MAX(M,P)+P); C Additional workspace: need N*P + C MAX(N*(N+5),P*(P+2),4*P,4*M); C prefer larger. C CALL SB08CD( DICO, N, M, P, A, LDA, DWORK(KB), N, $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3, $ DWORK(KW), LWR, IWARN, INFO ) END IF C IWARN = 10*IWARN IF( INFO.NE.0 ) $ RETURN C WRKOPT = INT( DWORK(KW) ) + KW - 1 C IF( NQ.EQ.0 ) THEN NR = 0 IWORK(1) = 0 DWORK(1) = WRKOPT RETURN END IF C IF( MAXMP.GT.M ) THEN C C Form the matrices ( BQ, BR ) and ( DQ, DR ) in consecutive C columns (see SLICOT Library routines SB08CD/SB08ED). C KBT = KBR KBR = KB + N*M KDT = KDR KDR = KD + MAXMP*M CALL DLACPY( 'Full', NQ, P, DWORK(KBT), N, DWORK(KBR), N ) CALL DLACPY( 'Full', P, P, DWORK(KDT), MAXMP, DWORK(KDR), $ MAXMP ) END IF C C Perform model reduction on ( Q, R ) to determine ( Qr, Rr ). C C Workspace needed: N*(2*MAX(M,P)+P) + C MAX(M,P)*(MAX(M,P)+P) + 2*N*N; C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; C prefer larger. C KT = KW KTI = KT + NQ*NQ KW = KTI + NQ*NQ CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, MP, P, NR, A, LDA, $ DWORK(KB), N, DWORK(KC), MAXMP, DWORK(KD), MAXMP, $ HSV, DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, $ IWORK, DWORK(KW), LDWORK-KW+1, IWARNK, IERR ) C IWARN = IWARN + IWARNK IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF C NMINR = IWORK(1) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C -1 C Compute the reduced order system Gr = Rr *Qr. C C Workspace needed: N*(2*MAX(M,P)+P) + C MAX(M,P)*(MAX(M,P)+P); C Additional workspace: need 4*P. C KW = KT CALL SB08GD( NR, M, P, A, LDA, DWORK(KB), N, DWORK(KC), MAXMP, $ DWORK(KD), MAXMP, DWORK(KBR), N, DWORK(KDR), $ MAXMP, IWORK, DWORK(KW), INFO ) C C Copy the reduced system matrices Br, Cr, and Dr to B, C, and D, C respectively. C CALL DLACPY( 'Full', NR, M, DWORK(KB), N, B, LDB ) CALL DLACPY( 'Full', P, NR, DWORK(KC), MAXMP, C, LDC ) CALL DLACPY( 'Full', P, M, DWORK(KD), MAXMP, D, LDD ) ELSE C -1 C Compute a RCF G = Q*R . C PM = P + M KDR = KD + P KC = KD + PM*M KCR = KC + P KW = KC + PM*N LWR = LDWORK - KW + 1 CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), PM ) CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), PM ) C IF( STABD ) THEN C C Compute a RCF with prescribed stability degree. C C Workspace needed: (N+M)*(M+P); C Additional workspace: need MAX( N*(N+5), 5*M, 4*P ); C prefer larger. C CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, $ DWORK(KCR), PM, DWORK(KDR), PM, TOL3, $ DWORK(KW), LWR, IWARN, INFO) ELSE C C Compute a RCF with inner denominator. C C Workspace needed: (N+M)*(M+P); 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, $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, $ DWORK(KCR), PM, DWORK(KDR), PM, TOL3, $ DWORK(KW), LWR, IWARN, INFO) END IF C IWARN = 10*IWARN IF( INFO.NE.0 ) $ RETURN C WRKOPT = INT( DWORK(KW) ) + KW - 1 C IF( NQ.EQ.0 ) THEN NR = 0 IWORK(1) = 0 DWORK(1) = WRKOPT RETURN END IF C ( Q ) ( Qr ) C Perform model reduction on ( R ) to determine ( Rr ). C C Workspace needed: (N+M)*(M+P) + 2*N*N; C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; C prefer larger. C KT = KW KTI = KT + NQ*NQ KW = KTI + NQ*NQ CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, M, PM, NR, A, LDA, $ B, LDB, DWORK(KC), PM, DWORK(KD), PM, HSV, $ DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, IWORK, $ DWORK(KW), LDWORK-KW+1, IWARNK, IERR ) C IWARN = IWARN + IWARNK IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF C NMINR = IWORK(1) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C -1 C Compute the reduced order system Gr = Qr*Rr . C C Workspace needed: (N+M)*(M+P); C Additional workspace: need 4*M. C KW = KT CALL SB08HD( NR, M, P, A, LDA, B, LDB, DWORK(KC), PM, $ DWORK(KD), PM, DWORK(KCR), PM, DWORK(KDR), PM, $ IWORK, DWORK(KW), INFO ) C C Copy the reduced system matrices Cr and Dr to C and D. C CALL DLACPY( 'Full', P, NR, DWORK(KC), PM, C, LDC ) CALL DLACPY( 'Full', P, M, DWORK(KD), PM, D, LDD ) END IF C IWORK(1) = NMINR DWORK(1) = WRKOPT C RETURN C *** Last line of AB09GD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09DD.f0000644000000000000000000000013215012430707016140 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB09DD.f0000644000175000017500000002002615012430707017334 0ustar00lilgelilge00000000000000 SUBROUTINE AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, $ D, LDD, RCOND, IWORK, DWORK, INFO ) C C PURPOSE C C To compute a reduced order model by using singular perturbation C approximation formulas. 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; also the number of rows of matrix B and the C number of columns of the matrix C. N >= 0. C C M (input) INTEGER C The dimension of input vector, i.e. the number of columns C of matrices B and D. M >= 0. C C P (input) INTEGER C The dimension of output vector, i.e. the number of rows of C matrices C and D. P >= 0. C C NR (input) INTEGER C The order of the reduced order system. N >= NR >= 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 original system. C On exit, the leading NR-by-NR part of this array contains C the state dynamics matrix Ar of the reduced order system. 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 original system. C On exit, the leading NR-by-M part of this array contains C the input/state matrix Br of the reduced order system. 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 original system. C On exit, the leading P-by-NR part of this array contains C the state/output matrix Cr of the reduced order system. 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 original system. C On exit, the leading P-by-M part of this array contains C the input/output matrix Dr of the reduced order system. C If NR = 0 and the given system is stable, then D contains C the steady state gain of the system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C RCOND (output) DOUBLE PRECISION C The reciprocal condition number of the matrix A22-g*I C (see METHOD). C C Workspace C C IWORK INTEGER array, dimension (2*(N-NR)) C C DWORK DOUBLE PRECISION array, dimension (4*(N-NR)) 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 A22-g*I (see METHOD) is numerically C singular. C C METHOD C C Given the system (A,B,C,D), partition the system matrices as C C ( A11 A12 ) ( B1 ) C A = ( ) , B = ( ) , C = ( C1 C2 ), C ( A21 A22 ) ( B2 ) C C where A11 is NR-by-NR, B1 is NR-by-M, C1 is P-by-NR, and the other C submatrices have appropriate dimensions. C C The matrices of the reduced order system (Ar,Br,Cr,Dr) are C computed according to the following residualization formulas: C -1 -1 C Ar = A11 + A12*(g*I-A22) *A21 , Br = B1 + A12*(g*I-A22) *B2 C -1 -1 C Cr = C1 + C2*(g*I-A22) *A21 , Dr = D + C2*(g*I-A22) *B2 C C where g = 0 if DICO = 'C' and g = 1 if DICO = 'D'. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C March 1998. C Based on the RASP routine SRESID. C C REVISIONS C C - C C KEYWORDS C C Model reduction, multivariable system, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO INTEGER INFO, LDA, LDB, LDC, LDD, M, N, NR, P DOUBLE PRECISION RCOND C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) INTEGER IWORK(*) C .. Local Scalars LOGICAL DISCR INTEGER I, J, K, NS DOUBLE PRECISION A22NRM C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C C Check the input scalar arguments. C INFO = 0 DISCR = LSAME( DICO, 'D' ) 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( P.LT.0 ) THEN INFO = -4 ELSE IF( NR.LT.0 .OR. NR.GT.N ) 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 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09DD', -INFO ) RETURN END IF C C Quick return if possible. C IF( NR.EQ.N ) THEN RCOND = ONE RETURN END IF C K = NR + 1 NS = N - NR C C Compute: T = -A22 if DICO = 'C' and C T = -A22+I if DICO = 'D'. C DO 20 J = K, N DO 10 I = K, N A(I,J) = -A(I,J) 10 CONTINUE IF( DISCR ) A(J,J) = A(J,J) + ONE 20 CONTINUE C C Compute the LU decomposition of T. C A22NRM = DLANGE( '1-norm', NS, NS, A(K,K), LDA, DWORK ) CALL DGETRF( NS, NS, A(K,K), LDA, IWORK, INFO ) IF( INFO.GT.0 ) THEN C C Error return. C RCOND = ZERO INFO = 1 RETURN END IF CALL DGECON( '1-norm', NS, A(K,K), LDA, A22NRM, RCOND, DWORK, $ IWORK(NS+1), INFO ) IF( RCOND.LE.DLAMCH('E') ) THEN C C Error return. C INFO = 1 RETURN END IF C C Compute A21 <- INV(T)*A21. C CALL DGETRS( 'NoTranspose', NS, NR, A(K,K), LDA, IWORK, A(K,1), $ LDA, INFO ) C C Compute B2 <- INV(T)*B2. C CALL DGETRS( 'NoTranspose', NS, M, A(K,K), LDA, IWORK, B(K,1), $ LDB, INFO ) C C Compute the residualized systems matrices. C Ar = A11 + A12*INV(T)*A21. C CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, NS, ONE, A(1,K), $ LDA, A(K,1), LDA, ONE, A, LDA ) C C Br = B1 + A12*INV(T)*B2. C CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, NS, ONE, A(1,K), $ LDA, B(K,1), LDB, ONE, B, LDB ) C C Cr = C1 + C2*INV(T)*A21. C CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, NS, ONE, C(1,K), $ LDC, A(K,1), LDA, ONE, C, LDC ) C C Dr = D + C2*INV(T)*B2. C CALL DGEMM( 'NoTranspose', 'NoTranspose', P, M, NS, ONE, C(1,K), $ LDC, B(K,1), LDB, ONE, D, LDD ) C RETURN C *** Last line of AB09DD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB05OY.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB05OY.f0000644000175000017500000001102515012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE MB05OY( JOB, N, LOW, IGH, A, LDA, SCALE, INFO ) C C PURPOSE C C To restore a matrix after it has been transformed by applying C balancing transformations (permutations and scalings), as C determined by LAPACK Library routine DGEBAL. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the type of backward transformation required, C as follows: C = 'N', do nothing, return immediately; C = 'P', do backward transformation for permutation only; C = 'S', do backward transformation for scaling only; C = 'B', do backward transformations for both permutation C and scaling. C JOB must be the same as the argument JOB supplied C to DGEBAL. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C LOW (input) INTEGER C IGH (input) INTEGER C The integers LOW and IGH determined by DGEBAL. C 1 <= LOW <= IGH <= N, if N > 0; LOW=1 and IGH=0, if 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 to be back-transformed. C On exit, the leading N-by-N part of this array contains C the transformed matrix. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C SCALE (input) DOUBLE PRECISION array, dimension (N) C Details of the permutation and scaling factors, as C returned by DGEBAL. 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 P be a permutation matrix, and D a diagonal matrix of scaling C factors, both of order N. The routine computes C -1 C A <-- P D A D P'. C C where the permutation and scaling factors are encoded in the C array SCALE. C C REFERENCES C C None. C C NUMERICAL ASPECTS C 2 C The algorithm requires O(N ) operations. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. C Supersedes Release 2.0 routine MB05CY. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, matrix algebra, matrix operations. C C ****************************************************************** C DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER IGH, INFO, LDA, LOW, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), SCALE(*) C .. Local Scalars .. INTEGER I, II, J, K C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DSCAL, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( N.LT.0 )THEN INFO = -2 ELSE IF( LOW.LT.1 .OR. LOW.GT.MAX( 1, N ) ) THEN INFO = -3 ELSE IF( IGH.LT.MIN( LOW, N ) .OR. IGH.GT.N ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = -6 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB05OY', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 .OR. LSAME( JOB, 'N' ) ) $ RETURN C IF ( .NOT.LSAME( JOB, 'P' ) .AND. IGH.NE.LOW ) THEN C DO 20 I = LOW, IGH CALL DSCAL( N, SCALE(I), A(I,1), LDA ) 20 CONTINUE C DO 40 J = LOW, IGH CALL DSCAL( N, ONE/SCALE(J), A(1,J), 1 ) 40 CONTINUE C END IF C IF( .NOT.LSAME( JOB, 'S' ) ) THEN C DO 60 II = 1, N I = II IF ( I.LT.LOW .OR. I.GT.IGH ) THEN IF ( I.LT.LOW ) I = LOW - II K = SCALE(I) IF ( K.NE.I ) THEN CALL DSWAP( N, A(I,1), LDA, A(K,1), LDA ) CALL DSWAP( N, A(1,I), 1, A(1,K), 1 ) END IF END IF 60 CONTINUE C END IF C RETURN C *** Last line of MB05OY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB4DLZ.f0000644000000000000000000000013015012430707016227 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB4DLZ.f0000644000175000017500000006763415012430707017445 0ustar00lilgelilge00000000000000 SUBROUTINE MB4DLZ( JOB, N, THRESH, A, LDA, B, LDB, ILO, IHI, $ LSCALE, RSCALE, DWORK, IWARN, INFO ) C C PURPOSE C C To balance a pair of N-by-N complex matrices (A,B). This involves, C first, permuting A and B by equivalence transformations to isolate C eigenvalues in the first 1 to ILO-1 and last IHI+1 to N elements C on the diagonal of A and B; and second, applying a diagonal C equivalence transformation to rows and columns ILO to IHI to make C the rows and columns as close in 1-norm as possible. Both steps C are optional. Balancing may reduce the 1-norms of the matrices, C and improve the accuracy of the computed eigenvalues and/or C eigenvectors in the generalized eigenvalue problem C A*x = lambda*B*x. C C This routine may optionally improve the conditioning of the C scaling transformation compared to the LAPACK routine ZGGBAL. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the operations to be performed on A and B: C = 'N': none: simply set ILO = 1, LSCALE(I) = 1.0 and C RSCALE(I) = 1.0 for I = 1,...,N. C = 'P': permute only; C = 'S': scale only; C = 'B': both permute and scale. C C Input/Output Parameters C C N (input) INTEGER C The order of matrices A and B. N >= 0. C C THRESH (input) DOUBLE PRECISION C If JOB = 'S' or JOB = 'B', and THRESH >= 0, threshold C value for magnitude of the elements to be considered in C the scaling process: elements with magnitude less than or C equal to THRESH*MXNORM are ignored for scaling, where C MXNORM is the maximum of the 1-norms of the original C submatrices A(s,s) and B(s,s), with s = ILO:IHI. C If THRESH < 0, the subroutine finds the scaling factors C for which some conditions, detailed below, are fulfilled. C A sequence of increasing strictly positive threshold C values is used. C If THRESH = -1, the condition is that C max( norm(A(s,s),1)/norm(B(s,s),1), C norm(B(s,s),1)/norm(S(s,s),1) ) (1) C has the smallest value, for the threshold values used, C where A(s,s) and B(s,s) are the scaled submatrices. C If THRESH = -2, the norm ratio reduction (1) is tried, but C the subroutine may return IWARN = 1 and reset the scaling C factors to 1, if this seems suitable. See the description C of the argument IWARN and FURTHER COMMENTS. C If THRESH = -3, the condition is that C norm(A(s,s),1)*norm(B(s,s),1) (2) C has the smallest value for the scaled submatrices. C If THRESH = -4, the norm reduction in (2) is tried, but C the subroutine may return IWARN = 1 and reset the scaling C factors to 1, as for THRESH = -2 above. C If THRESH = -VALUE, with VALUE >= 10, the condition C numbers of the left and right scaling transformations will C be bounded by VALUE, i.e., the ratios between the largest C and smallest entries in LSCALE(s) and RSCALE(s), will be C at most VALUE. VALUE should be a power of 10. C If JOB = 'N' or JOB = 'P', the value of THRESH is C irrelevant. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the matrix A. C On exit, the leading N-by-N part of this array contains C the balanced matrix A. C In particular, the strictly lower triangular part of the C first ILO-1 columns and the last N-IHI rows of A is zero. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) COMPLEX*16 array, dimension (LDB, N) C On entry, the leading N-by-N part of this array must C contain the matrix B. C On exit, the leading N-by-N part of this array contains C the balanced matrix B. C In particular, the strictly lower triangular part of the C first ILO-1 columns and the last N-IHI rows of B is zero. C If JOB = 'N', the arrays A and B are not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N). C C ILO (output) INTEGER C IHI (output) INTEGER C ILO and IHI are set to integers such that on exit C A(i,j) = 0 and B(i,j) = 0 if i > j and C j = 1,...,ILO-1 or i = IHI+1,...,N. C If JOB = 'N' or 'S', ILO = 1 and IHI = N. C C LSCALE (output) DOUBLE PRECISION array, dimension (N) C Details of the permutations and scaling factors applied C to the left side of A and B. If P(j) is the index of the C row interchanged with row j, and D(j) is the scaling C factor applied to row j, then C LSCALE(j) = P(j) for j = 1,...,ILO-1 C = D(j) for j = ILO,...,IHI C = P(j) for j = IHI+1,...,N. C The order in which the interchanges are made is N to C IHI+1, then 1 to ILO-1. C C RSCALE (output) DOUBLE PRECISION array, dimension (N) C Details of the permutations and scaling factors applied C to the right side of A and B. If P(j) is the index of the C column interchanged with column j, and D(j) is the scaling C factor applied to column j, then C RSCALE(j) = P(j) for j = 1,...,ILO-1 C = D(j) for j = ILO,...,IHI C = P(j) for j = IHI+1,...,N. C The order in which the interchanges are made is N to C IHI+1, then 1 to ILO-1. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) where C LDWORK = 0, if JOB = 'N' or JOB = 'P', or N = 0; C LDWORK = 6*N, if (JOB = 'S' or JOB = 'B') and THRESH >= 0; C LDWORK = 8*N, if (JOB = 'S' or JOB = 'B') and THRESH < 0. C On exit, if JOB = 'S' or JOB = 'B', DWORK(1) and DWORK(2) C contain the initial 1-norms of A(s,s) and B(s,s), and C DWORK(3) and DWORK(4) contain their final 1-norms, C respectively. Moreover, DWORK(5) contains the THRESH value C used (irrelevant if IWARN = 1 or ILO = IHI). C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: scaling has been requested, for THRESH = -2 or C THRESH = -4, but it most probably would not improve C the accuracy of the computed solution for a related C eigenproblem (since maximum norm increased C significantly compared to the original pencil C matrices and (very) high and/or small scaling C factors occurred). The returned scaling factors have C been reset to 1, but information about permutations, C if requested, has been preserved. 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 Balancing consists of applying an equivalence transformation C to isolate eigenvalues and/or to make the 1-norms of the rows C and columns ILO,...,IHI of A and B nearly equal. If THRESH < 0, C a search is performed to find those scaling factors giving the C smallest norm ratio or product defined above (see the description C of the parameter THRESH). C C Assuming JOB = 'S', let Dl and Dr be diagonal matrices containing C the vectors LSCALE and RSCALE, respectively. The returned matrices C are obtained using the equivalence transformation C C Dl*A*Dr and Dl*B*Dr. C C For THRESH = 0, the routine returns essentially the same results C as the LAPACK subroutine ZGGBAL [1]. Setting THRESH < 0, usually C gives better results than ZGGBAL for badly scaled matrix pencils. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C No rounding errors appear if JOB = 'P'. C C FURTHER COMMENTS C C If THRESH = -2, the increase of the maximum norm of the scaled C submatrices, compared to the maximum norm of the initial C submatrices, is bounded by MXGAIN = 100. C If THRESH = -2, or THRESH = -4, the maximum condition number of C the scaling transformations is bounded by MXCOND = 1/SQRT(EPS), C where EPS is the machine precision (see LAPACK Library routine C DLAMCH). C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2015. C C REVISIONS C C V. Sima, Jan. 2016, Jan. 2017, Feb. 2017. C C KEYWORDS C C Balancing, eigenvalue, equivalence transformation, matrix algebra, C matrix operations. C C ********************************************************************* C C .. Parameters .. DOUBLE PRECISION HALF, ONE, TEN, THREE, ZERO PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, TEN = 1.0D+1, $ THREE = 3.0D+0, ZERO = 0.0D+0 ) DOUBLE PRECISION MXGAIN, SCLFAC PARAMETER ( MXGAIN = 1.0D+2, SCLFAC = 1.0D+1 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. CHARACTER JOB INTEGER IHI, ILO, INFO, IWARN, LDA, LDB, N DOUBLE PRECISION THRESH C .. Array Arguments .. DOUBLE PRECISION DWORK(*), LSCALE(*), RSCALE(*) COMPLEX*16 A(LDA,*), B(LDB,*) C .. Local Scalars .. LOGICAL EVNORM, LOOP, LPERM, LSCAL, STORMN INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, ITER, ITH, $ J, JC, JP1, K, KOUNT, KS, KW1, KW2, KW3, KW4, $ KW5, KW6, KW7, L, LM1, LRAB, LSFMAX, LSFMIN, M, $ NR, NRP2 DOUBLE PRECISION AB, ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, DENOM, EPS, EW, EWC, GAMMA, GAP, $ MINPRO, MINRAT, MN, MX, MXCOND, MXNORM, MXS, $ NA, NA0, NAS, NB, NB0, NBS, PGAMMA, PROD, RAB, $ RATIO, SFMAX, SFMIN, SUM, T, TA, TB, TC, TH, $ TH0, THS C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, IZAMAX DOUBLE PRECISION DCABS1, DDOT, DLAMCH, ZLANGE EXTERNAL DCABS1, DDOT, DLAMCH, IDAMAX, IZAMAX, LSAME, $ ZLANGE C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA, ZDSCAL, ZSWAP C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN, SQRT C C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IWARN = 0 LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) C IF( .NOT.LPERM .AND. .NOT.LSCAL .AND. .NOT.LSAME( JOB, 'N' ) ) $ THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB4DLZ', -INFO ) RETURN END IF C ILO = 1 IHI = N C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN IF( ( .NOT.LPERM .AND. .NOT.LSCAL ) .OR. N.EQ.1 ) THEN DUM(1) = ONE CALL DCOPY( N, DUM, 0, LSCALE, 1 ) CALL DCOPY( N, DUM, 0, RSCALE, 1 ) IF( N.EQ.1 .AND. LSCAL ) THEN NA0 = ABS( A(1,1) ) NB0 = ABS( B(1,1) ) DWORK(1) = NA0 DWORK(2) = NB0 DWORK(3) = NA0 DWORK(4) = NB0 DWORK(5) = THRESH END IF RETURN END IF C K = 1 L = N C IF( LPERM ) THEN C C Permute the matrices A and B to isolate the eigenvalues. C C Find row with one nonzero in columns 1 through L. C 10 CONTINUE LM1 = L - 1 DO 60 I = L, 1, -1 DO 20 J = 1, LM1 JP1 = J + 1 IF( A(I,J).NE.CZERO .OR. B(I,J).NE.CZERO ) $ GO TO 30 20 CONTINUE J = L GO TO 50 C 30 CONTINUE DO 40 J = JP1, L IF( A(I,J).NE.CZERO .OR. B(I,J).NE.CZERO ) $ GO TO 60 40 CONTINUE J = JP1 - 1 C 50 CONTINUE M = L IFLOW = 1 GO TO 130 60 CONTINUE C C Find column with one nonzero in rows K through N. C 70 CONTINUE DO 120 J = K, L DO 80 I = K, LM1 IP1 = I + 1 IF( A(I,J).NE.CZERO .OR. B(I,J).NE.CZERO ) $ GO TO 90 80 CONTINUE I = L GO TO 110 C 90 CONTINUE DO 100 I = IP1, L IF( A(I,J).NE.CZERO .OR. B(I,J).NE.CZERO ) $ GO TO 120 100 CONTINUE I = IP1 - 1 C 110 CONTINUE M = K IFLOW = 2 GO TO 130 120 CONTINUE GO TO 140 C C Permute rows M and I. C 130 CONTINUE LSCALE(M) = I IF( I.NE.M ) THEN CALL ZSWAP( N-K+1, A(I,K), LDA, A(M,K), LDA ) CALL ZSWAP( N-K+1, B(I,K), LDB, B(M,K), LDB ) END IF C C Permute columns M and J. C RSCALE(M) = J IF( J.NE.M ) THEN CALL ZSWAP( L, A(1,J), 1, A(1,M), 1 ) CALL ZSWAP( L, B(1,J), 1, B(1,M), 1 ) END IF C IF( IFLOW.EQ.1 ) THEN L = LM1 IF( L.NE.1 ) $ GO TO 10 C RSCALE(1) = ONE LSCALE(1) = ONE ELSE K = K + 1 GO TO 70 END IF END IF C 140 CONTINUE ILO = K IHI = L C IF( .NOT.LSCAL ) THEN DO 150 I = ILO, IHI LSCALE(I) = ONE RSCALE(I) = ONE 150 CONTINUE RETURN END IF C NR = IHI - ILO + 1 C C Compute initial 1-norms and return if ILO = N. C NA0 = ZLANGE( '1-norm', NR, NR, A(ILO,ILO), LDA, DWORK ) NB0 = ZLANGE( '1-norm', NR, NR, B(ILO,ILO), LDB, DWORK ) C IF( ILO.EQ.IHI ) THEN DWORK(1) = NA0 DWORK(2) = NB0 DWORK(3) = NA0 DWORK(4) = NB0 DWORK(5) = THRESH RETURN END IF C C Balance the submatrices in rows ILO to IHI. C C Initialize balancing and allocate work storage. C KW1 = N KW2 = KW1 + N KW3 = KW2 + N KW4 = KW3 + N KW5 = KW4 + N DUM(1) = ZERO C C Prepare for scaling. C SFMIN = DLAMCH( 'Safe minimum' ) SFMAX = ONE / SFMIN BASL = LOG10( SCLFAC ) LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) MXNORM = MAX( NA0, NB0 ) LOOP = THRESH.LT.ZERO C IF( LOOP ) THEN C C Compute relative threshold. C NA = NA0 NAS = NA0 NB = NB0 NBS = NB0 C ITH = THRESH MXS = MXNORM MX = ZERO MN = SFMAX IF( ITH.GE.-2 ) THEN IF( NA.LT.NB ) THEN RATIO = MIN( NB/NA, SFMAX ) ELSE RATIO = MIN( NA/NB, SFMAX ) END IF MINRAT = RATIO ELSE IF( ITH.LE.-10 ) THEN MXCOND = -THRESH ELSE DENOM = MAX( ONE, MXNORM ) PROD = ( NA/DENOM )*( NB/DENOM ) MINPRO = PROD END IF STORMN = .FALSE. EVNORM = .FALSE. C C Find maximum order of magnitude of the differences in sizes of C the nonzero entries, not considering diag(A) and diag(B). C DO 170 J = ILO, IHI DO 160 I = ILO, IHI IF( I.NE.J ) THEN AB = DCABS1( A(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) END IF 160 CONTINUE 170 CONTINUE C DO 190 J = ILO, IHI DO 180 I = ILO, IHI IF( I.NE.J ) THEN AB = DCABS1( B(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) END IF 180 CONTINUE 190 CONTINUE C IF( MX*SFMIN.LE.MN ) THEN GAP = MX/MN ELSE GAP = SFMAX END IF EPS = DLAMCH( 'Precision' ) ITER = MIN( INT( LOG10( GAP ) ), -INT( LOG10( EPS ) ) ) + 1 TH = MAX( MN, MX*EPS )/MAX( MXNORM, SFMIN ) THS = TH KW6 = KW5 + N + ILO KW7 = KW6 + N CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) C C Set the maximum condition number of the transformations. C IF( ITH.GT.-10 ) $ MXCOND = ONE/SQRT( EPS ) ELSE TH = MXNORM*THRESH ITER = 1 EVNORM = .TRUE. END IF TH0 = TH C COEF = ONE / DBLE( 2*NR ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = NR + 2 BETA = ZERO C C If THRESH < 0, use a loop to reduce the norm ratio. C DO 400 K = 1, ITER C C Compute right side vector in resulting linear equations. C CALL DCOPY( 6*N, DUM, 0, DWORK, 1 ) CALL DCOPY( NR, DUM, 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM, 0, RSCALE(ILO), 1 ) DO 210 I = ILO, IHI DO 200 J = ILO, IHI TA = DCABS1( A(I,J) ) TB = DCABS1( B(I,J) ) IF( TA.GT.TH ) THEN TA = LOG10( TA ) / BASL ELSE TA = ZERO END IF IF( TB.GT.TH ) THEN TB = LOG10( TB ) / BASL ELSE TB = ZERO END IF DWORK(I+KW4) = DWORK(I+KW4) - TA - TB DWORK(J+KW5) = DWORK(J+KW5) - TA - TB 200 CONTINUE 210 CONTINUE C IT = 1 C C Start generalized conjugate gradient iteration. C 220 CONTINUE C GAMMA = DDOT( NR, DWORK(ILO+KW4), 1, DWORK(ILO+KW4), 1 ) + $ DDOT( NR, DWORK(ILO+KW5), 1, DWORK(ILO+KW5), 1 ) C EW = ZERO EWC = ZERO DO 230 I = ILO, IHI EW = EW + DWORK(I+KW4) EWC = EWC + DWORK(I+KW5) 230 CONTINUE C GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - $ COEF5*( EW - EWC )**2 IF( GAMMA.EQ.ZERO ) $ GO TO 300 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = COEF5*( EWC - THREE*EW ) TC = COEF5*( EW - THREE*EWC ) C CALL DSCAL( NR, BETA, DWORK(ILO), 1 ) CALL DSCAL( NR, BETA, DWORK(ILO+KW1), 1 ) C CALL DAXPY( NR, COEF, DWORK(ILO+KW4), 1, DWORK(ILO+KW1), 1 ) CALL DAXPY( NR, COEF, DWORK(ILO+KW5), 1, DWORK(ILO), 1 ) C DO 240 J = ILO, IHI DWORK(J) = DWORK(J) + TC DWORK(J+KW1) = DWORK(J+KW1) + T 240 CONTINUE C C Apply matrix to vector. C DO 260 I = ILO, IHI KOUNT = 0 SUM = ZERO DO 250 J = ILO, IHI KS = KOUNT IF( A(I,J).NE.CZERO ) $ KOUNT = KOUNT + 1 IF( B(I,J).NE.CZERO ) $ KOUNT = KOUNT + 1 SUM = SUM + DBLE( KOUNT - KS )*DWORK(J) 250 CONTINUE DWORK(I+KW2) = DBLE( KOUNT )*DWORK(I+KW1) + SUM 260 CONTINUE C DO 280 J = ILO, IHI KOUNT = 0 SUM = ZERO DO 270 I = ILO, IHI KS = KOUNT IF( A(I,J).NE.CZERO ) $ KOUNT = KOUNT + 1 IF( B(I,J).NE.CZERO ) $ KOUNT = KOUNT + 1 SUM = SUM + DBLE( KOUNT - KS )*DWORK(I+KW1) 270 CONTINUE DWORK(J+KW3) = DBLE( KOUNT )*DWORK(J) + SUM 280 CONTINUE C SUM = DDOT( NR, DWORK(ILO+KW1), 1, DWORK(ILO+KW2), 1 ) + $ DDOT( NR, DWORK(ILO), 1, DWORK(ILO+KW3), 1 ) ALPHA = GAMMA / SUM C C Determine correction to current iteration. C CMAX = ZERO DO 290 I = ILO, IHI COR = ALPHA*DWORK(I+KW1) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE(I) = LSCALE(I) + COR COR = ALPHA*DWORK(I) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE(I) = RSCALE(I) + COR 290 CONTINUE C IF( CMAX.GE.HALF ) THEN C CALL DAXPY( NR, -ALPHA, DWORK(ILO+KW2), 1, DWORK(ILO+KW4), $ 1 ) CALL DAXPY( NR, -ALPHA, DWORK(ILO+KW3), 1, DWORK(ILO+KW5), $ 1 ) C PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 220 END IF C C End generalized conjugate gradient iteration. C 300 CONTINUE C C Compute diagonal scaling matrices. C DO 310 I = ILO, IHI IRAB = IZAMAX( N-ILO+1, A(I,ILO), LDA ) RAB = ABS( A(I,ILO+IRAB-1) ) IRAB = IZAMAX( N-ILO+1, B(I,ILO), LDB ) RAB = MAX( RAB, ABS( B(I,ILO+IRAB-1) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) IR = LSCALE(I) + SIGN( HALF, LSCALE(I) ) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE(I) = SCLFAC**IR C ICAB = IZAMAX( IHI, A(1,I), 1 ) CAB = ABS( A(ICAB,I) ) ICAB = IZAMAX( IHI, B(1,I), 1 ) CAB = MAX( CAB, ABS( B(ICAB,I) ) ) LRAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) JC = RSCALE(I) + SIGN( HALF, RSCALE(I) ) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LRAB ) RSCALE(I) = SCLFAC**JC 310 CONTINUE C DO 320 I = ILO, IHI IF( LSCALE(I).NE.ONE .OR. RSCALE(I).NE.ONE ) $ GO TO 330 320 CONTINUE C C Finish the procedure for all scaling factors equal to 1. C NAS = NA0 NBS = NB0 THS = TH0 GO TO 460 C 330 CONTINUE C IF( LOOP ) THEN IF( ITH.LE.-10 ) THEN C C Compute the reciprocal condition number of the left and C right transformations. Continue the loop if it is too C small. C IR = IDAMAX( NR, LSCALE(ILO), 1 ) JC = IDAMAX( NR, RSCALE(ILO), 1 ) T = LSCALE(ILO+IR-1) MN = T DO 340 I = ILO, IHI IF( LSCALE(I).LT.MN ) $ MN = LSCALE(I) 340 CONTINUE T = MN/T TA = RSCALE(ILO+JC-1) MN = TA DO 350 I = ILO, IHI IF( RSCALE(I).LT.MN ) $ MN = RSCALE(I) 350 CONTINUE T = MIN( T, MN/TA ) IF( T.LT.ONE/MXCOND ) THEN TH = TH*TEN GO TO 400 ELSE THS = TH EVNORM = .TRUE. GO TO 430 END IF END IF C C Compute the 1-norms of the scaled submatrices, C without actually scaling them. C NA = ZERO DO 370 J = ILO, IHI T = ZERO DO 360 I = ILO, IHI T = T + ABS( A(I,J) )*LSCALE(I)*RSCALE(J) 360 CONTINUE IF( T.GT.NA ) $ NA = T 370 CONTINUE C NB = ZERO DO 390 J = ILO, IHI T = ZERO DO 380 I = ILO, IHI T = T + ABS( B(I,J) )*LSCALE(I)*RSCALE(J) 380 CONTINUE IF( T.GT.NB ) $ NB = T 390 CONTINUE C IF( ITH.GE.-4 .AND. ITH.LT.-2 ) THEN PROD = ( NA/DENOM )*( NB/DENOM ) IF( MINPRO.GT.PROD ) THEN MINPRO = PROD STORMN = .TRUE. CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) NAS = NA NBS = NB THS = TH END IF ELSE IF( ITH.GE.-2 ) THEN IF( NA.LT.NB ) THEN RATIO = MIN( NB/NA, SFMAX ) ELSE RATIO = MIN( NA/NB, SFMAX ) END IF IF( MINRAT.GT.RATIO ) THEN MINRAT = RATIO STORMN = .TRUE. CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) MXS = MAX( NA, NB ) NAS = NA NBS = NB THS = TH END IF END IF TH = TH*TEN END IF 400 CONTINUE C C Prepare for scaling. C IF( LOOP ) THEN IF( ITH.LE.-10 ) THEN C C Could not find enough well conditioned transformations C for THRESH <= -10. Set scaling factors to 1 and return. C DUM(1) = ONE CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 ) IWARN = 1 GO TO 460 END IF C C Check if scaling might reduce the accuracy when solving related C eigenproblems, and set the scaling factors to 1 in this case, C if THRESH = -2 or THRESH = -4. C IF( ( MXNORM.LT.MXS .AND. MXNORM.LT.MXS/MXGAIN .AND. ITH.EQ.-2) $ .OR. ITH.EQ.-4 ) THEN IR = IDAMAX( NR, DWORK(KW6), 1 ) JC = IDAMAX( NR, DWORK(KW7), 1 ) T = DWORK(KW6+IR-1) MN = T DO 410 I = KW6, KW6+NR-1 IF( DWORK(I).LT.MN ) $ MN = DWORK(I) 410 CONTINUE T = MN/T TA = DWORK(KW7+JC-1) MN = TA DO 420 I = KW7, KW7+NR-1 IF( DWORK(I).LT.MN ) $ MN = DWORK(I) 420 CONTINUE T = MIN( T, MN/TA ) IF( T.LT.ONE/MXCOND ) THEN DUM(1) = ONE CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 ) IWARN = 1 NAS = NA0 NBS = NB0 THS = TH0 GO TO 460 END IF END IF IF( STORMN ) THEN CALL DCOPY( NR, DWORK(KW6), 1, LSCALE(ILO), 1 ) CALL DCOPY( NR, DWORK(KW7), 1, RSCALE(ILO), 1 ) ELSE NAS = NA NBS = NB THS = TH END IF END IF C 430 CONTINUE C C Row scaling. C DO 440 I = ILO, IHI CALL ZDSCAL( N-ILO+1, LSCALE(I), A(I,ILO), LDA ) CALL ZDSCAL( N-ILO+1, LSCALE(I), B(I,ILO), LDB ) 440 CONTINUE C C Column scaling. C DO 450 J = ILO, IHI CALL ZDSCAL( IHI, RSCALE(J), A(1,J), 1 ) CALL ZDSCAL( IHI, RSCALE(J), B(1,J), 1 ) 450 CONTINUE C C Set DWORK(1:5). C 460 CONTINUE IF( EVNORM ) THEN NAS = ZLANGE( '1-norm', NR, NR, A(ILO,ILO), LDA, DWORK ) NBS = ZLANGE( '1-norm', NR, NR, B(ILO,ILO), LDB, DWORK ) END IF C DWORK(1) = NA0 DWORK(2) = NB0 DWORK(3) = NAS DWORK(4) = NBS IF( LOOP ) THEN DWORK(5) = THS/MAX( MXNORM, SFMIN ) ELSE DWORK(5) = THRESH END IF C RETURN C *** Last line of MB4DLZ *** END control-4.1.2/src/slicot/src/PaxHeaders/AB05RD.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB05RD.f0000644000175000017500000003161415012430707017353 0ustar00lilgelilge00000000000000 SUBROUTINE AB05RD( FBTYPE, JOBD, N, M, P, MV, PZ, ALPHA, BETA, A, $ LDA, B, LDB, C, LDC, D, LDD, F, LDF, K, LDK, $ G, LDG, H, LDH, RCOND, BC, LDBC, CC, LDCC, $ DC, LDDC, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To construct for a given state space system (A,B,C,D) the closed- C loop system (Ac,Bc,Cc,Dc) corresponding to the mixed output and C state feedback control law C C u = alpha*F*y + beta*K*x + G*v C z = H*y. C C ARGUMENTS C C Mode Parameters C C FBTYPE CHARACTER*1 C Specifies the type of the feedback law as follows: C = 'I': Unitary output feedback (F = I); C = 'O': General output feedback. C C JOBD CHARACTER*1 C Specifies whether or not a non-zero matrix D appears C in 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 dimension of state vector x, i.e. the order of the C matrix A, the number of rows of B and the number of C columns of C. N >= 0. C C M (input) INTEGER C The dimension of input vector u, i.e. the number of C columns of matrices B and D, and the number of rows of F. C M >= 0. C C P (input) INTEGER C The dimension of output vector y, i.e. the number of rows C of matrices C and D, and the number of columns of F. C P >= 0 and P = M if FBTYPE = 'I'. C C MV (input) INTEGER C The dimension of the new input vector v, i.e. the number C of columns of matrix G. MV >= 0. C C PZ (input) INTEGER. C The dimension of the new output vector z, i.e. the number C of rows of matrix H. PZ >= 0. C C ALPHA (input) DOUBLE PRECISION C The coefficient alpha in the output feedback law. C C BETA (input) DOUBLE PRECISION. C The coefficient beta in the state feedback law. 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 system state transition matrix A. C On exit, the leading N-by-N part of this array contains C the state matrix Ac of the closed-loop system. 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 system input matrix B. C On exit, the leading N-by-M part of this array contains C the intermediary input matrix B1 (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 system output matrix C. C On exit, the leading P-by-N part of this array contains C the intermediary output matrix C1+BETA*D1*K (see METHOD). C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,P) if N > 0. C LDC >= 1 if N = 0. C C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) C On entry, if JOBD = 'D', the leading P-by-M part of this C array must contain the system direct input/output C transmission matrix D. C On exit, the leading P-by-M part of this array contains C the intermediary direct input/output transmission matrix C D1 (see METHOD). 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 F (input) DOUBLE PRECISION array, dimension (LDF,P) C If FBTYPE = 'O', the leading M-by-P part of this array C must contain the output feedback matrix F. C If FBTYPE = 'I', then the feedback matrix is assumed to be C an M x M order identity matrix. C The array F is not referenced if FBTYPE = 'I' or C ALPHA = 0. C C LDF INTEGER C The leading dimension of array F. C LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0. C LDF >= 1 if FBTYPE = 'I' or ALPHA = 0. C C K (input) DOUBLE PRECISION array, dimension (LDK,N) C The leading M-by-N part of this array must contain the C state feedback matrix K. C The array K is not referenced if BETA = 0. C C LDK INTEGER C The leading dimension of the array K. C LDK >= MAX(1,M) if BETA <> 0. C LDK >= 1 if BETA = 0. C C G (input) DOUBLE PRECISION array, dimension (LDG,MV) C The leading M-by-MV part of this array must contain the C system input scaling matrix G. C C LDG INTEGER C The leading dimension of the array G. LDG >= MAX(1,M). C C H (input) DOUBLE PRECISION array, dimension (LDH,P) C The leading PZ-by-P part of this array must contain the C system output scaling matrix H. C C LDH INTEGER C The leading dimension of the array H. LDH >= MAX(1,PZ). C C RCOND (output) DOUBLE PRECISION C The reciprocal condition number of the matrix C I - alpha*D*F. C C BC (output) DOUBLE PRECISION array, dimension (LDBC,MV) C The leading N-by-MV part of this array contains the input C matrix Bc of the closed-loop system. C C LDBC INTEGER C The leading dimension of array BC. LDBC >= MAX(1,N). C C CC (output) DOUBLE PRECISION array, dimension (LDCC,N) C The leading PZ-by-N part of this array contains the C system output matrix Cc of the closed-loop system. C C LDCC INTEGER C The leading dimension of array CC. C LDCC >= MAX(1,PZ) if N > 0. C LDCC >= 1 if N = 0. C C DC (output) DOUBLE PRECISION array, dimension (LDDC,MV) C If JOBD = 'D', the leading PZ-by-MV part of this array C contains the direct input/output transmission matrix Dc C of the closed-loop system. C The array DC is not referenced if JOBD = 'Z'. C C LDDC INTEGER C The leading dimension of array DC. C LDDC >= MAX(1,PZ) if JOBD = 'D'. C LDDC >= 1 if JOBD = 'Z'. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK >= MAX(1,2*P) if JOBD = 'D'. C LIWORK >= 1 if JOBD = 'Z'. C IWORK is not referenced if JOBD = 'Z'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= wspace, where C wspace = MAX( 1, M, P*MV, P*P + 4*P ) if JOBD = 'D', C wspace = MAX( 1, M ) if JOBD = 'Z'. C For best performance, LDWORK >= MAX( wspace, N*M, N*P ). 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 I - alpha*D*F is numerically singular. C C METHOD C C The matrices of the closed-loop system have the expressions: C C Ac = A1 + beta*B1*K, Bc = B1*G, C Cc = H*(C1 + beta*D1*K), Dc = H*D1*G, C C where C C A1 = A + alpha*B*F*E*C, B1 = B + alpha*B*F*E*D, C C1 = E*C, D1 = E*D, C C with E = (I - alpha*D*F)**-1. C C NUMERICAL ASPECTS C C The accuracy of computations basically depends on the conditioning C of the matrix I - alpha*D*F. If RCOND is very small, it is likely C that the computed results are inaccurate. C C CONTRIBUTORS C C A. Varga, German Aerospace Research Establishment, C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, C Belgium, Nov. 1996. C C REVISIONS C C January 14, 1997, February 18, 1998. C V. Sima, Research Institute for Informatics, Bucharest, July 2003, C Jan. 2005. C C KEYWORDS C C Multivariable system, state-space model, state-space C representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER FBTYPE, JOBD INTEGER INFO, LDA, LDB, LDBC, LDC, LDCC, LDD, LDDC, $ LDF, LDG, LDH, LDK, LDWORK, M, MV, N, P, PZ DOUBLE PRECISION ALPHA, BETA, RCOND C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), BC(LDBC,*), C(LDC,*), $ CC(LDCC,*), D(LDD,*), DC(LDDC,*), DWORK(*), $ F(LDF,*), G(LDG,*), H(LDH,*), K(LDK,*) C .. Local Scalars .. LOGICAL LJOBD, OUTPF, UNITF INTEGER LDWP C .. External functions .. LOGICAL LSAME EXTERNAL LSAME C .. External subroutines .. EXTERNAL AB05SD, DGEMM, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C C .. Executable Statements .. C C Check the input scalar arguments. C UNITF = LSAME( FBTYPE, 'I' ) OUTPF = LSAME( FBTYPE, 'O' ) LJOBD = LSAME( JOBD, 'D' ) C INFO = 0 C IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN INFO = -1 ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN INFO = -5 ELSE IF( MV.LT.0 ) THEN INFO = -6 ELSE IF( PZ.LT.0 ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN INFO = -15 ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, P ) ) .OR. $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN INFO = -17 ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) ) $ .OR. ( ( UNITF .OR. ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN INFO = -19 ELSE IF( ( BETA.NE.ZERO .AND. LDK.LT.MAX( 1, M ) ) .OR. $ ( BETA.EQ.ZERO .AND. LDK.LT.1 ) ) THEN INFO = -21 ELSE IF( LDG.LT.MAX( 1, M ) ) THEN INFO = -23 ELSE IF( LDH.LT.MAX( 1, PZ ) ) THEN INFO = -25 ELSE IF( LDBC.LT.MAX( 1, N ) ) THEN INFO = -28 ELSE IF( ( N.GT.0 .AND. LDCC.LT.MAX( 1, PZ ) ) .OR. $ ( N.EQ.0 .AND. LDCC.LT.1 ) ) THEN INFO = -30 ELSE IF( ( ( LJOBD .AND. LDDC.LT.MAX( 1, PZ ) ) .OR. $ ( .NOT.LJOBD .AND. LDDC.LT.1 ) ) ) THEN INFO = -32 ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*MV, P*P + 4*P ) ) $ .OR. ( .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN INFO = -35 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB05RD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, MIN( M, P ), MIN( MV, PZ ) ).EQ.0 ) THEN RCOND = ONE RETURN END IF C C Apply the partial output feedback u = alpha*F*y + v1 C CALL AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB, C, $ LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK, LDWORK, $ INFO ) IF ( INFO.NE.0 ) RETURN C C Apply the partial state feedback v1 = beta*K*x + v2. C C Compute Ac = A1 + beta*B1*K and C1 <- C1 + beta*D1*K. C IF( BETA.NE.ZERO .AND. N.GT.0 ) THEN CALL DGEMM( 'N', 'N', N, N, M, BETA, B, LDB, K, LDK, ONE, A, $ LDA ) IF( LJOBD ) $ CALL DGEMM( 'N', 'N', P, N, M, BETA, D, LDD, K, LDK, ONE, $ C, LDC ) END IF C C Apply the input and output conversions v2 = G*v, z = H*y. C C Compute Bc = B1*G. C CALL DGEMM( 'N', 'N', N, MV, M, ONE, B, LDB, G, LDG, ZERO, BC, $ LDBC ) C C Compute Cc = H*C1. C IF( N.GT.0 ) $ CALL DGEMM( 'N', 'N', PZ, N, P, ONE, H, LDH, C, LDC, ZERO, CC, $ LDCC ) C C Compute Dc = H*D1*G. C IF( LJOBD ) THEN LDWP = MAX( 1, P ) CALL DGEMM( 'N', 'N', P, MV, M, ONE, D, LDD, G, LDG, ZERO, $ DWORK, LDWP ) CALL DGEMM( 'N', 'N', PZ, MV, P, ONE, H, LDH, DWORK, LDWP, $ ZERO, DC, LDDC ) END IF C RETURN C *** Last line of AB05RD *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01OD.f0000644000000000000000000000013215012430707016153 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/IB01OD.f0000644000175000017500000001321515012430707017351 0ustar00lilgelilge00000000000000 SUBROUTINE IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARN, INFO ) C C PURPOSE C C To estimate the system order, based on the singular values of the C relevant part of the triangular factor of the concatenated block C Hankel matrices. C C ARGUMENTS C C Mode Parameters C C CTRL CHARACTER*1 C Specifies whether or not the user's confirmation of the C system order estimate is desired, as follows: C = 'C': user's confirmation; C = 'N': no confirmation. C If CTRL = 'C', a reverse communication routine, IB01OY, C is called, and, after inspecting the singular values and C system order estimate, n, the user may accept n or set C a new value. C IB01OY is not called by the routine if CTRL = 'N'. C C Input/Output Parameters C C NOBR (input) INTEGER C The number of block rows, s, in the processed input and C output block Hankel matrices. NOBR > 0. C C L (input) INTEGER C The number of system outputs. L > 0. C C SV (input) DOUBLE PRECISION array, dimension ( L*NOBR ) C The singular values of the relevant part of the triangular C factor from the QR factorization of the concatenated block C Hankel matrices. C C N (output) INTEGER C The estimated order of the system. C C Tolerances C C TOL DOUBLE PRECISION C Absolute tolerance used for determining an estimate of C the system order. If TOL >= 0, the estimate is C indicated by the index of the last singular value greater C than or equal to TOL. (Singular values less than TOL C are considered as zero.) When TOL = 0, an internally C computed default value, TOL = NOBR*EPS*SV(1), is used, C where SV(1) is the maximal singular value, and EPS is C the relative machine precision (see LAPACK Library routine C DLAMCH). When TOL < 0, the estimate is indicated by the C index of the singular value that has the largest C logarithmic gap to its successor. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 3: all singular values were exactly zero, hence N = 0. C (Both input and output were identically zero.) 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 singular values are compared to the given, or default TOL, and C the estimated order n is returned, possibly after user's C confirmation. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. C C REVISIONS C C August 2000. C C KEYWORDS C C Identification methods, multivariable systems, singular value C decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER INFO, IWARN, L, N, NOBR CHARACTER CTRL C .. Array Arguments .. DOUBLE PRECISION SV(*) C .. Local Scalars .. DOUBLE PRECISION GAP, RNRM, TOLL INTEGER I, IERR, LNOBR LOGICAL CONTRL C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL IB01OY, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, LOG10 C .. C .. Executable Statements .. C C Check the scalar input parameters. C CONTRL = LSAME( CTRL, 'C' ) LNOBR = L*NOBR IWARN = 0 INFO = 0 IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN INFO = -1 ELSE IF( NOBR.LE.0 ) THEN INFO = -2 ELSE IF( L.LE.0 ) THEN INFO = -3 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB01OD', -INFO ) RETURN END IF C C Set TOL if necessay. C TOLL = TOL IF ( TOLL.EQ.ZERO) $ TOLL = DLAMCH( 'Precision' )*SV(1)*DBLE( NOBR ) C C Obtain the system order. C N = 0 IF ( SV(1).NE.ZERO ) THEN N = NOBR IF ( TOLL.GE.ZERO) THEN C C Estimate n based on the tolerance TOLL. C DO 10 I = 1, NOBR - 1 IF ( SV(I+1).LT.TOLL ) THEN N = I GO TO 30 END IF 10 CONTINUE ELSE C C Estimate n based on the largest logarithmic gap between C two consecutive singular values. C GAP = ZERO DO 20 I = 1, NOBR - 1 RNRM = SV(I+1) IF ( RNRM.NE.ZERO ) THEN RNRM = LOG10( SV(I) ) - LOG10( RNRM ) IF ( RNRM.GT.GAP ) THEN GAP = RNRM N = I END IF ELSE IF ( GAP.EQ.ZERO ) $ N = I GO TO 30 END IF 20 CONTINUE END IF END IF C 30 CONTINUE IF ( N.EQ.0 ) THEN C C Return with N = 0 if all singular values are zero. C IWARN = 3 RETURN END IF C IF ( CONTRL ) THEN C C Ask confirmation of the system order. C CALL IB01OY( LNOBR, NOBR-1, N, SV, IERR ) END IF RETURN C C *** Last line of IB01OD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03MX.f0000644000000000000000000000013015012430707016207 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03MX.f0000644000175000017500000006072315012430707017415 0ustar00lilgelilge00000000000000 SUBROUTINE SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) C C PURPOSE C C To solve the real discrete Lyapunov matrix equation C C op(A)'*X*op(A) - X = scale*C C C where op(A) = A or A' (A**T), A is upper quasi-triangular and C is C symmetric (C = C'). (A' denotes the transpose of the matrix A.) C A is N-by-N, the right hand side C and the solution X are N-by-N, C and scale is an output scale factor, set less than or equal to 1 C to avoid overflow in X. The solution matrix X is overwritten C onto C. C C A must be in Schur canonical form (as returned by LAPACK routines C DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and C 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its C diagonal elements equal and its off-diagonal elements of opposite C sign. C C ARGUMENTS C C Mode Parameters 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) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must contain the C upper quasi-triangular matrix A, in Schur canonical form. C The part of A below the first sub-diagonal is not C referenced. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) C On entry, the leading N-by-N part of this array must C contain the symmetric matrix C. C On exit, if INFO >= 0, the leading N-by-N part of this C array contains the symmetric solution matrix X. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,N). 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 Workspace C C DWORK DOUBLE PRECISION 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 A has almost reciprocal eigenvalues; perturbed C values were used to solve the equation (but the C matrix A is unchanged). C C METHOD C C A discrete-time version of the Bartels-Stewart algorithm is used. C A set of equivalent linear algebraic systems of equations of order C at most four are formed and solved using Gaussian elimination with C complete pivoting. 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 NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. C Supersedes Release 2.0 routine SB03AZ by Control Systems Research C Group, Kingston Polytechnic, United Kingdom, October 1982. C Based on DTRLPD by P. Petkov, Tech. University of Sofia, September C 1993. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. C A. Varga, DLR Oberpfaffenhofen, March 2002. C C KEYWORDS C C Discrete-time system, Lyapunov equation, matrix algebra, real C Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER TRANA INTEGER INFO, LDA, LDC, N DOUBLE PRECISION SCALE C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ) C .. C .. Local Scalars .. LOGICAL NOTRNA, LUPPER INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, $ MINK1N, MINK2N, MINL1N, MINL2N, NP1 DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22, $ SCALOC, SMIN, SMLNUM, XNORM C .. C .. Local Arrays .. DOUBLE PRECISION VEC( 2, 2 ), X( 2, 2 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLANHS EXTERNAL DDOT, DLAMCH, DLANHS, LSAME C .. C .. External Subroutines .. EXTERNAL DLABAD, DLALN2, DSCAL, DSYMV, SB03MV, SB04PX, $ XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN C .. C .. Executable Statements .. C C Decode and Test input parameters. C NOTRNA = LSAME( TRANA, 'N' ) LUPPER = .TRUE. C INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. $ .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDC.LT.MAX( 1, N ) ) THEN INFO = -6 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03MX', -INFO ) RETURN END IF C SCALE = ONE C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*DBLE( N*N ) / EPS BIGNUM = ONE / SMLNUM C SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, A, LDA, DWORK ) ) NP1 = N + 1 C IF( NOTRNA ) THEN C C Solve A'*X*A - X = scale*C. C C The (K,L)th block of X is determined starting from C upper-left corner column by column by C C A(K,K)'*X(K,L)*A(L,L) - X(K,L) = C(K,L) - R(K,L), C C where C K L-1 C R(K,L) = SUM {A(I,K)'*SUM [X(I,J)*A(J,L)]} + C I=1 J=1 C C K-1 C {SUM [A(I,K)'*X(I,L)]}*A(L,L). C I=1 C C Start column loop (index = L). C L1 (L2): column index of the first (last) row of X(K,L). C LNEXT = 1 C DO 60 L = 1, N IF( L.LT.LNEXT ) $ GO TO 60 L1 = L L2 = L IF( L.LT.N ) THEN IF( A( L+1, L ).NE.ZERO ) $ L2 = L2 + 1 LNEXT = L2 + 1 END IF C C Start row loop (index = K). C K1 (K2): row index of the first (last) row of X(K,L). C DWORK( L1 ) = ZERO DWORK( N+L1 ) = ZERO CALL DSYMV( 'Lower', L1-1, ONE, C, LDC, A( 1, L1 ), 1, ZERO, $ DWORK, 1 ) CALL DSYMV( 'Lower', L1-1, ONE, C, LDC, A( 1, L2 ), 1, ZERO, $ DWORK( NP1 ), 1 ) C KNEXT = L C DO 50 K = L, N IF( K.LT.KNEXT ) $ GO TO 50 K1 = K K2 = K IF( K.LT.N ) THEN IF( A( K+1, K ).NE.ZERO ) $ K2 = K2 + 1 KNEXT = K2 + 1 END IF C IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), $ 1 ) C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + A( L1, L1 ) $ *DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) ) SCALOC = ONE C A11 = A( K1, K1 )*A( L1, L1 ) - ONE DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 C IF( SCALOC.NE.ONE ) THEN C DO 10 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 10 CONTINUE C CALL DSCAL( N, SCALOC, DWORK, 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) IF( K1.NE.L1 ) THEN C( L1, K1 ) = X( 1, 1 ) END IF C ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN C DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), $ 1 ) DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), $ 1 ) C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + A( L1, L1 ) $ *DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) ) C VEC( 2, 1 ) = C( K2, L1 ) - $ ( DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + A( L1, L1 ) $ *DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) ) C CALL DLALN2( .TRUE., 2, 1, SMIN, A( L1, L1 ), $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, ONE, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 20 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 20 CONTINUE C CALL DSCAL( N, SCALOC, DWORK, 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) C( L1, K1 ) = X( 1, 1 ) C( L1, K2 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN C DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), $ 1 ) DWORK( N+K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, $ A( 1, L2 ), 1 ) P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + $ P11*A( L1, L1 ) + P12*A( L2, L1 ) ) C VEC( 2, 1 ) = C( K1, L2 ) - $ ( DDOT( K1, A( 1, K1 ), 1, DWORK( NP1 ), 1 ) + $ P11*A( L1, L2 ) + P12*A( L2, L2 ) ) C CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), $ A( L1, L1 ), LDA, ONE, ONE, VEC, 2, ONE, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 30 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 30 CONTINUE C CALL DSCAL( N, SCALOC, DWORK, 1 ) CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) C( L1, K1 ) = X( 1, 1 ) C( L2, K1 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN C DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), $ 1 ) DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), $ 1 ) DWORK( N+K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, $ A( 1, L2 ), 1 ) DWORK( N+K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, $ A( 1, L2 ), 1 ) P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + $ P11*A( L1, L1 ) + P12*A( L2, L1 ) ) C VEC( 1, 2 ) = C( K1, L2 ) - $ ( DDOT( K2, A( 1, K1 ), 1, DWORK( NP1 ), 1 ) + $ P11*A( L1, L2 ) + P12*A( L2, L2 ) ) C VEC( 2, 1 ) = C( K2, L1 ) - $ ( DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + $ P21*A( L1, L1 ) + P22*A( L2, L1 ) ) C VEC( 2, 2 ) = C( K2, L2 ) - $ ( DDOT( K2, A( 1, K2 ), 1, DWORK( NP1 ), 1 ) + $ P21*A( L1, L2 ) + P22*A( L2, L2 ) ) C IF( K1.EQ.L1 ) THEN CALL SB03MV( .FALSE., LUPPER, A( K1, K1 ), LDA, $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) IF( LUPPER ) THEN X( 2, 1 ) = X( 1, 2 ) ELSE X( 1, 2 ) = X( 2, 1 ) END IF ELSE CALL SB04PX( .TRUE., .FALSE., -1, 2, 2, $ A( K1, K1 ), LDA, A( L1, L1 ), LDA, $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) END IF IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 40 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 40 CONTINUE C CALL DSCAL( N, SCALOC, DWORK, 1 ) CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) IF( K1.NE.L1 ) THEN C( L1, K1 ) = X( 1, 1 ) C( L2, K1 ) = X( 1, 2 ) C( L1, K2 ) = X( 2, 1 ) C( L2, K2 ) = X( 2, 2 ) END IF END IF C 50 CONTINUE C 60 CONTINUE C ELSE C C Solve A*X*A' - X = scale*C. C C The (K,L)th block of X is determined starting from C bottom-right corner column by column by C C A(K,K)*X(K,L)*A(L,L)' - X(K,L) = C(K,L) - R(K,L), C C where C C N N C R(K,L) = SUM {A(K,I)* SUM [X(I,J)*A(L,J)']} + C I=K J=L+1 C C N C { SUM [A(K,J)*X(J,L)]}*A(L,L)' C J=K+1 C C Start column loop (index = L) C L1 (L2): column index of the first (last) row of X(K,L) C LNEXT = N C DO 120 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 120 L1 = L L2 = L IF( L.GT.1 ) THEN IF( A( L, L-1 ).NE.ZERO ) THEN L1 = L1 - 1 DWORK( L1 ) = ZERO DWORK( N+L1 ) = ZERO END IF LNEXT = L1 - 1 END IF MINL1N = MIN( L1+1, N ) MINL2N = MIN( L2+1, N ) C C Start row loop (index = K) C K1 (K2): row index of the first (last) row of X(K,L) C IF( L2.LT.N ) THEN CALL DSYMV( 'Upper', N-L2, ONE, C( L2+1, L2+1 ), LDC, $ A( L1, L2+1 ), LDA, ZERO, DWORK( L2+1 ), 1 ) CALL DSYMV( 'Upper', N-L2, ONE, C( L2+1, L2+1 ), LDC, $ A( L2, L2+1 ), LDA, ZERO, DWORK( NP1+L2 ), 1) END IF C KNEXT = L C DO 110 K = L, 1, -1 IF( K.GT.KNEXT ) $ GO TO 110 K1 = K K2 = K IF( K.GT.1 ) THEN IF( A( K, K-1 ).NE.ZERO ) $ K1 = K1 - 1 KNEXT = K1 - 1 END IF MINK1N = MIN( K1+1, N ) MINK2N = MIN( K2+1, N ) C IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN DWORK( K1 ) = DDOT( N-L1, C( K1, MINL1N ), LDC, $ A( L1, MINL1N ), LDA ) C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( N-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) $ + DDOT( N-K1, A( K1, MINK1N ), LDA, $ C( MINK1N, L1 ), 1 )*A( L1, L1 ) ) SCALOC = ONE C A11 = A( K1, K1 )*A( L1, L1 ) - ONE DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 C IF( SCALOC.NE.ONE ) THEN C DO 70 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 70 CONTINUE C CALL DSCAL( N, SCALOC, DWORK, 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) IF( K1.NE.L1 ) THEN C( L1, K1 ) = X( 1, 1 ) END IF C ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN C DWORK( K1 ) = DDOT( N-L1, C( K1, MINL1N ), LDC, $ A( L1, MINL1N ), LDA ) DWORK( K2 ) = DDOT( N-L1, C( K2, MINL1N ), LDC, $ A( L1, MINL1N ), LDA ) C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) $ + DDOT( N-K2, A( K1, MINK2N ), LDA, $ C( MINK2N, L1 ), 1 )*A( L1, L1 ) ) C VEC( 2, 1 ) = C( K2, L1 ) - $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( K1 ), 1 ) $ + DDOT( N-K2, A( K2, MINK2N ), LDA, $ C( MINK2N, L1 ), 1 )*A( L1, L1 ) ) C CALL DLALN2( .FALSE., 2, 1, SMIN, A( L1, L1 ), $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, ONE, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 80 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 80 CONTINUE C CALL DSCAL( N, SCALOC, DWORK, 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) C( L1, K1 ) = X( 1, 1 ) C( L1, K2 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN C DWORK( K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, $ A( L1, MINL2N ), LDA ) DWORK( N+K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, $ A( L2, MINL2N ), LDA ) P11 = DDOT( N-K1, A( K1, MINK1N ), LDA, $ C( MINK1N, L1 ), 1 ) P12 = DDOT( N-K1, A( K1, MINK1N ), LDA, $ C( MINK1N, L2 ), 1 ) C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) $ + P11*A( L1, L1 ) + P12*A( L1, L2 ) ) C VEC( 2, 1 ) = C( K1, L2 ) - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( N+K1 ), 1) $ + P11*A( L2, L1 ) + P12*A( L2, L2 ) ) C CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), $ A( L1, L1 ), LDA, ONE, ONE, VEC, 2, ONE, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 90 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 90 CONTINUE C CALL DSCAL( N, SCALOC, DWORK, 1 ) CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) C( L1, K1 ) = X( 1, 1 ) C( L2, K1 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN C DWORK( K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, $ A( L1, MINL2N ), LDA ) DWORK( K2 ) = DDOT( N-L2, C( K2, MINL2N ), LDC, $ A( L1, MINL2N ), LDA ) DWORK( N+K1 ) = DDOT( N-L2, C( K1, MINL2N ), LDC, $ A( L2, MINL2N ), LDA ) DWORK( N+K2 ) = DDOT( N-L2, C( K2, MINL2N ), LDC, $ A( L2, MINL2N ), LDA ) P11 = DDOT( N-K2, A( K1, MINK2N ), LDA, $ C( MINK2N, L1 ), 1 ) P12 = DDOT( N-K2, A( K1, MINK2N ), LDA, $ C( MINK2N, L2 ), 1 ) P21 = DDOT( N-K2, A( K2, MINK2N ), LDA, $ C( MINK2N, L1 ), 1 ) P22 = DDOT( N-K2, A( K2, MINK2N ), LDA, $ C( MINK2N, L2 ), 1 ) C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( K1 ), 1 ) $ + P11*A( L1, L1 ) + P12*A( L1, L2 ) ) C VEC( 1, 2 ) = C( K1, L2 ) - $ ( DDOT( NP1-K1, A( K1, K1 ), LDA, DWORK( N+K1 ), $ 1) + P11*A( L2, L1 ) + P12*A( L2, L2 ) ) C VEC( 2, 1 ) = C( K2, L1 ) - $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( K1 ), $ 1) + P21*A( L1, L1 ) + P22*A( L1, L2 ) ) C VEC( 2, 2 ) = C( K2, L2 ) - $ ( DDOT( NP1-K1, A( K2, K1 ), LDA, DWORK( N+K1 ), 1) $ + P21*A( L2, L1 ) + P22*A( L2, L2 ) ) C IF( K1.EQ.L1 ) THEN CALL SB03MV( .TRUE., LUPPER, A( K1, K1 ), LDA, VEC, $ 2, SCALOC, X, 2, XNORM, IERR ) IF( LUPPER ) THEN X( 2, 1 ) = X( 1, 2 ) ELSE X( 1, 2 ) = X( 2, 1 ) END IF ELSE CALL SB04PX( .FALSE., .TRUE., -1, 2, 2, $ A( K1, K1 ), LDA, A( L1, L1 ), LDA, $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) END IF IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 100 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 100 CONTINUE C CALL DSCAL( N, SCALOC, DWORK, 1 ) CALL DSCAL( N, SCALOC, DWORK( NP1 ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) IF( K1.NE.L1 ) THEN C( L1, K1 ) = X( 1, 1 ) C( L2, K1 ) = X( 1, 2 ) C( L1, K2 ) = X( 2, 1 ) C( L2, K2 ) = X( 2, 2 ) END IF END IF C 110 CONTINUE C 120 CONTINUE C END IF C RETURN C *** Last line of SB03MX *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03MU.f0000644000000000000000000000013015012430707016204 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03MU.f0000644000175000017500000003411615012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE SB03MU( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) C C PURPOSE C C To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in C C ISGN*op(TL)*X*op(TR) - X = SCALE*B, C C where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1 C or -1. op(T) = T or T', where T' denotes the transpose of T. C C ARGUMENTS C C Mode Parameters C C LTRANL LOGICAL C Specifies the form of op(TL) to be used, as follows: C = .FALSE.: op(TL) = TL, C = .TRUE. : op(TL) = TL'. C C LTRANR LOGICAL C Specifies the form of op(TR) to be used, as follows: C = .FALSE.: op(TR) = TR, C = .TRUE. : op(TR) = TR'. C C ISGN INTEGER C Specifies the sign of the equation as described before. C ISGN may only be 1 or -1. C C Input/Output Parameters C C N1 (input) INTEGER C The order of matrix TL. N1 may only be 0, 1 or 2. C C N2 (input) INTEGER C The order of matrix TR. N2 may only be 0, 1 or 2. C C TL (input) DOUBLE PRECISION array, dimension (LDTL,2) C The leading N1-by-N1 part of this array must contain the C matrix TL. C C LDTL INTEGER C The leading dimension of array TL. LDTL >= MAX(1,N1). C C TR (input) DOUBLE PRECISION array, dimension (LDTR,2) C The leading N2-by-N2 part of this array must contain the C matrix TR. C C LDTR INTEGER C The leading dimension of array TR. LDTR >= MAX(1,N2). C C B (input) DOUBLE PRECISION array, dimension (LDB,2) C The leading N1-by-N2 part of this array must contain the C right-hand side of the equation. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N1). C C SCALE (output) DOUBLE PRECISION C The scale factor. SCALE is chosen less than or equal to 1 C to prevent the solution overflowing. C C X (output) DOUBLE PRECISION array, dimension (LDX,N2) C The leading N1-by-N2 part of this array contains the C solution of the equation. C Note that X may be identified with B in the calling C statement. C C LDX INTEGER C The leading dimension of array X. LDX >= MAX(1,N1). C C XNORM (output) DOUBLE PRECISION C The infinity-norm of the solution. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if TL and TR have almost reciprocal eigenvalues, so C TL or TR is perturbed to get a nonsingular equation. C C NOTE: In the interests of speed, this routine does not C check the inputs for errors. C C METHOD C C The equivalent linear algebraic system of equations is formed and C solved using Gaussian elimination with complete pivoting. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C The algorithm is stable and reliable, since Gaussian elimination C with complete pivoting is used. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. C Based on DLASD2 by P. Petkov, Tech. University of Sofia, September C 1993. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. C C KEYWORDS C C Discrete-time system, Sylvester equation, matrix algebra. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, HALF, EIGHT PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) C .. C .. Scalar Arguments .. LOGICAL LTRANL, LTRANR INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 DOUBLE PRECISION SCALE, XNORM C .. C .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), $ X( LDX, * ) C .. C .. Local Scalars .. LOGICAL BSWAP, XSWAP INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, $ TEMP, U11, U12, U22, XMAX C .. C .. Local Arrays .. LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), $ LOCU22( 4 ) DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, IDAMAX C .. C .. External Subroutines .. EXTERNAL DSWAP C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. C .. Data statements .. DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , $ LOCU22 / 4, 3, 2, 1 / DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / C .. C .. Executable Statements .. C C Do not check the input parameters for errors. C INFO = 0 SCALE = ONE C C Quick return if possible. C IF( N1.EQ.0 .OR. N2.EQ.0 ) THEN XNORM = ZERO RETURN END IF C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS SGN = ISGN C K = N1 + N1 + N2 - 2 GO TO ( 10, 20, 30, 50 )K C C 1-by-1: SGN*TL11*X*TR11 - X = B11. C 10 CONTINUE TAU1 = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE BET = ABS( TAU1 ) IF( BET.LE.SMLNUM ) THEN TAU1 = SMLNUM BET = SMLNUM INFO = 1 END IF C GAM = ABS( B( 1, 1 ) ) IF( SMLNUM*GAM.GT.BET ) $ SCALE = ONE / GAM C X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 XNORM = ABS( X( 1, 1 ) ) RETURN C C 1-by-2: C ISGN*TL11*[X11 X12]*op[TR11 TR12] = [B11 B12]. C [TR21 TR22] C 20 CONTINUE C SMIN = MAX( MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) $ *ABS( TL( 1, 1 ) )*EPS, $ SMLNUM ) TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE TMP( 4 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE IF( LTRANR ) THEN TMP( 2 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) TMP( 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) ELSE TMP( 2 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) TMP( 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 1, 2 ) GO TO 40 C C 2-by-1: C ISGN*op[TL11 TL12]*[X11]*TR11 = [B11]. C [TL21 TL22] [X21] [B21] C 30 CONTINUE SMIN = MAX( MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) $ *ABS( TR( 1, 1 ) )*EPS, $ SMLNUM ) TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE TMP( 4 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE IF( LTRANL ) THEN TMP( 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) TMP( 3 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) ELSE TMP( 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) TMP( 3 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) 40 CONTINUE C C Solve 2-by-2 system using complete pivoting. C Set pivots less than SMIN to SMIN. C IPIV = IDAMAX( 4, TMP, 1 ) U11 = TMP( IPIV ) IF( ABS( U11 ).LE.SMIN ) THEN INFO = 1 U11 = SMIN END IF U12 = TMP( LOCU12( IPIV ) ) L21 = TMP( LOCL21( IPIV ) ) / U11 U22 = TMP( LOCU22( IPIV ) ) - U12*L21 XSWAP = XSWPIV( IPIV ) BSWAP = BSWPIV( IPIV ) IF( ABS( U22 ).LE.SMIN ) THEN INFO = 1 U22 = SMIN END IF IF( BSWAP ) THEN TEMP = BTMP( 2 ) BTMP( 2 ) = BTMP( 1 ) - L21*TEMP BTMP( 1 ) = TEMP ELSE BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) END IF IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE END IF X2( 2 ) = BTMP( 2 ) / U22 X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) IF( XSWAP ) THEN TEMP = X2( 2 ) X2( 2 ) = X2( 1 ) X2( 1 ) = TEMP END IF X( 1, 1 ) = X2( 1 ) IF( N1.EQ.1 ) THEN X( 1, 2 ) = X2( 2 ) XNORM = ABS( X2( 1 ) ) + ABS( X2( 2 ) ) ELSE X( 2, 1 ) = X2( 2 ) XNORM = MAX( ABS( X2( 1 ) ), ABS( X2( 2 ) ) ) END IF RETURN C C 2-by-2: C ISGN*op[TL11 TL12]*[X11 X12]*op[TR11 TR12]-[X11 X12] = [B11 B12]. C [TL21 TL22] [X21 X22] [TR21 TR22] [X21 X22] [B21 B22] C C Solve equivalent 4-by-4 system using complete pivoting. C Set pivots less than SMIN to SMIN. C 50 CONTINUE SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) SMIN = MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )*SMIN SMIN = MAX( EPS*SMIN, SMLNUM ) T16( 1, 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE T16( 2, 2 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE T16( 3, 3 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE T16( 4, 4 ) = SGN*TL( 2, 2 )*TR( 2, 2 ) - ONE IF( LTRANL ) THEN T16( 1, 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) T16( 2, 1 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) T16( 3, 4 ) = SGN*TL( 2, 1 )*TR( 2, 2 ) T16( 4, 3 ) = SGN*TL( 1, 2 )*TR( 2, 2 ) ELSE T16( 1, 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) T16( 2, 1 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) T16( 3, 4 ) = SGN*TL( 1, 2 )*TR( 2, 2 ) T16( 4, 3 ) = SGN*TL( 2, 1 )*TR( 2, 2 ) END IF IF( LTRANR ) THEN T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 1, 2 ) T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 2, 1 ) ELSE T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 2, 1 ) T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 1, 2 ) END IF IF( LTRANL .AND. LTRANR ) THEN T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) ELSE IF( LTRANL .AND. .NOT.LTRANR ) THEN T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) ELSE IF( .NOT.LTRANL .AND. LTRANR ) THEN T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) T16( 4, 1 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) ELSE T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) T16( 4, 1 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) BTMP( 3 ) = B( 1, 2 ) BTMP( 4 ) = B( 2, 2 ) C C Perform elimination C DO 100 I = 1, 3 XMAX = ZERO C DO 70 IP = I, 4 C DO 60 JP = I, 4 IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( T16( IP, JP ) ) IPSV = IP JPSV = JP END IF 60 CONTINUE C 70 CONTINUE C IF( IPSV.NE.I ) THEN CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) TEMP = BTMP( I ) BTMP( I ) = BTMP( IPSV ) BTMP( IPSV ) = TEMP END IF IF( JPSV.NE.I ) $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) JPIV( I ) = JPSV IF( ABS( T16( I, I ) ).LT.SMIN ) THEN INFO = 1 T16( I, I ) = SMIN END IF C DO 90 J = I + 1, 4 T16( J, I ) = T16( J, I ) / T16( I, I ) BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) C DO 80 K = I + 1, 4 T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) 80 CONTINUE C 90 CONTINUE C 100 CONTINUE C IF( ABS( T16( 4, 4 ) ).LT.SMIN ) $ T16( 4, 4 ) = SMIN IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), $ ABS( BTMP( 4 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE BTMP( 3 ) = BTMP( 3 )*SCALE BTMP( 4 ) = BTMP( 4 )*SCALE END IF C DO 120 I = 1, 4 K = 5 - I TEMP = ONE / T16( K, K ) TMP( K ) = BTMP( K )*TEMP C DO 110 J = K + 1, 4 TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) 110 CONTINUE C 120 CONTINUE C DO 130 I = 1, 3 IF( JPIV( 4-I ).NE.4-I ) THEN TEMP = TMP( 4-I ) TMP( 4-I ) = TMP( JPIV( 4-I ) ) TMP( JPIV( 4-I ) ) = TEMP END IF 130 CONTINUE C X( 1, 1 ) = TMP( 1 ) X( 2, 1 ) = TMP( 2 ) X( 1, 2 ) = TMP( 3 ) X( 2, 2 ) = TMP( 4 ) XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 3 ) ), $ ABS( TMP( 2 ) ) + ABS( TMP( 4 ) ) ) C RETURN C *** Last line of SB03MU *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04PB.f0000644000000000000000000000013215012430707016161 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04PB.f0000644000175000017500000002671115012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE MB04PB( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To reduce a Hamiltonian matrix, C C [ A G ] C H = [ T ] , C [ Q -A ] C C where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices, C to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U C is computed so that C C T [ Aout Gout ] C U H U = [ T ] , C [ Qout -Aout ] C C where Aout is upper Hessenberg and Qout is diagonal. C Blocked version. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C ILO (input) INTEGER C It is assumed that A is already upper triangular and Q is C zero in rows and columns 1:ILO-1. ILO is normally set by a C previous call to MB04DD; otherwise it should be set to 1. C 1 <= ILO <= N, if N > 0; ILO = 1, if 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. C On exit, the leading N-by-N part of this array contains C the matrix Aout and, in the zero part of Aout, C information about the elementary reflectors used to C compute the PVL factorization. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input/output) DOUBLE PRECISION array, dimension C (LDQG,N+1) C On entry, the leading N-by-N+1 part of this array must C contain the lower triangular part of the matrix Q and C the upper triangular part of the matrix G. C On exit, the leading N-by-N+1 part of this array contains C the diagonal of the matrix Qout, the upper triangular part C of the matrix Gout and, in the zero parts of Qout, C information about the elementary reflectors used to C compute the PVL factorization. C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C CS (output) DOUBLE PRECISION array, dimension (2N-2) C On exit, the first 2N-2 elements of this array contain the C cosines and sines of the symplectic Givens rotations used C to compute the PVL factorization. C C TAU (output) DOUBLE PRECISION array, dimension (N-1) C On exit, the first N-1 elements of this array contain the C scalar factors of some of the elementary reflectors. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK, 8*N*NB + 3*NB, where NB is the optimal C block size determined by the function UE01MD. C On exit, if INFO = -10, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,N-1). 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 matrix U is represented as a product of symplectic reflectors C and Givens rotations C C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). C C Each H(i) has the form C C H(i) = I - tau * v * v' C C where tau is a real scalar, and v is a real vector with C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in C QG(i+2:n,i), and tau in QG(i+1,i). C C Each F(i) has the form C C F(i) = I - nu * w * w' C C where nu is a real scalar, and w is a real vector with C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in C A(i+2:n,i), and nu in TAU(i). C C Each G(i) is a Givens rotation acting on rows i+1 and n+i+1, C where the cosine is stored in CS(2*i-1) and the sine in C CS(2*i). C C NUMERICAL ASPECTS C C The algorithm requires O(N**3) floating point operations and is C strongly backward stable. C C REFERENCES C C [1] C. F. VAN LOAN: C A symplectic method for approximating all the eigenvalues of C a Hamiltonian matrix. C Linear Algebra and its Applications, 61, pp. 233-251, 1984. C C [2] D. KRESSNER: C Block algorithms for orthogonal symplectic factorizations. C BIT, 43 (4), pp. 775-790, 2003. C C CONTRIBUTORS C C D. Kressner (Technical Univ. Berlin, Germany) and C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. C C REVISIONS C C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DHAPVB). C V. Sima, Aug. 2011. C C KEYWORDS C C Elementary matrix operations, Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER ILO, INFO, LDA, LDQG, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) C .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IERR, MINWRK, NB, NBMIN, NH, NIB, NNB, $ NX, PDW, PXA, PXG, PXQ, PYA, WRKOPT C .. External Functions .. INTEGER UE01MD EXTERNAL UE01MD C .. External Subroutines .. EXTERNAL DGEHRD, DGEMM, DSYR2K, MB04PA, MB04PU, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 MINWRK = MAX( 1, N-1 ) IF ( N.LT.0 ) THEN INFO = -1 ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE LQUERY = LDWORK.EQ.-1 IF ( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN DWORK(1) = DBLE( MINWRK ) INFO = -10 ELSE IF ( N.EQ.0 ) THEN WRKOPT = ONE ELSE CALL DGEHRD( N, ILO, N, DWORK, N, DWORK, DWORK, -1, $ INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) NB = INT( WRKOPT/N ) WRKOPT = MAX( WRKOPT, 8*N*NB + 3*NB ) END IF IF ( LQUERY ) THEN DWORK(1) = DBLE( WRKOPT ) RETURN END IF END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04PB', -INFO ) RETURN END IF C C Set elements 1:ILO-1 of TAU and CS. C DO 10 I = 1, ILO - 1 TAU( I ) = ZERO CS(2*I-1) = ONE CS(2*I) = ZERO 10 CONTINUE C C Quick return if possible. C IF ( N.LE.ILO ) THEN DWORK(1) = ONE RETURN END IF C C Determine the block size. C NH = N - ILO + 1 NBMIN = 2 IF ( NB.GT.1 .AND. NB.LT.NH ) THEN C C Determine when to cross over from blocked to unblocked code. C NX = MAX( NB, UE01MD( 3, 'MB04PB', ' ', N, ILO, -1 ) ) IF ( NX.LT.NH ) THEN C C Check whether workspace is large enough for blocked code. C IF ( LDWORK.LT.WRKOPT ) THEN C C Not enough workspace available. Determine minimum value C of NB, and reduce NB. C NBMIN = MAX( 2, UE01MD( 2, 'MB04PB', ' ', N, ILO, -1 ) ) NB = LDWORK / ( 8*N + 3 ) END IF END IF END IF C NNB = N*NB PXA = 1 PYA = PXA + 2*NNB PXQ = PYA + 2*NNB PXG = PXQ + 2*NNB PDW = PXG + 2*NNB C IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN C C Use unblocked code. C I = ILO C ELSE DO 20 I = ILO, N-NX-1, NB IB = MIN( NB, N-I ) NIB = N*IB C C Reduce rows and columns i:i+nb-1 to PVL form and return the C matrices XA, XG, XQ, and YA which are needed to update the C unreduced parts of the matrices. C CALL MB04PA( .TRUE., N-I+1, I-1, IB, A(1,I), LDA, QG(1,I), $ LDQG, DWORK(PXA), N, DWORK(PXG), N, $ DWORK(PXQ), N, DWORK(PYA), N, CS(2*I-1), $ TAU(I), DWORK(PDW) ) IF ( N.GT.I+IB ) THEN C C Update the submatrix A(1:n,i+ib+1:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, $ IB, ONE, QG(I+IB+1,I), LDQG, DWORK(PXA+IB+1), $ N, ONE, A(I+IB+1,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, $ IB, ONE, A(I+IB+1,I), LDA, $ DWORK(PXA+NIB+IB+1), N, ONE, $ A(I+IB+1,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, $ ONE, DWORK(PYA), N, QG(I+IB+1,I), LDQG, ONE, $ A(1,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, $ ONE, DWORK(PYA+NIB), N, A(I+IB+1,I), LDA, $ ONE, A(1,I+IB+1), LDA ) C C Update the submatrix Q(i+ib+1:n,i+ib+1:n). C CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE, $ DWORK(PXQ+IB+1), N, QG(I+IB+1,I), LDQG, ONE, $ QG(I+IB+1,I+IB+1), LDQG ) CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE, $ DWORK(PXQ+NIB+IB+1), N, A(I+IB+1,I), LDA, $ ONE, QG(I+IB+1,I+IB+1), LDQG ) C C Update the submatrix G(1:n,1:n). C CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, $ IB, ONE, DWORK(PXG), N, QG(I+IB+1,I), LDQG, $ ONE, QG(1,I+IB+2), LDQG ) CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, $ IB, ONE, DWORK(PXG+NIB), N, A(I+IB+1,I), LDA, $ ONE, QG(1,I+IB+2), LDQG ) CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE, $ DWORK(PXG+IB+I), N, QG(I+IB+1,I), LDQG, ONE, $ QG(I+IB+1,I+IB+2), LDQG ) CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE, $ DWORK(PXG+NIB+IB+I), N, A(I+IB+1,I), LDA, $ ONE, QG(I+IB+1,I+IB+2), LDQG ) END IF 20 CONTINUE END IF C C Unblocked code to reduce the rest of the matrices. C CALL MB04PU( N, I, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK, $ IERR ) C DWORK( 1 ) = DBLE( WRKOPT ) C RETURN C *** Last line of MB04PB *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01WX.f0000644000000000000000000000013215012430707016222 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01WX.f0000644000175000017500000002275015012430707017424 0ustar00lilgelilge00000000000000 SUBROUTINE TB01WX( COMPU, N, M, P, A, LDA, B, LDB, C, LDC, U, LDU, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To reduce the system state matrix A to an upper Hessenberg form C by using an orthogonal similarity transformation A <-- U'*A*U and C to apply the transformation to the matrices B and C: B <-- U'*B C and C <-- C*U. C C ARGUMENTS C C Mode Parameters C C COMPU CHARACTER*1 C = 'N': do not compute U; C = 'I': U is initialized to the unit matrix, and the C orthogonal matrix U is returned; C = 'U': U must contain an orthogonal matrix U1 on entry, C and the product U1*U is returned. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e., the order of the matrix A. N >= 0. C C M (input) INTEGER C The number of system inputs, or of columns of B. M >= 0. C C P (input) INTEGER C The number of system outputs, or of rows of C. 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 original state dynamics matrix A. C On exit, the leading N-by-N part of this array contains C the matrix U' * A * U in Hessenberg form. The elements C below the first subdiagonal are set to zero. C C LDA INTEGER C The leading dimension of the 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 matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix U' * B. C C LDB INTEGER C The leading dimension of the 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 output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed output matrix C * U. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) C On entry, if COMPU = 'U', the leading N-by-N part of this C array must contain the given matrix U1. Otherwise, this C array need not be set on input. C On exit, if COMPU <> 'N', the leading N-by-N part of this C array contains the orthogonal transformation matrix used C to reduce A to the Hessenberg form (U1*U if COMPU = 'U'). C If COMPU = 'N', this array is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= 1, if COMPU = 'N'; C LDU >= max(1,N), if COMPU <> 'N'. 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 length of the array DWORK. LDWORK >= 1, and if N > 0, C LDWORK >= N - 1 + MAX(N,M,P). C For optimum performance LDWORK should be larger. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 Matrix A is reduced to the Hessenberg form using an orthogonal C similarity transformation A <- U'*A*U. Then, the transformation C is applied to the matrices B and C: B <-- U'*B and C <-- C*U. C C NUMERICAL ASPECTS C 3 2 C The algorithm requires about 5N /3 + N (M+P) floating point C 3 C operations, if COMPU = 'N'. Otherwise, 2N /3 additional operations C are needed. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, April 2002. C C REVISIONS C C V. Sima, Dec. 2016. C C KEYWORDS C C Orthogonal transformation, Hessenberg form, similarity C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER COMPU INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*) C .. Local Scalars .. LOGICAL ILU, LQUERY INTEGER ICOMPU, ITAU, JWORK, MINWRK, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEHRD, DLACPY, DORGHR, DORMHR, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C C .. Executable Statements .. C C Decode COMPU. C IF( LSAME( COMPU, 'N' ) ) THEN ILU = .FALSE. ICOMPU = 1 ELSE IF( LSAME( COMPU, 'U' ) ) THEN ILU = .TRUE. ICOMPU = 2 ELSE IF( LSAME( COMPU, 'I' ) ) THEN ILU = .TRUE. ICOMPU = 3 ELSE ICOMPU = 0 END IF C INFO = 0 C C Check input parameters. C IF( ICOMPU.LE.0 ) 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( LDU.LT.1 .OR. ( ILU .AND. LDU.LT.MAX( 1, N ) ) ) THEN INFO = -12 ELSE LQUERY = LDWORK.LT.0 IF( N.EQ.0 ) THEN MINWRK = 1 ELSE MINWRK = N - 1 + MAX( N, M, P ) END IF IF( LQUERY ) THEN CALL DGEHRD( N, 1, N, A, LDA, DWORK, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, N - 1 + INT( DWORK(1) ) ) CALL DORMHR( 'Left', 'Transpose', N, M, 1, N, A, LDA, $ DWORK, B, LDB, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, N - 1 + INT( DWORK(1) ) ) CALL DORMHR( 'Right', 'No transpose', P, N, 1, N, A, LDA, $ DWORK, C, LDC, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, N - 1 + INT( DWORK(1) ) ) IF( ILU ) THEN IF( ICOMPU.EQ.3 ) THEN CALL DORGHR( N, 1, N, U, LDU, DWORK, DWORK, -1, INFO ) ELSE CALL DORMHR( 'Right', 'No transpose', N, N, 1, N, A, $ LDA, DWORK, U, LDU, DWORK, -1, INFO ) END IF WRKOPT = MAX( WRKOPT, N - 1 + INT( DWORK(1) ) ) END IF ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -14 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01WX', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Reduce A to Hessenberg form using an orthogonal similarity C transformation, A <- U'*A*U, and apply the orthogonal C transformations to B and C such that B <- U'*B, C <- C*U. C C Workspace: need N-1+MAX(N,M,P); C prefer N - 1 + MAX(N,M,P)*NB. C ITAU = 1 JWORK = ITAU + N - 1 CALL DGEHRD( N, 1, N, A, LDA, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = INT( DWORK(JWORK) )+JWORK-1 C CALL DORMHR( 'Left', 'Transpose', N, M, 1, N, A, LDA, $ DWORK(ITAU), B, LDB, DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C CALL DORMHR( 'Right', 'No transpose', P, N, 1, N, A, LDA, $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C IF( ILU ) THEN IF( ICOMPU.EQ.3 ) THEN C C Accumulate the transformation in U. C Copy Householder vectors to U. C CALL DLACPY( 'Lower', N, N, A, LDA, U, LDU ) C C Generate orthogonal matrix in U. C Workspace: need 2*N-1, prefer 2*N+(N-1)*NB. C CALL DORGHR( N, 1, N, U, LDU, DWORK( ITAU ), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) ELSE C C Apply the transformation to U1. C CALL DORMHR( 'Right', 'No transpose', N, N, 1, N, A, LDA, $ DWORK(ITAU), U, LDU, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) END IF WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) END IF C IF( N.GT.2 ) $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) C DWORK(1) = WRKOPT C RETURN C *** Last line of TB01WX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04FP.f0000644000000000000000000000013215012430707016165 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04FP.f0000644000175000017500000012510515012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE MB04FP( JOB, COMPQ, N, A, LDA, DE, LDDE, B, LDB, FG, $ LDFG, Q, LDQ, ALPHAR, ALPHAI, BETA, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the eigenvalues of a real N-by-N skew-Hamiltonian/ C skew-Hamiltonian pencil aS - bT with C C ( A D ) ( B F ) C S = ( ) and T = ( ). (1) C ( E A' ) ( G B' ) C C Optionally, if JOB = 'T', the pencil aS - bT will be transformed C to the structured Schur form: an orthogonal transformation matrix C Q is computed such that C C ( Aout Dout ) C J Q' J' S Q = ( ), and C ( 0 Aout' ) C (2) C ( Bout Fout ) ( 0 I ) C J Q' J' T Q = ( ), where J = ( ), C ( 0 Bout' ) ( -I 0 ) C C Aout is upper triangular, and Bout is upper quasi-triangular. The C notation M' denotes the transpose of the matrix M. C Optionally, if COMPQ = 'I' or COMPQ = 'U', the orthogonal C transformation matrix Q will be computed. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; S and T will not C necessarily be put into skew-Hamiltonian C triangular form (2); C = 'T': put S and T into skew-Hamiltonian triangular form C (2), and return the eigenvalues in ALPHAR, ALPHAI C and BETA. C C COMPQ CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q as follows: C = 'N': Q is not computed; C = 'I': the array Q is initialized internally to the unit C matrix, and the orthogonal matrix Q is returned; C = 'U': the array Q contains an orthogonal matrix Q0 on C entry, and the product Q0*Q is returned, where Q C is the product of the orthogonal transformations C that are applied to the pencil aS - bT to reduce C S and T to the forms in (2), for COMPQ = 'I'. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bT. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix A. C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix Aout; otherwise, it contains C meaningless elements, except for the diagonal blocks, C which are correctly set. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C DE (input/output) DOUBLE PRECISION array, dimension C (LDDE, N/2+1) C On entry, the leading N/2-by-N/2 strictly lower triangular C part of this array must contain the strictly lower C triangular part of the skew-symmetric matrix E, and the C N/2-by-N/2 strictly upper triangular part of the submatrix C in the columns 2 to N/2+1 of this array must contain the C strictly upper triangular part of the skew-symmetric C matrix D. C The entries on the diagonal and the first superdiagonal of C this array are not referenced, but are assumed to be zero. C On exit, if JOB = 'T', the leading N/2-by-N/2 strictly C upper triangular part of the submatrix in the columns C 2 to N/2+1 of this array contains the strictly upper C triangular part of the skew-symmetric matrix Dout. C If JOB = 'E', the leading N/2-by-N/2 strictly upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array contains the strictly upper triangular part C of the skew-symmetric matrix D just before the application C of the QZ algorithm. The remaining entries are C meaningless. C C LDDE INTEGER C The leading dimension of the array DE. C LDDE >= MAX(1, N/2). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix Bout; otherwise, it contains C meaningless elements, except for the diagonal 1-by-1 and C 2-by-2 blocks, which are correctly set. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C FG (input/output) DOUBLE PRECISION array, dimension C (LDFG, N/2+1) C On entry, the leading N/2-by-N/2 strictly lower triangular C part of this array must contain the strictly lower C triangular part of the skew-symmetric matrix G, and the C N/2-by-N/2 strictly upper triangular part of the submatrix C in the columns 2 to N/2+1 of this array must contain the C strictly upper triangular part of the skew-symmetric C matrix F. C The entries on the diagonal and the first superdiagonal of C this array are not referenced, but are assumed to be zero. C On exit, if JOB = 'T', the leading N/2-by-N/2 strictly C upper triangular part of the submatrix in the columns C 2 to N/2+1 of this array contains the strictly upper C triangular part of the skew-symmetric matrix Fout. C If JOB = 'E', the leading N/2-by-N/2 strictly upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array contains the strictly upper triangular part C of the skew-symmetric matrix F just before the application C of the QZ algorithm. The remaining entries are C meaningless. C C LDFG INTEGER C The leading dimension of the array FG. C LDFG >= MAX(1, N/2). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) C On entry, if COMPQ = 'U', then the leading N-by-N part of C this array must contain a given matrix Q0, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q0 and the transformation matrix Q C used to transform the matrices S and T. C On exit, if COMPQ = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q. C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bT. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bT. C If ALPHAI(j) is zero, then the j-th eigenvalue is real; if C positive, then the j-th and (j+1)-st eigenvalues are a C complex conjugate pair. C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta that define the eigenvalues of the pencil C aS - bT. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bT, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C Due to the skew-Hamiltonian/skew-Hamiltonian structure of C the pencil, every eigenvalue occurs twice and thus it has C only to be saved once in ALPHAR, ALPHAI and BETA. C C Workspace C C IWORK INTEGER array, dimension (N/2+1) C On exit, IWORK(1) contains the number of (pairs of) C possibly inaccurate eigenvalues, q <= N/2, and the C nonzero absolute values in IWORK(2), ..., IWORK(N/2+1) are C indices of the possibly inaccurate eigenvalues, as well as C of the corresponding 1-by-1 or 2-by-2 diagonal blocks in C the arrays A and B on exit. The 2-by-2 blocks correspond C to negative values in IWORK. One negative value is stored C for each such eigenvalue pair. Its modulus indicates the C starting index of a 2-by-2 block. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; C DWORK(2) and DWORK(3) contain the Frobenius norms of the C matrices S and T on entry. These norms are used in the C tests to decide that some eigenvalues are considered as C unreliable. C On exit, if INFO = -19, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= MAX(3,N/2,2*N-6), if JOB = 'E' and COMPQ = 'N'; C LDWORK >= MAX(3,N**2/4+N/2), if JOB = 'T' and COMPQ = 'N'; C LDWORK >= MAX(1,3*N**2/4), if COMPQ<> 'N'. C For good performance LDWORK should generally 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: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: QZ iteration failed in the LAPACK Library routine C DHGEQZ. (QZ iteration did not converge or computation C of the shifts failed.) C = 2: warning: the pencil is numerically singular. C C METHOD C C The algorithm uses Givens rotations and Householder reflections to C annihilate elements in S and T such that S is in skew-Hamiltonian C triangular form and T is in skew-Hamiltonian Hessenberg form: C C ( A1 D1 ) ( B1 F1 ) C S = ( ), T = ( ), C ( 0 A1' ) ( 0 B1' ) C C where A1 is upper triangular and B1 is upper Hessenberg. C Subsequently, the QZ algorithm is applied to the pencil aA1 - bB1 C to determine orthogonal matrices Q1 and Q2 such that C Q2' A1 Q1 is upper triangular and Q2' B1 Q1 is upper quasi- C triangular. C See also page 40 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C real floating point operations. C C FURTHER COMMENTS C C For large values of N, the routine applies the transformations C for reducing T on panels of columns. The user may specify in INFO C the desired number of columns. If on entry INFO <= 0, then the C routine estimates a suitable value of this number. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2011. C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, Dec. 2011. C C REVISIONS C C V. Sima, July 2013, Aug. 2014, Jan. 2017, Apr. 2020. C M. Voigt, July 2013. C C KEYWORDS C C QZ algorithm, upper (quasi-)triangular matrix, C skew-Hamiltonian/skew-Hamiltonian pencil. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO, THREE, TEN PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, $ TWO = 2.0D+0, THREE = 3.0D+0, TEN = 1.0D+1 $ ) INTEGER MMIN PARAMETER ( MMIN = 32 ) C C .. Scalar Arguments .. CHARACTER COMPQ, JOB INTEGER INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK, N C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), DE( LDDE, * ), $ DWORK( * ), FG( LDFG, * ), Q( LDQ, * ) INTEGER IWORK( * ) C C .. Local Scalars .. LOGICAL LCMPQ, LINIQ, LQUERY, LTRI, LUPDQ, PSNG, $ SING CHARACTER*16 CMPQ, CMPSC, CMPZ INTEGER I, IC, ICS, IQ1, IQ2, IWRK, J, JA, JC, JE, JS, $ K, M, M1, MINDW, MJ1, MJ2, MJ3, MK2, MK3, MM, $ NB, NBETA0, NC, NINF, OPTDW, P DOUBLE PRECISION CO, MU, NRM, NRMS, NRMT, NU, SDET, SI, TMP1, $ TMP2, TOLS, TOLT, X1, X2, X3, X4 C C .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) C C .. External Functions .. LOGICAL LSAME INTEGER MA02OD DOUBLE PRECISION DDOT, DLAMCH, DLANGE, DLANTR, DLAPY2, MA02ID EXTERNAL DDOT, DLAMCH, DLANGE, DLANTR, DLAPY2, LSAME, $ MA02ID, MA02OD C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DHGEQZ, DLACPY, $ DLARF, DLARFG, DLARTG, DLAS2, DLASET, DLASSQ, $ DROT, MA02PD, MB01LD, MB01MD, MB01ND, MB04FD, $ XERBLA C C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, MOD, SIGN, SQRT C C .. Executable Statements .. C C Decode the input arguments. C NB = INFO M = N/2 MM = M*M M1 = MAX( 1, M ) C IF( NB.LE.0 ) THEN CALL DGEQRF( M, M, A, LDA, DWORK, DWORK, -1, INFO ) NB = MIN( MAX( INT( DWORK( 1 ) )/M1, 2 ), M ) END IF C IF( NB.EQ.M .OR. M.LE.MMIN ) THEN CALL MB04FD( JOB, COMPQ, N, A, LDA, DE, LDDE, B, LDB, FG, $ LDFG, Q, LDQ, ALPHAR, ALPHAI, BETA, IWORK, $ DWORK, LDWORK, INFO ) RETURN END IF LTRI = LSAME( JOB, 'T' ) LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LCMPQ = LINIQ .OR. LUPDQ LQUERY = LDWORK.EQ.-1 C C Determine the mode of computations. C IQ1 = 1 IF( LCMPQ ) THEN CMPQ = 'Initialize' CMPZ = CMPQ IQ2 = IQ1 + MM IWRK = IQ2 + MM MINDW = MAX( 3, IWRK - 1 + MM ) ELSE IF( LTRI ) THEN CMPQ = 'Initialize' CMPZ = 'No Computation' IQ2 = 1 IWRK = IQ2 + MM MINDW = MAX( 3, IWRK - 1 + M ) ELSE CMPQ = 'No Computation' CMPZ = CMPQ IQ2 = 1 IWRK = 1 MINDW = MAX( 3, M, 2*N - 6 ) END IF K = IWRK - 1 C IF( LTRI ) THEN CMPSC = 'Schur Form' ELSE CMPSC = 'Eigenvalues Only' END IF C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.M1 ) THEN INFO = -5 ELSE IF( LDDE.LT.M1 ) THEN INFO = -7 ELSE IF( LDB.LT.M1 ) THEN INFO = -9 ELSE IF( LDFG.LT.M1 ) THEN INFO = -11 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN INFO = -13 ELSE IF( LDWORK.LT.MINDW .AND. .NOT.LQUERY ) THEN DWORK( 1 ) = MINDW INFO = -19 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04FP', -INFO ) RETURN ELSE IF( N.GT.0 .AND. LQUERY ) THEN CALL DHGEQZ( CMPSC, CMPQ, CMPZ, M, 1, M, B, LDB, A, LDA, $ ALPHAR, ALPHAI, BETA, DWORK, M1, DWORK, M1, $ DWORK, -1, INFO ) C IF( LCMPQ ) THEN OPTDW = K + MAX( K, INT( DWORK( 1 ) ) ) ELSE IF( LTRI ) THEN OPTDW = K + MAX( K - M, INT( DWORK( 1 ) ) ) ELSE OPTDW = INT( DWORK( 1 ) ) END IF DWORK( 1 ) = MAX( OPTDW, MINDW ) RETURN ELSE IF( LQUERY ) THEN DWORK( 1 ) = MINDW RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IWORK( 1 ) = 0 DWORK( 1 ) = THREE DWORK( 2 ) = ZERO DWORK( 3 ) = ZERO RETURN END IF C C Find half of the number of infinite eigenvalues if S is diagonal. C Otherwise, find a lower bound of this number. C NINF = 0 IF( M.EQ.1 ) THEN NRM = ZERO ELSE NRM = DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, DE( 2, 1 ), $ LDDE, DWORK ) + $ DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, DE( 1, 2 ), $ LDDE, DWORK ) END IF IF( NRM.EQ.ZERO ) THEN IF( M.EQ.1 ) THEN NRMS = ABS( A( 1, 1 ) ) IF( NRMS.EQ.ZERO ) $ NINF = 1 ELSE IF( DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, A( 2, 1 ), $ LDA, DWORK ).EQ.ZERO .AND. $ DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, A( 1, 2 ), $ LDA, DWORK ).EQ.ZERO ) THEN TMP1 = ZERO TMP2 = ONE CALL DLASSQ( M, A, LDA+1, TMP1, TMP2 ) NRMS = TMP1*SQRT( TMP2 ) DO 10 J = 1, M IF( ABS( A( J, J ) ).EQ.ZERO ) $ NINF = NINF + 1 10 CONTINUE ELSE CALL MA02PD( M, M, A, LDA, J, K ) NINF = MAX( J, K ) NRMS = DLANGE( 'Frobenius', M, M, A, LDA, DWORK ) END IF END IF NRMS = NRMS*SQRT( TWO ) ELSE C C Incrementing NINF below is due to even multiplicity of C eigenvalues for real skew-Hamiltonian matrices. C NINF = MA02OD( 'Skew', M, A, LDA, DE, LDDE ) IF( MOD( NINF, 2 ).GT.0 ) $ NINF = NINF + 1 NINF = NINF/2 NRMS = MA02ID( 'Skew', 'Frobenius', M, A, LDA, DE, LDDE, $ DWORK ) END IF C NRMT = MA02ID( 'Skew', 'Frobenius', M, B, LDB, FG, LDFG, DWORK ) C C STEP 1: Reduce S to skew-Hamiltonian triangular form. C C Workspace: need N, if COMPQ <> 'N'; C M, if COMPQ = 'N'. C IF( LINIQ ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) C DUM( 1 ) = ZERO C DO 20 K = 1, M - 1 C C Generate elementary reflector H(k) = I - nu * v * v' to C annihilate E(k+2:m,k). C MK2 = MIN( K+2, M ) MK3 = MK2 + 1 TMP1 = DE( K+1, K ) CALL DLARFG( M-K, TMP1, DE( MK2, K ), 1, NU ) IF( NU.NE.ZERO ) THEN DE( K+1, K ) = ONE C C Apply H(k) from both sides to E(k+1:m,k+1:m). C Compute x := nu * E(k+1:m,k+1:m) * v. C CALL MB01MD( 'Lower', M-K, NU, DE( K+1, K+1 ), LDDE, $ DE( K+1, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v in x. C MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 ) CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C E := E + v * w' - w * v'. C CALL MB01ND( 'Lower', M-K, ONE, DE( K+1, K ), 1, DWORK, 1, $ DE( K+1, K+1 ), LDDE ) C C Apply H(k) to G(k+1:m,1:k) from the left (and implicitly to C G(1:k,k+1:m) from the right). C CALL DLARF( 'Left', M-K, K, DE( K+1, K ), 1, NU, $ FG( K+1, 1 ), LDFG, DWORK ) C C Apply H(k) from both sides to G(k+1:m,k+1:m). C Compute x := nu * G(k+1:m,k+1:m) * v. C CALL MB01MD( 'Lower', M-K, NU, FG( K+1, K+1 ), LDFG, $ DE( K+1, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 ) CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C G := G + v * w' - w * v'. C CALL MB01ND( 'Lower', M-K, ONE, DE( K+1, K ), 1, DWORK, 1, $ FG( K+1, K+1 ), LDFG ) C C Apply H(k) from the right hand side to A(1:m,k+1:m) and C B(1:m,k+1:m). C CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU, $ A( 1, K+1 ), LDA, DWORK ) CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU, $ B( 1, K+1 ), LDB, DWORK ) C IF( LCMPQ ) THEN C C Apply H(k) from the right hand side to Q(1:n,k+1:m). C CALL DLARF( 'Right', N, M-K, DE( K+1, K ), 1, NU, $ Q( 1, K+1 ), LDQ, DWORK ) END IF DE( K+1, K ) = TMP1 END IF C C Determine a Givens rotation to annihilate E(k+1,k) from the C left. C TMP2 = A( K+1, K ) CALL DLARTG( TMP2, TMP1, CO, SI, A( K+1, K ) ) C C Update A, D and E. C CALL DROT( M-K-1, DE( MK2, K+1 ), 1, A( K+1, MK2 ), LDA, CO, $ SI ) CALL DROT( K, A( 1, K+1 ), 1, DE( 1, K+2 ), 1, CO, SI ) CALL DROT( M-K-1, DE( K+1, MK3 ), LDDE, A( MK2, K+1 ), 1, CO, $ SI ) C C Update B, G and F. C CALL DROT( K, FG( K+1, 1 ), LDFG, B( K+1, 1 ), LDB, CO, -SI ) CALL DROT( M-K-1, FG( MK2, K+1 ), 1, B( K+1, MK2 ), LDB, CO, $ SI ) CALL DROT( K, B( 1, K+1 ), 1, FG( 1, K+2 ), 1, CO, SI ) CALL DROT( M-K-1, FG( K+1, MK3 ), LDFG, B( MK2, K+1 ), 1, CO, $ SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, M+K+1 ), 1, Q( 1, K+1 ), 1, CO, -SI ) END IF C C Generate elementary reflector P(k) to annihilate A(k+1:m,k). C TMP1 = A( K, K ) CALL DLARFG( M-K+1, TMP1, A( K+1, K ), 1, NU ) IF( NU.NE.ZERO ) THEN A( K, K ) = ONE C C Apply P(k) from the left hand side to A(k:m,k+1:m). C CALL DLARF( 'Left', M-K+1, M-K, A( K, K ), 1, NU, $ A( K, K+1 ), LDA, DWORK ) C C Apply P(k) to D(1:k-1,k:m) from the right (and implicitly to C D(k:m,1:k-1) from the left). C CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU, $ DE( 1, K+1 ), LDDE, DWORK ) C C Apply P(k) from both sides to D(k:m,k:m). C Compute x := nu * D(k:m,k:m) * v. C CALL MB01MD( 'Upper', M-K+1, NU, DE( K, K+1 ), LDDE, $ A( K, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v in x. C MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 ) CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C D := D + v * w' - w * v'. C CALL MB01ND( 'Upper', M-K+1, ONE, A( K, K ), 1, DWORK, 1, $ DE( K, K+1 ), LDDE ) C C Apply P(k) from the left hand side to B(k:m,1:m). C CALL DLARF( 'Left', M-K+1, M, A( K, K ), 1, NU, B( K, 1 ), $ LDB, DWORK ) C C Apply P(k) to F(1:k-1,k:m) from the right (and implicitly to C F(k:m,1:k-1) from the left). C CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU, $ FG( 1, K+1 ), LDFG, DWORK ) C C Apply P(k) from both sides to F(k:m,k:m). C Compute x := nu * F(k:m,k:m) * v. C CALL MB01MD( 'Upper', M-K+1, NU, FG( K, K+1 ), LDFG, $ A( K, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 ) CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C F := F + v * w' - w * v'. C CALL MB01ND( 'Upper', M-K+1, ONE, A( K, K ), 1, DWORK, 1, $ FG( K, K+1 ), LDFG ) C IF( LCMPQ ) THEN C C Apply P(k) from the right hand side to Q(1:n,m+k:n). C CALL DLARF( 'Right', N, M-K+1, A( K, K ), 1, NU, $ Q( 1, M+K ), LDQ, DWORK ) END IF A( K, K ) = TMP1 END IF C C Set A(k+1:m,k) to zero in order to be able to apply DHGEQZ. C CALL DCOPY( M-K, DUM, 0, A( K+1, K ), 1 ) 20 CONTINUE C C STEP 2: Reduce T to skew-Hamiltonian triangular form. C C Workspace: need 2*N - 6. C DO 230 K = 1, M - 1 C C I. Annihilate G(k+1:m-1,k). C JS = K + 1 JE = MIN( M, JS+NB-1 ) IC = 1 JC = 2*( M - K ) + 1 DO 60 J = K + 1, M - 1 MJ2 = MIN( J+2, M ) MJ3 = MJ2 + 1 C C Determine a Givens rotation to annihilate G(j,k) from the C left. C CALL DLARTG( FG( J+1, K ), FG( J, K ), CO, SI, TMP1 ) DWORK( IC ) = CO DWORK( IC+1 ) = SI IC = IC + 2 C C Update B and G. C CALL DROT( M, B( 1, J+1 ), 1, B( 1, J ), 1, CO, SI ) FG( J+1, K ) = TMP1 CALL DROT( M-J-1, FG( MJ2, J+1 ), 1, FG( MJ2, J ), 1, CO, SI $ ) C IF( J.EQ.JE ) THEN C C Update the next panel (the columns JE+1 to JE+NB) of A, D C and F for previous row transformations. C JS = JE + 1 JE = MIN( M, JE+NB ) NC = JE - JS + 1 JA = 2*( M - K ) + 1 DO 30 I = K + 1, J - 1 CALL DROT( NC, A( I, JS ), LDA, A( I+1, JS ), LDA, $ DWORK( JA ), DWORK( JA+1 ) ) JA = JA + 2 30 CONTINUE JA = 2*( M - K ) + 1 DO 40 I = K + 1, J - 1 CALL DROT( NC, DE( I, JS+1 ), LDDE, DE( I+1, JS+1 ), $ LDDE, DWORK( JA ), DWORK( JA+1 ) ) JA = JA + 2 40 CONTINUE JA = 2*( M - K ) + 1 DO 50 I = K + 1, J - 1 CALL DROT( NC, FG( I, JS+1 ), LDFG, FG( I+1, JS+1 ), $ LDFG, DWORK( JA ), DWORK( JA+1 ) ) JA = JA + 2 50 CONTINUE END IF C C Update A. C CALL DROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO, SI ) TMP1 = -SI*A( J+1, J+1 ) A( J+1, J+1 ) = CO*A( J+1, J+1 ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate A(j+1,j) from the C left. C CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 ) DWORK( JC ) = CO DWORK( JC+1 ) = SI JC = JC + 2 C C Update A and D. C NC = MIN( JE-J, JE-JS+1 ) A( J, J ) = TMP2 CALL DROT( NC, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO, SI $ ) CALL DROT( J-1, DE( 1, J+1 ), 1, DE( 1, J+2 ), 1, CO, SI ) CALL DROT( NC-1, DE( J, MJ3 ), LDDE, DE( J+1, MJ3 ), LDDE, $ CO, SI ) C C Update B and F. C CALL DROT( J-1, FG( 1, J+1 ), 1, FG( 1, J+2 ), 1, CO, SI ) CALL DROT( NC-1, FG( J, MJ3 ), LDFG, FG( J+1, MJ3 ), LDFG, $ CO, SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, M+J ), 1, Q( 1, M+J+1 ), 1, CO, SI ) END IF 60 CONTINUE C C Update the remaining panels of columns of B and F for previous C row transformations. C DO 80 JS = 1, M, NB NC = MIN( M, JS+NB-1 ) - JS + 1 JC = 2*( M - K ) + 1 DO 70 J = K + 1, M - 1 CALL DROT( NC, B( J, JS ), LDB, B( J+1, JS ), LDB, $ DWORK( JC ), DWORK( JC+1 ) ) JC = JC + 2 70 CONTINUE 80 CONTINUE C ICS = 3 JE = K C C WHILE( JE.LT.M-2 ) DO 90 CONTINUE IF( JE.LT.M-2 ) THEN NC = 0 IC = ICS ICS = ICS + 2*NB DO 100 J = JE + 2, M - 1 NC = MIN( NC+1, NB ) JS = JE + 1 CALL DROT( NC, FG( J+1, JS ), LDFG, FG( J, JS ), LDFG, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 100 CONTINUE JE = JE + NB GO TO 90 END IF C END WHILE 90 C C II. Annihilate G(m,k). C C Determine a Givens rotation to annihilate G(m,k) from the C left. C CALL DLARTG( B( M, K ), -FG( M, K ), CO, SI, TMP1 ) C C Update B and G. C B( M, K ) = TMP1 FG( M, K ) = ZERO CALL DROT( M-1, FG( 1, M+1 ), 1, B( 1, M ), 1, CO, SI ) CALL DROT( M-K-1, FG( M, K+1 ), LDFG, B( M, K+1 ), LDB, CO, SI $ ) C C Update A and D. C CALL DROT( M-1, DE( 1, M+1 ), 1, A( 1, M ), 1, CO, SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO, SI ) END IF C C III. Annihilate B(k+2:m,k). C IC = 1 JC = 2*( M - K ) + 1 DO 110 J = M, K + 2, -1 C C Determine a Givens rotation to annihilate B(j,k) from the C left. C CALL DLARTG( B( J-1, K ), B( J, K ), CO, SI, TMP1 ) DWORK( IC ) = CO DWORK( IC+1 ) = SI IC = IC + 2 C C Update B and F. C B( J-1, K ) = TMP1 B( J, K ) = ZERO CALL DROT( J-2, FG( 1, J ), 1, FG( 1, J+1 ), 1, CO, SI ) C C Update A and D. C CALL DROT( 1, A( J-1, J ), LDA, A( J, J ), LDA, CO, SI ) TMP1 = -SI*A( J-1, J-1 ) A( J-1, J-1 ) = CO*A( J-1, J-1 ) CALL DROT( J-2, DE( 1, J ), 1, DE( 1, J+1 ), 1, CO, SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, M+J-1 ), 1, Q( 1, M+J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate A(j,j-1) from the C right. C CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 ) DWORK( JC ) = CO DWORK( JC+1 ) = SI JC = JC + 2 C C Update A. C A( J, J ) = TMP2 CALL DROT( J-1, A( 1, J ), 1, A( 1, J-1 ), 1, CO, SI ) C C Update B. C CALL DROT( M, B( 1, J ), 1, B( 1, J-1 ), 1, CO, SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, J ), 1, Q( 1, J-1 ), 1, CO, SI ) END IF 110 CONTINUE C C Update the remaining panels of columns of A, B, D, F, G for C previous row transformations. C DO 130 JS = K + 1, M, NB NC = MIN( M, JS+NB-1 ) - JS + 1 IC = 1 DO 120 J = M, K + 2, -1 CALL DROT( NC, B( J-1, JS ), LDB, B( J, JS ), LDB, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 120 CONTINUE 130 CONTINUE C ICS = 3 JE = M C C WHILE( JE.GT.3 ) DO 140 CONTINUE IF( JE.GT.3 ) THEN NC = 0 IC = ICS ICS = ICS + 2*NB DO 150 J = JE - 1, K + 2, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 2 CALL DROT( NC, FG( J-1, JS ), LDFG, FG( J, JS ), LDFG, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 150 CONTINUE JE = JE - NB GO TO 140 END IF C END WHILE 140 C ICS = 3 JE = M C C WHILE( JE.GT.2 ) DO 160 CONTINUE IF( JE.GT.2 ) THEN NC = 0 IC = ICS ICS = ICS + 2*NB DO 170 J = JE - 1, K + 2, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL DROT( NC, A( J-1, JS ), LDA, A( J, JS ), LDA, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 170 CONTINUE JE = JE - NB GO TO 160 END IF C END WHILE 160 C ICS = 3 JE = M C C WHILE( JE.GT.3 ) DO 180 CONTINUE IF( JE.GT.3 ) THEN NC = 0 IC = ICS ICS = ICS + 2*NB DO 190 J = JE - 1, K + 2, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 2 CALL DROT( NC, DE( J-1, JS ), LDDE, DE( J, JS ), LDDE, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 190 CONTINUE JE = JE - NB GO TO 180 END IF C END WHILE 180 C ICS = 2*( M - K ) + 1 DO 210 JS = K, M - 1, NB IC = ICS DO 200 J = M, JS + 2, -1 NC = MIN( J-JS-1, NB ) CALL DROT( NC, FG( J, JS ), LDFG, FG( J-1, JS ), LDFG, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 200 CONTINUE 210 CONTINUE C IC = 2*( M - K ) + 1 DO 220 J = M, K + 2, -1 MJ1 = MIN( J+1, M ) CALL DROT( M-J, FG( MJ1, J ), 1, FG( MJ1, J-1 ), 1, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 220 CONTINUE C 230 CONTINUE C C ( A1 D1 ) ( B1 F1 ) C Now we have S = ( ) and T = ( ), C ( 0 A1' ) ( 0 B1' ) C C where A1 is upper triangular and B1 is upper Hessenberg. C C STEP 3: Apply the QZ algorithm to the pencil aA1 - bB1 to C determine orthogonal matrices Q1 and Q2 such that C Q2' A1 Q1 is upper triangular and Q2' B1 Q1 is upper C quasi-triangular. C C Workspace: need w + M, where C w = 2*M**2, if COMPQ <> 'N'; C w = M**2, if COMPQ = 'N' and JOB = 'T'; C w = 0, if COMPQ = 'N' and JOB = 'E'; C prefer larger. C CALL DHGEQZ( CMPSC, CMPQ, CMPZ, M, 1, M, B, LDB, A, LDA, ALPHAR, $ ALPHAI, BETA, DWORK( IQ1 ), M, DWORK( IQ2 ), M, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Enforce the needed equalities in complex eigenvalues. C Count the number of found infinite eigenvalues, if necessary. C J = 1 NBETA0 = 0 C WHILE( J.LT.M ) DO 240 CONTINUE IF( J.LT.M ) THEN IF( ALPHAI( J ).NE.ZERO ) THEN IF( BETA( J ).GE.BETA( J + 1 ) ) THEN TMP2 = BETA( J + 1 )/BETA( J ) TMP1 = ( ALPHAR( J )*TMP2 + ALPHAR( J+1 ) )/TWO TMP2 = ( ALPHAI( J )*TMP2 - ALPHAI( J+1 ) )/TWO BETA( J ) = BETA( J+1 ) ELSE TMP2 = BETA( J )/BETA( J + 1 ) TMP1 = ( ALPHAR( J+1 )*TMP2 + ALPHAR( J ) )/TWO TMP2 = ( ALPHAI( J+1 )*TMP2 - ALPHAI( J ) )/TWO BETA( J+1 ) = BETA( J ) END IF ALPHAR( J ) = TMP1 ALPHAR( J+1 ) = TMP1 ALPHAI( J ) = TMP2 ALPHAI( J+1 ) = -TMP2 J = J + 2 ELSE IF( NINF.GT.0 ) THEN IF( BETA( J ).EQ.ZERO ) $ NBETA0 = NBETA0 + 1 END IF J = J + 1 END IF GO TO 240 ELSE IF( J.EQ.M .AND. NINF.GT.0 ) THEN IF( BETA( J ).EQ.ZERO ) $ NBETA0 = NBETA0 + 1 END IF C END WHILE 240 C C Set to infinity the largest eigenvalues, if necessary. C IF( NINF.GT.0 ) THEN DO 260 J = 1, NINF - NBETA0 TMP1 = ZERO TMP2 = ONE P = 1 DO 250 K = 1, M IF( BETA( K ).GT.ZERO ) THEN IF( ABS( ALPHAR( K ) )*TMP2.GT.TMP1*BETA( K ) )THEN TMP1 = ABS( ALPHAR( K ) ) TMP2 = BETA( K ) P = K END IF END IF 250 CONTINUE BETA( P ) = ZERO 260 CONTINUE END IF C IF( LTRI ) THEN C C Skew-symmetric update of D. C C Workspace: need w + M; C prefer w + M*(M-1). C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, DE( 1, 2 ), $ LDDE, DWORK( IQ1 ), M, DE( 1, 2 ), LDDE, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) C C Skew-symmetric update of F. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, FG( 1, 2 ), $ LDFG, DWORK( IQ1 ), M, FG( 1, 2 ), LDFG, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) END IF C IF( LCMPQ ) THEN C C Update Q. C Workspace: need 3*M*M; C prefer 4*M*M. C IF( LDWORK.GE.N*N ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q, LDQ, DWORK( IQ2 ), M, ZERO, DWORK( IWRK ), $ N ) CALL DLACPY( 'Full', N, M, DWORK( IWRK ), N, Q, LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q( 1, M+1 ), LDQ, DWORK( IQ1 ), M, ZERO, $ DWORK( IWRK ), N ) CALL DLACPY( 'Full', N, M, DWORK( IWRK ), N, Q( 1, M+1 ), $ LDQ ) ELSE CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q, LDQ, DWORK( IQ2 ), M, ZERO, DWORK( IWRK ), $ M ) CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q, LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q( M+1, 1 ), LDQ, DWORK( IQ2 ), M, ZERO, $ DWORK( IWRK ), M ) CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q( M+1, 1 ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q( 1, M+1 ), LDQ, DWORK( IQ1 ), M, ZERO, $ DWORK( IWRK ), M ) CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q( 1, M+1 ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q( M+1, M+1 ), LDQ, DWORK( IQ1 ), M, ZERO, $ DWORK( IWRK ), M ) CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q( M+1, M+1 ), $ LDQ ) END IF END IF C C Mark as unreliable the numerically infinite eigenvalues and C numerically zero eigenvalues. Store their indices. C The pencil is assumed regular. C TOLS = TEN*DLAMCH( 'Precision' )*NRMS TOLT = TEN*DLAMCH( 'Precision' )*NRMT P = 0 K = 1 C WHILE( K.LE.M ) DO 270 CONTINUE IF( K.LE.M ) THEN IF( BETA( K ).NE.ZERO ) THEN IF( ALPHAI( K ).EQ.ZERO ) THEN SING = ABS( B( K, K ) ).LT.TOLT IF( SING ) THEN P = P + 1 IWORK( P+1 ) = K END IF IF( ABS( A( K, K ) ).LT.TOLS ) THEN IF( SING ) THEN INFO = 2 ELSE P = P + 1 IWORK( P+1 ) = K END IF END IF ELSE X1 = B( K, K ) X2 = B( K+1, K ) X3 = B( K, K+1 ) X4 = B( K+1, K+1 ) NRM = DLANGE( 'Frobenius', 2, 2, B( K, K ), LDB, DWORK ) SDET = ( MAX( ABS( X1 ), ABS( X4 ) )/NRM ) $ *MIN( ABS( X1 ), ABS( X4 ) )* $ SIGN( ONE, X1 )*SIGN( ONE, X4 ) - $ ( MAX( ABS( X2 ), ABS( X3 ) )/NRM ) $ *MIN( ABS( X2 ), ABS( X3 ) )* $ SIGN( ONE, X2 )*SIGN( ONE, X3 ) IF( NRM.GT.ONE ) THEN PSNG = ABS( SDET ).LT.TOLT/NRM ELSE PSNG = ABS( SDET )*NRM.LT.TOLT END IF IF( PSNG ) THEN C C Make a more accurate singularity test using SVD. C IF ( ABS( X1 ).GE.ABS( X4 ) ) THEN CALL DLARTG( X1, X2, CO, SI, TMP1 ) X1 = TMP1 TMP1 = CO*X3 + SI*X4 X4 = CO*X4 - SI*X3 X3 = TMP1 ELSE CALL DLARTG( X4, X2, CO, SI, TMP1 ) X4 = TMP1 TMP1 = CO*X3 + SI*X1 X1 = CO*X1 - SI*X3 X3 = TMP1 END IF CALL DLAS2( X1, X3, X4, TMP1, TMP2 ) SING = TMP1.LT.TOLT IF ( SING ) THEN P = P + 1 IWORK( P+1 ) = -K INFO = 2 END IF END IF X1 = A( K, K ) X4 = A( K+1, K+1 ) NRM = DLAPY2( X1, X4 ) SDET = ( MAX( X1, X4 )/NRM )*MIN( X1, X4 ) IF ( ABS( SDET ).LT.TOLS ) THEN IF( SING ) THEN INFO = 2 ELSE P = P + 1 IWORK( P+1 ) = -K END IF END IF K = K + 1 END IF ELSE IWORK( K+1 ) = 0 END IF K = K + 1 GO TO 270 END IF C END WHILE 270 IWORK( 1 ) = P C DWORK( 1 ) = OPTDW DWORK( 2 ) = NRMS DWORK( 3 ) = NRMT RETURN C *** Last line of MB04FP *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03NY.f0000644000000000000000000000013215012430707016205 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03NY.f0000644000175000017500000001303115012430707017377 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION MB03NY( N, OMEGA, A, LDA, S, DWORK, $ LDWORK, CWORK, LCWORK, INFO ) C C PURPOSE C C To compute the smallest singular value of A - jwI. C C FUNCTION VALUE C C MB03NY DOUBLE PRECISION C The smallest singular value of A - jwI (if INFO = 0). C If N = 0, the function value is set to zero. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the the matrix A. N >= 0. C C OMEGA (input) DOUBLE PRECISION C The constant factor of A - jwI. C C A (input/workspace) DOUBLE PRECISION array, dimension C (LDA,N) C On entry, the leading N-by-N part of this array must C contain the matrix A. C On exit, if OMEGA = 0, the contents of this array are C destroyed. Otherwise, this array is unchanged. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C S (output) DOUBLE PRECISION array, dimension (N) C The singular values of A - jwI in decreasing order. 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 length of the array DWORK. LDWORK >= MAX( 1, 5*N ). C For optimum performance LDWORK should be larger. C C CWORK COMPLEX*16 array, dimension (LCWORK) C On exit, if INFO = 0 and OMEGA <> 0, CWORK(1) returns the C optimal value of LCWORK. C If OMEGA is zero, this array is not referenced. C C LCWORK INTEGER C The length of the array CWORK. C LCWORK >= 1, if OMEGA = 0; C LCWORK >= MAX( 1, N*N+3*N ), if OMEGA <> 0. C For optimum performance LCWORK 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 = 2: The SVD algorithm (in either LAPACK Library routine C DGESVD or ZGESVD) fails to converge; this error is C very rare. C C METHOD C C This procedure simply constructs the matrix A - jwI, and calls C ZGESVD if w is not zero, or DGESVD if w = 0. C C FURTHER COMMENTS C C This routine is not very efficient because it computes all C singular values, but it is very accurate. The routine is intended C to be called only from the SLICOT Library routine AB13FD. C C CONTRIBUTOR C C R. Byers, the routine SIGMIN (January, 1995). C C REVISIONS C C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. C C REVISIONS C C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. C Apr. 2002, V. Sima. C C KEYWORDS C C singular values. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) COMPLEX*16 CONE, RTMONE PARAMETER ( CONE = ( 1.0D0, 0.0D0 ), $ RTMONE = ( 0.0D0, 1.0D0 ) ) C .. Scalar Arguments .. INTEGER INFO, LCWORK, LDA, LDWORK, N DOUBLE PRECISION OMEGA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), S(*) COMPLEX*16 CWORK(*) C .. Local Scalars .. INTEGER I, IC, J C .. Local Arrays .. DOUBLE PRECISION DUMMY(1,1) COMPLEX*16 ZDUMMY(1,1) C .. External Subroutines .. EXTERNAL DGESVD, XERBLA, ZGESVD C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 C IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDWORK.LT.MAX( 1, 5*N ) ) THEN INFO = -7 ELSE IF( LCWORK.LT.1 .OR. ( OMEGA.NE.ZERO .AND. $ LCWORK.LT.N*N + 3*N ) ) THEN INFO = -9 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB03NY', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN MB03NY = ZERO DWORK(1) = ONE IF ( OMEGA.NE.ZERO ) $ CWORK(1) = CONE RETURN END IF C IF ( OMEGA.EQ.ZERO ) THEN C C OMEGA = 0 allows real SVD. C CALL DGESVD( 'No vectors', 'No vectors', N, N, A, N, S, DUMMY, $ 1, DUMMY, 1, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN INFO = 2 RETURN END IF ELSE C C General case, that is complex SVD. C IC = 1 DO 20 J = 1, N DO 10 I = 1, N CWORK(IC) = A(I,J) IC = IC + 1 10 CONTINUE CWORK((J-1)*N+J) = CWORK((J-1)*N+J) - OMEGA * RTMONE 20 CONTINUE CALL ZGESVD( 'No vectors', 'No vectors', N, N, CWORK, N, S, $ ZDUMMY, 1, ZDUMMY, 1, CWORK(N*N+1), LCWORK-N*N, $ DWORK, INFO ) IF ( INFO.NE.0 ) THEN INFO = 2 RETURN END IF CWORK(1) = CWORK(N*N+1) + DBLE( N*N ) * CONE DWORK(1) = DBLE( 5*N ) END IF C MB03NY = S(N) C C *** Last line of MB03NY *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02PZ.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02PZ.f0000644000175000017500000000454515012430707017412 0ustar00lilgelilge00000000000000 SUBROUTINE MA02PZ( M, N, A, LDA, NZR, NZC ) C C PURPOSE C C To compute the number of zero rows and zero columns of a complex C matrix. 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) COMPLEX*16 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 NZR (output) INTEGER C The number of zero rows of the matrix A. C C NZC (output) INTEGER C The number of zero columns of the matrix A. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Sep. 2016. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, complex matrix. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) C .. C .. Scalar Arguments .. INTEGER LDA, M, N, NZC, NZR C .. C .. Array Arguments .. COMPLEX*16 A( LDA, * ) C .. C .. Local Scalars .. INTEGER I, J C C ..Intrinsic Functions.. INTRINSIC MIN C .. C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked. C NZC = 0 NZR = 0 C IF( MIN( M, N ).GT.0 ) THEN C C Scan columns 1 .. N. C I = 0 C WHILE ( I.LE.N ) DO 10 CONTINUE I = I + 1 IF( I.LE.N ) THEN DO 20 J = 1, M IF( A( J, I ).NE.ZERO ) $ GO TO 10 20 CONTINUE NZC = NZC + 1 GO TO 10 C C END WHILE 10 END IF C C Scan rows 1 .. M. C I = 0 C WHILE ( I.LE.M ) DO 30 CONTINUE I = I + 1 IF( I.LE.M ) THEN DO 40 J = 1, N IF( A( I, J ).NE.ZERO ) $ GO TO 30 40 CONTINUE NZR = NZR + 1 GO TO 30 C END IF C END WHILE 30 END IF RETURN C C *** Last line of MA02PZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MD03BB.f0000644000000000000000000000013015012430707016142 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MD03BB.f0000644000175000017500000001550515012430707017346 0ustar00lilgelilge00000000000000 SUBROUTINE MD03BB( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To determine a value for the parameter PAR such that if x solves C the system C C A*x = b , sqrt(PAR)*D*x = 0 , C C in the least squares sense, where A is an m-by-n matrix, D is an C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, C then either PAR is zero and C C ( DXNORM - DELTA ) .LE. 0.1*DELTA , C C or PAR is positive and C C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . C C It is assumed that a QR factorization, with column pivoting, of A C is available, that is, A*P = Q*R, where P is a permutation matrix, C Q has orthogonal columns, and R is an upper triangular matrix C with diagonal elements of nonincreasing magnitude. C The routine needs the full upper triangle of R, the permutation C matrix P, and the first n components of Q'*b (' denotes the C transpose). On output, MD03BB also provides an upper triangular C matrix S such that C C P'*(A'*A + PAR*D*D)*P = S'*S . C C Matrix S is used in the solution process. C C This routine is an interface to SLICOT Library routine MD03BY, C for solving standard nonlinear least squares problems using SLICOT C routine MD03BD. C C ARGUMENTS C C Mode Parameters C C COND CHARACTER*1 C Specifies whether the condition of the matrices R and S C should be estimated, as follows: C = 'E' : use incremental condition estimation for R and S; C = 'N' : do not use condition estimation, but check the C diagonal entries of R and S for zero values; C = 'U' : use the rank already stored in RANKS (for R). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix R. N >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of the C matrix R. IPAR and LIPAR are not used by this routine, C but are provided for compatibility with SLICOT Library C routine MD03BD. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 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 full upper triangle is unaltered, and the C strict lower triangle contains the strict upper triangle C (transposed) of the upper triangular matrix S. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C IPVT (input) INTEGER array, dimension (N) C This array must define the permutation matrix P such that C A*P = Q*R. Column j of P is column IPVT(j) of the identity C matrix. C C DIAG (input) DOUBLE PRECISION array, dimension (N) C This array must contain the diagonal elements of the C matrix D. DIAG(I) <> 0, I = 1,...,N. C C QTB (input) DOUBLE PRECISION array, dimension (N) C This array must contain the first n elements of the C vector Q'*b. C C DELTA (input) DOUBLE PRECISION C An upper bound on the Euclidean norm of D*x. DELTA > 0. C C PAR (input/output) DOUBLE PRECISION C On entry, PAR must contain an initial estimate of the C Levenberg-Marquardt parameter. PAR >= 0. C On exit, it contains the final estimate of this parameter. C C RANKS (input or output) INTEGER array, dimension (1) C On entry, if COND = 'U' and N > 0, this array must contain C the numerical rank of the matrix R. C On exit, this array contains the numerical rank of the C matrix S. C RANKS is defined as an array for compatibility with SLICOT C Library routine MD03BD. C C X (output) DOUBLE PRECISION array, dimension (N) C This array contains the least squares solution of the C system A*x = b, sqrt(PAR)*D*x = 0. C C RX (output) DOUBLE PRECISION array, dimension (N) C This array contains the matrix-vector product -R*P'*x. C C Tolerances C C TOL DOUBLE PRECISION C If COND = 'E', the tolerance to be used for finding the C rank of the matrices R and S. If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C the reciprocal condition number; a (sub)matrix whose C estimated condition number is less than 1/TOL is C considered to be of full rank. If the user sets TOL <= 0, C then an implicitly computed, default tolerance, defined by C TOLDEF = N*EPS, is used instead, where EPS is the machine C precision (see LAPACK Library routine DLAMCH). C This parameter is not relevant if COND = 'U' or 'N'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, the first N elements of this array contain the C diagonal elements of the upper triangular matrix S. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 4*N, if COND = 'E'; C LDWORK >= 2*N, if COND <> 'E'. 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 This routine calls SLICOT Library routine MD03BY to perform the C calculations. C C FURTHER COMMENTS C C For efficiency, the arguments are not checked. This is done in C the routine MD03BY (except for LIPAR). C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C - C C KEYWORDS C C Linear system of equations, matrix operations, plane rotations. C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER COND INTEGER INFO, LDR, LDWORK, LIPAR, N DOUBLE PRECISION DELTA, PAR, TOL C .. Array Arguments .. INTEGER IPAR(*), IPVT(*), RANKS(*) DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) C .. External Subroutines .. EXTERNAL MD03BY C .. C .. Executable Statements .. C CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, $ RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO ) RETURN C C *** Last line of MD03BB *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01UD.f0000644000000000000000000000013215012430707016174 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01UD.f0000644000175000017500000004161215012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE TB01UD( JOBZ, N, M, P, A, LDA, B, LDB, C, LDC, NCONT, $ INDCON, NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To find a controllable realization for the linear time-invariant C multi-input system C C dX/dt = A * X + B * U, C Y = C * X, C C where A, B, and C are N-by-N, N-by-M, and P-by-N matrices, C respectively, and A and B are reduced by this routine to C orthogonal canonical form using (and optionally accumulating) C orthogonal similarity transformations, which are also applied C to C. Specifically, the system (A, B, C) is reduced to the C triplet (Ac, Bc, Cc), where Ac = Z' * A * Z, Bc = Z' * B, C Cc = C * Z, with C C [ Acont * ] [ Bcont ] C Ac = [ ], Bc = [ ], C [ 0 Auncont ] [ 0 ] C C and C C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] C Acont = [ . . . . . . . ], Bc = [ . ], C [ . . . . . . ] [ . ] C [ . . . . . ] [ . ] C [ 0 0 . . . Ap,p-1 App ] [ 0 ] C C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and C p is the controllability index of the pair. The size of the C block Auncont is equal to the dimension of the uncontrollable C subspace of the pair (A, B). C C ARGUMENTS C C Mode Parameters C C JOBZ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal similarity transformations for C reducing the system, as follows: C = 'N': Do not form Z and do not store the orthogonal C transformations; C = 'F': Do not form Z, but store the orthogonal C transformations in the factored form; C = 'I': Z is initialized to the unit matrix and the C orthogonal transformation matrix Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e. the order of the matrix A. N >= 0. C C M (input) INTEGER C The number of system inputs, or of columns of B. M >= 0. C C P (input) INTEGER C The number of system outputs, or of rows of C. 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 original state dynamics matrix A. C On exit, the leading NCONT-by-NCONT part contains the C upper block Hessenberg state dynamics matrix Acont in Ac, C given by Z' * A * Z, of a controllable realization for C the original system. The elements below the first block- C subdiagonal are set to zero. The leading N-by-N part C contains the matrix Ac. 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 matrix B. C On exit, the leading NCONT-by-M part of this array C contains the transformed input matrix Bcont in Bc, given C by Z' * B, with all elements but the first block set to C zero. The leading N-by-M part contains the matrix Bc. 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 output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed output matrix Cc, given by C * Z. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C NCONT (output) INTEGER C The order of the controllable state-space representation. C C INDCON (output) INTEGER C The controllability index of the controllable part of the C system representation. C C NBLK (output) INTEGER array, dimension (N) C The leading INDCON elements of this array contain the C the orders of the diagonal blocks of Acont. C C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) C If JOBZ = 'I', then the leading N-by-N part of this C array contains the matrix of accumulated orthogonal C similarity transformations which reduces the given system C to orthogonal canonical form. C If JOBZ = 'F', the elements below the diagonal, with the C array TAU, represent the orthogonal transformation matrix C as a product of elementary reflectors. The transformation C matrix can then be obtained by calling the LAPACK Library C routine DORGQR. C If JOBZ = 'N', the array Z is not referenced and can be C supplied as a dummy array (i.e. set parameter LDZ = 1 and C declare this array to be Z(1,1) in the calling program). C C LDZ INTEGER C The leading dimension of array Z. If JOBZ = 'I' or C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. C C TAU (output) DOUBLE PRECISION array, dimension (N) C The elements of TAU contain the scalar factors of the C elementary reflectors used in the reduction of B and A. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determination when C transforming (A, B). If the user sets TOL > 0, then C the given value of TOL is used as a lower bound for the C reciprocal condition number (see the description of the C argument RCOND in the SLICOT routine MB03OD); a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*N*EPS, is used instead, where EPS C is the machine precision (see LAPACK Library routine C DLAMCH). C C Workspace C C IWORK INTEGER array, dimension (M) 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, N, 3*M, P). 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 C METHOD C C Matrix B is first QR-decomposed and the appropriate orthogonal C similarity transformation applied to the matrix A. Leaving the C first rank(B) states unchanged, the remaining lower left block C of A is then QR-decomposed and the new orthogonal matrix, Q1, C is also applied to the right of A to complete the similarity C transformation. By continuing in this manner, a completely C controllable state-space pair (Acont, Bcont) is found for the C given (A, B), where Acont is upper block Hessenberg with each C subdiagonal block of full row rank, and Bcont is zero apart from C its (independent) first rank(B) rows. C All orthogonal transformations determined in this process are also C applied to the matrix C, from the right. C NOTE that the system controllability indices are easily C calculated from the dimensions of the blocks of Acont. C C REFERENCES C C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. C Orthogonal Invariants and Canonical Forms for Linear C Controllable Systems. C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. C C [2] Paige, C.C. C Properties of numerical algorithms related to computing C controllablity. C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. C C [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and C Postlethwaite, I. C Optimal Pole Assignment Design of Linear Multi-Input Systems. C Leicester University, Report 99-11, May 1996. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations and is backward stable. C C FURTHER COMMENTS C C If the system matrices A and B are badly scaled, it would be C useful to scale them with SLICOT routine TB01ID, before calling C the routine. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Nov. 2003, C Mar. 2017. C A. Varga, DLR Oberpfaffenhofen, March 2002, Nov. 2003. C C KEYWORDS C C Controllability, minimal realization, orthogonal canonical form, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBZ INTEGER INDCON, INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N, $ NCONT, P DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), TAU(*), $ Z(LDZ,*) INTEGER IWORK(*), NBLK(*) C .. Local Scalars .. LOGICAL LJOBF, LJOBI, LJOBZ INTEGER IQR, ITAU, J, MCRT, NBL, NCRT, NI, NJ, RANK, $ WRKOPT DOUBLE PRECISION ANORM, BNORM, FNRM, TOLDEF C .. Local Arrays .. DOUBLE PRECISION SVAL(3) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR, $ MB01PD, MB03OY, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C INFO = 0 LJOBF = LSAME( JOBZ, 'F' ) LJOBI = LSAME( JOBZ, 'I' ) LJOBZ = LJOBF.OR.LJOBI C C Test the input scalar arguments. C IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, '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( .NOT.LJOBZ .AND. LDZ.LT.1 .OR. $ LJOBZ .AND. LDZ.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDWORK.LT.MAX( 1, N, 3*M, P ) ) THEN INFO = -20 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01UD', -INFO ) RETURN END IF C NCONT = 0 INDCON = 0 C C Calculate the absolute norms of A and B (used for scaling). C ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) BNORM = DLANGE( 'M', N, M, B, LDB, DWORK ) C C Quick return if possible. C IF ( MIN( N, M ).EQ.0 .OR. BNORM.EQ.ZERO ) THEN IF( N.GT.0 ) THEN IF ( LJOBI ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) ELSE IF ( LJOBF ) THEN CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) END IF END IF DWORK(1) = ONE RETURN END IF C C Scale (if needed) the matrices A and B. C CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) CALL MB01PD( 'S', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, INFO ) C C Compute the Frobenius norm of [ B A ] (used for rank estimation). C FNRM = DLANGE( 'F', N, M, B, LDB, DWORK ) C TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance in controllability determination. C TOLDEF = DBLE( N*N )*DLAMCH( 'Precision' ) END IF C IF ( FNRM.LT.TOLDEF ) $ FNRM = ONE C WRKOPT = 1 NI = 0 ITAU = 1 NCRT = N MCRT = M IQR = 1 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 10 CONTINUE C C Rank-revealing QR decomposition with column pivoting. C The calculation is performed in NCRT rows of B starting from C the row IQR (initialized to 1 and then set to rank(B)+1). C Workspace: 3*MCRT. C CALL MB03OY( NCRT, MCRT, B(IQR,1), LDB, TOLDEF, FNRM, RANK, $ SVAL, IWORK, TAU(ITAU), DWORK, INFO ) C IF ( RANK.NE.0 ) THEN NJ = NI NI = NCONT NCONT = NCONT + RANK INDCON = INDCON + 1 NBLK(INDCON) = RANK C C Premultiply and postmultiply the appropriate block row C and block column of A by Q' and Q, respectively. C Workspace: need NCRT; C prefer NCRT*NB. C CALL DORMQR( 'Left', 'Transpose', NCRT, NCRT, RANK, $ B(IQR,1), LDB, TAU(ITAU), A(NI+1,NI+1), LDA, $ DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Workspace: need N; C prefer N*NB. C CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK, $ B(IQR,1), LDB, TAU(ITAU), A(1,NI+1), LDA, $ DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Postmultiply the appropriate block column of C by Q. C Workspace: need P; C prefer P*NB. C CALL DORMQR( 'Right', 'No transpose', P, NCRT, RANK, $ B(IQR,1), LDB, TAU(ITAU), C(1,NI+1), LDC, $ DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C If required, save transformations. C IF ( LJOBZ.AND.NCRT.GT.1 ) THEN CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ), $ B(IQR+1,1), LDB, Z(NI+2,ITAU), LDZ ) END IF C C Zero the subdiagonal elements of the current matrix. C IF ( RANK.GT.1 ) $ CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO, B(IQR+1,1), $ LDB ) C C Backward permutation of the columns of B or A. C IF ( INDCON.EQ.1 ) THEN CALL DLAPMT( .FALSE., RANK, M, B(IQR,1), LDB, IWORK ) IQR = RANK + 1 FNRM = DLANGE( 'F', N, N, A, LDA, DWORK ) ELSE DO 20 J = 1, MCRT CALL DCOPY( RANK, B(IQR,J), 1, A(NI+1,NJ+IWORK(J)), $ 1 ) 20 CONTINUE END IF C ITAU = ITAU + RANK IF ( RANK.NE.NCRT ) THEN MCRT = RANK NCRT = NCRT - RANK CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NI+1), LDA, $ B(IQR,1), LDB ) CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, $ A(NCONT+1,NI+1), LDA ) GO TO 10 END IF END IF C C If required, accumulate transformations. C Workspace: need N; prefer N*NB. C IF ( LJOBI ) THEN CALL DORGQR( N, N, ITAU-1, Z, LDZ, TAU, DWORK, $ LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF C C Annihilate the trailing blocks of B. C IF( IQR.LE.N ) $ CALL DLASET( 'G', N-IQR+1, M, ZERO, ZERO, B(IQR,1), LDB ) C C Annihilate the trailing elements of TAU, if JOBZ = 'F'. C IF ( LJOBF ) THEN DO 30 J = ITAU, N TAU(J) = ZERO 30 CONTINUE END IF C C Undo scaling of A and B. C IF ( INDCON.LT.N ) THEN NBL = INDCON + 1 NBLK(NBL) = N - NCONT ELSE NBL = 0 END IF CALL MB01PD( 'U', 'H', N, N, 0, 0, ANORM, NBL, NBLK, A, LDA, $ INFO ) CALL MB01PD( 'U', 'G', NBLK(1), M, 0, 0, BNORM, 0, NBLK, B, LDB, $ INFO ) C C Set optimal workspace dimension. C DWORK(1) = WRKOPT RETURN C *** Last line of TB01UD *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03AX.f0000644000000000000000000000013215012430707016202 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SG03AX.f0000644000175000017500000005133215012430707017402 0ustar00lilgelilge00000000000000 SUBROUTINE SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) 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) AL22 = A(LH,LH) C EK11 = E(KL,KL) C EL11 = E(LL,LL) EL12 = E(LL,LH) EL22 = E(LH,LH) C MAT(1,1) = AL11*AK11 - EL11*EK11 MAT(1,2) = AL21*AK11 MAT(2,1) = AL12*AK11 - EL12*EK11 MAT(2,2) = AL22*AK11 - EL22*EK11 C RHS(1) = X(KL,LL) RHS(2) = X(KL,LH) C ELSE C DIMMAT = 4 C AK11 = A(KL,KL) AK12 = A(KL,KH) AK21 = A(KH,KL) AK22 = A(KH,KH) C AL11 = A(LL,LL) AL12 = A(LL,LH) AL21 = A(LH,LL) AL22 = A(LH,LH) C EK11 = E(KL,KL) EK12 = E(KL,KH) EK22 = E(KH,KH) C EL11 = E(LL,LL) EL12 = E(LL,LH) EL22 = E(LH,LH) C MAT(1,1) = AL11*AK11 - EL11*EK11 MAT(1,2) = AL11*AK21 MAT(1,3) = AL21*AK11 MAT(1,4) = AL21*AK21 C MAT(2,1) = AL11*AK12 - EL11*EK12 MAT(2,2) = AL11*AK22 - EL11*EK22 MAT(2,3) = AL21*AK12 MAT(2,4) = AL21*AK22 C MAT(3,1) = AL12*AK11 - EL12*EK11 MAT(3,2) = AL12*AK21 MAT(3,3) = AL22*AK11 - EL22*EK11 MAT(3,4) = AL22*AK21 C MAT(4,1) = AL12*AK12 - EL12*EK12 MAT(4,2) = AL12*AK22 - EL12*EK22 MAT(4,3) = AL22*AK12 - EL22*EK12 MAT(4,4) = AL22*AK22 - EL22*EK22 C RHS(1) = X(KL,LL) IF ( KL .EQ. LL ) THEN RHS(2) = X(KL,KH) ELSE RHS(2) = X(KH,LL) END IF RHS(3) = X(KL,LH) RHS(4) = X(KH,LH) C END IF C CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) IF ( INFO1 .NE. 0 ) $ INFO = 1 CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) C C Scaling. C IF ( SCALE1 .NE. ONE ) THEN DO 80 I = 1, N CALL DSCAL( N, SCALE1, X(1,I), 1 ) 80 CONTINUE SCALE = SCALE*SCALE1 END IF C IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN X(KL,LL) = RHS(1) ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN X(KL,LL) = RHS(1) X(KH,LL) = RHS(2) ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN X(KL,LL) = RHS(1) X(KL,LH) = RHS(2) ELSE X(KL,LL) = RHS(1) X(KH,LL) = RHS(2) X(KL,LH) = RHS(3) X(KH,LH) = RHS(4) END IF C C Update right hand sides (II). C C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - C A(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*A(LL:LH,LL:LH)) C C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) + C E(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*E(LL:LH,LL:LH)) C IF ( KL .LT. LL ) THEN CALL DGEMM( 'N', 'N', KB, LB, LB, ONE, X(KL,LL), LDX, $ A(LL,LL), LDA, ZERO, TM, 2 ) CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, A(KL,KH+1), $ LDA, TM, 2, ONE, X(KH+1,LL), LDX ) IF ( LB .EQ. 2 ) THEN CALL DCOPY( KB, X(KL,LL), 1, TM, 1 ) CALL DSCAL( KB, E(LL,LL), TM, 1 ) END IF CALL DGEMV( 'N', KB, LB, ONE, X(KL,LL), LDX, E(LL,LH), $ 1, ZERO, TM(1,LB), 1 ) CALL DGEMM( 'T', 'N', LH-KH, LB, KB, ONE, E(KL,KH+1), $ LDE, TM, 2, ONE, X(KH+1,LL), LDX ) END IF C GOTO 60 END IF C END WHILE 60 C GOTO 20 END IF C END WHILE 20 C ELSE C C Solve equation (2). C C Outer Loop. Compute block column X(:,LL:LH). LB denotes the C number of columns in this block column. C LL = N + 1 C WHILE ( LL .GT. 1 ) DO 100 IF ( LL .GT. 1 ) THEN LH = LL - 1 IF ( LH .EQ. 1 ) THEN LB = 1 ELSE IF ( A(LL-1,LL-2) .NE. ZERO ) THEN LB = 2 ELSE LB = 1 END IF END IF LL = LL - LB C C Copy elements of solution already known by symmetry. C C X(LH+1:N,LL:LH) = X(LL:LH,LH+1:N)' C IF ( LH .LT. N ) THEN DO 120 I = LL, LH CALL DCOPY( N-LH, X(I,LH+1), LDX, X(LH+1,I), 1 ) 120 CONTINUE END IF C C Inner Loop. Compute block X(KL:KH,LL:LH). KB denotes the C number of rows in this block. C KL = LH + 1 C WHILE ( KL .GT. 1 ) DO 140 IF ( KL .GT. 1 ) THEN KH = KL - 1 IF ( KH .EQ. 1 ) THEN KB = 1 ELSE IF ( A(KL-1,KL-2) .NE. ZERO ) THEN KB =2 ELSE KB = 1 END IF END IF KL = KL - KB C C Update right hand sides (I). C C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - C (A(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*A(KL:LH,LL:LH)' C C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) + C (E(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*E(KL:LH,LL:LH)' C IF ( KH .LT. N ) THEN CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, A(KL,KH+1), $ LDA, X(KH+1,LL), LDX, ZERO, TM, 2 ) CALL DGEMM( 'N', 'T', KB, LH-KL+1, LB, MONE, TM, 2, $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, E(KL,KH+1), $ LDE, X(KH+1,LL), LDX, ZERO, TM, 2 ) CALL DGEMM( 'N', 'T', KB, LL-KL+1, LB, ONE, TM, 2, $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) IF ( LB .EQ. 2 ) CALL DAXPY( KB, E(LH,LH), TM(1,2), 1, $ X(KL,LH), 1 ) 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*AK12 - EL11*EK12 MAT(2,1) = AL11*AK21 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) AL22 = A(LH,LH) C EK11 = E(KL,KL) C EL11 = E(LL,LL) EL12 = E(LL,LH) EL22 = E(LH,LH) C MAT(1,1) = AL11*AK11 - EL11*EK11 MAT(1,2) = AL12*AK11 - EL12*EK11 MAT(2,1) = AL21*AK11 MAT(2,2) = AL22*AK11 - EL22*EK11 C RHS(1) = X(KL,LL) RHS(2) = X(KL,LH) C ELSE C DIMMAT = 4 C AK11 = A(KL,KL) AK12 = A(KL,KH) AK21 = A(KH,KL) AK22 = A(KH,KH) C AL11 = A(LL,LL) AL12 = A(LL,LH) AL21 = A(LH,LL) AL22 = A(LH,LH) C EK11 = E(KL,KL) EK12 = E(KL,KH) EK22 = E(KH,KH) C EL11 = E(LL,LL) EL12 = E(LL,LH) EL22 = E(LH,LH) C MAT(1,1) = AL11*AK11 - EL11*EK11 MAT(1,2) = AL11*AK12 - EL11*EK12 MAT(1,3) = AL12*AK11 - EL12*EK11 MAT(1,4) = AL12*AK12 - EL12*EK12 C MAT(2,1) = AL11*AK21 MAT(2,2) = AL11*AK22 - EL11*EK22 MAT(2,3) = AL12*AK21 MAT(2,4) = AL12*AK22 - EL12*EK22 C MAT(3,1) = AL21*AK11 MAT(3,2) = AL21*AK12 MAT(3,3) = AL22*AK11 - EL22*EK11 MAT(3,4) = AL22*AK12 - EL22*EK12 C MAT(4,1) = AL21*AK21 MAT(4,2) = AL21*AK22 MAT(4,3) = AL22*AK21 MAT(4,4) = AL22*AK22 - EL22*EK22 C RHS(1) = X(KL,LL) IF ( KL .EQ. LL ) THEN RHS(2) = X(KL,KH) ELSE RHS(2) = X(KH,LL) END IF RHS(3) = X(KL,LH) RHS(4) = X(KH,LH) C END IF C CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) IF ( INFO1 .NE. 0 ) $ INFO = 1 CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) C C Scaling. C IF ( SCALE1 .NE. ONE ) THEN DO 160 I = 1, N CALL DSCAL( N, SCALE1, X(1,I), 1 ) 160 CONTINUE SCALE = SCALE*SCALE1 END IF C IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN X(KL,LL) = RHS(1) ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN X(KL,LL) = RHS(1) X(KH,LL) = RHS(2) ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN X(KL,LL) = RHS(1) X(KL,LH) = RHS(2) ELSE X(KL,LL) = RHS(1) X(KH,LL) = RHS(2) X(KL,LH) = RHS(3) X(KH,LH) = RHS(4) END IF C C Update right hand sides (II). C C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - C (A(KL:KH,KL:KH)*X(KL:KH,LL:LH))*A(KL:LL-1,LL:LH)' C C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) + C (E(KL:KH,KL:KH)*X(KL:KH,LL:LH))*E(KL:LL-1,LL:LH)' C IF ( KL .LT. LL ) THEN CALL DGEMM( 'N', 'N', KB, LB, KB, ONE, A(KL,KL), LDA, $ X(KL,LL), LDX, ZERO, TM, 2 ) CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) CALL DGEMV( 'T', KB, LB, ONE, X(KL,LL), LDX, E(KL,KL), $ LDE, ZERO, TM, 2 ) IF ( KB .EQ. 2 ) THEN CALL DCOPY( LB, X(KH,LL), LDX, TM(2,1), 2 ) CALL DSCAL( LB, E(KH,KH), TM(2,1), 2 ) END IF CALL DGEMM( 'N', 'T', KB, LL-KL, LB, ONE, TM, 2, $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) END IF C GOTO 140 END IF C END WHILE 140 C GOTO 100 END IF C END WHILE 100 C END IF C RETURN C *** Last line of SG03AX *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01VD.f0000644000000000000000000000013015012430707016165 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MC01VD.f0000644000175000017500000002004415012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO ) C C PURPOSE C C To compute the roots of a quadratic equation with real C coefficients. C C ARGUMENTS C C Input/Output Parameters C C A (input) DOUBLE PRECISION C The value of the coefficient of the quadratic term. C C B (input) DOUBLE PRECISION C The value of the coefficient of the linear term. C C C (input) DOUBLE PRECISION C The value of the coefficient of the constant term. C C Z1RE (output) DOUBLE PRECISION C Z1IM (output) DOUBLE PRECISION C The real and imaginary parts, respectively, of the largest C root in magnitude. C C Z2RE (output) DOUBLE PRECISION C Z2IM (output) DOUBLE PRECISION C The real and imaginary parts, respectively, of the C smallest root in magnitude. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if on entry, either A = B = 0.0 or A = 0.0 and the C root -C/B overflows; in this case Z1RE, Z1IM, Z2RE C and Z2IM are unassigned; C = 2: if on entry, A = 0.0; in this case Z1RE contains C BIG and Z1IM contains zero, where BIG is a C representable number near the overflow threshold C of the machine (see LAPACK Library Routine DLAMCH); C = 3: if on entry, either C = 0.0 and the root -B/A C overflows or A, B and C are non-zero and the largest C real root in magnitude cannot be computed without C overflow; in this case Z1RE contains BIG and Z1IM C contains zero; C = 4: if the roots cannot be computed without overflow; in C this case Z1RE, Z1IM, Z2RE and Z2IM are unassigned. C C METHOD C C The routine computes the roots (r1 and r2) of the real quadratic C equation C 2 C a * x + b * x + c = 0 C C as C - b - SIGN(b) * SQRT(b * b - 4 * a * c) c C r1 = --------------------------------------- and r2 = ------ C 2 * a a * r1 C C unless a = 0, in which case C C -c C r1 = --. C b C C Precautions are taken to avoid overflow and underflow wherever C possible. C C NUMERICAL ASPECTS C C The algorithm is numerically stable. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01JD by A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Quadratic equation, zeros. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, FOUR PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR=4.0D0 ) C .. Scalar Arguments .. INTEGER INFO DOUBLE PRECISION A, B, C, Z1IM, Z1RE, Z2IM, Z2RE C .. Local Scalars .. LOGICAL OVFLOW INTEGER BETA, EA, EAPLEC, EB, EB2, EC, ED DOUBLE PRECISION ABSA, ABSB, ABSC, BIG, M1, M2, MA, MB, MC, MD, $ SFMIN, W C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. External Subroutines .. EXTERNAL MC01SW, MC01SY C .. Intrinsic Functions .. INTRINSIC ABS, MOD, SIGN, SQRT C .. Executable Statements .. C C Detect special cases. C INFO = 0 BETA = DLAMCH( 'Base' ) SFMIN = DLAMCH( 'Safe minimum' ) BIG = ONE/SFMIN IF ( A.EQ.ZERO ) THEN IF ( B.EQ.ZERO ) THEN INFO = 1 ELSE OVFLOW = .FALSE. Z2RE = ZERO IF ( C.NE.ZERO ) THEN ABSB = ABS( B ) IF ( ABSB.GE.ONE ) THEN IF ( ABS( C ).GE.ABSB*SFMIN ) Z2RE = -C/B ELSE IF ( ABS( C ).LE.ABSB*BIG ) THEN Z2RE = -C/B ELSE OVFLOW = .TRUE. Z2RE = BIG IF ( SIGN( ONE, B )*SIGN( ONE, C ).GT.ZERO ) $ Z2RE = -BIG END IF END IF END IF IF ( OVFLOW ) THEN INFO = 1 ELSE Z1RE = BIG Z1IM = ZERO Z2IM = ZERO INFO = 2 END IF END IF RETURN END IF C IF ( C.EQ.ZERO ) THEN OVFLOW = .FALSE. Z1RE = ZERO IF ( B.NE.ZERO ) THEN ABSA = ABS( A ) IF ( ABSA.GE.ONE ) THEN IF ( ABS( B ).GE.ABSA*SFMIN ) Z1RE = -B/A ELSE IF ( ABS( B ).LE.ABSA*BIG ) THEN Z1RE = -B/A ELSE OVFLOW = .TRUE. Z1RE = BIG END IF END IF END IF IF ( OVFLOW ) INFO = 3 Z1IM = ZERO Z2RE = ZERO Z2IM = ZERO RETURN END IF C C A and C are non-zero. C IF ( B.EQ.ZERO ) THEN OVFLOW = .FALSE. ABSC = SQRT( ABS( C ) ) ABSA = SQRT( ABS( A ) ) W = ZERO IF ( ABSA.GE.ONE ) THEN IF ( ABSC.GE.ABSA*SFMIN ) W = ABSC/ABSA ELSE IF ( ABSC.LE.ABSA*BIG ) THEN W = ABSC/ABSA ELSE OVFLOW = .TRUE. W = BIG END IF END IF IF ( OVFLOW ) THEN INFO = 4 ELSE IF ( SIGN( ONE, A )*SIGN( ONE, C ).GT.ZERO ) THEN Z1RE = ZERO Z2RE = ZERO Z1IM = W Z2IM = -W ELSE Z1RE = W Z2RE = -W Z1IM = ZERO Z2IM = ZERO END IF END IF RETURN END IF C C A, B and C are non-zero. C CALL MC01SW( A, BETA, MA, EA ) CALL MC01SW( B, BETA, MB, EB ) CALL MC01SW( C, BETA, MC, EC ) C C Compute a 'near' floating-point representation of the discriminant C D = MD * BETA**ED. C EAPLEC = EA + EC EB2 = 2*EB IF ( EAPLEC.GT.EB2 ) THEN CALL MC01SY( MB*MB, EB2-EAPLEC, BETA, W, OVFLOW ) W = W - FOUR*MA*MC CALL MC01SW( W, BETA, MD, ED ) ED = ED + EAPLEC ELSE CALL MC01SY( FOUR*MA*MC, EAPLEC-EB2, BETA, W, OVFLOW ) W = MB*MB - W CALL MC01SW( W, BETA, MD, ED ) ED = ED + EB2 END IF C IF ( MOD( ED, 2 ).NE.0 ) THEN ED = ED + 1 MD = MD/BETA END IF C C Complex roots. C IF ( MD.LT.ZERO ) THEN CALL MC01SY( -MB/( 2*MA ), EB-EA, BETA, Z1RE, OVFLOW ) IF ( OVFLOW ) THEN INFO = 4 ELSE CALL MC01SY( SQRT( -MD )/( 2*MA ), ED/2-EA, BETA, Z1IM, $ OVFLOW ) IF ( OVFLOW ) THEN INFO = 4 ELSE Z2RE = Z1RE Z2IM = -Z1IM END IF END IF RETURN END IF C C Real roots. C MD = SQRT( MD ) ED = ED/2 IF ( ED.GT.EB ) THEN CALL MC01SY( ABS( MB ), EB-ED, BETA, W, OVFLOW ) W = W + MD M1 = -SIGN( ONE, MB )*W/( 2*MA ) CALL MC01SY( M1, ED-EA, BETA, Z1RE, OVFLOW ) IF ( OVFLOW ) THEN Z1RE = BIG INFO = 3 END IF M2 = -SIGN( ONE, MB )*2*MC/W CALL MC01SY( M2, EC-ED, BETA, Z2RE, OVFLOW ) ELSE CALL MC01SY( MD, ED-EB, BETA, W, OVFLOW ) W = W + ABS( MB ) M1 = -SIGN( ONE, MB )*W/( 2*MA ) CALL MC01SY( M1, EB-EA, BETA, Z1RE, OVFLOW ) IF ( OVFLOW ) THEN Z1RE = BIG INFO = 3 END IF M2 = -SIGN( ONE, MB )*2*MC/W CALL MC01SY( M2, EC-EB, BETA, Z2RE, OVFLOW ) END IF Z1IM = ZERO Z2IM = ZERO C RETURN C *** Last line of MC01VD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03TD.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03TD.f0000644000175000017500000005441615012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To reorder a matrix X in skew-Hamiltonian Schur form: C C [ A G ] T C X = [ T ], G = -G, C [ 0 A ] C C or in Hamiltonian Schur form: C C [ A G ] T C X = [ T ], G = G, C [ 0 -A ] C C where A is in upper quasi-triangular form, so that a selected C cluster of eigenvalues appears in the leading diagonal blocks C of the matrix A (in X) and the leading columns of [ U1; -U2 ] form C an orthonormal basis for the corresponding right invariant C subspace. C C If X is skew-Hamiltonian, then each eigenvalue appears twice; one C copy corresponds to the j-th diagonal element and the other to the C (n+j)-th diagonal element of X. The logical array LOWER controls C which copy is to be reordered to the leading part of A. C C If X is Hamiltonian then the eigenvalues appear in pairs C (lambda,-lambda); lambda corresponds to the j-th diagonal C element and -lambda to the (n+j)-th diagonal element of X. C The logical array LOWER controls whether lambda or -lambda is to C be reordered to the leading part of A. C C The matrix A must be in Schur canonical form (as returned by the C LAPACK routine DHSEQR), that is, block upper triangular with C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has C its diagonal elements equal and its off-diagonal elements of C opposite sign. C C ARGUMENTS C C Mode Parameters C C TYP CHARACTER*1 C Specifies the type of the input matrix X: C = 'S': X is skew-Hamiltonian; C = 'H': X is Hamiltonian. C C COMPU CHARACTER*1 C = 'U': update the matrices U1 and U2 containing the C Schur vectors; C = 'N': do not update U1 and U2. C C SELECT (input/output) LOGICAL array, dimension (N) C SELECT specifies the eigenvalues in the selected cluster. C To select a real eigenvalue w(j), SELECT(j) must be set C to .TRUE.. To select a complex conjugate pair of C eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 C diagonal block, both SELECT(j) and SELECT(j+1) must be set C to .TRUE.; a complex conjugate pair of eigenvalues must be C either both included in the cluster or both excluded. C C LOWER (input/output) LOGICAL array, dimension (N) C LOWER controls which copy of a selected eigenvalue is C included in the cluster. If SELECT(j) is set to .TRUE. C for a real eigenvalue w(j); then LOWER(j) must be set to C .TRUE. if the eigenvalue corresponding to the (n+j)-th C diagonal element of X is to be reordered to the leading C part; and LOWER(j) must be set to .FALSE. if the C eigenvalue corresponding to the j-th diagonal element of C X is to be reordered to the leading part. Similarly, for C a complex conjugate pair of eigenvalues w(j) and w(j+1), C both LOWER(j) and LOWER(j+1) must be set to .TRUE. if the C eigenvalues corresponding to the (n+j:n+j+1,n+j:n+j+1) C diagonal block of X are to be reordered to the leading C part. 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 part of this array must C contain the upper quasi-triangular matrix A in Schur C canonical form. C On exit, the leading N-by-N part of this array contains C the reordered matrix A, again in Schur canonical form, C with the selected eigenvalues in the diagonal blocks. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) C On entry, if TYP = 'S', the leading N-by-N part of this C array must contain the strictly upper triangular part of C the skew-symmetric matrix G. The rest of this array is not C referenced. C On entry, if TYP = 'H', the leading N-by-N part of this C array must contain the upper triangular part of the C symmetric matrix G. The rest of this array is not C referenced. C On exit, if TYP = 'S', the leading N-by-N part of this C array contains the strictly upper triangular part of the C skew-symmetric matrix G, updated by the orthogonal C symplectic transformation which reorders X. C On exit, if TYP = 'H', the leading N-by-N part of this C array contains the upper triangular part of the symmetric C matrix G, updated by the orthogonal symplectic C transformation which reorders X. C C LDG INTEGER C The leading dimension of the array G. LDG >= MAX(1,N). C C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) C On entry, if COMPU = 'U', the leading N-by-N part of this C array must contain U1, the (1,1) block of an orthogonal C symplectic matrix U = [ U1, U2; -U2, U1 ]. C On exit, if COMPU = 'U', the leading N-by-N part of this C array contains the (1,1) block of the matrix U, C postmultiplied by the orthogonal symplectic transformation C which reorders X. The leading M columns of U form an C orthonormal basis for the specified invariant subspace. C If COMPU = 'N', this array is not referenced. C C LDU1 INTEGER C The leading dimension of the array U1. C LDU1 >= MAX(1,N), if COMPU = 'U'; C LDU1 >= 1, otherwise. C C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) C On entry, if COMPU = 'U', the leading N-by-N part of this C array must contain U2, the (1,2) block of an orthogonal C symplectic matrix U = [ U1, U2; -U2, U1 ]. C On exit, if COMPU = 'U', the leading N-by-N part of this C array contains the (1,2) block of the matrix U, C postmultiplied by the orthogonal symplectic transformation C which reorders X. C If COMPU = 'N', this array is not referenced. C C LDU2 INTEGER C The leading dimension of the array U2. C LDU2 >= MAX(1,N), if COMPU = 'U'; C LDU2 >= 1, otherwise. C C WR (output) DOUBLE PRECISION array, dimension (N) C WI (output) DOUBLE PRECISION array, dimension (N) C The real and imaginary parts, respectively, of the C reordered eigenvalues of A. The eigenvalues are stored C in the same order as on the diagonal of A, with C WR(i) = A(i,i) and, if A(i:i+1,i:i+1) is a 2-by-2 diagonal C block, WI(i) > 0 and WI(i+1) = -WI(i). Note that if an C eigenvalue is sufficiently ill-conditioned, then its value C may differ significantly from its value before reordering. C C M (output) INTEGER C The dimension of the specified invariant subspace. C 0 <= M <= N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -18, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,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: reordering of X failed because some eigenvalue pairs C are too close to separate (the problem is very C ill-conditioned); X may have been partially C reordered, and WR and WI contain the eigenvalues in C the same order as in X. C C REFERENCES C C [1] Bai, Z. and Demmel, J.W. C On Swapping Diagonal Blocks in Real Schur Form. C Linear Algebra Appl., 186, pp. 73-95, 1993. C C [2] Benner, P., Kressner, D., and Mehrmann, V. C Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory, C Algorithms and Applications. Techn. Report, TU Berlin, 2003. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAORD). C C KEYWORDS C C Hamiltonian matrix, skew-Hamiltonian matrix, invariant subspace. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER COMPU, TYP INTEGER INFO, LDA, LDG, LDU1, LDU2, LDWORK, M, N C .. Array Arguments .. LOGICAL LOWER(*), SELECT(*) DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*), $ U2(LDU2,*), WI(*), WR(*) C .. Local Scalars .. LOGICAL FLOW, ISHAM, PAIR, SWAP, WANTU INTEGER HERE, IERR, IFST, ILST, K, KS, NBF, NBL, NBNEXT, $ WRKMIN C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL MB03TS, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C C .. Executable Statements .. C C Decode and check input parameters. C ISHAM = LSAME( TYP, 'H' ) WANTU = LSAME( COMPU, 'U' ) WRKMIN = MAX( 1, N ) INFO = 0 IF ( .NOT.ISHAM .AND. .NOT.LSAME( TYP, 'S' ) ) THEN INFO = -1 ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN INFO = -2 ELSE IF ( N.LT.0 ) THEN INFO = -5 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN INFO = -11 ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN INFO = -13 ELSE IF ( LDWORK.LT.WRKMIN ) THEN INFO = -18 DWORK(1) = DBLE( WRKMIN ) END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03TD', -INFO ) RETURN END IF C C Set M to the dimension of the specified invariant subspace. C M = 0 PAIR = .FALSE. DO 10 K = 1, N IF ( PAIR ) THEN PAIR = .FALSE. ELSE IF ( K.LT.N ) THEN IF ( A(K+1,K).EQ.ZERO ) THEN IF ( SELECT(K) ) $ M = M + 1 ELSE PAIR = .TRUE. IF ( SELECT(K) .OR. SELECT(K+1) ) $ M = M + 2 END IF ELSE IF ( SELECT(N) ) $ M = M + 1 END IF END IF 10 CONTINUE C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Collect the selected blocks at the top-left corner of X. C KS = 0 PAIR = .FALSE. DO 60 K = 1, N IF ( PAIR ) THEN PAIR = .FALSE. ELSE SWAP = SELECT(K) FLOW = LOWER(K) IF ( K.LT.N ) THEN IF ( A(K+1,K).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP.OR.SELECT(K+1) FLOW = FLOW.OR.LOWER(K+1) END IF END IF C IF ( PAIR ) THEN NBF = 2 ELSE NBF = 1 END IF C IF ( SWAP ) THEN KS = KS + 1 IF ( FLOW ) THEN C C Step 1: Swap the K-th block to position N. C IFST = K ILST = N NBL = 1 IF ( ILST.GT.1 ) THEN IF ( A(ILST,ILST-1).NE.ZERO ) THEN ILST = ILST - 1 NBL = 2 END IF END IF C C Update ILST. C IF ( NBF.EQ.2 .AND. NBL.EQ.1 ) $ ILST = ILST - 1 IF ( NBF.EQ.1 .AND. NBL.EQ.2 ) $ ILST = ILST + 1 C IF ( ILST.EQ.IFST ) $ GO TO 30 C HERE = IFST C 20 CONTINUE C C Swap block with next one below. C IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN C C Current block is either 1-by-1 or 2-by-2. C NBNEXT = 1 IF ( HERE+NBF+1.LE.N ) THEN IF ( A(HERE+NBF+1,HERE+NBF).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, HERE, NBF, NBNEXT, $ DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF HERE = HERE + NBNEXT C C Test if 2-by-2 block breaks into two 1-by-1 blocks. C IF ( NBF.EQ.2 ) THEN IF ( A(HERE+1,HERE).EQ.ZERO ) $ NBF = 3 END IF C ELSE C C Current block consists of two 1-by-1 blocks each of C which must be swapped individually. C NBNEXT = 1 IF ( HERE+3.LE.N ) THEN IF ( A(HERE+3,HERE+2).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, HERE+1, 1, NBNEXT, $ DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF IF ( NBNEXT.EQ.1 ) THEN C C Swap two 1-by-1 blocks, no problems possible. C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE, 1, $ NBNEXT, DWORK, IERR ) HERE = HERE + 1 ELSE C C Recompute NBNEXT in case 2 by 2 split. C IF ( A(HERE+2,HERE+1).EQ.ZERO ) $ NBNEXT = 1 IF ( NBNEXT.EQ.2 ) THEN C C 2-by-2 block did not split C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE, 1, $ NBNEXT, DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF HERE = HERE + 2 ELSE C C 2-by-2 block did split C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE, 1, 1, $ DWORK, IERR ) CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE+1, 1, $ 1, DWORK, IERR ) HERE = HERE + 2 END IF END IF END IF IF ( HERE.LT.ILST ) $ GO TO 20 C 30 CONTINUE C C Step 2: Apply an orthogonal symplectic transformation C to swap the last blocks in A and -A' (or A'). C IF ( NBF.EQ.1 ) THEN C C Exchange columns/rows N <-> 2*N. No problems C possible. C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, N, 1, 1, $ DWORK, IERR ) C ELSE IF ( NBF.EQ.2 ) THEN C C Swap last block with its equivalent by an C orthogonal symplectic transformation. C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, N-1, 2, 2, $ DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF C C Test if 2-by-2 block breaks into two 1-by-1 blocks. C IF ( A(N-1,N).EQ.ZERO ) $ NBF = 3 ELSE C C Block did split. Swap (N-1)-th and N-th elements C consecutively by symplectic generalized C permutations and one rotation. C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, N-1, 1, 1, DWORK, $ IERR ) CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) END IF IFST = N IF ( PAIR ) $ IFST = N-1 ELSE IFST = K END IF C C Step 3: Swap the K-th / N-th block to position KS. C ILST = KS NBL = 1 IF ( ILST.GT.1 ) THEN IF ( A(ILST,ILST-1).NE.ZERO ) THEN ILST = ILST - 1 NBL = 2 END IF END IF C IF ( ILST.EQ.IFST ) $ GO TO 50 C HERE = IFST 40 CONTINUE C C Swap block with next one above. C IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN C C Current block either 1 by 1 or 2 by 2. C NBNEXT = 1 IF ( HERE.GE.3 ) THEN IF ( A(HERE-1,HERE-2).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, $ NBF, DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF HERE = HERE - NBNEXT C C Test if 2-by-2 block breaks into two 1-by-1 blocks. C IF ( NBF.EQ.2 ) THEN IF ( A(HERE+1,HERE).EQ.ZERO ) $ NBF = 3 END IF C ELSE C C Current block consists of two 1 by 1 blocks each of C which must be swapped individually. C NBNEXT = 1 IF ( HERE.GE.3 ) THEN IF ( A(HERE-1,HERE-2).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, $ 1, DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF IF ( NBNEXT.EQ.1 ) THEN C C Swap two 1-by-1 blocks, no problems possible. C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, HERE, NBNEXT, 1, $ DWORK, IERR ) HERE = HERE - 1 ELSE C C Recompute NBNEXT in case 2-by-2 split. C IF ( A(HERE,HERE-1).EQ.ZERO ) $ NBNEXT = 1 IF ( NBNEXT.EQ.2 ) THEN C C 2-by-2 block did not split C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE-1, 2, 1, $ DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF HERE = HERE - 2 ELSE C C 2-by-2 block did split C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE, 1, 1, $ DWORK, IERR ) CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE-1, 1, 1, $ DWORK, IERR ) HERE = HERE - 2 END IF END IF END IF C IF ( HERE.GT.ILST ) $ GO TO 40 C 50 CONTINUE IF ( PAIR ) $ KS = KS + 1 END IF END IF 60 CONTINUE C 70 CONTINUE C C Store eigenvalues. C DO 80 K = 1, N WR(K) = A(K,K) WI(K) = ZERO 80 CONTINUE DO 90 K = 1, N - 1 IF ( A(K+1,K).NE.ZERO ) THEN WI(K) = SQRT( ABS( A(K,K+1) ) )* $ SQRT( ABS( A(K+1,K) ) ) WI(K+1) = -WI(K) END IF 90 CONTINUE C DWORK(1) = DBLE( WRKMIN ) C RETURN C *** Last line of MB03TD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02CX.f0000644000000000000000000000013015012430707016174 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB02CX.f0000644000175000017500000000320515012430707017372 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION SB02CX( REIG, IEIG ) C C PURPOSE C C To select the purely imaginary eigenvalues in computing the C H-infinity norm of a system. C C ARGUMENTS C C Input/Output Parameters C C REIG (input) DOUBLE PRECISION C The real part of the current eigenvalue considered. C C IEIG (input) DOUBLE PRECISION C The imaginary part of the current eigenvalue considered. C C METHOD C C The function value SB02CX is set to .TRUE. for a purely imaginary C eigenvalue and to .FALSE., otherwise. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C P. Hr. Petkov, Technical University of Sofia, May, 1999. C C REVISIONS C C P. Hr. Petkov, Technical University of Sofia, Oct. 2000. C C KEYWORDS C C H-infinity norm, robust control. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION HUNDRD PARAMETER ( HUNDRD = 100.0D+0 ) C .. C .. Scalar Arguments .. DOUBLE PRECISION IEIG, REIG C .. C .. Local Scalars .. DOUBLE PRECISION EPS, TOL C .. C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. C .. Intrinsic Functions .. INTRINSIC ABS C .. C .. Executable Statements .. C C Get the machine precision. C EPS = DLAMCH( 'Epsilon' ) C C Set the tolerance in the determination of the purely C imaginary eigenvalues. C TOL = HUNDRD*EPS SB02CX = ABS( REIG ).LT.TOL C RETURN C *** Last line of SB02CX *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01PX.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01PX.f0000644000175000017500000004173215012430707017416 0ustar00lilgelilge00000000000000 SUBROUTINE TB01PX( JOB, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, $ NR, INFRED, TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To find a reduced (controllable, observable, or minimal) state- C space representation (Ar,Br,Cr) for any original state-space C representation (A,B,C). The matrix Ar is in an upper block C Hessenberg staircase form. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Indicates whether the user wishes to remove the C uncontrollable and/or unobservable parts as follows: C = 'M': Remove both the uncontrollable and unobservable C parts to get a minimal state-space representation; C = 'C': Remove the uncontrollable part only to get a C controllable state-space representation; C = 'O': Remove the unobservable part only to get an C observable state-space representation. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily balance C the triplet (A,B,C) 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 order of the original state-space representation, i.e. C the order of the 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/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the original state dynamics matrix A. C On exit, if INFRED(1) >= 0 and/or INFRED(2) >= 0, the C leading NR-by-NR part of this array contains the upper C block Hessenberg state dynamics matrix Ar of a minimal, C controllable, or observable realization for the original C system, depending on the value of JOB, JOB = 'M', C JOB = 'C', or JOB = 'O', respectively. C The block structure of the resulting staircase form is C contained in the leading INFRED(4) elements of IWORK. C If INFRED(1:2) < 0, then A contains the original matrix. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), C if JOB = 'C', or (LDB,MAX(M,P)), otherwise. C On entry, the leading N-by-M part of this array must C contain the original input/state matrix B; if JOB = 'M', C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) C part is used as internal workspace. C On exit, if INFRED(1) >= 0 and/or INFRED(2) >= 0, the C leading NR-by-M part of this array contains the C input/state matrix Br of a minimal, controllable, or C observable realization for the original system, depending C on the value of JOB, JOB = 'M', JOB = 'C', or JOB = 'O', C respectively. If JOB = 'C', only the first IWORK(1) rows C of B are nonzero. C If INFRED(1:2) < 0, then B contains the original matrix. C C LDB INTEGER C The leading dimension of the 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 original state/output matrix C; if JOB = 'M', C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N C part is used as internal workspace. C On exit, if INFRED(1) >= 0 and/or INFRED(2) >= 0, the C leading P-by-NR part of this array contains the C state/output matrix Cr of a minimal, controllable, or C observable realization for the original system, depending C on the value of JOB, JOB = 'M', JOB = 'C', or JOB = 'O', C respectively. If JOB = 'M', or JOB = 'O', only the last C IWORK(1) columns (in the first NR columns) of C are C nonzero. C If INFRED(1:2) < 0, then C contains the original matrix. C C LDC INTEGER C The leading dimension of the array C. C LDC >= MAX(1,M,P), if N > 0. C LDC >= 1, if N = 0. C C NR (output) INTEGER C The order of the reduced state-space representation C (Ar,Br,Cr) of a minimal, controllable, or observable C realization for the original system, depending on C JOB = 'M', JOB = 'C', or JOB = 'O'. C C INFRED (output) INTEGER array, dimension 4 C This array contains information on the performed reduction C and on structure of resulting system matrices, as follows: C INFRED(k) >= 0 (k = 1 or 2) if Phase k of the reduction C (see METHOD) has been performed. In this C case, INFRED(k) is the achieved order C reduction in Phase k. C INFRED(k) < 0 (k = 1 or 2) if Phase k was not performed. C This can also appear when Phase k was C tried, but did not reduce the order, if C enough workspace is provided for saving the C system matrices (see LDWORK description). C INFRED(3) - the number of nonzero subdiagonals of A. C INFRED(4) - the number of blocks in the resulting C staircase form at the last performed C reduction phase. The block dimensions are C contained in the first INFRED(4) elements C of IWORK. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determinations when C transforming (A, B, C). If the user sets TOL > 0, then C the given value of TOL is used as a lower bound for the C reciprocal condition number (see the description of the C argument RCOND in the SLICOT routine MB03OD); a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance C (determined by the SLICOT routine TB01UD) is used instead. C C Workspace C C IWORK INTEGER array, dimension (c*N+MAX(M,P)), where C c = 2, if JOB = 'M', and c = 1, otherwise. C On exit, if INFO = 0, the first INFRED(4) elements of C IWORK return the orders of the diagonal blocks of A. 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. LDWORK >= 1, and if N > 0, C LDWORK >= N + MAX(N, 3*M, 3*P). C For optimum performance LDWORK should be larger. C If LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P) + N*(N+M+P) ), C then more accurate results are to be expected by accepting C only those reductions phases (see METHOD), where effective C order reduction occurs. This is achieved by saving the C system matrices before each phase and restoring them if C no order reduction took place in that phase. 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 order reduction is performed in two phases: C C Phase 1: C If JOB = 'M' or 'C', the pair (A,B) is reduced by orthogonal C similarity transformations to the controllability staircase form C (see [1]) and a controllable realization (Ac,Bc,Cc) is extracted. C Ac results in an upper block Hessenberg form. C C Phase 2: C If JOB = 'M' or 'O', the same algorithm is applied to the dual C of the controllable realization (Ac,Bc,Cc), or to the dual of C the original system, respectively, to extract an observable C realization (Ar,Br,Cr). If JOB = 'M', the resulting realization C is also controllable, and thus minimal. C Ar results in an upper block Hessenberg form. C C REFERENCES C C [1] Van Dooren, P. C The Generalized Eigenstructure Problem in Linear System C Theory. (Algorithm 1) C IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations and is backward stable. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium. C A. Varga, DLR - Oberpfaffenhofen, April 1999. C C REVISIONS C C A. Varga, DLR - Oberpfaffenhofen, March 2002. C V.Sima, Dec. 2016, Mar. 2017. C C KEYWORDS C C Hessenberg form, minimal realization, multivariable system, C orthogonal transformation, state-space model, state-space C representation. C C ****************************************************************** C C .. Parameters .. INTEGER LDIZ PARAMETER ( LDIZ = 1 ) DOUBLE PRECISION ONE, HUNDR PARAMETER ( ONE = 1.0D0, HUNDR = 100.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL, JOB INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, NR, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER INFRED(*), IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) C .. Local Scalars .. LOGICAL LEQUIL, LNJOBC, LNJOBO, LSPACE INTEGER I, IB, ICON, INDCON, ITAU, IZ, JWORK, KL, KWA, $ KWB, KWC, LDWMIN, MAXMP, NCONT, WRKOPT DOUBLE PRECISION ANORM, BNORM, CNORM, MAXRED C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE EXTERNAL DLANGE, LSAME C .. External Subroutines .. EXTERNAL AB07MD, DLACPY, TB01ID, TB01UD, TB01XD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C INFO = 0 MAXMP = MAX( M, P ) LDWMIN = N + MAX( N, 3*MAXMP ) LNJOBC = .NOT.LSAME( JOB, 'C' ) LNJOBO = .NOT.LSAME( JOB, 'O' ) LEQUIL = LSAME( EQUIL, 'S' ) C C Test the input scalar arguments. C IF( LNJOBC .AND. LNJOBO .AND. .NOT.LSAME( JOB, 'M' ) ) THEN INFO = -1 ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) 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.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN INFO = -11 ELSE IF( LDWORK.LT.1 .OR. ( N.GT.0 .AND. LDWORK.LT.LDWMIN ) ) THEN INFO = -17 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01PX', -INFO ) RETURN END IF C INFRED(1) = -1 INFRED(2) = -1 INFRED(4) = 0 C C Quick return if possible. C IF ( N.EQ.0 .OR. ( LNJOBC .AND. P.EQ.0 ) .OR. $ ( LNJOBO .AND. M.EQ.0 ) ) THEN NR = 0 INFRED(3) = 0 DWORK(1) = ONE RETURN END IF ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK ) * * In case of absolute error control, the following * squence can be employed: * * IF( .NOT. LEQUIL .AND. BNORM.LE.TOL ) THEN * NR = 0 * INFRED(1) = N * DWORK(1) = ONE * RETURN * END IF * IF( .NOT. LEQUIL .AND. CNORM.LE.TOL ) THEN * NR = 0 * INFRED(2) = N * DWORK(1) = ONE * RETURN * END IF C C If required, balance the triplet (A,B,C). C Workspace: need N. C C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of real workspace needed at that point in the code, C as well as the preferred amount for good performance.) C IF ( LEQUIL ) THEN MAXRED = MAX( HUNDR, ANORM, BNORM, CNORM ) CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Set large workspace option and determine offsets. C LSPACE = LDWORK.GE.N*( N + M + P ) + LDWMIN IF ( LSPACE ) THEN KWA = 1 KWB = KWA + N*N KWC = KWB + N*M IZ = KWC + P*N ELSE IZ = 1 END IF C ITAU = IZ JWORK = ITAU + N KL = MAX( 0, N-1 ) IB = 1 C IF ( LNJOBO ) THEN C C Phase 1: Eliminate uncontrolable eigenvalues. C IF( LSPACE ) THEN C C Save system matrices. C CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KWA), N ) CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KWB), N ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KWC), MAX( 1, P ) ) END IF C C Separate out controllable subsystem (of order NCONT): C A <-- Z'*A*Z, B <-- Z'*B, C <-- C*Z. C C Workspace: need N + MAX(N, 3*M, P). C prefer larger. C CALL TB01UD( 'No Z', N, M, P, A, LDA, B, LDB, C, LDC, NCONT, $ ICON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL, $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 C IF( NCONT.LT.N .OR. .NOT.LSPACE ) THEN IF( ICON.GT.1 ) THEN KL = IWORK(1) + IWORK(2) - 1 ELSE IF( ICON.EQ.1 ) THEN KL = IWORK(1) - 1 ELSE KL = 0 END IF INFRED(1) = N - NCONT INFRED(4) = ICON IF ( LNJOBC ) $ IB = N + 1 ELSE C C Restore system matrices. C CALL DLACPY( 'Full', N, N, DWORK(KWA), N, A, LDA ) CALL DLACPY( 'Full', N, M, DWORK(KWB), N, B, LDB ) CALL DLACPY( 'Full', P, N, DWORK(KWC), MAX( 1, P ), C, LDC ) END IF ELSE NCONT = N END IF C IF ( LNJOBC ) THEN C C Phase 2: Eliminate unobservable eigenvalues. C IF( LSPACE .AND. ( ( LNJOBO .AND. NCONT.LT.N ) .OR. $ .NOT.LNJOBO ) ) THEN C C Save system matrices. C CALL DLACPY( 'Full', NCONT, NCONT, A, LDA, DWORK(KWA), N ) CALL DLACPY( 'Full', NCONT, M, B, LDB, DWORK(KWB), N ) CALL DLACPY( 'Full', P, NCONT, C, LDC, DWORK(KWC), $ MAX( 1, P ) ) END IF C C Separate out the observable subsystem (of order NR): C Form the dual of the subsystem of order NCONT (which is C controllable, if JOB = 'M'), leaving the rest as it is. C CALL AB07MD( 'Z', NCONT, M, P, A, LDA, B, LDB, C, LDC, DWORK, $ 1, INFO ) C C And separate out the controllable part of this dual subsystem. C C Workspace: need NCONT + MAX(NCONT, 3*P, M). C prefer larger. C CALL TB01UD( 'No Z', NCONT, P, M, A, LDA, B, LDB, C, LDC, NR, $ INDCON, IWORK(IB), DWORK(IZ), LDIZ, DWORK(ITAU), $ TOL, IWORK(IB+N), DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Transpose and reorder (to get a block upper Hessenberg C matrix A), giving, for JOB = 'M', the controllable and C observable (i.e., minimal) part of original system. C IF( NR.LT.NCONT .OR. .NOT.LSPACE ) THEN IF( INDCON.GT.1 ) THEN KL = IWORK(IB) + IWORK(IB+1) - 1 ELSE IF( INDCON.EQ.1 ) THEN KL = IWORK(IB) - 1 ELSE KL = 0 END IF CALL TB01XD( 'Zero D', NR, P, M, KL, MAX( 0, NR-1 ), $ A, LDA, B, LDB, C, LDC, DWORK, 1, INFO ) INFRED(2) = NCONT - NR INFRED(4) = INDCON IF ( LNJOBO ) THEN DO 10 I = 1, INDCON IWORK(I) = IWORK(IB+I-1) 10 CONTINUE END IF ELSE C C Restore system matrices. C CALL DLACPY( 'Full', NCONT, NCONT, DWORK(KWA), N, A, LDA ) CALL DLACPY( 'Full', NCONT, M, DWORK(KWB), N, B, LDB ) CALL DLACPY( 'Full', P, NCONT, DWORK(KWC), MAX( 1, P ), $ C, LDC ) END IF ELSE NR = NCONT END IF C C Set structure information and optimal workspace dimension. C INFRED(3) = KL DWORK(1) = MAX( WRKOPT, LDWMIN + N*( N + M + P ) ) RETURN C *** Last line of TB01PX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01RY.f0000644000000000000000000000013215012430707016207 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01RY.f0000644000175000017500000003272215012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE MB01RY( SIDE, UPLO, TRANS, M, ALPHA, BETA, R, LDR, H, $ LDH, B, LDB, DWORK, INFO ) 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 control-4.1.2/src/slicot/src/PaxHeaders/SB04PX.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04PX.f0000644000175000017500000003363115012430707017417 0ustar00lilgelilge00000000000000 SUBROUTINE SB04PX( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) C C PURPOSE C C To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in C C op(TL)*X*op(TR) + ISGN*X = SCALE*B, C C where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1 C or -1. op(T) = T or T', where T' denotes the transpose of T. C C ARGUMENTS C C Mode Parameters C C LTRANL LOGICAL C Specifies the form of op(TL) to be used, as follows: C = .FALSE.: op(TL) = TL, C = .TRUE. : op(TL) = TL'. C C LTRANR LOGICAL C Specifies the form of op(TR) to be used, as follows: C = .FALSE.: op(TR) = TR, C = .TRUE. : op(TR) = TR'. C C ISGN INTEGER C Specifies the sign of the equation as described before. C ISGN may only be 1 or -1. C C Input/Output Parameters C C N1 (input) INTEGER C The order of matrix TL. N1 may only be 0, 1 or 2. C C N2 (input) INTEGER C The order of matrix TR. N2 may only be 0, 1 or 2. C C TL (input) DOUBLE PRECISION array, dimension (LDTL,N1) C The leading N1-by-N1 part of this array must contain the C matrix TL. C C LDTL INTEGER C The leading dimension of array TL. LDTL >= MAX(1,N1). C C TR (input) DOUBLE PRECISION array, dimension (LDTR,N2) C The leading N2-by-N2 part of this array must contain the C matrix TR. C C LDTR INTEGER C The leading dimension of array TR. LDTR >= MAX(1,N2). C C B (input) DOUBLE PRECISION array, dimension (LDB,N2) C The leading N1-by-N2 part of this array must contain the C right-hand side of the equation. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N1). C C SCALE (output) DOUBLE PRECISION C The scale factor. SCALE is chosen less than or equal to 1 C to prevent the solution overflowing. C C X (output) DOUBLE PRECISION array, dimension (LDX,N2) C The leading N1-by-N2 part of this array contains the C solution of the equation. C Note that X may be identified with B in the calling C statement. C C LDX INTEGER C The leading dimension of array X. LDX >= MAX(1,N1). C C XNORM (output) DOUBLE PRECISION C The infinity-norm of the solution. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if TL and -ISGN*TR have almost reciprocal C eigenvalues, so TL or TR is perturbed to get a C nonsingular equation. C C NOTE: In the interests of speed, this routine does not C check the inputs for errors. C C METHOD C C The equivalent linear algebraic system of equations is formed and C solved using Gaussian elimination with complete pivoting. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C The algorithm is stable and reliable, since Gaussian elimination C with complete pivoting is used. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, May 2000. C This is a modification and slightly more efficient version of C SLICOT Library routine SB03MU. C C REVISIONS C C - C C KEYWORDS C C Discrete-time system, Sylvester equation, matrix algebra. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, HALF, EIGHT PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) C .. C .. Scalar Arguments .. LOGICAL LTRANL, LTRANR INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 DOUBLE PRECISION SCALE, XNORM C .. C .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), $ X( LDX, * ) C .. C .. Local Scalars .. LOGICAL BSWAP, XSWAP INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, $ TEMP, U11, U12, U22, XMAX C .. C .. Local Arrays .. LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), $ LOCU22( 4 ) DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, IDAMAX C .. C .. External Subroutines .. EXTERNAL DSWAP C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. C .. Data statements .. DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , $ LOCU22 / 4, 3, 2, 1 / DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / C .. C .. Executable Statements .. C C Do not check the input parameters for errors. C INFO = 0 SCALE = ONE C C Quick return if possible. C IF( N1.EQ.0 .OR. N2.EQ.0 ) THEN XNORM = ZERO RETURN END IF C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS SGN = ISGN C K = N1 + N1 + N2 - 2 GO TO ( 10, 20, 30, 50 )K C C 1-by-1: TL11*X*TR11 + ISGN*X = B11. C 10 CONTINUE TAU1 = TL( 1, 1 )*TR( 1, 1 ) + SGN BET = ABS( TAU1 ) IF( BET.LE.SMLNUM ) THEN TAU1 = SMLNUM BET = SMLNUM INFO = 1 END IF C GAM = ABS( B( 1, 1 ) ) IF( SMLNUM*GAM.GT.BET ) $ SCALE = ONE / GAM C X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 XNORM = ABS( X( 1, 1 ) ) RETURN C C 1-by-2: C TL11*[X11 X12]*op[TR11 TR12] + ISGN*[X11 X12] = [B11 B12]. C [TR21 TR22] C 20 CONTINUE C SMIN = MAX( MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) $ *ABS( TL( 1, 1 ) )*EPS, $ SMLNUM ) TMP( 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN TMP( 4 ) = TL( 1, 1 )*TR( 2, 2 ) + SGN IF( LTRANR ) THEN TMP( 2 ) = TL( 1, 1 )*TR( 2, 1 ) TMP( 3 ) = TL( 1, 1 )*TR( 1, 2 ) ELSE TMP( 2 ) = TL( 1, 1 )*TR( 1, 2 ) TMP( 3 ) = TL( 1, 1 )*TR( 2, 1 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 1, 2 ) GO TO 40 C C 2-by-1: C op[TL11 TL12]*[X11]*TR11 + ISGN*[X11] = [B11]. C [TL21 TL22] [X21] [X21] [B21] C 30 CONTINUE SMIN = MAX( MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) $ *ABS( TR( 1, 1 ) )*EPS, $ SMLNUM ) TMP( 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN TMP( 4 ) = TL( 2, 2 )*TR( 1, 1 ) + SGN IF( LTRANL ) THEN TMP( 2 ) = TL( 1, 2 )*TR( 1, 1 ) TMP( 3 ) = TL( 2, 1 )*TR( 1, 1 ) ELSE TMP( 2 ) = TL( 2, 1 )*TR( 1, 1 ) TMP( 3 ) = TL( 1, 2 )*TR( 1, 1 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) 40 CONTINUE C C Solve 2-by-2 system using complete pivoting. C Set pivots less than SMIN to SMIN. C IPIV = IDAMAX( 4, TMP, 1 ) U11 = TMP( IPIV ) IF( ABS( U11 ).LE.SMIN ) THEN INFO = 1 U11 = SMIN END IF U12 = TMP( LOCU12( IPIV ) ) L21 = TMP( LOCL21( IPIV ) ) / U11 U22 = TMP( LOCU22( IPIV ) ) - U12*L21 XSWAP = XSWPIV( IPIV ) BSWAP = BSWPIV( IPIV ) IF( ABS( U22 ).LE.SMIN ) THEN INFO = 1 U22 = SMIN END IF IF( BSWAP ) THEN TEMP = BTMP( 2 ) BTMP( 2 ) = BTMP( 1 ) - L21*TEMP BTMP( 1 ) = TEMP ELSE BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) END IF IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE END IF X2( 2 ) = BTMP( 2 ) / U22 X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) IF( XSWAP ) THEN TEMP = X2( 2 ) X2( 2 ) = X2( 1 ) X2( 1 ) = TEMP END IF X( 1, 1 ) = X2( 1 ) IF( N1.EQ.1 ) THEN X( 1, 2 ) = X2( 2 ) XNORM = ABS( X2( 1 ) ) + ABS( X2( 2 ) ) ELSE X( 2, 1 ) = X2( 2 ) XNORM = MAX( ABS( X2( 1 ) ), ABS( X2( 2 ) ) ) END IF RETURN C C 2-by-2: C op[TL11 TL12]*[X11 X12]*op[TR11 TR12] + ISGN*[X11 X12] = [B11 B12] C [TL21 TL22] [X21 X22] [TR21 TR22] [X21 X22] [B21 B22] C C Solve equivalent 4-by-4 system using complete pivoting. C Set pivots less than SMIN to SMIN. C 50 CONTINUE SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) SMIN = MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )*SMIN SMIN = MAX( EPS*SMIN, SMLNUM ) T16( 1, 1 ) = TL( 1, 1 )*TR( 1, 1 ) + SGN T16( 2, 2 ) = TL( 2, 2 )*TR( 1, 1 ) + SGN T16( 3, 3 ) = TL( 1, 1 )*TR( 2, 2 ) + SGN T16( 4, 4 ) = TL( 2, 2 )*TR( 2, 2 ) + SGN IF( LTRANL ) THEN T16( 1, 2 ) = TL( 2, 1 )*TR( 1, 1 ) T16( 2, 1 ) = TL( 1, 2 )*TR( 1, 1 ) T16( 3, 4 ) = TL( 2, 1 )*TR( 2, 2 ) T16( 4, 3 ) = TL( 1, 2 )*TR( 2, 2 ) ELSE T16( 1, 2 ) = TL( 1, 2 )*TR( 1, 1 ) T16( 2, 1 ) = TL( 2, 1 )*TR( 1, 1 ) T16( 3, 4 ) = TL( 1, 2 )*TR( 2, 2 ) T16( 4, 3 ) = TL( 2, 1 )*TR( 2, 2 ) END IF IF( LTRANR ) THEN T16( 1, 3 ) = TL( 1, 1 )*TR( 1, 2 ) T16( 2, 4 ) = TL( 2, 2 )*TR( 1, 2 ) T16( 3, 1 ) = TL( 1, 1 )*TR( 2, 1 ) T16( 4, 2 ) = TL( 2, 2 )*TR( 2, 1 ) ELSE T16( 1, 3 ) = TL( 1, 1 )*TR( 2, 1 ) T16( 2, 4 ) = TL( 2, 2 )*TR( 2, 1 ) T16( 3, 1 ) = TL( 1, 1 )*TR( 1, 2 ) T16( 4, 2 ) = TL( 2, 2 )*TR( 1, 2 ) END IF IF( LTRANL .AND. LTRANR ) THEN T16( 1, 4 ) = TL( 2, 1 )*TR( 1, 2 ) T16( 2, 3 ) = TL( 1, 2 )*TR( 1, 2 ) T16( 3, 2 ) = TL( 2, 1 )*TR( 2, 1 ) T16( 4, 1 ) = TL( 1, 2 )*TR( 2, 1 ) ELSE IF( LTRANL .AND. .NOT.LTRANR ) THEN T16( 1, 4 ) = TL( 2, 1 )*TR( 2, 1 ) T16( 2, 3 ) = TL( 1, 2 )*TR( 2, 1 ) T16( 3, 2 ) = TL( 2, 1 )*TR( 1, 2 ) T16( 4, 1 ) = TL( 1, 2 )*TR( 1, 2 ) ELSE IF( .NOT.LTRANL .AND. LTRANR ) THEN T16( 1, 4 ) = TL( 1, 2 )*TR( 1, 2 ) T16( 2, 3 ) = TL( 2, 1 )*TR( 1, 2 ) T16( 3, 2 ) = TL( 1, 2 )*TR( 2, 1 ) T16( 4, 1 ) = TL( 2, 1 )*TR( 2, 1 ) ELSE T16( 1, 4 ) = TL( 1, 2 )*TR( 2, 1 ) T16( 2, 3 ) = TL( 2, 1 )*TR( 2, 1 ) T16( 3, 2 ) = TL( 1, 2 )*TR( 1, 2 ) T16( 4, 1 ) = TL( 2, 1 )*TR( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) BTMP( 3 ) = B( 1, 2 ) BTMP( 4 ) = B( 2, 2 ) C C Perform elimination. C DO 100 I = 1, 3 XMAX = ZERO C DO 70 IP = I, 4 C DO 60 JP = I, 4 IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( T16( IP, JP ) ) IPSV = IP JPSV = JP END IF 60 CONTINUE C 70 CONTINUE C IF( IPSV.NE.I ) THEN CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) TEMP = BTMP( I ) BTMP( I ) = BTMP( IPSV ) BTMP( IPSV ) = TEMP END IF IF( JPSV.NE.I ) $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) JPIV( I ) = JPSV IF( ABS( T16( I, I ) ).LT.SMIN ) THEN INFO = 1 T16( I, I ) = SMIN END IF C DO 90 J = I + 1, 4 T16( J, I ) = T16( J, I ) / T16( I, I ) BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) C DO 80 K = I + 1, 4 T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) 80 CONTINUE C 90 CONTINUE C 100 CONTINUE C IF( ABS( T16( 4, 4 ) ).LT.SMIN ) $ T16( 4, 4 ) = SMIN IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), $ ABS( BTMP( 4 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE BTMP( 3 ) = BTMP( 3 )*SCALE BTMP( 4 ) = BTMP( 4 )*SCALE END IF C DO 120 I = 1, 4 K = 5 - I TEMP = ONE / T16( K, K ) TMP( K ) = BTMP( K )*TEMP C DO 110 J = K + 1, 4 TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) 110 CONTINUE C 120 CONTINUE C DO 130 I = 1, 3 IF( JPIV( 4-I ).NE.4-I ) THEN TEMP = TMP( 4-I ) TMP( 4-I ) = TMP( JPIV( 4-I ) ) TMP( JPIV( 4-I ) ) = TEMP END IF 130 CONTINUE C X( 1, 1 ) = TMP( 1 ) X( 2, 1 ) = TMP( 2 ) X( 1, 2 ) = TMP( 3 ) X( 2, 2 ) = TMP( 4 ) XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 3 ) ), $ ABS( TMP( 2 ) ) + ABS( TMP( 4 ) ) ) C RETURN C *** Last line of SB04PX *** END control-4.1.2/src/slicot/src/PaxHeaders/TF01MX.f0000644000000000000000000000013215012430707016214 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TF01MX.f0000644000175000017500000003161615012430707017417 0ustar00lilgelilge00000000000000 SUBROUTINE TF01MX( N, M, P, NY, S, LDS, U, LDU, X, Y, LDY, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the output sequence of a linear time-invariant C open-loop system given by its discrete-time state-space model C with an (N+P)-by-(N+M) general system matrix S, C C ( A B ) C S = ( ) . C ( C D ) C C The initial state vector x(1) must be supplied by the user. C C The input and output trajectories are stored as in the SLICOT C Library routine TF01MY. 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 number of system inputs. M >= 0. C C P (input) INTEGER C The number of system outputs. P >= 0. C C NY (input) INTEGER C The number of output vectors y(k) to be computed. C NY >= 0. C C S (input) DOUBLE PRECISION array, dimension (LDS,N+M) C The leading (N+P)-by-(N+M) part of this array must contain C the system matrix S. C C LDS INTEGER C The leading dimension of array S. LDS >= MAX(1,N+P). C C U (input) DOUBLE PRECISION array, dimension (LDU,M) C The leading NY-by-M part of this array must contain the C input vector sequence u(k), for k = 1,2,...,NY. C Specifically, the k-th row of U must contain u(k)'. C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,NY). C C X (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the initial state vector C x(1) which consists of the N initial states of the system. C On exit, this array contains the final state vector C x(NY+1) of the N states of the system at instant NY+1. C C Y (output) DOUBLE PRECISION array, dimension (LDY,P) C The leading NY-by-P part of this array contains the output C vector sequence y(1),y(2),...,y(NY) such that the k-th C row of Y contains y(k)' (the outputs at instant k), C for k = 1,2,...,NY. C C LDY INTEGER C The leading dimension of array Y. LDY >= MAX(1,NY). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 0, if MIN(N,P,NY) = 0; otherwise, C LDWORK >= N+P, if M = 0; C LDWORK >= 2*N+M+P, if M > 0. C For better 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 C METHOD C C Given an initial state vector x(1), the output vector sequence C y(1), y(2),..., y(NY) is obtained via the formulae C C ( x(k+1) ) ( x(k) ) C ( ) = S ( ) , C ( y(k) ) ( u(k) ) C C where each element y(k) is a vector of length P containing the C outputs at instant k, and k = 1,2,...,NY. C C REFERENCES C C [1] Luenberger, D.G. C Introduction to Dynamic Systems: Theory, Models and C Applications. C John Wiley & Sons, New York, 1979. C C NUMERICAL ASPECTS C C The algorithm requires approximately (N + M) x (N + P) x NY C multiplications and additions. C C FURTHER COMMENTS C C The implementation exploits data locality as much as possible, C given the workspace length. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 2002. C C REVISIONS C C - C C KEYWORDS C C Discrete-time system, multivariable system, state-space model, C state-space representation, time response. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDS, LDU, LDWORK, LDY, M, N, NY, P C .. Array Arguments .. DOUBLE PRECISION DWORK(*), S(LDS,*), U(LDU,*), X(*), Y(LDY,*) C .. Local Scalars .. INTEGER I, IC, IU, IW, IY, J, JW, K, N2M, N2P, NB, NF, $ NM, NP, NS C .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C NP = N + P NM = N + M IW = NM + NP 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( NY.LT.0 ) THEN INFO = -4 ELSE IF( LDS.LT.MAX( 1, NP ) ) THEN INFO = -6 ELSE IF( LDU.LT.MAX( 1, NY ) ) THEN INFO = -8 ELSE IF( LDY.LT.MAX( 1, NY ) ) THEN INFO = -11 ELSE IF( MIN( N, P, NY ).EQ.0 ) THEN JW = 0 ELSE IF( M.EQ.0 ) THEN JW = NP ELSE JW = IW END IF IF( LDWORK.LT.JW ) $ INFO = -13 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TF01MX', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( NY, P ).EQ.0 ) THEN RETURN ELSE IF ( N.EQ.0 ) THEN C C Non-dynamic system: compute the output vectors. C IF ( M.EQ.0 ) THEN CALL DLASET( 'Full', NY, P, ZERO, ZERO, Y, LDY ) ELSE CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, $ U, LDU, S, LDS, ZERO, Y, LDY ) END IF RETURN END IF C C Determine the block size (taken as for LAPACK routine DGETRF). C NB = ILAENV( 1, 'DGETRF', ' ', NY, MAX( M, P ), -1, -1 ) C C Find the number of state vectors, extended with inputs (if M > 0) C and outputs, that can be accommodated in the provided workspace. C NS = MIN( LDWORK/JW, NB*NB/JW, NY ) N2P = N + NP C IF ( M.EQ.0 ) THEN C C System with no inputs. C Workspace: need N + P; C prefer larger. C IF( NS.LE.1 .OR. NY*P.LE.NB*NB ) THEN IY = N + 1 C C LDWORK < 2*(N+P), or small problem. C One row of array Y is computed for each loop index value. C DO 10 I = 1, NY C C Compute C C /x(i+1)\ /A\ C | | = | | * x(i). C \ y(i) / \C/ C CALL DGEMV( 'NoTranspose', NP, N, ONE, S, LDS, X, 1, $ ZERO, DWORK, 1 ) CALL DCOPY( N, DWORK, 1, X, 1 ) CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY ) 10 CONTINUE C ELSE C C LDWORK >= 2*(N+P), and large problem. C NS rows of array Y are computed before being saved. C NF = ( NY/NS )*NS CALL DCOPY( N, X, 1, DWORK, 1 ) C DO 40 I = 1, NF, NS C C Compute the current NS extended state vectors in the C workspace: C C /x(i+1)\ /A\ C | | = | | * x(i), i = 1 : ns - 1. C \ y(i) / \C/ C DO 20 IC = 1, ( NS - 1 )*NP, NP CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, $ DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 ) 20 CONTINUE C C Prepare the next iteration. C CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, $ DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 ) C C Transpose the NS output vectors in the corresponding part C of Y (column-wise). C DO 30 J = 1, P CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(I,J), 1 ) Y(I+NS-1,J) = DWORK(N+J) 30 CONTINUE C 40 CONTINUE C NS = NY - NF C IF ( NS.GT.1 ) THEN C C Compute similarly the last NS output vectors. C DO 50 IC = 1, ( NS - 1 )*NP, NP CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, $ DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 ) 50 CONTINUE C CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, $ DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 ) C DO 60 J = 1, P CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(NF+1,J), 1 ) Y(NF+NS,J) = DWORK(N+J) 60 CONTINUE C ELSE IF ( NS.EQ.1 ) THEN C C Compute similarly the last NS = 1 output vectors. C CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 ) CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, $ DWORK(NP+1), 1, ZERO, DWORK, 1 ) CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY ) C END IF C C Set the final state vector. C CALL DCOPY( N, DWORK, 1, X, 1 ) C END IF C ELSE C C General case. C Workspace: need 2*N + M + P; C prefer larger. C CALL DCOPY( N, X, 1, DWORK, 1 ) C IF( NS.LE.1 .OR. NY*( M + P ).LE.NB*NB ) THEN IU = N + 1 JW = IU + M IY = JW + N C C LDWORK < 2*(2*N+M+P), or small problem. C One row of array Y is computed for each loop index value. C DO 70 I = 1, NY C C Compute C C /x(i+1)\ /A, B\ /x(i)\ C | | = | | * | | . C \ y(i) / \C, D/ \u(i)/ C CALL DCOPY( M, U(I,1), LDU, DWORK(IU), 1 ) CALL DGEMV( 'NoTranspose', NP, NM, ONE, S, LDS, DWORK, 1, $ ZERO, DWORK(JW), 1 ) CALL DCOPY( N, DWORK(JW), 1, DWORK, 1 ) CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY ) 70 CONTINUE C ELSE C C LDWORK >= 2*(2*N+M+P), and large problem. C NS rows of array Y are computed before being saved. C NF = ( NY/NS )*NS N2M = N + NM C DO 110 I = 1, NF, NS JW = 1 C C Compute the current NS extended state vectors in the C workspace: C C /x(i+1)\ /A, B\ /x(i)\ C | | = | | * | | , i = 1 : ns - 1. C \ y(i) / \C, D/ \u(i)/ C DO 80 J = 1, M CALL DCOPY( NS, U(I,J), 1, DWORK(N+J), IW ) 80 CONTINUE C DO 90 K = 1, NS - 1 CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) JW = JW + NM CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 ) JW = JW + NP 90 CONTINUE C C Prepare the next iteration. C CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 ) C C Transpose the NS output vectors in the corresponding part C of Y (column-wise). C DO 100 J = 1, P CALL DCOPY( NS, DWORK(N2M+J), IW, Y(I,J), 1 ) 100 CONTINUE C 110 CONTINUE C NS = NY - NF C IF ( NS.GT.1 ) THEN JW = 1 C C Compute similarly the last NS output vectors. C DO 120 J = 1, M CALL DCOPY( NS, U(NF+1,J), 1, DWORK(N+J), IW ) 120 CONTINUE C DO 130 K = 1, NS - 1 CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) JW = JW + NM CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 ) JW = JW + NP 130 CONTINUE C CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 ) C DO 140 J = 1, P CALL DCOPY( NS, DWORK(N2M+J), IW, Y(NF+1,J), 1 ) 140 CONTINUE C ELSE IF ( NS.EQ.1 ) THEN C C Compute similarly the last NS = 1 output vectors. C CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 ) CALL DCOPY( M, U(NF+1,1), LDU, DWORK(N2P+1), 1 ) CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, $ DWORK(NP+1), 1, ZERO, DWORK, 1 ) CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY ) C END IF C END IF C C Set the final state vector. C CALL DCOPY( N, DWORK, 1, X, 1 ) C END IF C RETURN C *** Last line of TF01MX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04ND.f0000644000000000000000000000013215012430707016161 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04ND.f0000644000175000017500000002020015012430707017347 0ustar00lilgelilge00000000000000 SUBROUTINE MB04ND( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, $ TAU, DWORK ) 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 .. 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 control-4.1.2/src/slicot/src/PaxHeaders/SB02OV.f0000644000000000000000000000013015012430707016206 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB02OV.f0000644000175000017500000000330415012430707017404 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION SB02OV( ALPHAR, ALPHAI, BETA ) C C PURPOSE C C To select the unstable generalized eigenvalues for solving the C discrete-time algebraic Riccati equation. C C ARGUMENTS C C Input/Output Parameters C C ALPHAR (input) DOUBLE PRECISION C The real part of the numerator of the current eigenvalue C considered. C C ALPHAI (input) DOUBLE PRECISION C The imaginary part of the numerator of the current C eigenvalue considered. C C BETA (input) DOUBLE PRECISION C The (real) denominator of the current eigenvalue C considered. C C METHOD C C The function value SB02OV is set to .TRUE. for an unstable C eigenvalue (i.e., with modulus greater than or equal to one) and C to .FALSE., otherwise. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. C Supersedes Release 2.0 routine SB02CX by P. Van Dooren, Philips C Research Laboratory, Brussels, Belgium. C C REVISIONS C C - C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, optimal regulator, Schur form. C C ****************************************************************** C C .. Scalar Arguments .. DOUBLE PRECISION ALPHAR, ALPHAI, BETA C .. External Functions .. DOUBLE PRECISION DLAPY2 EXTERNAL DLAPY2 C .. Intrinsic Functions .. INTRINSIC ABS C .. Executable Statements .. C SB02OV = DLAPY2( ALPHAR, ALPHAI ).GE.ABS( BETA ) C RETURN C *** Last line of SB02OV *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02MD.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02MD.f0000644000175000017500000005364415012430707017366 0ustar00lilgelilge00000000000000 SUBROUTINE MB02MD( JOB, M, N, L, RANK, C, LDC, S, X, LDX, TOL, $ IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To solve the Total Least Squares (TLS) problem using a Singular C Value Decomposition (SVD) approach. C The TLS problem assumes an overdetermined set of linear equations C AX = B, where both the data matrix A as well as the observation C matrix B are inaccurate. The routine also solves determined and C underdetermined sets of equations by computing the minimum norm C solution. C It is assumed that all preprocessing measures (scaling, coordinate C transformations, whitening, ... ) of the data have been performed C in advance. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Determines whether the values of the parameters RANK and C TOL are to be specified by the user or computed by the C routine as follows: C = 'R': Compute RANK only; C = 'T': Compute TOL only; C = 'B': Compute both RANK and TOL; C = 'N': Compute neither RANK nor TOL. C C Input/Output Parameters C C M (input) INTEGER C The number of rows in the data matrix A and the C observation matrix B. M >= 0. C C N (input) INTEGER C The number of columns in the data matrix A. N >= 0. C C L (input) INTEGER C The number of columns in the observation matrix B. C L >= 0. C C RANK (input/output) INTEGER C On entry, if JOB = 'T' or JOB = 'N', then RANK must C specify r, the rank of the TLS approximation [A+DA|B+DB]. C RANK <= min(M,N). C Otherwise, r is computed by the routine. C On exit, if JOB = 'R' or JOB = 'B', and INFO = 0, then C RANK contains the computed (effective) rank of the TLS C approximation [A+DA|B+DB]. C Otherwise, the user-supplied value of RANK may be C changed by the routine on exit if the RANK-th and the C (RANK+1)-th singular values of C = [A|B] are considered C to be equal, or if the upper triangular matrix F (as C defined in METHOD) is (numerically) singular. C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N+L) C On entry, the leading M-by-(N+L) part of this array must C contain the matrices A and B. Specifically, the first N C columns must contain the data matrix A and the last L C columns the observation matrix B (right-hand sides). C On exit, the leading (N+L)-by-(N+L) part of this array C contains the (transformed) right singular vectors, C including null space vectors, if any, of C = [A|B]. C Specifically, the leading (N+L)-by-RANK part of this array C always contains the first RANK right singular vectors, C corresponding to the largest singular values of C. If C L = 0, or if RANK = 0 and IWARN <> 2, the remaining C (N+L)-by-(N+L-RANK) top-right part of this array contains C the remaining N+L-RANK right singular vectors. Otherwise, C this part contains the matrix V2 transformed as described C in Step 3 of the TLS algorithm (see METHOD). C C LDC INTEGER C The leading dimension of array C. LDC >= max(1,M,N+L). C C S (output) DOUBLE PRECISION array, dimension (min(M,N+L)) C If INFO = 0, the singular values of matrix C, ordered C such that S(1) >= S(2) >= ... >= S(p-1) >= S(p) >= 0, C where p = min(M,N+L). C C X (output) DOUBLE PRECISION array, dimension (LDX,L) C If INFO = 0, the leading N-by-L part of this array C contains the solution X to the TLS problem specified C by A and B. C C LDX INTEGER C The leading dimension of array X. LDX >= max(1,N). C C Tolerances C C TOL DOUBLE PRECISION C A tolerance used to determine the rank of the TLS C approximation [A+DA|B+DB] and to check the multiplicity C of the singular values of matrix C. Specifically, S(i) C and S(j) (i < j) are considered to be equal if C SQRT(S(i)**2 - S(j)**2) <= TOL, and the TLS approximation C [A+DA|B+DB] has rank r if S(i) > TOL*S(1) (or S(i) > TOL, C if TOL specifies sdev (see below)), for i = 1,2,...,r. C TOL is also used to check the singularity of the upper C triangular matrix F (as defined in METHOD). C If JOB = 'R' or JOB = 'N', then TOL must specify the C desired tolerance. If the user sets TOL to be less than or C equal to 0, the tolerance is taken as EPS, where EPS is C the machine precision (see LAPACK Library routine DLAMCH). C Otherwise, the tolerance is computed by the routine and C the user must supply the non-negative value sdev, i.e. the C estimated standard deviation of the error on each element C of the matrix C, as input value of TOL. C C Workspace C C IWORK INTEGER array, dimension (L) 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) returns the reciprocal of the C condition number of the matrix F. C If INFO > 0, DWORK(1:min(M,N+L)-1) contain the unconverged C non-diagonal elements of the bidiagonal matrix whose C diagonal is in S (see LAPACK Library routine DGESVD). C C LDWORK INTEGER C The length of the array DWORK. C LDWORK = max(2, 3*(N+L) + M, 5*(N+L)), if M >= N+L; C LDWORK = max(2, M*(N+L) + max( 3M+N+L, 5*M), 3*L), C if M < N+L. 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 Warning Indicator C C IWARN INTEGER C = 0: no warnings; C = 1: if the rank of matrix C has been lowered because a C singular value of multiplicity greater than 1 was C found; C = 2: if the rank of matrix C has been lowered because the C upper triangular matrix F is (numerically) singular. 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 the SVD algorithm (in LAPACK Library routine C DBDSQR) has failed to converge. In this case, S(1), C S(2), ..., S(INFO) may not have been found C correctly and the remaining singular values may C not be the smallest. This failure is not likely C to occur. C C METHOD C C The method used is an extension (see [3,4,5]) of the classical C TLS algorithm proposed by Golub and Van Loan [1]. C C Let [A|B] denote the matrix formed by adjoining the columns of B C to the columns of A on the right. C C Total Least Squares (TLS) definition: C ------------------------------------- C C Given matrices A and B, find a matrix X satisfying C C (A + DA) X = B + DB, C C where A and DA are M-by-N matrices, B and DB are M-by-L matrices C and X is an N-by-L matrix. C The solution X must be such that the Frobenius norm of [DA|DB] C is a minimum and each column of B + DB is in the range of C A + DA. Whenever the solution is not unique, the routine singles C out the minimum norm solution X. C C Define matrix C = [A|B] and s(i) as its i-th singular value for C i = 1,2,...,min(M,NL), where NL = N + L. If M < NL, then s(j) = 0 C for j = M+1,...,NL. C C The Classical TLS algorithm proceeds as follows (see [3,4,5]): C C Step 1: Compute part of the singular value decomposition (SVD) C USV' of C = [A|B], namely compute S and V'. (An initial C QR factorization of C is used when M is larger enough C than NL.) C C Step 2: If not fixed by the user, compute the rank r0 of the data C [A|B] based on TOL as follows: if JOB = 'R' or JOB = 'N', C C s(1) >= ... >= s(r0) > TOL*s(1) >= ... >= s(NL). C C Otherwise, using [2], TOL can be computed from the C standard deviation sdev of the errors on [A|B]: C C TOL = SQRT(2 * max(M,NL)) * sdev, C C and the rank r0 is determined (if JOB = 'R' or 'B') using C C s(1) >= ... >= s(r0) > TOL >= ... >= s(NL). C C The rank r of the approximation [A+DA|B+DB] is then equal C to the minimum of N and r0. C C Step 3: Let V2 be the matrix of the columns of V corresponding to C the (NL - r) smallest singular values of C, i.e. the last C (NL - r) columns of V. C Compute with Householder transformations the orthogonal C matrix Q such that: C C |VH Y| C V2 x Q = | | C |0 F| C C where VH is an N-by-(N - r) matrix, Y is an N-by-L matrix C and F is an L-by-L upper triangular matrix. C If F is singular, then lower the rank r with the C multiplicity of s(r) and repeat this step. C C Step 4: If F is nonsingular then the solution X is obtained by C solving the following equations by forward elimination: C C X F = -Y. C C Notes : C The TLS solution is unique if r = N, F is nonsingular and C s(N) > s(N+1). C If F is singular, however, then the computed solution is infinite C and hence does not satisfy the second TLS criterion (see TLS C definition). For these cases, Golub and Van Loan [1] claim that C the TLS problem has no solution. The properties of these so-called C nongeneric problems are described in [4] and the TLS computations C are generalized in order to solve them. As proven in [4], the C proposed generalization satisfies the TLS criteria for any C number L of observation vectors in B provided that, in addition, C the solution | X| is constrained to be orthogonal to all vectors C |-I| C of the form |w| which belong to the space generated by the columns C |0| C of the submatrix |Y|. C |F| C C REFERENCES C C [1] Golub, G.H. and Van Loan, C.F. C An Analysis of the Total Least-Squares Problem. C SIAM J. Numer. Anal., 17, pp. 883-893, 1980. C C [2] Staar, J., Vandewalle, J. and Wemans, M. C Realization of Truncated Impulse Response Sequences with C Prescribed Uncertainty. C Proc. 8th IFAC World Congress, Kyoto, I, pp. 7-12, 1981. C C [3] Van Huffel, S. C Analysis of the Total Least Squares Problem and its Use in C Parameter Estimation. C Doctoral dissertation, Dept. of Electr. Eng., Katholieke C Universiteit Leuven, Belgium, June 1987. C C [4] Van Huffel, S. and Vandewalle, J. C Analysis and Solution of the Nongeneric Total Least Squares C Problem. C SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988. C C [5] Van Huffel, S. and Vandewalle, J. C The Total Least Squares Problem: Computational Aspects and C Analysis. C Series "Frontiers in Applied Mathematics", Vol. 9, C SIAM, Philadelphia, 1991. C C NUMERICAL ASPECTS C C The algorithm consists in (backward) stable steps. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. C Supersedes Release 2.0 routine MB02AD by S. Van Huffel, Katholieke C University, Leuven, Belgium. C C REVISIONS C C June 24, 1997, Feb. 27, 2000, Oct. 19, 2003, Feb. 21, 2004, C June 13, 2012. C C KEYWORDS C C Least-squares approximation, singular subspace, singular value C decomposition, singular values, total least-squares. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION C(LDC,*), DWORK(*), S(*), X(LDX,*) C .. Local Scalars .. LOGICAL CRANK, CTOL, LJOBN, LJOBR, LJOBT, LQUERY INTEGER ITAU, J, JWORK, LDW, K, MINMNL, MINWRK, N1, NL, $ P, R1, WRKOPT DOUBLE PRECISION FNORM, RCOND, SMAX, TOLTMP C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE, DLANTR EXTERNAL DLAMCH, DLANGE, DLANTR, LSAME C .. External Subroutines .. EXTERNAL DGERQF, DGESVD, DLACPY, DLASET, DORMRQ, DSWAP, $ DTRCON, DTRSM, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C IWARN = 0 INFO = 0 NL = N + L K = MAX( M, NL ) P = MIN( M, N ) MINMNL = MIN( M, NL ) LDW = MAX( 3*MINMNL + K, 5*MINMNL ) LJOBR = LSAME( JOB, 'R' ) LJOBT = LSAME( JOB, 'T' ) LJOBN = LSAME( JOB, 'N' ) C C Determine whether RANK or/and TOL is/are to be computed. C CRANK = .NOT.LJOBT .AND. .NOT.LJOBN CTOL = .NOT.LJOBR .AND. .NOT.LJOBN C C Test the input scalar arguments. C IF( CTOL .AND. CRANK .AND. .NOT.LSAME( JOB, 'B' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( L.LT.0 ) THEN INFO = -4 ELSE IF( .NOT.CRANK .AND. RANK.GT.P ) THEN INFO = -5 ELSE IF( LDC.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( CTOL .AND. TOL.LT.ZERO ) THEN INFO = -11 ELSE IF( M.GE.NL ) THEN MINWRK = MAX( 2, LDW ) ELSE MINWRK = MAX( 2, M*NL + LDW, 3*L ) END IF WRKOPT = MINWRK LQUERY = LDWORK.EQ.-1 IF( LQUERY ) THEN IF ( M.GE.NL ) THEN CALL DGESVD( 'N', 'O', M, NL, C, LDC, S, DWORK, 1, DWORK, $ 1, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) ELSE CALL DGESVD( 'N', 'A', M, NL, DWORK, M, S, DWORK, 1, C, $ LDC, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) + M*NL ) END IF C IF ( L.GT.0 ) THEN CALL DGERQF( L, NL-1, C, LDC, DWORK, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + L ) CALL DORMRQ( 'R', 'T', N, NL-1, L, C, LDC, DWORK, C, LDC, $ DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + L ) END IF END IF IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -14 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB02MD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF ( CRANK ) $ RANK = P IF ( MIN( M, NL ).EQ.0 ) THEN IF ( M.EQ.0 ) THEN CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) END IF DWORK(1) = TWO DWORK(2) = ONE RETURN END IF C C Subroutine MB02MD solves a set of linear equations by a Total C Least Squares Approximation. C C Step 1: Compute part of the singular value decomposition (SVD) C USV' of C = [A |B ], namely compute S and V'. C M,N M,L 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 IF ( M.GE.NL ) THEN C C M >= N + L: Overwrite V' on C. C Workspace: need max(3*min(M,N+L) + max(M,N+L), 5*min(M,N+L)). C JWORK = 1 CALL DGESVD( 'No left vectors', 'Overwritten on C', M, NL, C, $ LDC, S, DWORK, 1, DWORK, 1, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) ELSE C C M < N + L: Save C in the workspace and compute V' in C. C Note that the previous DGESVD call cannot be used in this case. C Workspace: need M*(N+L) + max(3*min(M,N+L) + max(M,N+L), C 5*min(M,N+L)). C CALL DLACPY( 'Full', M, NL, C, LDC, DWORK, M ) JWORK = M*NL + 1 CALL DGESVD( 'No left vectors', 'All right vectors', M, NL, $ DWORK, M, S, DWORK, 1, C, LDC, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) END IF C IF ( INFO.GT.0 ) THEN C C Save the unconverged non-diagonal elements of the bidiagonal C matrix and exit. C DO 10 J = 1, MINMNL - 1 DWORK(J) = DWORK(JWORK+J) 10 CONTINUE C RETURN END IF WRKOPT = MAX( 2, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Transpose V' in-situ (in C). C DO 20 J = 2, NL CALL DSWAP( J-1, C(J,1), LDC, C(1,J), 1 ) 20 CONTINUE C C Step 2: Compute the rank of the approximation [A+DA|B+DB]. C IF ( CTOL ) THEN TOLTMP = SQRT( TWO*DBLE( K ) )*TOL SMAX = TOLTMP ELSE TOLTMP = TOL IF ( TOLTMP.LE.ZERO ) TOLTMP = DLAMCH( 'Precision' ) SMAX = MAX( TOLTMP*S(1), DLAMCH( 'Safe minimum' ) ) END IF C IF ( CRANK ) THEN C WHILE ( RANK .GT. 0 ) .AND. ( S(RANK) .LE. SMAX ) DO 40 IF ( RANK.GT.0 ) THEN IF ( S(RANK).LE.SMAX ) THEN RANK = RANK - 1 GO TO 40 END IF END IF C END WHILE 40 END IF C IF ( L.EQ.0 ) THEN DWORK(1) = WRKOPT DWORK(2) = ONE RETURN END IF C N1 = N + 1 ITAU = 1 JWORK = ITAU + L C C Step 3: Compute the orthogonal matrix Q and matrices F and Y C such that F is nonsingular. C C REPEAT C C Adjust the rank if S(RANK) has multiplicity greater than 1. C 60 CONTINUE R1 = RANK + 1 IF ( RANK.LT.MINMNL ) THEN C WHILE RANK.GT.0 .AND. S(RANK)**2 - S(R1)**2.LE.TOL**2 DO 80 IF ( RANK.GT.0 ) THEN IF ( ONE - ( S(R1)/S(RANK) )**2.LE.( TOLTMP/S(RANK) )**2 $ ) THEN RANK = RANK - 1 IWARN = 1 GO TO 80 END IF END IF C END WHILE 80 END IF C IF ( RANK.EQ.0 ) THEN C C Return zero solution. C CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) DWORK(1) = WRKOPT DWORK(2) = ONE RETURN END IF C C Compute the orthogonal matrix Q (in factorized form) and the C matrices F and Y using RQ factorization. It is assumed that, C generically, the last L rows of V2 matrix have full rank. C The code could not be the most efficient one when RANK has been C lowered, because the already created zero pattern of the last C L rows of V2 matrix is not exploited. C Workspace: need 2*L; prefer L + L*NB. C R1 = RANK + 1 CALL DGERQF( L, NL-RANK, C(N1,R1), LDC, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Workspace: need N+L; prefer L + N*NB. C CALL DORMRQ( 'Right', 'Transpose', N, NL-RANK, L, C(N1,R1), $ LDC, DWORK(ITAU), C(1,R1), LDC, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C CALL DLASET( 'Full', L, N-RANK, ZERO, ZERO, C(N1,R1), LDC ) IF ( L.GT.1 ) $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, C(N1+1,N1), $ LDC ) C C Estimate the reciprocal condition number of the matrix F, C and lower the rank if F can be considered as singular. C Workspace: need 3*L. C CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, C(N1,N1), LDC, $ RCOND, DWORK, IWORK, INFO ) WRKOPT = MAX( WRKOPT, 3*L ) C FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, C(N1,N1), $ LDC, DWORK ) IF ( RCOND.LE.TOLTMP*FNORM ) THEN RANK = RANK - 1 IWARN = 2 GO TO 60 ELSE IF ( FNORM.LE.TOLTMP*DLANGE( '1-norm', N, L, C(1,N1), LDC, $ DWORK ) ) THEN RANK = RANK - L IWARN = 2 GO TO 60 END IF C UNTIL ( F nonsingular, i.e., RCOND.GT.TOL*FNORM or C FNORM.GT.TOL*norm(Y) ) C C Step 4: Solve X F = -Y by forward elimination, C (F is upper triangular). C CALL DLACPY( 'Full', N, L, C(1,N1), LDC, X, LDX ) CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, $ -ONE, C(N1,N1), LDC, X, LDX ) C C Set the optimal workspace and reciprocal condition number of F. C DWORK(1) = WRKOPT DWORK(2) = RCOND C RETURN C *** Last line of MB02MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01WD.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01WD.f0000644000175000017500000002441515012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE MB01WD( DICO, UPLO, TRANS, HESS, N, ALPHA, BETA, R, $ LDR, A, LDA, T, LDT, INFO ) C C PURPOSE C C To compute the matrix formula C _ C R = alpha*( op( A )'*op( T )'*op( T ) + op( T )'*op( T )*op( A ) ) C + beta*R, (1) C C if DICO = 'C', or C _ C R = alpha*( op( A )'*op( T )'*op( T )*op( A ) - op( T )'*op( T )) C + beta*R, (2) C _ C if DICO = 'D', where alpha and beta are scalars, R, and R are C symmetric matrices, T is a triangular matrix, A is a general or C Hessenberg matrix, and op( M ) is one of C C op( M ) = M or op( M ) = M'. C C The result is overwritten on R. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the formula to be evaluated, as follows: C = 'C': formula (1), "continuous-time" case; C = 'D': formula (2), "discrete-time" case. C C UPLO CHARACTER*1 C Specifies which triangles of the symmetric matrix R and C triangular matrix T are given, as follows: C = 'U': the upper triangular parts of R and T are given; C = 'L': the lower triangular parts of R and T are given; C C TRANS CHARACTER*1 C Specifies the form of op( M ) to be used, as follows: C = 'N': op( M ) = M; C = 'T': op( M ) = M'; C = 'C': op( M ) = M'. C C HESS CHARACTER*1 C Specifies the form of the matrix A, as follows: C = 'F': matrix A is full; C = 'H': matrix A is Hessenberg (or Schur), either upper C (if UPLO = 'U'), or lower (if UPLO = 'L'). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices R, A, and T. N >= 0. C C ALPHA (input) DOUBLE PRECISION C The scalar alpha. When alpha is zero then the arrays A C and T are not referenced. C C BETA (input) DOUBLE PRECISION C The scalar beta. When beta is zero then the array R need C not be set before entry. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) C On entry with 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 R. C On entry with 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 R. C On exit, the leading N-by-N 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,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 matrix A. If HESS = 'H' the elements below the C first subdiagonal, if UPLO = 'U', or above the first C superdiagonal, if UPLO = 'L', need not be set to zero, C and are not referenced if DICO = 'D'. C On exit, the leading N-by-N part of this array contains C the following matrix product C alpha*T'*T*A, if TRANS = 'N', or C alpha*A*T*T', otherwise, C if DICO = 'C', or C T*A, if TRANS = 'N', or C A*T, otherwise, C if DICO = 'D' (and in this case, these products have a C Hessenberg form, if HESS = 'H'). C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C T (input) DOUBLE PRECISION array, dimension (LDT,N) C If UPLO = 'U', the leading N-by-N upper triangular part of C this array must contain the upper triangular matrix T and C the strictly lower triangular part need not be set to zero C (and it is not referenced). C If UPLO = 'L', the leading N-by-N lower triangular part of C this array must contain the lower triangular matrix T and C the strictly upper triangular part need not be set to zero C (and it is not referenced). C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,N). 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 (1) or (2) is efficiently evaluated taking C the structure into account. BLAS 3 operations (DTRMM, DSYRK and C their specializations) are used throughout. C C NUMERICAL ASPECTS C C If A is a full matrix, the algorithm requires approximately C 3 C N operations, if DICO = 'C'; C 3 C 7/6 x N operations, if DICO = 'D'. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. 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 DICO, HESS, TRANS, UPLO INTEGER INFO, LDA, LDR, LDT, N DOUBLE PRECISION ALPHA, BETA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), R(LDR,*), T(LDT,*) C .. Local Scalars .. LOGICAL DISCR, REDUC, TRANSP, UPPER CHARACTER NEGTRA, SIDE INTEGER I, INFO2, J C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLASCL, DLASET, DSYRK, DTRMM, MB01YD, MB01ZD, $ XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 DISCR = LSAME( DICO, 'D' ) UPPER = LSAME( UPLO, 'U' ) TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) REDUC = LSAME( HESS, 'H' ) C IF( .NOT.( DISCR .OR. LSAME( DICO, 'C' ) ) )THEN INFO = -1 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) )THEN INFO = -2 ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) )THEN INFO = -3 ELSE IF( .NOT.( REDUC .OR. LSAME( HESS, 'F' ) ) )THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -13 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01WD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C IF ( ALPHA.EQ.ZERO ) THEN IF ( BETA.EQ.ZERO ) THEN C C Special case when both alpha = 0 and beta = 0. C CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) ELSE C C Special case alpha = 0. C IF ( BETA.NE.ONE ) $ CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, R, LDR, INFO2 ) END IF RETURN END IF C C General case: alpha <> 0. C C Compute (in A) T*A, if TRANS = 'N', or C A*T, otherwise. C IF ( TRANSP ) THEN SIDE = 'R' NEGTRA = 'N' ELSE SIDE = 'L' NEGTRA = 'T' END IF C IF ( REDUC .AND. N.GT.2 ) THEN CALL MB01ZD( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, 1, $ ONE, T, LDT, A, LDA, INFO2 ) ELSE CALL DTRMM( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, ONE, $ T, LDT, A, LDA ) END IF C IF( .NOT.DISCR ) THEN C C Compute (in A) alpha*T'*T*A, if TRANS = 'N', or C alpha*A*T*T', otherwise. C IF ( REDUC .AND. N.GT.2 ) THEN CALL MB01ZD( SIDE, UPLO, 'Transpose', 'Non-unit', N, N, 1, $ ALPHA, T, LDT, A, LDA, INFO2 ) ELSE CALL DTRMM( SIDE, UPLO, 'Transpose', 'Non-unit', N, N, $ ALPHA, T, LDT, A, LDA ) END IF C C Compute the required triangle of the result, using symmetry. C IF ( UPPER ) THEN IF ( BETA.EQ.ZERO ) THEN C DO 20 J = 1, N DO 10 I = 1, J R( I, J ) = A( I, J ) + A( J, I ) 10 CONTINUE 20 CONTINUE C ELSE C DO 40 J = 1, N DO 30 I = 1, J R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J ) 30 CONTINUE 40 CONTINUE C END IF C ELSE C IF ( BETA.EQ.ZERO ) THEN C DO 60 J = 1, N DO 50 I = J, N R( I, J ) = A( I, J ) + A( J, I ) 50 CONTINUE 60 CONTINUE C ELSE C DO 80 J = 1, N DO 70 I = J, N R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J ) 70 CONTINUE 80 CONTINUE C END IF C END IF C ELSE C C Compute (in R) alpha*A'*T'*T*A + beta*R, if TRANS = 'N', or C alpha*A*T*T'*A' + beta*R, otherwise. C IF ( REDUC .AND. N.GT.2 ) THEN CALL MB01YD( UPLO, NEGTRA, N, N, 1, ALPHA, BETA, A, LDA, R, $ LDR, INFO2 ) ELSE CALL DSYRK( UPLO, NEGTRA, N, N, ALPHA, A, LDA, BETA, R, $ LDR ) END IF C C Compute (in R) -alpha*T'*T + R, if TRANS = 'N', or C -alpha*T*T' + R, otherwise. C CALL MB01YD( UPLO, NEGTRA, N, N, 0, -ALPHA, ONE, T, LDT, R, $ LDR, INFO2 ) C END IF C RETURN C *** Last line of MB01WD *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BW.f0000644000000000000000000000013015012430707016170 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/NF01BW.f0000644000175000017500000001544615012430707017400 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BW( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the matrix-vector product x <-- (J'*J + c*I)*x, for the C Jacobian J as received from SLICOT Library routine NF01BD: C C / dy(1)/dwb(1) | dy(1)/dtheta \ C Jc = | : | : | . C \ dy(L)/dwb(L) | dy(L)/dtheta / C C This is a compressed representation of the actual structure C C / J_1 0 .. 0 | L_1 \ C | 0 J_2 .. 0 | L_2 | C J = | : : .. : | : | . C | : : .. : | : | C \ 0 0 .. J_L | L_L / C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The dimension of the vector x. C N = BN*BSN + ST >= 0. (See parameter description below.) C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of the C matrix J, as follows: C IPAR(1) must contain ST, the number of parameters C corresponding to the linear part. ST >= 0. C IPAR(2) must contain BN, the number of blocks, BN = L, C for the parameters corresponding to the nonlinear C part. BN >= 0. C IPAR(3) must contain BSM, the number of rows of the blocks C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the C number of rows of the matrix J, if BN <= 1. C IPAR(4) must contain BSN, the number of columns of the C blocks J_k, k = 1:BN. BSN >= 0. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 4. C C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) C The real parameters needed for solving the problem. C The entry DPAR(1) must contain the real scalar c. C C LDPAR (input) INTEGER C The length of the array DPAR. LDPAR >= 1. C C J (input) DOUBLE PRECISION array, dimension (LDJ, NC) C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. C The leading NR-by-NC part of this array must contain C the (compressed) representation (Jc) of the Jacobian C matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM, C if BN > 1. C C LDJ (input) INTEGER C The leading dimension of array J. LDJ >= MAX(1,NR). C C X (input/output) DOUBLE PRECISION array, dimension C (1+(N-1)*INCX) C On entry, this incremented array must contain the C vector x. C On exit, this incremented array contains the value of the C matrix-vector product (J'*J + c*I)*x. C C INCX (input) INTEGER C The increment for the elements of X. INCX >= 1. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= NR. 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 associativity of matrix multiplications is used; the result C is obtained as: x_out = J'*( J*x ) + c*x. C C CONTRIBUTORS C C A. Riedel, R. Schneider, Chemnitz University of Technology, C Mar. 2001, during a stay at University of Twente, NL. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001, C Mar. 2002. C C KEYWORDS C C Elementary matrix operations, matrix algebra, matrix operations, C Wiener system. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N C .. Array Arguments .. DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), X(*) INTEGER IPAR(*) C .. Local Scalars .. INTEGER BN, BSM, BSN, IBSM, IBSN, IX, JL, M, NTHS, ST, $ XL DOUBLE PRECISION C C .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C INFO = 0 C IF ( N.LT.0 ) THEN INFO = -1 ELSEIF ( LIPAR.LT.4 ) THEN INFO = -3 ELSEIF ( LDPAR.LT.1 ) THEN INFO = -5 ELSEIF ( INCX.LT.1 ) THEN INFO = -9 ELSE ST = IPAR(1) BN = IPAR(2) BSM = IPAR(3) BSN = IPAR(4) NTHS = BN*BSN IF ( BN.GT.1 ) THEN M = BN*BSM ELSE M = BSM END IF IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN INFO = -2 ELSEIF ( N.NE.NTHS + ST ) THEN INFO = -1 ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN INFO = -7 ELSEIF ( LDWORK.LT.M ) THEN INFO = -11 END IF END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01BW', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C C = DPAR(1) C IF ( M.EQ.0 ) THEN C C Special case, void Jacobian: x <-- c*x. C CALL DSCAL( N, C, X, INCX ) RETURN END IF C IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN C C Special case, l <= 1 or BSN = 0: the Jacobian is represented C as a full matrix. Adapted code from NF01BX is included in-line. C CALL DGEMV( 'NoTranspose', M, N, ONE, J, LDJ, X, INCX, ZERO, $ DWORK, 1 ) CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, DWORK, 1, C, X, $ INCX ) RETURN END IF C C General case: l > 1, BSN > 0, BSM > 0. C JL = BSN + 1 IX = BSN*INCX XL = BN*IX + 1 C IF ( ST.GT.0 ) THEN CALL DGEMV( 'NoTranspose', M, ST, ONE, J(1,JL), LDJ, X(XL), $ INCX, ZERO, DWORK, 1 ) ELSE DWORK(1) = ZERO CALL DCOPY( M, DWORK(1), 0, DWORK, 1 ) END IF IBSN = 1 C DO 10 IBSM = 1, M, BSM CALL DGEMV( 'NoTranspose', BSM, BSN, ONE, J(IBSM,1), LDJ, $ X(IBSN), INCX, ONE, DWORK(IBSM), 1 ) CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1), LDJ, $ DWORK(IBSM), 1, C, X(IBSN), INCX ) IBSN = IBSN + IX 10 CONTINUE C IF ( ST.GT.0 ) $ CALL DGEMV( 'Transpose', M, ST, ONE, J(1,JL), LDJ, DWORK, 1, C, $ X(XL), INCX ) C RETURN C C *** Last line of NF01BW *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03QD.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03QD.f0000644000175000017500000005726415012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE SB03QD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To estimate the conditioning and compute an error bound on the C solution of the real continuous-time Lyapunov matrix equation C C op(A)'*X + X*op(A) = scale*C C C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The C matrix A is N-by-N, the right hand side C and the solution X are C N-by-N symmetric matrices, and scale is a given scale factor. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'C': Compute the reciprocal condition number only; C = 'E': Compute the error bound only; C = 'B': Compute both the reciprocal condition number and C the error bound. 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, T and U (if LYAPUN = 'O') contain the C factors from the real Schur factorization of the C matrix A; C = 'N': The Schur factorization of A will be computed C and the factors will be stored in T and U (if C LYAPUN = 'O'). 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 UPLO CHARACTER*1 C Specifies which part of the symmetric matrix C is to be C used, as follows: C = 'U': Upper triangular part; C = 'L': Lower triangular part. C C LYAPUN CHARACTER*1 C Specifies whether or not the original Lyapunov equations C should be solved in the iterative estimation process, C as follows: C = 'O': Solve the original Lyapunov equations, updating C the right-hand sides and solutions with the C matrix U, e.g., X <-- U'*X*U; C = 'R': Solve reduced Lyapunov equations only, without C updating the right-hand sides and solutions. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, X and C. N >= 0. C C SCALE (input) DOUBLE PRECISION C The scale factor, scale, set by a Lyapunov solver. C 0 <= SCALE <= 1. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of C this array must contain the original matrix A. C If FACT = 'F' and LYAPUN = 'R', A is not referenced. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O'; C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. C C T (input/output) DOUBLE PRECISION array, dimension C (LDT,N) C If FACT = 'F', then on entry the leading N-by-N upper C Hessenberg part of this array must contain the upper C quasi-triangular matrix T in Schur canonical form from a C Schur factorization of A. C If FACT = 'N', then this array need not be set on input. C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the C leading N-by-N upper Hessenberg part of this array C contains the upper quasi-triangular matrix T in Schur C canonical form from a Schur factorization of A. C C LDT INTEGER C The leading dimension of the array T. LDT >= MAX(1,N). C C U (input or output) DOUBLE PRECISION array, dimension C (LDU,N) C If LYAPUN = 'O' and FACT = 'F', then U is an input C argument and on entry, the leading N-by-N part of this C array must contain the orthogonal matrix U from a real C Schur factorization of A. C If LYAPUN = 'O' and FACT = 'N', then U is an output C argument and on exit, if INFO = 0 or INFO = N+1, it C contains the orthogonal N-by-N matrix from a real Schur C factorization of A. C If LYAPUN = 'R', the array U is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= 1, if LYAPUN = 'R'; C LDU >= MAX(1,N), if LYAPUN = 'O'. C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C If UPLO = 'U', the leading N-by-N upper triangular part of C this array must contain the upper triangular part of the C matrix C of the original Lyapunov equation (with C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov C equation (with matrix T), if LYAPUN = 'R'. C If UPLO = 'L', the leading N-by-N lower triangular part of C this array must contain the lower triangular part of the C matrix C of the original Lyapunov equation (with C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov C equation (with matrix T), if LYAPUN = 'R'. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,N). C C X (input) DOUBLE PRECISION array, dimension (LDX,N) C The leading N-by-N part of this array must contain the C symmetric solution matrix X of the original Lyapunov C equation (with matrix A), if LYAPUN = 'O', or of the C reduced Lyapunov equation (with matrix T), if C LYAPUN = 'R'. C C LDX INTEGER C The leading dimension of the array X. LDX >= MAX(1,N). C C SEP (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'B', the estimated quantity C sep(op(A),-op(A)'). C If N = 0, or X = 0, or JOB = 'E', SEP is not referenced. C C RCOND (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal C condition number of the continuous-time Lyapunov equation. C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. C If JOB = 'E', RCOND is not referenced. C C FERR (output) DOUBLE PRECISION C If JOB = 'E' or JOB = 'B', an estimated forward error C bound for the solution X. If XTRUE is the true solution, C FERR bounds the magnitude of the largest entry in C (X - XTRUE) divided by the magnitude of the largest entry C in X. C If N = 0 or X = 0, FERR is set to 0. C If JOB = 'C', FERR is not referenced. C C Workspace C C IWORK INTEGER array, dimension (N*N) 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 dimension of the array DWORK. C If JOB = 'C', then C LDWORK >= MAX(1,2*N*N), if FACT = 'F'; C LDWORK >= MAX(1,2*N*N,5*N), if FACT = 'N'. C If JOB = 'E', or JOB = 'B', and LYAPUN = 'O', then C LDWORK >= MAX(1,3*N*N), if FACT = 'F'; C LDWORK >= MAX(1,3*N*N,5*N), if FACT = 'N'. C If JOB = 'E', or JOB = 'B', and LYAPUN = 'R', then C LDWORK >= MAX(1,3*N*N+N-1), if FACT = 'F'; C LDWORK >= MAX(1,3*N*N+N-1,5*N), if FACT = 'N'. C For optimum performance LDWORK should sometimes 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 > 0: if INFO = i, i <= N, the QR algorithm failed to C complete the reduction to Schur canonical form (see C LAPACK Library routine DGEES); on exit, the matrix C T(i+1:N,i+1:N) contains the partially converged C Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N) C contain the real and imaginary parts, respectively, C of the converged eigenvalues; this error is unlikely C to appear; C = N+1: if the matrices T and -T' have common or very C close eigenvalues; perturbed values were used to C solve Lyapunov equations, but the matrix T, if given C (for FACT = 'F'), is unchanged. C C METHOD C C The condition number of the continuous-time Lyapunov equation is C estimated as C C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), C C where Omega and Theta are linear operators defined by C C Omega(W) = op(A)'*W + W*op(A), C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). C C The routine estimates the quantities C C sep(op(A),-op(A)') = 1 / norm(inv(Omega)) C C and norm(Theta) using 1-norm condition estimators. C C The forward error bound is estimated using a practical error bound C similar to the one proposed in [1]. C C REFERENCES C C [1] Higham, N.J. C Perturbation theory and backward error for AX-XB=C. C BIT, vol. 33, pp. 124-136, 1993. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C The accuracy of the estimates obtained depends on the solution C accuracy and on the properties of the 1-norm estimator. C C FURTHER COMMENTS C C The option LYAPUN = 'R' may occasionally produce slightly worse C or better estimates, and it is much faster than the option 'O'. C When SEP is computed and it is zero, the routine returns C immediately, with RCOND and FERR (if requested) set to 0 and 1, C respectively. In this case, the equation is singular. C C CONTRIBUTORS C C P. Petkov, Tech. University of Sofia, December 1998. C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, March 2003, July 2012. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D0, $ THREE = 3.0D0 ) C .. C .. Scalar Arguments .. CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N DOUBLE PRECISION FERR, RCOND, SCALE, SEP C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), $ T( LDT, * ), U( LDU, * ), X( LDX, * ) C .. C .. Local Scalars .. LOGICAL JOBB, JOBC, JOBE, LOWER, LQUERY, NOFACT, $ NOTRNA, UPDATE CHARACTER SJOB, TRANAT INTEGER I, IABS, IRES, IWRK, IXBS, J, JJ, JX, LDW, NN, $ SDIM, WRKOPT DOUBLE PRECISION ANORM, CNORM, DENOM, EPS, EPSN, TEMP, THNORM, $ TMAX, XANORM, XNORM C .. C .. Local Arrays .. LOGICAL BWORK( 1 ) C .. C .. External Functions .. LOGICAL LSAME, SELECT DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT C .. C .. External Subroutines .. EXTERNAL DAXPY, DGEES, DLACPY, DLASET, DSYR2K, MB01UD, $ MB01UW, SB03QX, SB03QY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C C Decode and Test input parameters. C JOBC = LSAME( JOB, 'C' ) JOBE = LSAME( JOB, 'E' ) JOBB = LSAME( JOB, 'B' ) NOFACT = LSAME( FACT, 'N' ) NOTRNA = LSAME( TRANA, 'N' ) LOWER = LSAME( UPLO, 'L' ) UPDATE = LSAME( LYAPUN, 'O' ) C NN = N*N IF( JOBC ) THEN LDW = 2*NN ELSE LDW = 3*NN END IF IF( .NOT.( JOBC .OR. UPDATE ) ) $ LDW = LDW + N - 1 C INFO = 0 IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN INFO = -1 ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. $ LSAME( TRANA, 'C' ) ) ) THEN INFO = -3 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -4 ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) THEN INFO = -7 ELSE IF( LDA.LT.1 .OR. $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN INFO = -9 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( NOFACT ) THEN IWRK = MAX( LDW, 5*N ) ELSE IWRK = LDW END IF IWRK = MAX( 1, IWRK ) LQUERY = LDWORK.EQ.-1 IF( UPDATE ) THEN SJOB = 'V' ELSE SJOB = 'N' END IF IF( LQUERY ) THEN IF( NOFACT ) THEN CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK, DWORK, U, LDU, DWORK, -1, BWORK, INFO) WRKOPT = MAX( IWRK, INT( DWORK( 1 ) ) + 2*N ) ELSE WRKOPT = IWRK END IF IF( .NOT.UPDATE ) $ WRKOPT = MAX( WRKOPT, 4*N*N ) END IF IF( LDWORK.LT.IWRK .AND. .NOT. LQUERY ) $ INFO = -23 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03QD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK( 1 ) = WRKOPT RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IF( .NOT.JOBE ) $ RCOND = ONE IF( .NOT.JOBC ) $ FERR = ZERO DWORK( 1 ) = ONE RETURN END IF C C Compute the 1-norm of the matrix X. C XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) IF( XNORM.EQ.ZERO ) THEN C C The solution is zero. C IF( .NOT.JOBE ) $ RCOND = ZERO IF( .NOT.JOBC ) $ FERR = ZERO DWORK( 1 ) = DBLE( N ) RETURN END IF C C Compute the 1-norm of A or T. C IF( NOFACT .OR. UPDATE ) THEN ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) ELSE ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) END IF C C For the special case A = 0, set SEP and RCOND to 0. C For the special case A = I, set SEP to 2 and RCOND to 1. C A quick test is used in general. C IF( ANORM.EQ.ONE ) THEN IF( NOFACT .OR. UPDATE ) THEN CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) ELSE CALL DLACPY( 'Full', N, N, T, LDT, DWORK, N ) IF( N.GT.2 ) $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK( 3 ), $ N ) END IF DWORK( NN+1 ) = ONE CALL DAXPY( N, -ONE, DWORK( NN+1 ), 0, DWORK, N+1 ) IF( DLANGE( 'Max', N, N, DWORK, N, DWORK ).EQ.ZERO ) THEN IF( .NOT.JOBE ) THEN SEP = TWO RCOND = ONE END IF IF( JOBC ) THEN DWORK( 1 ) = DBLE( NN + 1 ) RETURN ELSE C C Set FERR for the special case A = I. C CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) C IF( LOWER ) THEN DO 10 J = 1, N CALL DAXPY( N-J+1, -SCALE/TWO, C( J, J ), 1, $ DWORK( (J-1)*N+J ), 1 ) 10 CONTINUE ELSE DO 20 J = 1, N CALL DAXPY( J, -SCALE/TWO, C( 1, J ), 1, $ DWORK( (J-1)*N+1 ), 1 ) 20 CONTINUE END IF C FERR = MIN( ONE, DLANSY( '1-norm', UPLO, N, DWORK, N, $ DWORK( NN+1 ) ) / XNORM ) DWORK( 1 ) = DBLE( NN + N ) RETURN END IF END IF C ELSE IF( ANORM.EQ.ZERO ) THEN IF( .NOT.JOBE ) THEN SEP = ZERO RCOND = ZERO END IF IF( .NOT.JOBC ) $ FERR = ONE DWORK( 1 ) = DBLE( N ) RETURN END IF C C General case. C CNORM = DLANSY( '1-norm', UPLO, N, C, LDC, DWORK ) C C Workspace usage. C IABS = 0 IXBS = IABS + NN IRES = IXBS + NN IWRK = IRES + NN WRKOPT = 0 C IF( NOFACT ) THEN C C Compute the Schur factorization of A, A = U*T*U'. C Workspace: need 5*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 CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK( 1 ), DWORK( N+1 ), U, LDU, DWORK( 2*N+1 ), $ LDWORK-2*N, BWORK, INFO ) IF( INFO.GT.0 ) $ RETURN WRKOPT = INT( DWORK( 2*N+1 ) ) + 2*N END IF C IF( .NOT.JOBE ) THEN C C Estimate sep(op(A),-op(A)') = sep(op(T),-op(T)') and C norm(Theta). C Workspace 2*N*N. C CALL SB03QY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) C WRKOPT = MAX( WRKOPT, 2*NN ) C C Return if the equation is singular. C IF( SEP.EQ.ZERO ) THEN RCOND = ZERO IF( JOBB ) $ FERR = ONE DWORK( 1 ) = DBLE( WRKOPT ) RETURN END IF C C Estimate the reciprocal condition number. C TMAX = MAX( SEP, XNORM, ANORM ) IF( TMAX.LE.ONE ) THEN TEMP = SEP*XNORM DENOM = ( SCALE*CNORM ) + ( SEP*ANORM )*THNORM ELSE TEMP = ( SEP / TMAX )*( XNORM / TMAX ) DENOM = ( ( SCALE / TMAX )*( CNORM / TMAX ) ) + $ ( ( SEP / TMAX )*( ANORM / TMAX ) )*THNORM END IF IF( TEMP.GE.DENOM ) THEN RCOND = ONE ELSE RCOND = TEMP / DENOM END IF END IF C IF( .NOT.JOBC ) THEN C C Form a triangle of the residual matrix C R = op(A)'*X + X*op(A) - scale*C, or C R = op(T)'*X + X*op(T) - scale*C, C exploiting the symmetry. C Workspace 3*N*N. C IF( NOTRNA ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF C IF( UPDATE ) THEN C CALL DLACPY( UPLO, N, N, C, LDC, DWORK( IRES+1 ), N ) CALL DSYR2K( UPLO, TRANAT, N, N, ONE, A, LDA, X, LDX, $ -SCALE, DWORK( IRES+1 ), N ) ELSE CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, $ DWORK( IRES+1 ), N, INFO ) JJ = IRES + 1 IF( LOWER ) THEN DO 30 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK( JJ ), N, DWORK( JJ ), $ 1 ) CALL DAXPY( N-J+1, -SCALE, C( J, J ), 1, DWORK( JJ ), $ 1 ) JJ = JJ + N + 1 30 CONTINUE ELSE DO 40 J = 1, N CALL DAXPY( J, ONE, DWORK( IRES+J ), N, DWORK( JJ ), $ 1 ) CALL DAXPY( J, -SCALE, C( 1, J ), 1, DWORK( JJ ), 1 ) JJ = JJ + N 40 CONTINUE END IF END IF C WRKOPT = MAX( WRKOPT, 3*NN ) C C Get the machine precision. C EPS = DLAMCH( 'Epsilon' ) EPSN = EPS*DBLE( N + 3 ) TEMP = EPS*THREE*SCALE C C Add to abs(R) a term that takes account of rounding errors in C forming R: C abs(R) := abs(R) + EPS*(3*scale*abs(C) + C (n+3)*(abs(op(A))'*abs(X) + abs(X)*abs(op(A)))), or C abs(R) := abs(R) + EPS*(3*scale*abs(C) + C (n+3)*(abs(op(T))'*abs(X) + abs(X)*abs(op(T)))), C where EPS is the machine precision. C DO 60 J = 1, N DO 50 I = 1, N DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) 50 CONTINUE 60 CONTINUE C IF( LOWER ) THEN DO 80 J = 1, N DO 70 I = J, N DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( C( I, J ) ) + $ ABS( DWORK( IRES+(J-1)*N+I ) ) 70 CONTINUE 80 CONTINUE ELSE DO 100 J = 1, N DO 90 I = 1, J DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( C( I, J ) ) + $ ABS( DWORK( IRES+(J-1)*N+I ) ) 90 CONTINUE 100 CONTINUE END IF C IF( UPDATE ) THEN C C Workspace 3*N*N. C DO 120 J = 1, N DO 110 I = 1, N DWORK( IABS+(J-1)*N+I ) = ABS( A( I, J ) ) 110 CONTINUE 120 CONTINUE C CALL DSYR2K( UPLO, TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, $ DWORK( IXBS+1 ), N, ONE, DWORK( IRES+1 ), N ) ELSE C C Workspace 3*N*N + N - 1. C DO 140 J = 1, N DO 130 I = 1, MIN( J+1, N ) DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) 130 CONTINUE 140 CONTINUE C CALL MB01UW( 'Left', TRANAT, N, N, EPSN, DWORK( IABS+1 ), $ N, DWORK( IXBS+1), N, DWORK( IWRK+1 ), $ LDWORK-IWRK, INFO ) JJ = IRES + 1 JX = IXBS + 1 IF( LOWER ) THEN DO 150 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK( JX ), N, DWORK( JX ), $ 1 ) CALL DAXPY( N-J+1, ONE, DWORK( JX ), 1, DWORK( JJ ), $ 1 ) JJ = JJ + N + 1 JX = JX + N + 1 150 CONTINUE ELSE DO 160 J = 1, N CALL DAXPY( J, ONE, DWORK( IXBS+J ), N, DWORK( JX ), $ 1 ) CALL DAXPY( J, ONE, DWORK( JX ), 1, DWORK( JJ ), 1 ) JJ = JJ + N JX = JX + N 160 CONTINUE END IF C WRKOPT = MAX( WRKOPT, 3*NN + N - 1 ) END IF C C Compute forward error bound, using matrix norm estimator. C Workspace 3*N*N. C XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) C CALL SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, $ INFO ) END IF C DWORK( 1 ) = DBLE( WRKOPT ) RETURN C C *** Last line of SB03QD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB08MD.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB08MD.f0000644000175000017500000003375415012430707017402 0ustar00lilgelilge00000000000000 SUBROUTINE SB08MD( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute a real polynomial E(s) such that C C (a) E(-s) * E(s) = A(-s) * A(s) and C (b) E(s) is stable - that is, all the zeros of E(s) have C non-positive real parts, C C which corresponds to computing the spectral factorization of the C real polynomial A(s) arising from continuous optimality problems. C C The input polynomial may be supplied either in the form C C A(s) = a(0) + a(1) * s + ... + a(DA) * s**DA C C or as C C B(s) = A(-s) * A(s) C = b(0) + b(1) * s**2 + ... + b(DA) * s**(2*DA) (1) C C ARGUMENTS C C Mode Parameters C C ACONA CHARACTER*1 C Indicates whether the coefficients of A(s) or B(s) = C A(-s) * A(s) are to be supplied as follows: C = 'A': The coefficients of A(s) are to be supplied; C = 'B': The coefficients of B(s) are to be supplied. C C Input/Output Parameters C C DA (input) INTEGER C The degree of the polynomials A(s) and E(s). DA >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (DA+1) C On entry, this array must contain either the coefficients C of the polynomial A(s) in increasing powers of s if C ACONA = 'A', or the coefficients of the polynomial B(s) in C increasing powers of s**2 (see equation (1)) if ACONA = C 'B'. C On exit, this array contains the coefficients of the C polynomial B(s) in increasing powers of s**2. C C RES (output) DOUBLE PRECISION C An estimate of the accuracy with which the coefficients of C the polynomial E(s) have been computed (see also METHOD C and NUMERICAL ASPECTS). C C E (output) DOUBLE PRECISION array, dimension (DA+1) C The coefficients of the spectral factor E(s) in increasing C powers of s. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 5*DA+5. 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 on entry, A(I) = 0.0, for I = 1,2,...,DA+1. C = 2: if on entry, ACONA = 'B' but the supplied C coefficients of the polynomial B(s) are not the C coefficients of A(-s) * A(s) for some real A(s); C in this case, RES and E are unassigned; C = 3: if the iterative process (see METHOD) has failed to C converge in 30 iterations; C = 4: if the last computed iterate (see METHOD) is C unstable. If ACONA = 'B', then the supplied C coefficients of the polynomial B(s) may not be the C coefficients of A(-s) * A(s) for some real A(s). C C METHOD C _ _ C Let A(s) be the conjugate polynomial of A(s), i.e., A(s) = A(-s). C C The method used by the routine is based on applying the C Newton-Raphson iteration to the function C _ _ C F(e) = A * A - e * e, C C which leads to the iteration formulae (see [1]): C C _(i) (i) _(i) (i) _ ) C q * x + x * q = 2 A * A ) C ) for i = 0, 1, 2,... C (i+1) (i) (i) ) C q = (q + x )/2 ) C C (0) DA C Starting from q = (1 + s) (which has no zeros in the closed C (1) (2) (3) C right half-plane), the sequence of iterates q , q , q ,... C converges to a solution of F(e) = 0 which has no zeros in the C open right half-plane. C C The iterates satisfy the following conditions: C C (i) C (a) q is a stable polynomial (no zeros in the closed right C half-plane) and C C (i) (i-1) C (b) q (1) <= q (1). C C (i-1) (i) C The iterative process stops with q , (where i <= 30) if q C violates either (a) or (b), or if the condition C _(i) (i) _ C (c) RES = ||(q q - A A)|| < tol, C C is satisfied, where || . || denotes the largest coefficient of C _(i) (i) _ C the polynomial (q q - A A) and tol is an estimate of the C _(i) (i) C rounding error in the computed coefficients of q q . If there C is no convergence after 30 iterations then the routine returns C with the Error Indicator (INFO) set to 3, and the value of RES may C indicate whether or not the last computed iterate is close to the C solution. C C If ACONA = 'B', then it is possible that the equation e(-s) * C e(s) = B(s) has no real solution, which will be the case if A(1) C < 0 or if ( -1)**DA * A(DA+1) < 0. C C REFERENCES C C [1] Vostry, Z. C New Algorithm for Polynomial Spectral Factorization with C Quadratic Convergence II. C Kybernetika, 12, pp. 248-259, 1976. C C NUMERICAL ASPECTS C C The conditioning of the problem depends upon the distance of the C zeros of A(s) from the imaginary axis and on their multiplicity. C For a well-conditioned problem the accuracy of the computed C coefficients of E(s) is of the order of RES. However, for problems C with zeros near the imaginary axis or with multiple zeros, the C value of RES may be an overestimate of the true accuracy. C C FURTHER COMMENTS C C In order for the problem e(-s) * e(s) = B(s) to have a real C solution e(s), it is necessary and sufficient that B(j*omega) C >= 0 for any purely imaginary argument j*omega (see [1]). C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB08AD by A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Factorization, Laplace transform, optimal control, optimal C filtering, polynomial operations, spectral factorization, zeros. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER ACONA INTEGER DA, INFO, LDWORK DOUBLE PRECISION RES C .. Array Arguments .. DOUBLE PRECISION A(*), DWORK(*), E(*) C .. Local Scalars .. LOGICAL CONV, LACONA, STABLE INTEGER BINC, DA1, I, I0, J, K, LAMBDA, LAY, LAYEND, $ LDIF, LPHEND, LPHI, LQ, M, NC DOUBLE PRECISION A0, EPS, MU, MUJ, SI, SIGNI, SIGNI0, SIGNJ, $ SIMIN1, SQRTA0, SQRTMJ, SQRTMU, TOLPHI, W, XDA C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, SB08MY, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MOD, SQRT C .. Executable Statements .. C INFO = 0 LACONA = LSAME( ACONA, 'A' ) C C Test the input scalar arguments. C IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN INFO = -1 ELSE IF( DA.LT.0 ) THEN INFO = -2 ELSE IF( LDWORK.LT.5*DA + 5 ) THEN INFO = -7 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB08MD', -INFO ) RETURN END IF C IF ( .NOT.LACONA ) THEN CALL DCOPY( DA+1, A, 1, E, 1 ) ELSE W = ZERO CALL SB08MY( DA, A, E, W ) END IF C C Reduce E such that the first and the last element are non-zero. C DA1 = DA + 1 C C WHILE ( DA1 >= 1 and E(DA1) = 0 ) DO 20 IF ( DA1.GE.1 ) THEN IF ( E(DA1).EQ.ZERO ) THEN DA1 = DA1 - 1 GO TO 20 END IF END IF C END WHILE 20 C DA1 = DA1 - 1 IF ( DA1.LT.0 ) THEN INFO = 1 RETURN END IF C I0 = 1 C C WHILE ( E(I0) = 0 ) DO 40 IF ( E(I0).EQ.ZERO ) THEN I0 = I0 + 1 GO TO 40 END IF C END WHILE 40 C I0 = I0 - 1 IF ( I0.NE.0 ) THEN IF ( MOD( I0, 2 ).EQ.0 ) THEN SIGNI0 = ONE ELSE SIGNI0 = -ONE END IF C DO 60 I = 1, DA1 - I0 + 1 E(I) = SIGNI0*E(I+I0) 60 CONTINUE C DA1 = DA1 - I0 END IF IF ( MOD( DA1, 2 ).EQ.0 ) THEN SIGNI = ONE ELSE SIGNI = -ONE END IF NC = DA1 + 1 IF ( ( E(1).LT.ZERO ) .OR. ( ( E(NC)*SIGNI ).LT.ZERO ) ) THEN INFO = 2 RETURN END IF C C Initialization. C EPS = DLAMCH( 'Epsilon' ) SI = ONE/DLAMCH( 'Safe minimum' ) LQ = 1 LAY = LQ + NC LAMBDA = LAY + NC LPHI = LAMBDA + NC LDIF = LPHI + NC C A0 = E(1) BINC = 1 C C Computation of the starting polynomial and scaling of the input C polynomial. C MU = ( A0/ABS( E(NC) ) )**( ONE/DBLE( DA1 ) ) MUJ = ONE C DO 80 J = 1, NC W = E(J)*MUJ/A0 A(J) = W E(J) = BINC DWORK(LQ+J-1) = BINC MUJ = MUJ*MU BINC = BINC*( NC - J )/J 80 CONTINUE C CONV = .FALSE. STABLE = .TRUE. C C The contents of the arrays is, cf [1], C C E : the last computed stable polynomial q ; C i-1 C DWORK(LAY+1,...,LAY+DA1-1) : a'(1), ..., a'(DA1-1), these values C are changed during the computation C into y; C (LAMBDA+1,...,LAMBDA+DA1-2) : lambda(1), ..., lambda(DA1-2), C the factors of the Routh C stability test, (lambda(i) is C P(i) in [1]); C (LPHI+1,...,LPHI+DA1-1) : phi(1), ..., phi(DA1-1), the values C phi(i,j), see [1], scheme (11); C (LDIF,...,LDIF+DA1) : the coeffs of q (-s) * q (s) - b(s). C i i C DWORK(LQ,...,LQ+DA1) : the last computed polynomial q . C i I = 0 C C WHILE ( I < 30 and CONV = FALSE and STABLE = TRUE ) DO 100 IF ( I.LT.30 .AND. .NOT.CONV .AND. STABLE ) THEN I = I + 1 CALL DCOPY( NC, A, 1, DWORK(LAY), 1 ) CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LPHI), 1 ) M = DA1/2 LAYEND = LAY + DA1 LPHEND = LPHI + DA1 XDA = A(NC)/DWORK(LQ+DA1) C DO 120 K = 1, M DWORK(LAY+K) = DWORK(LAY+K) - DWORK(LPHI+2*K) DWORK(LAYEND-K) = DWORK(LAYEND-K) - DWORK(LPHEND-2*K)*XDA 120 CONTINUE C C Computation of lambda(k) and y(k). C K = 1 C C WHILE ( K <= DA1 - 2 and STABLE = TRUE ) DO 140 IF ( ( K.LE.( DA1 - 2 ) ) .AND. STABLE ) THEN IF ( DWORK(LPHI+K).LE.ZERO ) STABLE = .FALSE. IF ( STABLE ) THEN W = DWORK(LPHI+K-1)/DWORK(LPHI+K) DWORK(LAMBDA+K) = W CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2, $ DWORK(LPHI+K+1), 2 ) W = DWORK(LAY+K)/DWORK(LPHI+K) DWORK(LAY+K) = W CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2, $ DWORK(LAY+K+1), 1 ) K = K + 1 END IF GO TO 140 END IF C END WHILE 140 C IF ( DWORK(LPHI+DA1-1).LE.ZERO ) THEN STABLE = .FALSE. ELSE DWORK(LAY+DA1-1) = DWORK(LAY+DA1-1)/DWORK(LPHI+DA1-1) END IF C C STABLE = The polynomial q is stable. C i-1 IF ( STABLE ) THEN C C Computation of x and q . C i i C DO 160 K = DA1 - 2, 1, -1 W = DWORK(LAMBDA+K) CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LAY+K+1), 2, $ DWORK(LAY+K), 2 ) 160 CONTINUE C DWORK(LAY+DA1) = XDA C CALL DCOPY( NC, DWORK(LQ), 1, E, 1 ) SIMIN1 = SI SI = DWORK(LQ) SIGNJ = -ONE C DO 180 J = 1, DA1 W = HALF*( DWORK(LQ+J) + SIGNJ*DWORK(LAY+J) ) DWORK(LQ+J) = W SI = SI + W SIGNJ = -SIGNJ 180 CONTINUE C TOLPHI = EPS CALL SB08MY( DA1, E, DWORK(LDIF), TOLPHI ) CALL DAXPY( NC, -ONE, A, 1, DWORK(LDIF), 1 ) RES = ABS( DWORK( IDAMAX( NC, DWORK(LDIF), 1 ) + LDIF-1 ) ) C C Convergency test. C IF ( ( SI.GT.SIMIN1 ) .OR. ( RES.LT.TOLPHI ) ) THEN CONV = .TRUE. END IF GO TO 100 END IF END IF C END WHILE 100 C C Backscaling. C MU = ONE/MU SQRTA0 = SQRT( A0 ) SQRTMU = SQRT( MU ) MUJ = ONE SQRTMJ = ONE C DO 200 J = 1, NC E(J) = E(J)*SQRTA0*SQRTMJ A(J) = A(J)*A0*MUJ MUJ = MUJ*MU SQRTMJ = SQRTMJ*SQRTMU 200 CONTINUE C IF ( I0.NE.0 ) THEN C DO 220 J = NC, 1, -1 E(I0+J) = E(J) A(I0+J) = SIGNI0*A(J) 220 CONTINUE C DO 240 J = 1, I0 E(J) = ZERO A(J) = ZERO 240 CONTINUE C END IF C IF ( .NOT.CONV ) THEN IF ( STABLE ) THEN INFO = 3 ELSE INFO = 4 END IF END IF C RETURN C *** Last line of SB08MD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01HY.f0000644000000000000000000000013215012430707016211 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01HY.f0000644000175000017500000007607415012430707017423 0ustar00lilgelilge00000000000000 SUBROUTINE TG01HY( COMPQ, COMPZ, L, N, M, P, N1, LBE, A, LDA, $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, $ NRBLCK, RTAU, TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C Given the descriptor system (A-lambda*E,B,C) with the system C matrices A, E and B of the form C C ( A1 X1 ) ( E1 Y1 ) ( B1 ) C A = ( ) , E = ( ) , B = ( ) , C ( 0 X2 ) ( 0 Y2 ) ( 0 ) C C where C - B is an L-by-M matrix, with B1 an N1-by-M submatrix, C - A is an L-by-N matrix, with A1 an N1-by-N1 submatrix, C - E is an L-by-N matrix, with E1 an N1-by-N1 submatrix C with LBE nonzero sub-diagonals, C this routine reduces the pair (A1-lambda*E1,B1) to the form C C Qc'*[ B1 A1-lambda*E1 ]*diag(I,Zc) = C C ( Bc Ac-lambda*Ec * ) C ( ) , C ( 0 0 Anc-lambda*Enc ) C C where: C 1) the pencil ( Bc Ac-lambda*Ec ) has full row rank NR for C all finite lambda and is in a staircase form with C _ _ _ _ C ( A1,0 A1,1 ... A1,k-1 A1,k ) C ( _ _ _ ) C ( Bc Ac ) = ( 0 A2,1 ... A2,k-1 A2,k ) , (1) C ( ... _ _ ) C ( 0 0 ... Ak,k-1 Ak,k ) C C _ _ _ C ( E1,1 ... E1,k-1 E1,k ) C ( _ _ ) C Ec = ( 0 ... E2,k-1 E2,k ) , (2) C ( ... _ ) C ( 0 ... 0 Ek,k ) C _ C where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank C _ C matrix (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i) C upper triangular matrix. C C 2) the pencil Anc-lambda*Enc is regular of order N1-NR with Enc C upper triangular; this pencil contains the uncontrollable C finite eigenvalues of the pencil (A1-lambda*E1). C C The transformations are applied to the whole matrices A, E, B C and C. The left and/or right orthogonal transformations Qc and Zc, C performed to reduce the pencil, can be optionally accumulated in C the matrices Q and Z, respectively. C C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has no C uncontrollable finite eigenvalues and has the same transfer- C function matrix as the original system (A-lambda*E,B,C). C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C = 'N': do not compute Q; C = 'I': Q is initialized to the unit matrix, and the C orthogonal matrix Q is returned; C = 'U': Q must contain an orthogonal matrix Q1 on entry, C and the product Q1*Q is returned. C C COMPZ CHARACTER*1 C = 'N': do not compute Z; C = 'I': Z is initialized to the unit matrix, and the C orthogonal matrix Z is returned; C = 'U': Z must contain an orthogonal matrix Z1 on entry, C and the product Z1*Z is returned. C C Input/Output Parameters C C L (input) INTEGER C The number of descriptor state equations; also the number C of rows of the matrices A, E and B. L >= 0. C C N (input) INTEGER C The dimension of the descriptor state vector; also the C number of columns of the matrices A, E and C. N >= 0. C C M (input) INTEGER C The dimension of descriptor system input vector; also the C number of columns of the matrix B. M >= 0. C C P (input) INTEGER C The dimension of descriptor system output; also the C number of rows of the matrix C. P >= 0. C C N1 (input) INTEGER C The order of the subsystem (A1-lambda*E1,B1,C1) to be C reduced. MIN(L,N) >= N1 >= 0. C C LBE (input) INTEGER C The number of nonzero sub-diagonals of the submatrix E1. C MAX(0,N1-1) >= LBE >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the L-by-N state matrix A in the partitioned form C C ( A1 X1 ) C A = ( ) , C ( 0 X2 ) C C where A1 is N1-by-N1. C On exit, the leading L-by-N part of this array contains C the transformed state matrix, C C ( Ac * * ) C Qc'*A*diag(Zc,I) = ( 0 Anc * ) , C ( 0 0 * ) C C where Ac is NR-by-NR and Anc is (N1-NR)-by-(N1-NR). C The matrix ( Bc Ac ) is in the controllability staircase C form (1). C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,L). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the L-by-N descriptor matrix E in the partitioned C form C ( E1 Y1 ) C E = ( ) , C ( 0 Y2 ) C C where E1 is an N1-by-N1 matrix with LBE nonzero C sub-diagonals. C On exit, the leading L-by-N part of this array contains C the transformed descriptor matrix C C ( Ec * * ) C Qc'*E*diag(Zc,I) = ( 0 Enc * ) , C ( 0 0 * ) C C where Ec is NR-by-NR and Enc is (N1-NR)-by-(N1-NR). C Both Ec and Enc are upper triangular. C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,L). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, the leading L-by-M part of this array must C contain the L-by-M input matrix B in the partitioned form C C ( B1 ) C B = ( ) , C ( 0 ) C C where B1 is N1-by-M. C On exit, the leading L-by-M part of this array contains C the transformed input matrix C C ( Bc ) C Qc'*B = ( ) , C ( 0 ) C C where Bc is NR-by-M. C The matrix ( Bc Ac ) is in the controllability staircase C form (1). C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,L). 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Zc. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) C If COMPQ = 'N': Q is not referenced. C If COMPQ = 'I': on entry, Q need not be set; C on exit, the leading L-by-L part of this C array contains the orthogonal matrix Qc, C where Qc' is the product of the C transformations applied to A, E, and B on C the left. C If COMPQ = 'U': on entry, the leading L-by-L part of this C array must contain an orthogonal matrix Q; C on exit, the leading L-by-L part of this C array contains the orthogonal matrix C Q*Qc. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C If COMPZ = 'N': Z is not referenced. C If COMPZ = 'I': on entry, Z need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Zc, C i.e., the product of the transformations C applied to A, E, and C on the right. C If COMPZ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix Z; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Z*Zc. C C LDZ INTEGER C The leading dimension of the array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. C C NR (output) INTEGER C The order of the reduced matrices Ac and Ec, and the C number of rows of the reduced matrix Bc; also the order of C the controllable part of the pair (B, A-lambda*E). C C NRBLCK (output) INTEGER _ C The number k, of full row rank blocks Ai,i in the C staircase form of the pencil (Bc Ac-lambda*Ec) (see (1) C and (2)). C C RTAU (output) INTEGER array, dimension (N1) C RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of C _ C the full row rank block Ai,i-1 in the staircase form (1). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determinations when C transforming (A-lambda*E, B). If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C reciprocal condition numbers in rank determinations; a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = L*N*EPS, is used instead, where C EPS is the machine precision (see LAPACK Library routine C DLAMCH). TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (M) 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,N,L,2*(M+N1-1)) C For good performance, LDWORK should be generally 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 subroutine is based on the reduction algorithm of [1]. C If suitable, it uses block algorithms for the reduction of the C matrix E and for the corresponding updates of the matrices A, B, C and Q. Moreover, for large systems, the row transformations are C applied on panels of columns of the matrices A, B, and E. C C REFERENCES C C [1] Varga, A. C Computation of Irreducible Generalized State-Space C Realizations. C Kybernetika, vol. 26, pp. 89-106, 1990. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N*N1**2 ) floating point operations. C C FURTHER COMMENTS C C If INFO > 0 on entry, that value is used as block size for the C block algorithms. Otherwise, the block size is chosen internally. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2012. C Based on SLICOT Library routine TG01HX, by A. Varga. C C REVISIONS C C V. Sima, Feb. 2012, April 2012, June 2012, Dec. 2016, Apr. 2017, C Mar. 2019. C C KEYWORDS C C Controllability, minimal realization, orthogonal canonical form, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. INTEGER IMAX, IMIN PARAMETER ( IMAX = 1, IMIN = 2 ) DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER COMPQ, COMPZ INTEGER INFO, L, LBE, LDA, LDB, LDC, LDE, LDQ, LDWORK, $ LDZ, M, N, N1, NR, NRBLCK, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK( * ), RTAU( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), $ Z( LDZ, * ) C .. Local Scalars .. LOGICAL ILQ, ILZ, LQUERY, ONECOL, OPB, UB, UPDB, WITHC INTEGER I, IB, IC, ICOL, ICOMPQ, ICOMPZ, IR, IROT, $ IROW, ISMAX, ISMIN, J, JB, K, KB, LB, MAXWRK, $ MINWRK, MN, NB, NF, NI, NR1, NX, RANK, SR, $ TAUIM1 DOUBLE PRECISION C1, C2, CO, RCOND, S1, S2, SI, SMAX, SMAXPR, $ SMIN, SMINPR, SVMA, SVMR, T, TOLZ, TT C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, ILAENV DOUBLE PRECISION DLAMCH, DLANGE, DNRM2 EXTERNAL DLAMCH, DLANGE, DNRM2, IDAMAX, ILAENV, $ LSAME C .. External Subroutines .. EXTERNAL DGEQRF, DLACPY, DLAIC1, DLARF, DLARFG, DLARTG, $ DLASET, DORMQR, DROT, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD, SQRT C C .. Executable Statements .. C C Decode COMPQ. C IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'U' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF C C Decode COMPZ. C IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'U' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF C C Test the input scalar parameters. C NB = INFO INFO = 0 IF( ICOMPQ.LE.0 ) THEN INFO = -1 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -2 ELSE IF( L.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( N1.LT.0 .OR. N1.GT.MIN( L, N ) ) THEN INFO = -7 ELSE IF( LBE.LT.0 .OR. LBE.GT.MAX( 0, N1-1 ) ) THEN INFO = -8 ELSE IF( LDA.LT.MAX( 1, L ) ) THEN INFO = -10 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -12 ELSE IF( LDB.LT.MAX( 1, L ) ) THEN INFO = -14 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -16 ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN INFO = -18 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -20 ELSE IF( TOL.GE.ONE ) THEN INFO = -24 ELSE IF( MIN( N1, M ).EQ.0 ) THEN MINWRK = 1 ELSE MINWRK = MAX( 1, N, L, 2*( M + N1 - 1 ) ) END IF MAXWRK = MINWRK LQUERY = LDWORK.EQ.-1 IF( LQUERY .AND. LBE.GT.0 ) THEN C C Compute optimal workspace. C CALL DGEQRF( N1, N1, E, LDE, DWORK, DWORK, -1, INFO ) MAXWRK = MAX( MAXWRK, N1 + INT( DWORK(1) ) ) CALL DORMQR( 'Left', 'Transpose', N1, N, N1, E, LDE, DWORK, $ A, LDA, DWORK, -1, INFO ) MAXWRK = MAX( MAXWRK, N1 + INT( DWORK(1) ) ) CALL DORMQR( 'Left', 'Transpose', N1, M, N1, E, LDE, DWORK, $ B, LDB, DWORK, -1, INFO ) MAXWRK = MAX( MAXWRK, N1 + INT( DWORK(1) ) ) IF( ILQ ) THEN CALL DORMQR( 'Right', 'NoTranspose', L, N1, N1, E, LDE, $ DWORK, Q, LDQ, DWORK, -1, INFO ) MAXWRK = MAX( MAXWRK, N1 + INT( DWORK(1) ) ) END IF ELSE IF( LQUERY ) THEN MAXWRK = MINWRK ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -27 END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01HY', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = MAXWRK RETURN END IF C C Initialize Q and Z if necessary. C IF( ICOMPQ.EQ.3 ) $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) C C Initialize output variables. C NR = 0 NRBLCK = 0 C C Quick return if possible. C IF( M.EQ.0 .OR. N1.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C TOLZ = DLAMCH( 'Precision' ) WITHC = P.GT.0 RCOND = TOL IF ( RCOND.LE.ZERO ) THEN C C Use the default tolerance in controllability determination. C RCOND = DBLE( L*N )*TOLZ END IF TOLZ = SQRT( TOLZ ) C SVMR = RCOND SVMA = MAX( ONE, DLANGE( 'F', L, N, A, LDA, DWORK ) )*RCOND C C Reduce E to upper triangular form if necessary. C Check if block algorithms should be used. C IF( NB.LE.0 ) THEN CALL DGEQRF( N1, N1, E, LDE, DWORK, DWORK, -1, INFO ) NB = INT( DWORK(1)/N1 ) END IF NX = ILAENV( 3, 'DGEQRF', ' ', N1, N1, -1, -1 ) C IF( LBE.GT.0 ) THEN NI = NB IF( LDWORK.LT.N1*NB ) $ NB = INT( LDWORK/N1 ) C IF( LBE.LT.NX/2 .OR. NB.LT.NX .OR. N1.LT.NX ) THEN DO 10 I = 1, N1-1 C C Generate elementary reflector H(i) to annihilate C E(i+1:i+lbe,i). C K = MIN( LBE, N1-I ) + 1 CALL DLARFG( K, E(I,I), E(I+1,I), 1, TT ) T = E(I,I) E(I,I) = ONE C C Apply H(i) to E(i:n1,i+1:n) from the left. C CALL DLARF( 'Left', K, N-I, E(I,I), 1, TT, $ E(I,I+1), LDE, DWORK ) C C Apply H(i) to A(i:n1,1:n) from the left. C CALL DLARF( 'Left', K, N, E(I,I), 1, TT, $ A(I,1), LDA, DWORK ) C C Apply H(i) to B(i:n1,1:m) from the left. C CALL DLARF( 'Left', K, M, E(I,I), 1, TT, $ B(I,1), LDB, DWORK ) IF( ILQ ) THEN C C Apply H(i) to Q(1:l,i:n1) from the right. C CALL DLARF( 'Right', L, K, E(I,I), 1, TT, $ Q(1,I), LDQ, DWORK ) END IF E(I,I) = T 10 CONTINUE MAXWRK = MINWRK ELSE CALL DGEQRF( N1, N1, E, LDE, DWORK, DWORK(N1+1), LDWORK-N1, $ INFO ) MAXWRK = MAX( MINWRK, INT( DWORK(N1+1) )+N1 ) CALL DORMQR( 'Left', 'Transpose', N1, N-N1, N1, E, LDE, $ DWORK, E(1,N1+1), LDE, DWORK(N1+1), LDWORK-N1, $ INFO ) CALL DORMQR( 'Left', 'Transpose', N1, N, N1, E, LDE, DWORK, $ A, LDA, DWORK(N1+1), LDWORK-N1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(N1+1) )+N1 ) CALL DORMQR( 'Left', 'Transpose', N1, M, N1, E, LDE, DWORK, $ B, LDB, DWORK(N1+1), LDWORK-N1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(N1+1) )+N1 ) IF( ILQ ) THEN CALL DORMQR( 'Right', 'NoTranspose', L, N1, N1, E, LDE, $ DWORK, Q, LDQ, DWORK(N1+1), LDWORK-N1, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(N1+1) )+N1 ) END IF END IF CALL DLASET( 'Lower', N1-1, N1-1, ZERO, ZERO, E(2,1), LDE ) NB = NI END IF C ISMIN = 1 ISMAX = ISMIN + M IROT = 2*( M + N1 ) - 3 TAUIM1 = M IC = -M NF = N1 UB = NB.LE.2 C 20 CONTINUE NRBLCK = NRBLCK + 1 RANK = 0 IF( NF.GT.0 ) THEN C C IROW will point to the current pivot line in B, C ICOL+1 will point to the first active columns of A. C ICOL = IC + TAUIM1 NI = N - ICOL IROW = NR NR1 = NR + 1 IF( NR.GT.0 ) THEN CALL DLACPY( 'Full', NF, TAUIM1, A(NR1,IC+1), LDA, $ B(NR1,1), LDB ) SVMR = SVMA END IF ONECOL = TAUIM1.EQ.1 C C Perform QR-decomposition with column pivoting on the current B C while keeping E upper triangular. C The current B is at first iteration B and for subsequent C iterations the NF-by-TAUIM1 matrix delimited by rows C NR + 1 to N1 and columns IC + 1 to IC + TAUIM1 of A. C The rank of current B is computed in RANK. C IF( ONECOL ) THEN MN = 1 ELSE MN = MIN( NF, TAUIM1 ) C C Compute column norms. C DO 30 J = 1, TAUIM1 DWORK(J) = DNRM2( NF, B(NR1,J), 1 ) DWORK(M+J) = DWORK(J) IWORK(J) = J 30 CONTINUE END IF C 40 CONTINUE IF( RANK.LT.MN ) THEN J = RANK + 1 IROW = IROW + 1 UPDB = TAUIM1-J.GT.0 C C Pivot if necessary. C IF( UPDB ) THEN K = ( J - 1 ) + IDAMAX( TAUIM1-J+1, DWORK(J), 1 ) IF( K.NE.J ) THEN CALL DSWAP( NF, B(NR1,J), 1, B(NR1,K), 1 ) I = IWORK(K) IWORK(K) = IWORK(J) IWORK(J) = I DWORK(K) = DWORK(J) DWORK(M+K) = DWORK(M+J) END IF END IF C C Zero elements below the current diagonal element of B. C Apply transformations on block rows and columns of A, B, C and E. C IR = IROT IB = N1 - 1 K = 0 C DO 50 I = IB, IROW, -1 C C Rotate rows I and I+1 to zero B(I+1,J). C K = K + 1 T = B(I,J) CALL DLARTG( T, B(I+1,J), CO, SI, B(I,J) ) B(I+1,J) = ZERO DWORK(IR) = CO DWORK(IR+1) = SI IR = IR - 2 IF( UB ) THEN CALL DROT( N-I+1, E(I,I), LDE, E(I+1,I), LDE, CO, SI ) ELSE CALL DROT( MIN(N-I,K)+1, E(I,I), LDE, E(I+1,I), LDE, $ CO, SI ) END IF IF( K.EQ.NB ) $ K = 0 IF( UPDB ) THEN OPB = TAUIM1-J.LT.NX .OR. UB .OR. $ ( TAUIM1-J )*LDB.LE.NB*N1 IF( OPB ) $ CALL DROT( TAUIM1-J, B(I,J+1), LDB, B(I+1,J+1), $ LDB, CO, SI ) ELSE OPB = .FALSE. END IF IF( NI.LT.NX .OR. UB ) $ CALL DROT( NI, A(I,ICOL+1), LDA, A(I+1,ICOL+1), LDA, $ CO, SI ) IF( ILQ ) $ CALL DROT( L, Q(1,I), 1, Q(1,I+1), 1, CO, SI ) C C Rotate columns I, I+1 to zero E(I+1,I). C T = E(I+1,I+1) CALL DLARTG( T, E(I+1,I), CO, SI, E(I+1,I+1) ) E(I+1,I) = ZERO CALL DROT( I, E(1,I+1), 1, E(1,I), 1, CO, SI ) CALL DROT( N1, A(1,I+1), 1, A(1,I), 1, CO, SI ) IF( ILZ ) $ CALL DROT( N, Z(1,I+1), 1, Z(1,I), 1, CO, SI ) IF( WITHC ) $ CALL DROT( P, C(1,I+1), 1, C(1,I), 1, CO, SI ) 50 CONTINUE C IF( .NOT.UB ) THEN IF( NI.GE.NX ) THEN C C Apply all row rotations to column panels of A. C DO 70 KB = N-NB+1, ICOL+1, -NB IR = IROT DO 60 I = IB, IROW, -1 CALL DROT( NB, A(I,KB), LDA, A(I+1,KB), LDA, $ DWORK(IR), DWORK(IR+1) ) IR = IR - 2 60 CONTINUE 70 CONTINUE C LB = MOD( NI, NB ) C IF( LB.GT.0 ) THEN IR = IROT DO 80 I = IB, IROW, -1 CALL DROT( LB, A(I,ICOL+1), LDA, A(I+1,ICOL+1), $ LDA, DWORK(IR), DWORK(IR+1) ) IR = IR - 2 80 CONTINUE END IF END IF C IF( .NOT.OPB ) THEN C C Apply all row rotations to column panels of B. C DO 100 KB = TAUIM1-NB+1, J+1, -NB IR = IROT DO 90 I = IB, IROW, -1 CALL DROT( NB, B(I,KB), LDB, B(I+1,KB), LDB, $ DWORK(IR), DWORK(IR+1) ) IR = IR - 2 90 CONTINUE 100 CONTINUE C LB = MOD( TAUIM1-J, NB ) C IF( LB.GT.0 ) THEN IR = IROT DO 110 I = IB, IROW, -1 CALL DROT( LB, B(I,J+1), LDB, B(I+1,J+1), LDB, $ DWORK(IR), DWORK(IR+1) ) IR = IR - 2 110 CONTINUE END IF END IF C C Apply all row rotations to column panels of E. C Start with the rightmost, possibly thinner, panel. C IF( N.GT.N1 ) THEN LB = MOD( N-N1, NB ) JB = N - LB + 1 K = ( N - LB - N1 )/NB C IF( LB.GT.0 ) THEN IR = IROT DO 120 I = IB, IROW, -1 CALL DROT( LB, E(I,JB), LDE, E(I+1,JB), LDE, $ DWORK(IR), DWORK(IR+1) ) IR = IR - 2 120 CONTINUE END IF C DO 140 KB = JB-NB, N-LB-K*NB, -NB IR = IROT DO 130 I = IB, IROW, -1 CALL DROT( NB, E(I,KB), LDE, E(I+1,KB), LDE, $ DWORK(IR), DWORK(IR+1) ) IR = IR - 2 130 CONTINUE 140 CONTINUE C END IF C SR = IROT IB = IB - NB LB = MOD( N1 - IROW + 1, NB ) IF( LB.EQ.0 ) THEN LB = NB ELSE IF( LB.EQ.1 ) THEN LB = 2 END IF C DO 170 KB = N1-NB+1, IROW+LB, -NB SR = SR - 2*NB IR = SR DO 160 I = IB, IROW, -1 CALL DROT( NB, E(I,KB), LDE, E(I+1,KB), LDE, $ DWORK(IR), DWORK(IR+1) ) IR = IR - 2 160 CONTINUE IB = IB - NB 170 CONTINUE END IF C IF( RANK.EQ.0 ) THEN C C Initialize; exit if matrix is zero (RANK = 0). C Short pass if the current B has one column. C SMAX = ABS( B(NR1,1) ) IF ( SMAX.LE.SVMR ) THEN GO TO 200 ELSE IF ( ONECOL ) THEN RANK = RANK + 1 GO TO 200 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, B(NR1,J), $ B(IROW,J), SMINPR, S1, C1 ) CALL DLAIC1( IMAX, RANK, DWORK(ISMAX), SMAX, B(NR1,J), $ B(IROW,J), SMAXPR, S2, C2 ) END IF C C Check the rank; finish the loop if rank loss occurs. C IF( SVMR.LE.SMAXPR ) THEN IF( SMAXPR*RCOND.LT.SMINPR ) THEN C C Finish the loop if last row. C IF( IROW.EQ.N1 ) THEN RANK = RANK + 1 GO TO 200 END IF C C Update partial column norms. C DO 180 I = J + 1, TAUIM1 IF( DWORK(I).NE.ZERO ) THEN T = ABS( B(IROW,I) )/DWORK(I) T = MAX( ( ONE + T )*( ONE - T ), ZERO ) TT = T*( DWORK(I)/DWORK(M+I) )**2 IF( TT.GT.TOLZ ) THEN DWORK(I) = DWORK(I)*SQRT( T ) ELSE DWORK(I) = DNRM2( NF-J, B(IROW+1,I), 1 ) DWORK(M+I) = DWORK(I) END IF END IF 180 CONTINUE C DO 190 I = 1, RANK DWORK(ISMIN+I-1) = S1*DWORK(ISMIN+I-1) DWORK(ISMAX+I-1) = S2*DWORK(ISMAX+I-1) 190 CONTINUE C DWORK(ISMIN+RANK) = C1 DWORK(ISMAX+RANK) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 GO TO 40 END IF END IF END IF END IF C 200 CONTINUE C IF( RANK.GT.0 ) THEN RTAU(NRBLCK) = RANK C C Back permute interchanged columns. C IF( .NOT.ONECOL ) THEN DO 220 J = 1, TAUIM1 IF( IWORK(J).GT.0 ) THEN K = IWORK(J) IWORK(J) = -K 210 CONTINUE IF( K.NE.J ) THEN CALL DSWAP( RANK, B(NR1,J), 1, B(NR1,K), 1 ) IWORK(K) = -IWORK(K) K = -IWORK(K) GO TO 210 END IF END IF 220 CONTINUE END IF C IF( NR.GT.0 ) $ CALL DLACPY( 'Full', NF, TAUIM1, B(NR1,1), LDB, $ A(NR1,IC+1), LDA ) NR = NR + RANK NF = NF - RANK IC = ICOL TAUIM1 = RANK GO TO 20 ELSE NRBLCK = NRBLCK - 1 END IF C IF( NRBLCK.GT.0 ) $ RANK = RTAU(1) IF( RANK.LT.N1 ) $ CALL DLASET( 'Full', N1-RANK, M, ZERO, ZERO, B(RANK+1,1), LDB ) C DWORK(1) = MAXWRK RETURN C *** Last line of TG01HY *** END control-4.1.2/src/slicot/src/PaxHeaders/AB08NW.f0000644000000000000000000000013215012430707016174 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB08NW.f0000644000175000017500000004652215012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE AB08NW( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ NFZ, NRANK, NIZ, DINFZ, NKROR, NINFE, NKROL, $ INFZ, KRONR, INFE, KRONL, E, LDE, TOL, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To extract from the system pencil C C ( A-lambda*I B ) C S(lambda) = ( ) C ( C D ) C C a regular pencil Af-lambda*Ef which has the finite Smith zeros of C S(lambda) as generalized eigenvalues. The routine also computes C the orders of the infinite Smith zeros and determines the singular C and infinite Kronecker structure of the system pencil, i.e., the C right and left Kronecker indices, and the multiplicities of the C infinite eigenvalues. C C ARGUMENTS C C Mode Parameters C C EQUIL CHARACTER*1 C Specifies whether the user wishes to balance the system C matrix 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 order of the square matrix A, the number of rows of C the matrix B, and number of columns of the matrix C. C N >= 0. C C M (input) INTEGER. C The number of columns of the matrix B. M >= 0. C C P (input) INTEGER. C The number of rows of the matrix C. 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 A of the system. C On exit, the leading NFZ-by-NFZ part of this array C contains the matrix Af of the reduced pencil. C C LDA INTEGER C The leading dimension of the 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 B of the system. C On exit, this matrix does not contain useful information. C C LDB INTEGER C The leading dimension of the array B. LDB >= 1, and C LDB >= MAX(1,N), if M > 0. 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 C of the system. C On exit, this matrix does not contain useful information. 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 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 the array D. LDD >= MAX(1,P). C C NFZ (output) INTEGER C The number of finite zeros. C C NRANK (output) INTEGER C The normal rank of the system pencil. C C NIZ (output) INTEGER C The number of infinite zeros. C C DINFZ (output) INTEGER C The maximal multiplicity of infinite Smith zeros. C C NKROR (output) INTEGER C The number of right Kronecker indices. C C NINFE (output) INTEGER C The number of elementary infinite blocks. C C NKROL (output) INTEGER C The number of left Kronecker indices. C C INFZ (output) INTEGER array, dimension (N+1) 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 in C the Smith form of degree i, where i = 1,2,...,DINFZ. C C KRONR (output) INTEGER array, dimension (N+1) C The leading NKROR elements of this array contain the C right Kronecker (column) indices. C C INFE (output) INTEGER array, dimension (N+1) C The leading NINFE elements of INFE contain the C multiplicities of infinite eigenvalues. C C KRONL (output) INTEGER array, dimension (N+1) C The leading NKROL elements of this array contain the C left Kronecker (row) indices. C C E (output) DOUBLE PRECISION array, dimension (LDE,N) C The leading NFZ-by-NFZ part of this array contains the C matrix Ef of the reduced pencil. C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,N). 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 <= 0, then an implicitly computed, C default tolerance TOLDEF = MAX(N+P,N+M)**2*EPS, is used C instead, where EPS is the machine precision (see LAPACK C Library routine DLAMCH). TOL < 1. 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 >= 1, if MAX(N,M,P) = 0; otherwise, C LDWORK >= MAX( MIN(P,M) + M + MAX(2*M,N) - 1, C MIN(P,N) + MAX(N + MAX(P,M), 3*P - 1 ) ) + C MAX(P+N,M+N)*MAX(P+N,M+N). 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-lambda*I,B,C,D), a regular pencil Af-lambda*Ef, which C has the finite zeros of the system as generalized eigenvalues. C The procedure has the following main computational steps: C C (a) construct the (N+P)-by-(M+N) system pencil C C S(lambda) = (B A)-lambda*( 0 I ); C (D C) ( 0 0 ) C C (b) reduce S(lambda) to S1(lambda) with the same finite zeros C and right Kronecker structure, but with D of full row rank; C C (c) reduce the pencil S1(lambda) to S2(lambda) with the same C finite zeros and with D square invertible; C C (d) perform a unitary transformation on the columns of C S2(lambda) = (A-lambda*I B), in order to reduce it to C ( C D) C C (Af-lambda*Ef X), with Y and Ef square invertible; C ( 0 Y) C C (e) compute the right and left Kronecker indices of the system C matrix, which, together with the multiplicities of the C finite and infinite eigenvalues, constitute the complete C set of structural invariants under strict equivalence C 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 the C 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 finite Smith zeros of the system C explicitly, a call to this routine may be followed by a call to C the LAPACK Library routine DGGEV. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. C C REVISIONS C C A. Varga, May 2003, German Aerospace Center, DLR Oberpfaffenhofen. C V. Sima, Dec. 2016, Jan. 2017, Apr. 2017. C C KEYWORDS C C Generalized eigenvalue problem, Kronecker indices, multivariable C system, orthogonal transformation, structural invariant. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL INTEGER DINFZ, INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, $ M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), E(LDE,*) C .. Local Scalars .. LOGICAL LEQUIL, LQUERY, QRET INTEGER I, I0, I1, II, ITAU, J, JWORK, KABCD, LABCD2, $ LDABCD, MM, MPM, MPN, MU, NN, NSINFE, NU, NU1, $ PP, WRKOPT DOUBLE PRECISION MAXRED, SVLMAX, TOLER C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL AB08NY, DLACPY, DLASET, DORMRZ, DTZRZF, MA02BD, $ TB01ID, TB01XD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C .. Executable Statements .. C INFO = 0 LDABCD = N + MAX( P, M ) LABCD2 = LDABCD*LDABCD LEQUIL = LSAME( EQUIL, 'S' ) 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.1 .OR. ( M.GT.0 .AND. LDB.LT.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( LDE.LT.MAX( 1, N ) ) THEN INFO = -25 ELSE IF( TOL.GE.ONE ) THEN INFO = -26 ELSE MPN = MIN( P, N ) MPM = MIN( P, M ) QRET = MAX( N, M, P ).EQ.0 LQUERY = ( LDWORK.EQ.-1 ) IF( QRET ) THEN JWORK = 1 ELSE JWORK = MAX( MPM + M + MAX( 2*M, N ) - 1, $ MPN + MAX( LDABCD, 3*P - 1 ) ) + LABCD2 END IF IF( LQUERY ) THEN IF( QRET ) THEN WRKOPT = 1 ELSE SVLMAX = ZERO NIZ = 0 CALL AB08NY( .TRUE., N, M, P, SVLMAX, DWORK, LDABCD, NIZ, $ NU, MU, DINFZ, NKROL, INFZ, KRONL, TOL, $ IWORK, DWORK, -1, INFO ) WRKOPT = MAX( JWORK, LABCD2 + INT( DWORK(1) ) ) CALL AB08NY( .FALSE., N, M, M, SVLMAX, DWORK, LDABCD, $ NIZ, NU, MU, I1, NKROR, IWORK, KRONR, TOL, $ IWORK, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) ) CALL DTZRZF( MPM, N+MPM, DWORK, LDABCD, DWORK, DWORK, -1, $ INFO ) WRKOPT = MAX( WRKOPT, LABCD2 + MPM + INT( DWORK(1) ) ) CALL DORMRZ( 'Right', 'Transpose', N, N+MPM, MPM, N, $ DWORK, LDABCD, DWORK, DWORK, LDABCD, DWORK, $ -1, INFO ) WRKOPT = MAX( WRKOPT, LABCD2 + MPM + INT( DWORK(1) ) ) END IF ELSE IF( LDWORK.LT.JWORK ) THEN INFO = -29 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB08NW', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C NIZ = 0 NKROL = 0 NKROR = 0 NINFE = 0 C C Quick return if possible. C IF( QRET ) THEN DINFZ = 0 NFZ = 0 NRANK = 0 DWORK(1) = ONE RETURN 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 KABCD = 1 JWORK = KABCD + LABCD2 C C If required, balance the system pencil. C Workspace: need N. C IF( LEQUIL ) THEN MAXRED = ZERO CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) WRKOPT = N END IF C C Construct the system pencil C C ( B A-lambda*I ) C S(lambda) = ( ) C ( D C ) C C of dimension (N+P)-by-(M+N). C NN = N MM = M PP = P C CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KABCD), LDABCD ) CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KABCD+N), LDABCD ) CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KABCD+LDABCD*M), LDABCD ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KABCD+LDABCD*M+N), $ LDABCD ) C C If required, set tolerance. C TOLER = TOL IF( TOLER.LE.ZERO ) THEN TOLER = DBLE( LABCD2 ) * DLAMCH( 'Precision' ) END IF SVLMAX = DLANGE( 'Frobenius', NN+PP, NN+MM, DWORK(KABCD), LDABCD, $ DWORK(JWORK) ) C C Extract the reduced pencil S1(lambda) C C ( Bc Ac-lambda*I ), C ( Dc Cc ) C C having the same finite Smith zeros as the system pencil S(lambda), C but with Dc, a MU-by-MM full row rank left upper-trapezoidal C matrix, with the first MU columns in an upper triangular form. C C Workspace: need MAX( MIN(P,M) + M + MAX(2*M,N) - 1, C MIN(P,N) + MAX(N + MAX(P,M), 3*P - 1 ) ). C prefer larger. C Int.work. need MAX(M,P). C CALL AB08NY( .TRUE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, $ NIZ, NU, MU, DINFZ, NKROL, INFZ, KRONL, TOLER, IWORK, $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Set the number of simple (non-dynamic) infinite eigenvalues, and C the normal rank of the system pencil. C NSINFE = MU NRANK = NN + MU C C Pertranspose the system. C CALL TB01XD( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ), $ DWORK(KABCD+LDABCD*MM), LDABCD, $ DWORK(KABCD), LDABCD, $ DWORK(KABCD+LDABCD*MM+NU), LDABCD, $ DWORK(KABCD+NU), LDABCD, INFO ) CALL MA02BD( 'Right', NU+MM, MM, DWORK(KABCD), LDABCD ) CALL MA02BD( 'Left', MM, NU+MM, DWORK(KABCD+NU), LDABCD ) C IF( MU.NE.MM ) THEN NN = NU PP = MM MM = MU KABCD = KABCD + ( PP - MM )*LDABCD C C Extract the reduced pencil S2(lambda) to C C ( Br Ar-lambda*I ), C ( Dr Cr ) C C having the same finite Smith zeros as the pencil S(lambda), C but with Dr, a MU-by-MU invertible upper-triangular matrix. C C Workspace: need MAX( MIN(P,M) + M + MAX(2*M,N) - 1, C MIN(P,N) + MAX(N + MAX(P,M), 3*P-1 ) ). C prefer larger. C CALL AB08NY( .FALSE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, $ I0, NU, MU, I1, NKROR, IWORK, KRONR, TOLER, $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) END IF C IF( MIN( NU, MU ).NE.0 ) THEN C C Perform a unitary transformation on the columns of C ( Br Ar-lambda*I ), C ( Dr Cr ) C in order to reduce it to C ( Af-lambda*Ef * ), C ( 0 Y ) C with Y and Ef square invertible. C NU1 = NU + KABCD I1 = NU + MU ITAU = JWORK JWORK = ITAU + MU C C Workspace: need 2*MIN(P,M); C prefer MIN(P,M) + MIN(P,M)*NB. C CALL DTZRZF( MU, I1, DWORK(NU1), LDABCD, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Compute and save Af. C C Workspace: need MIN(P,M) + N; C prefer MIN(P,M) + N*NB. C CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, $ DWORK(NU1), LDABCD, DWORK(ITAU), DWORK(KABCD), $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+MU*LDABCD), LDABCD, A, $ LDA ) C C Compute and save Ef. C CALL DLASET( 'Full', NU, MU, ZERO, ZERO, DWORK(KABCD), LDABCD ) CALL DLASET( 'Full', NU, NU, ZERO, ONE, DWORK(KABCD+MU*LDABCD), $ LDABCD ) CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, $ DWORK(NU1), LDABCD, DWORK(ITAU), DWORK(KABCD), $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+MU*LDABCD), LDABCD, E, $ LDE ) ELSE C C Save Af and set Ef. C CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+MU*LDABCD), LDABCD, A, $ LDA ) CALL DLASET( 'Full', NU, NU, ZERO, ONE, E, LDE ) END IF C NFZ = NU C C Set right Kronecker indices (column indices). C DO 30 I = 1, NKROR IWORK(I) = KRONR(I) 30 CONTINUE C J = 0 C DO 50 I = 1, NKROR DO 40 II = J + 1, J + IWORK(I) KRONR(II) = I - 1 40 CONTINUE C J = J + IWORK(I) 50 CONTINUE C NKROR = J C C Set left Kronecker indices (row indices). C DO 60 I = 1, NKROL IWORK(I) = KRONL(I) 60 CONTINUE C J = 0 C DO 80 I = 1, NKROL DO 70 II = J + 1, J + IWORK(I) KRONL(II) = I - 1 70 CONTINUE C J = J + IWORK(I) 80 CONTINUE C NKROL = J C C Determine the number of simple infinite blocks as the difference C between the order of Dr and the number of infinite blocks of order C greater than one. C DO 90 I = 1, DINFZ NINFE = NINFE + INFZ(I) 90 CONTINUE C NINFE = NSINFE - NINFE C DO 100 I = 1, NINFE INFE(I) = 1 100 CONTINUE C C Set the structure of infinite eigenvalues. C DO 120 I = 1, DINFZ C DO 110 II = NINFE + 1, NINFE + INFZ(I) INFE(II) = I + 1 110 CONTINUE C NINFE = NINFE + INFZ(I) 120 CONTINUE C DWORK(1) = WRKOPT RETURN C *** Last line of AB08NW *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09FD.f0000644000000000000000000000013215012430707016142 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB09FD.f0000644000175000017500000005753515012430707017355 0ustar00lilgelilge00000000000000 SUBROUTINE AB09FD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M, $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, NQ, HSV, $ TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr) for an original C state-space representation (A,B,C) by using either the square-root C or the balancing-free square-root Balance & Truncate (B & T) C model reduction method in conjunction with stable coprime C factorization techniques. 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 JOBCF CHARACTER*1 C Specifies whether left or right coprime factorization is C to be used as follows: C = 'L': use left coprime factorization; C = 'R': use right coprime factorization. C C FACT CHARACTER*1 C Specifies the type of coprime factorization to be computed C as follows: C = 'S': compute a coprime factorization with prescribed C stability degree ALPHA; C = 'I': compute a coprime factorization with inner C denominator. C C JOBMR CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root Balance & Truncate method; C = 'N': use the balancing-free square-root C Balance & Truncate method. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of the C resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. NR is set as follows: C if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR C is the desired order on entry, NQ is the order of the C computed coprime factorization of the given system, and C NMIN is the order of a minimal realization of the extended C system (see METHOD); NMIN is determined as the number of C Hankel singular values greater than NQ*EPS*HNORM(Ge), C where EPS is the machine precision (see LAPACK Library C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the C extended system (computed in HSV(1)); C if ORDSEL = 'A', NR is equal to the number of Hankel C singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)). C C ALPHA (input) DOUBLE PRECISION C If FACT = 'S', the desired stability degree for the C factors of the coprime factorization (see SLICOT Library C routines SB08ED/SB08FD). C ALPHA < 0 for a continuous-time system (DICO = 'C'), and C 0 <= ALPHA < 1 for a discrete-time system (DICO = 'D'). C If FACT = 'I', ALPHA is not used. 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 original state dynamics matrix A. C On exit, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the reduced C order system. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C NQ (output) INTEGER C The order of the computed extended system Ge (see METHOD). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, it contains the NQ Hankel singular values of C the extended system Ge ordered decreasingly (see METHOD). C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced extended system. C For model reduction, the recommended value is C TOL1 = c*HNORM(Ge), where c is a constant in the C interval [0.00001,0.001], and HNORM(Ge) is the C Hankel-norm of the extended system (computed in HSV(1)). C The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if C TOL1 <= 0 on entry, where EPS is the machine precision C (see LAPACK Library Routine DLAMCH). C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The absolute tolerance level below which the elements of C B or C are considered zero (used for controllability or C observability tests). C If the user sets TOL2 <= 0, then an implicitly computed, C default tolerance TOLDEF is used: C TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or C TOLDEF = N*EPS*NORM(B), if JOBCF = 'R', C where EPS is the machine precision, and NORM(.) denotes C the 1-norm of a matrix. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = PM, if JOBMR = 'B', C LIWORK = MAX(N,PM), if JOBMR = 'N', where C PM = P, if JOBCF = 'L', C PM = M, if JOBCF = 'R'. 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,LW1) if JOBCF = 'L' and FACT = 'S', C LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I', C LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S', C LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where C LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + C MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ), C LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + C MAX( N*P+MAX(N*(N+5), P*(P+2), 4*P, 4*M), LWR ), C LW3 = (N+M)*(M+P) + MAX( 5*M, 4*P, LWR ), C LW4 = (N+M)*(M+P) + MAX( M*(M+2), 4*M, 4*P, LWR ), and C LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2. C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 10*K+I: C I = 1: with ORDSEL = 'F', the selected order NR is C greater than the order of the computed coprime C factorization of the given system. In this case, C the resulting NR is set automatically to a value C corresponding to the order of a minimal C realization of the system; C K > 0: K violations of the numerical stability C condition occured when computing the coprime C factorization using pole assignment (see SLICOT C Library routines SB08CD/SB08ED, SB08DD/SB08FD). 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 + H*C)*Z C (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT C Library routines SB08CD/SB08ED (or SB08DD/SB08FD); C = 3: the matrix A has an observable or controllable C eigenvalue on the imaginary axis if DICO = 'C' or C on the unit circle if DICO = 'D'; C = 4: the computation of Hankel singular values failed. C C METHOD C C Let be the linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system, and let G be the corresponding C transfer-function matrix. The subroutine AB09FD determines C the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) (2) C C with the transfer-function matrix Gr, by using the C balanced-truncation model reduction method in conjunction with C a left coprime factorization (LCF) or a right coprime C factorization (RCF) technique: C C 1. Compute the appropriate stable coprime factorization of G: C -1 -1 C G = R *Q (LCF) or G = Q*R (RCF). C C 2. Perform the model reduction algorithm on the extended system C ( Q ) C Ge = ( Q R ) (LCF) or Ge = ( R ) (RCF) C C to obtain a reduced extended system with reduced factors C ( Qr ) C Ger = ( Qr Rr ) (LCF) or Ger = ( Rr ) (RCF). C C 3. Recover the reduced system from the reduced factors as C -1 -1 C Gr = Rr *Qr (LCF) or Gr = Qr*Rr (RCF). C C The approximation error for the extended system satisfies C C HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)], C C where INFNORM(G) is the infinity-norm of G. C C If JOBMR = 'B', the square-root Balance & Truncate method of [1] C is used for model reduction. C If JOBMR = 'N', the balancing-free square-root version of the C Balance & Truncate method [2] is used for model reduction. C C If FACT = 'S', the stable coprime factorization with prescribed C stability degree ALPHA is computed by using the algorithm of [3]. C If FACT = 'I', the stable coprime factorization with inner C denominator is computed by using the algorithm of [4]. C C REFERENCES C C [1] Tombs M.S. and Postlethwaite I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C [2] Varga A. C Efficient minimal realization procedure based on balancing. C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, C pp. 42-46, 1991. C C [3] Varga A. C Coprime factors model reduction method based on square-root C balancing-free techniques. C System Analysis, Modelling and Simulation, Vol. 11, C pp. 303-311, 1993. C C [4] 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 C The implemented methods rely on accuracy enhancing square-root or C balancing-free square-root techniques. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C August 1998. C C REVISIONS C C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. C C KEYWORDS C C Balancing, coprime factorization, minimal realization, C model reduction, multivariable system, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION C100, ONE, ZERO PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NQ, $ NR, P DOUBLE PRECISION ALPHA, TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) C .. Local Scalars .. LOGICAL DISCR, FIXORD, LEFT, STABD INTEGER IERR, IWARNK, KB, KBR, KBT, KC, KCR, KD, KDR, $ KDT, KT, KTI, KW, LW1, LW2, LW3, LW4, LWR, $ MAXMP, MP, NDR, PM, WRKOPT DOUBLE PRECISION MAXRED C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB09AX, DLACPY, DLASET, SB08CD, SB08DD, SB08ED, $ SB08FD, SB08GD, SB08HD, TB01ID, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) FIXORD = LSAME( ORDSEL, 'F' ) LEFT = LSAME( JOBCF, 'L' ) STABD = LSAME( FACT, 'S' ) MAXMP = MAX( M, P ) C LWR = 2*N*N + N*( MAX( N, M + P ) + 5 ) + ( N*( N + 1 ) )/2 LW1 = N*( 2*MAXMP + P ) + MAXMP*( MAXMP + P ) LW2 = LW1 + $ MAX( N*P + MAX( N*( N + 5 ), P*( P+2 ), 4*P, 4*M ), LWR ) LW1 = LW1 + MAX( N*P + MAX( N*( N + 5 ), 5*P, 4*M ), LWR ) LW3 = ( N + M )*( M + P ) + MAX( 5*M, 4*P, LWR ) LW4 = ( N + M )*( M + P ) + MAX( M*( M + 2 ), 4*M, 4*P, LWR ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( STABD .OR. LSAME( FACT, 'I' ) ) ) THEN INFO = -3 ELSE IF( .NOT. ( LSAME( JOBMR, 'B' ) .OR. $ LSAME( JOBMR, 'N' ) ) ) THEN INFO = -4 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -5 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -6 ELSE IF( STABD .AND. ( ( .NOT.DISCR .AND. ALPHA.GE.ZERO ) .OR. $ ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GE.ONE ) ) ) ) $ THEN INFO = -7 ELSE IF( N.LT.0 ) THEN INFO = -8 ELSE IF( M.LT.0 ) THEN INFO = -9 ELSE IF( P.LT.0 ) THEN INFO = -10 ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -11 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -17 ELSE IF( ( LDWORK.LT.1 ) .OR. $ ( STABD .AND. LEFT .AND. LDWORK.LT.LW1 ) .OR. $ ( .NOT.STABD .AND. LEFT .AND. LDWORK.LT.LW2 ) .OR. $ ( STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW3 ) .OR. $ ( .NOT.STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW4 ) ) THEN INFO = -24 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09FD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN NR = 0 NQ = 0 DWORK(1) = ONE RETURN END IF C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C MAXRED = C100 CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Perform the coprime factor model reduction procedure. C KD = 1 IF( LEFT ) THEN C -1 C Compute a LCF G = R *Q. C MP = M + P KDR = KD + MAXMP*MAXMP KC = KDR + MAXMP*P KB = KC + MAXMP*N KBR = KB + N*MAXMP KW = KBR + N*P LWR = LDWORK - KW + 1 CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KB), N ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), MAXMP ) CALL DLASET( 'Full', P, M, ZERO, ZERO, DWORK(KD), MAXMP ) C IF( STABD ) THEN C C Compute a LCF with prescribed stability degree. C C Workspace needed: N*(2*MAX(M,P)+P) + C MAX(M,P)*(MAX(M,P)+P); C Additional workspace: need N*P+MAX(N*(N+5),5*P,4*M); C prefer larger. C CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, DWORK(KB), N, $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL2, $ DWORK(KW), LWR, IWARN, INFO ) ELSE C C Compute a LCF with inner denominator. C C Workspace needed: N*(2*MAX(M,P)+P) + C MAX(M,P)*(MAX(M,P)+P); C Additional workspace: need N*P + C MAX(N*(N+5),P*(P+2),4*P,4*M). C prefer larger; C CALL SB08CD( DICO, N, M, P, A, LDA, DWORK(KB), N, $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL2, $ DWORK(KW), LWR, IWARN, INFO ) END IF C IWARN = 10*IWARN IF( INFO.NE.0 ) $ RETURN C WRKOPT = INT( DWORK(KW) ) + KW - 1 C IF( NQ.EQ.0 ) THEN NR = 0 DWORK(1) = WRKOPT RETURN END IF C IF( MAXMP.GT.M ) THEN C C Form the matrices ( BQ, BR ) and ( DQ, DR ) in consecutive C columns (see SLICOT Library routines SB08CD/SB08ED). C KBT = KBR KBR = KB + N*M KDT = KDR KDR = KD + MAXMP*M CALL DLACPY( 'Full', NQ, P, DWORK(KBT), N, DWORK(KBR), N ) CALL DLACPY( 'Full', P, P, DWORK(KDT), MAXMP, DWORK(KDR), $ MAXMP ) END IF C C Perform model reduction on ( Q, R ) to determine ( Qr, Rr ). C C Workspace needed: N*(2*MAX(M,P)+P) + C MAX(M,P)*(MAX(M,P)+P) + 2*N*N; C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; C prefer larger. C KT = KW KTI = KT + NQ*NQ KW = KTI + NQ*NQ CALL AB09AX( DICO, JOBMR, ORDSEL, NQ, MP, P, NR, A, LDA, $ DWORK(KB), N, DWORK(KC), MAXMP, HSV, DWORK(KT), $ N, DWORK(KTI), N, TOL1, IWORK, DWORK(KW), $ LDWORK-KW+1, IWARNK, IERR ) C IWARN = IWARN + IWARNK IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF C WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C -1 C Compute the reduced order system Gr = Rr *Qr. C C Workspace needed: N*(2*MAX(M,P)+P) + C MAX(M,P)*(MAX(M,P)+P); C Additional workspace: need 4*P. C KW = KT CALL SB08GD( NR, M, P, A, LDA, DWORK(KB), N, DWORK(KC), MAXMP, $ DWORK(KD), MAXMP, DWORK(KBR), N, DWORK(KDR), $ MAXMP, IWORK, DWORK(KW), INFO ) C C Copy the reduced system matrices Br and Cr to B and C. C CALL DLACPY( 'Full', NR, M, DWORK(KB), N, B, LDB ) CALL DLACPY( 'Full', P, NR, DWORK(KC), MAXMP, C, LDC ) C ELSE C -1 C Compute a RCF G = Q*R . C PM = P + M KDR = KD + P KC = KD + PM*M KCR = KC + P KW = KC + PM*N LWR = LDWORK - KW + 1 CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), PM ) CALL DLASET( 'Full', P, M, ZERO, ZERO, DWORK(KD), PM ) C IF( STABD ) THEN C C Compute a RCF with prescribed stability degree. C C Workspace needed: (N+M)*(M+P); C Additional workspace: need MAX( N*(N+5), 5*M, 4*P ); C prefer larger. C CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, $ DWORK(KCR), PM, DWORK(KDR), PM, TOL2, $ DWORK(KW), LWR, IWARN, INFO ) ELSE C C Compute a RCF with inner denominator. C C Workspace needed: (N+M)*(M+P); 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, $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, $ DWORK(KCR), PM, DWORK(KDR), PM, TOL2, $ DWORK(KW), LWR, IWARN, INFO ) END IF C IWARN = 10*IWARN IF( INFO.NE.0 ) $ RETURN C WRKOPT = INT( DWORK(KW) ) + KW - 1 C IF( NQ.EQ.0 ) THEN NR = 0 DWORK(1) = WRKOPT RETURN END IF C ( Q ) ( Qr ) C Perform model reduction on ( R ) to determine ( Rr ). C C Workspace needed: (N+M)*(M+P) + 2*N*N; C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; C prefer larger. C KT = KW KTI = KT + NQ*NQ KW = KTI + NQ*NQ CALL AB09AX( DICO, JOBMR, ORDSEL, NQ, M, PM, NR, A, LDA, B, $ LDB, DWORK(KC), PM, HSV, DWORK(KT), N, DWORK(KTI), $ N, TOL1, IWORK, DWORK(KW), LDWORK-KW+1, IWARNK, $ IERR ) C IWARN = IWARN + IWARNK IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF C WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C -1 C Compute the reduced order system Gr = Qr*Rr . C C Workspace needed: (N+M)*(M+P); C Additional workspace: need 4*M. C KW = KT CALL SB08HD( NR, M, P, A, LDA, B, LDB, DWORK(KC), PM, $ DWORK(KD), PM, DWORK(KCR), PM, DWORK(KDR), PM, $ IWORK, DWORK(KW), INFO ) C C Copy the reduced system matrix Cr to C. C CALL DLACPY( 'Full', P, NR, DWORK(KC), PM, C, LDC ) END IF C DWORK(1) = WRKOPT C RETURN C *** Last line of AB09FD *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02OZ.f0000644000000000000000000000013215012430707016205 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02OZ.f0000644000175000017500000001121215012430707017376 0ustar00lilgelilge00000000000000 INTEGER FUNCTION MA02OZ( SKEW, M, A, LDA, DE, LDDE ) C C PURPOSE C C To compute the number of zero rows (and zero columns) of a complex C (skew-)Hamiltonian matrix, C C ( A D ) C H = ( ). C ( E +/-A' ) C C FUNCTION VALUE C C MA02OZ INTEGER C The number of zero rows. C C ARGUMENTS C C Mode Parameters C C SKEW CHARACTER*1 C Specifies whether the matrix is Hamiltonian or skew- C Hamiltonian as follows: C = 'H': The matrix is Hamiltonian; C = 'S': The matrix is skew-Hamiltonian. C C Input/Output Parameters C C M (input) INTEGER C The order of the matrices A, D, and E. M >= 0. C C A (input) COMPLEX*16 array, dimension (LDA,M) C The leading M-by-M 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 DE (input) COMPLEX*16 array, dimension (LDDE,M+1) C The leading M-by-M lower triangular part of this array C must contain the lower triangular part of the (skew-) C Hermitian matrix E, and the M-by-M upper triangular C part of the submatrix in the columns 2 to M+1 of this C array must contain the upper triangular part of the C (skew-)Hermitian matrix D. If S is skew-Hamiltonian, the C real parts of the entries on the diagonal and the first C superdiagonal of this array, which should be zero, are C not used. If S is Hamiltonian, the imaginary parts of the C entries on the diagonal and the first superdiagonal of C this array, which should be zero, are not used. C C LDDE INTEGER C The leading dimension of the array DE. LDDE >= MAX(1,M). C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Sep. 2016. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, skew-Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) C .. C .. Scalar Arguments .. CHARACTER SKEW INTEGER LDA, LDDE, M C .. C .. Array Arguments .. COMPLEX*16 A( LDA, * ), DE( LDDE, * ) C .. C .. Local Scalars .. LOGICAL ISSKEW INTEGER I, J, NZ C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. Intrinsic Functions .. INTRINSIC DBLE, DIMAG C .. C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked. C NZ = 0 C IF( M.GT.0 ) THEN ISSKEW = LSAME( SKEW, 'S' ) C C Scan columns 1 .. M. C I = 0 C WHILE ( I.LE.M ) DO 10 CONTINUE I = I + 1 IF( I.LE.M ) THEN DO 20 J = 1, M IF( A( J, I ).NE.CZERO ) $ GO TO 10 20 CONTINUE DO 30 J = 1, I - 1 IF( DE( I, J ).NE.CZERO ) $ GO TO 10 30 CONTINUE IF( ISSKEW ) THEN IF( DIMAG( DE( I, I ) ).NE.ZERO ) $ GO TO 10 ELSE IF( DBLE( DE( I, I ) ).NE.ZERO ) $ GO TO 10 END IF DO 40 J = I + 1, M IF( DE( J, I ).NE.CZERO ) $ GO TO 10 40 CONTINUE C NZ = NZ + 1 GO TO 10 C C END WHILE 10 END IF C C Scan columns M+1 .. 2*M. C I = 0 C WHILE ( I.LE.M ) DO 50 CONTINUE I = I + 1 IF( I.LE.M ) THEN DO 60 J = 1, M IF( A( I, J ).NE.CZERO ) $ GO TO 50 60 CONTINUE DO 70 J = 1, I - 1 IF( DE( J, I+1 ).NE.CZERO ) $ GO TO 50 70 CONTINUE IF( ISSKEW ) THEN IF( DIMAG( DE( I, I+1 ) ).NE.ZERO ) $ GO TO 50 ELSE IF( DBLE( DE( I, I+1 ) ).NE.ZERO ) $ GO TO 50 END IF DO 80 J = I + 1, M IF( DE( I, J+1 ).NE.CZERO ) $ GO TO 50 80 CONTINUE C NZ = NZ + 1 GO TO 50 C END IF C END WHILE 50 END IF C MA02OZ = NZ RETURN C C *** Last line of MA02OZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03XU.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03XU.f0000644000175000017500000033436515012430707017425 0ustar00lilgelilge00000000000000 SUBROUTINE MB03XU( LTRA, LTRB, N, K, NB, A, LDA, B, LDB, G, LDG, $ Q, LDQ, XA, LDXA, XB, LDXB, XG, LDXG, XQ, LDXQ, $ YA, LDYA, YB, LDYB, YG, LDYG, YQ, LDYQ, CSL, $ CSR, TAUL, TAUR, DWORK ) C C PURPOSE C C To reduce 2*nb columns and rows of a real (k+2n)-by-(k+2n) C matrix H: C C [ op(A) G ] C H = [ ], C [ Q op(B) ] C C so that elements in the first nb columns below the k-th C subdiagonal of the (k+n)-by-n matrix op(A), in the first nb C columns and rows of the n-by-n matrix Q and in the first nb rows C above the diagonal of the n-by-(k+n) matrix op(B) are zero. C The reduction is performed by orthogonal symplectic C transformations UU'*H*VV and matrices U, V, YA, YB, YG, YQ, XA, C XB, XG, and XQ are returned so that C C [ op(Aout)+U*YA'+XA*V' G+U*YG'+XG*V' ] C UU' H VV = [ ]. C [ Qout+U*YQ'+XQ*V' op(Bout)+U*YB'+XB*V' ] C C This is an auxiliary routine called by MB04TB. C C ARGUMENTS C C Mode Parameters C C LTRA LOGICAL C Specifies the form of op( A ) as follows: C = .FALSE.: op( A ) = A; C = .TRUE.: op( A ) = A'. C C LTRB LOGICAL C Specifies the form of op( B ) as follows: C = .FALSE.: op( B ) = B; C = .TRUE.: op( B ) = B'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix Q. N >= 0. C C K (input) INTEGER C The offset of the reduction. Elements below the K-th C subdiagonal in the first NB columns of op(A) are C reduced to zero. K >= 0. C C NB (input) INTEGER C The number of columns/rows to be reduced. N > NB >= 0. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA,N) if LTRA = .FALSE. C (LDA,K+N) if LTRA = .TRUE. C On entry with LTRA = .FALSE., the leading (K+N)-by-N part C of this array must contain the matrix A. C On entry with LTRA = .TRUE., the leading N-by-(K+N) part C of this array must contain the matrix A. C On exit with LTRA = .FALSE., the leading (K+N)-by-N part C of this array contains the matrix Aout and, in the zero C parts, information about the elementary reflectors used to C compute the reduction. C On exit with LTRA = .TRUE., the leading N-by-(K+N) part of C this array contains the matrix Aout and in the zero parts C information about the elementary reflectors. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,K+N), if LTRA = .FALSE.; C LDA >= MAX(1,N), if LTRA = .TRUE.. C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,K+N) if LTRB = .FALSE. C (LDB,N) if LTRB = .TRUE. C On entry with LTRB = .FALSE., the leading N-by-(K+N) part C of this array must contain the matrix B. C On entry with LTRB = .TRUE., the leading (K+N)-by-N part C of this array must contain the matrix B. C On exit with LTRB = .FALSE., the leading N-by-(K+N) part C of this array contains the matrix Bout and, in the zero C parts, information about the elementary reflectors used to C compute the reduction. C On exit with LTRB = .TRUE., the leading (K+N)-by-N part of C this array contains the matrix Bout and in the zero parts C information about the elementary reflectors. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N), if LTRB = .FALSE.; C LDB >= MAX(1,K+N), if LTRB = .TRUE.. C C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) C On entry, the leading N-by-N part of this array must C contain the matrix G. C On exit, the leading N-by-N part of this array contains C the matrix Gout. C C LDG INTEGER C The leading dimension of the array G. LDG >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, the leading N-by-N part of this array must C contain the matrix Q. C On exit, the leading N-by-N part of this array contains C the matrix Qout and in the zero parts information about C the elementary reflectors used to compute the reduction. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= MAX(1,N). C C XA (output) DOUBLE PRECISION array, dimension (LDXA,2*NB) C On exit, the leading N-by-(2*NB) part of this array C contains the matrix XA. C C LDXA INTEGER C The leading dimension of the array XA. LDXA >= MAX(1,N). C C XB (output) DOUBLE PRECISION array, dimension (LDXB,2*NB) C On exit, the leading (K+N)-by-(2*NB) part of this array C contains the matrix XB. C C LDXB INTEGER C The leading dimension of the array XB. LDXB >= MAX(1,K+N). C C XG (output) DOUBLE PRECISION array, dimension (LDXG,2*NB) C On exit, the leading (K+N)-by-(2*NB) part of this array C contains the matrix XG. C C LDXG INTEGER C The leading dimension of the array XG. LDXG >= MAX(1,K+N). C C XQ (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB) C On exit, the leading N-by-(2*NB) part of this array C contains the matrix XQ. C C LDXQ INTEGER C The leading dimension of the array XQ. LDXQ >= MAX(1,N). C C YA (output) DOUBLE PRECISION array, dimension (LDYA,2*NB) C On exit, the leading (K+N)-by-(2*NB) part of this array C contains the matrix YA. C C LDYA INTEGER C The leading dimension of the array YA. LDYA >= MAX(1,K+N). C C YB (output) DOUBLE PRECISION array, dimension (LDYB,2*NB) C On exit, the leading N-by-(2*NB) part of this array C contains the matrix YB. C C LDYB INTEGER C The leading dimension of the array YB. LDYB >= MAX(1,N). C C YG (output) DOUBLE PRECISION array, dimension (LDYG,2*NB) C On exit, the leading (K+N)-by-(2*NB) part of this array C contains the matrix YG. C C LDYG INTEGER C The leading dimension of the array YG. LDYG >= MAX(1,K+N). C C YQ (output) DOUBLE PRECISION array, dimension (LDYQ,2*NB) C On exit, the leading N-by-(2*NB) part of this array C contains the matrix YQ. C C LDYQ INTEGER C The leading dimension of the array YQ. LDYQ >= MAX(1,N). C C CSL (output) DOUBLE PRECISION array, dimension (2*NB) C On exit, the first 2NB elements of this array contain the C cosines and sines of the symplectic Givens rotations C applied from the left-hand side used to compute the C reduction. C C CSR (output) DOUBLE PRECISION array, dimension (2*NB) C On exit, the first 2NB-2 elements of this array contain C the cosines and sines of the symplectic Givens rotations C applied from the right-hand side used to compute the C reduction. C C TAUL (output) DOUBLE PRECISION array, dimension (NB) C On exit, the first NB elements of this array contain the C scalar factors of some of the elementary reflectors C applied form the left-hand side. C C TAUR (output) DOUBLE PRECISION array, dimension (NB) C On exit, the first NB-1 elements of this array contain the C scalar factors of some of the elementary reflectors C applied form the right-hand side. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (5*NB) C C METHOD C C For details regarding the representation of the orthogonal C symplectic matrices UU and VV within the arrays A, B, CSL, CSR, Q, C TAUL and TAUR see the description of MB04TB. C C The contents of A, B, G and Q on exit are illustrated by the C following example with op(A) = A, op(B) = B, n = 5, k = 2 and C nb = 2: C C ( a r r a a ) ( g g g r r g g ) C ( a r r a a ) ( g g g r r g g ) C ( r r r r r ) ( r r r r r r r ) C A = ( u2 r r r r ), G = ( r r r r r r r ), C ( u2 u2 r a a ) ( g g g r r g g ) C ( u2 u2 r a a ) ( g g g r r g g ) C ( u2 u2 r a a ) ( g g g r r g g ) C C ( t t v1 v1 v1 ) ( r r r r r v2 v2 ) C ( u1 t t v1 v1 ) ( r r r r r r v2 ) C Q = ( u1 u1 r q q ), B = ( b b b r r b b ). C ( u1 u1 r q q ) ( b b b r r b b ) C ( u1 u1 r q q ) ( b b b r r b b ) C C where a, b, g and q denote elements of the original matrices, r C denotes a modified element, t denotes a scalar factor of an C applied elementary reflector, ui and vi denote elements of the C matrices U and V, respectively. C C NUMERICAL ASPECTS C C The algorithm requires ( 16*K + 32*N + 42 )*N*NB + C ( 16*K + 112*N - 208/3*NB - 69 )*NB*NB - 29/3*NB floating point C operations and is numerically backward stable. C C REFERENCES C C [1] Benner, P., Mehrmann, V., and Xu, H. C A numerically stable, structure preserving method for C computing the eigenvalues of real Hamiltonian or symplectic C pencils. C Numer. Math., Vol. 78 (3), pp. 329-358, 1998. C C [2] Kressner, D. C Block algorithms for orthogonal symplectic factorizations. C BIT Numerical Mathematics, 43 (4), pp. 775-790, 2003. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLASUB). C C KEYWORDS C C Elementary matrix operations, Matrix decompositions, Hamiltonian C matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. LOGICAL LTRA, LTRB INTEGER K, LDA, LDB, LDG, LDQ, LDXA, LDXB, LDXG, LDXQ, $ LDYA, LDYB, LDYG, LDYQ, N, NB C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*), $ XA(LDXA,*), XB(LDXB,*), XG(LDXG,*), XQ(LDXQ,*), $ YA(LDYA,*), YB(LDYB,*), YG(LDYG,*), YQ(LDYQ,*) C .. Local Scalars .. INTEGER I, J, NB1, NB2, NB3, PDW DOUBLE PRECISION ALPHA, C, S, TAUQ, TEMP C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. External Subroutines .. EXTERNAL DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL C C .. Executable Statements .. C C Quick return if possible. C IF ( N+K.LE.0 ) THEN RETURN END IF C NB1 = NB + 1 NB2 = NB + NB NB3 = NB2 + NB PDW = NB3 + NB + 1 C IF ( LTRA.AND.LTRB ) THEN DO 90 I = 1, NB C C Transform first row/column of A and Q. See routine MB04TS. C ALPHA = Q(I,I) CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) Q(I,I) = ONE TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA ) CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA ) TEMP = A(I,K+I) CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) ) CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) ) TEMP = A(I,K+I) A(I,K+I) = ONE C C Update XQ with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, $ Q(I,I), 1, ZERO, DWORK, 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, $ DWORK, 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA, $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) C C Update Q(i,i+1:n). C CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) C C Update XA with first Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), $ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, $ DWORK, 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, $ Q(I,I), 1, ZERO, XA(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, $ Q(I,I), 1, ZERO, XA(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) C C Update A(i+1:n,k+i). C CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 ) C C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ]. C CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S ) C C Update XQ with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, $ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA, $ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) C C Update Q(i,i+1:n). C CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) C C Update XA with second Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), $ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) C C Update A(i+1:n,k+i). C CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 ) C C Update XG with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, $ Q(I,I), 1, ZERO, XG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, $ DWORK, 1, ONE, XG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) C C Update G(k+i,:). C CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) C C Update XB with first Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB, $ Q(I,I), 1, ZERO, XB(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, $ DWORK, 1, ONE, XB(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) C C Update B(:,i). C CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, $ Q(I,1), LDQ, ONE, B(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, A(1,K+I), 1, ONE, B(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 ) C C Apply rotation to [ G(k+i,:); B(:,i)' ]. C CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S ) C DO 10 J = 1, I-1 YG(K+I,J) = ZERO 10 CONTINUE DO 20 J = 1, I-1 YG(K+I,NB+J) = ZERO 20 CONTINUE DO 30 J = 1, I-1 YA(K+I,J) = ZERO 30 CONTINUE DO 40 J = 1, I-1 YA(K+I,NB+J) = ZERO 40 CONTINUE C C Update XG with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, $ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) C C Update G(k+i,:). C CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) C C Update XB with second Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB, $ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) C C Update B(:,i). C CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 ) C A(I,K+I) = TEMP Q(I,I) = TAUQ CSL(2*I-1) = C CSL(2*I) = S C C Transform first row/column of Q and B. C ALPHA = Q(I,I+1) CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) Q(I,I+1) = ONE TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) TEMP = B(K+I+1,I) CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) ) S = -S CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) ) TEMP = B(K+I+1,I) B(K+I+1,I) = ONE C C Update YB with first Householder reflection. C CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, $ DWORK, 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) C C Update B(k+i+1,i+1:n). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB ) CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, $ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB ) C C Update YQ with first Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, $ DWORK, 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) C C Update Q(i+1:n,i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 ) C C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ]. C CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S ) DO 50 J = 1, I XB(K+I+1,J) = ZERO 50 CONTINUE DO 60 J = 1, I XB(K+I+1,NB+J) = ZERO 60 CONTINUE C C Update YB with second Householder reflection. C CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), $ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, $ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1), $ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) C C Update B(k+i+1,i+1:n). C CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB ) C C Update YQ with second Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, $ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) C C Update Q(i+1:n,i+1). C CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) C C Update YA with first Householder reflection. C CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, $ DWORK, 1, ONE, YA(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) C C Update A(i+1,1:k+n). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA ) CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, $ Q(1,I+1), 1, ONE, A(I+1,1), LDA ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ B(K+I+1,1), LDB, ONE, A(I+1,1), LDA ) C C Update YG with first Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, $ DWORK, 1, ONE, YG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) C C Update G(1:k+n,k+i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 ) DO 70 J = 1, I XG(K+I+1,J) = ZERO 70 CONTINUE DO 80 J = 1, I XG(K+I+1,NB+J) = ZERO 80 CONTINUE C C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ]. C CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S ) C C Update YA with second Householder reflection. C CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, $ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) C C Update A(i+1,1:k+n). C CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA ) C C Update YG with second Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, $ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) C C Update G(1:k+n,k+i+1). C CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) C B(K+I+1,I) = TEMP Q(I,I+1) = TAUQ CSR(2*I-1) = C CSR(2*I) = S 90 CONTINUE ELSE IF ( LTRA ) THEN DO 180 I = 1, NB C C Transform first row/column of A and Q. See routine MB04TS. C ALPHA = Q(I,I) CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) Q(I,I) = ONE TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA ) CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA ) TEMP = A(I,K+I) CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) ) CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) ) TEMP = A(I,K+I) A(I,K+I) = ONE C C Update XQ with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, $ Q(I,I), 1, ZERO, DWORK, 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, $ DWORK, 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA, $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) C C Update Q(i,i+1:n). C CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) C C Update XA with first Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), $ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, $ DWORK, 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, $ Q(I,I), 1, ZERO, XA(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, $ Q(I,I), 1, ZERO, XA(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) C C Update A(i+1:n,k+i). C CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 ) C C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ]. C CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S ) C C Update XQ with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, $ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA, $ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) C C Update Q(i,i+1:n). C CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) C C Update XA with second Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), $ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) C C Update A(i+1:n,k+i). C CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 ) C C Update XG with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, $ Q(I,I), 1, ZERO, XG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, $ DWORK, 1, ONE, XG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) C C Update G(k+i,:). C CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) C C Update XB with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, $ Q(I,I), 1, ZERO, XB(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, $ DWORK, 1, ONE, XB(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) C C Update B(i,:). C CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, $ Q(I,1), LDQ, ONE, B(I,1), LDB ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, A(1,K+I), 1, ONE, B(I,1), LDB ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB ) C C Apply rotation to [ G(k+i,:); B(i,:) ]. C CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S ) C DO 100 J = 1, I-1 YG(K+I,J) = ZERO 100 CONTINUE DO 110 J = 1, I-1 YG(K+I,NB+J) = ZERO 110 CONTINUE DO 120 J = 1, I-1 YA(K+I,J) = ZERO 120 CONTINUE DO 130 J = 1, I-1 YA(K+I,NB+J) = ZERO 130 CONTINUE C C Update XG with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, $ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) C C Update G(k+i,:). C CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) C C Update XB with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, $ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) C C Update B(i,:). C CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB ) C A(I,K+I) = TEMP Q(I,I) = TAUQ CSL(2*I-1) = C CSL(2*I) = S C C Transform first rows of Q and B. C ALPHA = Q(I,I+1) CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) Q(I,I+1) = ONE TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) TEMP = B(I,K+I+1) CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) ) S = -S CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) ) TEMP = B(I,K+I+1) B(I,K+I+1) = ONE C C Update YB with first Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, $ DWORK, 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) C C Update B(i+1:n,k+i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, $ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 ) C C Update YQ with first Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, $ DWORK, 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) C C Update Q(i+1:n,i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 ) C C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ]. C CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S ) DO 140 J = 1, I XB(K+I+1,J) = ZERO 140 CONTINUE DO 150 J = 1, I XB(K+I+1,NB+J) = ZERO 150 CONTINUE C C Update YB with second Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), $ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, $ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2), $ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) C C Update B(i+1:n,k+i+1). C CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 ) C C Update YQ with second Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, $ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) C C Update Q(i+1:n,i+1). C CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) C C Update YA with first Householder reflection. C CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, $ DWORK, 1, ONE, YA(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) C C Update A(i+1,1:k+n). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA ) CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, $ Q(1,I+1), 1, ONE, A(I+1,1), LDA ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ B(1,K+I+1), 1, ONE, A(I+1,1), LDA ) C C Update YG with first Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, $ DWORK, 1, ONE, YG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) C C Update G(1:k+n,k+i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 ) DO 160 J = 1, I XG(K+I+1,J) = ZERO 160 CONTINUE DO 170 J = 1, I XG(K+I+1,NB+J) = ZERO 170 CONTINUE C C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ]. C CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S ) C C Update YA with second Householder reflection. C CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, $ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) C C Update A(i+1,1:k+n). C CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA ) C C Update YG with second Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, $ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) C C Update G(1:k+n,k+i+1). C CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) C B(I,K+I+1) = TEMP Q(I,I+1) = TAUQ CSR(2*I-1) = C CSR(2*I) = S 180 CONTINUE C ELSE IF ( LTRB ) THEN DO 270 I = 1, NB C C Transform first columns of A and Q. See routine MB04TS. C ALPHA = Q(I,I) CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) Q(I,I) = ONE TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 ) CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 ) TEMP = A(K+I,I) CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) ) CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) ) TEMP = A(K+I,I) A(K+I,I) = ONE C C Update XQ with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, $ Q(I,I), 1, ZERO, DWORK, 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, $ DWORK, 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA, $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) C C Update Q(i,i+1:n). C CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) C C Update XA with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, $ Q(I,I), 1, ZERO, XA(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, $ DWORK, 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, $ Q(I,I), 1, ZERO, XA(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, $ Q(I,I), 1, ZERO, XA(1,I), 1 ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) C C Update A(k+i,i+1:n). C CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA ) C C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ]. C CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S ) C C Update XQ with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, $ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) C C Update Q(i,i+1:n). C CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) C C Update XA with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, $ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) C C Update A(k+i,i+1:n). C CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA ) C C Update XG with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, $ Q(I,I), 1, ZERO, XG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, $ DWORK, 1, ONE, XG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) C C Update G(k+i,:). C CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) C C Update XB with first Householder reflection. C CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB, $ Q(I,I), 1, ZERO, XB(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, $ DWORK, 1, ONE, XB(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) C C Update B(:,i). C CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, $ Q(I,1), LDQ, ONE, B(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, A(K+I,1), LDA, ONE, B(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 ) C C Apply rotation to [ G(k+i,:); B(:,i)' ]. C CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S ) C DO 190 J = 1, I-1 YG(K+I,J) = ZERO 190 CONTINUE DO 200 J = 1, I-1 YG(K+I,NB+J) = ZERO 200 CONTINUE DO 210 J = 1, I-1 YA(K+I,J) = ZERO 210 CONTINUE DO 220 J = 1, I-1 YA(K+I,NB+J) = ZERO 220 CONTINUE C C Update XG with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, $ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) C C Update G(k+i,:). C CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) C C Update XB with second Householder reflection. C CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB, $ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) C C Update B(:,i). C CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 ) C A(K+I,I) = TEMP Q(I,I) = TAUQ CSL(2*I-1) = C CSL(2*I) = S C C Transform first rows of Q and B. C ALPHA = Q(I,I+1) CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) Q(I,I+1) = ONE TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) TEMP = B(K+I+1,I) CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) ) S = -S CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) ) TEMP = B(K+I+1,I) B(K+I+1,I) = ONE C C Update YB with first Householder reflection. C CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, $ DWORK, 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) C C Update B(k+i+1,i+1:n). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB ) CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, $ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB ) C C Update YQ with first Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, $ DWORK, 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) C C Update Q(i+1:n,i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 ) C C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ]. C CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S ) DO 230 J = 1, I XB(K+I+1,J) = ZERO 230 CONTINUE DO 240 J = 1, I XB(K+I+1,NB+J) = ZERO 240 CONTINUE C C Update YB with second Householder reflection. C CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), $ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, $ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1), $ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) C C Update B(k+i+1,i+1:n). C CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB ) C C Update YQ with second Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, $ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) C C Update Q(i+1:n,i+1). C CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) C C Update YA with first Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, $ DWORK, 1, ONE, YA(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) C C Update A(1:k+n,i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, $ Q(1,I+1), 1, ONE, A(1,I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ B(K+I+1,1), LDB, ONE, A(1,I+1), 1 ) C C Update YG with first Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, $ DWORK, 1, ONE, YG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) C C Update G(1:k+n,k+i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 ) DO 250 J = 1, I XG(K+I+1,J) = ZERO 250 CONTINUE DO 260 J = 1, I XG(K+I+1,NB+J) = ZERO 260 CONTINUE C C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ]. C CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S ) C C Update YA with second Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, $ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) C C Update A(1:k+n,i+1). C CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 ) C C Update YG with second Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, $ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) C C Update G(1:k+n,k+i+1). C CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) C B(K+I+1,I) = TEMP Q(I,I+1) = TAUQ CSR(2*I-1) = C CSR(2*I) = S 270 CONTINUE C ELSE DO 360 I = 1, NB C C Transform first columns of A and Q. See routine MB04TS. C ALPHA = Q(I,I) CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) Q(I,I) = ONE TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 ) CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 ) TEMP = A(K+I,I) CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) ) CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) ) TEMP = A(K+I,I) A(K+I,I) = ONE C C Update XQ with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, $ Q(I,I), 1, ZERO, DWORK, 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, $ DWORK, 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA, $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) C C Update Q(i,i+1:n). C CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) C C Update XA with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, $ Q(I,I), 1, ZERO, XA(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, $ DWORK, 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, $ Q(I,I), 1, ZERO, XA(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, $ Q(I,I), 1, ZERO, XA(1,I), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) C C Update A(k+i,i+1:n). C CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA ) C C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ]. C CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S ) C C Update XQ with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, $ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) C C Update Q(i,i+1:n). C CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) C C Update XA with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, $ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) C C Update A(k+i,i+1:n). C CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA ) C C Update XG with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, $ Q(I,I), 1, ZERO, XG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, $ DWORK, 1, ONE, XG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) C C Update G(k+i,:). C CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) C C Update XB with first Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, $ Q(I,I), 1, ZERO, XB(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, $ DWORK, 1, ONE, XB(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) C C Update B(i,:). C CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, $ Q(I,1), LDQ, ONE, B(I,1), LDB ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, A(K+I,1), LDA, ONE, B(I,1), LDB ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB ) C C Apply rotation to [ G(k+i,:); B(i,:) ]. C CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S ) C DO 280 J = 1, I-1 YG(K+I,J) = ZERO 280 CONTINUE DO 290 J = 1, I-1 YG(K+I,NB+J) = ZERO 290 CONTINUE DO 300 J = 1, I-1 YA(K+I,J) = ZERO 300 CONTINUE DO 310 J = 1, I-1 YA(K+I,NB+J) = ZERO 310 CONTINUE C C Update XG with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, $ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) C C Update G(k+i,:). C CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) C C Update XB with second Householder reflection. C CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, $ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) C C Update B(i,:). C CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB ) C A(K+I,I) = TEMP Q(I,I) = TAUQ CSL(2*I-1) = C CSL(2*I) = S C C Transform first rows of Q and B. C ALPHA = Q(I,I+1) CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) Q(I,I+1) = ONE TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) TEMP = B(I,K+I+1) CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) ) S = -S CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) ) TEMP = B(I,K+I+1) B(I,K+I+1) = ONE C C Update YB with first Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, $ DWORK, 1, ONE, YB(I+1,I), 1 ) CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) C C Update B(i+1:n,k+i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, $ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 ) C C Update YQ with first Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, $ DWORK, 1, ONE, YQ(I+1,I), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) C C Update Q(i+1:n,i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 ) C C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ]. C CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S ) DO 320 J = 1, I XB(K+I+1,J) = ZERO 320 CONTINUE DO 330 J = 1, I XB(K+I+1,NB+J) = ZERO 330 CONTINUE C C Update YB with second Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), $ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, $ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2), $ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) C C Update B(i+1:n,k+i+1). C CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 ) C C Update YQ with second Householder reflection. C CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, $ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) C C Update Q(i+1:n,i+1). C CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) C C Update YA with first Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, $ DWORK, 1, ONE, YA(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) C C Update A(1:k+n,i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, $ Q(1,I+1), 1, ONE, A(1,I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ B(1,K+I+1), 1, ONE, A(1,I+1), 1 ) C C Update YG with first Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, $ DWORK, 1, ONE, YG(1,I), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) C C Update G(1:k+n,k+i+1). C CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 ) DO 340 J = 1, I XG(K+I+1,J) = ZERO 340 CONTINUE DO 350 J = 1, I XG(K+I+1,NB+J) = ZERO 350 CONTINUE C C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ]. C CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S ) C C Update YA with second Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, $ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) C C Update A(1:k+n,i+1). C CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 ) C C Update YG with second Householder reflection. C CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, $ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) C C Update G(1:k+n,k+i+1). C CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) C B(I,K+I+1) = TEMP Q(I,I+1) = TAUQ CSR(2*I-1) = C CSR(2*I) = S 360 CONTINUE END IF C RETURN C *** Last line of MB03XU *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BF.f0000644000000000000000000000013015012430707016147 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/NF01BF.f0000644000175000017500000001214015012430707017343 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BF( IFLAG, NFUN, LX, IPAR, LIPAR, U, LDU, Y, LDY, $ X, NFEVL, E, J, LDJ, DWORK, LDWORK, INFO ) C C PURPOSE C C This is the FCN routine for optimizing all parameters of a Wiener C system using SLICOT Library routine MD03BD. See the argument FCN C in the routine MD03BD for the description of parameters. C C ****************************************************************** C C .. Parameters .. C .. CJTE is initialized to avoid the calculation of J'*e .. C .. NOUT is the unit number for printing intermediate results .. CHARACTER CJTE PARAMETER ( CJTE = 'N' ) INTEGER NOUT PARAMETER ( NOUT = 6 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER IFLAG, INFO, LDJ, LDU, LDWORK, LDY, LIPAR, LX, $ NFEVL, NFUN C .. Array Arguments .. INTEGER IPAR(*) DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), U(LDU,*), X(*), $ Y(LDY,*) C .. Local Scalars .. LOGICAL FULL INTEGER BSN, I, JWORK, L, M, N, NN, NSMP, ST DOUBLE PRECISION ERR C .. External Functions .. DOUBLE PRECISION DNRM2 EXTERNAL DNRM2 C .. External Subroutines .. EXTERNAL DAXPY, NF01AD, NF01BD C C .. Executable Statements .. C L = IPAR(2) M = IPAR(5) N = IPAR(6) IF ( L.EQ.0 ) THEN NSMP = NFUN ELSE NSMP = NFUN/L END IF C INFO = 0 IF ( IFLAG.EQ.1 ) THEN C C Call NF01AD to compute the output y of the Wiener system (in E) C and then the error functions (also in E). The array U must C contain the input to the linear part of the Wiener system, and C Y must contain the original output Y of the Wiener system. C IPAR(6) must contain the number of states of the linear part, n. C Workspace: need: NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + C MAX( N*(N + L), N + M + L ) ), C if M>0, C NFUN + MAX( 2*NN, (N + L)*N + 2*N + C MAX( N*(N + L), L ) ), if M=0, C where NN = IPAR(7) (number of neurons); C prefer: larger. C CALL NF01AD( NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, LDU, E, $ NSMP, DWORK, LDWORK, INFO ) C DO 10 I = 1, L CALL DAXPY( NSMP, -ONE, Y(1,I), 1, E((I-1)*NSMP+1), 1 ) 10 CONTINUE C DWORK(1) = NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + $ MAX( N*(N + L), N + M + L ) ) C ELSE IF ( IFLAG.EQ.2 ) THEN C C Call NF01BD to compute the Jacobian in a compressed form. C Workspace: need: 2*NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + C MAX( N*(N + L), N + M + L )), C if M > 0, C 2*NFUN + MAX( 2*NN, (N + L)*N + 2*N + C MAX( N*(N + L), L ) ), C if M > 0; C prefer: larger. C CALL NF01BD( CJTE, NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, $ LDU, E, J, LDJ, DWORK, DWORK, LDWORK, INFO ) NFEVL = IPAR(6)*( M + L + 1 ) + L*M DWORK(1) = 2*NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + $ MAX( N*(N + L), N + M + L ) ) C ELSE IF ( IFLAG.EQ.3 ) THEN C C Set the parameter LDJ, the length of the array J, and the sizes C of the workspace for FCN (IFLAG = 1 or 2), QRFACT and LMPARM. C Condition estimation (COND = 'E') is assumed in these routines. C ST = IPAR(1) BSN = IPAR(4) NN = IPAR(7) FULL = L.LE.1 .OR. BSN.EQ.0 C LDJ = NFUN IPAR(1) = LDJ*( BSN + ST ) IF ( M.GT.0 ) THEN JWORK = MAX( N*( N + L ), N + M + L ) ELSE JWORK = MAX( N*( N + L ), L ) END IF IPAR(2) = LDJ + MAX( (N + L)*(N + M) + 2*N + JWORK, 2*NN ) IPAR(3) = LDJ + IPAR(2) JWORK = 1 IF ( FULL ) THEN JWORK = 4*LX + 1 ELSEIF ( BSN.GT.0 ) THEN JWORK = BSN + MAX( 3*BSN + 1, ST ) IF ( NSMP.GT.BSN ) THEN JWORK = MAX( JWORK, 4*ST + 1 ) IF ( NSMP.LT.2*BSN ) $ JWORK = MAX( JWORK, ( NSMP - BSN )*( L - 1 ) ) END IF END IF IPAR(4) = JWORK IF ( FULL ) THEN JWORK = 4*LX ELSE JWORK = ST*( LX - ST ) + 2*LX + 2*MAX( BSN, ST ) END IF IPAR(5) = JWORK C ELSE IF ( IFLAG.EQ.0 ) THEN C C Special call for printing intermediate results. C ERR = DNRM2( NFUN, E, 1 ) WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR END IF RETURN C C *** Last line of NF01BF *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03KA.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03KA.f0000644000175000017500000005521315012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE MB03KA( COMPQ, WHICHQ, WS, K, NC, KSCHUR, IFST, ILST, $ N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To reorder the diagonal blocks of the formal matrix product C C T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1), (1) C C of length K, in the generalized periodic Schur form C C [ T11_k T12_k T13_k ] C T_k = [ 0 T22_k T23_k ], k = 1, ..., K, (2) C [ 0 0 T33_k ] C C where C C - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or C NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced C infinite eigenvalues, C - the submatrices T22_k are NC-by-NC and contain core eigenvalues, C which are generically neither zero nor infinite, C - the submatrices T33_k contain dimension-induced zero C eigenvalues, C C such that the block with starting row index IFST in (1) is moved C to row index ILST. The indices refer to the T22_k submatrices. C C Optionally, the transformation matrices Q_1,...,Q_K from the C reduction into generalized periodic Schur form are updated with C respect to the performed reordering. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C = 'N': do not compute any of the matrices Q_k; C = 'U': each coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the products Q1_k*Q_k are C returned, where Q_k, k = 1, ..., K, performed the C reordering; C = 'W': the computation of each Q_k is specified C individually in the array WHICHQ. C C WHICHQ INTEGER array, dimension (K) C If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k C as follows: C = 0: do not compute Q_k; C > 0: the kth coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the product Q1_k*Q_k is C returned. C This array is not referenced if COMPQ <> 'W'. C C WS LOGICAL C = .FALSE. : do not perform the strong stability tests; C = .TRUE. : perform the strong stability tests; often, C this is not needed, and omitting them can save C some computations. C C Input/Output Parameters C C K (input) INTEGER C The period of the periodic matrix sequences T and Q (the C number of factors in the matrix product). K >= 2. C (For K = 1, a standard eigenvalue reordering problem is C obtained.) C C NC (input) INTEGER C The number of core eigenvalues. 0 <= NC <= min(N). C C KSCHUR (input) INTEGER C The index for which the matrix T22_kschur is upper quasi- C triangular. All other T22 matrices are upper triangular. C C IFST (input/output) INTEGER C ILST (input/output) INTEGER C Specify the reordering of the diagonal blocks, as follows: C The block with starting row index IFST in (1) is moved to C row index ILST by a sequence of direct swaps between adjacent C blocks in the product. C On exit, if IFST pointed on entry to the second row of a C 2-by-2 block in the product, it is changed to point to the C first row; ILST always points to the first row of the block C in its final position in the product (which may differ from C its input value by +1 or -1). C 1 <= IFST <= NC, 1 <= ILST <= NC. C C N (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the formal matrix product T, C such that the k-th coefficient T_k is an N(k+1)-by-N(k) C matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix, C if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1). C C NI (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the matrix sequence T11_k. C N(k) >= NI(k) + NC >= 0. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures (exponents) of the factors in the K-periodic C matrix sequence. Each entry in S must be either 1 or -1; C the value S(k) = -1 corresponds to using the inverse of C the factor T_k. C C T (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXT(k) the C matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1, C or at least N(k)-by-N(k+1), if S(k) = -1, in periodic C Schur form. C On exit, the matrices T_k are overwritten by the reordered C periodic Schur form. C C LDT INTEGER array, dimension (K) C The leading dimensions of the matrices T_k in the one- C dimensional array T. C LDT(k) >= max(1,N(k+1)), if S(k) = 1, C LDT(k) >= max(1,N(k)), if S(k) = -1. C C IXT INTEGER array, dimension (K) C Start indices of the matrices T_k in the one-dimensional C array T. C C Q (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXQ(k) a C matrix Q_k of size at least N(k)-by-N(k), provided that C COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0. C On exit, if COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0, C Q_k is post-multiplied with the orthogonal matrix that C performed the reordering. C This array is not referenced if COMPQ = 'N'. C C LDQ INTEGER array, dimension (K) C The leading dimensions of the matrices Q_k in the one- C dimensional array Q. C LDQ(k) >= max(1,N(k)), if COMPQ = 'U', or COMPQ = 'W' and C WHICHQ(k) > 0; C This array is not referenced if COMPQ = 'N'. C C IXQ INTEGER array, dimension (K) C Start indices of the matrices Q_k in the one-dimensional C array Q. C This array is not referenced if COMPQ = 'N'. C C Tolerances C C TOL DOUBLE PRECISION array, dimension (3) C This array contains tolerance parameters. The weak and C strong stability tests use a threshold computed by the C formula MAX( c*EPS*NRM, SMLNUM ), where c is a constant, C NRM is the Frobenius norm of the current matrix formed by C concatenating K pairs of adjacent diagonal blocks of sizes C 1 and/or 2 in the T22_k submatrices from (2), which are C swapped, and EPS and SMLNUM are the machine precision and C safe minimum divided by EPS, respectively (see LAPACK C Library routine DLAMCH). The norm NRM is computed by this C routine; the other values are stored in the array TOL. C TOL(1), TOL(2), and TOL(3) contain c, EPS, and SMLNUM, C respectively. TOL(1) should normally be at least 10. C C Workspace C C IWORK INTEGER array, dimension (4*K) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= 10*K + MN, if all blocks between IFST and ILST C have order 1; C LDWORK >= 25*K + MN, if there is at least a block of C order 2, but no adjacent blocks of C order 2 can appear between IFST and C ILST during reordering; C LDWORK >= MAX(42*K + MN, 80*K - 48), if at least a pair of C adjacent blocks of order 2 can appear C between IFST and ILST during C reordering; C where MN = MXN, if MXN > 10, and MN = 0, otherwise, with C MXN = MAX(N(k),k=1,...,K). C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C < 0: if INFO = -21, the LDWORK argument was too small; C = 1: the reordering of T failed because some eigenvalues C are too close to separate (the problem is very ill- C conditioned); T may have been partially reordered. C The returned value of ILST is the index where this C was detected. C C METHOD C C An adaptation of the LAPACK Library routine DTGEXC is used. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C C CONTRIBUTOR C C R. Granat, Umea University, Sweden, Apr. 2008. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Mar. 2010, SLICOT Library version of the PEP routine PEP_DTGEXC. C V. Sima, July 2010. C C KEYWORDS C C Orthogonal transformation, periodic QZ algorithm, periodic C Sylvester-like equations, QZ algorithm. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER COMPQ LOGICAL WS INTEGER IFST, ILST, INFO, K, KSCHUR, LDWORK, NC C .. C .. Array Arguments .. INTEGER IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ), $ LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * ) DOUBLE PRECISION DWORK( * ), Q( * ), T( * ), TOL( * ) C .. C .. Local Scalars .. INTEGER HERE, I, IP1, IT, MINWRK, NBF, NBL, NBNEXT C .. C .. External Subroutines .. EXTERNAL MB03KB, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MOD C .. C .. Executable Statements .. C C For efficiency reasons the parameters are not checked, except for C workspace. C IF( NC.EQ.2 ) THEN NBF = 1 NBL = 1 ELSE IF( NC.EQ.3 ) THEN NBF = 1 NBL = 2 ELSE NBF = 2 NBL = 2 END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, 1, NBF, NBL, N, NI, $ S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK, DWORK, -1, $ INFO ) MINWRK = MAX( 1, INT( DWORK(1) ) ) IF( LDWORK.NE.-1 .AND. LDWORK.LT.MINWRK ) $ INFO = -21 C C Quick return if possible C IF( LDWORK.EQ.-1 ) THEN DWORK(1) = DBLE( MINWRK ) RETURN ELSE IF( INFO.LT.0 ) THEN CALL XERBLA( 'MB03KA', -INFO ) RETURN END IF C C Set I and IP1 to point to KSCHUR and KSCHUR+1 to simplify C indices below. C I = KSCHUR IP1 = MOD( I, K ) + 1 C C Determine the first row of the block in T22_kschur corresponding C to the first block in the product and find out if it is 1-by-1 or C 2-by-2. C IF( IFST.GT.1 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + IFST - 2 )*LDT(I) + NI(IP1) + IFST $ - 1 ELSE IT = IXT(I) + ( NI(IP1) + IFST - 2 )*LDT(I) + NI(I) + IFST $ - 1 END IF IF( T( IT ).NE.ZERO ) $ IFST = IFST - 1 END IF NBF = 1 IF( IFST.LT.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + IFST - 1 )*LDT(I) + NI(IP1) + IFST ELSE IT = IXT(I) + ( NI(IP1) + IFST - 1 )*LDT(I) + NI(I) + IFST END IF IF( T( IT ).NE.ZERO ) $ NBF = 2 END IF C C Determine the first row of the block in T_kschur corresponding C to the last block in the product and find out it is 1-by-1 or C 2-by-2. C IF( ILST.GT.1 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + ILST - 2 )*LDT(I) + NI(IP1) + ILST $ - 1 ELSE IT = IXT(I) + ( NI(IP1) + ILST - 2 )*LDT(I) + NI(I) + ILST $ - 1 END IF IF( T( IT ).NE.ZERO ) $ ILST = ILST - 1 END IF NBL = 1 IF( ILST.LT.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + ILST - 1 )*LDT(I) + NI(IP1) + ILST ELSE IT = IXT(I) + ( NI(IP1) + ILST - 1 )*LDT(I) + NI(I) + ILST END IF IF( T( IT ).NE.ZERO ) $ NBL = 2 END IF C C If the specified and last block in the product were the same, C return. C IF( IFST.EQ.ILST ) $ RETURN C C If the specified block lies above the last block on the diagonal C of the product and the blocks have unequal sizes, update ILST. C IF( IFST.LT.ILST ) THEN C C Update ILST. C IF( NBF.EQ.2 .AND. NBL.EQ.1 ) $ ILST = ILST - 1 IF( NBF.EQ.1 .AND. NBL.EQ.2 ) $ ILST = ILST + 1 C HERE = IFST C 10 CONTINUE C C Swap a block with next one below. C IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN C C Current next block is either 1-by-1 or 2-by-2. C NBNEXT = 1 IF( HERE+NBF+1.LE.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE + NBF - 1 )*LDT(I) + $ NI(IP1) + HERE + NBF ELSE IT = IXT(I) + ( NI(IP1) + HERE + NBF - 1 )*LDT(I) + $ NI(I) + HERE + NBF END IF IF( T( IT ).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, NBF, $ NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + NBNEXT C C Test if a 2-by-2 block breaks into two 1-by-1 blocks. C IF( NBF.EQ.2 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE - 1 )*LDT(I) + NI(IP1) $ + HERE ELSE IT = IXT(I) + ( NI(IP1) + HERE - 1 )*LDT(I) + NI(I) $ + HERE END IF IF( T( IT ).EQ.ZERO ) $ NBF = 3 END IF ELSE C C Current next block consists of two 1-by-1 blocks each of C which must be swapped individually. C NBNEXT = 1 IF( HERE+3.LE.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE + 1 )*LDT(I) + NI(IP1) + $ HERE + 2 ELSE IT = IXT(I) + ( NI(IP1) + HERE + 1 )*LDT(I) + NI(I) + $ HERE + 2 END IF IF( T( IT ).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE+1, 1, $ NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN C C Swap two 1-by-1 blocks. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, 1, $ NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 1 ELSE C C Recompute NBNEXT in case 2-by-2 split. C IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE )*LDT(I) + NI(IP1) + HERE $ + 1 ELSE IT = IXT(I) + ( NI(IP1) + HERE )*LDT(I) + NI(I) + HERE $ + 1 END IF IF( T( IT ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN C C The 2-by-2 block did not split. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, $ 1, NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, $ IXQ, TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 2 ELSE C C The 2-by-2 block did split. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, $ 1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE+1, $ 1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE + 1 RETURN END IF HERE = HERE + 2 END IF END IF END IF IF( HERE.LT.ILST ) $ GO TO 10 C ELSE C HERE = IFST 20 CONTINUE C C Swap a block with next one above. C IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN C C Current block is either 1-by-1 or 2-by-2. C NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE - 3 )*LDT(I) + NI(IP1) $ + HERE - 2 ELSE IT = IXT(I) + ( NI(IP1) + HERE - 3 )*LDT(I) + NI(I) $ + HERE - 2 END IF IF( T( IT ).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-NBNEXT, $ NBNEXT, NBF, N, NI, S, T, LDT, IXT, Q, LDQ, $ IXQ, TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - NBNEXT C C Test if a 2-by-2 block breaks into two 1-by-1 blocks. C IF( NBF.EQ.2 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE - 1 )*LDT(I) + NI(IP1) $ + HERE ELSE IT = IXT(I) + ( NI(IP1) + HERE - 1 )*LDT(I) + NI(I) $ + HERE END IF IF( T( IT ).EQ.ZERO ) $ NBF = 3 END IF C ELSE C C Current block consists of two 1-by-1 blocks each of which C must be swapped individually. C NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE - 3 )*LDT(I) + NI(IP1) $ + HERE - 2 ELSE IT = IXT(I) + ( NI(IP1) + HERE - 3 )*LDT(I) + NI(I) $ + HERE - 2 END IF IF( T( IT ).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-NBNEXT, $ NBNEXT, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN C C Swap two 1-by-1 blocks. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, $ NBNEXT, 1, N, NI, S, T, LDT, IXT, Q, LDQ, $ IXQ, TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 1 ELSE C C Recompute NBNEXT in case 2-by-2 split. C IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + HERE - 2 )*LDT(I) + NI(IP1) $ + HERE - 1 ELSE IT = IXT(I) + ( NI(IP1) + HERE - 2 )*LDT(I) + NI(I) $ + HERE - 1 END IF IF( T( IT ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN C C The 2-by-2 block did not split. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-1, $ 2, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 2 ELSE C The 2-by-2 block did split. C CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, $ 1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-1, $ 1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOL, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE - 1 RETURN END IF HERE = HERE - 2 END IF END IF END IF IF( HERE.GT.ILST ) $ GO TO 20 END IF ILST = HERE C C Store optimal workspace values and return. C DWORK(1) = DBLE( MINWRK ) RETURN C C *** Last line of MB03KA *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01AD.f0000644000000000000000000000013015012430707016144 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/NF01AD.f0000644000175000017500000001560415012430707017350 0ustar00lilgelilge00000000000000 SUBROUTINE NF01AD( NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, Y, LDY, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To calculate the output y of the Wiener system C C x(t+1) = A*x(t) + B*u(t) C z(t) = C*x(t) + D*u(t), C C y(t) = f(z(t),wb(1:L)), C C where t = 1, 2, ..., NSMP, and f is a nonlinear function, C evaluated by the SLICOT Library routine NF01AY. The parameter C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), C where wb(i), i = 1:L, correspond to the nonlinear part, theta C corresponds to the linear part, and the notation is fully C described below. C C ARGUMENTS C C Input/Output Parameters C C NSMP (input) INTEGER C The number of training samples. NSMP >= 0. C C M (input) INTEGER C The length of each input sample. M >= 0. C C L (input) INTEGER C The length of each output sample. L >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters needed. C IPAR(1) must contain the order of the linear part, C referred to as N below. N >= 0. C IPAR(2) must contain the number of neurons for the C nonlinear part, referred to as NN below. C NN >= 0. C C LIPAR (input) INTEGER C The length of IPAR. LIPAR >= 2. C C X (input) DOUBLE PRECISION array, dimension (LX) C The parameter vector, partitioned as C X = (wb(1), ..., wb(L), theta), where the vectors C wb(i), of length NN*(L+2)+1, are parameters for the C static nonlinearity, which is simulated by the C SLICOT Library routine NF01AY. See the documentation of C NF01AY for further details. The vector theta, of length C N*(M + L + 1) + L*M, represents the matrices A, B, C, C D and x(1), and it can be retrieved from these matrices C by SLICOT Library routine TB01VD and retranslated by C TB01VY. C C LX (input) INTEGER C The length of the array X. C LX >= ( NN*(L+2)+1 )*L + N*(M + L + 1) + L*M. C C U (input) DOUBLE PRECISION array, dimension (LDU, M) C The leading NSMP-by-M part of this array must contain the C set of input samples, C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). C C LDU INTEGER C The leading dimension of the array U. LDU >= MAX(1,NSMP). C C Y (output) DOUBLE PRECISION array, dimension (LDY, L) C The leading NSMP-by-L part of this array contains the C simulated output. C C LDY INTEGER C The leading dimension of the array Y. LDY >= MAX(1,NSMP). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + C MAX( N*(N + L), N + M + L ) ) C if M > 0; C LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + C MAX( N*(N + L), L ) ), if M = 0. C A larger value of LDWORK could improve the efficiency. 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 METHOD C C BLAS routines are used for the matrix-vector multiplications and C the routine NF01AY is called for the calculation of the nonlinear C function. C C CONTRIBUTORS C C A. Riedel, R. Schneider, Chemnitz University of Technology, C Mar. 2001, during a stay at University of Twente, NL. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, C Dec. 2001. C C KEYWORDS C C Nonlinear system, output normal form, simulation, state-space C representation, Wiener system. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INFO, L, LDU, LDWORK, LDY, LX, LIPAR, M, NSMP C .. Array Arguments .. INTEGER IPAR(*) DOUBLE PRECISION DWORK(*), U(LDU,*), X(*), Y(LDY,*) C .. Local Scalars .. INTEGER AC, BD, IX, JW, LDAC, LTHS, N, NN, NTHS, Z C .. External Subroutines .. EXTERNAL NF01AY, TB01VY, TF01MX, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C INFO = 0 IF ( NSMP.LT.0 ) THEN INFO = -1 ELSEIF ( M.LT.0 ) THEN INFO = -2 ELSEIF ( L.LT.0 ) THEN INFO = -3 ELSEIF ( LIPAR.LT.2 ) THEN INFO = -5 ELSE C N = IPAR(1) NN = IPAR(2) LDAC = N + L NTHS = ( NN*( L + 2 ) + 1 )*L LTHS = N*( M + L + 1 ) + L*M C IF ( N.LT.0 .OR. NN.LT.0 ) THEN INFO = -4 ELSEIF ( LX.LT.NTHS + LTHS ) THEN INFO = -7 ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN INFO = -9 ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN INFO = -11 ELSE IF ( M.GT.0 ) THEN JW = MAX( N*LDAC, N + M + L ) ELSE JW = MAX( N*LDAC, L ) END IF IF ( LDWORK.LT.NSMP*L + MAX( 2*NN, LDAC*( N + M ) + 2*N + $ JW ) ) $ INFO = -13 ENDIF ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01AD', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( MIN( NSMP, L ).EQ.0 ) $ RETURN C C Compute the output of the linear part. C Workspace: need NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1). C (NSMP*L locations are reserved for the output of the linear part.) C Z = 1 AC = Z + NSMP*L BD = AC + LDAC*N IX = BD + LDAC*M JW = IX + N C CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC, $ DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), $ LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO ) C C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, if M>0; C NSMP*L + (N + L)*N + 2*N + L, if M=0; C prefer larger. C CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX), $ DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO ) C C Simulate the static nonlinearity. C Workspace: need NSMP*L + 2*NN; C prefer larger. C JW = AC CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z), $ NSMP, Y, LDY, DWORK(JW), LDWORK-JW+1, INFO ) C RETURN C C *** Last line of NF01AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04TV.f0000644000000000000000000000013215012430707016211 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04TV.f0000644000175000017500000001256615012430707017417 0ustar00lilgelilge00000000000000 SUBROUTINE MB04TV( UPDATZ, N, NRA, NCA, IFIRA, IFICA, A, LDA, E, $ LDE, Z, LDZ ) C C PURPOSE C C To reduce a submatrix A(k) of A to upper triangular form by column C Givens rotations only. C Here A(k) = A(IFIRA:ma,IFICA:na) where ma = IFIRA - 1 + NRA, C na = IFICA - 1 + NCA. C Matrix A(k) is assumed to have full row rank on entry. Hence, no C pivoting is done during the reduction process. See Algorithm 2.3.1 C and Remark 2.3.4 in [1]. C The constructed column transformations are also applied to matrix C E(k) = E(1:IFIRA-1,IFICA:na). C Note that in E columns are transformed with the same column C indices as in A, but with row indices different from those in A. C C ARGUMENTS C C Mode Parameters C C UPDATZ LOGICAL C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal column transformations, as C follows: C = .FALSE.: Do not form Z; C = .TRUE.: The given matrix Z is updated by the orthogonal C column transformations used in the reduction. C C Input/Output Parameters C C N (input) INTEGER C Number of columns of A and E. N >= 0. C C NRA (input) INTEGER C Number of rows in A to be transformed. 0 <= NRA <= LDA. C C NCA (input) INTEGER C Number of columns in A to be transformed. 0 <= NCA <= N. C C IFIRA (input) INTEGER C Index of the first row in A to be transformed. C C IFICA (input) INTEGER C Index of the first column in A to be transformed. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the elements of A(IFIRA:ma,IFICA:na) must C contain the submatrix A(k) of full row rank to be reduced C to upper triangular form. C On exit, it contains the transformed matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,NRA). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the elements of E(1:IFIRA-1,IFICA:na) must C contain the submatrix E(k). C On exit, it contains the transformed matrix E. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,IFIRA-1). C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) C On entry, if UPDATZ = .TRUE., then the leading N-by-N C part of this array must contain a given matrix Z (e.g. C from a previous call to another SLICOT routine), and on C exit, the leading N-by-N part of this array contains the C product of the input matrix Z and the column C transformation matrix that has transformed the columns of C the matrices A and E. C If UPDATZ = .FALSE., the array Z is not referenced and C can be supplied as a dummy array (i.e. set parameter C LDZ = 1 and declare this array to be Z(1,1) in the calling C program). C C LDZ INTEGER C The leading dimension of array Z. If UPDATZ = .TRUE., C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. C C REFERENCES C C [1] Beelen, Th. C New Algorithms for Computing the Kronecker structure of a C Pencil with Applications to Systems and Control Theory. C Ph.D.Thesis, Eindhoven University of Technology, C The Netherlands, 1987. 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, Apr. 1997. C Supersedes Release 2.0 routine MB04FV by Th.G.J. Beelen, C Philips Glass Eindhoven, Holland. C C REVISIONS C C - C C KEYWORDS C C Generalized eigenvalue problem, orthogonal transformation, C staircase form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. LOGICAL UPDATZ INTEGER IFICA, IFIRA, LDA, LDE, LDZ, N, NCA, NRA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), E(LDE,*), Z(LDZ,*) C .. Local Scalars .. INTEGER I, IFIRA1, J, JPVT DOUBLE PRECISION SC, SS C .. External Subroutines .. EXTERNAL DROT, DROTG C .. Executable Statements .. C IF ( N.LE.0 .OR. NRA.LE.0 .OR. NCA.LE.0 ) $ RETURN IFIRA1 = IFIRA - 1 JPVT = IFICA + NCA C DO 40 I = IFIRA1 + NRA, IFIRA, -1 JPVT = JPVT - 1 C DO 20 J = JPVT - 1, IFICA, -1 C C Determine the Givens transformation on columns j and jpvt C to annihilate A(i,j). Apply the transformation to these C columns from rows 1 up to i. C Apply the transformation also to the E-matrix (from rows 1 C up to ifira1). C Update column transformation matrix Z, if needed. C CALL DROTG( A(I,JPVT), A(I,J), SC, SS ) CALL DROT( I-1, A(1,JPVT), 1, A(1,J), 1, SC, SS ) A(I,J) = ZERO CALL DROT( IFIRA1, E(1,JPVT), 1, E(1,J), 1, SC, SS ) IF( UPDATZ ) CALL DROT( N, Z(1,JPVT), 1, Z(1,J), 1, SC, SS ) 20 CONTINUE C 40 CONTINUE C RETURN C *** Last line of MB04TV *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03GD.f0000644000000000000000000000013215012430707016151 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03GD.f0000644000175000017500000002633615012430707017357 0ustar00lilgelilge00000000000000 SUBROUTINE MB03GD( N, B, LDB, D, LDD, MACPAR, Q, LDQ, U, LDU, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute an orthogonal matrix Q and an orthogonal symplectic C matrix U for a real regular 2-by-2 or 4-by-4 skew-Hamiltonian/ C Hamiltonian pencil a J B' J' B - b D with C C ( B11 B12 ) ( D11 D12 ) ( 0 I ) C B = ( ), D = ( ), J = ( ), C ( 0 B22 ) ( 0 -D11' ) ( -I 0 ) C C such that J Q' J' D Q and U' B Q keep block triangular form, but C the eigenvalues are reordered. The notation M' denotes the C transpose of the matrix M. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil a J B' J' B - b D. N = 2 or N = 4. C C B (input) DOUBLE PRECISION array, dimension (LDB, N) C The leading N-by-N part of this array must contain the C non-trivial factor of the decomposition of the C skew-Hamiltonian input matrix J B' J' B. The (2,1) block C is not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= N. C C D (input) DOUBLE PRECISION array, dimension (LDD, N) C The leading N/2-by-N part of this array must contain the C first block row of the second matrix of a J B' J' B - b D. C The matrix D has to be Hamiltonian. The strict lower C triangle of the (1,2) block is not referenced. C C LDD INTEGER C The leading dimension of the array D. LDD >= N/2. C C MACPAR (input) DOUBLE PRECISION array, dimension (2) C Machine parameters: C MACPAR(1) (machine precision)*base, DLAMCH( 'P' ); C MACPAR(2) safe minimum, DLAMCH( 'S' ). C This argument is not used for N = 2. C C Q (output) DOUBLE PRECISION array, dimension (LDQ, N) C The leading N-by-N part of this array contains the C orthogonal transformation matrix Q. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= N. C C U (output) DOUBLE PRECISION array, dimension (LDU, N) C The leading N-by-N part of this array contains the C orthogonal symplectic transformation matrix U. C C LDU INTEGER C The leading dimension of the array U. LDU >= N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C If N = 2 then DWORK is not referenced. C C LDWORK INTEGER C The length of the array DWORK. C If N = 2 then LDWORK >= 0; if N = 4 then LDWORK >= 12. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: B11 or B22 is a (numerically) singular matrix. C C METHOD C C The algorithm uses orthogonal transformations as described on page C 22 in [1], but with an improved implementation. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 29, 2008. C V. Sima, Aug. 2009 (SLICOT version of the routine DHAFEX). C C REVISIONS C C V. Sima, Nov. 2009, July 2010, Nov. 2010. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue exchange, skew-Hamiltonian/Hamiltonian pencil, C structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) C C .. Scalar Arguments .. INTEGER INFO, LDB, LDD, LDQ, LDU, LDWORK, N C C .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( LDD, * ), DWORK( * ), $ MACPAR( * ), Q( LDQ, * ), U( LDU, * ) C C .. Local Scalars .. INTEGER I, ICS, IR, ITAU, IWRK1, IWRK2 DOUBLE PRECISION CL1, CL2, CO, CO2, CR1, CR2, EPS, F, F1, G, G1, $ R, R1, S, SFMIN, SI, SI2, SL1, SL2, SMAX1, $ SMAX2, SMIN1, SMIN2, SR1, SR2, T, T1 C C .. External Subroutines .. EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLARTG, DLASV2, $ DORGR2, DORM2R, DSWAP, DSYR2K, MB01RU, MB04SU, $ MB04WU C C .. Intrinsic Functions .. INTRINSIC ABS, MAX C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C INFO = 0 C C Computations. C IF( N.EQ.4 ) THEN C C Set machine constants. C EPS = MACPAR( 1 ) SFMIN = MACPAR( 2 ) C C Compute the first two columns of H = inv( B' )*J'*D*inv( B )*J C in U, using the singular value decompositions of B11 and B22. C CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CO, SI, R ) F = CO*B( 1, 2 ) + SI*B( 2, 2 ) G = CO*B( 2, 2 ) - SI*B( 1, 2 ) CALL DLASV2( R, F, G, SMIN1, SMAX1, SR1, CR1, SL1, CL1 ) IF( ABS( SMIN1 ).LT.MAX( SFMIN, EPS*ABS( SMAX1 ) ) ) THEN INFO = 1 RETURN END IF C CALL DLARTG( B( 3, 3 ), B( 4, 3 ), CO2, SI2, R ) F = CO2*B( 3, 4 ) + SI2*B( 4, 4 ) G = CO2*B( 4, 4 ) - SI2*B( 3, 4 ) CALL DLASV2( R, F, G, SMIN2, SMAX2, SR2, CR2, SL2, CL2 ) IF( ABS( SMIN2 ).LT.MAX( SFMIN, EPS*ABS( SMAX2 ) ) ) THEN INFO = 1 RETURN END IF C C Compute inv( B11' )*D11' and copy it in U12. C R = ( CR1*D( 1, 1 ) + SR1*D( 1, 2 ) )/SMAX1 F = ( CR1*D( 2, 1 ) + SR1*D( 2, 2 ) )/SMAX1 T = ( CR1*D( 1, 2 ) - SR1*D( 1, 1 ) )/SMIN1 G = ( CR1*D( 2, 2 ) - SR1*D( 2, 1 ) )/SMIN1 C R1 = CL1*R - SL1*T F1 = CL1*F - SL1*G T1 = CL1*T + SL1*R G1 = CL1*G + SL1*F C U( 1, 3 ) = CO*R1 - SI*T1 U( 2, 3 ) = CO*T1 + SI*R1 U( 1, 4 ) = CO*F1 - SI*G1 U( 2, 4 ) = CO*G1 + SI*F1 C C Compute D11*inv( B11 )*B12 + B12'*inv( B11' )*D11' - D12 in Q. C Q( 1, 1 ) = D( 1, 3 ) Q( 1, 2 ) = D( 1, 4 ) Q( 2, 2 ) = D( 2, 4 ) C CALL DSYR2K( 'Upper', 'Transpose', 2, 2, ONE, U( 1, 3 ), LDU, $ B( 1, 3 ), LDB, -ONE, Q, LDQ ) C C Compute inv( B22 ) in U22. C R = CR2/SMAX2 T = SR2/SMAX2 F = -SR2/SMIN2 G = CR2/SMIN2 C R1 = CL2*R - SL2*F T1 = CL2*T - SL2*G F1 = CL2*F + SL2*R G1 = CL2*G + SL2*T C U( 3, 3 ) = CO2*R1 - SI2*F1 U( 4, 3 ) = CO2*T1 - SI2*G1 U( 3, 4 ) = CO2*F1 + SI2*R1 U( 4, 4 ) = CO2*G1 + SI2*T1 C C Compute H11 = -inv( B11' )*D11'*inv( B22 ) in U11. C CALL DGEMM( 'No Transpose', 'No Transpose', 2, 2, 2, -ONE, $ U( 1, 3 ), LDU, U( 3, 3 ), LDU, ZERO, U, LDU ) C C Compute H21 = inv( B22' )*Q*inv( B22 ) in U21. C CALL MB01RU( 'Upper', 'Transpose', 2, 2, ZERO, ONE, U( 3, 1 ), $ LDU, U( 3, 3 ), LDU, Q, LDQ, DWORK, 4, INFO ) U( 4, 1 ) = U( 3, 2 ) C S = -( U( 1, 1 ) + U( 2, 2 ) ) C C Compute Y1, the first two columns of Y = H*H - s*H + t*I4, C where H = ( Hij ), i,j = 1,2, H12 = 0, t = det(H22). C H is real lower Hamiltonian block triangular with the C desired eigenvalues in the leading positions. C T = U( 1, 1 )*U( 2, 2 ) - U( 2, 1 )*U( 1, 2 ) C CALL DLACPY( 'Full', 4, 2, U, LDU, Q, LDQ ) Q( 1, 3 ) = U( 1, 1 ) - S Q( 2, 3 ) = U( 2, 1 ) Q( 3, 3 ) = U( 1, 1 ) Q( 4, 3 ) = U( 2, 1 ) Q( 1, 4 ) = U( 1, 2 ) Q( 2, 4 ) = U( 2, 2 ) - S Q( 3, 4 ) = U( 1, 2 ) Q( 4, 4 ) = U( 2, 2 ) CALL DGEMM( 'No Transpose', 'No Transpose', 4, 2, 2, ONE, $ Q, LDQ, Q( 1, 3 ), LDQ, ZERO, U, LDU ) CALL DGEMM( 'Transpose', 'No Transpose', 2, 2, 2, -ONE, $ Q( 3, 3 ), LDQ, Q( 3, 1 ), LDQ, ONE, U( 3, 1 ), $ LDU ) U( 1, 1 ) = U( 1, 1 ) + T U( 2, 2 ) = U( 2, 2 ) + T C C Compute the relevant part of the orthogonal symplectic C matrix U performing the symplectic QR factorization of Y1. C Workspace: need 10. C ICS = 1 ITAU = ICS + 4 IWRK2 = ITAU + 2 CALL MB04SU( 2, 2, U( 1, 1 ), LDU, U( 3, 1 ), LDU, $ DWORK( ICS ), DWORK( ITAU ), DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL MB04WU( 'No Transpose', 'No Transpose', 2, 2, 2, $ U( 1, 1 ), LDU, U( 3, 1 ), LDU, DWORK( ICS ), $ DWORK( ITAU ), DWORK( IWRK2 ), LDWORK-IWRK2+1, $ INFO ) C C Compute J*U in U. C U( 1, 3 ) = U( 1, 1 ) U( 2, 3 ) = U( 2, 1 ) U( 1, 4 ) = U( 1, 2 ) U( 2, 4 ) = U( 2, 2 ) C U( 1, 1 ) = -U( 3, 1 ) U( 2, 1 ) = -U( 4, 1 ) U( 1, 2 ) = -U( 3, 2 ) U( 2, 2 ) = -U( 4, 2 ) C U( 3, 1 ) = -U( 1, 3 ) U( 4, 1 ) = -U( 2, 3 ) U( 3, 2 ) = -U( 1, 4 ) U( 4, 2 ) = -U( 2, 4 ) C U( 3, 3 ) = U( 1, 1 ) U( 4, 3 ) = U( 2, 1 ) U( 3, 4 ) = U( 1, 2 ) U( 4, 4 ) = U( 2, 2 ) C C Compute U'*B using structure. C CALL DGEMM( 'Transpose', 'No Transpose', 4, 2, 2, ONE, U, $ LDU, B, LDB, ZERO, Q, LDQ ) CALL DGEMM( 'Transpose', 'No Transpose', 4, 2, 4, ONE, U, $ LDU, B( 1, 3 ), LDB, ZERO, Q( 1, 3 ), LDQ ) C C Determine Q using different elimination orders in the RQ and C QR factorizations of U'*B. C Workspace: need 12. C ITAU = 1 IWRK1 = ITAU + N CALL DGERQ2( N, N, Q, LDQ, DWORK( ITAU ), DWORK( IWRK1 ), $ INFO ) IR = IWRK1 IWRK2 = IR + 4 DWORK( IR ) = Q( 3, 3 ) DWORK( IR+1 ) = Q( 3, 4 ) DWORK( IR+2 ) = ZERO DWORK( IR+3 ) = Q( 4, 4 ) CALL DORGR2( N, N, N, Q, LDQ, DWORK( ITAU ), DWORK( IWRK2 ), $ INFO ) C DO 20 I = 2, N CALL DSWAP( N-I+1, Q( I, I-1 ), 1, Q( I-1, I ), LDQ ) 20 CONTINUE C CALL DGEQR2( 2, 2, DWORK( IR ), 2, DWORK( ITAU ), $ DWORK( IWRK2 ), INFO ) CALL DORM2R( 'Right', 'No Transpose', N, 2, 2, DWORK( IR ), 2, $ DWORK( ITAU ), Q( 1, 3 ), LDQ, DWORK( IWRK2 ), $ INFO ) ELSE C G = TWO*B( 1, 1 )*B( 2, 2 )*D( 1, 1 ) CALL DLARTG( B( 1, 1 )*B( 2, 2 )*D( 1, 2 ), G, CO, SI, R ) Q( 1, 1 ) = CO Q( 2, 1 ) = -SI Q( 1, 2 ) = SI Q( 2, 2 ) = CO CALL DLARTG( B( 1, 1 )*Q( 1, 1 ) + B( 1, 2 )*Q( 2, 1 ), $ B( 2, 2 )*Q( 2, 1 ), CO, SI, R ) U( 1, 1 ) = CO U( 2, 1 ) = SI U( 1, 2 ) = -SI U( 2, 2 ) = CO END IF C RETURN C *** Last line of MB03GD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03RW.f0000644000000000000000000000013215012430707016207 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03RW.f0000644000175000017500000001746415012430707017417 0ustar00lilgelilge00000000000000 SUBROUTINE MB03RW( M, N, PMAX, A, LDA, B, LDB, C, LDC, INFO ) C C PURPOSE C C To solve the Sylvester equation -AX + XB = C, where A and B are C complex M-by-M and N-by-N matrices, respectively, in Schur form. C C This routine is intended to be called only by SLICOT Library C routine MB03RZ. For efficiency purposes, the computations are C aborted when the absolute value of an element of X is greater than C a given value PMAX. C C ARGUMENTS C C Input/Output Parameters C C M (input) INTEGER C The order of the matrix A and the number of rows of the C matrices C and X. M >= 0. C C N (input) INTEGER C The order of the matrix B and the number of columns of the C matrices C and X. N >= 0. C C PMAX (input) DOUBLE PRECISION C An upper bound for the absolute value of the elements of X C (see METHOD). C C A (input) COMPLEX*16 array, dimension (LDA,M) C The leading M-by-M upper triangular part of this array C must contain the matrix A of the Sylvester equation. C The elements below the diagonal are not referenced. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C B (input) COMPLEX*16 array, dimension (LDB,N) C The leading N-by-N upper triangular part of this array C must contain the matrix B of the Sylvester equation. C The elements below the diagonal are not referenced. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C C (input/output) COMPLEX*16 array, dimension (LDC,N) C On entry, the leading M-by-N part of this array must C contain the matrix C of the Sylvester equation. C On exit, if INFO = 0, the leading M-by-N part of this C array contains the solution matrix X of the Sylvester C equation, and each element of X (see METHOD) has the C absolute value less than or equal to PMAX. C On exit, if INFO = 1, the solution matrix X has not been C computed completely, because an element of X had the C absolute value greater than PMAX. Part of the matrix C has C possibly been overwritten with the corresponding part C of X. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,M). C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: an element of X had the absolute value greater than C the given value PMAX. C = 2: A and B have common or very close eigenvalues; C perturbed values were used to solve the equation C (but the matrices A and B are unchanged). This is a C warning. C C METHOD C C The routine uses an adaptation of the standard method for solving C Sylvester equations [1], which controls the magnitude of the C individual elements of the computed solution [2]. The equation C -AX + XB = C can be rewritten as C m l-1 C -A X + X B = C + sum A X - sum X B C kk kl kl ll kl i=k+1 ki il j=1 kj jl C C for l = 1:n, and k = m:-1:1, where A , B , C , and X , are the C kk ll kl kl C elements defined by the partitioning induced by the Schur form C of A and B. So, the elements of X are found column by column, C starting from the bottom. If any such element has the absolute C value greater than the given value PMAX, the calculations are C ended. C C REFERENCES C C [1] 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 [2] Bavely, C. and Stewart, G.W. C An Algorithm for Computing Reducing Subspaces by Block C Diagonalization. C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. C C NUMERICAL ASPECTS C 2 2 C The algorithm requires 0(M N + MN ) operations. C C FURTHER COMMENTS C C Let C C ( A C ) ( I X ) C M = ( ), Y = ( ). C ( 0 B ) ( 0 I ) C C Then C C -1 ( A 0 ) C Y M Y = ( ), C ( 0 B ) C C hence Y is a non-unitary transformation matrix which performs the C reduction of M to a block-diagonal form. Bounding a norm of X is C equivalent to setting an upper bound to the condition number of C the transformation matrix Y. C C CONTRIBUTOR C C V. Sima, June 2021. C C REVISIONS C C - C C KEYWORDS C C Diagonalization, Schur form, Sylvester equation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, M, N DOUBLE PRECISION PMAX C .. Array Arguments .. COMPLEX*16 A(LDA,*), B(LDB,*), C(LDC,*) C .. Local Scalars .. INTEGER K, K1, L, LM1 DOUBLE PRECISION AA11, AC11, BIGNUM, EPS, SMIN, SMLNUM COMPLEX*16 A11, C11, X11 C .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) C .. External Functions .. DOUBLE PRECISION DLAMCH, ZLANTR COMPLEX*16 ZDOTU, ZLADIV EXTERNAL DLAMCH, ZDOTU, ZLADIV, ZLANTR C .. External Subroutines .. EXTERNAL DLABAD, ZGEMV C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX C .. Executable Statements .. C C For efficiency reasons, this routine does not check the input C parameters for errors. C INFO = 0 C C Quick return if possible. C IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*DBLE( M*N ) / EPS BIGNUM = ONE / SMLNUM SMIN = MAX( SMLNUM, $ EPS*ZLANTR( 'M', 'U', 'N', M, M, A, LDA, DUM ), $ EPS*ZLANTR( 'M', 'U', 'N', N, N, B, LDB, DUM ) ) C C Column loop indexed by L. C DO 20 L = 1, N LM1 = L - 1 C IF ( LM1.GT.0 ) THEN C C Update column L of C. C CALL ZGEMV( 'No transpose', M, LM1, -CONE, C, LDC, B(1,L), $ 1, CONE, C(1,L), 1 ) ENDIF C m l-1 C -A X + X B = C + sum A X - sum X B C kk kl kl ll kl i=k+1 ki il j=1 kj jl C C Row loop indexed by K. C DO 10 K = M, 1, -1 K1 = K + 1 C11 = C(K,L) IF ( K.LT.M ) THEN C C Update C(K,L). C C11 = C11 + ZDOTU( M-K, A(K,K1), LDA, C(K1,L), 1 ) ENDIF A11 = B( L, L ) - A( K, K ) AA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) IF( AA11.LE.SMIN ) THEN A11 = SMIN AA11 = SMIN INFO = 2 END IF AC11 = ABS( DBLE( C11 ) ) + ABS( DIMAG( C11 ) ) IF( AA11.LT.ONE .AND. AC11.GT.ONE ) THEN IF( AC11.GT.BIGNUM*AA11 ) THEN INFO = 1 RETURN END IF END IF X11 = ZLADIV( C11, A11 ) IF( ABS( X11 ).GT.PMAX ) THEN INFO = 1 RETURN END IF C(K,L) = X11 10 CONTINUE 20 CONTINUE C RETURN C *** Last line of MB03RW *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01KX.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01KX.f0000644000175000017500000002004015012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE TB01KX( N, M, P, NDIM, A, LDA, B, LDB, C, LDC, U, LDU, $ V, LDV, INFO ) C C PURPOSE C C To compute an additive spectral decomposition of the transfer- C function matrix of the system (A,B,C) by reducing the system C state-matrix A to a block-diagonal form. It is assumed that A is C in a real Schur form, and the leading diagonal block of order NDIM C has eigenvalues distinct from those of the trailing diagonal C block. The system matrices are transformed as C A <-- V*A*U, B <--V*B and C <-- C*U, where V = inv(U), C preserving the spectra of the two diagonal blocks. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the state-space representation, i.e., the C order of the matrix A. N >= 0. C C M (input) INTEGER C The number of system inputs, or of columns of B. M >= 0. C C P (input) INTEGER C The number of system outputs, or of rows of C. P >= 0. C C NDIM (input) INTEGER C The dimension of the leading diagonal block of A having C eigenvalues distinct from those of the trailing diagonal C block. 0 <= NDIM <= 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 state dynamics matrix A in real Schur form. C On exit, the leading N-by-N part of this array contains a C block diagonal matrix inv(U) * A * U with two diagonal C blocks in real Schur form, with the elements below the C first subdiagonal set to zero. The leading block has C dimension NDIM-by-NDIM. C C LDA INTEGER C The leading dimension of the 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 matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix inv(U) * B. C C LDB INTEGER C The leading dimension of the 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 output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed output matrix C * U. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). 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 an initial transformation matrix U. C On exit, the leading N-by-N part of this array contains C the transformation matrix used to reduce A to the block- C diagonal form. The first NDIM columns of U span the C invariant subspace of A corresponding to the eigenvalues C of its leading diagonal block. The last N-NDIM columns of C U span the reducing subspace of A corresponding to the C eigenvalues of the trailing diagonal block of A. C C LDU INTEGER C The leading dimension of the array U. LDU >= max(1,N). C C V (output) DOUBLE PRECISION array, dimension (LDV,N) C The leading N-by-N part of this array contains the C inverse of the transformation matrix U used to reduce A C to the block-diagonal form. C C LDV INTEGER C The leading dimension of the array V. LDV >= max(1,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 value; C = 1: the separation of the two diagonal blocks failed C because of very close eigenvalues. C C METHOD C C A similarity transformation U is determined that reduces the given C system state-matrix A to a block-diagonal form (with two diagonal C blocks), so that the eigenvalues of the leading diagonal block of C the resulting A are preserved. The determined transformation is C applied to the system (A,B,C) as C A <-- inv(U)*A*U, B <-- inv(U)*B and C <-- C*U. C C REFERENCES C C [1] Safonov, M.G., Jonckheere, E.A., Verma, M., Limebeer, D.J.N. C Synthesis of positive real multivariable feedback systems. C Int. J. Control, pp. 817-842, 1987. C C NUMERICAL ASPECTS C 3 C The algorithm requires about N /2 + NDIM*(N-NDIM)*(2*N+M+P) C floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, March 1998. C Based on the RASP routine SADSDC. C C REVISIONS C C V. Sima, Dec. 2016. C C KEYWORDS C C Invariant subspace, real Schur form, similarity transformation, C spectral factorization. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDU, LDV, M, N, NDIM, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), U(LDU,*), V(LDV,*) C .. Local Scalars .. INTEGER NDIM1, NR DOUBLE PRECISION SCALE C .. External Subroutines .. EXTERNAL DGEMM, DLASET, DTRSYL, MA02AD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C INFO = 0 C C Check 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( NDIM.LT.0 .OR. NDIM.GT.N ) 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( LDU.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -14 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01KX', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C C Form U' in V. C CALL MA02AD( 'Full', N, N, U, LDU, V, LDV ) C IF( NDIM.GT.0 .AND. NDIM.LT.N ) THEN C C Reduce A to a block-diagonal form by a similarity C transformation of the form C -1 ( I -X ) C A <- T AT, where T = ( ) and X satisfies the C ( 0 I ) C Sylvester equation C C A11*X - X*A22 = A12. C NR = N - NDIM NDIM1 = NDIM + 1 CALL DTRSYL( 'N', 'N', -1, NDIM, NR, A, LDA, A(NDIM1,NDIM1), $ LDA, A(1,NDIM1), LDA, SCALE, INFO ) IF ( INFO.NE.0 ) $ RETURN C -1 -1 C Compute B <- T *B, C <- C*T, U <- U*T, V <- T *V. C SCALE = ONE/SCALE CALL DGEMM( 'N', 'N', NDIM, M, NR, SCALE, A(1,NDIM1), LDA, $ B(NDIM1,1), LDB, ONE, B, LDB ) CALL DGEMM( 'N', 'N', P, NR, NDIM, -SCALE, C, LDC, A(1,NDIM1), $ LDA, ONE, C(1,NDIM1), LDC ) CALL DGEMM( 'N', 'N', N, NR, NDIM, -SCALE, U, LDU, A(1,NDIM1), $ LDA, ONE, U(1,NDIM1), LDU ) CALL DGEMM( 'N', 'N', NDIM, N, NR, SCALE, A(1,NDIM1), LDA, $ V(NDIM1,1), LDV, ONE, V, LDV ) C C Set A12 to zero. C CALL DLASET( 'Full', NDIM, NR, ZERO, ZERO, A(1,NDIM1), LDA ) END IF C C Set to zero the lower triangular part under the first subdiagonal C of A. C IF ( N.GT.2 ) $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA ) RETURN C *** Last line of TB01KX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01UY.f0000644000000000000000000000013215012430707016212 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01UY.f0000644000175000017500000003465415012430707017422 0ustar00lilgelilge00000000000000 SUBROUTINE MB01UY( SIDE, UPLO, TRANS, M, N, ALPHA, T, LDT, A, LDA, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute one of the matrix products C C T : = alpha*op( T ) * A, or T : = alpha*A * op( T ), C C where alpha is a scalar, A is an M-by-N matrix, T is a triangular C matrix, and op( T ) is one of C C op( T ) = T or op( T ) = T', the transpose of T. C C A block-row/column algorithm is used, if possible. The result C overwrites the array T. C C ARGUMENTS C C Mode Parameters C C SIDE CHARACTER*1 C Specifies whether the triangular matrix T appears on the C left or right in the matrix product, as follows: C = 'L': T := alpha*op( T ) * A; C = 'R': T := alpha*A * op( T ). C C UPLO CHARACTER*1. C Specifies whether the matrix T is an upper or lower C triangular matrix, as follows: C = 'U': T is an upper triangular matrix; C = 'L': T is a lower triangular matrix. C C TRANS CHARACTER*1 C Specifies the form of op( T ) to be used in the matrix C multiplication as follows: C = 'N': op( T ) = T; C = 'T': op( T ) = T'; C = 'C': op( T ) = T'. 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 ALPHA (input) DOUBLE PRECISION C The scalar alpha. When alpha is zero then T and A need not C be set before entry. C C T (input/output) DOUBLE PRECISION array, dimension C (LDT,max(K,N)), when SIDE = 'L', and C (LDT,K), when SIDE = 'R', C where K is M if SIDE = 'L' and is N if SIDE = 'R'. C On entry with UPLO = 'U', the leading K-by-K upper C triangular part of this array must contain the upper C triangular matrix T. The elements below the diagonal C do not need to be zero. C On entry with UPLO = 'L', the leading K-by-K lower C triangular part of this array must contain the lower C triangular matrix T. The elements above the diagonal C do not need to be zero. C On exit, the leading M-by-N part of this array contains C the corresponding product defined by SIDE, UPLO, and C TRANS. C C LDT INTEGER C The leading dimension of the array T. C LDT >= max(1,M), if SIDE = 'L'; C LDT >= max(1,M,N), if 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 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 On exit, if INFO = -12, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK The length of the array DWORK. C LDWORK >= 1, if alpha = 0 or MIN(M,N) = 0; C LDWORK >= M, if SIDE = 'L'; C LDWORK >= N, if SIDE = 'R'. C For good 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 A block-row/column size is found based on the available workspace. C BLAS 3 gemm and trmm are used if possible. C C CONTRIBUTORS C C V. Sima, June 2021. C C REVISIONS C C V. Sima, July 2021. C C KEYWORDS C C Elementary 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, LDT, LDWORK, M, N DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), T(LDT,*) C .. Local Scalars .. CHARACTER TRANC, UPLOC LOGICAL LONT, LOTR, LQUERY, LSIDE, LTRAN, LUPLO, UPNT, $ UPTR INTEGER BL, I, II, IJ, J, K, L, MN, NB, NC, NR, WRKMIN, $ WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DLACPY, DLASET, $ DTRMM, MA02ED, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C C .. Executable Statements .. C C Decode and test the input scalar arguments. C INFO = 0 LSIDE = LSAME( SIDE, 'L' ) LUPLO = LSAME( UPLO, 'U' ) LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) IF ( LSIDE ) THEN K = M L = N ELSE K = N L = M END IF MN = MIN( M, N ) C C Ensure that at least two rows or columns of A fit into the C workspace, if optimal workspace is required. C WRKMIN = 1 IF ( ALPHA.NE.ZERO .AND. MN.GT.0 ) $ WRKMIN = MAX( WRKMIN, K ) LQUERY = LDWORK.EQ.-1 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.LTRAN ).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 ( LDT.LT.MAX( 1, M ) .OR. ( .NOT.LSIDE .AND. LDT.LT.N ) ) $ THEN INFO = -8 ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LQUERY ) THEN IF ( ALPHA.NE.ZERO .AND. MN.GT.0 ) THEN CALL DGEQRF( M, MAX( M,N ), A, LDA, DWORK, DWORK, -1, INFO ) WRKOPT = MAX( WRKMIN, 2*L, INT( DWORK(1) ) ) DWORK(1) = DBLE( WRKOPT ) ELSE DWORK(1) = ONE END IF RETURN ELSE IF ( LDWORK.LT.WRKMIN ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = -12 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01UY', -INFO ) RETURN END IF C C Quick return, if possible. C IF ( MN.EQ.0 ) $ RETURN C IF ( ALPHA.EQ.ZERO ) THEN C C Set T to zero and return. C CALL DLASET( 'Full', M, N, ZERO, ZERO, T, LDT ) RETURN END IF C C Set the panel (block-row/column) size NB. C NB = MAX( 1, MIN( K, INT( LDWORK/L ) ) ) C IF ( LDWORK.GE.M*N ) THEN C C Enough workspace for a fast BLAS 3 calculation. C Save relevant parts of A in the workspace and compute one of C the matrix products C T : = alpha*op( triu( T ) ) * A, or C T : = alpha*A * op( triu( T ) ), C involving the upper/lower triangle of T. C CALL DLACPY( 'All', M, N, A, LDA, DWORK, M ) CALL DTRMM( SIDE, UPLO, TRANS, 'NonUnit', M, N, ALPHA, T, LDT, $ DWORK, M ) CALL DLACPY( 'All', M, N, DWORK, M, T, LDT ) C ELSE IF ( NB.GT.1 ) THEN C C Use BLAS 3 calculations in a loop. BL is the number of panels. C C If UPLO = 'L' and TRANS <> 'N', change the format so that to C correspond to UPLO = 'U' and TRANS = 'N'. C If UPLO = 'U' and TRANS <> 'N', change the format so that to C correspond to UPLO = 'L' and TRANS = 'N'. C IF ( LTRAN ) THEN CALL MA02ED( UPLO, K, T, LDT ) IF ( LUPLO ) THEN UPLOC = 'Lower' ELSE UPLOC = 'Upper' END IF TRANC = 'NoTran' LUPLO = .NOT.LUPLO LTRAN = .NOT.LTRAN ELSE UPLOC = UPLO TRANC = TRANS END IF C BL = MAX( 1, INT( K/NB ) ) J = MIN( K, NB*BL ) C IF ( LSIDE ) THEN C IF ( LUPLO ) THEN C C Compute the last rows. C IF ( J.EQ.M ) THEN NR = NB II = M - NB + 1 BL = BL - 1 ELSE NR = M - J II = J + 1 END IF CALL DLACPY( 'All', NR, N, A(II,1), LDA, DWORK, NR ) CALL DTRMM( SIDE, UPLOC, TRANC, 'NonUnit', NR, N, ALPHA, $ T(II,II), LDT, DWORK, NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, T(II,1), LDT ) C DO 10 I = 1, BL IJ = II II = II - NB CALL DLACPY( 'All', NB, N, A(II,1), LDA, DWORK, NB ) CALL DTRMM( SIDE, UPLOC, TRANC, 'NonUnit', NB, N, $ ALPHA, T(II,II), LDT, DWORK, NB ) CALL DGEMM( TRANC, 'NoTrans', NB, N, M-IJ+1, ALPHA, $ T(II,IJ), LDT, A(IJ,1), LDA, ONE, DWORK, $ NB ) CALL DLACPY( 'All', NB, N, DWORK, NB, T(II,1), LDT ) 10 CONTINUE C ELSE C C Compute the first rows. C IF ( J.EQ.M ) THEN NR = NB BL = BL - 1 ELSE NR = M - J END IF CALL DLACPY( 'All', NR, N, A, LDA, DWORK, NR ) CALL DTRMM( SIDE, UPLOC, TRANC, 'NonUnit', NR, N, ALPHA, $ T, LDT, DWORK, NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, T, LDT ) II = NR + 1 C DO 20 I = 1, BL CALL DLACPY( 'All', NB, N, A(II,1), LDA, DWORK, NB ) CALL DTRMM( SIDE, UPLOC, TRANC, 'NonUnit', NB, N, $ ALPHA, T(II,II), LDT, DWORK, NB ) CALL DGEMM( TRANC, 'NoTrans', NB, N, II-1, ALPHA, $ T(II,1), LDT, A, LDA, ONE, DWORK, NB ) CALL DLACPY( 'All', NB, N, DWORK, NB, T(II,1), LDT ) II = II + NB 20 CONTINUE C END IF C ELSE C IF ( LUPLO ) THEN C C Compute the first columns. C II = 1 IF ( J.EQ.N ) THEN NC = NB BL = BL - 1 ELSE NC = N - J END IF CALL DLACPY( 'All', M, NC, A, LDA, DWORK, M ) CALL DTRMM( SIDE, UPLOC, TRANC, 'NonUnit', M, NC, ALPHA, $ T, LDT, DWORK, M ) CALL DLACPY( 'All', M, NC, DWORK, M, T, LDT ) II = II + NC C DO 30 I = 1, BL IJ = II - 1 CALL DLACPY( 'All', M, NB, A(1,II), LDA, DWORK, M ) CALL DTRMM( SIDE, UPLOC, TRANC, 'NonUnit', M, NB, $ ALPHA, T(II,II), LDT, DWORK, M ) CALL DGEMM( TRANC, 'NoTrans', M, NB, IJ, ALPHA, A, $ LDA, T(1,II), LDT, ONE, DWORK, M ) CALL DLACPY( 'All', M, NB, DWORK, M, T(1,II), LDT ) II = II + NB 30 CONTINUE C ELSE C C Compute the last columns. C IF ( J.EQ.N ) THEN NC = NB II = N - NB + 1 BL = BL - 1 ELSE NC = N - J II = J + 1 END IF CALL DLACPY( 'All', M, NC, A(1,II), LDA, DWORK, M ) CALL DTRMM( SIDE, UPLOC, TRANC, 'NonUnit', M, NC, ALPHA, $ T(II,II), LDT, DWORK, M ) CALL DLACPY( 'All', M, NC, DWORK, M, T(1,II), LDT ) C DO 40 I = 1, BL IJ = II II = II - NB CALL DLACPY( 'All', M, NB, A(1,II), LDA, DWORK, M ) CALL DTRMM( SIDE, UPLOC, TRANC, 'NonUnit', M, NB, $ ALPHA, T(II,II), LDT, DWORK, M ) CALL DGEMM( TRANC, 'NoTrans', M, NB, NC, ALPHA, $ A(1,IJ), LDA, T(IJ,II), LDT, ONE, DWORK, $ M ) CALL DLACPY( 'All', M, NB, DWORK, M, T(1,II), LDT ) NC = NC + NB 40 CONTINUE C END IF C END IF C ELSE C C Use BLAS 2 calculations in a loop. C Fill-in the other part of T by symmetry. C UPNT = LUPLO .AND. .NOT.LTRAN LOTR = LTRAN .AND. .NOT.LUPLO UPTR = LUPLO .AND. LTRAN LONT = .NOT.LUPLO .AND. .NOT.LTRAN C IF ( LUPLO .OR. LOTR ) $ CALL MA02ED( UPLO, K, T, LDT ) C IF ( LSIDE ) THEN C IF ( UPNT .OR. LOTR ) THEN C DO 50 I = 1, M CALL DCOPY( M-I+1, T(I,I), 1, DWORK, 1 ) CALL DGEMV( 'Trans', M-I+1, N, ALPHA, A(I,1), LDA, $ DWORK, 1, ZERO, T(I,1), LDT ) 50 CONTINUE C ELSE IF ( UPTR .OR. LONT ) THEN C DO 60 I = 1, M CALL DCOPY( I, T(I,1), LDT, DWORK, 1 ) CALL DGEMV( 'Trans', I, N, ALPHA, A, LDA, DWORK, 1, $ ZERO, T(I,1), LDT ) 60 CONTINUE C END IF C ELSE C IF ( UPNT .OR. LOTR ) THEN C DO 70 I = 1, N CALL DCOPY( I, T(1,I), 1, DWORK, 1 ) CALL DGEMV( 'NoTran', M, I, ALPHA, A, LDA, DWORK, 1, $ ZERO, T(1,I), 1 ) 70 CONTINUE C ELSE IF ( UPTR .OR. LONT ) THEN C DO 80 I = 1, N CALL DCOPY( N-I+1, T(I,I), 1, DWORK, 1 ) CALL DGEMV( 'NoTran', M, N-I+1, ALPHA, A(1,I), LDA, $ DWORK, 1, ZERO, T(1,I), 1 ) 80 CONTINUE C END IF C END IF C END IF C DWORK(1) = DBLE( MAX( WRKMIN, WRKOPT ) ) RETURN C *** Last line of MB01UY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04PY.f0000644000000000000000000000013215012430707016216 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04PY.f0000644000175000017500000011643315012430707017422 0ustar00lilgelilge00000000000000 SUBROUTINE SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, DWORK, INFO ) C C PURPOSE C C To solve for X the discrete-time Sylvester equation C C op(A)*X*op(B) + ISGN*X = scale*C, C C where op(A) = A or A**T, A and B are both upper quasi-triangular, C and ISGN = 1 or -1. A is M-by-M and B is N-by-N; the right hand C side C and the solution X are M-by-N; and scale is an output scale C factor, set less than or equal to 1 to avoid overflow in X. The C solution matrix X is overwritten onto C. C C A and B must be in Schur canonical form (as returned by LAPACK C Library routine DHSEQR), that is, block upper triangular with C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has C its diagonal elements equal and its off-diagonal elements of C opposite sign. C C ARGUMENTS C C Mode Parameters 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 TRANB CHARACTER*1 C Specifies the form of op(B) to be used, as follows: C = 'N': op(B) = B (No transpose); C = 'T': op(B) = B**T (Transpose); C = 'C': op(B) = B**T (Conjugate transpose = Transpose). C C ISGN INTEGER C Specifies the sign of the equation as described before. C ISGN may only be 1 or -1. C C Input/Output Parameters C C M (input) INTEGER C The order of the matrix A, and the number of rows in the C matrices X and C. M >= 0. C C N (input) INTEGER C The order of the matrix B, and the number of columns in C the matrices X and C. N >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,M) C The leading M-by-M part of this array must contain the C upper quasi-triangular matrix A, in Schur canonical form. C The part of A below the first sub-diagonal is not C referenced. 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 the C upper quasi-triangular matrix B, in Schur canonical form. C The part of B below the first sub-diagonal is not C referenced. C C LDB (input) INTEGER C The leading dimension of the 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 right hand side matrix C. C On exit, if INFO >= 0, the leading M-by-N part of this C array contains the solution matrix X. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,M). 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 Workspace C C DWORK DOUBLE PRECISION array, dimension (2*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 = 1: A and -ISGN*B have almost reciprocal eigenvalues; C perturbed values were used to solve the equation C (but the matrices A and B are unchanged). C C METHOD C C The solution matrix X is computed column-wise via a back C substitution scheme, an extension and refinement of the algorithm C in [1], similar to that used in [2] for continuous-time Sylvester C equations. A set of equivalent linear algebraic systems of C equations of order at most four are formed and solved using C Gaussian elimination with complete pivoting. C C REFERENCES C C [1] 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 [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C The algorithm is stable and reliable, since Gaussian elimination C with complete pivoting is used. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000. C D. Sima, University of Bucharest, April 2000. C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. C Partly based on the routine SYLSV, A. Varga, 1992. C C REVISIONS C C - C C KEYWORDS C C Discrete-time system, matrix algebra, Sylvester equation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER TRANA, TRANB INTEGER INFO, ISGN, LDA, LDB, LDC, M, N DOUBLE PRECISION SCALE C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ) C .. C .. Local Scalars .. LOGICAL NOTRNA, NOTRNB INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, $ MNK1, MNK2, MNL1, MNL2 DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22, $ SCALOC, SGN, SMIN, SMLNUM, SUMR, XNORM C .. C .. Local Arrays .. DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLANGE EXTERNAL DDOT, DLAMCH, DLANGE, LSAME C .. C .. External Subroutines .. EXTERNAL DLABAD, DLALN2, DSCAL, SB04PX, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN C .. C .. Executable Statements .. C C Decode and Test input parameters C NOTRNA = LSAME( TRANA, 'N' ) NOTRNB = LSAME( TRANB, 'N' ) C INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. $ .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. $ .NOT.LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB04PY', -INFO ) RETURN END IF C C Quick return if possible. C SCALE = ONE IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN C C Set constants to control overflow. C EPS = DLAMCH( 'Precision' ) SMLNUM = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*DBLE( M*N ) / EPS BIGNUM = ONE / SMLNUM C SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ), $ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) ) C SGN = ISGN C IF( NOTRNA .AND. NOTRNB ) THEN C C Solve A*X*B + ISGN*X = scale*C. C C The (K,L)th block of X is determined starting from C bottom-left corner column by column by C C A(K,K)*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) C C where C M C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L) + C J=K+1 C M L-1 C SUM { A(K,J) * SUM [X(J,I)*B(I,L)] }. C J=K I=1 C C Start column loop (index = L) C L1 (L2) : column index of the first (last) row of X(K,L). C LNEXT = 1 C DO 60 L = 1, N IF( L.LT.LNEXT ) $ GO TO 60 L1 = L IF( L.EQ.N ) THEN L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L2 = L + 1 ELSE L2 = L END IF LNEXT = L2 + 1 END IF C C Start row loop (index = K) C K1 (K2): row index of the first (last) row of X(K,L). C KNEXT = M C DO 50 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 50 K2 = K IF( K.EQ.1 ) THEN K1 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 ELSE K1 = K END IF KNEXT = K1 - 1 END IF C MNK1 = MIN( K1+1, M ) MNK2 = MIN( K2+1, M ) P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), $ 1 ) C IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN C SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) SCALOC = ONE C A11 = A( K1, K1 )*B( L1, L1 ) + SGN DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 C IF( SCALOC.NE.ONE ) THEN C DO 10 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 10 CONTINUE C CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN C P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), $ 1 ) DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), $ 1 ) SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) C SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) C CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 20 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 20 CONTINUE C CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN C P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), $ 1 ) SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + $ P12*B( L2, L1 ) ) C DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, $ B( 1, L2 ), 1 ) SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), $ 1 ) VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + $ P12*B( L2, L2 ) ) C CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 30 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 30 CONTINUE C CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN C P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), $ 1 ) P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), $ 1 ) P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), $ 1 ) C DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), $ 1 ) SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + $ P12*B( L2, L1 ) ) C DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, $ B( 1, L2 ), 1 ) DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, $ B( 1, L2 ), 1 ) SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), $ 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + $ P12*B( L2, L2 ) ) C SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + $ P22*B( L2, L1 ) ) C SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), $ 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + $ P22*B( L2, L2 ) ) C CALL SB04PX( .FALSE., .FALSE., ISGN, 2, 2, $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, $ 2, SCALOC, X, 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 40 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 40 CONTINUE C CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF C 50 CONTINUE C 60 CONTINUE C ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN C C Solve A'*X*B + ISGN*X = scale*C. C C The (K,L)th block of X is determined starting from C upper-left corner column by column by C C A(K,K)'*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) C C where C K-1 C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L) + C J=1 C K L-1 C SUM A(J,K)' * { SUM [X(J,I)*B(I,L)] }. C J=1 I=1 C C Start column loop (index = L) C L1 (L2): column index of the first (last) row of X(K,L). C LNEXT = 1 C DO 120 L = 1, N IF( L.LT.LNEXT ) $ GO TO 120 L1 = L IF( L.EQ.N ) THEN L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L2 = L + 1 ELSE L2 = L END IF LNEXT = L2 + 1 END IF C C Start row loop (index = K) C K1 (K2): row index of the first (last) row of X(K,L). C KNEXT = 1 C DO 110 K = 1, M IF( K.LT.KNEXT ) $ GO TO 110 K1 = K IF( K.EQ.M ) THEN K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K2 = K + 1 ELSE K2 = K END IF KNEXT = K2 + 1 END IF C P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1), $ 1 ) C IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN C SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) SCALOC = ONE C A11 = A( K1, K1 )*B( L1, L1 ) + SGN DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 C IF( SCALOC.NE.ONE ) THEN C DO 70 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 70 CONTINUE C CALL DSCAL( K1, SCALOC, DWORK, 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN C P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, $ B( 1, L1), 1 ) SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) C SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) C CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 80 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 80 CONTINUE C CALL DSCAL( K2, SCALOC, DWORK, 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN C P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + $ P12*B( L2, L1 ) ) C DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, $ B( 1, L2 ), 1 ) SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + $ P12*B( L2, L2 ) ) C CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 90 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 90 CONTINUE C CALL DSCAL( K1, SCALOC, DWORK, 1 ) CALL DSCAL( K1, SCALOC, DWORK( M+1 ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN C P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) C DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, $ B( 1, L1), 1 ) SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + $ P12*B( L2, L1 ) ) C SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + $ P22*B( L2, L1 ) ) C DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, $ B( 1, L2 ), 1 ) DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, $ B( 1, L2 ), 1 ) SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + $ P12*B( L2, L2 ) ) C SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + $ P22*B( L2, L2 ) ) C CALL SB04PX( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 100 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 100 CONTINUE C CALL DSCAL( K2, SCALOC, DWORK, 1 ) CALL DSCAL( K2, SCALOC, DWORK( M+1 ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF C 110 CONTINUE C 120 CONTINUE C ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN C C Solve A'*X*B' + ISGN*X = scale*C. C C The (K,L)th block of X is determined starting from C top-right corner column by column by C C A(K,K)'*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) C C where C K-1 C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L)' + C J=1 C K N C SUM A(J,K)' * { SUM [X(J,I)*B(L,I)'] }. C J=1 I=L+1 C C Start column loop (index = L) C L1 (L2): column index of the first (last) row of X(K,L). C LNEXT = N C DO 180 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 180 L2 = L IF( L.EQ.1 ) THEN L1 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 ELSE L1 = L END IF LNEXT = L1 - 1 END IF C C Start row loop (index = K) C K1 (K2): row index of the first (last) row of X(K,L). C KNEXT = 1 C DO 170 K = 1, M IF( K.LT.KNEXT ) $ GO TO 170 K1 = K IF( K.EQ.M ) THEN K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K2 = K + 1 ELSE K2 = K END IF KNEXT = K2 + 1 END IF C MNL1 = MIN( L1+1, N ) MNL2 = MIN( L2+1, N ) P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, $ B( L1, MNL2 ), LDB ) C IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) SCALOC = ONE C A11 = A( K1, K1 )*B( L1, L1 ) + SGN DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 C IF( SCALOC.NE.ONE ) THEN C DO 130 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 130 CONTINUE C CALL DSCAL( K1, SCALOC, DWORK, 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN C P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, $ B( L1, MNL1 ), LDB ) SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) C SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) C CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 140 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 140 CONTINUE C CALL DSCAL( K2, SCALOC, DWORK, 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN C P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + $ P12*B( L1, L2 ) ) C DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, $ B( L2, MNL2 ), LDB ) SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + $ P12*B( L2, L2 ) ) C CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 150 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 150 CONTINUE C CALL DSCAL( K1, SCALOC, DWORK, 1 ) CALL DSCAL( K1, SCALOC, DWORK(M+1), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN C P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) C DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, $ B( L1, MNL2 ), LDB ) SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + $ P12*B( L1, L2 ) ) C SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + $ P22*B( L1, L2 ) ) C DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, $ B( L2, MNL2 ), LDB ) DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, $ B( L2, MNL2 ), LDB ) SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + $ P12*B( L2, L2 ) ) C SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + $ P22*B( L2, L2 ) ) C CALL SB04PX( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 160 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 160 CONTINUE C CALL DSCAL( K2, SCALOC, DWORK, 1 ) CALL DSCAL( K2, SCALOC, DWORK(M+1), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF C 170 CONTINUE C 180 CONTINUE C ELSE C C Solve A*X*B' + ISGN*X = scale*C. C C The (K,L)th block of X is determined starting from C bottom-right corner column by column by C C A(K,K)*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) C C where C M C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L)' + C J=K+1 C M N C SUM { A(K,J) * SUM [X(J,I)*B(L,I)'] }. C J=K I=L+1 C C Start column loop (index = L) C L1 (L2): column index of the first (last) row of X(K,L). C LNEXT = N C DO 240 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 240 L2 = L IF( L.EQ.1 ) THEN L1 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 ELSE L1 = L END IF LNEXT = L1 - 1 END IF C C Start row loop (index = K) C K1 (K2): row index of the first (last) row of X(K,L). C KNEXT = M C DO 230 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 230 K2 = K IF( K.EQ.1 ) THEN K1 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 ELSE K1 = K END IF KNEXT = K1 - 1 END IF C MNK1 = MIN( K1+1, M ) MNK2 = MIN( K2+1, M ) MNL1 = MIN( L1+1, N ) MNL2 = MIN( L2+1, N ) P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, $ B( L1, MNL2 ), LDB ) C IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN C SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) SCALOC = ONE C A11 = A( K1, K1 )*B( L1, L1 ) + SGN DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 C IF( SCALOC.NE.ONE ) THEN C DO 190 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 190 CONTINUE C CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN C P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), $ 1 ) DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, $ B( L1, MNL1 ), LDB ) SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) C SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) C CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 200 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 200 CONTINUE C CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN C P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), $ 1 ) SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + $ P12*B( L1, L2 ) ) C DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, $ B( L2, MNL2 ), LDB ) SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), $ 1 ) VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + $ P12*B( L2, L2 ) ) C CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 210 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 210 CONTINUE C CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN C P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), $ 1 ) P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), $ 1 ) P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), $ 1 ) C DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, $ B( L1, MNL2 ), LDB ) SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + $ P12*B( L1, L2 ) ) C SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), $ 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + $ P22*B( L1, L2 ) ) C DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, $ B( L2, MNL2 ), LDB ) DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, $ B( L2, MNL2 ), LDB ) SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), $ 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + $ P12*B( L2, L2 ) ) C SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), $ 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + $ P22*B( L2, L2 ) ) C CALL SB04PX( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 220 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 220 CONTINUE C CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF C 230 CONTINUE C 240 CONTINUE C END IF C RETURN C *** Last line of SB04PY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02MX.f0000644000000000000000000000013015012430707016206 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB02MX.f0000644000175000017500000006132415012430707017412 0ustar00lilgelilge00000000000000 SUBROUTINE SB02MX( JOBG, JOBL, FACT, UPLO, TRANS, FLAG, DEF, N, M, $ A, LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, IPIV, $ OUFACT, G, LDG, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the following matrices C C -1 C G = B*R *B', C C - -1 C A = A +/- op(B*R *L'), C C - -1 C Q = Q +/- L*R *L', C C where A, B, Q, R, L, and G are N-by-N, N-by-M, N-by-N, M-by-M, C N-by-M, and N-by-N matrices, respectively, with Q, R and G C symmetric matrices, and op(W) is one of C C op(W) = W or op(W) = W'. C C When R is well-conditioned with respect to inversion, standard C algorithms for solving linear-quadratic optimization problems will C then also solve optimization problems with coupling weighting C matrix L. Moreover, a gain in efficiency is possible using matrix C G in the deflating subspace algorithms (see SLICOT Library routine C SB02OD) or in the Newton's algorithms (see SLICOT Library routine C SG02CD). C C ARGUMENTS C C Mode Parameters C C JOBG CHARACTER*1 C Specifies whether or not the matrix G is to be computed, C as follows: C = 'G': Compute G; C = 'N': Do not compute G. C C JOBL CHARACTER*1 C Specifies whether or not the matrix L is zero, as follows: C = 'Z': L is zero; C = 'N': L is nonzero. C C FACT CHARACTER*1 C Specifies how the matrix R is given (factored or not), as C follows: C = 'N': Array R contains the matrix R; C = 'C': Array R contains the Cholesky factor of R; C = 'U': Array R contains the factors of the symmetric C indefinite UdU' or LdL' factorization of R. C C UPLO CHARACTER*1 C Specifies which triangle of the matrices R, Q (if C JOBL = 'N'), and G (if JOBG = 'G') is stored, as follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. C C TRANS CHARACTER*1 C Specifies the form of op(W) to be used in the matrix C multiplication, as follows: C = 'N': op(W) = W; C = 'T': op(W) = W'; C = 'C': op(W) = W'. C C FLAG CHARACTER*1 C Specifies which sign is used, as follows: C = 'P': The plus sign is used; C = 'M': The minus sign is used. C C DEF CHARACTER*1 C If FACT = 'N', specifies whether or not it is assumed that C matrix R is positive definite, as follows: C = 'D': Matrix R is assumed positive definite; C = 'I': Matrix R is assumed indefinite. C Both values can be used to perform the computations, C irrespective to the R definiteness, but using the adequate C value will save some computational effort (see FURTHER C COMMENTS). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, Q, and G, and the number of C rows of the matrices B and L. N >= 0. C C M (input) INTEGER C The order of the matrix R, and the number of columns of C the matrices B and L. M >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, if JOBL = 'N', the leading N-by-N part of this C array must contain the matrix A. C On exit, if JOBL = 'N', and INFO = 0, the leading N-by-N C - C part of this array contains the matrix A. C If JOBL = 'Z', this array is not referenced. C C LDA INTEGER C The leading dimension of array A. C LDA >= MAX(1,N) if JOBL = 'N'; C LDA >= 1 if JOBL = 'Z'. 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 matrix B. C On exit, if OUFACT = 1, and INFO = 0, the leading N-by-M C -1 C part of this array contains the matrix B*chol(R) . C On exit, B is unchanged if OUFACT <> 1 (hence also when C FACT = 'U'). C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, if JOBL = 'N', the leading N-by-N upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the upper C triangular part or lower triangular part, respectively, of C the symmetric matrix Q. The strictly lower triangular part C (if UPLO = 'U') or strictly upper triangular part (if C UPLO = 'L') is not referenced. C On exit, if JOBL = 'N' and INFO = 0, the leading N-by-N C upper triangular part (if UPLO = 'U') or lower triangular C part (if UPLO = 'L') of this array contains the upper C triangular part or lower triangular part, respectively, of C - -1 C the symmetric matrix Q = Q +/- L*R *L'. C If JOBL = 'Z', this array is not referenced. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= MAX(1,N) if JOBL = 'N'; C LDQ >= 1 if JOBL = 'Z'. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) C On entry, if FACT = 'N', the leading M-by-M upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the upper C triangular part or lower triangular part, respectively, C of the symmetric input weighting matrix R. C On entry, if FACT = 'C', the leading M-by-M upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the Cholesky C factor of the positive definite input weighting matrix R C (as produced by LAPACK routine DPOTRF). C On entry, if FACT = 'U', the leading M-by-M upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the factors of C the UdU' or LdL' factorization, respectively, of the C symmetric indefinite input weighting matrix R (as produced C by LAPACK routine DSYTRF). C If FACT = 'N' and DEF = 'D', the strictly lower triangular C part (if UPLO = 'U') or strictly upper triangular part C (if UPLO = 'L') of this array is used as workspace (filled C in by symmetry). If FACT = 'N' and DEF = 'I', the strictly C lower triangular part (if UPLO = 'U') or strictly upper C triangular part (if UPLO = 'L') is unchanged. C On exit, if OUFACT = 1, and INFO = 0 (or INFO = M+1), C the leading M-by-M upper triangular part (if UPLO = 'U') C or lower triangular part (if UPLO = 'L') of this array C contains the Cholesky factor of the given input weighting C matrix. C On exit, if OUFACT = 2, and INFO = 0 (or INFO = M+1), C the leading M-by-M upper triangular part (if UPLO = 'U') C or lower triangular part (if UPLO = 'L') of this array C contains the factors of the UdU' or LdL' factorization, C respectively, of the given input weighting matrix. C On exit R is unchanged if FACT = 'C' or 'U'. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,M). C C L (input/output) DOUBLE PRECISION array, dimension (LDL,M) C On entry, if JOBL = 'N', the leading N-by-M part of this C array must contain the matrix L. C On exit, if JOBL = 'N', OUFACT = 1, and INFO = 0, the C leading N-by-M part of this array contains the matrix C -1 C L*chol(R) . C On exit, L is unchanged if OUFACT <> 1 (hence also when C FACT = 'U'). C L is not referenced if JOBL = 'Z'. C C LDL INTEGER C The leading dimension of array L. C LDL >= MAX(1,N) if JOBL = 'N'; C LDL >= 1 if JOBL = 'Z'. C C IPIV (input/output) INTEGER array, dimension (M) C On entry, if FACT = 'U', this array must contain details C of the interchanges performed and the block structure of C the d factor in the UdU' or LdL' factorization of matrix R C (as produced by LAPACK routine DSYTRF). C On exit, if OUFACT = 2, this array contains details of C the interchanges performed and the block structure of the C d factor in the UdU' or LdL' factorization of matrix R, C as produced by LAPACK routine DSYTRF. C This array is not referenced if FACT = 'C'. C C OUFACT (output) INTEGER C Information about the factorization finally used. C OUFACT = 0: no factorization of R has been used (M = 0); C OUFACT = 1: Cholesky factorization of R has been used; C OUFACT = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = 'L') C factorization of R has been used. C C G (output) DOUBLE PRECISION array, dimension (LDG,N) C If JOBG = 'G', and INFO = 0, the leading N-by-N upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array contains the upper C triangular part (if UPLO = 'U') or lower triangular part C -1 C (if UPLO = 'L'), respectively, of the matrix G = B*R B'. C If JOBG = 'N', this array is not referenced. C C LDG INTEGER C The leading dimension of array G. C LDG >= MAX(1,N) if JOBG = 'G'; C LDG >= 1 if JOBG = 'N'. C C Workspace C C IWORK INTEGER array, dimension (M) C If FACT = 'C' or FACT = 'U', this array is not referenced. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or LDWORK = -1, DWORK(1) returns the C optimal value of LDWORK; if FACT = 'N' and LDWORK is set C as specified below, DWORK(2) contains the reciprocal C condition number of the given matrix R. DWORK(2) is set to C zero if M = 0. C On exit, if LDWORK = -2 on input or INFO = -26, then C DWORK(1) returns the minimal value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 1 if FACT = 'C' or (FACT = 'U' and C JOBG = 'N' and JOBL = 'Z'); C LDWORK >= MAX(2,3*M) if FACT = 'N' and JOBG = 'N' and C JOBL = 'Z'; C LDWORK >= MAX(2,3*M,N*M) if FACT = 'N' and (JOBG = 'G' or C JOBL = 'N'); C LDWORK >= MAX(1,N*M) if FACT = 'U' and (JOBG = 'G' or C JOBL = 'N'). C For optimum performance LDWORK should be larger than 3*M, C if FACT = 'N'. C C If LDWORK = -1, an optimal workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C If LDWORK = -2, a minimal workspace query is assumed; the C routine only calculates the minimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message 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 = i: if the i-th element (1 <= i <= M) of the d factor is C exactly zero; the UdU' (or LdL') factorization has C been completed, but the block diagonal matrix d is C exactly singular; C = M+1: if the matrix R is numerically singular. C C METHOD C - - C The matrices G, and/or A and Q are evaluated using the given or C computed symmetric factorization of R. C C NUMERICAL ASPECTS C C The routine should not be used when R is ill-conditioned. C C FURTHER COMMENTS C C Using argument TRANS allows to avoid the transposition of matrix A C needed to solve optimal filtering/estimation problems by the same C routines solving optimal control problems. C If DEF is set to 'D', but R is indefinite, the computational C effort for factorization will be approximately double, since C Cholesky factorization, tried first, will fail, and symmetric C indefinite factorization will then be used. C If DEF is set to 'I', but R is positive definite, the C computational effort will be slightly higher than that when using C Cholesky factorization. It is recommended to use DEF = 'D' also if C the definiteness is not known, but M is (much) smaller than N. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2014. C This is an extended version of the SLICOT Library routine SB02MT. C C REVISIONS C C V. Sima, May 2014, Aug. 2017, Oct. 2017. C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, discrete-time system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DEF, FACT, FLAG, JOBG, JOBL, TRANS, UPLO INTEGER INFO, LDA, LDB, LDG, LDL, LDQ, LDR, LDWORK, M, $ N, OUFACT C .. Array Arguments .. INTEGER IPIV(*), IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), G(LDG,*), $ L(LDL,*), Q(LDQ,*), R(LDR,*) C .. Local Scalars .. LOGICAL BNZER, LDEF, LFACTC, LFACTU, LFLAG, LJOBG, $ LJOBL, LNFACT, LTRANS, LUPLOU CHARACTER NT, TR, TRANSU INTEGER J, WRKMIN, WRKOPT DOUBLE PRECISION EPS, RCOND, RNORM, TEMP C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE, DLANSY EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DLASET, DPOCON, DPOTRF, DSYCON, $ DSYRK, DSYTRF, DSYTRS, DTRSM, MA02ED, MB01RB, $ XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C INFO = 0 LJOBG = LSAME( JOBG, 'G' ) LJOBL = LSAME( JOBL, 'N' ) LFACTC = LSAME( FACT, 'C' ) LFACTU = LSAME( FACT, 'U' ) LTRANS = LSAME( TRANS, 'N' ) LUPLOU = LSAME( UPLO, 'U' ) LFLAG = LSAME( FLAG, 'M' ) LDEF = LSAME( DEF, 'D' ) LNFACT = .NOT.( LFACTC .OR. LFACTU ) C C Test the input scalar arguments. C IF( .NOT.LJOBG .AND. .NOT.LSAME( JOBG, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN INFO = -2 ELSE IF( LNFACT .AND. .NOT.LSAME( FACT, 'N' ) ) THEN INFO = -3 ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -4 ELSE IF( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'T' ) $ .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -5 ELSE IF( .NOT.LFLAG .AND. .NOT.LSAME( FLAG, 'P' ) ) THEN INFO = -6 ELSE IF( .NOT.LDEF .AND. .NOT.LSAME( DEF, 'I' ) $ .AND. LNFACT ) THEN INFO = -7 ELSE IF( N.LT.0 ) THEN INFO = -8 ELSE IF( M.LT.0 ) THEN INFO = -9 ELSE IF( LDA.LT.1 .OR. ( LJOBL .AND. LDA.LT.N ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDQ.LT.1 .OR. ( LJOBL .AND. LDQ.LT.N ) ) THEN INFO = -15 ELSE IF( LDR.LT.MAX( 1, M ) ) THEN INFO = -17 ELSE IF( LDL.LT.1 .OR. ( LJOBL .AND. LDL.LT.N ) ) THEN INFO = -19 ELSE IF( LDG.LT.1 .OR. ( LJOBG .AND. LDG.LT.N ) ) THEN INFO = -23 ELSE IF( LFACTC ) THEN WRKMIN = 1 ELSE IF( LFACTU ) THEN IF( LJOBG .OR. LJOBL ) THEN WRKMIN = MAX( 1, N*M ) ELSE WRKMIN = 1 END IF ELSE IF( LJOBG .OR. LJOBL ) THEN WRKMIN = MAX( 2, 3*M, N*M ) ELSE WRKMIN = MAX( 2, 3*M ) END IF END IF IF( LDWORK.EQ.-1 ) THEN IF( LNFACT ) THEN CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, -1, INFO ) WRKOPT = MAX( WRKMIN, INT( DWORK(1) ) ) ELSE WRKOPT = WRKMIN END IF DWORK(1) = WRKOPT RETURN ELSE IF( LDWORK.EQ.-2 ) THEN DWORK(1) = WRKMIN RETURN ELSE IF( LDWORK.LT.WRKMIN ) THEN INFO = -26 DWORK(1) = WRKMIN END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB02MX', -INFO ) RETURN END IF C C Quick return if possible. C IF( M.EQ.0 ) THEN IF( LJOBG ) $ CALL DLASET( UPLO, N, N, ZERO, ZERO, G, LDG ) OUFACT = 0 DWORK(1) = WRKMIN IF( LNFACT ) $ DWORK(2) = ZERO RETURN END IF C C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 WRKOPT = 1 C IF( LNFACT ) THEN C C Set relative machine precision. C EPS = DLAMCH( 'Precision' ) C C Compute the norm of the matrix R, which is not factored. C Then, if DEF = 'D', save the given triangle of R in the other C strict triangle and the diagonal in the workspace, and try C Cholesky factorization. C Workspace: need M. C RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) C IF( LDEF ) THEN CALL DCOPY( M, R, LDR+1, DWORK, 1 ) CALL MA02ED( UPLO, M, R, LDR ) CALL DPOTRF( UPLO, M, R, LDR, INFO ) IF( INFO.EQ.0 ) THEN C C Compute the reciprocal of the condition number of R. C Workspace: need 3*M. C CALL DPOCON( UPLO, M, R, LDR, RNORM, RCOND, DWORK, IWORK, $ INFO ) C C Return if the matrix is singular to working precision. C OUFACT = 1 IF( RCOND.LT.EPS ) THEN INFO = M + 1 DWORK(2) = RCOND RETURN END IF WRKOPT = MAX( WRKOPT, 3*M ) ELSE C C Restore the saved triangle, to use the UdU' or LdL' C factorization. C CALL DCOPY( M, DWORK, 1, R, LDR+1 ) IF( LUPLOU ) THEN CALL MA02ED( 'Lower', M, R, LDR ) ELSE CALL MA02ED( 'Upper', M, R, LDR ) END IF END IF END IF C IF( .NOT.LDEF .OR. INFO.GT.0 ) THEN C C Compute the UdU' or LdL' factorization. C Workspace: need 1, C prefer M*NB. C CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) OUFACT = 2 IF( INFO.GT.0 ) THEN DWORK(2) = ZERO RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Compute the reciprocal of the condition number of R. C Workspace: need 2*M. C CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, $ IWORK, INFO ) C C Return if the matrix is singular to working precision. C IF( RCOND.LT.EPS ) THEN INFO = M + 1 DWORK(2) = RCOND RETURN END IF END IF ELSE IF( LFACTC ) THEN OUFACT = 1 ELSE OUFACT = 2 END IF C IF( N.GT.0 ) THEN NT = 'No transpose' TR = 'Transpose' C IF( LJOBL ) THEN IF( LFLAG ) THEN TEMP = -ONE ELSE TEMP = ONE END IF END IF C BNZER = DLANGE( '1-norm', N, M, B, LDB, DWORK ).GT.ZERO C IF( OUFACT.EQ.1 ) THEN C C Solve positive definite linear system(s). C IF( LUPLOU ) THEN TRANSU = NT ELSE TRANSU = TR END IF C IF( BNZER ) THEN C C Solve the system X*U = B, overwriting B with X. C CALL DTRSM( 'Right', UPLO, TRANSU, 'Non-unit', N, M, ONE, $ R, LDR, B, LDB ) C IF( LJOBG ) THEN C -1 C Compute the matrix G = B*R *B', multiplying X*X'. C CALL DSYRK( UPLO, NT, N, M, ONE, B, LDB, ZERO, G, LDG) END IF END IF C IF( LJOBL ) THEN C C Update matrices A (if B nonzero) and Q. C C Solve the system Y*U = L, overwriting L with Y. C CALL DTRSM( 'Right', UPLO, TRANSU, 'Non-unit', N, M, ONE, $ R, LDR, L, LDL ) C IF( BNZER ) THEN C C Compute A <- A +/- op(X*Y'). C IF( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, M, TEMP, B, LDB, L, LDL, $ ONE, A, LDA ) ELSE CALL DGEMM( NT, TR, N, N, M, TEMP, L, LDL, B, LDB, $ ONE, A, LDA ) END IF END IF C C Compute Q <- Q +/- Y*Y'. C CALL DSYRK( UPLO, NT, N, M, TEMP, L, LDL, ONE, Q, LDQ ) END IF ELSE C C Solve indefinite linear system(s). C IF( BNZER ) THEN C IF( LJOBG .OR. .NOT.LTRANS ) THEN C C Solve the system UdU'*X = B' (or LdL'*X = B'). C Workspace: need N*M. C DO 10 J = 1, M CALL DCOPY( N, B(1,J), 1, DWORK(J), M ) 10 CONTINUE C CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO) END IF C IF( LJOBG ) THEN C -1 C Compute a triangle of the matrix G = B*R *B' = B*X. C CALL MB01RB( 'Left', UPLO, NT, N, M, ZERO, ONE, G, $ LDG, B, LDB, DWORK, M, INFO ) END IF END IF C IF( LJOBL ) THEN C C Update matrices A and Q. C IF( .NOT.LTRANS .AND. BNZER ) THEN C C A <- A +/- L*X, if TRANS <> 'N'. C CALL DGEMM( NT, NT, N, N, M, TEMP, L, LDL, DWORK, M, $ ONE, A, LDA ) END IF C C Solve the system UdU'*Y = L' (or LdL'*Y = L'). C DO 20 J = 1, M CALL DCOPY( N, L(1,J), 1, DWORK(J), M ) 20 CONTINUE C CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) C IF( LTRANS .AND. BNZER ) THEN C C A <- A +/- B*Y, if TRANS = 'N'. C CALL DGEMM( NT, NT, N, N, M, TEMP, B, LDB, DWORK, M, $ ONE, A, LDA ) END IF C - -1 C Compute a triangle of the matrix Q = Q +/- L*R *L' C = Q +/- L*Y. C CALL MB01RB( 'Left', UPLO, NT, N, M, ONE, TEMP, Q, LDQ, $ L, LDL, DWORK, M, INFO ) END IF END IF END IF C DWORK(1) = WRKOPT IF( LNFACT ) $ DWORK(2) = RCOND C C *** Last line of SB02MX *** RETURN END control-4.1.2/src/slicot/src/PaxHeaders/MB04TT.f0000644000000000000000000000013215012430707016207 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04TT.f0000644000175000017500000003306315012430707017410 0ustar00lilgelilge00000000000000 SUBROUTINE MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A, $ LDA, E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANK, TOL, $ IWORK ) C C PURPOSE C C Let A and E be M-by-N matrices with E in column echelon form. C Let AA and EE be the following submatrices of A and E: C AA := A(IFIRA : M ; IFICA : N) C EE := E(IFIRA : M ; IFICA : N). C Let Aj and Ej be the following submatrices of AA and EE: C Aj := A(IFIRA : M ; IFICA : IFICA + NCA - 1) and C Ej := E(IFIRA : M ; IFICA + NCA : N). C C To transform (AA,EE) such that Aj is row compressed while keeping C matrix Ej in column echelon form (which may be different from the C form on entry). C In fact the routine performs the j-th step of Algorithm 3.2.1 in C [1]. Furthermore, it determines the rank RANK of the submatrix Ej, C which is equal to the number of corner points in submatrix Ej. C C ARGUMENTS C C Mode Parameters C C UPDATQ LOGICAL C Indicates whether the user wishes to accumulate in a C matrix Q the orthogonal row transformations, as follows: C = .FALSE.: Do not form Q; C = .TRUE.: The given matrix Q is updated by the orthogonal C row transformations used in the reduction. C C UPDATZ LOGICAL C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal column transformations, as C follows: C = .FALSE.: Do not form Z; C = .TRUE.: The given matrix Z is updated by the orthogonal C column transformations used in the reduction. C C Input/Output Parameters C C M (input) INTEGER C M is the number of rows of the matrices A, E and Q. C M >= 0. C C N (input) INTEGER C N is the number of columns of the matrices A, E and Z. C N >= 0. C C IFIRA (input) INTEGER C IFIRA is the first row index of the submatrices Aj and Ej C in the matrices A and E, respectively. C C IFICA (input) INTEGER C IFICA and IFICA + NCA are the first column indices of the C submatrices Aj and Ej in the matrices A and E, C respectively. C C NCA (input) INTEGER C NCA is the number of columns of the submatrix Aj in A. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, A(IFIRA : M ; IFICA : IFICA + NCA - 1) contains C the matrix Aj. C On exit, it contains the matrix A with AA that has been C row compressed while keeping EE in column echelon form. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, E(IFIRA : M ; IFICA + NCA : N) contains the C matrix Ej which is in column echelon form. C On exit, it contains the transformed matrix EE which is C kept in column echelon form. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,M). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) C On entry, if UPDATQ = .TRUE., then the leading M-by-M C part of this array must contain a given matrix Q (e.g. C from a previous call to another SLICOT routine), and on C exit, the leading M-by-M part of this array contains the C product of the input matrix Q and the row transformation C matrix that has transformed the rows of the matrices A C and E. C If UPDATQ = .FALSE., the array Q is not referenced and C can be supplied as a dummy array (i.e. set parameter C LDQ = 1 and declare this array to be Q(1,1) in the calling C program). C C LDQ INTEGER C The leading dimension of array Q. If UPDATQ = .TRUE., C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) C On entry, if UPDATZ = .TRUE., then the leading N-by-N C part of this array must contain a given matrix Z (e.g. C from a previous call to another SLICOT routine), and on C exit, the leading N-by-N part of this array contains the C product of the input matrix Z and the column C transformation matrix that has transformed the columns of C the matrices A and E. C If UPDATZ = .FALSE., the array Z is not referenced and C can be supplied as a dummy array (i.e. set parameter C LDZ = 1 and declare this array to be Z(1,1) in the calling C program). C C LDZ INTEGER C The leading dimension of array Z. If UPDATZ = .TRUE., C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. C C ISTAIR (input/output) INTEGER array, dimension (M) C On entry, ISTAIR contains information on the column C echelon form of the input matrix E as follows: C ISTAIR(i) = +j: the boundary element E(i,j) is a corner C point; C -j: the boundary element E(i,j) is not a C corner point (where i=1,...,M). C On exit, ISTAIR contains the same information for the C transformed matrix E. C C RANK (output) INTEGER C Numerical rank of the submatrix Aj in A (based on TOL). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance used when considering matrix elements C to be zero. C C Workspace C C IWORK INTEGER array, dimension (N) C C REFERENCES C C [1] Beelen, Th. C New Algorithms for Computing the Kronecker structure of a C Pencil with Applications to Systems and Control Theory. C Ph.D.Thesis, Eindhoven University of Technology, C The Netherlands, 1987. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations and is backward stable. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MB04FZ by Th.G.J. Beelen, C Philips Glass Eindhoven, Holland. C C REVISIONS C C June 13, 1997, V. Sima. C November 24, 1997, A. Varga: array starting point A(KK,LL) C correctly set when calling DLASET. C December 08, 2016, V. Sima. C C KEYWORDS C C Echelon form, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. LOGICAL UPDATQ, UPDATZ INTEGER IFICA, IFIRA, LDA, LDE, LDQ, LDZ, M, N, NCA, $ RANK DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER ISTAIR(*), IWORK(*) DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. LOGICAL LZERO INTEGER I, IFICA1, IFIRA1, II, IP, IST1, IST2, ISTPVT, $ ITYPE, JC1, JC2, JPVT, K, KK, L, LL, LSAV, MJ, $ MK1, MXRANK, NJ DOUBLE PRECISION BMX, BMXNRM, EIJPVT, SC, SS C .. External Functions .. INTEGER IDAMAX EXTERNAL IDAMAX C .. External Subroutines .. EXTERNAL DLAPMT, DLASET, DROT, DROTG, DSWAP C .. Intrinsic Functions .. INTRINSIC ABS, MIN C .. Executable Statements .. C RANK = 0 IF ( M.LE.0 .OR. N.LE.0 ) $ RETURN C C Initialisation. C C NJ = number of columns in submatrix Aj, C MJ = number of rows in submatrices Aj and Ej. C NJ = NCA MJ = M + 1 - IFIRA IFIRA1 = IFIRA - 1 IFICA1 = IFICA - 1 C DO 20 I = 1, NJ IWORK(I) = I 20 CONTINUE C K = 1 LZERO = .FALSE. RANK = MIN( NJ, MJ ) MXRANK = RANK C C WHILE ( K <= MXRANK ) and ( LZERO = FALSE ) DO 40 IF ( ( K.LE.MXRANK ) .AND. ( .NOT.LZERO ) ) THEN C C Determine column in Aj with largest max-norm. C BMXNRM = ZERO LSAV = K KK = IFIRA1 + K C DO 60 L = K, NJ C C IDAMAX call gives the relative index in column L of Aj where C max element is found. C Note: the first element in column L is in row K of C matrix Aj. C LL = IFICA1 + L BMX = ABS( A(IDAMAX( MJ-K+1, A(KK,LL), 1 )+KK-1,LL) ) IF ( BMX.GT.BMXNRM ) THEN BMXNRM = BMX LSAV = L END IF 60 CONTINUE C LL = IFICA1 + K IF ( BMXNRM.LE.TOL ) THEN C C Set submatrix of Aj to zero. C CALL DLASET( 'Full', MJ-K+1, NJ-K+1, ZERO, ZERO, A(KK,LL), $ LDA ) LZERO = .TRUE. RANK = K - 1 ELSE C C Check whether columns have to be interchanged. C IF ( LSAV.NE.K ) THEN C C Interchange the columns in A which correspond to the C columns lsav and k in Aj. Store the permutation in IWORK. C CALL DSWAP( M, A(1,LL), 1, A(1,IFICA1+LSAV), 1 ) IP = IWORK(LSAV) IWORK(LSAV) = IWORK(K) IWORK(K) = IP END IF C K = K + 1 MK1 = N - LL + 1 C DO 80 I = MJ, K, -1 C C II = absolute row number in A corresponding to row i in C Aj. C II = IFIRA1 + I C C Construct Givens transformation to annihilate Aj(i,k). C Apply the row transformation to whole matrix A C (NOT only to Aj). C Update row transformation matrix Q, if needed. C CALL DROTG( A(II-1,LL), A(II,LL), SC, SS ) CALL DROT( MK1-1, A(II-1,LL+1), LDA, A(II,LL+1), LDA, SC, $ SS ) A(II,LL) = ZERO IF ( UPDATQ ) $ CALL DROT( M, Q(1,II-1), 1, Q(1,II), 1, SC, SS ) C C Determine boundary type of matrix E at rows II-1 and II. C IST1 = ISTAIR(II-1) IST2 = ISTAIR(II) IF ( ( IST1*IST2 ).GT.0 ) THEN IF ( IST1.GT.0 ) THEN C C boundary form = (* x) C (0 *) C ITYPE = 1 ELSE C C boundary form = (x x) C (x x) C ITYPE = 3 END IF ELSE IF ( IST1.LT.0 ) THEN C C boundary form = (x x) C (* x) C ITYPE = 2 ELSE C C boundary form = (* x) C (0 x) C ITYPE = 4 END IF END IF C C Apply row transformation also to matrix E. C C JC1 = absolute number of the column in E in which stair C element of row i-1 of Ej is present. C JC2 = absolute number of the column in E in which stair C element of row i of Ej is present. C C Note: JC1 < JC2 if ITYPE = 1. C JC1 = JC2 if ITYPE = 2, 3 or 4. C JC1 = ABS( IST1 ) JC2 = ABS( IST2 ) JPVT = MIN( JC1, JC2 ) C CALL DROT( N-JPVT+1, E(II-1,JPVT), LDE, E(II,JPVT), LDE, $ SC, SS ) EIJPVT = E(II,JPVT) C IF ( ITYPE.EQ.1 ) THEN C C Construct column Givens transformation to annihilate C E(ii,jpvt). C Apply column Givens transformation to matrix E C (NOT only to Ej). C CALL DROTG( E(II,JPVT+1), E(II,JPVT), SC, SS ) CALL DROT( II-1, E(1,JPVT+1), 1, E(1,JPVT), 1, SC, $ SS ) E(II,JPVT) = ZERO C C Apply this transformation also to matrix A C (NOT only to Aj). C Update column transformation matrix Z, if needed. C CALL DROT( M, A(1,JPVT+1), 1, A(1,JPVT), 1, SC, SS ) IF ( UPDATZ ) CALL DROT( N, Z(1,JPVT+1), 1, Z(1,JPVT), $ 1, SC, SS ) C ELSE IF ( ITYPE.EQ.2 ) THEN IF ( ABS( EIJPVT ).LE.TOL ) THEN C C (x x) (* x) C Boundary form has been changed from (* x) to (0 x). C ISTPVT = ISTAIR(II) ISTAIR(II-1) = ISTPVT ISTAIR(II) = -(ISTPVT+1 ) E(II,JPVT) = ZERO END IF C ELSE IF ( ITYPE.EQ.4 ) THEN IF ( ABS( EIJPVT ).GT.TOL ) THEN C C (* x) (x x) C Boundary form has been changed from (0 x) to (* x). C ISTPVT = ISTAIR(II-1) ISTAIR(II-1) = -ISTPVT ISTAIR(II) = ISTPVT END IF END IF 80 CONTINUE C END IF GO TO 40 END IF C END WHILE 40 C C Permute columns of Aj to original order. C CALL DLAPMT( .FALSE., IFIRA1+RANK, NJ, A(1,IFICA), LDA, IWORK ) C RETURN C *** Last line of MB04TT *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10SD.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10SD.f0000644000175000017500000005014515012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE SB10SD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, $ X, LDX, Y, LDY, RCOND, TOL, IWORK, DWORK, $ LDWORK, BWORK, INFO ) C C PURPOSE C C To compute the matrices of the H2 optimal controller C C | AK | BK | C K = |----|----|, C | CK | DK | C C for the normalized discrete-time system C C | A | B1 B2 | | A | B | C P = |----|---------| = |---|---| C | C1 | D11 D12 | | C | D | C | C2 | D21 0 | C C where B2 has as column size the number of control inputs (NCON) C and C2 has as row size the number of measurements (NMEAS) being C 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 with D21 = | 0 I | as obtained by the C SLICOT Library routine SB10PD, 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 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 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. Only the leading C (NP-NP2)-by-(M-M2) submatrix D11 is used. 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 Y (output) DOUBLE PRECISION array, dimension (LDY,N) C The leading N-by-N part of this array contains the matrix C Y, solution of the Y-Riccati equation. C C LDY INTEGER C The leading dimension of the array Y. LDY >= max(1,N). C C RCOND (output) DOUBLE PRECISION array, dimension (4) C RCOND contains estimates of the reciprocal condition C numbers of the matrices which are to be inverted and the C reciprocal condition numbers of the Riccati equations C which have to be solved during the computation of the C controller. (See the description of the algorithm in [2].) C RCOND(1) contains the reciprocal condition number of the C matrix Im2 + B2'*X2*B2; C RCOND(2) contains the reciprocal condition number of the C matrix Ip2 + C2*Y2*C2'; C RCOND(3) contains the reciprocal condition number of the C X-Riccati equation; C RCOND(4) contains the reciprocal condition number of the C Y-Riccati equation. C C Tolerances C C TOL DOUBLE PRECISION C Tolerance used in determining the nonsingularity of the C matrices which must be inverted. If TOL <= 0, then a C default value equal to sqrt(EPS) is used, where EPS is the C relative machine precision. C C Workspace C C IWORK INTEGER array, dimension (max(M2,2*N,N*N,NP2)) 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(1, 14*N*N+6*N+max(14*N+23,16*N), C M2*(N+M2+max(3,M1)), NP2*(N+NP2+3)), C where M1 = M - M2. C For good performance, LDWORK must generally be larger. 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 X-Riccati equation was not solved C successfully; C = 2: if the matrix Im2 + B2'*X2*B2 is not positive C definite, or it is numerically singular (with C respect to the tolerance TOL); C = 3: if the Y-Riccati equation was not solved C successfully; C = 4: if the matrix Ip2 + C2*Y2*C2' is not positive C definite, or it is numerically singular (with C respect to the tolerance TOL). C C METHOD C C The routine implements the formulas given in [1]. The X- and C Y-Riccati equations are solved with condition estimates. C C REFERENCES C C [1] Zhou, K., Doyle, J.C., and Glover, K. C Robust and Optimal Control. C Prentice-Hall, Upper Saddle River, NJ, 1996. 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 The accuracy of the result depends on the condition numbers of the C matrices which are to be inverted and on the condition numbers of C the matrix Riccati equations which are to be solved in the C computation of the controller. (The corresponding reciprocal C condition numbers are given in 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, May 1999, C January 2003. C C KEYWORDS C C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal C regulator, robust 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, LDX, LDY, M, N, NCON, NMEAS, NP DOUBLE PRECISION 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, * ), Y( LDY, * ) LOGICAL BWORK( * ) C .. C .. Local Scalars .. INTEGER INFO2, IW2, IWB, IWC, IWG, IWI, IWQ, IWR, IWRK, $ IWS, IWT, IWU, IWV, J, LWAMAX, M1, M2, MINWRK, $ ND1, ND2, NP1, NP2 DOUBLE PRECISION ANORM, FERR, RCOND2, SEPD, TOLL C .. C .. External functions .. DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL DLAMCH, DLANSY C .. C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, DPOCON, DPOTRF, DPOTRS, $ DSWAP, DSYRK, DTRSM, 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -11 ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN INFO = -13 ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN INFO = -19 ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN INFO = -21 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -23 ELSE IF( LDY.LT.MAX( 1, N ) ) THEN INFO = -25 ELSE C C Compute workspace. C MINWRK = MAX( 1, 14*N*N + 6*N + MAX( 14*N + 23, 16*N ), $ M2*( N + M2 + MAX( 3, M1 ) ), NP2*( N + NP2 + 3 ) ) IF( LDWORK.LT.MINWRK ) $ INFO = -30 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10SD', -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 ND1 = NP1 - M2 ND2 = M1 - NP2 TOLL = TOL IF( TOLL.LE.ZERO ) THEN C C Set the default value of the tolerance for nonsingularity test. C TOLL = SQRT( DLAMCH( 'Epsilon' ) ) END IF C C Workspace usage. C IWQ = 1 IWG = IWQ + N*N IWR = IWG + N*N IWI = IWR + 2*N IWB = IWI + 2*N IWS = IWB + 2*N IWT = IWS + 4*N*N IWU = IWT + 4*N*N IWRK = IWU + 4*N*N IWC = IWR IWV = IWC + N*N C C Compute Ax = A - B2*D12'*C1 in AK . C CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB, $ C( ND1+1, 1), LDC, ONE, AK, LDAK ) C C Compute Cx = C1'*C1 - C1'*D12*D12'*C1 . C IF( ND1.GT.0 ) THEN CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ), $ N ) ELSE CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) END IF C C Compute Dx = B2*B2' . C CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO, $ DWORK( IWG ), N ) C C Solution of the discrete-time Riccati equation C Ax'*inv(In + X2*Dx)*X2*Ax - X2 + Cx = 0 . C Workspace: need 14*N*N + 6*N + max(14*N+23,16*N); C prefer larger. C CALL SB02OD( 'D', 'G', 'N', 'L', 'Z', 'S', N, M2, NP1, AK, LDAK, $ DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M, $ DWORK( IWRK ), N, RCOND2, X, LDX, DWORK( IWR ), $ DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N, $ DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 C C Condition estimation. C Workspace: need 4*N*N + max(N*N+5*N,max(3,2*N*N)+N*N); C prefer larger. C IWRK = IWV + N*N CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, AK, LDAK, DWORK( IWC ), $ N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, $ X, LDX, SEPD, RCOND( 3 ), FERR, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO2 ) IF( INFO2.GT.0 ) RCOND( 3 ) = ZERO LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Workspace usage. C IW2 = M2*N + 1 IWRK = IW2 + M2*M2 C C Compute B2'*X2 . C CALL DGEMM( 'T', 'N', M2, N, N, ONE, B( 1, M1+1 ), LDB, X, LDX, $ ZERO, DWORK, M2 ) C C Compute Im2 + B2'*X2*B2 . C CALL DLASET( 'L', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) CALL MB01RX( 'Left', 'Lower', 'N', M2, N, ONE, ONE, DWORK( IW2 ), $ M2, DWORK, M2, B( 1, M1+1 ), LDB, INFO2 ) C C Compute the Cholesky factorization of Im2 + B2'*X2*B2 . C Workspace: need M2*N + M2*M2 + max(3*M2,M2*M1); C prefer larger. C ANORM = DLANSY( 'I', 'L', M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) CALL DPOTRF( 'L', M2, DWORK( IW2 ), M2, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 2 RETURN END IF CALL DPOCON( 'L', M2, DWORK( IW2 ), M2, 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 = 2 RETURN END IF C C Compute -( B2'*X2*A + D12'*C1 ) in CK . C CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, CK, LDCK ) CALL DGEMM( 'N', 'N', M2, N, N, -ONE, DWORK, M2, A, LDA, -ONE, CK, $ LDCK ) C C Compute F2 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*A + D12'*C1 ) . C CALL DPOTRS( 'L', M2, N, DWORK( IW2 ), M2, CK, LDCK, INFO2 ) C C Compute -( B2'*X2*B1 + D12'*D11 ) . C CALL DLACPY( 'Full', M2, M1, D( ND1+1, 1 ), LDD, DWORK( IWRK ), $ M2 ) CALL DGEMM( 'N', 'N', M2, M1, N, -ONE, DWORK, M2, B, LDB, -ONE, $ DWORK( IWRK ), M2 ) C C Compute F0 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*B1 + D12'*D11 ) . C CALL DPOTRS( 'L', M2, M1, DWORK( IW2 ), M2, DWORK( IWRK ), M2, $ INFO2 ) C C Save F0*D21' in DK . C CALL DLACPY( 'Full', M2, NP2, DWORK( IWRK+ND2*M2 ), M2, DK, $ LDDK ) C C Workspace usage. C IWRK = IWU + 4*N*N C C Compute Ay = A - B1*D21'*C2 in AK . C CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB, $ C( NP1+1, 1 ), LDC, ONE, AK, LDAK ) C C Transpose Ay in-situ. C DO 20 J = 1, N - 1 CALL DSWAP( J, AK( J+1, 1 ), LDAK, AK( 1, J+1 ), 1 ) 20 CONTINUE C C Compute Cy = B1*B1' - B1*D21'*D21*B1' . C IF( ND2.GT.0 ) THEN CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ), $ N ) ELSE CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) END IF C C Compute Dy = C2'*C2 . C CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO, $ DWORK( IWG ), N ) C C Solution of the discrete-time Riccati equation C Ay*inv( In + Y2*Dy )*Y2*Ay' - Y2 + Cy = 0 . C CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, NP2, M1, AK, LDAK, $ DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M, $ DWORK( IWRK ), N, RCOND2, Y, LDY, DWORK( IWR ), $ DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N, $ DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 3 RETURN END IF LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Condition estimation. C IWRK = IWV + N*N CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWC ), $ N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, $ Y, LDY, SEPD, RCOND( 4 ), FERR, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO2 ) IF( INFO2.GT.0 ) RCOND( 4 ) = ZERO LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Workspace usage. C IW2 = N*NP2 + 1 IWRK = IW2 + NP2*NP2 C C Compute Y2*C2' . C CALL DGEMM( 'N', 'T', N, NP2, N, ONE, Y, LDY, C( NP1+1, 1 ), LDC, $ ZERO, DWORK, N ) C C Compute Ip2 + C2*Y2*C2' . C CALL DLASET( 'U', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 ) CALL MB01RX( 'Left', 'Upper', 'N', NP2, N, ONE, ONE, DWORK( IW2 ), $ NP2, C( NP1+1, 1 ), LDC, DWORK, N, INFO2 ) C C Compute the Cholesky factorization of Ip2 + C2*Y2*C2' . C ANORM = DLANSY( 'I', 'U', NP2, DWORK( IW2 ), NP2, DWORK( IWRK ) ) CALL DPOTRF( 'U', NP2, DWORK( IW2 ), NP2, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 4 RETURN END IF CALL DPOCON( 'U', NP2, DWORK( IW2 ), NP2, 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 = 4 RETURN END IF C C Compute A*Y2*C2' + B1*D21' in BK . C CALL DLACPY ( 'Full', N, NP2, B( 1, ND2+1 ), LDB, BK, LDBK ) CALL DGEMM( 'N', 'N', N, NP2, N, ONE, A, LDA, DWORK, N, ONE, $ BK, LDBK ) C C Compute L2 = -( A*Y2*C2' + B1*D21' )*inv( Ip2 + C2*Y2*C2' ) . C CALL DTRSM( 'R', 'U', 'N', 'N', N, NP2, -ONE, DWORK( IW2 ), NP2, $ BK, LDBK ) CALL DTRSM( 'R', 'U', 'T', 'N', N, NP2, ONE, DWORK( IW2 ), NP2, $ BK, LDBK ) C C Compute F2*Y2*C2' + F0*D21' . C CALL DGEMM( 'N', 'N', M2, NP2, N, ONE, CK, LDCK, DWORK, N, ONE, $ DK, LDDK ) C C Compute DK = L0 = ( F2*Y2*C2' + F0*D21' )*inv( Ip2 + C2*Y2*C2' ) . C CALL DTRSM( 'R', 'U', 'N', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2, $ DK, LDDK ) CALL DTRSM( 'R', 'U', 'T', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2, $ DK, LDDK ) C C Compute CK = F2 - L0*C2 . C CALL DGEMM( 'N', 'N', M2, N, NP2, -ONE, DK, LDDK, C( NP1+1, 1), $ LDC, ONE, CK, LDCK ) C C Find AK = A + B2*( F2 - L0*C2 ) + L2*C2 . C CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, M2, ONE, B(1, M1+1 ), LDB, CK, LDCK, $ ONE, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, C( NP1+1, 1), $ LDC, ONE, AK, LDAK ) C C Find BK = -L2 + B2*L0 . C CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, B( 1, M1+1 ), LDB, DK, $ LDDK, -ONE, BK, LDBK ) C DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10SD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10ZP.f0000644000000000000000000000013215012430707016214 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10ZP.f0000644000175000017500000002452615012430707017421 0ustar00lilgelilge00000000000000 SUBROUTINE SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To transform a SISO (single-input single-output) system [A,B;C,D] C by mirroring its unstable poles and zeros in the boundary of the C stability domain, thus preserving the frequency response of the C system, but making it stable and minimum phase. Specifically, for C a continuous-time system, the positive real parts of its poles C and zeros are exchanged with their negatives. Discrete-time C systems are first converted to continuous-time systems using a C bilinear transformation, and finally converted back. C C ARGUMENTS C C Input/Output parameters C C DISCFL (input) INTEGER C Indicates the type of the system, as follows: C = 0: continuous-time system; C = 1: discrete-time system. C C N (input/output) INTEGER C On entry, the order of the original system. N >= 0. C On exit, the order of the transformed, minimal system. 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 original system matrix A. C On exit, the leading N-by-N part of this array contains C the transformed matrix A, in an upper Hessenberg form. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the original system C vector B. C On exit, this array contains the transformed vector B. C C C (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the original system C vector C. C On exit, this array contains the transformed vector C. C The first N-1 elements are zero (for the exit value of N). C C D (input/output) DOUBLE PRECISION array, dimension (1) C On entry, this array must contain the original system C scalar D. C On exit, this array contains the transformed scalar D. C C Workspace C C IWORK INTEGER array, dimension (max(2,N+1)) 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(N*N + 5*N, 6*N + 1 + min(1,N)). 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: if the discrete --> continuous transformation cannot C be made; C = 2: if the system poles cannot be found; C = 3: if the inverse system cannot be found, i.e., D is C (close to) zero; C = 4: if the system zeros cannot be found; C = 5: if the state-space representation of the new C transfer function T(s) cannot be found; C = 6: if the continuous --> discrete transformation cannot C be made. C C METHOD C C First, if the system is discrete-time, it is transformed to C continuous-time using alpha = beta = 1 in the bilinear C transformation implemented in the SLICOT routine AB04MD. C Then the eigenvalues of A, i.e., the system poles, are found. C Then, the inverse of the original system is found and its poles, C i.e., the system zeros, are evaluated. C The obtained system poles Pi and zeros Zi are checked and if a C positive real part is detected, it is exchanged by -Pi or -Zi. C Then the polynomial coefficients of the transfer function C T(s) = Q(s)/P(s) are found. C The state-space representation of T(s) is then obtained. C The system matrices B, C, D are scaled so that the transformed C system has the same system gain as the original system. C If the original system is discrete-time, then the result (which is C continuous-time) is converted back to discrete-time. C C CONTRIBUTORS C C Asparuh Markovski, Technical University of Sofia, July 2003. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. C C KEYWORDS C C Bilinear transformation, stability, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. INTEGER DISCFL, INFO, LDA, LDWORK, N C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( * ), C( * ), D( * ), DWORK( * ) C .. C .. Local Scalars .. INTEGER I, IDW1, IDW2, IDW3, IMP, IMZ, INFO2, IWA, IWP, $ IWPS, IWQ, IWQS, LDW1, MAXWRK, REP, REZ DOUBLE PRECISION RCOND, SCALB, SCALC, SCALD C .. C .. Local Arrays .. INTEGER INDEX(1) C .. C .. External Subroutines .. EXTERNAL AB04MD, AB07ND, DCOPY, DGEEV, DLACPY, DSCAL, $ MC01PD, TD04AD, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, SIGN, SQRT C C Test input parameters and workspace. C INFO = 0 IF ( DISCFL.NE.0 .AND. DISCFL.NE.1 ) THEN INFO = -1 ELSE IF ( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF ( LDWORK.LT.MAX( N*N + 5*N, 6*N + 1 + MIN( 1, N ) ) ) THEN INFO = -10 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB10ZP', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Workspace usage 1. C REP = 1 IMP = REP + N REZ = IMP + N IMZ = REZ + N IWA = REZ IDW1 = IWA + N*N LDW1 = LDWORK - IDW1 + 1 C C 1. Discrete --> continuous transformation if needed. C IF ( DISCFL.EQ.1 ) THEN C C Workspace: need max(1,N); C prefer larger. C CALL AB04MD( 'D', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1, $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) IF ( INFO2.NE.0 ) THEN INFO = 1 RETURN END IF MAXWRK = INT( DWORK(1) ) ELSE MAXWRK = 0 END IF C C 2. Determine the factors for restoring system gain. C SCALD = D(1) SCALC = SQRT( ABS( SCALD ) ) SCALB = SIGN( SCALC, SCALD ) C C 3. Find the system poles, i.e., the eigenvalues of A. C Workspace: need N*N + 2*N + 3*N; C prefer larger. C CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IWA), N ) C CALL DGEEV( 'N', 'N', N, DWORK(IWA), N, DWORK(REP), DWORK(IMP), $ DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1, $ INFO2 ) IF ( INFO2.NE.0 ) THEN INFO = 2 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) C C 4. Compute the inverse system [Ai, Bi; Ci, Di]. C Workspace: need N*N + 2*N + 4; C prefer larger. C CALL AB07ND( N, 1, A, LDA, B, LDA, C, 1, D, 1, RCOND, IWORK, $ DWORK(IDW1), LDW1, INFO2 ) IF ( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) C C 5. Find the system zeros, i.e., the eigenvalues of Ai. C Workspace: need 4*N + 3*N; C prefer larger. C IDW1 = IMZ + N LDW1 = LDWORK - IDW1 + 1 C CALL DGEEV( 'N', 'N', N, A, LDA, DWORK(REZ), DWORK(IMZ), $ DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1, $ INFO2 ) IF ( INFO2.NE.0 ) THEN INFO = 4 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) C C 6. Exchange the zeros and the poles with positive real parts with C their negatives. C DO 10 I = 0, N - 1 IF ( DWORK(REP+I).GT.ZERO ) $ DWORK(REP+I) = -DWORK(REP+I) IF ( DWORK(REZ+I).GT.ZERO ) $ DWORK(REZ+I) = -DWORK(REZ+I) 10 CONTINUE C C Workspace usage 2. C IWP = IDW1 IDW2 = IWP + N + 1 IWPS = 1 C C 7. Construct the nominator and the denominator C of the system transfer function T( s ) = Q( s )/P( s ). C 8. Rearrange the coefficients in Q(s) and P(s) because C MC01PD subroutine produces them in increasing powers of s. C Workspace: need 6*N + 2. C CALL MC01PD( N, DWORK(REP), DWORK(IMP), DWORK(IWP), DWORK(IDW2), $ INFO2 ) CALL DCOPY( N+1, DWORK(IWP), -1, DWORK(IWPS), 1 ) C C Workspace usage 3. C IWQ = IDW1 IWQS = IWPS + N + 1 IDW3 = IWQS + N + 1 C CALL MC01PD( N, DWORK(REZ), DWORK(IMZ), DWORK(IWQ), DWORK(IDW2), $ INFO2 ) CALL DCOPY( N+1, DWORK(IWQ), -1, DWORK(IWQS), 1 ) C C 9. Make the conversion T(s) --> [A, B; C, D]. C Workspace: need 2*N + 2 + N + max(N,3); C prefer larger. C INDEX(1) = N CALL TD04AD( 'R', 1, 1, INDEX, DWORK(IWPS), 1, DWORK(IWQS), 1, 1, $ N, A, LDA, B, LDA, C, 1, D, 1, -ONE, IWORK, $ DWORK(IDW3), LDWORK-IDW3+1, INFO2 ) IF ( INFO2.NE.0 ) THEN INFO = 5 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(IDW3) + IDW3 - 1 ) ) C C 10. Scale the transformed system to the previous gain. C IF ( N.GT.0 ) THEN CALL DSCAL( N, SCALB, B, 1 ) C(N) = SCALC*C(N) END IF C D(1) = SCALD C C 11. Continuous --> discrete transformation if needed. C IF ( DISCFL.EQ.1 ) THEN CALL AB04MD( 'C', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1, $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) IF ( INFO2.NE.0 ) THEN INFO = 6 RETURN END IF END IF C DWORK(1) = MAXWRK RETURN C C *** Last line of SB10ZP *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03BG.f0000644000000000000000000000013215012430707016147 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03BG.f0000644000175000017500000000761615012430707017355 0ustar00lilgelilge00000000000000 SUBROUTINE MB03BG( K, N, AMAP, S, SINV, A, LDA1, LDA2, WR, WI ) C C PURPOSE C C To compute the eigenvalues of the 2-by-2 trailing submatrix of the C matrix product C C S(1) S(2) S(K) C A(:,:,1) * A(:,:,2) * ... * A(:,:,K) C C where A(:,:,AMAP(K)) is upper Hessenberg and A(:,:,AMAP(i)), C 1 <= i < K, is upper triangular. All factors to be inverted C (depending on S and SINV) are assumed nonsingular. Moreover, C AMAP(K) is either 1 or K. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of the factors. N >= 2. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input) DOUBLE PRECISION array, dimension (LDA1,LDA2,K) C The leading N-by-N-by-K part of this array must contain C the product (implicitly represented by its K factors) C in upper Hessenberg form. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= N. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= N. C C WR (output) DOUBLE PRECISION array, dimension (2) C WI (output) DOUBLE PRECISION array, dimension (2) C The real and imaginary parts, respectively, of the C eigenvalues of the 2-by-2 trailing submatrix of the C matrix product. C C METHOD C C The 2-by-2 trailing submatrix of the matrix product and its C eigenvalues are computed. C C FURTHER COMMENTS C C This routine is intended to be used in a context in which all C eigenvalues of the product are needed, hence, the product can be C evaluated as prod( A(:,:,AMAP(I)) ), for i = 1 : K. This way, the C 2-by-2 trailing submatrix depends only on the 2-by-2 trailing C submatrices of the factors. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Jan. 2019. C C REVISIONS C C V. Sima, Mar. 2019. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER K, LDA1, LDA2, N, SINV C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*), WI(*), WR(*) C .. Local Scalars .. INTEGER I, INFO, L, M DOUBLE PRECISION P1, P3, P4 C .. Local Arrays .. DOUBLE PRECISION DWORK(4), Z(1) C .. External Subroutines .. EXTERNAL DLAHQR C C .. Executable Statements .. C M = N - 1 P1 = ONE P3 = ZERO P4 = ONE C DO 10 L = 1, K - 1 I = AMAP(L) IF ( S(I).EQ.SINV ) THEN P3 = P1*A(M,N,I) + P3*A(N,N,I) ELSE P3 = ( P3 - P1*A(M,N,I)/A(M,M,I) )/A(N,N,I) END IF P1 = P1*A(M,M,I) P4 = P4*A(N,N,I) 10 CONTINUE C I = AMAP(K) DWORK(1) = P1*A(M,M,I) + P3*A(N,M,I) DWORK(2) = P4*A(N,M,I) DWORK(3) = P1*A(M,N,I) + P3*A(N,N,I) DWORK(4) = P4*A(N,N,I) C C Compute eigenvalues. C CALL DLAHQR( .FALSE., .FALSE., 2, 1, 2, DWORK, 2, WR, WI, 1, 2, Z, $ 1, INFO ) C RETURN C *** Last line of MB03BG *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01SY.f0000644000000000000000000000013015012430707016207 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MC01SY.f0000644000175000017500000000627415012430707017416 0ustar00lilgelilge00000000000000 SUBROUTINE MC01SY( M, E, B, A, OVFLOW ) C C PURPOSE C C To find a real number A from its mantissa M and its exponent E, C i.e., C A = M * B**E. C M and E need not be the standard floating-point values. C If ABS(A) < B**(EMIN-1), i.e. the smallest positive model number, C then the routine returns A = 0. C If M = 0, then the routine returns A = 0 regardless of the value C of E. C C ARGUMENTS C C Input/Output Parameters C C M (input) DOUBLE PRECISION C The mantissa of the floating-point representation of A. C C E (input) INTEGER C The exponent of the floating-point representation of A. C C B (input) INTEGER C The base of the floating-point arithmetic. C C A (output) DOUBLE PRECISION C The value of M * B**E. C C OVFLOW (output) LOGICAL C The value .TRUE., if ABS(M) * B**E >= B**EMAX (where EMAX C is the largest possible exponent) and .FALSE. otherwise. C A is not defined if OVFLOW = .TRUE.. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01GY by A.J. Geurts. C C REVISIONS C C - C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. LOGICAL OVFLOW INTEGER B, E DOUBLE PRECISION A, M C .. Local Scalars .. INTEGER EMAX, EMIN, ET, EXPON DOUBLE PRECISION BASE, MT C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. Intrinsic Functions .. INTRINSIC ABS, MOD C .. Executable Statements .. C OVFLOW = .FALSE. C IF ( ( M.EQ.ZERO ) .OR. ( E.EQ.0 ) ) THEN A = M RETURN END IF C C Determination of the mantissa MT and the exponent ET of the C standard floating-point representation. C EMIN = DLAMCH( 'Minimum exponent' ) EMAX = DLAMCH( 'Largest exponent' ) MT = M ET = E C WHILE ( ABS( MT ) >= B ) DO 20 IF ( ABS( MT ).GE.B ) THEN MT = MT/B ET = ET + 1 GO TO 20 END IF C END WHILE 20 C WHILE ( ABS( MT ) < 1 ) DO 40 IF ( ABS( MT ).LT.ONE ) THEN MT = MT*B ET = ET - 1 GO TO 40 END IF C END WHILE 40 C IF ( ET.LT.EMIN ) THEN A = ZERO RETURN END IF C IF ( ET.GE.EMAX ) THEN OVFLOW = .TRUE. RETURN END IF C C Computation of the value of A by the relation C M * B**E = A * (BASE)**EXPON C EXPON = ABS( ET ) A = MT BASE = B IF ( ET.LT.0 ) BASE = ONE/BASE C WHILE ( not EXPON = 0 ) DO 60 IF ( EXPON.NE.0 ) THEN IF ( MOD( EXPON, 2 ).EQ.0 ) THEN BASE = BASE*BASE EXPON = EXPON/2 ELSE A = A*BASE EXPON = EXPON - 1 END IF GO TO 60 END IF C END WHILE 60 C RETURN C *** Last line of MC01SY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01OC.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01OC.f0000644000175000017500000002455615012430707017366 0ustar00lilgelilge00000000000000 SUBROUTINE MB01OC( UPLO, TRANS, N, ALPHA, BETA, R, LDR, H, LDH, X, $ LDX, INFO ) C C PURPOSE C C To perform one of the special symmetric rank 2k operations C C R := alpha*R + beta*H*X + beta*X*H', C or C R := alpha*R + beta*H'*X + beta*X*H, C C where alpha and beta are scalars, R and X are N-by-N symmetric C matrices, and H is an N-by-N upper Hessenberg matrix. 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 operation to be performed as follows: C = 'N': R := alpha*R + beta*H*X + beta*X*H'; C = 'T' or 'C': R := alpha*R + beta*H'*X + beta*X*H. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices R, H, and X. 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 H and X are not C referenced. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) C On entry with 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 R. C On entry with 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 R. C In both cases, the other strictly triangular part is not C referenced. C On exit, the leading N-by-N 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 the computed matrix R. C C LDR INTEGER C The leading dimension of the array R. LDR >= MAX(1,N). C C H (input) DOUBLE PRECISION array, dimension (LDH,N) C On entry, the leading N-by-N upper Hessenberg part of this C array must contain the upper Hessenberg matrix H. C The remaining part of this array is not referenced. C C LDH INTEGER C The leading dimension of the array H. LDH >= MAX(1,N). 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 C LDX INTEGER C The leading dimension of the array X. LDX >= MAX(1,N). 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 C structure into account, and using inline code and BLAS1 routines. C C NUMERICAL ASPECTS C C The algorithm requires approximately N**3/2 operations. C C FURTHER COMMENTS C C This routine acts as a specialization of BLAS Library routine C DSYR2K. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2019. C C REVISIONS C C V. Sima, Mar. 2019. 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 TRANS, UPLO INTEGER INFO, LDH, LDR, LDX, N DOUBLE PRECISION ALPHA, BETA C .. Array Arguments .. DOUBLE PRECISION H(LDH,*), R(LDR,*), X(LDX,*) C .. Local Scalars .. DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, J, L LOGICAL LTRANS, LUPLO C .. Local Arrays .. DOUBLE PRECISION TMP(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN 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 ( N.LT.0 ) THEN INFO = -3 ELSE IF ( LDR.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF ( LDH.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF ( LDX.LT.MAX( 1, N ) ) THEN INFO = -11 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01OC', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C IF ( BETA.EQ.ZERO ) THEN IF ( ALPHA.EQ.ZERO ) THEN C C Special case alpha = 0. C CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) ELSE C C Special case beta = 0. C IF ( ALPHA.NE.ONE ) $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, N, N, R, LDR, INFO ) END IF RETURN END IF C C General case: beta <> 0. C Compute R = alpha*R + beta*( op( H )*X + X*op( H )' ), exploiting C the structure, where op( H ) is H, if UPLO = 'U', and H', if C UPLO = 'L'. C IF ( .NOT.LTRANS ) THEN C C Form R := alpha*R + beta*( H*X + X*H' ). C IF ( LUPLO ) THEN DO 20 J = 1, N IF ( ALPHA.EQ.ZERO ) THEN TMP(1) = ZERO CALL DCOPY( J, TMP, 0, R(1,J), 1 ) ELSE IF ( ALPHA.NE.ONE ) THEN CALL DSCAL( J, ALPHA, R(1,J), 1 ) END IF I = MAX( 1, J-1 ) DO 10 L = 1, N IF ( L.LE.J ) THEN TEMP1 = X(L,J) ELSE TEMP1 = X(J,L) END IF IF ( TEMP1.NE.ZERO ) $ CALL DAXPY( MIN( L+1, J ), BETA*TEMP1, H(1,L), 1, $ R(1,J), 1 ) IF ( L.GE.I ) THEN TEMP2 = H(J,L) IF ( TEMP2.NE.ZERO ) THEN TEMP2 = BETA*TEMP2 CALL DAXPY( I, TEMP2, X(1,L), 1, R(1,J), 1 ) IF ( J.GT.1 ) $ R(J,J) = R(J,J) + TEMP1*TEMP2 END IF END IF 10 CONTINUE 20 CONTINUE ELSE DO 40 J = 1, N IF ( ALPHA.EQ.ZERO ) THEN TMP(1) = ZERO CALL DCOPY( N-J+1, TMP, 0, R(J,J), 1 ) ELSE IF ( ALPHA.NE.ONE ) THEN CALL DSCAL( N-J+1, ALPHA, R(J,J), 1 ) END IF DO 30 L = MAX( 1, J-1 ), N I = MIN( L+1, N ) TEMP2 = BETA*H(J,L) IF ( L.GE.J ) THEN TEMP1 = BETA*X(L,J) ELSE TEMP1 = BETA*X(J,L) END IF CALL DAXPY( I-J+1, TEMP1, H(J,L), 1, R(J,J), 1 ) CALL DAXPY( N-L+1, TEMP2, X(L,L), 1, R(L,J), 1 ) IF ( L.GT.J ) $ CALL DAXPY( L-J, TEMP2, X(L,J), LDX, R(J,J), 1 ) 30 CONTINUE 40 CONTINUE END IF ELSE C C Form R := alpha*R + beta*( H'*X + X*H ). C IF ( LUPLO ) THEN DO 70 J = 1, N IF ( ALPHA.EQ.ZERO ) THEN TMP(1) = ZERO CALL DCOPY( J, TMP, 0, R(1,J), 1 ) ELSE IF ( ALPHA.NE.ONE ) THEN CALL DSCAL( J, ALPHA, R(1,J), 1 ) END IF DO 60 I = 1, J DO 50 L = 1, MIN( J+1, N ) IF ( L.LE.J ) THEN TEMP1 = X(L,J) IF ( L.LE.I ) THEN TEMP2 = X(L,I) ELSE TEMP2 = X(I,L) END IF ELSE TEMP1 = X(J,L) TEMP2 = X(I,L) END IF IF ( L.LE.MIN( I+1, N ) ) $ R(I,J) = R(I,J) + BETA*TEMP1*H(L,I) R(I,J) = R(I,J) + BETA*TEMP2*H(L,J) 50 CONTINUE 60 CONTINUE 70 CONTINUE ELSE DO 100 J = 1, N IF ( ALPHA.EQ.ZERO ) THEN TMP(1) = ZERO CALL DCOPY( N-J+1, TMP, 0, R(J,J), 1 ) ELSE IF ( ALPHA.NE.ONE ) THEN CALL DSCAL( N-J+1, ALPHA, R(J,J), 1 ) END IF DO 90 I = J, N DO 80 L = 1, MIN( I+1, N ) IF ( L.GE.I ) THEN TEMP1 = X(L,J) TEMP2 = X(L,I) ELSE IF ( L.GE.J ) THEN TEMP1 = X(L,J) ELSE TEMP1 = X(J,L) END IF TEMP2 = X(I,L) END IF R(I,J) = R(I,J) + BETA*TEMP1*H(L,I) IF ( L.LE.MIN( J+1, N ) ) $ R(I,J) = R(I,J) + BETA*TEMP2*H(L,J) 80 CONTINUE 90 CONTINUE 100 CONTINUE END IF END IF C RETURN C *** Last line of MB01OC *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03QX.f0000644000000000000000000000013215012430707016207 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03QX.f0000644000175000017500000000533415012430707017410 0ustar00lilgelilge00000000000000 SUBROUTINE MB03QX( N, T, LDT, WR, WI, INFO ) 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 control-4.1.2/src/slicot/src/PaxHeaders/AB13ED.f0000644000000000000000000000013215012430707016134 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB13ED.f0000644000175000017500000002461415012430707017337 0ustar00lilgelilge00000000000000 SUBROUTINE AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To estimate beta(A), the 2-norm distance from a real matrix A to C the nearest complex matrix with an eigenvalue on the imaginary C axis. The estimate is given as C C LOW <= beta(A) <= HIGH, C C where either C C (1 + TOL) * LOW >= HIGH, C C or C C LOW = 0 and HIGH = delta, C C and delta is a small number approximately equal to the square root C of machine precision times the Frobenius norm (Euclidean norm) C of A. If A is stable in the sense that all eigenvalues of A lie C in the open left half complex plane, then beta(A) is the distance C to the nearest unstable complex matrix, i.e., the complex C stability radius. C C ARGUMENTS 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 part of this array must contain the C matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C LOW (output) DOUBLE PRECISION C A lower bound for beta(A). C C HIGH (output) DOUBLE PRECISION C An upper bound for beta(A). C C Tolerances C C TOL DOUBLE PRECISION C Specifies the accuracy with which LOW and HIGH approximate C beta(A). If the user sets TOL to be less than SQRT(EPS), C where EPS is the machine precision (see LAPACK Library C Routine DLAMCH), then the tolerance is taken to be C SQRT(EPS). C The recommended value is TOL = 9, which gives an estimate C of beta(A) correct to within an order of magnitude. 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 length of the array DWORK. C LDWORK >= MAX( 1, 3*N*(N+1) ). 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: the QR algorithm (LAPACK Library routine DHSEQR) C fails to converge; this error is very rare. C C METHOD C C Let beta(A) be the 2-norm distance from a real matrix A to the C nearest complex matrix with an eigenvalue on the imaginary axis. C It is known that beta(A) = minimum of the smallest singular C value of (A - jwI), where I is the identity matrix and j**2 = -1, C and the minimum is taken over all real w. C The algorithm computes a lower bound LOW and an upper bound HIGH C for beta(A) by a bisection method in the following way. Given a C non-negative real number sigma, the Hamiltonian matrix H(sigma) C is constructed: C C | A -sigma*I | | A G | C H(sigma) = | | := | | . C | sigma*I -A' | | F -A' | C C It can be shown [1] that H(sigma) has an eigenvalue whose real C part is zero if and only if sigma >= beta. Any lower and upper C bounds on beta(A) can be improved by choosing a number between C them and checking to see if H(sigma) has an eigenvalue with zero C real part. This decision is made by computing the eigenvalues of C H(sigma) using the square reduced algorithm of Van Loan [2]. C C REFERENCES C C [1] Byers, R. C A bisection method for measuring the distance of a stable C matrix to the unstable matrices. C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988. C C [2] Van Loan, C.F. C A symplectic method for approximating all the eigenvalues of a C Hamiltonian matrix. C Linear Algebra and its Applications, Vol 61, 233-251, 1984. C C NUMERICAL ASPECTS C C Due to rounding errors the computed values of LOW and HIGH can be C proven to satisfy C C LOW - p(n) * sqrt(e) * norm(A) <= beta(A) C and C beta(A) <= HIGH + p(n) * sqrt(e) * norm(A), C C where p(n) is a modest polynomial of degree 3, e is the machine C precision and norm(A) is the Frobenius norm of A, see [1]. C The recommended value for TOL is 9 which gives an estimate of C beta(A) correct to within an order of magnitude. C AB13ED requires approximately 38*N**3 flops for TOL = 9. C C CONTRIBUTOR C C R. Byers, the routines BISEC and BISEC0 (January, 1995). C C REVISIONS C C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003. C C KEYWORDS C C Distances, eigenvalue, eigenvalue perturbation, norms, stability C radius. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION HIGH, LOW, TOL INTEGER INFO, LDA, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*) C .. Local Scalars .. INTEGER I, IA2, IAA, IGF, IHI, ILO, IWI, IWK, IWR, $ JWORK, MINWRK, N2 DOUBLE PRECISION ANRM, SEPS, SFMN, SIGMA, TAU, TEMP, TOL1, TOL2 LOGICAL RNEG, SUFWRK C .. Local Arrays .. DOUBLE PRECISION DUMMY(1), DUMMY2(1,1) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE C .. External Subroutines .. EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM, $ DSYMV, MA02ED, MB04ZD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, SQRT C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 MINWRK = 3*N*( N + 1 ) C IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN INFO = -8 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB13ED', -INFO ) RETURN END IF C C Quick return if possible. C LOW = ZERO IF ( N.EQ.0 ) THEN HIGH = ZERO DWORK(1) = ONE RETURN END IF C C Indices for splitting the work array. 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 N2 = N*N IGF = 1 IA2 = IGF + N2 + N IAA = IA2 + N2 IWK = IAA + N2 IWR = IAA IWI = IWR + N C SUFWRK = LDWORK-IWK.GE.N2 C C Computation of the tolerances and the treshold for termination of C the bisection method. SEPS is the square root of the machine C precision. C SFMN = DLAMCH( 'Safe minimum' ) SEPS = SQRT( DLAMCH( 'Epsilon' ) ) TAU = ONE + MAX( TOL, SEPS ) ANRM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) TOL1 = SEPS * ANRM TOL2 = TOL1 * DBLE( 2*N ) C C Initialization of the bisection method. C HIGH = ANRM C C WHILE ( HIGH > TAU*MAX( TOL1, LOW ) ) DO 10 IF ( HIGH.GT.( TAU*MAX( TOL1, LOW ) ) ) THEN SIGMA = SQRT( HIGH ) * SQRT( MAX( TOL1, LOW ) ) C C Set up H(sigma). C Workspace: N*(N+1)+2*N*N. C CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N ) DWORK(IGF) = SIGMA DWORK(IGF+N) = -SIGMA DUMMY(1) = ZERO CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 ) C DO 20 I = IGF, IA2 - N - 2, N + 1 CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 ) 20 CONTINUE C C Computation of the eigenvalues by the square reduced algorithm. C Workspace: N*(N+1)+2*N*N+2*N. C CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N, $ DUMMY2, 1, DWORK(IWK), INFO ) C C Form the matrix A*A + F*G. C Workspace: need N*(N+1)+2*N*N+N; C prefer N*(N+1)+3*N*N. C JWORK = IA2 IF ( SUFWRK ) $ JWORK = IWK C CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N ) CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) C IF ( SUFWRK ) THEN C C Use BLAS 3 calculation. C CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N, $ DWORK(JWORK), N, ZERO, DWORK(IA2), N ) ELSE C C Use BLAS 2 calculation. C DO 30 I = 1, N CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N, $ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 ) CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 ) 30 CONTINUE C END IF C CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, $ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N ) C C Find the eigenvalues of A*A + F*G. C Workspace: N*(N+1)+N*N+3*N. C JWORK = IWI + N CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK), $ I ) CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, $ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1, $ DWORK(JWORK), N, INFO ) C IF ( INFO.NE.0 ) THEN INFO = 1 RETURN END IF C C (DWORK(IWR+i), DWORK(IWI+i)), i = 0,...,N-1, contain the C squares of the eigenvalues of H(sigma). C I = 0 RNEG = .FALSE. C WHILE ( ( DWORK(IWR+i),DWORK(IWI+i) ) not real positive C .AND. I < N ) DO 40 IF ( .NOT.RNEG .AND. I.LT.N ) THEN TEMP = ABS( DWORK(IWI+I) ) IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1 RNEG = ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL2 ) ) I = I + 1 GO TO 40 C END WHILE 40 END IF IF ( RNEG ) THEN HIGH = SIGMA ELSE LOW = SIGMA END IF GO TO 10 C END WHILE 10 END IF C C Set optimal workspace dimension. C DWORK(1) = DBLE( MAX( 4*N2 + N, MINWRK ) ) C C *** Last line of AB13ED *** END control-4.1.2/src/slicot/src/PaxHeaders/TF01PD.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TF01PD.f0000644000175000017500000001150315012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE TF01PD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) C C PURPOSE C C To construct the block Toeplitz expansion T of a multivariable C parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k) C is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1). C C ARGUMENTS C C Input/Output Parameters C C NH1 (input) INTEGER C The number of rows in each parameter M(k). NH1 >= 0. C C NH2 (input) INTEGER C The number of columns in each parameter M(k). NH2 >= 0. C C NR (input) INTEGER C The number of parameters required in each column of the C block Toeplitz expansion matrix T. NR >= 0. C C NC (input) INTEGER C The number of parameters required in each row of the C block Toeplitz expansion matrix T. NC >= 0. C C H (input) DOUBLE PRECISION array, dimension C (LDH,(NR+NC-1)*NH2) C The leading NH1-by-(NR+NC-1)*NH2 part of this array must C contain the multivariable sequence M(k), where k = 1,2, C ...,(NR+NC-1). Specifically, each parameter M(k) is an C NH1-by-NH2 matrix whose (i,j)-th element must be stored in C H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2. C C LDH INTEGER C The leading dimension of array H. LDH >= MAX(1,NH1). C C T (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC) C The leading NH1*NR-by-NH2*NC part of this array contains C the block Toeplitz expansion of the multivariable sequence C M(k). C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,NH1*NR). 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 NH1-by-NH2 dimensional parameters M(k) of a multivariable C sequence are arranged into a matrix T in Toeplitz form such that C C | M(NC) M(NC-1) M(NC-2) . . . M(1) | C | | C | M(NC+1) M(NC) M(NC-1) . . . M(2) | C T = | . . . . |. C | . . . . | C | . . . . | C | | C | M(NR+NC-1) M(NR+NC-2) M(NR+NC-3) . . . M(NR) | C C REFERENCES C C [1] Johvidov, J.S. C Hankel and Toeplitz Matrices and Forms: Algebraic Theory, C (translated by G.P.A. Thijsse, I. Gohberg, ed.). C Birkhaeuser, Boston, 1982. C C NUMERICAL ASPECTS C C The time taken is approximately proportional to C NH1 x NH2 x NR x NC. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TF01DD by S. Van Huffel, Katholieke C Univ. Leuven, Belgium. C C REVISIONS C C - C C KEYWORDS C C Multivariable system, Toeplitz matrix. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INFO, LDH, LDT, NC, NH1, NH2, NR C .. Array Arguments .. DOUBLE PRECISION H(LDH,*), T(LDT,*) C .. Local Scalars .. INTEGER IH, IT, JT, NCOL, NROW C .. External Subroutines .. EXTERNAL DLACPY, XERBLA C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C IF( NH1.LT.0 ) THEN INFO = -1 ELSE IF( NH2.LT.0 ) THEN INFO = -2 ELSE IF( NR.LT.0 ) THEN INFO = -3 ELSE IF( NC.LT.0 ) THEN INFO = -4 ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN INFO = -6 ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN INFO = -8 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TF01PD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( NH1, NH2, NR, NC ).EQ.0 ) $ RETURN C C Construct the last block column of T. C IH = 1 NROW = (NR-1)*NH1 NCOL = (NC-1)*NH2 + 1 C DO 10 IT = 1, NROW+NH1, NH1 CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,NCOL), $ LDT ) IH = IH + NH2 10 CONTINUE C C Construct the remaining block columns of T in backward order. C DO 20 JT = NCOL-NH2, 1, -NH2 CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT+NH2), LDT, T(1,JT), $ LDT ) CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT), $ LDT ) IH = IH + NH2 20 CONTINUE C RETURN C *** Last line of TF01PD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10VD.f0000644000000000000000000000013215012430707016174 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10VD.f0000644000175000017500000002771415012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE SB10VD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, $ F, LDF, H, LDH, X, LDX, Y, LDY, XYCOND, IWORK, $ DWORK, LDWORK, BWORK, INFO ) C C PURPOSE C C To compute the state feedback and the output injection C matrices for an H2 optimal n-state controller for the system C C | A | B1 B2 | | A | B | C P = |----|---------| = |---|---| C | C1 | 0 D12 | | C | D | C | C2 | D21 D22 | C C where B2 has as column size the number of control inputs (NCON) C and C2 has as row size the number of measurements (NMEAS) being C 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 with D21 = | 0 I | as obtained by the C SLICOT Library routine SB10UD. Matrix D is not used C explicitly. 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 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 F (output) DOUBLE PRECISION array, dimension (LDF,N) C The leading NCON-by-N part of this array contains the C state feedback matrix F. C C LDF INTEGER C The leading dimension of the array F. LDF >= max(1,NCON). C C H (output) DOUBLE PRECISION array, dimension (LDH,NMEAS) C The leading N-by-NMEAS part of this array contains the C output injection matrix H. C C LDH INTEGER C The leading dimension of the array H. LDH >= max(1,N). 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 Y (output) DOUBLE PRECISION array, dimension (LDY,N) C The leading N-by-N part of this array contains the matrix C Y, solution of the Y-Riccati equation. C C LDY INTEGER C The leading dimension of the array Y. LDY >= max(1,N). C C XYCOND (output) DOUBLE PRECISION array, dimension (2) C XYCOND(1) contains an estimate of the reciprocal condition C number of the X-Riccati equation; C XYCOND(2) contains an estimate of the reciprocal condition C number of the Y-Riccati equation. C C Workspace C C IWORK INTEGER array, dimension (max(2*N,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 >= 13*N*N + 12*N + 5. C For good performance, LDWORK must generally be larger. 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 X-Riccati equation was not solved C successfully; C = 2: if the Y-Riccati equation was not solved C successfully. C C METHOD C C The routine implements the formulas given in [1], [2]. The X- C and Y-Riccati equations are solved with condition and accuracy C estimates [3]. C C REFERENCES C C [1] Zhou, K., Doyle, J.C., and Glover, K. C Robust and Optimal Control. C Prentice-Hall, Upper Saddle River, NJ, 1996. 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., Konstantinov, M.M., and Mehrmann, V. C DGRSVX and DMSRIC: Fortan 77 subroutines for solving C continuous-time matrix algebraic Riccati equations with C condition and accuracy estimates. C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. C Chemnitz, May 1998. C C NUMERICAL ASPECTS C C The precision of the solution of the matrix Riccati equations C can be controlled by the values of the condition numbers C XYCOND(1) and XYCOND(2) of these equations. C C FURTHER COMMENTS C C The Riccati equations are solved by the Schur approach C implementing condition and accuracy estimates. 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 C KEYWORDS C C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal C regulator, robust 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, LDB, LDC, LDF, LDH, LDWORK, LDX, $ LDY, M, N, NCON, NMEAS, NP C .. C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), F( LDF, * ), H( LDH, * ), $ X( LDX, * ), XYCOND( 2 ), Y( LDY, * ) C .. C .. Local Scalars .. INTEGER INFO2, IWG, IWI, IWQ, IWR, IWRK, IWS, IWT, IWV, $ LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, NP1, NP2 DOUBLE PRECISION FERR, SEP C .. C .. External Functions .. C DOUBLE PRECISION DLANSY EXTERNAL DLANSY C .. C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, DSYRK, SB02RD, 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -11 ELSE IF( LDF.LT.MAX( 1, NCON ) ) THEN INFO = -13 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDY.LT.MAX( 1, N ) ) THEN INFO = -19 ELSE C C Compute workspace. C MINWRK = 13*N*N + 12*N + 5 IF( LDWORK.LT.MINWRK ) $ INFO = -23 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10VD', -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 DWORK( 1 ) = ONE XYCOND( 1 ) = ONE XYCOND( 2 ) = ONE RETURN END IF C ND1 = NP1 - M2 ND2 = M1 - NP2 N2 = 2*N C C Workspace usage. C IWQ = N*N + 1 IWG = IWQ + N*N IWT = IWG + N*N IWV = IWT + N*N IWR = IWV + N*N IWI = IWR + N2 IWS = IWI + N2 IWRK = IWS + 4*N*N C C Compute Ax = A - B2*D12'*C1 . C CALL DLACPY ('Full', N, N, A, LDA, DWORK, N ) CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB, $ C( ND1+1, 1), LDC, ONE, DWORK, N ) C C Compute Cx = C1'*C1 - C1'*D12*D12'*C1 . C IF( ND1.GT.0 ) THEN CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ), $ N ) ELSE CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) END IF C C Compute Dx = B2*B2' . C CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO, $ DWORK( IWG ), N ) C C Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 . C Workspace: need 13*N*N + 12*N + 5; C prefer larger. C CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose', $ 'Lower', 'GeneralScaling', 'Stable', 'NotFactored', $ 'Original', N, DWORK, N, DWORK( IWT ), N, $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, $ X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ), $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF C LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 C C Compute F = -D12'*C1 - B2'*X . C CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, F, LDF ) CALL DGEMM( 'T', 'N', M2, N, N, -ONE, B( 1, M1+1 ), LDB, X, LDX, $ -ONE, F, LDF ) C C Compute Ay = A - B1*D21'*C2 . C CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB, $ C( NP1+1, 1 ), LDC, ONE, DWORK, N ) C C Compute Cy = B1*B1' - B1*D21'*D21*B1' . C IF( ND2.GT.0 ) THEN CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ), $ N ) ELSE CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) END IF C C Compute Dy = C2'*C2 . C CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO, $ DWORK( IWG ), N ) C C Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 . C Workspace: need 13*N*N + 12*N + 5; C prefer larger. C CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose', $ 'Upper', 'GeneralScaling', 'Stable', 'NotFactored', $ 'Original', N, DWORK, N, DWORK( IWT ), N, $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, $ Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ), $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 2 RETURN END IF C LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Compute H = -B1*D21' - Y*C2' . C CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, H, LDH ) CALL DGEMM( 'N', 'T', N, NP2, N, -ONE, Y, LDY, C( NP1+1, 1 ), LDC, $ -ONE, H, LDH ) C DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10VD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03SX.f0000644000000000000000000000013215012430707016217 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03SX.f0000644000175000017500000003000415012430707017410 0ustar00lilgelilge00000000000000 SUBROUTINE SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To estimate a forward error bound for the solution X of a real C discrete-time Lyapunov matrix equation, C C op(A)'*X*op(A) - X = C, C C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The C matrix A, the right hand side C, and the solution X are N-by-N. C An absolute residual matrix, which takes into account the rounding C errors in forming it, is given in the array R. C C ARGUMENTS C C Mode Parameters 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 UPLO CHARACTER*1 C Specifies which part of the symmetric matrix R is to be C used, as follows: C = 'U': Upper triangular part; C = 'L': Lower triangular part. C C LYAPUN CHARACTER*1 C Specifies whether or not the original Lyapunov equations C should be solved, as follows: C = 'O': Solve the original Lyapunov equations, updating C the right-hand sides and solutions with the C matrix U, e.g., X <-- U'*X*U; C = 'R': Solve reduced Lyapunov equations only, without C updating the right-hand sides and solutions. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and R. N >= 0. C C XANORM (input) DOUBLE PRECISION C The absolute (maximal) norm of the symmetric solution C matrix X of the Lyapunov equation. XANORM >= 0. C C T (input) DOUBLE PRECISION array, dimension (LDT,N) C The leading N-by-N upper Hessenberg part of this array C must contain the upper quasi-triangular matrix T in Schur C canonical form from a Schur factorization of A. C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,N). C C U (input) DOUBLE PRECISION array, dimension (LDU,N) C The leading N-by-N part of this array must contain the C orthogonal matrix U from a real Schur factorization of A. C If LYAPUN = 'R', the array U is not referenced. C C LDU INTEGER C The leading dimension of array U. C LDU >= 1, if LYAPUN = 'R'; C LDU >= MAX(1,N), if LYAPUN = 'O'. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,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 absolute residual matrix R, with C bounds on rounding errors added. 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 absolute residual matrix R, with C bounds on rounding errors added. C On exit, the leading N-by-N part of this array contains C the symmetric absolute residual matrix R (with bounds on C rounding errors added), fully stored. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C FERR (output) DOUBLE PRECISION C An estimated forward error bound for the solution X. C If XTRUE is the true solution, FERR bounds the magnitude C of the largest entry in (X - XTRUE) divided by the C magnitude of the largest entry in X. C If N = 0 or XANORM = 0, FERR is set to 0, without any C calculations. C C Workspace C C IWORK INTEGER array, dimension (N*N) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 0, if N = 0; C LDWORK >= MAX(3,2*N*N), if N > 0. 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 = N+1: if T has almost reciprocal eigenvalues; perturbed C values were used to solve Lyapunov equations (but C the matrix T is unchanged). C C METHOD C C The forward error bound is estimated using a practical error bound C similar to the one proposed in [1], based on the 1-norm estimator C in [2]. C C REFERENCES C C [1] Higham, N.J. C Perturbation theory and backward error for AX-XB=C. C BIT, vol. 33, pp. 124-136, 1993. C C [2] Higham, N.J. C FORTRAN codes for estimating the one-norm of a real or C complex matrix, with applications to condition estimation. C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C FURTHER COMMENTS C C The option LYAPUN = 'R' may occasionally produce slightly worse C or better estimates, and it is much faster than the option 'O'. C The routine can be also used as a final step in estimating a C forward error bound for the solution of a discrete-time algebraic C matrix Riccati equation. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Oct. 1998. Partly based on DDLSVX (and then SB03SD) by P. Petkov, C Tech. University of Sofia, March 1998 (and December 1998). C C REVISIONS C C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004, C May 2020. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) C .. C .. Scalar Arguments .. CHARACTER LYAPUN, TRANA, UPLO INTEGER INFO, LDR, LDT, LDU, LDWORK, N DOUBLE PRECISION FERR, XANORM C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION DWORK( * ), R( LDR, * ), T( LDT, * ), $ U( LDU, * ) C .. C .. Local Scalars .. LOGICAL LOWER, NOTRNA, UPDATE CHARACTER TRANAT, UPLOW INTEGER I, IJ, INFO2, ITMP, J, KASE, NN DOUBLE PRECISION EST, SCALE, TEMP C .. C .. Local Arrays .. INTEGER ISAVE( 3 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANSY EXTERNAL DLANSY, LSAME C .. C .. External Subroutines .. EXTERNAL DLACN2, DSCAL, MA02ED, MB01RU, SB03MX, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Decode and Test input parameters. C NOTRNA = LSAME( TRANA, 'N' ) UPDATE = LSAME( LYAPUN, 'O' ) C NN = N*N INFO = 0 IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. $ LSAME( TRANA, 'C' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) $ THEN INFO = -2 ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( XANORM.LT.ZERO ) THEN INFO = -5 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN INFO = -9 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDWORK.LT.0 .OR. $ ( LDWORK.LT.MAX( 3, 2*NN ) .AND. N.GT.0 ) ) THEN INFO = -15 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03SX', -INFO ) RETURN END IF C C Quick return if possible. C FERR = ZERO IF( N.EQ.0 .OR. XANORM.EQ.ZERO ) $ RETURN C ITMP = NN + 1 C IF( NOTRNA ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF C C Fill in the remaining triangle of the symmetric residual matrix. C CALL MA02ED( UPLO, N, R, LDR ) C KASE = 0 C C REPEAT 10 CONTINUE CALL DLACN2( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN C C Select the triangular part of symmetric matrix to be used. C IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) $ .GE. $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) $ ) THEN UPLOW = 'U' LOWER = .FALSE. ELSE UPLOW = 'L' LOWER = .TRUE. END IF C IF( KASE.EQ.2 ) THEN IJ = 0 IF( LOWER ) THEN C C Scale the lower triangular part of symmetric matrix C by the residual matrix. C DO 30 J = 1, N DO 20 I = J, N IJ = IJ + 1 DWORK( IJ ) = DWORK( IJ )*R( I, J ) 20 CONTINUE IJ = IJ + J 30 CONTINUE ELSE C C Scale the upper triangular part of symmetric matrix C by the residual matrix. C DO 50 J = 1, N DO 40 I = 1, J IJ = IJ + 1 DWORK( IJ ) = DWORK( IJ )*R( I, J ) 40 CONTINUE IJ = IJ + N - J 50 CONTINUE END IF END IF C IF( UPDATE ) THEN C C Transform the right-hand side: RHS := U'*RHS*U. C CALL MB01RU( UPLOW, 'Transpose', N, N, ZERO, ONE, DWORK, N, $ U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) END IF CALL MA02ED( UPLOW, N, DWORK, N ) C IF( KASE.EQ.2 ) THEN C C Solve op(T)'*Y*op(T) - Y = scale*RHS. C CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, $ DWORK( ITMP ), INFO2 ) ELSE C C Solve op(T)*W*op(T)' - W = scale*RHS. C CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, $ DWORK( ITMP ), INFO2 ) END IF C IF( INFO2.GT.0 ) $ INFO = N + 1 C IF( UPDATE ) THEN C C Transform back to obtain the solution: Z := U*Z*U', with C Z = Y or Z = W. C CALL MB01RU( UPLOW, 'No transpose', N, N, ZERO, ONE, DWORK, $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) END IF C IF( KASE.EQ.1 ) THEN IJ = 0 IF( LOWER ) THEN C C Scale the lower triangular part of symmetric matrix C by the residual matrix. C DO 70 J = 1, N DO 60 I = J, N IJ = IJ + 1 DWORK( IJ ) = DWORK( IJ )*R( I, J ) 60 CONTINUE IJ = IJ + J 70 CONTINUE ELSE C C Scale the upper triangular part of symmetric matrix C by the residual matrix. C DO 90 J = 1, N DO 80 I = 1, J IJ = IJ + 1 DWORK( IJ ) = DWORK( IJ )*R( I, J ) 80 CONTINUE IJ = IJ + N - J 90 CONTINUE END IF END IF C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( UPLOW, N, DWORK, N ) GO TO 10 END IF C C UNTIL KASE = 0 C C Compute the estimate of the relative error. C TEMP = XANORM*SCALE IF( TEMP.GT.EST ) THEN FERR = EST / TEMP ELSE FERR = ONE END IF C RETURN C C *** Last line of SB03SX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02CV.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02CV.f0000644000175000017500000006470315012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE MB02CV( TYPEG, STRUCG, K, N, P, Q, NB, RNK, A1, LDA1, $ A2, LDA2, B, LDB, F1, LDF1, F2, LDF2, G, LDG, $ CS, DWORK, LDWORK, INFO ) C C PURPOSE C C To apply the transformations created by the SLICOT Library routine C MB02CU on other columns / rows of the generator, contained in the C arrays F1, F2 and G. C C ARGUMENTS C C Mode Parameters C C TYPEG CHARACTER*1 C Specifies the type of the generator, as follows: C = 'D': generator is column oriented and rank C deficient; C = 'C': generator is column oriented and not rank C deficient; C = 'R': generator is row oriented and not rank C deficient. C Note that this parameter must be equivalent with the C used TYPEG in the call of MB02CU. C C STRUCG CHARACTER*1 C Information about the structure of the generators, C as follows: C = 'T': the trailing block of the positive generator C is upper / lower triangular, and the trailing C block of the negative generator is zero; C = 'N': no special structure to mention. C C Input/Output Parameters C C K (input) INTEGER C The number of rows in A1 to be processed. K >= 0. C C N (input) INTEGER C If TYPEG = 'D' or TYPEG = 'C', the number of rows in F1; C if TYPEG = 'R', the number of columns in F1. N >= 0. C C P (input) INTEGER C The number of columns of the positive generator. P >= K. C C Q (input) INTEGER C The number of columns in B. C If TYPEG = 'D', Q >= K; C If TYPEG = 'C' or 'R', Q >= 0. C C NB (input) INTEGER C On entry, if TYPEG = 'C' or TYPEG = 'R', NB specifies C the block size to be used in the blocked parts of the C algorithm. NB must be equivalent with the used block size C in the routine MB02CU. C C RNK (input) INTEGER C If TYPEG = 'D', the number of linearly independent columns C in the generator as returned by MB02CU. 0 <= RNK <= K. C If TYPEG = 'C' or 'R', the value of this parameter is C irrelevant. C C A1 (input) DOUBLE PRECISION array, dimension C (LDA1, K) C On entry, if TYPEG = 'D', the leading K-by-K part of this C array must contain the matrix A1 as returned by MB02CU. C If TYPEG = 'C' or 'R', this array is not referenced. C C LDA1 INTEGER C The leading dimension of the array A1. C If TYPEG = 'D', LDA1 >= MAX(1,K); C if TYPEG = 'C' or TYPEG = 'R', LDA1 >= 1. C C A2 (input) DOUBLE PRECISION array, C if TYPEG = 'D' or TYPEG = 'C', dimension (LDA2, P-K); C if TYPEG = 'R', dimension (LDA2, K). C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading C K-by-(P-K) part of this array must contain the matrix C A2 as returned by MB02CU. C On entry, if TYPEG = 'R', the leading (P-K)-by-K part of C this array must contain the matrix A2 as returned by C MB02CU. C C LDA2 INTEGER C The leading dimension of the array A2. C If P = K, LDA2 >= 1; C If P > K and (TYPEG = 'D' or TYPEG = 'C'), C LDA2 >= MAX(1,K); C if P > K and TYPEG = 'R', LDA2 >= P-K. C C B (input) DOUBLE PRECISION array, C if TYPEG = 'D' or TYPEG = 'C', dimension (LDB, Q); C if TYPEG = 'R', dimension (LDB, K). C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading C K-by-Q part of this array must contain the matrix B as C returned by MB02CU. C On entry, if TYPEG = 'R', the leading Q-by-K part of this C array must contain the matrix B as returned by MB02CU. C C LDB INTEGER C The leading dimension of the array B. C If Q = 0, LDB >= 1; C If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), C LDB >= MAX(1,K); C if Q > 0 and TYPEG = 'R', LDB >= Q. C C F1 (input/output) DOUBLE PRECISION array, C if TYPEG = 'D' or TYPEG = 'C', dimension (LDF1, K); C if TYPEG = 'R', dimension (LDF1, N). C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading C N-by-K part of this array must contain the first part C of the positive generator to be processed. C On entry, if TYPEG = 'R', the leading K-by-N part of this C array must contain the first part of the positive C generator to be processed. C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading C N-by-K part of this array contains the first part of the C transformed positive generator. C On exit, if TYPEG = 'R', the leading K-by-N part of this C array contains the first part of the transformed positive C generator. C C LDF1 INTEGER C The leading dimension of the array F1. C If TYPEG = 'D' or TYPEG = 'C', LDF1 >= MAX(1,N); C if TYPEG = 'R', LDF1 >= MAX(1,K). C C F2 (input/output) DOUBLE PRECISION array, C if TYPEG = 'D' or TYPEG = 'C', dimension (LDF2, P-K); C if TYPEG = 'R', dimension (LDF2, N). C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading C N-by-(P-K) part of this array must contain the second part C of the positive generator to be processed. C On entry, if TYPEG = 'R', the leading (P-K)-by-N part of C this array must contain the second part of the positive C generator to be processed. C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading C N-by-(P-K) part of this array contains the second part of C the transformed positive generator. C On exit, if TYPEG = 'R', the leading (P-K)-by-N part of C this array contains the second part of the transformed C positive generator. C C LDF2 INTEGER C The leading dimension of the array F2. C If P = K, LDF2 >= 1; C If P > K and (TYPEG = 'D' or TYPEG = 'C'), C LDF2 >= MAX(1,N); C if P > K and TYPEG = 'R', LDF2 >= P-K. C C G (input/output) DOUBLE PRECISION array, C if TYPEG = 'D' or TYPEG = 'C', dimension (LDG, Q); C if TYPEG = 'R', dimension (LDG, N). C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading C N-by-Q part of this array must contain the negative part C of the generator to be processed. C On entry, if TYPEG = 'R', the leading Q-by-N part of this C array must contain the negative part of the generator to C be processed. C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading C N-by-Q part of this array contains the transformed C negative generator. C On exit, if TYPEG = 'R', the leading Q-by-N part of this C array contains the transformed negative generator. C C LDG INTEGER C The leading dimension of the array G. C If Q = 0, LDG >= 1; C If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), C LDG >= MAX(1,N); C if Q > 0 and TYPEG = 'R', LDG >= Q. C C CS (input) DOUBLE PRECISION array, dimension (x) C If TYPEG = 'D' and P = K, x = 3*K; C If TYPEG = 'D' and P > K, x = 5*K; C If (TYPEG = 'C' or TYPEG = 'R') and P = K, x = 4*K; C If (TYPEG = 'C' or TYPEG = 'R') and P > K, x = 6*K. C On entry, the first x elements of this array must contain C Givens and modified hyperbolic rotation parameters, and C scalar factors of the Householder transformations as C returned by MB02CU. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = -23, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C TYPEG = 'D': LDWORK >= MAX(1,N); C (TYPEG = 'C' or TYPEG = 'R') and NB <= 0: C LDWORK >= MAX(1,N); C (TYPEG = 'C' or TYPEG = 'R') and NB >= 1: C LDWORK >= MAX(1,( N + K )*NB). 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 NUMERICAL ASPECTS C C The algorithm requires 0(N*K*( P + Q )) floating point operations. C C METHOD C C The Householder transformations and modified hyperbolic rotations C computed by SLICOT Library routine MB02CU are applied to the C corresponding parts of the matrices F1, F2 and G. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, June 2001, C March 2004, March 2007. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. Scalar Arguments .. CHARACTER STRUCG, TYPEG INTEGER INFO, K, LDA1, LDA2, LDB, LDF1, LDF2, LDG, $ LDWORK, N, NB, P, Q, RNK C .. Array Arguments .. DOUBLE PRECISION A1(LDA1,*), A2(LDA2,*), B(LDB,*), CS(*), $ DWORK(*), F1(LDF1,*), F2(LDF2,*), G(LDG,*) C .. Local Scalars .. INTEGER COL2, I, IB, J, JJ, LEN, NBL, POS, PST2, $ WRKMIN DOUBLE PRECISION ALPHA, BETA, C, S, TAU, TEMP LOGICAL LRDEF, LTRI, LCOL C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DLARF, DLARFB, DLARFT, DROT, DSCAL, $ XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 COL2 = MAX( 0, P - K ) LRDEF = LSAME( TYPEG, 'D' ) LCOL = LSAME( TYPEG, 'C' ) LTRI = LSAME( STRUCG, 'T' ) IF ( LRDEF ) THEN WRKMIN = MAX( 1, N ) ELSE IF ( NB.GE.1 ) THEN WRKMIN = MAX( 1, ( N + K )*NB ) ELSE WRKMIN = MAX( 1, N ) END IF END IF C C Check the scalar input parameters. C IF ( .NOT.( LCOL .OR. LRDEF .OR. LSAME( TYPEG, 'R' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( LTRI .OR. LSAME( STRUCG, 'N' ) ) ) THEN INFO = -2 ELSE IF ( K.LT.0 ) THEN INFO = -3 ELSE IF ( N.LT.0 ) THEN INFO = -4 ELSE IF ( P.LT.K ) THEN INFO = -5 ELSE IF ( Q.LT.0 .OR. ( LRDEF .AND. Q.LT.K ) ) THEN INFO = -6 ELSE IF ( LRDEF .AND. ( RNK.LT.0 .OR. RNK.GT.K ) ) THEN INFO = -8 ELSE IF ( ( LDA1.LT.1 ) .OR. ( LRDEF .AND. LDA1.LT.K ) ) THEN INFO = -10 ELSE IF ( ( ( P.EQ.K ) .AND. LDA2.LT.1 ) .OR. $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. $ ( LDA2.LT.MAX( 1, K ) ) ) .OR. $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. $ ( LDA2.LT.( P-K ) ) ) ) THEN INFO = -12 ELSE IF ( ( ( Q.EQ.0 ) .AND. LDB.LT.1 ) .OR. $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. $ ( LDB.LT.MAX( 1, K ) ) ) .OR. $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. $ ( LDB.LT.Q ) ) ) THEN INFO = -14 ELSE IF ( ( LRDEF .OR. LCOL ) .AND. LDF1.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF ( (.NOT.( LRDEF .OR. LCOL ) ) .AND. LDF1.LT.MAX( 1, K ) ) $ THEN INFO = -16 ELSE IF ( ( ( P.EQ.K ) .AND. LDF2.LT.1 ) .OR. $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. $ ( LDF2.LT.MAX( 1, N ) ) ) .OR. $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. $ ( LDF2.LT.( P-K ) ) ) ) THEN INFO = -18 ELSE IF ( ( ( Q.EQ.0 ) .AND. LDG.LT.1 ) .OR. $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. $ ( LDG.LT.MAX( 1, N ) ) ) .OR. $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. $ ( LDG.LT.Q ) ) ) THEN INFO = -20 ELSE IF ( LDWORK.LT.WRKMIN ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = -23 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02CV', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( K, N ).EQ.0 .OR. $ ( ( .NOT.LRDEF ) .AND. Q.EQ.0 .AND. P.EQ.K ) ) THEN RETURN END IF C IF ( LRDEF ) THEN C C Deficient generator. C IF ( COL2.EQ.0 ) THEN PST2 = 2*K ELSE PST2 = 4*K END IF C DO 10 I = 1, RNK C C Apply elementary reflectors. C IF ( COL2.GT.1 ) THEN TAU = A2(I,1) A2(I,1) = ONE CALL DLARF( 'Right', N, COL2, A2(I,1), LDA2, TAU, F2, $ LDF2, DWORK ) A2(I,1) = TAU END IF C IF ( K.GT.I ) THEN ALPHA = A1(I,I) A1(I,I) = ONE CALL DLARF( 'Right', N, K-I+1, A1(I,I), LDA1, CS(PST2+I), $ F1(1,I), LDF1, DWORK ) A1(I,I) = ALPHA END IF C IF ( COL2.GT.0 ) THEN C = CS(2*K+I*2-1) S = CS(2*K+I*2) CALL DROT( N, F1(1,I), 1, F2, 1, C, S ) END IF C IF ( Q.GT.1 ) THEN TAU = B(I,1) B(I,1) = ONE CALL DLARF( 'Right', N, Q, B(I,1), LDB, TAU, $ G, LDG, DWORK ) B(I,1) = TAU END IF C C Apply hyperbolic rotation. C C = CS(I*2-1) S = CS(I*2) CALL DSCAL( N, ONE/C, F1(1,I), 1 ) CALL DAXPY( N, -S/C, G(1,1), 1, F1(1,I), 1 ) CALL DSCAL( N, C, G(1,1), 1 ) CALL DAXPY( N, -S, F1(1,I), 1, G(1,1), 1 ) 10 CONTINUE C LEN = Q POS = 1 C DO 20 J = RNK + 1, K C C Apply the reductions working on singular rows. C IF ( COL2.GT.1 ) THEN TAU = A2(J,1) A2(J,1) = ONE CALL DLARF( 'Right', N, COL2, A2(J,1), LDA2, TAU, F2, $ LDF2, DWORK ) A2(J,1) = TAU END IF IF ( K.GT.J ) THEN ALPHA = A1(J,J) A1(J,J) = ONE CALL DLARF( 'Right', N, K-J+1, A1(J,J), LDA1, CS(PST2+J), $ F1(1,J), LDF1, DWORK ) A1(J,J) = ALPHA END IF IF ( COL2.GT.0 ) THEN C = CS(2*K+J*2-1) S = CS(2*K+J*2) CALL DROT( N, F1(1,J), 1, F2, 1, C, S ) END IF IF ( LEN.GT.1 ) THEN BETA = B(J,POS) B(J,POS) = ONE CALL DLARF( 'Right', N, LEN, B(J,POS), LDB, CS(J*2-1), $ G(1,POS), LDG, DWORK ) B(J,POS) = BETA END IF LEN = LEN - 1 POS = POS + 1 20 CONTINUE C ELSE IF ( LCOL ) THEN C C Column oriented and not deficient generator. C C Apply an LQ like hyperbolic/orthogonal blocked decomposition. C IF ( LTRI ) THEN LEN = MAX( N - K, 0 ) ELSE LEN = N END IF IF ( COL2.GT.0 ) THEN C NBL = MIN( COL2, NB ) IF ( NBL.GT.0 ) THEN C C Blocked version. C DO 50 I = 1, K - NBL + 1, NBL IB = MIN( K-I+1, NBL ) CALL DLARFT( 'Forward', 'Rowwise', COL2, IB, A2(I,1), $ LDA2, CS(4*K+I), DWORK, N+K ) CALL DLARFB( 'Right', 'No Transpose', 'Forward', $ 'Rowwise', LEN, COL2, IB, A2(I,1), $ LDA2, DWORK, N+K, F2, LDF2, $ DWORK(IB+1), N+K ) C DO 40 J = I, I + IB - 1 TAU = A2(J,1) A2(J,1) = ONE CALL DLARF( 'Right', LEN, MIN( COL2, J-I+1 ), $ A2(J,1), LDA2, TAU, F2, LDF2, DWORK ) A2(J,1) = TAU C = CS(2*K+J*2-1) S = CS(2*K+J*2) CALL DROT( LEN, F1(1,J), 1, F2, 1, C, S ) IF ( LTRI ) THEN LEN = LEN + 1 TEMP = F1(LEN,J) F1(LEN,J) = C*TEMP F2(LEN,1) = -S*TEMP C DO 30 JJ = 2, COL2 F2(LEN,JJ) = ZERO 30 CONTINUE C END IF 40 CONTINUE C 50 CONTINUE C ELSE I = 1 END IF C C Unblocked version for the last or only block. C DO 70 J = I, K IF ( COL2.GT.1 ) THEN TAU = A2(J,1) A2(J,1) = ONE CALL DLARF( 'Right', LEN, COL2, A2(J,1), LDA2, TAU, $ F2, LDF2, DWORK ) A2(J,1) = TAU END IF C C = CS(2*K+J*2-1) S = CS(2*K+J*2) CALL DROT( LEN, F1(1,J), 1, F2, 1, C, S ) IF ( LTRI ) THEN LEN = LEN + 1 TEMP = F1(LEN,J) F1(LEN,J) = C*TEMP F2(LEN,1) = -S*TEMP C DO 60 JJ = 2, COL2 F2(LEN,JJ) = ZERO 60 CONTINUE C END IF 70 CONTINUE C PST2 = 5*K ELSE PST2 = 2*K END IF C IF ( LTRI ) THEN LEN = N - K ELSE LEN = N END IF C NBL = MIN( Q, NB ) IF ( NBL.GT.0 ) THEN C C Blocked version. C DO 100 I = 1, K - NBL + 1, NBL IB = MIN( K-I+1, NBL ) CALL DLARFT( 'Forward', 'Rowwise', Q, IB, B(I,1), $ LDB, CS(PST2+I), DWORK, N+K ) CALL DLARFB( 'Right', 'NonTranspose', 'Forward', $ 'Rowwise', LEN, Q, IB, B(I,1), $ LDB, DWORK, N+K, G, LDG, $ DWORK(IB+1), N+K ) C DO 90 J = I, I + IB - 1 TAU = B(J,1) B(J,1) = ONE CALL DLARF( 'Right', LEN, J-I+1, B(J,1), LDB, $ TAU, G, LDG, DWORK ) B(J,1) = TAU C C Apply hyperbolic rotation. C C = CS(J*2-1) S = CS(J*2) CALL DSCAL( LEN, ONE/C, F1(1,J), 1 ) CALL DAXPY( LEN, -S/C, G, 1, F1(1,J), 1 ) CALL DSCAL( LEN, C, G, 1 ) CALL DAXPY( LEN, -S, F1(1,J), 1, G, 1 ) IF ( LTRI ) THEN LEN = LEN + 1 G(LEN,1) = -S/C*F1(LEN,J) F1(LEN,J) = F1(LEN,J) / C C DO 80 JJ = 2, Q G(LEN,JJ) = ZERO 80 CONTINUE C END IF 90 CONTINUE C 100 CONTINUE C ELSE I = 1 END IF C C Unblocked version for the last or only block. C DO 120 J = I, K IF ( Q.GT.1 ) THEN TAU = B(J,1) B(J,1) = ONE CALL DLARF( 'Right', LEN, Q, B(J,1), LDB, TAU, $ G, LDG, DWORK ) B(J,1) = TAU END IF IF ( Q.GT.0 ) THEN C C Apply hyperbolic rotation. C C = CS(J*2-1) S = CS(J*2) CALL DSCAL( LEN, ONE/C, F1(1,J), 1 ) CALL DAXPY( LEN, -S/C, G, 1, F1(1,J), 1 ) CALL DSCAL( LEN, C, G, 1 ) CALL DAXPY( LEN, -S, F1(1,J), 1, G, 1 ) IF ( LTRI ) THEN LEN = LEN + 1 G(LEN,1) = -S/C*F1(LEN,J) F1(LEN,J) = F1(LEN,J) / C C DO 110 JJ = 2, Q G(LEN,JJ) = ZERO 110 CONTINUE C END IF END IF 120 CONTINUE C ELSE C C Row oriented and not deficient generator. C IF ( LTRI ) THEN LEN = MAX( N - K, 0 ) ELSE LEN = N END IF C IF ( COL2.GT.0 ) THEN NBL = MIN( NB, COL2 ) IF ( NBL.GT.0 ) THEN C C Blocked version. C DO 150 I = 1, K - NBL + 1, NBL IB = MIN( K-I+1, NBL ) CALL DLARFT( 'Forward', 'Columnwise', COL2, IB, $ A2(1,I), LDA2, CS(4*K+I), DWORK, N+K ) CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', COL2, LEN, IB, A2(1,I), $ LDA2, DWORK, N+K, F2, LDF2, $ DWORK(IB+1), N+K ) C DO 140 J = I, I + IB - 1 TAU = A2(1,J) A2(1,J) = ONE CALL DLARF( 'Left', MIN( COL2, J-I+1 ), LEN, $ A2(1,J), 1, TAU, F2, LDF2, DWORK ) A2(1,J) = TAU C = CS(2*K+J*2-1) S = CS(2*K+J*2) CALL DROT( LEN, F1(J,1), LDF1, F2, LDF2, C, S ) IF ( LTRI ) THEN LEN = LEN + 1 TEMP = F1(J,LEN) F1(J,LEN) = C*TEMP F2(1,LEN) = -S*TEMP C DO 130 JJ = 2, COL2 F2(JJ,LEN) = ZERO 130 CONTINUE C END IF 140 CONTINUE C 150 CONTINUE C ELSE I = 1 END IF C C Unblocked version for the last or only block. C DO 170 J = I, K IF ( COL2.GT.1 ) THEN TAU = A2(1,J) A2(1,J) = ONE CALL DLARF( 'Left', COL2, LEN, A2(1,J), 1, TAU, $ F2, LDF2, DWORK ) A2(1,J) = TAU END IF C C = CS(2*K+J*2-1) S = CS(2*K+J*2) CALL DROT( LEN, F1(J,1), LDF1, F2, LDF2, C, S ) IF ( LTRI ) THEN LEN = LEN + 1 TEMP = F1(J,LEN) F1(J,LEN) = C*TEMP F2(1,LEN) = -S*TEMP C DO 160 JJ = 2, COL2 F2(JJ,LEN) = ZERO 160 CONTINUE C END IF 170 CONTINUE C PST2 = 5*K ELSE PST2 = 2*K END IF C IF ( LTRI ) THEN LEN = N - K ELSE LEN = N END IF C NBL = MIN( Q, NB ) IF ( NBL.GT.0 ) THEN C C Blocked version. C DO 200 I = 1, K - NBL + 1, NBL IB = MIN( K-I+1, NBL ) CALL DLARFT( 'Forward', 'Columnwise', Q, IB, B(1,I), $ LDB, CS(PST2+I), DWORK, N+K ) CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', Q, LEN, IB, B(1,I), $ LDB, DWORK, N+K, G, LDG, $ DWORK(IB+1), N+K ) C DO 190 J = I, I + IB - 1 TAU = B(1,J) B(1,J) = ONE CALL DLARF( 'Left', J-I+1, LEN, B(1,J), 1, $ TAU, G, LDG, DWORK ) B(1,J) = TAU C C Apply hyperbolic rotation. C C = CS(J*2-1) S = CS(J*2) CALL DSCAL( LEN, ONE/C, F1(J,1), LDF1 ) CALL DAXPY( LEN, -S/C, G, LDG, F1(J,1), LDF1 ) CALL DSCAL( LEN, C, G, LDG ) CALL DAXPY( LEN, -S, F1(J,1), LDF1, G, LDG ) IF ( LTRI ) THEN LEN = LEN + 1 G(1,LEN) = -S/C*F1(J,LEN) F1(J,LEN) = F1(J,LEN) / C C DO 180 JJ = 2, Q G(JJ,LEN) = ZERO 180 CONTINUE C END IF 190 CONTINUE C 200 CONTINUE C ELSE I = 1 END IF C C Unblocked version for the last or only block. C DO 220 J = I, K IF ( Q.GT.1 ) THEN TAU = B(1,J) B(1,J) = ONE CALL DLARF( 'Left', Q, LEN, B(1,J), 1, TAU, $ G, LDG, DWORK ) B(1,J) = TAU END IF IF ( Q.GT.0 ) THEN C C Apply hyperbolic rotation. C C = CS(J*2-1) S = CS(J*2) CALL DSCAL( LEN, ONE/C, F1(J,1), LDF1 ) CALL DAXPY( LEN, -S/C, G, LDG, F1(J,1), LDF1 ) CALL DSCAL( LEN, C, G, LDG ) CALL DAXPY( LEN, -S, F1(J,1), LDF1, G, LDG ) IF ( LTRI ) THEN LEN = LEN + 1 G(1,LEN) = -S/C*F1(J,LEN) F1(J,LEN) = F1(J,LEN) / C C DO 210 JJ = 2, Q G(JJ,LEN) = ZERO 210 CONTINUE C END IF END IF 220 CONTINUE C END IF C C *** Last line of MB02CV *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03MV.f0000644000000000000000000000013015012430707016205 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03MV.f0000644000175000017500000002117515012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE SB03MV( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, $ XNORM, INFO ) C C PURPOSE C C To solve for the 2-by-2 symmetric matrix X in C C op(T)'*X*op(T) - X = SCALE*B, C C where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T', C where T' denotes the transpose of T. C C ARGUMENTS C C Mode Parameters C C LTRAN LOGICAL C Specifies the form of op(T) to be used, as follows: C = .FALSE.: op(T) = T, C = .TRUE. : op(T) = T'. C C LUPPER LOGICAL C Specifies which triangle of the matrix B is used, and C which triangle of the matrix X is computed, as follows: C = .TRUE. : The upper triangular part; C = .FALSE.: The lower triangular part. C C Input/Output Parameters C C T (input) DOUBLE PRECISION array, dimension (LDT,2) C The leading 2-by-2 part of this array must contain the C matrix T. C C LDT INTEGER C The leading dimension of array T. LDT >= 2. C C B (input) DOUBLE PRECISION array, dimension (LDB,2) C On entry with LUPPER = .TRUE., the leading 2-by-2 upper C triangular part of this array must contain the upper C triangular part of the symmetric matrix B and the strictly C lower triangular part of B is not referenced. C On entry with LUPPER = .FALSE., the leading 2-by-2 lower C triangular part of this array must contain the lower C triangular part of the symmetric matrix B and the strictly C upper triangular part of B is not referenced. C C LDB INTEGER C The leading dimension of array B. LDB >= 2. C C SCALE (output) DOUBLE PRECISION C The scale factor. SCALE is chosen less than or equal to 1 C to prevent the solution overflowing. C C X (output) DOUBLE PRECISION array, dimension (LDX,2) C On exit with LUPPER = .TRUE., the leading 2-by-2 upper C triangular part of this array contains the upper C triangular part of the symmetric solution matrix X and the C strictly lower triangular part of X is not referenced. C On exit with LUPPER = .FALSE., the leading 2-by-2 lower C triangular part of this array contains the lower C triangular part of the symmetric solution matrix X and the C strictly upper triangular part of X is not referenced. C Note that X may be identified with B in the calling C statement. C C LDX INTEGER C The leading dimension of array X. LDX >= 2. C C XNORM (output) DOUBLE PRECISION C The infinity-norm of the solution. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if T has almost reciprocal eigenvalues, so T C is perturbed to get a nonsingular equation. C C NOTE: In the interests of speed, this routine does not C check the inputs for errors. C C METHOD C C The equivalent linear algebraic system of equations is formed and C solved using Gaussian elimination with complete pivoting. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C The algorithm is stable and reliable, since Gaussian elimination C with complete pivoting is used. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. C Based on DLALD2 by P. Petkov, Tech. University of Sofia, September C 1993. C C REVISIONS C C - C C KEYWORDS C C Discrete-time system, Lyapunov equation, matrix algebra. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, FOUR PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, FOUR = 4.0D+0 ) C .. C .. Scalar Arguments .. LOGICAL LTRAN, LUPPER INTEGER INFO, LDB, LDT, LDX DOUBLE PRECISION SCALE, XNORM C .. C .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) C .. C .. Local Scalars .. INTEGER I, IP, IPSV, J, JP, JPSV, K DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX C .. C .. Local Arrays .. INTEGER JPIV( 3 ) DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) C .. C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. C .. External Subroutines .. EXTERNAL DSWAP C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. C .. Executable Statements .. C C Do not check the input parameters for errors. C INFO = 0 C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS C C Solve equivalent 3-by-3 system using complete pivoting. C Set pivots less than SMIN to SMIN. C SMIN = MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) ) SMIN = MAX( EPS*SMIN, SMLNUM ) T9( 1, 1 ) = T( 1, 1 )*T( 1, 1 ) - ONE T9( 2, 2 ) = T( 1, 1 )*T( 2, 2 ) + T( 1, 2 )*T( 2, 1 ) - ONE T9( 3, 3 ) = T( 2, 2 )*T( 2, 2 ) - ONE IF( LTRAN ) THEN T9( 1, 2 ) = T( 1, 1 )*T( 1, 2 ) + T( 1, 1 )*T( 1, 2 ) T9( 1, 3 ) = T( 1, 2 )*T( 1, 2 ) T9( 2, 1 ) = T( 1, 1 )*T( 2, 1 ) T9( 2, 3 ) = T( 1, 2 )*T( 2, 2 ) T9( 3, 1 ) = T( 2, 1 )*T( 2, 1 ) T9( 3, 2 ) = T( 2, 1 )*T( 2, 2 ) + T( 2, 1 )*T( 2, 2 ) ELSE T9( 1, 2 ) = T( 1, 1 )*T( 2, 1 ) + T( 1, 1 )*T( 2, 1 ) T9( 1, 3 ) = T( 2, 1 )*T( 2, 1 ) T9( 2, 1 ) = T( 1, 1 )*T( 1, 2 ) T9( 2, 3 ) = T( 2, 1 )*T( 2, 2 ) T9( 3, 1 ) = T( 1, 2 )*T( 1, 2 ) T9( 3, 2 ) = T( 1, 2 )*T( 2, 2 ) + T( 1, 2 )*T( 2, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) IF ( LUPPER ) THEN BTMP( 2 ) = B( 1, 2 ) ELSE BTMP( 2 ) = B( 2, 1 ) END IF BTMP( 3 ) = B( 2, 2 ) C C Perform elimination. C DO 50 I = 1, 2 XMAX = ZERO C DO 20 IP = I, 3 C DO 10 JP = I, 3 IF( ABS( T9( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( T9( IP, JP ) ) IPSV = IP JPSV = JP END IF 10 CONTINUE C 20 CONTINUE C IF( IPSV.NE.I ) THEN CALL DSWAP( 3, T9( IPSV, 1 ), 3, T9( I, 1 ), 3 ) TEMP = BTMP( I ) BTMP( I ) = BTMP( IPSV ) BTMP( IPSV ) = TEMP END IF IF( JPSV.NE.I ) $ CALL DSWAP( 3, T9( 1, JPSV ), 1, T9( 1, I ), 1 ) JPIV( I ) = JPSV IF( ABS( T9( I, I ) ).LT.SMIN ) THEN INFO = 1 T9( I, I ) = SMIN END IF C DO 40 J = I + 1, 3 T9( J, I ) = T9( J, I ) / T9( I, I ) BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) C DO 30 K = I + 1, 3 T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) 30 CONTINUE C 40 CONTINUE C 50 CONTINUE C IF( ABS( T9( 3, 3 ) ).LT.SMIN ) $ T9( 3, 3 ) = SMIN SCALE = ONE IF( ( FOUR*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T9( 1, 1 ) ) .OR. $ ( FOUR*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T9( 2, 2 ) ) .OR. $ ( FOUR*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T9( 3, 3 ) ) ) THEN SCALE = ( ONE / FOUR ) / MAX( ABS( BTMP( 1 ) ), $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE BTMP( 3 ) = BTMP( 3 )*SCALE END IF C DO 70 I = 1, 3 K = 4 - I TEMP = ONE / T9( K, K ) TMP( K ) = BTMP( K )*TEMP C DO 60 J = K + 1, 3 TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) 60 CONTINUE C 70 CONTINUE C DO 80 I = 1, 2 IF( JPIV( 3-I ).NE.3-I ) THEN TEMP = TMP( 3-I ) TMP( 3-I ) = TMP( JPIV( 3-I ) ) TMP( JPIV( 3-I ) ) = TEMP END IF 80 CONTINUE C X( 1, 1 ) = TMP( 1 ) IF ( LUPPER ) THEN X( 1, 2 ) = TMP( 2 ) ELSE X( 2, 1 ) = TMP( 2 ) END IF X( 2, 2 ) = TMP( 3 ) XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 2 ) ), $ ABS( TMP( 2 ) ) + ABS( TMP( 3 ) ) ) C RETURN C *** Last line of SB03MV *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03UD.f0000644000000000000000000000013215012430707016175 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03UD.f0000644000175000017500000004743315012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE SB03UD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, $ RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To solve the real discrete-time Lyapunov matrix equation C C op(A)'*X*op(A) - X = scale*C, C C estimate the conditioning, and compute an error bound on the C solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N, C the right hand side C and the solution X are N-by-N symmetric C matrices (C = C', X = X'), and scale is an output scale factor, C set less than or equal to 1 to avoid overflow in X. C C ARGUMENTS C C Mode Parameters 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 = 'C': Compute the reciprocal condition number only; C = 'E': Compute the error bound only; C = 'A': Compute all: the solution, separation, reciprocal C condition number, and the error bound. 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, T and U (if LYAPUN = 'O') contain the C factors from the real Schur factorization of the C matrix A; C = 'N': The Schur factorization of A will be computed C and the factors will be stored in T and U (if C LYAPUN = 'O'). 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 UPLO CHARACTER*1 C Specifies which part of the symmetric matrix C is to be C used, as follows: C = 'U': Upper triangular part; C = 'L': Lower triangular part. C C LYAPUN CHARACTER*1 C Specifies whether or not the original or "reduced" C Lyapunov equations should be solved, as follows: C = 'O': Solve the original Lyapunov equations, updating C the right-hand sides and solutions with the C matrix U, e.g., X <-- U'*X*U; C = 'R': Solve reduced Lyapunov equations only, without C updating the right-hand sides and solutions. C This means that a real Schur form T of A appears C in the equation, instead of A. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, X, and C. N >= 0. C C SCALE (input or output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'E', SCALE is an input argument: C the scale factor, set by a Lyapunov solver. C 0 <= SCALE <= 1. C If JOB = 'X' or JOB = 'A', SCALE is an output argument: C the scale factor, scale, set less than or equal to 1 to C prevent the solution overflowing. C If JOB = 'S', this argument is not used. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the C leading N-by-N part of this array must contain the C original matrix A. C If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is C not referenced. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and C JOB <> 'X'; C LDA >= 1, otherwise. C C T (input/output) DOUBLE PRECISION array, dimension C (LDT,N) C If FACT = 'F', then on entry the leading N-by-N upper C Hessenberg part of this array must contain the upper C quasi-triangular matrix T in Schur canonical form from a C Schur factorization of A. C If FACT = 'N', then this array need not be set on input. C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the C leading N-by-N upper Hessenberg part of this array C contains the upper quasi-triangular matrix T in Schur C canonical form from a Schur factorization of A. C The contents of array T is not modified if FACT = 'F'. C C LDT INTEGER C The leading dimension of the array T. LDT >= MAX(1,N). C C U (input or output) DOUBLE PRECISION array, dimension C (LDU,N) C If LYAPUN = 'O' and FACT = 'F', then U is an input C argument and on entry, the leading N-by-N part of this C array must contain the orthogonal matrix U from a real C Schur factorization of A. C If LYAPUN = 'O' and FACT = 'N', then U is an output C argument and on exit, if INFO = 0 or INFO = N+1, it C contains the orthogonal N-by-N matrix from a real Schur C factorization of A. C If LYAPUN = 'R', the array U is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= 1, if LYAPUN = 'R'; C LDU >= MAX(1,N), if LYAPUN = 'O'. C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper C triangular part of this array must contain the upper C triangular part of the matrix C of the original Lyapunov C equation (with matrix A), if LYAPUN = 'O', or of the C reduced Lyapunov equation (with matrix T), if C LYAPUN = 'R'. C If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower C triangular part of this array must contain the lower C triangular part of the matrix C of the original Lyapunov C equation (with matrix A), if LYAPUN = 'O', or of the C reduced Lyapunov equation (with matrix T), if C LYAPUN = 'R'. C The remaining strictly triangular part of this array is C used as workspace. C If JOB = 'X', then this array may be identified with X C in the call of this routine. C If JOB = 'S', the array C is not referenced. C C LDC INTEGER C The leading dimension of the array C. C LDC >= 1, if JOB = 'S'; C LDC >= MAX(1,N), otherwise. C C X (input or output) DOUBLE PRECISION array, dimension C (LDX,N) C If JOB = 'C' or 'E', then X is an input argument and on C entry, the leading N-by-N part of this array must contain C the symmetric solution matrix X of the original Lyapunov C equation (with matrix A), if LYAPUN = 'O', or of the C reduced Lyapunov equation (with matrix T), if C LYAPUN = 'R'. C If JOB = 'X' or 'A', then X is an output argument and on C exit, if INFO = 0 or INFO = N+1, the leading N-by-N part C of this array contains the symmetric solution matrix X of C of the original Lyapunov equation (with matrix A), if C LYAPUN = 'O', or of the reduced Lyapunov equation (with C matrix T), if LYAPUN = 'R'. C If JOB = 'S', the array X is not referenced. C C LDX INTEGER C The leading dimension of the array X. C LDX >= 1, if JOB = 'S'; C LDX >= MAX(1,N), otherwise. C C SEPD (output) DOUBLE PRECISION C If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or C INFO = N+1, SEPD contains the estimated separation of the C matrices op(A) and op(A)', sepd(op(A),op(A)'). C If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEPD is not C referenced. C C RCOND (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'A', an estimate of the reciprocal C condition number of the continuous-time Lyapunov equation. C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. C If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not C referenced. C C FERR (output) DOUBLE PRECISION C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1, C FERR contains an estimated forward error bound for the C solution X. If XTRUE is the true solution, FERR bounds the C relative error in the computed solution, measured in the C Frobenius norm: norm(X - XTRUE)/norm(XTRUE). C If N = 0 or X = 0, FERR is set to 0. C If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not C 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 the C 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. C If JOB = 'X', then C LDWORK >= MAX(1,N*N,2*N), if FACT = 'F'; C LDWORK >= MAX(1,N*N,3*N), if FACT = 'N'. C If JOB = 'S', then C LDWORK >= MAX(3,2*N*N). C If JOB = 'C', then C LDWORK >= MAX(3,2*N*N) + N*N. C If JOB = 'E', or JOB = 'A', then C LDWORK >= MAX(3,2*N*N) + N*N + 2*N. C For optimum performance LDWORK should sometimes 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, i <= N, the QR algorithm failed to C complete the reduction to Schur canonical form (see C LAPACK Library routine DGEES); on exit, the matrix C T(i+1:N,i+1:N) contains the partially converged C Schur form, and the elements i+1:n of WR and WI C contain the real and imaginary parts, respectively, C of the converged eigenvalues; this error is unlikely C to appear; C = N+1: if the matrix T has almost reciprocal eigenvalues; C perturbed values were used to solve Lyapunov C equations, but the matrix T, if given (for C FACT = 'F'), is unchanged. C C METHOD C C After reducing matrix A to real Schur canonical form (if needed), C a discrete-time version of the Bartels-Stewart algorithm is used. C A set of equivalent linear algebraic systems of equations of order C at most four are formed and solved using Gaussian elimination with C complete pivoting. C C The condition number of the discrete-time Lyapunov equation is C estimated as C C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), C C where Omega and Theta are linear operators defined by C C Omega(W) = op(A)'*W*op(A) - W, C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). C C The routine estimates the quantities C C sepd(op(A),op(A)') = 1 / norm(inv(Omega)) C C and norm(Theta) using 1-norm condition estimators. C C The forward error bound is estimated using a practical error bound C similar to the one proposed in [3]. 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] Higham, N.J. C Perturbation theory and backward error for AX-XB=C. C BIT, vol. 33, pp. 124-136, 1993. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C The accuracy of the estimates obtained depends on the solution C accuracy and on the properties of the 1-norm estimator. C C FURTHER COMMENTS C C The "separation" sepd of op(A) and op(A)' can also be defined as C C sepd( 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( op(A)', op(A)' ) - I(N**2). C C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the C Kronecker product. The routine estimates sigma_min(T) by the C reciprocal of an estimate of the 1-norm of inverse(T). The true C reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by C more than a factor of N. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. C This is an extended and improved version of Release 3.0 routine C SB03PD. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form, C Sylvester equation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) C .. C .. Scalar Arguments .. CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N DOUBLE PRECISION FERR, RCOND, SCALE, SEPD C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), $ T( LDT, * ), U( LDU, * ), WI( * ), WR( * ), $ X( LDX, * ) C .. C .. Local Scalars .. LOGICAL JOBA, JOBC, JOBE, JOBS, JOBX, LOWER, NOFACT, $ NOTRNA, UPDATE CHARACTER CFACT, JOBL, SJOB INTEGER LDW, NN, SDIM DOUBLE PRECISION THNORM C .. C .. Local Arrays .. LOGICAL BWORK( 1 ) C .. C .. External Functions .. LOGICAL LSAME, SELECT EXTERNAL LSAME, SELECT C .. C .. External Subroutines .. EXTERNAL DGEES, DLACPY, DSCAL, MA02ED, MB01RU, SB03MX, $ SB03SD, SB03SY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX C .. C .. Executable Statements .. C C Decode option parameters. C JOBX = LSAME( JOB, 'X' ) JOBS = LSAME( JOB, 'S' ) JOBC = LSAME( JOB, 'C' ) JOBE = LSAME( JOB, 'E' ) JOBA = LSAME( JOB, 'A' ) NOFACT = LSAME( FACT, 'N' ) NOTRNA = LSAME( TRANA, 'N' ) LOWER = LSAME( UPLO, 'L' ) UPDATE = LSAME( LYAPUN, 'O' ) C C Compute workspace. C NN = N*N IF( JOBX ) THEN IF( NOFACT ) THEN LDW = MAX( 1, NN, 3*N ) ELSE LDW = MAX( 1, NN, 2*N ) END IF ELSE IF( JOBS ) THEN LDW = MAX( 3, 2*NN ) ELSE IF( JOBC ) THEN LDW = MAX( 3, 2*NN ) + NN ELSE LDW = MAX( 3, 2*NN ) + NN + 2*N END IF C C Test the scalar input parameters. C INFO = 0 IF( .NOT.( JOBX .OR. JOBS .OR. JOBC .OR. JOBE .OR. JOBA ) ) THEN INFO = -1 ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. $ LSAME( TRANA, 'C' ) ) ) THEN INFO = -3 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -4 ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( ( JOBC .OR. JOBE ) .AND. $ ( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) )THEN INFO = -7 ELSE IF( LDA.LT.1 .OR. $ ( LDA.LT.N .AND. ( ( UPDATE .AND. .NOT.JOBX ) .OR. $ NOFACT ) ) ) THEN INFO = -9 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN INFO = -13 ELSE IF( LDC.LT.1 .OR. ( .NOT.JOBS .AND. LDC.LT.N ) ) THEN INFO = -15 ELSE IF( LDX.LT.1 .OR. ( .NOT.JOBS .AND. LDX.LT.N ) ) THEN INFO = -17 ELSE IF( LDWORK.LT.LDW ) THEN INFO = -25 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03UD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IF( JOBX .OR. JOBA ) $ SCALE = ONE IF( JOBC .OR. JOBA ) $ RCOND = ONE IF( JOBE .OR. JOBA ) $ FERR = ZERO DWORK( 1 ) = ONE RETURN END IF C IF( NOFACT ) THEN C C Compute the Schur factorization of A. C Workspace: need 3*N; C prefer larger. C CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) IF( UPDATE ) THEN SJOB = 'V' ELSE SJOB = 'N' END IF CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, WR, $ WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) IF( INFO.GT.0 ) $ RETURN LDW = MAX( LDW, INT( DWORK( 1 ) ) ) CFACT = 'F' ELSE CFACT = FACT END IF C IF( JOBX .OR. JOBA ) THEN C C Copy the right-hand side in X. C CALL DLACPY( UPLO, N, N, C, LDC, X, LDX ) C IF( UPDATE ) THEN C C Transform the right-hand side. C Workspace: need N*N. C CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, U, $ LDU, X, LDX, DWORK, LDWORK, INFO ) CALL DSCAL( N, HALF, X, LDX+1 ) END IF C C Fill in the remaining triangle of X. C CALL MA02ED( UPLO, N, X, LDX ) C C Solve the transformed equation. C Workspace: 2*N. C CALL SB03MX( TRANA, N, T, LDT, X, LDX, SCALE, DWORK, INFO ) IF( INFO.GT.0 ) $ INFO = N + 1 C IF( UPDATE ) THEN C C Transform back the solution. C CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, X, LDX, $ U, LDU, X, LDX, DWORK, LDWORK, INFO ) CALL DSCAL( N, HALF, X, LDX+1 ) C C Fill in the remaining triangle of X. C CALL MA02ED( UPLO, N, X, LDX ) END IF END IF C IF( JOBS ) THEN C C Estimate sepd(op(A),op(A)'). C Workspace: MAX(3,2*N*N). C CALL SB03SY( 'Separation', TRANA, LYAPUN, N, T, LDT, U, LDU, $ DWORK, 1, SEPD, THNORM, IWORK, DWORK, LDWORK, $ INFO ) C ELSE IF( .NOT.JOBX ) THEN C C Estimate the reciprocal condition and/or the error bound. C Workspace: MAX(3,2*N*N) + N*N + a*N, where: C a = 2, if JOB = 'E' or JOB = 'A'; C a = 0, otherwise. C IF( JOBA ) THEN JOBL = 'B' ELSE JOBL = JOB END IF CALL SB03SD( JOBL, CFACT, TRANA, UPLO, LYAPUN, N, SCALE, A, $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, RCOND, $ FERR, IWORK, DWORK, LDWORK, INFO ) LDW = MAX( LDW, INT( DWORK( 1 ) ) ) END IF C DWORK( 1 ) = DBLE( LDW ) C RETURN C *** Last line of SB03UD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02CY.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02CY.f0000644000175000017500000002627615012430707017402 0ustar00lilgelilge00000000000000 SUBROUTINE MB02CY( TYPET, STRUCG, P, Q, N, K, A, LDA, B, LDB, H, $ LDH, CS, LCS, DWORK, LDWORK, INFO ) C C PURPOSE C C To apply the transformations created by the SLICOT Library C routine MB02CX on other columns / rows of the generator, C contained in the arrays A and B of positive and negative C generators, respectively. C C ARGUMENTS C C Mode Parameters C C TYPET CHARACTER*1 C Specifies the type of the generator, as follows: C = 'R': A and B are additional columns of the generator; C = 'C': A and B are additional rows of the generator. C Note: in the sequel, the notation x / y means that C x corresponds to TYPET = 'R' and y corresponds to C TYPET = 'C'. C C STRUCG CHARACTER*1 C Information about the structure of the two generators, C as follows: C = 'T': the trailing block of the positive generator C is lower / upper triangular, and the trailing C block of the negative generator is zero; C = 'N': no special structure to mention. C C Input/Output Parameters C C P (input) INTEGER C The number of rows / columns in A containing the positive C generators. P >= 0. C C Q (input) INTEGER C The number of rows / columns in B containing the negative C generators. Q >= 0. C C N (input) INTEGER C The number of columns / rows in A and B to be processed. C N >= 0. C C K (input) INTEGER C The number of columns / rows in H. P >= K >= 0. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N) / (LDA, P) C On entry, the leading P-by-N / N-by-P part of this array C must contain the positive part of the generator. C On exit, the leading P-by-N / N-by-P part of this array C contains the transformed positive part of the generator. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,P), if TYPET = 'R'; C LDA >= MAX(1,N), if TYPET = 'C'. C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N) / (LDB, Q) C On entry, the leading Q-by-N / N-by-Q part of this array C must contain the negative part of the generator. C On exit, the leading Q-by-N / N-by-Q part of this array C contains the transformed negative part of the generator. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,Q), if TYPET = 'R'; C LDB >= MAX(1,N), if TYPET = 'C'. C C H (input) DOUBLE PRECISION array, dimension C (LDH, K) / (LDH, Q) C The leading Q-by-K / K-by-Q part of this array must C contain part of the necessary information for the C Householder transformations computed by SLICOT Library C routine MB02CX. C C LDH INTEGER C The leading dimension of the array H. C LDH >= MAX(1,Q), if TYPET = 'R'; C LDH >= MAX(1,K), if TYPET = 'C'. C C CS (input) DOUBLE PRECISION array, dimension (LCS) C The leading 2*K + MIN(K,Q) part of this array must C contain the necessary information for modified hyperbolic C rotations and the scalar factors of the Householder C transformations computed by SLICOT Library routine MB02CX. C C LCS INTEGER C The length of the array CS. LCS >= 2*K + MIN(K,Q). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -16, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,N). C For optimum performance LDWORK should be larger. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal C value. C C METHOD C C The Householder transformations and modified hyperbolic rotations C computed by SLICOT Library routine MB02CX are applied to the C corresponding parts of the matrices A and B. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 2000, C February 2004, March 2007, Aug. 2011. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, K, LDA, LDB, LCS, LDH, LDWORK, N, P, Q CHARACTER STRUCG, TYPET C .. Array Arguments .. DOUBLE PRECISION A(LDA, *), B(LDB, *), CS(*), DWORK(*), H(LDH,*) C .. Local Scalars .. LOGICAL ISLWR, ISROW INTEGER I, IERR, CI, MAXWRK DOUBLE PRECISION C, S, TAU C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DLARF, DLASET, DORMLQ, DORMQR, DSCAL, $ XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 ISROW = LSAME( TYPET, 'R' ) ISLWR = LSAME( STRUCG, 'T' ) C C Check the scalar input parameters. C IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( ISLWR .OR. LSAME( STRUCG, 'N' ) ) ) THEN INFO = -2 ELSE IF ( P.LT.0 ) THEN INFO = -3 ELSE IF ( Q.LT.0 ) THEN INFO = -4 ELSE IF ( N.LT.0 ) THEN INFO = -5 ELSE IF ( K.LT.0 .OR. K.GT.P ) THEN INFO = -6 ELSE IF ( LDA.LT.1 .OR. ( ISROW .AND. LDA.LT.P ) .OR. $ ( .NOT.ISROW .AND. LDA.LT.N ) ) THEN INFO = -8 ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.Q ) .OR. $ ( .NOT.ISROW .AND. LDB.LT.N ) ) THEN INFO = -10 ELSE IF ( LDH.LT.1 .OR. ( ISROW .AND. LDH.LT.Q ) .OR. $ ( .NOT.ISROW .AND. LDH.LT.K ) ) THEN INFO = -12 ELSE IF ( LCS.LT.2*K + MIN( K, Q ) ) THEN INFO = -14 ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN DWORK(1) = MAX( 1, N ) INFO = -16 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02CY', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( N, K, Q ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Applying the transformations. C IF ( ISROW ) THEN C C The generator is row wise stored. C IF ( ISLWR ) THEN MAXWRK = 1 C DO 10 I = 1, K C C Apply Householder transformation avoiding touching of C zero blocks. C CI = N - K + I - 1 TAU = H(1,I) H(1,I) = ONE CALL DLARF( 'Left', MIN( I, Q ), CI, H(1,I), 1, TAU, B, $ LDB, DWORK ) H(1,I) = TAU C C Now apply the hyperbolic rotation under the assumption C that A(I, N-K+I+1:N) and B(1, N-K+I:N) are zero. C C = CS(I*2-1) S = CS(I*2) C CALL DSCAL( CI, ONE/C, A(I,1), LDA ) CALL DAXPY( CI, -S/C, B(1,1), LDB, A(I,1), LDA ) CALL DSCAL( CI, C, B(1,1), LDB ) CALL DAXPY( CI, -S, A(I,1), LDA, B(1,1), LDB ) C B(1,N-K+I) = -S/C * A(I,N-K+I) A(I,N-K+I) = ONE/C * A(I,N-K+I) C C All below B(1,N-K+I) should be zero. C IF( Q.GT.1 ) $ CALL DLASET( 'All', Q-1, 1, ZERO, ZERO, B(2,N-K+I), $ 1 ) 10 CONTINUE C ELSE C C Apply the QR reduction on B. C CALL DORMQR( 'Left', 'Transpose', Q, N, MIN( K, Q ), H, $ LDH, CS(2*K+1), B, LDB, DWORK, LDWORK, IERR ) MAXWRK = DWORK(1) C DO 20 I = 1, K C C Apply Householder transformation. C TAU = H(1,I) H(1,I) = ONE CALL DLARF( 'Left', MIN( I, Q ), N, H(1,I), 1, TAU, B, $ LDB, DWORK ) H(1,I) = TAU C C Apply Hyperbolic Rotation. C C = CS(I*2-1) S = CS(I*2) C CALL DSCAL( N, ONE/C, A(I,1), LDA ) CALL DAXPY( N, -S/C, B(1,1), LDB, A(I,1), LDA ) CALL DSCAL( N, C, B(1,1), LDB ) CALL DAXPY( N, -S, A(I,1), LDA, B(1,1), LDB ) 20 CONTINUE C END IF C ELSE C C The generator is column wise stored. C IF ( ISLWR ) THEN MAXWRK = 1 C DO 30 I = 1, K C C Apply Householder transformation avoiding touching zeros. C CI = N - K + I - 1 TAU = H(I,1) H(I,1) = ONE CALL DLARF( 'Right', CI, MIN( I, Q ), H(I,1), LDH, TAU, $ B, LDB, DWORK ) H(I,1) = TAU C C Apply Hyperbolic Rotation. C C = CS(I*2-1) S = CS(I*2) C CALL DSCAL( CI, ONE/C, A(1,I), 1 ) CALL DAXPY( CI, -S/C, B(1,1), 1, A(1,I), 1 ) CALL DSCAL( CI, C, B(1,1), 1 ) CALL DAXPY( CI, -S, A(1,I), 1, B(1,1), 1 ) C B(N-K+I,1) = -S/C * A(N-K+I,I) A(N-K+I,I) = ONE/C * A(N-K+I,I) C C All elements right behind B(N-K+I,1) should be zero. C IF( Q.GT.1 ) $ CALL DLASET( 'All', 1, Q-1, ZERO, ZERO, B(N-K+I,2), $ LDB ) 30 CONTINUE C ELSE C C Apply the LQ reduction on B. C CALL DORMLQ( 'Right', 'Transpose', N, Q, MIN( K, Q ), H, $ LDH, CS(2*K+1), B, LDB, DWORK, LDWORK, IERR ) MAXWRK = DWORK(1) C DO 40 I = 1, K C C Apply Householder transformation. C TAU = H(I,1) H(I,1) = ONE CALL DLARF( 'Right', N, MIN( I, Q ), H(I,1), LDH, TAU, B, $ LDB, DWORK ) H(I,1) = TAU C C Apply Hyperbolic Rotation. C C = CS(I*2-1) S = CS(I*2) C CALL DSCAL( N, ONE/C, A(1,I), 1 ) CALL DAXPY( N, -S/C, B(1,1), 1, A(1,I), 1 ) CALL DSCAL( N, C, B(1,1), 1 ) CALL DAXPY( N, -S, A(1,I), 1, B(1,1), 1 ) 40 CONTINUE C END IF C END IF C DWORK(1) = MAX( MAXWRK, N ) C RETURN C C *** Last line of MB02CY *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01SX.f0000644000000000000000000000013015012430707016206 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MC01SX.f0000644000175000017500000000253215012430707017406 0ustar00lilgelilge00000000000000 INTEGER FUNCTION MC01SX( LB, UB, E, MANT ) C C PURPOSE C C To compute the variation V of the exponents of a series of C non-zero floating-point numbers: a(j) = MANT(j) * beta**(E(j)), C where beta is the base of the machine representation of C floating-point numbers, i.e., C V = max(E(j)) - min(E(j)), j = LB,...,UB and MANT(j) non-zero. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01GX by A.J. Geurts. C C REVISIONS C C - C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER LB, UB C .. Array Arguments .. INTEGER E(*) DOUBLE PRECISION MANT(*) C .. Local Scalars .. INTEGER J, MAXE, MINE C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C MAXE = E(LB) MINE = MAXE C DO 20 J = LB + 1, UB IF ( MANT(J).NE.ZERO ) THEN MAXE = MAX( MAXE, E(J) ) MINE = MIN( MINE, E(J) ) END IF 20 CONTINUE C MC01SX = MAXE - MINE C RETURN C *** Last line of MC01SX *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BR.f0000644000000000000000000000013015012430707016163 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/NF01BR.f0000644000175000017500000005640615012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BR( COND, UPLO, TRANS, N, IPAR, LIPAR, R, LDR, $ SDIAG, S, LDS, B, RANKS, TOL, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To solve one of the systems of linear equations C C R*x = b , or R'*x = b , C C in the least squares sense, where R is an n-by-n block upper C triangular matrix, with the structure C C / R_1 0 .. 0 | L_1 \ C | 0 R_2 .. 0 | L_2 | C | : : .. : | : | , C | 0 0 .. R_l | L_l | C \ 0 0 .. 0 | R_l+1 / C C with the upper triangular submatrices R_k, k = 1:l+1, square, and C the first l of the same order, BSN. The diagonal elements of each C block R_k have nonincreasing magnitude. The matrix R is stored in C the compressed form, as returned by SLICOT Library routine NF01BS, C C / R_1 | L_1 \ C | R_2 | L_2 | C Rc = | : | : | , C | R_l | L_l | C \ X | R_l+1 / C C where the submatrix X is irrelevant. If the matrix R does not have C full rank, then a least squares solution is obtained. If l <= 1, C then R is an upper triangular matrix and its full upper triangle C is stored. C C Optionally, the transpose of the matrix R can be stored in the C strict lower triangles of the submatrices R_k, k = 1:l+1, and in C the arrays SDIAG and S, as described at the parameter UPLO below. C C ARGUMENTS C C Mode Parameters C C COND CHARACTER*1 C Specifies whether the condition of submatrices R_k should C be estimated, as follows: C = 'E' : use incremental condition estimation and store C the numerical rank of R_k in the array entry C RANKS(k), for k = 1:l+1; C = 'N' : do not use condition estimation, but check the C diagonal entries of R_k for zero values; C = 'U' : use the ranks already stored in RANKS(1:l+1). C C UPLO CHARACTER*1 C Specifies the storage scheme for the matrix R, as follows: C = 'U' : the upper triangular part is stored as in Rc; C = 'L' : the lower triangular part is stored, namely, C - the transpose of the strict upper triangle of C R_k is stored in the strict lower triangle of C R_k, for k = 1:l+1; C - the diagonal elements of R_k, k = 1:l+1, are C stored in the array SDIAG; C - the transpose of the last block column in R C (without R_l+1) is stored in the array S. C C TRANS CHARACTER*1 C Specifies the form of the system of equations, as follows: C = 'N': R*x = b (No transpose); C = 'T': R'*x = b (Transpose); C = 'C': R'*x = b (Transpose). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix R. N = BN*BSN + ST >= 0. C (See parameter description below.) C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of the C matrix R, as follows: C IPAR(1) must contain ST, the number of columns of the C submatrices L_k and the order of R_l+1. ST >= 0. C IPAR(2) must contain BN, the number of blocks, l, in the C block diagonal part of R. BN >= 0. C IPAR(3) must contain BSM, the number of rows of the blocks C R_k, k = 1:l. BSM >= 0. C IPAR(4) must contain BSN, the number of columns of the C blocks R_k, k = 1:l. BSN >= 0. C BSM is not used by this routine, but assumed equal to BSN. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 4. C C R (input) DOUBLE PRECISION array, dimension (LDR, NC) C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. C If UPLO = 'U', the leading N-by-NC part of this array must C contain the (compressed) representation (Rc) of the upper C triangular matrix R. The submatrix X in Rc and the strict C lower triangular parts of the diagonal blocks R_k, C k = 1:l+1, are not referenced. If BN <= 1 or BSN = 0, then C the full upper triangle of R must be stored. C If UPLO = 'L', BN > 1 and BSN > 0, the leading C (N-ST)-by-BSN part of this array must contain the C transposes of the strict upper triangles of R_k, k = 1:l, C stored in the strict lower triangles of R_k, and the C strict lower triangle of R_l+1 must contain the transpose C of the strict upper triangle of R_l+1. The submatrix X C in Rc is not referenced. The diagonal elements of R_k, C and, if COND = 'E', the upper triangular parts of R_k, C k = 1:l+1, are modified internally, but are restored C on exit. C If UPLO = 'L' and BN <= 1 or BSN = 0, the leading N-by-N C strict lower triangular part of this array must contain C the transpose of the strict upper triangular part of R. C The diagonal elements and, if COND = 'E', the upper C triangular elements are modified internally, but are C restored on exit. C C LDR INTEGER C The leading dimension of the array R. LDR >= MAX(1,N). C C SDIAG (input) DOUBLE PRECISION array, dimension (N) C If UPLO = 'L', this array must contain the diagonal C entries of R_k, k = 1:l+1. This array is modified C internally, but is restored on exit. C This parameter is not referenced if UPLO = 'U'. C C S (input) DOUBLE PRECISION array, dimension (LDS,N-ST) C If UPLO = 'L', BN > 1, and BSN > 0, the leading C ST-by-(N-ST) part of this array must contain the transpose C of the rectangular part of the last block column in R, C that is [ L_1' L_2' ... L_l' ] . If COND = 'E', S is C modified internally, but is restored on exit. C This parameter is not referenced if UPLO = 'U', or C BN <= 1, or BSN = 0. C C LDS INTEGER C The leading dimension of the array S. C LDS >= 1, if UPLO = 'U', or BN <= 1, or BSN = 0; C LDS >= MAX(1,ST), if UPLO = 'L', BN > 1, and BSN > 0. C C B (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the right hand side C vector b. C On exit, this array contains the (least squares) solution C of the system R*x = b or R'*x = b. C C RANKS (input or output) INTEGER array, dimension (r), where C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; C r = BN, if ST = 0 and BSN > 0; C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); C r = 0, if ST = 0 and BSN = 0. C On entry, if COND = 'U' and N > 0, this array must contain C the numerical ranks of the submatrices R_k, k = 1:l(+1). C On exit, if COND = 'E' or 'N' and N > 0, this array C contains the numerical ranks of the submatrices R_k, C k = 1:l(+1), estimated according to the value of COND. C C Tolerances C C TOL DOUBLE PRECISION C If COND = 'E', the tolerance to be used for finding the C ranks of the submatrices R_k. If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C the reciprocal condition number; a (sub)matrix whose C estimated condition number is less than 1/TOL is C considered to be of full rank. If the user sets TOL <= 0, C then an implicitly computed, default tolerance, defined by C TOLDEF = N*EPS, is used instead, where EPS is the machine C precision (see LAPACK Library routine DLAMCH). C This parameter is not relevant if COND = 'U' or 'N'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C Denote Full = ( BN <= 1 or BSN = 0 ); C Comp = ( BN > 1 and BSN > 0 ). C LDWORK >= 2*N, if Full and COND = 'E'; C LDWORK >= 2*MAX(BSN,ST), if Comp and COND = 'E'; C LDWORK >= 0, in the remaining cases. 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 Block back or forward substitution is used (depending on TRANS C and UPLO), exploiting the special structure and storage scheme of C the matrix R. If a submatrix R_k, k = 1:l+1, is singular, a local C basic least squares solution is computed. Therefore, the returned C result is not the basic least squares solution for the whole C problem, but a concatenation of (least squares) solutions of the C individual subproblems involving R_k, k = 1:l+1 (with adapted C right hand sides). C C NUMERICAL ASPECTS C 2 2 C The algorithm requires 0(BN*BSN + ST + N*ST) operations and is C backward stable, if R is nonsingular. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. C C KEYWORDS C C Linear system of equations, matrix operations, plane rotations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, SVLMAX PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, SVLMAX = 0.0D0 ) C .. Scalar Arguments .. CHARACTER COND, TRANS, UPLO INTEGER INFO, LDR, LDS, LDWORK, LIPAR, N DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IPAR(*), RANKS(*) DOUBLE PRECISION B(*), DWORK(*), R(LDR,*), S(LDS,*), SDIAG(*) C .. Local Scalars .. DOUBLE PRECISION TOLDEF INTEGER BN, BSM, BSN, I, I1, J, K, L, NC, NTHS, RANK, ST CHARACTER TRANSL, UPLOL LOGICAL ECOND, FULL, LOWER, NCOND, TRANR C .. Local Arrays .. DOUBLE PRECISION DUM(3) C .. External Functions .. DOUBLE PRECISION DLAMCH LOGICAL LSAME EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DSWAP, DTRSV, MB03OD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C .. C .. Executable Statements .. C C Check the scalar input parameters. C ECOND = LSAME( COND, 'E' ) NCOND = LSAME( COND, 'N' ) LOWER = LSAME( UPLO, 'L' ) TRANR = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) C INFO = 0 IF( .NOT.( ECOND .OR. NCOND .OR. LSAME( COND, 'U' ) ) ) THEN INFO = -1 ELSEIF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -2 ELSEIF( .NOT.( TRANR .OR. LSAME( TRANS, 'N' ) ) ) THEN INFO = -3 ELSEIF( N.LT.0 ) THEN INFO = -4 ELSEIF( LIPAR.LT.4 ) THEN INFO = -6 ELSE ST = IPAR(1) BN = IPAR(2) BSM = IPAR(3) BSN = IPAR(4) NTHS = BN*BSN FULL = BN.LE.1 .OR. BSN.EQ.0 IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN INFO = -5 ELSEIF ( N.NE.NTHS + ST ) THEN INFO = -4 ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN INFO = -8 ELSEIF ( LDS.LT.1 .OR. ( LOWER .AND. .NOT.FULL .AND. $ LDS.LT.ST ) ) THEN INFO = -11 ELSE IF ( ECOND ) THEN IF ( FULL ) THEN L = 2*N ELSE L = 2*MAX( BSN, ST ) END IF ELSE L = 0 END IF IF ( LDWORK.LT.L ) $ INFO = -16 END IF END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01BR', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C IF ( ECOND ) THEN TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance in rank determination. C TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) END IF END IF C NC = BSN + ST IF ( FULL ) THEN C C Special case: l <= 1 or BSN = 0; R is just an upper triangular C matrix. C IF ( LOWER ) THEN C C Swap the diagonal elements of R and the elements of SDIAG C and, if COND = 'E', swap the upper and lower triangular C parts of R, in order to find the numerical rank. C CALL DSWAP( N, R, LDR+1, SDIAG, 1 ) IF ( ECOND ) THEN UPLOL = 'U' TRANSL = TRANS C DO 10 J = 1, N CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 ) 10 CONTINUE C ELSE UPLOL = UPLO IF ( TRANR ) THEN TRANSL = 'N' ELSE TRANSL = 'T' END IF END IF ELSE UPLOL = UPLO TRANSL = TRANS END IF C IF ( ECOND ) THEN C C Estimate the reciprocal condition number and set the rank. C Workspace: 2*N. C CALL MB03OD( 'No QR', N, N, R, LDR, IPAR, TOLDEF, SVLMAX, $ DWORK, RANK, DUM, DWORK, LDWORK, INFO ) RANKS(1) = RANK C ELSEIF ( NCOND ) THEN C C Determine rank(R) by checking zero diagonal entries. C RANK = N C DO 20 J = 1, N IF ( R(J,J).EQ.ZERO .AND. RANK.EQ.N ) $ RANK = J - 1 20 CONTINUE C RANKS(1) = RANK C ELSE C C Use the stored rank. C RANK = RANKS(1) END IF C C Solve R*x = b, or R'*x = b using back or forward substitution. C DUM(1) = ZERO IF ( RANK.LT.N ) $ CALL DCOPY( N-RANK, DUM, 0, B(RANK+1), 1 ) CALL DTRSV( UPLOL, TRANSL, 'NonUnit', RANK, R, LDR, B, 1 ) C IF ( LOWER ) THEN C C Swap the diagonal elements of R and the elements of SDIAG C and, if COND = 'E', swap back the upper and lower triangular C parts of R. C CALL DSWAP( N, R, LDR+1, SDIAG, 1 ) IF ( ECOND ) THEN C DO 30 J = 1, N CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 ) 30 CONTINUE C END IF C END IF RETURN END IF C C General case: l > 1 and BSN > 0. C I = 1 L = BN IF ( ECOND ) THEN C C Estimate the reciprocal condition numbers and set the ranks. C IF ( LOWER ) THEN C C Swap the diagonal elements of R and the elements of SDIAG C and swap the upper and lower triangular parts of R, in order C to find the numerical rank. Swap S and the transpose of the C rectangular part of the last block column of R. C DO 50 K = 1, BN CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 ) C DO 40 J = 1, BSN CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) I = I + 1 40 CONTINUE C 50 CONTINUE C IF ( ST.GT.0 ) THEN CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 ) C DO 60 J = BSN + 1, NC CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS ) CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) I = I + 1 60 CONTINUE C END IF C END IF C I1 = 1 C C Determine rank(R_k) using incremental condition estimation. C Workspace 2*MAX(BSN,ST). C DO 70 K = 1, BN CALL MB03OD( 'No QR', BSN, BSN, R(I1,1), LDR, IPAR, TOLDEF, $ SVLMAX, DWORK, RANKS(K), DUM, DWORK, LDWORK, $ INFO ) I1 = I1 + BSN 70 CONTINUE C IF ( ST.GT.0 ) THEN L = L + 1 CALL MB03OD( 'No QR', ST, ST, R(I1,BSN+1), LDR, IPAR, $ TOLDEF, SVLMAX, DWORK, RANKS(L), DUM, DWORK, $ LDWORK, INFO ) END IF C ELSEIF ( NCOND ) THEN C C Determine rank(R_k) by checking zero diagonal entries. C IF ( LOWER ) THEN C DO 90 K = 1, BN RANK = BSN C DO 80 J = 1, BSN IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.BSN ) $ RANK = J - 1 I = I + 1 80 CONTINUE C RANKS(K) = RANK 90 CONTINUE C IF ( ST.GT.0 ) THEN L = L + 1 RANK = ST C DO 100 J = 1, ST IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.ST ) $ RANK = J - 1 I = I + 1 100 CONTINUE C RANKS(L) = RANK END IF C ELSE C DO 120 K = 1, BN RANK = BSN C DO 110 J = 1, BSN IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.BSN ) $ RANK = J - 1 I = I + 1 110 CONTINUE C RANKS(K) = RANK 120 CONTINUE C IF ( ST.GT.0 ) THEN L = L + 1 RANK = ST C DO 130 J = BSN + 1, NC IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.ST ) $ RANK = J - BSN - 1 I = I + 1 130 CONTINUE C RANKS(L) = RANK END IF END IF C ELSE C C Set the number of elements of RANKS. Then use the stored ranks. C IF ( ST.GT.0 ) $ L = L + 1 END IF C C Solve the triangular system for x. If the system is singular, C then obtain a basic least squares solution. C DUM(1) = ZERO IF ( LOWER .AND. .NOT.ECOND ) THEN C IF ( .NOT.TRANR ) THEN C C Solve R*x = b using back substitution, with R' stored in C the arrays R, SDIAG and S. Swap diag(R) and SDIAG. C I1 = NTHS + 1 IF ( ST.GT.0 ) THEN RANK = RANKS(L) IF ( RANK.LT.ST ) $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK, $ R(I1,BSN+1), LDR, B(I1), 1 ) CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) CALL DGEMV( 'Transpose', ST, NTHS, -ONE, S, LDS, $ B(NTHS+1), 1, ONE, B, 1 ) END IF C DO 140 K = BN, 1, -1 I1 = I1 - BSN RANK = RANKS(K) IF ( RANK.LT.BSN ) $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK, $ R(I1,1), LDR, B(I1), 1 ) CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) 140 CONTINUE C ELSE C C Solve R'*x = b using forward substitution, with R' stored in C the arrays R, SDIAG and S. Swap diag(R) and SDIAG. C I1 = 1 IF ( TRANR ) THEN TRANSL = 'N' ELSE TRANSL = 'T' END IF C DO 150 K = 1, BN RANK = RANKS(K) IF ( RANK.LT.BSN ) $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK, R(I1,1), $ LDR, B(I1), 1 ) CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) I1 = I1 + BSN 150 CONTINUE C IF ( ST.GT.0 ) THEN RANK = RANKS(L) IF ( RANK.LT.ST ) $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) CALL DGEMV( 'NoTranspose', ST, NTHS, -ONE, S, LDS, B, 1, $ ONE, B(I1), 1 ) CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK, $ R(I1,BSN+1), LDR, B(I1), 1 ) CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) END IF C END IF C ELSE C IF ( .NOT.TRANR ) THEN C C Solve R*x = b using back substitution. C I1 = NTHS + 1 IF ( ST.GT.0 ) THEN RANK = RANKS(L) IF ( RANK.LT.ST ) $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1), $ LDR, B(I1), 1 ) CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR, $ B(NTHS+1), 1, ONE, B, 1 ) END IF C DO 160 K = BN, 1, -1 I1 = I1 - BSN RANK = RANKS(K) IF ( RANK.LT.BSN ) $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1), $ LDR, B(I1), 1 ) 160 CONTINUE C ELSE C C Solve R'*x = b using forward substitution. C I1 = 1 C DO 170 K = 1, BN RANK = RANKS(K) IF ( RANK.LT.BSN ) $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1), $ LDR, B(I1), 1 ) I1 = I1 + BSN 170 CONTINUE C IF ( ST.GT.0 ) THEN RANK = RANKS(L) IF ( RANK.LT.ST ) $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR, B, 1, $ ONE, B(I1), 1 ) CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1), $ LDR, B(I1), 1 ) END IF C END IF END IF C IF ( ECOND .AND. LOWER ) THEN I = 1 C C If COND = 'E' and UPLO = 'L', swap the diagonal elements of R C and the elements of SDIAG and swap back the upper and lower C triangular parts of R, including the part corresponding to S. C DO 190 K = 1, BN CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 ) C DO 180 J = 1, BSN CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) I = I + 1 180 CONTINUE C 190 CONTINUE C IF ( ST.GT.0 ) THEN CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 ) C DO 200 J = BSN + 1, NC CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS ) CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) I = I + 1 200 CONTINUE C END IF C END IF C RETURN C C *** Last line of NF01BR *** END control-4.1.2/src/slicot/src/PaxHeaders/BB03AD.f0000644000000000000000000000013215012430707016130 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/BB03AD.f0000644000175000017500000004117315012430707017332 0ustar00lilgelilge00000000000000 SUBROUTINE BB03AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, 1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, 2 LDWORK, INFO) C C PURPOSE C C To generate benchmark examples of (generalized) continuous-time C Lyapunov equations C C T T C A X E + E X A = Y . C C In some examples, the right hand side has the form C C T C Y = - B B C C and the solution can be represented as a product of Cholesky C factors C C T C X = U U . C C E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note C that E can be the identity matrix. For some examples, B, X, or U C are not provided. C C This routine is an implementation of the benchmark library C CTLEX (Version 1.0) described in [1]. C C ARGUMENTS C C Mode Parameters C C DEF CHARACTER*1 C Specifies the kind of values used as parameters when C generating parameter-dependent and scalable examples C (i.e., examples with NR(1) = 2, 3, or 4): C DEF = 'D' or 'd': Default values are used. C DEF = 'N' or 'n': Values set in DPAR and IPAR are used. C This parameter is not referenced if NR(1) = 1. C Note that the scaling parameter of examples with C NR(1) = 3 or 4 is considered as a regular parameter in C this context. C C Input/Output Parameters C C NR (input) INTEGER array, dimension 2 C Specifies the index of the desired example according C to [1]. C NR(1) defines the group: C 1 : parameter-free problems of fixed size C 2 : parameter-dependent problems of fixed size C 3 : parameter-free problems of scalable size C 4 : parameter-dependent problems of scalable size C NR(2) defines the number of the benchmark example C within a certain group according to [1]. C C DPAR (input/output) DOUBLE PRECISION array, dimension 2 C On entry, if DEF = 'N' or 'n' and the desired example C depends on real parameters, then the array DPAR must C contain the values for these parameters. C For an explanation of the parameters see [1]. C For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's', C respectively. C For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and C 's', respectively. C For Examples 4.3 and 4.4, DPAR(1) defines the parameter C 't'. C On exit, if DEF = 'D' or 'd' and the desired example C depends on real parameters, then the array DPAR is C overwritten by the default values given in [1]. C C IPAR (input/output) INTEGER array of DIMENSION at least 1 C On entry, if DEF = 'N' or 'n' and the desired example C depends on integer parameters, then the array IPAR must C contain the values for these parameters. C For an explanation of the parameters see [1]. C For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'. C For Example 4.4, IPAR(1) defines 'q'. C On exit, if DEF = 'D' or 'd' and the desired example C depends on integer parameters, then the array IPAR is C overwritten by the default values given in [1]. C C VEC (output) LOGICAL array, dimension 8 C Flag vector which displays the availability of the output C data: C VEC(1) and VEC(2) refer to N and M, respectively, and are C always .TRUE. C VEC(3) is .TRUE. iff E is NOT the identity matrix. C VEC(4) and VEC(5) refer to A and Y, respectively, and are C always .TRUE. C VEC(6) is .TRUE. iff B is provided. C VEC(7) is .TRUE. iff the solution matrix X is provided. C VEC(8) is .TRUE. iff the Cholesky factor U is provided. C C N (output) INTEGER C The actual state dimension, i.e., the order of the C matrices E and A. C C M (output) INTEGER C The number of rows in the matrix B. If B is not provided C for the desired example, M = 0 is returned. C C E (output) DOUBLE PRECISION array, dimension (LDE,N) C The leading N-by-N part of this array contains the C matrix E. C NOTE that this array is overwritten (by the identity C matrix), if VEC(3) = .FALSE. C C LDE INTEGER C The leading dimension of array E. LDE >= N. C C A (output) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array contains the C matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= N. C C Y (output) DOUBLE PRECISION array, dimension (LDY,N) C The leading N-by-N part of this array contains the C matrix Y. C C LDY INTEGER C The leading dimension of array Y. LDY >= N. C C B (output) DOUBLE PRECISION array, dimension (LDB,N) C The leading M-by-N part of this array contains the C matrix B. C C LDB INTEGER C The leading dimension of array B. LDB >= M. C C X (output) DOUBLE PRECISION array, dimension (LDX,N) C The leading N-by-N part of this array contains the C matrix X. C C LDX INTEGER C The leading dimension of array X. LDX >= N. C C U (output) DOUBLE PRECISION array, dimension (LDU,N) C The leading N-by-N part of this array contains the C matrix U. C C LDU INTEGER C The leading dimension of array U. LDU >= N. C C NOTE (output) CHARACTER*70 C String containing short information about the chosen C example. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is C required. C For the other examples, no workspace is needed, i.e., C LDWORK >= 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; in particular, INFO = -3 or -4 indicates C that at least one of the parameters in DPAR or C IPAR, respectively, has an illegal value. C C REFERENCES C C [1] D. Kressner, V. Mehrmann, and T. Penzl. C CTLEX - a Collection of Benchmark Examples for Continuous- C Time Lyapunov Equations. C SLICOT Working Note 1999-6, 1999. C C NUMERICAL ASPECTS C C None C C CONTRIBUTOR C C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) C C For questions concerning the collection or for the submission of C test examples, please contact Volker Mehrmann C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). C C REVISIONS C C June 1999, V. Sima. C C KEYWORDS C C continuous-time Lyapunov equations C C ******************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, FOUR PARAMETER (ZERO = .0D0, ONE = .1D1, TWO = .2D1, 1 FOUR = .4D1) C .. Scalar Arguments .. CHARACTER DEF CHARACTER*70 NOTE INTEGER INFO, LDA, LDB, LDE, LDU, LDWORK, LDX, LDY, M, N C .. Array Arguments .. LOGICAL VEC(8) INTEGER IPAR(*), NR(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), DPAR(*), DWORK(LDWORK), 1 E(LDE,*), U(LDU,*), X(LDX,*), Y(LDY,*) C .. Local Scalars .. INTEGER I, J, K DOUBLE PRECISION TEMP, TTM1, TTP1, TWOBYN C .. Local Arrays .. LOGICAL VECDEF(8) C .. External Functions .. C . BLAS . DOUBLE PRECISION DDOT EXTERNAL DDOT C . LAPACK . LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. C . BLAS . EXTERNAL DGEMV, DGER, DAXPY C . LAPACK . EXTERNAL DLASET C .. Intrinsic Functions .. INTRINSIC DBLE, MIN, MOD C .. Data Statements .. C . default values for availabilities . DATA VECDEF /.TRUE., .TRUE., .FALSE., .TRUE., 1 .TRUE., .FALSE., .FALSE., .FALSE./ C C .. Executable Statements .. C INFO = 0 DO 10 I = 1, 8 VEC(I) = VECDEF(I) 10 CONTINUE C IF (NR(1) .EQ. 4) THEN IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN INFO = -1 RETURN END IF C IF (NR(2) .EQ. 1) THEN NOTE = 'CTLEX: Example 4.1' IF (LSAME(DEF,'D')) THEN IPAR(1) = 10 DPAR(1) = .15D1 DPAR(2) = .15D1 END IF IF ((DPAR(1) .LE. ONE) .OR. (DPAR(2) .LE. ONE)) INFO = -3 IF (IPAR(1) .LT. 2) INFO = -4 N = IPAR(1) M = 1 IF (LDE .LT. N) INFO = -9 IF (LDA .LT. N) INFO = -11 IF (LDY .LT. N) INFO = -13 IF (LDB .LT. M) INFO = -15 IF (LDX .LT. N) INFO = -17 IF (LDWORK .LT. N*2) INFO = -22 IF (INFO .NE. 0) RETURN C VEC(6) = .TRUE. VEC(7) = .TRUE. TWOBYN = TWO / DBLE( N ) CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) CALL DLASET('A', M, N, ZERO, ZERO, B, LDB) CALL DLASET('A', N, N, ZERO, ZERO, X, LDX) DO 30 J = 1, N TEMP = DPAR(1) ** (J-1) A(J,J) = -TEMP DWORK(J) = ONE DO 20 I = 1, N X(I,J) = DBLE( I*J ) / (TEMP + DPAR(1)**(I-1)) 20 CONTINUE 30 CONTINUE C H1 * A CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) C A * H1 CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) C H1 * X CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX) C X * H1 CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX) C S A INV(S), INV(S) X INV(S), B INV(S) DO 50 J = 1, N B(1,J) = DBLE( J-N-1 ) / (DPAR(2)**(J-1)) DO 40 I = 1, N X(I,J) = X(I,J) / (DPAR(2)**(I+J-2)) A(I,J) = A(I,J) * (DPAR(2)**(I-J)) 40 CONTINUE DWORK(J) = ONE - TWO * MOD(J,2) 50 CONTINUE C H2 * A CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) C A * H2 CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) C H2 * X CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX) C X * H2 CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX) C B * H2 CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, 1 B, LDB) C Y = -B' * B CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) C ELSE IF (NR(2) .EQ. 2) THEN NOTE = 'CTLEX: Example 4.2' IF (LSAME(DEF,'D')) THEN IPAR(1) = 10 DPAR(1) = -.5D0 DPAR(2) = .15D1 END IF IF ((DPAR(1) .GE. ZERO) .OR. (DPAR(2) .LE. ONE)) INFO = -3 IF (IPAR(1) .LT. 2) INFO = -4 N = IPAR(1) M = 1 IF (LDE .LT. N) INFO = -9 IF (LDA .LT. N) INFO = -11 IF (LDY .LT. N) INFO = -13 IF (LDB .LT. M) INFO = -15 IF (LDWORK .LT. N*2) INFO = -22 IF (INFO .NE. 0) RETURN C VEC(6) = .TRUE. TWOBYN = TWO / DBLE( N ) CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) DO 60 I = 1, N-1 DWORK(I) = ONE A(I,I+1) = ONE 60 CONTINUE DWORK(N) = ONE C H1 * A CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) C A * H1 CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) C S A INV(S), B INV(S) DO 80 J = 1, N B(1,J) = B(1,J) / (DPAR(2)**(J-1)) DO 70 I = 1, N A(I,J) = A(I,J) * (DPAR(2)**(I-J)) 70 CONTINUE DWORK(J) = ONE - TWO * MOD(J,2) 80 CONTINUE C H2 * A CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) C A * H2 CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) C B * H2 CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, 1 B, LDB) C Y = -B' * B CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) C ELSE IF (NR(2) .EQ. 3) THEN NOTE = 'CTLEX: Example 4.3' IF (LSAME(DEF,'D')) THEN IPAR(1) = 10 DPAR(1) = .1D2 END IF IF (DPAR(1) .LT. ZERO) INFO = -3 IF (IPAR(1) .LT. 2) INFO = -4 N = IPAR(1) M = 0 IF (LDE .LT. N) INFO = -9 IF (LDA .LT. N) INFO = -11 IF (LDY .LT. N) INFO = -13 IF (LDX .LT. N) INFO = -17 IF (INFO .NE. 0) RETURN C VEC(3) = .TRUE. VEC(7) = .TRUE. TEMP = TWO ** (-DPAR(1)) CALL DLASET('U', N, N, ZERO, ZERO, E, LDE) CALL DLASET('L', N, N, TEMP, ONE, E, LDE) CALL DLASET('L', N, N, ZERO, ZERO, A, LDA) CALL DLASET('U', N, N, ONE, ZERO, A, LDA) CALL DLASET('A', N, N, ONE, ONE, X, LDX) DO 90 I = 1, N A(I,I) = DBLE( I - 1 ) + TEMP 90 CONTINUE Y(1,1) = TWO * TEMP + TWO * DBLE( N-1 ) * TEMP**2 TTP1 = TWO * DBLE( N+1 ) * TEMP + TWO - TEMP**2 TTM1 = TWO * DBLE( N-1 ) * TEMP + TWO - TEMP**2 DO 100 I = 2, N Y(I,1) = Y(1,1) + DBLE( I-1 ) * TTM1 100 CONTINUE DO 120 J = 2, N DO 110 I = 1, N Y(I,J) = Y(I,1) + DBLE( J-1 ) * (TTP1 - FOUR * I * TEMP) 110 CONTINUE 120 CONTINUE C ELSE IF (NR(2) .EQ. 4) THEN NOTE = 'CTLEX: Example 4.4' IF (LSAME(DEF,'D')) THEN IPAR(1) = 10 DPAR(1) = .15D1 END IF IF (DPAR(1) .LT. ONE) INFO = -3 IF (IPAR(1) .LT. 1) INFO = -4 N = IPAR(1) * 3 M = 1 IF (LDE .LT. N) INFO = -9 IF (LDA .LT. N) INFO = -11 IF (LDY .LT. N) INFO = -13 IF (LDB .LT. M) INFO = -15 IF (INFO .NE. 0) RETURN C VEC(3) = .TRUE. VEC(6) = .TRUE. CALL DLASET('A', N, N, ZERO, ZERO, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) DO 150 I = 1, IPAR(1) TEMP = -DPAR(1)**I DO 140 J = 1, I - 1 DO 130 K = 0, 2 A(N - I*3+3, J*3-K) = TEMP A(N - I*3+2, J*3-K) = TWO * TEMP 130 CONTINUE 140 CONTINUE A(N - I*3+3, I*3-2) = TEMP A(N - I*3+2, I*3-2) = TWO * TEMP A(N - I*3+2, I*3-1) = TWO * TEMP A(N - I*3+2, I*3 ) = TEMP A(N - I*3+1, I*3 ) = TEMP 150 CONTINUE DO 170 J = 1, N IF (J .GT. 1) CALL DAXPY(N, ONE, A(J-1,1), LDA, A(J,1), LDA) B(1, J) = DBLE( J ) DO 160 I = 1, N E(I,N-J+1) = DBLE( MIN( I, J ) ) Y(I,J) = -DBLE( I*J ) 160 CONTINUE 170 CONTINUE C ELSE INFO = -2 END IF ELSE INFO = -2 END IF C RETURN C *** Last Line of BB03AD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB08NX.f0000644000000000000000000000013215012430707016175 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB08NX.f0000644000175000017500000003551615012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE AB08NX( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD, $ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, $ DWORK, LDWORK, INFO ) 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, Apr. 2011. 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, NP, RANK, RO1, TAU, WRKOPT DOUBLE PRECISION T C .. Local Arrays .. DOUBLE PRECISION SVAL(3) 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 CALL DORMQR( 'Left', 'Transpose', P, N, MPM, ABCD, $ LDABCD, DWORK, ABCD, LDABCD, DWORK, -1, $ INFO ) WRKOPT = MAX( JWORK, MPM + INT( DWORK(1) ) ) ELSE WRKOPT = JWORK END IF CALL DORMRQ( 'Right', 'Transpose', NP, N, MIN( P, N ), ABCD, $ LDABCD, DWORK, ABCD, LDABCD, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, MIN( P, N ) + INT( DWORK(1) ) ) CALL DORMRQ( 'Left', 'NoTranspose', N, M+N, MIN( P, N ), $ ABCD, LDABCD, DWORK, ABCD, LDABCD, DWORK, -1, $ INFO ) WRKOPT = MAX( WRKOPT, MIN( P, N ) + INT( DWORK(1) ) ) 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 control-4.1.2/src/slicot/src/PaxHeaders/MB03QG.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03QG.f0000644000175000017500000003753715012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE MB03QG( DICO, STDOM, JOBU, JOBV, N, NLOW, NSUP, ALPHA, $ A, LDA, E, LDE, U, LDU, V, LDV, NDIM, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To reorder the diagonal blocks of a principal subpencil of an C upper quasi-triangular matrix pencil A-lambda*E together with C their generalized eigenvalues, by constructing orthogonal C similarity transformations UT and VT. C After reordering, the leading block of the selected subpencil of C A-lambda*E has generalized eigenvalues in a suitably defined C domain of interest, usually related to stability/instability in a C continuous- or discrete-time 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 JOBV CHARACTER*1 C Indicates how the performed orthogonal transformations VT C are accumulated, as follows: C = 'I': V is initialized to the unit matrix and the matrix C VT is returned in V; C = 'U': the given matrix V is updated and the matrix V*VT C is returned in V. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, E, U, and V. N >= 0. C C NLOW, (input) INTEGER C NSUP (input) INTEGER C NLOW and NSUP specify the boundary indices for the rows C and columns of the principal subpencil of A - lambda*E C whose diagonal blocks are to be reordered. C 0 <= 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 the generalized eigenvalues, while for C DICO = 'D', ALPHA >= 0 represents the boundary value for C the moduli of the generalized 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 of this array contains C a real Schur matrix UT' * A * VT, with the elements below C the first subdiagonal set to zero. C The leading NDIM-by-NDIM part of the principal subpencil C B - lambda*C, defined with B := A(NLOW:NSUP,NLOW:NSUP), C C := E(NLOW:NSUP,NLOW:NSUP), has generalized eigenvalues C in the domain of interest and the trailing part of this C subpencil has generalized eigenvalues outside the domain C of interest. C The domain of interest for eig(B,C), the generalized C eigenvalues of the pair (B,C), is defined by the C parameters ALPHA, DICO and STDOM as follows: C For DICO = 'C': C Real(eig(B,C)) < ALPHA if STDOM = 'S'; C Real(eig(B,C)) > ALPHA if STDOM = 'U'. C For DICO = 'D': C Abs(eig(B,C)) < ALPHA if STDOM = 'S'; C Abs(eig(B,C)) > ALPHA if STDOM = 'U'. 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, the leading N-by-N part of this array must C contain a matrix in an upper triangular form. C On exit, the leading N-by-N part of this array contains an C upper triangular matrix UT' * E * VT, with the elements C below the diagonal set to zero. C The leading NDIM-by-NDIM part of the principal subpencil C B - lambda*C, defined with B := A(NLOW:NSUP,NLOW:NSUP) C C := E(NLOW:NSUP,NLOW:NSUP) has generalized eigenvalues C in the domain of interest and the trailing part of this C subpencil has generalized eigenvalues outside the domain C of interest (see description of A). C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,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 - lambda*E. 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 the array U. LDU >= MAX(1,N). C C V (input/output) DOUBLE PRECISION array, dimension (LDV,N) C On entry with JOBV = '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 JOBV = 'U', the leading N-by-N part of this C array contains the product of the input matrix V and the C orthogonal matrix VT used to reorder the diagonal blocks C of A - lambda*E. C On exit, if JOBV = 'I', the leading N-by-N part of this C array contains the matrix VT of the performed orthogonal C transformations. C Array V need not be set on entry if JOBV = 'I'. C C LDV INTEGER C The leading dimension of the array V. LDV >= MAX(1,N). C C NDIM (output) INTEGER C The number of generalized eigenvalues of the selected C principal subpencil lying inside the domain of interest. C If NLOW = 1, NDIM is also the dimension of the deflating C subspace corresponding to the generalized eigenvalues of C the leading NDIM-by-NDIM subpencil. In this case, if U and C V are the orthogonal transformation matrices used to C compute and reorder the generalized real Schur form of the C pair (A,E), then the first NDIM columns of V form an C orthonormal basis for the above deflating subspace. 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 length of the array DWORK. LDWORK >= 1, and if N > 1, C LDWORK >= 4*N + 16. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 = 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 pencil A - lambda*E with C 1-by-1 or 2-by-2 diagonal blocks, the routine reorders its C diagonal blocks along with its eigenvalues by performing an C orthogonal equivalence transformation UT'*(A - lambda*E)* VT. C The column transformations UT and VT are also performed on the C given (initial) transformations U and V (resulted from a C possible previous step or initialized as identity matrices). C After reordering, the generalized eigenvalues inside the region C specified by the parameters ALPHA, DICO and STDOM appear at the C top of the selected diagonal subpencil between positions NLOW and C NSUP. In other words, lambda(A(Select,Select),E(Select,Select)) C are ordered such that lambda(A(Inside,Inside),E(Inside,Inside)) C are inside, and lambda(A(Outside,Outside),E(Outside,Outside)) are C outside the domain of interest, where Select = NLOW:NSUP, C Inside = NLOW:NLOW+NDIM-1, and Outside = NLOW+NDIM:NSUP. C If NLOW = 1, the first NDIM columns of V*VT span the corresponding C right deflating subspace of (A,E). 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 October 2002. Based on the RASP/BIMASC routine GSEOR1. C C REVISIONS C C V. Sima, Dec. 2016. C C KEYWORDS C C Eigenvalues, invariant subspace, orthogonal transformation, real C Schur form, equivalence transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOBU, JOBV, STDOM INTEGER INFO, LDA, LDE, LDU, LDV, LDWORK, N, NDIM, NLOW, $ NSUP DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), E(LDE,*), U(LDU,*), V(LDV,*) C .. Local Scalars .. LOGICAL DISCR, LQUERY, LSTDOM INTEGER IB, L, LM1, MINWRK, NUP DOUBLE PRECISION ALPHAI(2), ALPHAR(2), BETA(2) DOUBLE PRECISION TLAMBD, TOLE, X C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANTR, DLAPY2 EXTERNAL DLAMCH, DLANTR, DLAPY2, LSAME C .. External Subroutines .. EXTERNAL DLASET, DTGEXC, MB03QW, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX 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( .NOT. ( LSAME( JOBV, 'I' ) .OR. $ LSAME( JOBV, 'U' ) ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( NLOW.LT.0 ) THEN INFO = -6 ELSE IF( NSUP.LT.NLOW .OR. N.LT.NSUP ) THEN INFO = -7 ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN INFO = -8 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDU.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE LQUERY = LDWORK.EQ.-1 IF( N.LE.1 ) THEN MINWRK = 1 ELSE MINWRK = 4*N + 16 END IF IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -19 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB03QG', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = MINWRK RETURN END IF C C Quick return if possible. C NDIM = 0 IF( NSUP.EQ.0 ) $ RETURN 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 C Initialize V with an identity matrix if necessary. C IF( LSAME( JOBV, 'I' ) ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, V, LDV ) C C Compute zero tolerance for the diagonal elements of matrix E. C TOLE = DLAMCH( 'Epsilon' ) * $ DLANTR( '1', 'Upper', 'Non-unit', N, N, E, LDE, DWORK ) C L = NSUP NUP = NSUP C C NUP is the minimal value such that the subpencil C A(i,j)-lambda*E(i,j), with NUP+1 <= i,j <= NSUP contains no C generalized eigenvalues inside the domain of interest. C L is such that all generalized eigenvalues of the subpencil C A(i,j)-lambda*E(i,j) with L <= i,j <= NUP lie inside the C domain of interest. C C WHILE( L >= NLOW ) DO C 10 CONTINUE IF( L.GE.NLOW ) THEN IB = 1 IF( L.GT.NLOW ) THEN LM1 = L - 1 IF( A(L,LM1).NE.ZERO ) THEN CALL MB03QW( N, LM1, A, LDA, E, LDE, U, LDU, V, LDV, $ ALPHAR, ALPHAI, BETA, 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) ) X = ABS( E(L,L) ) ELSE TLAMBD = DLAPY2( ALPHAR(1), ALPHAI(1) ) X = ABS( BETA(1) ) END IF ELSE IF( IB.EQ.1 ) THEN X = E(L,L) IF( X.LT.ZERO ) THEN TLAMBD = -A(L,L) X = -X ELSE TLAMBD = A(L,L) END IF ELSE TLAMBD = ALPHAR(1) X = BETA(1) IF( X.LT.ZERO ) THEN TLAMBD = -TLAMBD X = -X END IF END IF END IF IF(( LSTDOM .AND. TLAMBD.LT.ALPHA*X .AND. X.GT.TOLE ) .OR. $ ( .NOT.LSTDOM .AND. TLAMBD.GT.ALPHA*X ) ) $ THEN NDIM = NDIM + IB L = L - IB ELSE IF( NDIM.NE.0 ) THEN CALL DTGEXC( .TRUE., .TRUE., N, A, LDA, E, LDE, U, LDU, $ V, LDV, L, NUP, DWORK, LDWORK, 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 DWORK(1) = MINWRK RETURN C *** Last line of MB03QG *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03OY.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03OY.f0000644000175000017500000003155015012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, $ TAU, DWORK, INFO ) 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 FURTHER COMMENTS C C For a matrix with a small norm, the rank is set to zero if the C largest column Euclidean norm is smaller than or equal to RCOND. 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 V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. C V. Sima, Apr. 2017, Mar. 2019. 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 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 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, TOLZ C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL DLAMCH, 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 TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) 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 the matrix is negligible (RANK = 0). C SMAX = ABS( A( 1, 1 ) ) IF ( SMAX.LE.RCOND ) THEN SVAL( 1 ) = ZERO SVAL( 2 ) = ZERO SVAL( 3 ) = ZERO 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.LT.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 = ABS( A( I, J ) ) / DWORK( J ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO) TEMP2 = TEMP*( DWORK( J ) / DWORK( N+J ) )**2 IF( TEMP2.LE.TOLZ ) 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 control-4.1.2/src/slicot/src/PaxHeaders/MB02NY.f0000644000000000000000000000013215012430707016204 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02NY.f0000644000175000017500000002044015012430707017400 0ustar00lilgelilge00000000000000 SUBROUTINE MB02NY( UPDATU, UPDATV, M, N, I, K, Q, E, U, LDU, V, $ LDV, DWORK ) C C PURPOSE C C To separate a zero singular value of a bidiagonal submatrix of C order k, k <= p, of the bidiagonal matrix C C |Q(1) E(1) 0 ... 0 | C | 0 Q(2) E(2) . | C J = | . . | C | . E(p-1)| C | 0 ... ... ... Q(p) | C C with p = MIN(M,N), by annihilating one or two superdiagonal C elements E(i-1) (if i > 1) and/or E(i) (if i < k). C C ARGUMENTS C C Mode Parameters C C UPDATU LOGICAL C Indicates whether the user wishes to accumulate in a C matrix U the left-hand Givens rotations S, as follows: C = .FALSE.: Do not form U; C = .TRUE. : The given matrix U is updated (postmultiplied) C by the left-hand Givens rotations S. C C UPDATV LOGICAL C Indicates whether the user wishes to accumulate in a C matrix V the right-hand Givens rotations T, as follows: C = .FALSE.: Do not form V; C = .TRUE. : The given matrix V is updated (postmultiplied) C by the right-hand Givens rotations T. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrix U. M >= 0. C C N (input) INTEGER C The number of rows of the matrix V. N >= 0. C C I (input) INTEGER C The index of the negligible diagonal entry Q(I) of the C bidiagonal matrix J, I <= p. C C K (input) INTEGER C The index of the last diagonal entry of the considered C bidiagonal submatrix of J, i.e., E(K-1) is considered C negligible, K <= p. C C Q (input/output) DOUBLE PRECISION array, dimension (p) C where p = MIN(M,N). C On entry, Q must contain the diagonal entries of the C bidiagonal matrix J. C On exit, Q contains the diagonal entries of the C transformed bidiagonal matrix S' J T. C C E (input/output) DOUBLE PRECISION array, dimension (p-1) C On entry, E must contain the superdiagonal entries of J. C On exit, E contains the superdiagonal entries of the C transformed bidiagonal matrix S' J T. C C U (input/output) DOUBLE PRECISION array, dimension (LDU,p) C On entry, if UPDATU = .TRUE., U must contain the M-by-p C left transformation matrix. C On exit, if UPDATU = .TRUE., the Givens rotations S on the C left, annihilating E(i) if i < k, have been postmultiplied C into U. C U is not referenced if UPDATU = .FALSE.. C C LDU INTEGER C The leading dimension of the array U. C LDU >= max(1,M) if UPDATU = .TRUE.; C LDU >= 1 if UPDATU = .FALSE.. C C V (input/output) DOUBLE PRECISION array, dimension (LDV,p) C On entry, if UPDATV = .TRUE., V must contain the N-by-p C right transformation matrix. C On exit, if UPDATV = .TRUE., the Givens rotations T on the C right, annihilating E(i-1) if i > 1, have been C postmultiplied into V. C V is not referenced if UPDATV = .FALSE.. C C LDV INTEGER C The leading dimension of the array V. C LDV >= max(1,N) if UPDATV = .TRUE.; C LDV >= 1 if UPDATV = .FALSE.. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)) C LDWORK >= 2*MAX(K-I,I-1), if UPDATV = UPDATU = .TRUE.; C LDWORK >= 2*(K-I), if UPDATU = .TRUE., UPDATV = .FALSE.; C LDWORK >= 2*(I-1), if UPDATV = .TRUE., UPDATU = .FALSE.; C LDWORK >= 1, if UPDATU = UPDATV = .FALSE.. C C METHOD C C Let the considered bidiagonal submatrix be C C |Q(1) E(1) 0 ... 0 | C | 0 Q(2) E(2) . | C | . . | C | . Q(i-1) E(i-1) . | C Jk = | . Q(i) E(i) . |. C | . Q(i+1) . . | C | . .. . | C | . E(k-1)| C | 0 ... ... Q(k) | C C A zero singular value of Jk manifests itself by a zero diagonal C entry Q(i) or in practice, a negligible value of Q(i). C When a negligible diagonal element Q(i) in Jk is present, the C bidiagonal submatrix Jk is split by the routine into 2 or 3 C unreduced bidiagonal submatrices by annihilating E(i) (if i < k) C using Givens rotations S on the left and by annihilating E(i-1) C (if i > 1) using Givens rotations T on the right until Jk is C reduced to the form: C C |Q(1) E(1) 0 ... 0 | C | 0 . ... . | C | . ... . | C | . Q(i-1) 0 . | C S' Jk T = | . 0 0 . |. C | . Q(i+1) . . | C | . .. . | C | . E(k-1)| C | 0 ... ... Q(k) | C C For more details, see [1, pp.11.12-11.14]. C C REFERENCES C C [1] Dongarra, J.J., Bunch, J.R., Moler C.B. and Stewart, G.W. C LINPACK User's Guide. C SIAM, Philadelphia, 1979. 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, June 1997. C Supersedes Release 2.0 routine MB02BZ by S. Van Huffel, Katholieke C University, Leuven, Belgium. C C REVISIONS C C - C C KEYWORDS C C Bidiagonal matrix, orthogonal transformation, singular values. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. LOGICAL UPDATU, UPDATV INTEGER I, K, LDU, LDV, M, N C .. Array Arguments .. DOUBLE PRECISION DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*) C .. Local Scalars .. INTEGER I1, IROT, L, L1, NROT DOUBLE PRECISION C, F, G, R, S C .. External Subroutines .. EXTERNAL DLARTG, DLASR C .. Intrinsic Functions .. INTRINSIC MIN C .. Executable Statements .. C C For speed, no tests of the input scalar arguments are done. C C Quick return if possible. C IF ( M.LE.0 .OR. N.LE.0 ) $ RETURN C IF ( I.LE.MIN( M, N ) ) Q(I) = ZERO C C Annihilate E(I) (if I < K). C IF ( I.LT.K ) THEN C = ZERO S = ONE IROT = 0 NROT = K - I C DO 20 L = I, K-1 G = E(L) E(L) = C*G CALL DLARTG( Q(L+1), S*G, C, S, R ) Q(L+1) = R IF ( UPDATU ) THEN IROT = IROT + 1 DWORK(IROT) = C DWORK(IROT+NROT) = S END IF 20 CONTINUE C IF ( UPDATU ) $ CALL DLASR( 'Right', 'Top', 'Forward', M, NROT+1, DWORK(1), $ DWORK(NROT+1), U(1,I), LDU ) END IF C C Annihilate E(I-1) (if I > 1). C IF ( I.GT.1 ) THEN I1 = I - 1 F = E(I1) E(I1) = ZERO C DO 40 L1 = 1, I1 - 1 L = I - L1 CALL DLARTG( Q(L), F, C, S, R ) Q(L) = R IF ( UPDATV ) THEN DWORK(L) = C DWORK(L+I1) = S END IF G = E(L-1) F = -S*G E(L-1) = C*G 40 CONTINUE C CALL DLARTG( Q(1), F, C, S, R ) Q(1) = R IF ( UPDATV ) THEN DWORK(1) = C DWORK(I) = S CALL DLASR( 'Right', 'Bottom', 'Backward', N, I, DWORK(1), $ DWORK(I), V(1,1), LDV ) END IF END IF C RETURN C *** Last line of MB02NY *** END control-4.1.2/src/slicot/src/PaxHeaders/UD01ND.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/UD01ND.f0000644000175000017500000001233215012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, TEXT, $ INFO ) C C PURPOSE C C To print the MP-by-NP coefficient matrices of a matrix polynomial C dp-1 dp C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . C C The elements of the matrices are output to 7 significant figures. C C ARGUMENTS C C Input/Output Parameters C C MP (input) INTEGER C The number of rows of the matrix polynomial P(s). C MP >= 1. C C NP (input) INTEGER C The number of columns of the matrix polynomial P(s). C NP >= 1. C C DP (input) INTEGER C The degree of the matrix polynomial P(s). DP >= 0. C C L (input) INTEGER C The number of elements of the coefficient matrices to be C printed per line. 1 <= L <= 5. C C NOUT (input) INTEGER C The output channel to which the results are sent. C NOUT >= 0. C C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) C The leading MP-by-NP-by-(DP+1) part of this array must C contain the coefficients of the matrix polynomial P(s). C Specifically, P(i,j,k) must contain the coefficient of C s**(k-1) of the polynomial which is the (i,j)-th element C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and C k = 1,2,...,DP+1. C C LDP1 INTEGER C The leading dimension of array P. LDP1 >= MP. C C LDP2 INTEGER C The second dimension of array P. LDP2 >= NP. C C TEXT (input) CHARACTER*72 C Title caption of the coefficient matrices to be printed. C TEXT is followed by the degree of the coefficient matrix, C within brackets. If TEXT = ' ', then the coefficient C matrices are separated by an empty line. 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 For i = 1, 2, ..., DP + 1 the routine first prints the contents of C TEXT followed by (i-1) as a title, followed by the elements of the C MP-by-NP coefficient matrix P(i) such that C (i) if NP < L, then the leading MP-by-NP part is printed; C (ii) if NP = k*L + p (where k, p > 0), then k MP-by-L blocks of C consecutive columns of P(i) are printed one after another C followed by one MP-by-p block containing the last p columns C of P(i). C Row numbers are printed on the left of each row and a column C number on top of each column. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. C Based on routine PRMAPO by A.J. Geurts, Eindhoven University of C Technology, Holland. C C REVISIONS C C - C C ****************************************************************** C C .. Scalar Arguments .. INTEGER DP, INFO, L, LDP1, LDP2, MP, NP, NOUT CHARACTER*(*) TEXT C .. Array Arguments .. DOUBLE PRECISION P(LDP1,LDP2,*) C .. Local Scalars .. INTEGER I, J, J1, J2, JJ, K, LENTXT, LTEXT, N1 C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC LEN, MIN C C .. Executable Statements .. C INFO = 0 C C Check the input scalar arguments. C IF( MP.LT.1 ) THEN INFO = -1 ELSE IF( NP.LT.1 ) THEN INFO = -2 ELSE IF( DP.LT.0 ) THEN INFO = -3 ELSE IF( L.LT.1 .OR. L.GT.5 ) THEN INFO = -4 ELSE IF( NOUT.LT.0 ) THEN INFO = -5 ELSE IF( LDP1.LT.MP ) THEN INFO = -7 ELSE IF( LDP2.LT.NP ) THEN INFO = -8 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'UD01ND', -INFO ) RETURN END IF C LENTXT = LEN( TEXT ) LTEXT = MIN( 72, LENTXT ) C WHILE ( TEXT(LTEXT:LTEXT) = ' ' ) DO 10 IF ( TEXT(LTEXT:LTEXT).EQ.' ' ) THEN LTEXT = LTEXT - 1 GO TO 10 END IF C END WHILE 10 C DO 50 K = 1, DP + 1 IF ( LTEXT.EQ.0 ) THEN WRITE ( NOUT, FMT = 99999 ) ELSE WRITE ( NOUT, FMT = 99998 ) TEXT(1:LTEXT), K - 1, MP, NP END IF N1 = ( NP - 1 )/L J1 = 1 J2 = L C DO 30 J = 1, N1 WRITE ( NOUT, FMT = 99997 ) ( JJ, JJ = J1, J2 ) C DO 20 I = 1, MP WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, J2 ) 20 CONTINUE C J1 = J1 + L J2 = J2 + L 30 CONTINUE C WRITE ( NOUT, FMT = 99997 ) ( J, J = J1, NP ) C DO 40 I = 1, MP WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, NP ) 40 CONTINUE C 50 CONTINUE C WRITE ( NOUT, FMT = 99999 ) C RETURN C 99999 FORMAT (' ') 99998 FORMAT (/, 1X, A, '(', I2, ')', ' (', I2, 'X', I2, ')') 99997 FORMAT (5X, 5(6X, I2, 7X)) 99996 FORMAT (1X, I2, 2X, 5D15.7) C C *** Last line of UD01ND *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04MY.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04MY.f0000644000175000017500000001012315012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE SB04MY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, $ INFO ) 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 control-4.1.2/src/slicot/src/PaxHeaders/MA02ES.f0000644000000000000000000000013215012430707016164 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02ES.f0000644000175000017500000000464315012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE MA02ES( UPLO, N, A, LDA ) C C PURPOSE C C To store by skew-symmetry the upper or lower triangle of a C skew-symmetric matrix, given the other triangle. The diagonal C entries are set to zero. 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 skew-symmetric matrix A. C On exit, the leading N-by-N part of this array contains C the skew-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 Sep. 2012. C C REVISIONS C C - C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) 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 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 I = 1, N A(I,I) = ZERO DO 10 J = 2, N A(I,J) = -A(J,I) 10 CONTINUE 20 CONTINUE C ELSE IF( LSAME( UPLO, 'U' ) ) THEN C C Construct the lower triangle of A. C DO 40 I = 1, N A(I,I) = ZERO DO 30 J = 2, N A(J,I) = -A(I,J) 30 CONTINUE 40 CONTINUE C END IF RETURN C *** Last line of MA02ES *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01PY.f0000644000000000000000000000013215012430707016201 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/IB01PY.f0000644000175000017500000007125215012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE IB01PY( METH, JOB, NOBR, N, M, L, RANKR1, UL, LDUL, $ R1, LDR1, TAU1, PGAL, LDPGAL, K, LDK, R, LDR, $ H, LDH, B, LDB, D, LDD, TOL, IWORK, DWORK, $ LDWORK, IWARN, INFO ) C C PURPOSE C C 1. To compute the triangular (QR) factor of the p-by-L*s C structured matrix Q, C C [ Q_1s Q_1,s-1 Q_1,s-2 ... Q_12 Q_11 ] C [ 0 Q_1s Q_1,s-1 ... Q_13 Q_12 ] C Q = [ 0 0 Q_1s ... Q_14 Q_13 ], C [ : : : : : ] C [ 0 0 0 ... 0 Q_1s ] C C and apply the transformations to the p-by-m matrix Kexpand, C C [ K_1 ] C [ K_2 ] C Kexpand = [ K_3 ], C [ : ] C [ K_s ] C C where, for MOESP approach (METH = 'M'), p = s*(L*s-n), and C Q_1i = u2(L*(i-1)+1:L*i,:)' is (Ls-n)-by-L, for i = 1:s, C u2 = Un(1:L*s,n+1:L*s), K_i = K(:,(i-1)*m+1:i*m) (i = 1:s) C is (Ls-n)-by-m, and for N4SID approach (METH = 'N'), p = s*(n+L), C and C C [ -L_1|1 ] [ M_i-1 - L_1|i ] C Q_11 = [ ], Q_1i = [ ], i = 2:s, C [ I_L - L_2|1 ] [ -L_2|i ] C C are (n+L)-by-L matrices, and C K_i = K(:,(i-1)*m+1:i*m), i = 1:s, is (n+L)-by-m. C The given matrices are: C For METH = 'M', u2 = Un(1:L*s,n+1:L*s), C K(1:Ls-n,1:m*s); C C [ L_1|1 ... L_1|s ] C For METH = 'N', L = [ ], (n+L)-by-L*s, C [ L_2|1 ... L_2|s ] C C M = [ M_1 ... M_s-1 ], n-by-L*(s-1), and C K, (n+L)-by-m*s. C Matrix M is the pseudoinverse of the matrix GaL, C built from the first n relevant singular C vectors, GaL = Un(1:L(s-1),1:n), and computed C by SLICOT Library routine IB01PD for METH = 'N'. C C Matrix Q is triangularized (in R), exploiting its structure, C and the transformations are applied from the left to Kexpand. C C 2. To estimate the matrices B and D of a linear time-invariant C (LTI) state space model, using the factor R, transformed matrix C Kexpand, and the singular value decomposition information provided C by other routines. C C IB01PY routine is intended for speed and efficient use of the C memory space. It is generally not recommended for METH = 'N', as C IB01PX routine can produce more accurate results. C C ARGUMENTS C C Mode Parameters C C METH CHARACTER*1 C Specifies the subspace identification method to be used, C as follows: C = 'M': MOESP algorithm with past inputs and outputs; C = 'N': N4SID algorithm. C C JOB CHARACTER*1 C Specifies whether or not the matrices B and D should be C computed, as follows: C = 'B': compute the matrix B, but not the matrix D; C = 'D': compute both matrices B and D; C = 'N': do not compute the matrices B and D, but only the C R factor of Q and the transformed Kexpand. C C Input/Output Parameters C C NOBR (input) INTEGER C The number of block rows, s, in the input and output C Hankel matrices processed by other routines. NOBR > 1. C C N (input) INTEGER C The order of the system. NOBR > N > 0. C C M (input) INTEGER C The number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L > 0. C C RANKR1 (input) INTEGER C The effective rank of the upper triangular matrix r1, C i.e., the triangular QR factor of the matrix GaL, C computed by SLICOT Library routine IB01PD. It is also C the effective rank of the matrix GaL. 0 <= RANKR1 <= N. C If JOB = 'N', or M = 0, or METH = 'N', this C parameter is not used. C C UL (input/workspace) DOUBLE PRECISION array, dimension C ( LDUL,L*NOBR ) C On entry, if METH = 'M', the leading L*NOBR-by-L*NOBR C part of this array must contain the matrix Un of C relevant singular vectors. The first N columns of UN C need not be specified for this routine. C On entry, if METH = 'N', the leading (N+L)-by-L*NOBR C part of this array must contain the given matrix L. C On exit, the leading LDF-by-L*(NOBR-1) part of this array C is overwritten by the matrix F of the algorithm in [4], C where LDF = MAX( 1, L*NOBR-N-L ), if METH = 'M'; C LDF = N, if METH = 'N'. C C LDUL INTEGER C The leading dimension of the array UL. C LDUL >= L*NOBR, if METH = 'M'; C LDUL >= N+L, if METH = 'N'. C C R1 (input) DOUBLE PRECISION array, dimension ( LDR1,N ) C If JOB <> 'N', M > 0, METH = 'M', and RANKR1 = N, C the leading L*(NOBR-1)-by-N part of this array must C contain details of the QR factorization of the matrix C GaL, as computed by SLICOT Library routine IB01PD. C Specifically, the leading N-by-N upper triangular part C must contain the upper triangular factor r1 of GaL, C and the lower L*(NOBR-1)-by-N trapezoidal part, together C with array TAU1, must contain the factored form of the C orthogonal matrix Q1 in the QR factorization of GaL. C If JOB = 'N', or M = 0, or METH = 'N', or METH = 'M' C and RANKR1 < N, this array is not referenced. C C LDR1 INTEGER C The leading dimension of the array R1. C LDR1 >= L*(NOBR-1), if JOB <> 'N', M > 0, METH = 'M', C and RANKR1 = N; C LDR1 >= 1, otherwise. C C TAU1 (input) DOUBLE PRECISION array, dimension ( N ) C If JOB <> 'N', M > 0, METH = 'M', and RANKR1 = N, C this array must contain the scalar factors of the C elementary reflectors used in the QR factorization of the C matrix GaL, computed by SLICOT Library routine IB01PD. C If JOB = 'N', or M = 0, or METH = 'N', or METH = 'M' C and RANKR1 < N, this array is not referenced. C C PGAL (input) DOUBLE PRECISION array, dimension C ( LDPGAL,L*(NOBR-1) ) C If METH = 'N', or JOB <> 'N', M > 0, METH = 'M' and C RANKR1 < N, the leading N-by-L*(NOBR-1) part of this C array must contain the pseudoinverse of the matrix GaL, C as computed by SLICOT Library routine IB01PD. C If METH = 'M' and JOB = 'N', or M = 0, or C RANKR1 = N, this array is not referenced. C C LDPGAL INTEGER C The leading dimension of the array PGAL. C LDPGAL >= N, if METH = 'N', or JOB <> 'N', M > 0, C and METH = 'M' and RANKR1 < N; C LDPGAL >= 1, otherwise. C C K (input/output) DOUBLE PRECISION array, dimension C ( LDK,M*NOBR ) C On entry, the leading (p/s)-by-M*NOBR part of this array C must contain the given matrix K defined above. C On exit, the leading (p/s)-by-M*NOBR part of this array C contains the transformed matrix K. C C LDK INTEGER C The leading dimension of the array K. LDK >= p/s. C C R (output) DOUBLE PRECISION array, dimension ( LDR,L*NOBR ) C If JOB = 'N', or M = 0, or Q has full rank, the C leading L*NOBR-by-L*NOBR upper triangular part of this C array contains the R factor of the QR factorization of C the matrix Q. C If JOB <> 'N', M > 0, and Q has not a full rank, the C leading L*NOBR-by-L*NOBR upper trapezoidal part of this C array contains details of the complete orhogonal C factorization of the matrix Q, as constructed by SLICOT C Library routines MB03OD and MB02QY. C C LDR INTEGER C The leading dimension of the array R. LDR >= L*NOBR. C C H (output) DOUBLE PRECISION array, dimension ( LDH,M ) C If JOB = 'N' or M = 0, the leading L*NOBR-by-M part C of this array contains the updated part of the matrix C Kexpand corresponding to the upper triangular factor R C in the QR factorization of the matrix Q. C If JOB <> 'N', M > 0, and METH = 'N' or METH = 'M' C and RANKR1 < N, the leading L*NOBR-by-M part of this C array contains the minimum norm least squares solution of C the linear system Q*X = Kexpand, from which the matrices C B and D are found. The first NOBR-1 row blocks of X C appear in the reverse order in H. C If JOB <> 'N', M > 0, METH = 'M' and RANKR1 = N, the C leading L*(NOBR-1)-by-M part of this array contains the C matrix product Q1'*X, and the subarray C L*(NOBR-1)+1:L*NOBR-by-M contains the corresponding C submatrix of X, with X defined in the phrase above. C C LDH INTEGER C The leading dimension of the array H. LDH >= L*NOBR. C C B (output) DOUBLE PRECISION array, dimension ( LDB,M ) C If M > 0, JOB = 'B' or 'D' and INFO = 0, the leading C N-by-M part of this array contains the system input C matrix. C If M = 0 or JOB = 'N', this array is not referenced. C C LDB INTEGER C The leading dimension of the array B. C LDB >= N, if M > 0 and JOB = 'B' or 'D'; C LDB >= 1, if M = 0 or JOB = 'N'. C C D (output) DOUBLE PRECISION array, dimension ( LDD,M ) C If M > 0, JOB = 'D' and INFO = 0, the leading C L-by-M part of this array contains the system input-output C matrix. C If M = 0 or JOB = 'B' or 'N', this array is not C referenced. C C LDD INTEGER C The leading dimension of the array D. C LDD >= L, if M > 0 and JOB = 'D'; C LDD >= 1, if M = 0 or JOB = 'B' or 'N'. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used for estimating the rank of C matrices. If the user sets TOL > 0, then the given value C of TOL is used as a lower bound for the reciprocal C condition number; an m-by-n matrix whose estimated C condition number is less than 1/TOL is considered to C be of full rank. If the user sets TOL <= 0, then an C implicitly computed, default tolerance, defined by C TOLDEF = m*n*EPS, is used instead, where EPS is the C relative machine precision (see LAPACK Library routine C DLAMCH). C This parameter is not used if M = 0 or JOB = 'N'. C C Workspace C C IWORK INTEGER array, dimension ( LIWORK ) C where LIWORK >= 0, if JOB = 'N', or M = 0; C LIWORK >= L*NOBR, if JOB <> 'N', and M > 0. C C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK, and, if JOB <> 'N', and M > 0, DWORK(2) C contains the reciprocal condition number of the triangular C factor of the matrix R. C On exit, if INFO = -28, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( 2*L, L*NOBR, L+M*NOBR ), C if JOB = 'N', or M = 0; C LDWORK >= MAX( L+M*NOBR, L*NOBR + MAX( 3*L*NOBR+1, M ) ), C if JOB <> 'N', and M > 0. C For good performance, LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 4: the least squares problem to be solved has a C rank-deficient coefficient matrix. 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 = 3: a singular upper triangular matrix was found. C C METHOD C C The QR factorization is computed exploiting the structure, C as described in [4]. C The matrices B and D are then obtained by solving certain C linear systems in a least squares sense. C C REFERENCES C C [1] Verhaegen M., and Dewilde, P. C Subspace Model Identification. Part 1: The output-error C state-space model identification class of algorithms. C Int. J. Control, 56, pp. 1187-1210, 1992. C C [2] Van Overschee, P., and De Moor, B. C N4SID: Two Subspace Algorithms for the Identification C of Combined Deterministic-Stochastic Systems. C Automatica, Vol.30, No.1, pp. 75-93, 1994. C C [3] Van Overschee, P. C Subspace Identification : Theory - Implementation - C Applications. C Ph. D. Thesis, Department of Electrical Engineering, C Katholieke Universiteit Leuven, Belgium, Feb. 1995. C C [4] Sima, V. C Subspace-based Algorithms for Multivariable System C Identification. C Studies in Informatics and Control, 5, pp. 335-344, 1996. C C NUMERICAL ASPECTS C C The implemented method for computing the triangular factor and C updating Kexpand is numerically stable. C C FURTHER COMMENTS C C The computed matrices B and D are not the least squares solutions C delivered by either MOESP or N4SID algorithms, except for the C special case n = s - 1, L = 1. However, the computed B and D are C frequently good enough estimates, especially for METH = 'M'. C Better estimates could be obtained by calling SLICOT Library C routine IB01PX, but it is less efficient, and requires much more C workspace. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 1999. C C REVISIONS C C Feb. 2000, Sep. 2001, March 2005. C C KEYWORDS C C Identification methods; least squares solutions; multivariable C systems; QR decomposition; singular value decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER INFO, IWARN, L, LDB, LDD, LDH, LDK, LDPGAL, $ LDR, LDR1, LDUL, LDWORK, M, N, NOBR, RANKR1 CHARACTER JOB, METH C .. Array Arguments .. DOUBLE PRECISION B(LDB, *), D(LDD, *), DWORK(*), H(LDH, *), $ K(LDK, *), PGAL(LDPGAL, *), R(LDR, *), $ R1(LDR1, *), TAU1(*), UL(LDUL, *) INTEGER IWORK( * ) C .. Local Scalars .. DOUBLE PRECISION EPS, RCOND, SVLMAX, THRESH, TOLL INTEGER I, IERR, ITAU, J, JI, JL, JM, JWORK, LDUN2, $ LNOBR, LP1, MAXWRK, MINWRK, MNOBR, NOBRH, $ NROW, NROWML, RANK LOGICAL MOESP, N4SID, WITHB, WITHD C .. Local Array .. DOUBLE PRECISION SVAL(3) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, ILAENV, LSAME C .. External Subroutines .. EXTERNAL DGEMM, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP, $ DTRCON, DTRSM, DTRTRS, MA02AD, MB02QY, MB03OD, $ MB04OD, MB04OY, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MOD C .. Executable Statements .. C C Decode the scalar input parameters. C MOESP = LSAME( METH, 'M' ) N4SID = LSAME( METH, 'N' ) WITHD = LSAME( JOB, 'D' ) WITHB = LSAME( JOB, 'B' ) .OR. WITHD MNOBR = M*NOBR LNOBR = L*NOBR LDUN2 = LNOBR - L LP1 = L + 1 IF ( MOESP ) THEN NROW = LNOBR - N ELSE NROW = N + L END IF NROWML = NROW - L IWARN = 0 INFO = 0 C C Check the scalar input parameters. C IF( .NOT.( MOESP .OR. N4SID ) ) THEN INFO = -1 ELSE IF( .NOT.( WITHB .OR. LSAME( JOB, 'N' ) ) ) THEN INFO = -2 ELSE IF( NOBR.LE.1 ) THEN INFO = -3 ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( L.LE.0 ) THEN INFO = -6 ELSE IF( ( MOESP .AND. WITHB .AND. M.GT.0 ) .AND. $ ( RANKR1.LT.ZERO .OR. RANKR1.GT.N ) ) THEN INFO = -7 ELSE IF( ( MOESP .AND. LDUL.LT.LNOBR ) .OR. $ ( N4SID .AND. LDUL.LT.NROW ) ) THEN INFO = -9 ELSE IF( LDR1.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. MOESP .AND. $ LDR1.LT.LDUN2 .AND. RANKR1.EQ.N ) ) THEN INFO = -11 ELSE IF( LDPGAL.LT.1 .OR. $ ( LDPGAL.LT.N .AND. ( N4SID .OR. ( WITHB .AND. M.GT.0 $ .AND. ( MOESP .AND. RANKR1.LT.N ) ) ) ) ) $ THEN INFO = -14 ELSE IF( LDK.LT.NROW ) THEN INFO = -16 ELSE IF( LDR.LT.LNOBR ) THEN INFO = -18 ELSE IF( LDH.LT.LNOBR ) THEN INFO = -20 ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. LDB.LT.N ) ) $ THEN INFO = -22 ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. WITHD .AND. LDD.LT.L ) ) $ THEN INFO = -24 ELSE C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 MINWRK = MAX( 2*L, LNOBR, L + MNOBR ) MAXWRK = MINWRK MAXWRK = MAX( MAXWRK, L + L*ILAENV( 1, 'DGEQRF', ' ', NROW, L, $ -1, -1 ) ) MAXWRK = MAX( MAXWRK, L + LDUN2*ILAENV( 1, 'DORMQR', 'LT', $ NROW, LDUN2, L, -1 ) ) MAXWRK = MAX( MAXWRK, L + MNOBR*ILAENV( 1, 'DORMQR', 'LT', $ NROW, MNOBR, L, -1 ) ) C IF( M.GT.0 .AND. WITHB ) THEN MINWRK = MAX( MINWRK, 4*LNOBR+1, LNOBR + M ) MAXWRK = MAX( MINWRK, MAXWRK, LNOBR + $ M*ILAENV( 1, 'DORMQR', 'LT', LNOBR, M, LNOBR, $ -1 ) ) END IF C IF ( LDWORK.LT.MINWRK ) THEN INFO = -28 DWORK( 1 ) = MINWRK END IF END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB01PY', -INFO ) RETURN END IF C C Construct in R the first block-row of Q, i.e., the C (p/s)-by-L*s matrix [ Q_1s ... Q_12 Q_11 ], where C Q_1i, defined above, is (p/s)-by-L, for i = 1:s. C IF ( MOESP ) THEN C DO 10 I = 1, NOBR CALL MA02AD( 'Full', L, NROW, UL(L*(I-1)+1,N+1), LDUL, $ R(1,L*(NOBR-I)+1), LDR ) 10 CONTINUE C ELSE JL = LNOBR JM = LDUN2 C DO 50 JI = 1, LDUN2, L C DO 40 J = JI + L - 1, JI, -1 C DO 20 I = 1, N R(I,J) = PGAL(I,JM) - UL(I,JL) 20 CONTINUE C DO 30 I = N + 1, NROW R(I,J) = -UL(I,JL) 30 CONTINUE C JL = JL - 1 JM = JM - 1 40 CONTINUE C 50 CONTINUE C DO 70 J = LNOBR, LDUN2 + 1, -1 C DO 60 I = 1, NROW R(I,J) = -UL(I,JL) 60 CONTINUE C JL = JL - 1 R(N+J-LDUN2,J) = ONE + R(N+J-LDUN2,J) 70 CONTINUE END IF C C Triangularize the submatrix Q_1s using an orthogonal matrix S. C Workspace: need 2*L, prefer L+L*NB. C ITAU = 1 JWORK = ITAU + L C CALL DGEQRF( NROW, L, R, LDR, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) C C Apply the transformation S' to the matrix C [ Q_1,s-1 ... Q_11 ]. Therefore, C C [ R P_s-1 P_s-2 ... P_2 P_1 ] C S'[ Q_1,s ... Q_11 ] = [ ]. C [ 0 F_s-1 F_s-2 ... F_2 F_1 ] C C Workspace: need L*NOBR, prefer L+(L*NOBR-L)*NB. C CALL DORMQR( 'Left', 'Transpose', NROW, LDUN2, L, R, LDR, $ DWORK(ITAU), R(1,LP1), LDR, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) C C Apply the transformation S' to each of the submatrices K_i of C Kexpand = [ K_1' K_2' ... K_s' ]', K_i = K(:,(i-1)*m+1:i*m) C (i = 1:s) being (p/s)-by-m. Denote ( H_i' G_i' )' = S'K_i C (i = 1:s), where H_i has L rows. C Finally, H_i is saved in H(L*(i-1)+1:L*i,1:m), i = 1:s. C (G_i is in K(L+1:p/s,(i-1)*m+1:i*m), i = 1:s.) C Workspace: need L+M*NOBR, prefer L+M*NOBR*NB. C CALL DORMQR( 'Left', 'Transpose', NROW, MNOBR, L, R, LDR, $ DWORK(ITAU), K, LDK, DWORK(JWORK), LDWORK-JWORK+1, $ IERR ) C C Put the rows to be annihilated (matrix F) in UL(1:p/s-L,1:L*s-L). C CALL DLACPY( 'Full', NROWML, LDUN2, R(LP1,LP1), LDR, UL, LDUL ) C C Now, the structure of the transformed matrices is: C C [ R P_s-1 P_s-2 ... P_2 P_1 ] [ H_1 ] C [ 0 R P_s-1 ... P_3 P_2 ] [ H_2 ] C [ 0 0 R ... P_4 P_3 ] [ H_3 ] C [ : : : : : ] [ : ] C [ 0 0 0 ... R P_s-1 ] [ H_s-1 ] C Q = [ 0 0 0 ... 0 R ], Kexpand = [ H_s ], C [ 0 F_s-1 F_s-2 ... F_2 F_1 ] [ G_1 ] C [ 0 0 F_s-1 ... F_3 F_2 ] [ G_2 ] C [ : : : : : ] [ : ] C [ 0 0 0 ... 0 F_s-1 ] [ G_s-1 ] C [ 0 0 0 ... 0 0 ] [ G_s ] C C where the block-rows have been permuted, to better exploit the C structure. The block-rows having R on the diagonal are dealt C with successively in the array R. C The F submatrices are stored in the array UL, as a block-row. C C Copy H_1 in H(1:L,1:m). C CALL DLACPY( 'Full', L, M, K, LDK, H, LDH ) C C Triangularize the transformed matrix exploiting its structure. C Workspace: need L+MAX(L-1,L*NOBR-2*L,M*(NOBR-1)). C DO 90 I = 1, NOBR - 1 C C Copy part of the preceding block-row and then annihilate the C current submatrix F_s-i using an orthogonal matrix modifying C the corresponding submatrix R. Simultaneously, apply the C transformation to the corresponding block-rows of the matrices C R and F. C CALL DLACPY( 'Upper', L, LNOBR-L*I, R(L*(I-1)+1,L*(I-1)+1), $ LDR, R(L*I+1,L*I+1), LDR ) CALL MB04OD( 'Full', L, LNOBR-L*(I+1), NROWML, R(L*I+1,L*I+1), $ LDR, UL(1,L*(I-1)+1), LDUL, R(L*I+1,L*(I+1)+1), $ LDR, UL(1,L*I+1), LDUL, DWORK(ITAU), DWORK(JWORK) $ ) C C Apply the transformation to the corresponding block-rows of C the matrix G and copy H_(i+1) in H(L*i+1:L*(i+1),1:m). C DO 80 J = 1, L CALL MB04OY( NROWML, M*(NOBR-I), UL(1,L*(I-1)+J), DWORK(J), $ K(J,M*I+1), LDK, K(LP1,1), LDK, DWORK(JWORK) ) 80 CONTINUE C CALL DLACPY( 'Full', L, M, K(1,M*I+1), LDK, H(L*I+1,1), LDH ) 90 CONTINUE C C Return if only the factorization is needed. C IF( M.EQ.0 .OR. .NOT.WITHB ) THEN DWORK(1) = MAXWRK RETURN END IF C C Set the precision parameters. A threshold value EPS**(2/3) is C used for deciding to use pivoting or not, where EPS is the C relative machine precision (see LAPACK Library routine DLAMCH). C EPS = DLAMCH( 'Precision' ) THRESH = EPS**( TWO/THREE ) TOLL = TOL IF( TOLL.LE.ZERO ) $ TOLL = LNOBR*LNOBR*EPS SVLMAX = ZERO C C Compute the reciprocal of the condition number of the triangular C factor R of Q. C Workspace: need 3*L*NOBR. C CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LNOBR, R, LDR, RCOND, $ DWORK, IWORK, IERR ) C IF ( RCOND.GT.MAX( TOLL, THRESH ) ) THEN C C The triangular factor R is considered to be of full rank. C Solve for X, R*X = H. C CALL DTRSM( 'Left', 'Upper', 'NoTranspose', 'Non-unit', $ LNOBR, M, ONE, R, LDR, H, LDH ) ELSE C C Rank-deficient triangular factor R. Compute the C minimum-norm least squares solution of R*X = H using C the complete orthogonal factorization of R. C DO 100 I = 1, LNOBR IWORK(I) = 0 100 CONTINUE C C Workspace: need 4*L*NOBR+1; C prefer 3*L*NOBR+(L*NOBR+1)*NB. C JWORK = ITAU + LNOBR CALL DLASET( 'Lower', LNOBR-1, LNOBR, ZERO, ZERO, R(2,1), LDR ) CALL MB03OD( 'QR', LNOBR, LNOBR, R, LDR, IWORK, TOLL, SVLMAX, $ DWORK(ITAU), RANK, SVAL, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Workspace: need L*NOBR+M; prefer L*NOBR+M*NB. C CALL DORMQR( 'Left', 'Transpose', LNOBR, M, LNOBR, R, LDR, $ DWORK(ITAU), H, LDH, DWORK(JWORK), LDWORK-JWORK+1, $ IERR ) IF ( RANK.LT.LNOBR ) THEN C C The least squares problem is rank-deficient. C IWARN = 4 END IF C C Workspace: need L*NOBR+max(L*NOBR,M); prefer larger. C CALL MB02QY( LNOBR, LNOBR, M, RANK, R, LDR, IWORK, H, LDH, $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) END IF C C Construct the matrix D, if needed. C IF ( WITHD ) $ CALL DLACPY( 'Full', L, M, H(LDUN2+1,1), LDH, D, LDD ) C C Compute B by solving another linear system (possibly in C a least squares sense). C C Make a block-permutation of the rows of the right-hand side, H, C to construct the matrix C C [ H(L*(s-2)+1:L*(s-1),:); ... H(L+1:L*2,:); H(1:L),:) ] C C in H(1:L*s-L,1:n). C NOBRH = NOBR/2 + MOD( NOBR, 2 ) - 1 C DO 120 J = 1, M C DO 110 I = 1, NOBRH CALL DSWAP( L, H(L*(I-1)+1,J), 1, H(L*(NOBR-I-1)+1,J), 1 ) 110 CONTINUE C 120 CONTINUE C C Solve for B the matrix equation GaL*B = H(1:L*s-L,:), using C the available QR factorization of GaL, if METH = 'M' and C rank(GaL) = n, or the available pseudoinverse of GaL, otherwise. C IF ( MOESP .AND. RANKR1.EQ.N ) THEN C C The triangular factor r1 of GaL is considered to be of C full rank. Compute Q1'*H in H and then solve for B, C r1*B = H(1:n,:) in B, where Q1 is the orthogonal matrix C in the QR factorization of GaL. C Workspace: need M; prefer M*NB. C CALL DORMQR( 'Left', 'Transpose', LDUN2, M, N, R1, LDR1, $ TAU1, H, LDH, DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C C Compute the solution in B. C CALL DLACPY( 'Full', N, M, H, LDH, B, LDB ) C CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, M, R1, LDR1, $ B, LDB, IERR ) IF ( IERR.GT.0 ) THEN INFO = 3 RETURN END IF ELSE C C Rank-deficient triangular factor r1. Use the available C pseudoinverse of GaL for computing B from GaL*B = H. C CALL DGEMM ( 'NoTranspose', 'NoTranspose', N, M, LDUN2, ONE, $ PGAL, LDPGAL, H, LDH, ZERO, B, LDB ) END IF C C Return optimal workspace in DWORK(1) and reciprocal condition C number in DWORK(2). C DWORK(1) = MAXWRK DWORK(2) = RCOND C RETURN C C *** Last line of IB01PY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02QY.f0000644000000000000000000000013215012430707016207 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02QY.f0000644000175000017500000002624015012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE MB02QY( M, N, NRHS, RANK, A, LDA, JPVT, B, LDB, TAU, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To determine the minimum-norm solution to a real linear least C squares problem: C C minimize || A * X - B ||, C C using the rank-revealing QR factorization of a real general C M-by-N matrix A, computed by SLICOT Library routine MB03OD. 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 A. N >= 0. C C NRHS (input) INTEGER C The number of columns of the matrix B. NRHS >= 0. C C RANK (input) INTEGER C The effective rank of A, as returned by SLICOT Library C routine MB03OD. min(M,N) >= RANK >= 0. C C A (input/output) DOUBLE PRECISION array, dimension C ( LDA, N ) C On entry, the leading min(M,N)-by-N upper trapezoidal C part of this array contains the triangular factor R, as C returned by SLICOT Library routine MB03OD. The strict C lower trapezoidal part of A is not referenced. C On exit, if RANK < N, the leading RANK-by-RANK upper C triangular part of this array contains the upper C triangular matrix R of the complete orthogonal C factorization of A, and the submatrix (1:RANK,RANK+1:N) C of this array, with the array TAU, represent the C orthogonal matrix Z (of the complete orthogonal C factorization of A), as a product of RANK elementary C reflectors. C On exit, if RANK = N, this array is unchanged. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C JPVT (input) INTEGER array, dimension ( N ) C The recorded permutations performed by SLICOT Library C routine MB03OD; if JPVT(i) = k, then the i-th column C of A*P was the k-th column of the original matrix A. C C B (input/output) DOUBLE PRECISION array, dimension C ( LDB, NRHS ) C On entry, if NRHS > 0, the leading M-by-NRHS part of C this array must contain the matrix B (corresponding to C the transformed matrix A, returned by SLICOT Library C routine MB03OD). C On exit, if NRHS > 0, the leading N-by-NRHS part of this C array contains the solution matrix X. C If M >= N and RANK = N, the residual sum-of-squares C for the solution in the i-th column is given by the sum C of squares of elements N+1:M in that column. C If NRHS = 0, the array B is not referenced. C C LDB INTEGER C The leading dimension of the array B. C LDB >= max(1,M,N), if NRHS > 0. C LDB >= 1, if NRHS = 0. C C TAU (output) DOUBLE PRECISION array, dimension ( min(M,N) ) C The scalar factors of the elementary reflectors. C If RANK = N, the array TAU is not referenced. 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 length of the array DWORK. C LDWORK >= max( 1, N, NRHS ). C For good performance, LDWORK should sometimes 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 uses a QR factorization with column pivoting: C C A * P = Q * R = Q * [ R11 R12 ], C [ 0 R22 ] C C where R11 is an upper triangular submatrix of estimated rank C RANK, the effective rank of A. The submatrix R22 can be C considered as negligible. C C If RANK < N, then R12 is annihilated by orthogonal C transformations from the right, arriving at the complete C orthogonal factorization: C C A * P = Q * [ T11 0 ] * Z. C [ 0 0 ] C C The minimum-norm solution is then C C X = P * Z' [ inv(T11)*Q1'*B ], C [ 0 ] C C where Q1 consists of the first RANK columns of Q. C C The input data for MB02QY are the transformed matrices Q' * A C (returned by SLICOT Library routine MB03OD) and Q' * B. C Matrix Q is not needed. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2011. C C KEYWORDS C C Least squares solutions; QR decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK C .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), TAU( * ) C .. Local Scalars .. LOGICAL LQUERY INTEGER I, IASCL, IBSCL, J, MN DOUBLE PRECISION ANRM, BIGNUM, BNRM, MAXWRK, SMLNUM C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE, DLANTR EXTERNAL DLAMCH, DLANGE, DLANTR C .. External Subroutines .. EXTERNAL DCOPY, DLABAD, DLASCL, DLASET, DORMRZ, DTRSM, $ DTZRZF, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C .. C .. Executable Statements .. C MN = MIN( M, N ) 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( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( RANK.LT.0 .OR. RANK.GT.MN ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.1 .OR. ( NRHS.GT.0 .AND. LDB.LT.MAX( M, N ) ) ) $ THEN INFO = -9 ELSE I = MAX( 1, N, NRHS ) LQUERY = LDWORK.EQ.-1 IF ( LQUERY ) THEN RANK = MAX( 0, N-1 ) CALL DTZRZF( RANK, N, A, LDA, TAU, DWORK, -1, INFO ) MAXWRK = MAX( DBLE( I ), DWORK( 1 ) ) CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, $ LDA, TAU, B, LDB, DWORK, -1, INFO ) MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) END IF IF( LDWORK.LT.I .AND. .NOT.LQUERY ) $ INFO = -12 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02QY', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = MAXWRK RETURN END IF C C Quick return if possible. C IF( MIN( MN, NRHS ).EQ.0 ) THEN DWORK( 1 ) = ONE RETURN END IF C C Logically partition R = [ R11 R12 ], C [ 0 R22 ] C C where R11 = R(1:RANK,1:RANK). If RANK = N, let T11 = R11. C MAXWRK = DBLE( N ) IF( RANK.LT.N ) THEN C C Get machine parameters. C SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) C C Scale A, B if max entries outside range [SMLNUM,BIGNUM]. C ANRM = DLANTR( 'MaxNorm', 'Upper', 'Non-unit', RANK, N, A, LDA, $ DWORK ) IASCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN C C Scale matrix norm up to SMLNUM. C CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, RANK, N, A, LDA, $ INFO ) IASCL = 1 ELSE IF( ANRM.GT.BIGNUM ) THEN C C Scale matrix norm down to BIGNUM. C CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, RANK, N, A, LDA, $ INFO ) IASCL = 2 ELSE IF( ANRM.EQ.ZERO ) THEN C C Matrix all zero. Return zero solution. C CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, B, LDB ) DWORK( 1 ) = ONE RETURN END IF C BNRM = DLANGE( 'MaxNorm', M, NRHS, B, LDB, DWORK ) IBSCL = 0 IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN C C Scale matrix norm up to SMLNUM. C CALL DLASCL( 'General', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, $ INFO ) IBSCL = 1 ELSE IF( BNRM.GT.BIGNUM ) THEN C C Scale matrix norm down to BIGNUM. C CALL DLASCL( 'General', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, $ INFO ) IBSCL = 2 END IF C C [R11,R12] = [ T11, 0 ] * Z. C Details of Householder rotations are stored in TAU. C Workspace need RANK, prefer RANK*NB. C CALL DTZRZF( RANK, N, A, LDA, TAU, DWORK, LDWORK, INFO ) MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) END IF C C B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS). C CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, $ NRHS, ONE, A, LDA, B, LDB ) C IF( RANK.LT.N ) THEN C CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, B( RANK+1, 1 ), $ LDB ) C C B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS). C Workspace need NRHS, prefer NRHS*NB. C CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, $ LDA, TAU, B, LDB, DWORK, LDWORK, INFO ) MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) C C Undo scaling. C IF( IASCL.EQ.1 ) THEN CALL DLASCL( 'General', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, $ INFO ) CALL DLASCL( 'Upper', 0, 0, SMLNUM, ANRM, RANK, RANK, A, $ LDA, INFO ) ELSE IF( IASCL.EQ.2 ) THEN CALL DLASCL( 'General', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, $ INFO ) CALL DLASCL( 'Upper', 0, 0, BIGNUM, ANRM, RANK, RANK, A, $ LDA, INFO ) END IF IF( IBSCL.EQ.1 ) THEN CALL DLASCL( 'General', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, $ INFO ) ELSE IF( IBSCL.EQ.2 ) THEN CALL DLASCL( 'General', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, $ INFO ) END IF END IF C C B(1:N,1:NRHS) := P * B(1:N,1:NRHS). C Workspace N. C DO 20 J = 1, NRHS C DO 10 I = 1, N DWORK( JPVT( I ) ) = B( I, J ) 10 CONTINUE C CALL DCOPY( N, DWORK, 1, B( 1, J ), 1 ) 20 CONTINUE C DWORK( 1 ) = MAXWRK RETURN C C *** Last line of MB02QY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB01BX.f0000644000000000000000000000013015012430707016172 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB01BX.f0000644000175000017500000001016615012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE SB01BX( REIG, N, XR, XI, WR, WI, S, P ) 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 control-4.1.2/src/slicot/src/PaxHeaders/MA02JZ.f0000644000000000000000000000013215012430707016200 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02JZ.f0000644000175000017500000001176215012430707017403 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION MA02JZ( LTRAN1, LTRAN2, N, Q1, LDQ1, Q2, $ LDQ2, RES, LDRES ) C C PURPOSE C C To compute || Q^H Q - I ||_F for a complex matrix of the form C C [ op( Q1 ) op( Q2 ) ] C Q = [ ], C [ -op( Q2 ) op( Q1 ) ] C C where Q1 and Q2 are N-by-N matrices. This residual can be used to C test wether Q is numerically a unitary symplectic matrix. C C FUNCTION VALUE C C MA02JZ DOUBLE PRECISION C The computed residual. C C ARGUMENTS C C Mode Parameters C C LTRAN1 LOGICAL C Specifies the form of op( Q1 ) as follows: C = .FALSE.: op( Q1 ) = Q1; C = .TRUE. : op( Q1 ) = Q1'. C C LTRAN2 LOGICAL C Specifies the form of op( Q2 ) as follows: C = .FALSE.: op( Q2 ) = Q2; C = .TRUE. : op( Q2 ) = Q2'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices Q1 and Q2. N >= 0. C C Q1 (input) COMPLEX*16 array, dimension (LDQ1,N) C On entry, the leading N-by-N part of this array must C contain the matrix op( Q1 ). C C LDQ1 INTEGER C The leading dimension of the array Q1. LDQ1 >= MAX(1,N). C C Q2 (input) COMPLEX*16 array, dimension (LDQ2,N) C On entry, the leading N-by-N part of this array must C contain the matrix op( Q2 ). C C LDQ2 INTEGER C The leading dimension of the array Q2. LDQ2 >= MAX(1,N). C C Workspace C C RES DOUBLE PRECISION array, dimension (LDRES,N) C C LDRES INTEGER C The leading dimension of the array RES. C LDRES >= MAX(1,N). C C METHOD C C The routine computes the residual by simple elementary operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Sep. 2012. Based on SLICOT Library routine MA02JD. C C REVISIONS C C - C C KEYWORDS C C Elementary operations. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = (0.0D0,0.0D0), ONE = (1.0D0,0.0D0) ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) C .. Scalar Arguments .. LOGICAL LTRAN1, LTRAN2 INTEGER LDQ1, LDQ2, LDRES, N C .. Array Arguments .. COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), RES(LDRES,*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION TEMP C .. Local Arrays .. DOUBLE PRECISION DUMMY(1) C .. External Subroutines .. EXTERNAL ZGEMM C .. External Functions .. DOUBLE PRECISION DLAPY2, ZLANGE EXTERNAL DLAPY2, ZLANGE C .. Intrinsic Functions .. INTRINSIC SQRT C C .. Executable Statements .. C IF ( LTRAN1 ) THEN CALL ZGEMM( 'No Transpose', 'Conj Transpose', N, N, N, ONE, Q1, $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) ELSE CALL ZGEMM( 'Conj Transpose', 'No Transpose', N, N, N, ONE, Q1, $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) END IF IF ( LTRAN2 ) THEN CALL ZGEMM( 'No Transpose', 'Conj Transpose', N, N, N, ONE, Q2, $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) ELSE CALL ZGEMM( 'Conj Transpose', 'No Transpose', N, N, N, ONE, Q2, $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) END IF DO 10 I = 1, N RES(I,I) = RES(I,I) - ONE 10 CONTINUE TEMP = ZLANGE( 'Frobenius', N, N, RES, LDRES, DUMMY ) IF ( LTRAN1 .AND. LTRAN2 ) THEN CALL ZGEMM( 'No Transpose', 'Conj Transpose', N, N, N, ONE, Q2, $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) CALL ZGEMM( 'No Transpose', 'Conj Transpose', N, N, N, ONE, Q1, $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) ELSE IF ( LTRAN1 ) THEN CALL ZGEMM( 'Conj Transpose', 'Conj Transpose', N, N, N, ONE, $ Q2, LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) CALL ZGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q1, $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) ELSE IF ( LTRAN2 ) THEN CALL ZGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q2, $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) CALL ZGEMM( 'Conj Transpose', 'Conj Transpose', N, N, N, ONE, $ Q1, LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) ELSE CALL ZGEMM( 'Conj Transpose', 'No Transpose', N, N, N, ONE, Q2, $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) CALL ZGEMM( 'Conj Transpose', 'No Transpose', N, N, N, ONE, Q1, $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) END IF TEMP = DLAPY2( TEMP, ZLANGE( 'Frobenius', N, N, RES, LDRES, $ DUMMY ) ) MA02JZ = SQRT( TWO )*TEMP RETURN C *** Last line of MA02JZ *** END control-4.1.2/src/slicot/src/PaxHeaders/AB05QD.f0000644000000000000000000000013215012430707016151 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB05QD.f0000644000175000017500000003232315012430707017350 0ustar00lilgelilge00000000000000 SUBROUTINE AB05QD( OVER, N1, M1, P1, N2, M2, P2, A1, LDA1, B1, $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, $ C2, LDC2, D2, LDD2, N, M, P, A, LDA, B, LDB, $ C, LDC, D, LDD, INFO ) C C PURPOSE C C To append two systems G1 and G2 in state-space form together. C If G1 = (A1,B1,C1,D1) and G2 = (A2,B2,C2,D2) are the state-space C models of the given two systems having the transfer-function C matrices G1 and G2, respectively, this subroutine constructs the C state-space model G = (A,B,C,D) which corresponds to the C transfer-function matrix C C ( G1 0 ) C G = ( ) C ( 0 G2 ) C C ARGUMENTS C C Mode Parameters C C OVER CHARACTER*1 C Indicates whether the user wishes to overlap pairs of C arrays, as follows: C = 'N': Do not overlap; C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, C C1 and C, and D1 and D, i.e. the same name is C effectively used for each pair (for all pairs) C in the routine call. In this case, setting C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD C will give maximum efficiency. C C Input/Output Parameters C C N1 (input) INTEGER C The number of state variables in the first system, i.e. C the order of the matrix A1, the number of rows of B1 and C the number of columns of C1. N1 >= 0. C C M1 (input) INTEGER C The number of input variables in the first system, i.e. C the number of columns of matrices B1 and D1. M1 >= 0. C C P1 (input) INTEGER C The number of output variables in the first system, i.e. C the number of rows of matrices C1 and D1. P1 >= 0. C C N2 (input) INTEGER C The number of state variables in the second system, i.e. C the order of the matrix A2, the number of rows of B2 and C the number of columns of C2. N2 >= 0. C C M2 (input) INTEGER C The number of input variables in the second system, i.e. C the number of columns of matrices B2 and D2. M2 >= 0. C C P2 (input) INTEGER C The number of output variables in the second system, i.e. C the number of rows of matrices C2 and D2. P2 >= 0. C C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) C The leading N1-by-N1 part of this array must contain the C state transition matrix A1 for the first system. C C LDA1 INTEGER C The leading dimension of array A1. LDA1 >= MAX(1,N1). C C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) C The leading N1-by-M1 part of this array must contain the C input/state matrix B1 for the first system. C C LDB1 INTEGER C The leading dimension of array B1. LDB1 >= MAX(1,N1). C C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) C The leading P1-by-N1 part of this array must contain the C state/output matrix C1 for the first system. C C LDC1 INTEGER C The leading dimension of array C1. C LDC1 >= MAX(1,P1) if N1 > 0. C LDC1 >= 1 if N1 = 0. C C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) C The leading P1-by-M1 part of this array must contain the C input/output matrix D1 for the first system. C C LDD1 INTEGER C The leading dimension of array D1. LDD1 >= MAX(1,P1). C C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) C The leading N2-by-N2 part of this array must contain the C state transition matrix A2 for the second system. C C LDA2 INTEGER C The leading dimension of array A2. LDA2 >= MAX(1,N2). C C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M2) C The leading N2-by-M2 part of this array must contain the C input/state matrix B2 for the second system. C C LDB2 INTEGER C The leading dimension of array B2. LDB2 >= MAX(1,N2). C C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) C The leading P2-by-N2 part of this array must contain the C state/output matrix C2 for the second system. C C LDC2 INTEGER C The leading dimension of array C2. C LDC2 >= MAX(1,P2) if N2 > 0. C LDC2 >= 1 if N2 = 0. C C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M2) C The leading P2-by-M2 part of this array must contain the C input/output matrix D2 for the second system. C C LDD2 INTEGER C The leading dimension of array D2. LDD2 >= MAX(1,P2). C C N (output) INTEGER C The number of state variables (N1 + N2) in the resulting C system, i.e. the order of the matrix A, the number of rows C of B and the number of columns of C. C C M (output) INTEGER C The number of input variables (M1 + M2) in the resulting C system, i.e. the number of columns of B and D. C C P (output) INTEGER C The number of output variables (P1 + P2) of the resulting C system, i.e. the number of rows of C and D. C C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) C The leading N-by-N part of this array contains the state C transition matrix A for the resulting system. C The array A can overlap A1 if OVER = 'O'. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N1+N2). C C B (output) DOUBLE PRECISION array, dimension (LDB,M1+M2) C The leading N-by-M part of this array contains the C input/state matrix B for the resulting system. C The array B can overlap B1 if OVER = 'O'. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N1+N2). C C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) C The leading P-by-N part of this array contains the C state/output matrix C for the resulting system. C The array C can overlap C1 if OVER = 'O'. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,P1+P2) if N1+N2 > 0. C LDC >= 1 if N1+N2 = 0. C C D (output) DOUBLE PRECISION array, dimension (LDD,M1+M2) C The leading P-by-M part of this array contains the C input/output matrix D for the resulting system. C The array D can overlap D1 if OVER = 'O'. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P1+P2). 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 matrices of the resulting systems are determined as: C C ( A1 0 ) ( B1 0 ) C A = ( ) , B = ( ) , C ( 0 A2 ) ( 0 B2 ) C C ( C1 0 ) ( D1 0 ) C C = ( ) , D = ( ) . C ( 0 C2 ) ( 0 D2 ) C C REFERENCES C C None C C CONTRIBUTORS C C A. Varga, German Aerospace Research Establishment, C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, C Belgium, Nov. 1996. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. C C KEYWORDS C C Multivariable system, state-space model, state-space C representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO=0.0D0 ) C .. Scalar Arguments .. CHARACTER OVER INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, $ LDC1, LDC2, LDD, LDD1, LDD2, M, M1, M2, N, N1, $ N2, P, P1, P2 C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) C .. Local Scalars .. LOGICAL LOVER INTEGER I, J C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLACPY, DLASET, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C LOVER = LSAME( OVER, 'O' ) N = N1 + N2 M = M1 + M2 P = P1 + P2 INFO = 0 C C Test the input scalar arguments. C IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN INFO = -1 ELSE IF( N1.LT.0 ) THEN INFO = -2 ELSE IF( M1.LT.0 ) THEN INFO = -3 ELSE IF( P1.LT.0 ) THEN INFO = -4 ELSE IF( N2.LT.0 ) THEN INFO = -5 ELSE IF( M2.LT.0 ) THEN INFO = -6 ELSE IF( P2.LT.0 ) THEN INFO = -7 ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN INFO = -9 ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN INFO = -11 ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN INFO = -13 ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN INFO = -15 ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN INFO = -17 ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN INFO = -19 ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P2 ) ) .OR. $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN INFO = -21 ELSE IF( LDD2.LT.MAX( 1, P2 ) ) THEN INFO = -23 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -28 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -30 ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN INFO = -32 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -34 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB05QD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, MIN( M, P ) ).EQ.0 ) $ RETURN C ( A1 0 ) C Construct A = ( ) . C ( 0 A2 ) C IF ( LOVER .AND. LDA1.LE.LDA ) THEN IF ( LDA1.LT.LDA ) THEN C DO 20 J = N1, 1, -1 DO 10 I = N1, 1, -1 A(I,J) = A1(I,J) 10 CONTINUE 20 CONTINUE C END IF ELSE CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) END IF C IF ( N2.GT.0 ) THEN CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1+1), LDA ) CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1+1,1), LDA ) CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) END IF C C ( B1 0 ) C Construct B = ( ) . C ( 0 B2 ) C IF ( LOVER .AND. LDB1.LE.LDB ) THEN IF ( LDB1.LT.LDB ) THEN C DO 40 J = M1, 1, -1 DO 30 I = N1, 1, -1 B(I,J) = B1(I,J) 30 CONTINUE 40 CONTINUE C END IF ELSE CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) END IF C IF ( M2.GT.0 ) $ CALL DLASET( 'F', N1, M2, ZERO, ZERO, B(1,M1+1), LDB ) IF ( N2.GT.0 ) THEN CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) IF ( M2.GT.0 ) $ CALL DLACPY( 'F', N2, M2, B2, LDB2, B(N1+1,M1+1), LDB ) END IF C C ( C1 0 ) C Construct C = ( ) . C ( 0 C2 ) C IF ( LOVER .AND. LDC1.LE.LDC ) THEN IF ( LDC1.LT.LDC ) THEN C DO 60 J = N1, 1, -1 DO 50 I = P1, 1, -1 C(I,J) = C1(I,J) 50 CONTINUE 60 CONTINUE C END IF ELSE CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) END IF C IF ( N2.GT.0 ) $ CALL DLASET( 'F', P1, N2, ZERO, ZERO, C(1,N1+1), LDC ) IF ( P2.GT.0 ) THEN IF ( N1.GT.0 ) $ CALL DLASET( 'F', P2, N1, ZERO, ZERO, C(P1+1,1), LDC ) IF ( N2.GT.0 ) $ CALL DLACPY( 'F', P2, N2, C2, LDC2, C(P1+1,N1+1), LDC ) END IF C C ( D1 0 ) C Construct D = ( ) . C ( 0 D2 ) C IF ( LOVER .AND. LDD1.LE.LDD ) THEN IF ( LDD1.LT.LDD ) THEN C DO 80 J = M1, 1, -1 DO 70 I = P1, 1, -1 D(I,J) = D1(I,J) 70 CONTINUE 80 CONTINUE C END IF ELSE CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) END IF C IF ( M2.GT.0 ) $ CALL DLASET( 'F', P1, M2, ZERO, ZERO, D(1,M1+1), LDD ) IF ( P2.GT.0 ) THEN CALL DLASET( 'F', P2, M1, ZERO, ZERO, D(P1+1,1), LDD ) IF ( M2.GT.0 ) $ CALL DLACPY( 'F', P2, M2, D2, LDD2, D(P1+1,M1+1), LDD ) END IF C RETURN C *** Last line of AB05QD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10FD.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10FD.f0000644000175000017500000004101215012430707017346 0ustar00lilgelilge00000000000000 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 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 control-4.1.2/src/slicot/src/PaxHeaders/MB05MY.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB05MY.f0000644000175000017500000002554615012430707017416 0ustar00lilgelilge00000000000000 SUBROUTINE MB05MY( BALANC, N, A, LDA, WR, WI, R, LDR, Q, LDQ, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute, for an N-by-N real nonsymmetric matrix A, the C orthogonal matrix Q reducing it to real Schur form T, the C eigenvalues, and the right eigenvectors of T. C C The right eigenvector r(j) of T satisfies C T * r(j) = lambda(j) * r(j) C where lambda(j) is its eigenvalue. C C The matrix of right eigenvectors R is upper triangular, by C construction. C C ARGUMENTS C C Mode Parameters C C BALANC CHARACTER*1 C Indicates how the input matrix should be diagonally scaled C to improve the conditioning of its eigenvalues as follows: C = 'N': Do not diagonally scale; C = 'S': Diagonally scale the matrix, i.e. replace A by C D*A*D**(-1), where D is a diagonal matrix chosen C to make the rows and columns of A more equal in C norm. Do not permute. 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 part of this array must C contain the given matrix A. C On exit, the leading N-by-N upper quasi-triangular part of C this array contains the real Schur canonical form of A. C C LDA INTEGER C The leading dimension of array A. LDA >= max(1,N). C C WR (output) DOUBLE PRECISION array, dimension (N) C WI (output) DOUBLE PRECISION array, dimension (N) C WR and WI contain the real and imaginary parts, C respectively, of the computed eigenvalues. Complex C conjugate pairs of eigenvalues appear consecutively C with the eigenvalue having the positive imaginary part C first. C C R (output) DOUBLE PRECISION array, dimension (LDR,N) C The leading N-by-N upper triangular part of this array C contains the matrix of right eigenvectors R, in the same C order as their eigenvalues. The real and imaginary parts C of a complex eigenvector corresponding to an eigenvalue C with positive imaginary part are stored in consecutive C columns. (The corresponding conjugate eigenvector is not C stored.) The eigenvectors are not backward transformed C for balancing (when BALANC = 'S'). C C LDR INTEGER C The leading dimension of array R. LDR >= max(1,N). C C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) C The leading N-by-N part of this array contains the C orthogonal matrix Q which has reduced A to real Schur C form. C C LDQ INTEGER C The leading dimension of array Q. LDQ >= MAX(1,N). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C If BALANC = 'S' and LDWORK > 0, DWORK(2),...,DWORK(N+1) C return the scaling factors used for balancing. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= max(1,4*N). C For good performance, LDWORK must generally 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 > 0: if INFO = i, the QR algorithm failed to compute all C the eigenvalues, and no eigenvectors have been C computed; elements i+1:N of WR and WI contain C eigenvalues which have converged. C C METHOD C C This routine uses the QR algorithm to obtain the real Schur form C T of matrix A. Then, the right eigenvectors of T are computed, C but they are not backtransformed into the eigenvectors of A. C MB05MY is a modification of the LAPACK driver routine DGEEV. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. C Supersedes Release 2.0 routine MB05AY. C C REVISIONS C C V. Sima, April 25, 2003, Feb. 15, 2004, Aug. 2011. C C KEYWORDS C C Eigenvalue, eigenvector decomposition, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER BALANC INTEGER INFO, LDA, LDQ, LDR, LDWORK, N C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), DWORK( * ), Q( LDQ, * ), $ R( LDR, * ), WI( * ), WR( * ) C .. C .. Local Scalars .. LOGICAL LQUERY, SCALE, SCALEA INTEGER IBAL, IERR, IHI, ILO, ITAU, JWORK, K, MAXWRK, $ MINWRK, NOUT DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM C .. C .. Local Arrays .. LOGICAL SELECT( 1 ) DOUBLE PRECISION DUM( 1 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. C .. External Subroutines .. EXTERNAL DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, DLASCL, $ DORGHR, DTREVC, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, SQRT C .. C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 SCALE = LSAME( BALANC, 'S' ) IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 HSDWOR refers to the workspace preferred by DHSEQR; it is C computed assuming ILO=1 and IHI=N, the worst case.) C MINWRK = MAX( 1, 4*N ) LQUERY = LDWORK.EQ.-1 IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -12 ELSE IF( LQUERY ) THEN CALL DGEHRD( N, 1, N, A, LDA, DWORK, DWORK, -1, INFO ) MAXWRK = INT( DWORK( 1 ) ) CALL DORGHR( N, 1, N, Q, LDQ, DWORK, DWORK, -1, INFO ) MAXWRK = 2*N + MAX( MAXWRK, INT( DWORK( 1 ) ) ) CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, Q, LDQ, $ DWORK, -1, INFO ) MAXWRK = MAX( MAXWRK, N + INT( DWORK( 1 ) ), MINWRK ) END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB05MY', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK( 1 ) = MAXWRK RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK( 1 ) = ONE RETURN END IF C C Get machine constants. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM C C Scale A if max element outside range [SMLNUM,BIGNUM]. C ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) SCALEA = .FALSE. IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN SCALEA = .TRUE. CSCALE = SMLNUM ELSE IF( ANRM.GT.BIGNUM ) THEN SCALEA = .TRUE. CSCALE = BIGNUM END IF IF( SCALEA ) $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) C C Balance the matrix, if requested. (Permutation is not possible.) C (Workspace: need N) C IBAL = 1 CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, DWORK( IBAL ), IERR ) C C Reduce to upper Hessenberg form. C (Workspace: need 3*N, prefer 2*N+N*NB) C ITAU = IBAL + N JWORK = ITAU + N CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK( ITAU ), DWORK( JWORK ), $ LDWORK-JWORK+1, IERR ) MAXWRK = INT( DWORK( JWORK ) ) C C Compute right eigenvectors of T. C Copy Householder vectors to Q. C CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ ) C C Generate orthogonal matrix in Q. C (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) C CALL DORGHR( N, ILO, IHI, Q, LDQ, DWORK( ITAU ), DWORK( JWORK ), $ LDWORK-JWORK+1, IERR ) MAXWRK = 2*N + MAX( MAXWRK, INT( DWORK( JWORK ) ) ) C C Perform QR iteration, accumulating Schur vectors in Q. C (Workspace: need N+1, prefer N+HSDWOR (see comments) ) C JWORK = ITAU CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, Q, LDQ, $ DWORK( JWORK ), LDWORK-JWORK+1, INFO ) MAXWRK = MAX( MAXWRK, N + INT( DWORK( JWORK ) ), MINWRK ) C C If INFO > 0 from DHSEQR, then quit. C IF( INFO.GT.0 ) $ GO TO 10 C C Compute right eigenvectors of T in R. C (Workspace: need 4*N) C CALL DTREVC( 'Right', 'All', SELECT, N, A, LDA, DUM, 1, R, LDR, N, $ NOUT, DWORK( JWORK ), IERR ) C C Undo scaling if necessary. C 10 CONTINUE IF( SCALEA ) THEN CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), $ MAX( N-INFO, 1 ), IERR ) CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), $ MAX( N-INFO, 1 ), IERR ) IF( INFO.GT.0 ) THEN CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, $ IERR ) CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, $ IERR ) END IF END IF C IF ( SCALE ) THEN DO 20 K = N, 1, -1 DWORK( K+1 ) = DWORK( K ) 20 CONTINUE END IF DWORK( 1 ) = MAXWRK C RETURN C *** Last line of MB05MY *** END control-4.1.2/src/slicot/src/PaxHeaders/TF01RD.f0000644000000000000000000000013215012430707016175 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TF01RD.f0000644000175000017500000001444315012430707017377 0ustar00lilgelilge00000000000000 SUBROUTINE TF01RD( NA, NB, NC, N, A, LDA, B, LDB, C, LDC, H, LDH, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute N Markov parameters M(1), M(2),..., M(N) from the C parameters (A,B,C) of a linear time-invariant system, where each C M(k) is an NC-by-NB matrix and k = 1,2,...,N. C C All matrices are treated as dense, and hence TF01RD is not C intended for large sparse problems. C C ARGUMENTS C C Input/Output Parameters C C NA (input) INTEGER C The order of the matrix A. NA >= 0. C C NB (input) INTEGER C The number of system inputs. NB >= 0. C C NC (input) INTEGER C The number of system outputs. NC >= 0. C C N (input) INTEGER C The number of Markov parameters M(k) to be computed. C N >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,NA) C The leading NA-by-NA part of this array must contain the C state matrix A of the system. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,NA). C C B (input) DOUBLE PRECISION array, dimension (LDB,NB) C The leading NA-by-NB part of this array must contain the C input matrix B of the system. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,NA). C C C (input) DOUBLE PRECISION array, dimension (LDC,NA) C The leading NC-by-NA part of this array must contain the C output matrix C of the system. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,NC). C C H (output) DOUBLE PRECISION array, dimension (LDH,N*NB) C The leading NC-by-N*NB part of this array contains the C multivariable parameters M(k), where each parameter M(k) C is an NC-by-NB matrix and k = 1,2,...,N. The Markov C parameters are stored such that H(i,(k-1)xNB+j) contains C the (i,j)-th element of M(k) for i = 1,2,...,NC and C j = 1,2,...,NB. C C LDH INTEGER C The leading dimension of array H. LDH >= MAX(1,NC). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1, 2*NA*NC). 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 For the linear time-invariant discrete-time system C C x(k+1) = A x(k) + B u(k) C y(k) = C x(k) + D u(k), C C the transfer function matrix G(z) is given by C -1 C G(z) = C(zI-A) B + D C -1 -2 2 -3 C = D + CB z + CAB z + CA B z + ... (1) C C Using Markov parameters, G(z) can also be written as C -1 -2 -3 C G(z) = M(0) + M(1)z + M(2)z + M(3)z + ... (2) C C k-1 C Equating (1) and (2), we find that M(0) = D and M(k) = C A B C for k > 0, from which the Markov parameters M(1),M(2)...,M(N) are C computed. C C REFERENCES C C [1] Chen, C.T. C Introduction to Linear System Theory. C H.R.W. Series in Electrical Engineering, Electronics and C Systems, Holt, Rinehart and Winston Inc., London, 1970. C C NUMERICAL ASPECTS C C The algorithm requires approximately (NA + NB) x NA x NC x N C multiplications and additions. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TF01FD by S. Van Huffel, Katholieke C Univ. Leuven, Belgium. C C REVISIONS C C - C C KEYWORDS C C Markov parameters, multivariable system, time-invariant system, C transfer function, transfer matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDH, LDWORK, N, NA, NB, NC C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), H(LDH,*) C .. Local Scalars .. INTEGER I, JWORK, K, LDW C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C IF( NA.LT.0 ) THEN INFO = -1 ELSE IF( NB.LT.0 ) THEN INFO = -2 ELSE IF( NC.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, NA ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, NA ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, NC ) ) THEN INFO = -10 ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN INFO = -12 ELSE IF( LDWORK.LT.MAX( 1, 2*NA*NC ) ) THEN INFO = -14 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TF01RD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( NA, NB, NC, N ).EQ.0 ) $ RETURN C JWORK = 1 + NC*NA LDW = MAX( 1, NC ) I = 1 C C Copy C in the workspace beginning from the position JWORK. C This workspace will contain the product C*A**(K-1), K = 1,2,...,N. C CALL DLACPY( 'Full', NC, NA, C, LDC, DWORK(JWORK), LDW ) C C Form M(1), M(2), ..., M(N). C DO 10 K = 1, N CALL DLACPY( 'Full', NC, NA, DWORK(JWORK), LDW, DWORK, LDW ) C C Form (C * A**(K-1)) * B = M(K). C CALL DGEMM( 'No transpose', 'No transpose', NC, NB, NA, ONE, $ DWORK, LDW, B, LDB, ZERO, H(1,I), LDH ) C IF ( K.NE.N ) THEN C C Form C * A**K. C CALL DGEMM( 'No transpose', 'No transpose', NC, NA, NA, ONE, $ DWORK, LDW, A, LDA, ZERO, DWORK(JWORK), LDW ) C I = I + NB END IF 10 CONTINUE C RETURN C *** Last line of TF01RD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02OX.f0000644000000000000000000000013015012430707016210 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB02OX.f0000644000175000017500000000325215012430707017410 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION SB02OX( ALPHAR, ALPHAI, BETA ) C C PURPOSE C C To select the stable generalized eigenvalues for solving the C discrete-time algebraic Riccati equation. C C ARGUMENTS C C Input/Output Parameters C C ALPHAR (input) DOUBLE PRECISION C The real part of the numerator of the current eigenvalue C considered. C C ALPHAI (input) DOUBLE PRECISION C The imaginary part of the numerator of the current C eigenvalue considered. C C BETA (input) DOUBLE PRECISION C The (real) denominator of the current eigenvalue C considered. C C METHOD C C The function value SB02OX is set to .TRUE. for a stable eigenvalue C (i.e., with modulus less than one) and to .FALSE., otherwise. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. C Supersedes Release 2.0 routine SB02CX by P. Van Dooren, Philips C Research Laboratory, Brussels, Belgium. C C REVISIONS C C - C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, optimal regulator, Schur form. C C ****************************************************************** C C .. Scalar Arguments .. DOUBLE PRECISION ALPHAR, ALPHAI, BETA C .. External Functions .. DOUBLE PRECISION DLAPY2 EXTERNAL DLAPY2 C .. Intrinsic Functions .. INTRINSIC ABS C .. Executable Statements .. C SB02OX = DLAPY2( ALPHAR, ALPHAI ).LT.ABS( BETA ) C RETURN C *** Last line of SB02OX *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10KD.f0000644000000000000000000000013215012430707016161 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10KD.f0000644000175000017500000005070615012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE SB10KD( N, M, NP, A, LDA, B, LDB, C, LDC, FACTOR, $ AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, RCOND, $ IWORK, DWORK, LDWORK, BWORK, INFO ) C C PURPOSE C C To compute the matrices of the positive feedback controller C C | Ak | Bk | C K = |----|----| C | Ck | Dk | C C for the shaped plant C C | A | B | C G = |---|---| C | C | 0 | C C in the Discrete-Time Loop Shaping Design Procedure. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the plant. 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 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 of the shaped plant. 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 of the shaped plant. 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 of the shaped plant. C C LDC INTEGER C The leading dimension of the array C. LDC >= max(1,NP). C C FACTOR (input) DOUBLE PRECISION C = 1 implies that an optimal controller is required; C > 1 implies that a suboptimal controller is required C achieving a performance FACTOR less than optimal. C FACTOR >= 1. 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,NP) C The leading N-by-NP 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 M-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. LDCK >= max(1,M). C C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) C The leading M-by-NP part of this array contains the C controller matrix Dk. C C LDDK INTEGER C The leading dimension of the array DK. LDDK >= max(1,M). C C RCOND (output) DOUBLE PRECISION array, dimension (4) C RCOND(1) contains an estimate of the reciprocal condition C number of the linear system of equations from C which the solution of the P-Riccati equation is C obtained; C RCOND(2) contains an estimate of the reciprocal condition C number of the linear system of equations from C which the solution of the Q-Riccati equation is C obtained; C RCOND(3) contains an estimate of the reciprocal condition C number of the linear system of equations from C which the solution of the X-Riccati equation is C obtained; C RCOND(4) contains an estimate of the reciprocal condition C number of the matrix Rx + Bx'*X*Bx (see the C comments in the code). C C Workspace C C IWORK INTEGER array, dimension (2*max(N,NP+M)) 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 >= 15*N*N + 6*N + C max( 14*N+23, 16*N, 2*N+NP+M, 3*(NP+M) ) + C max( N*N, 11*N*NP + 2*M*M + 8*NP*NP + 8*M*N + C 4*M*NP + NP ). C For good performance, LDWORK must generally be larger. 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: the P-Riccati equation is not solved successfully; C = 2: the Q-Riccati equation is not solved successfully; C = 3: the X-Riccati equation is not solved successfully; C = 4: the iteration to compute eigenvalues failed to C converge; C = 5: the matrix Rx + Bx'*X*Bx is singular; C = 6: the closed-loop system is unstable. C C METHOD C C The routine implements the method presented in [1]. C C REFERENCES C C [1] McFarlane, D. and Glover, K. C A loop shaping design procedure using H_infinity synthesis. C IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769, C 1992. C C NUMERICAL ASPECTS C C The accuracy of the results depends on the conditioning of the C two Riccati equations solved in the controller design. For C better conditioning it is advised to take FACTOR > 1. C C CONTRIBUTORS C C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 2000. C C REVISIONS C C V. Sima, Katholieke University Leuven, January 2001, C February 2001. C C KEYWORDS C C H_infinity control, Loop-shaping design, Robust 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, LDDK, $ LDWORK, M, N, NP DOUBLE PRECISION FACTOR C .. C .. Array Arguments .. INTEGER IWORK( * ) LOGICAL BWORK( * ) DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), $ DK( LDDK, * ), DWORK( * ), RCOND( 4 ) C .. C .. Local Scalars .. INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, $ I11, I12, I13, I14, I15, I16, I17, I18, I19, $ I20, I21, I22, I23, I24, I25, I26, INFO2, $ IWRK, J, LWA, LWAMAX, MINWRK, N2, NS, SDIM DOUBLE PRECISION GAMMA, RNORM C .. C .. External Functions .. LOGICAL SELECT DOUBLE PRECISION DLANSY, DLAPY2 EXTERNAL DLANSY, DLAPY2, SELECT C .. C .. External Subroutines .. EXTERNAL DGEMM, DGEES, DLACPY, DLASET, DPOTRF, DPOTRS, $ DSYCON, DSYEV, DSYRK, DSYTRF, DSYTRS, SB02OD, $ XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, SQRT C .. C .. Executable Statements .. C C Decode and Test input parameters. 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -9 ELSE IF( FACTOR.LT.ONE ) THEN INFO = -10 ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN INFO = -16 ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN INFO = -18 END IF C C Compute workspace. C MINWRK = 15*N*N + 6*N + MAX( 14*N+23, 16*N, 2*N+NP+M, 3*(NP+M) ) + $ MAX( N*N, 11*N*NP + 2*M*M + 8*NP*NP + 8*M*N + $ 4*M*NP + NP ) IF( LDWORK.LT.MINWRK ) THEN INFO = -22 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10KD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN RCOND( 1 ) = ONE RCOND( 2 ) = ONE RCOND( 3 ) = ONE RCOND( 4 ) = ONE DWORK( 1 ) = ONE RETURN END IF C C Workspace usage. C N2 = 2*N I1 = N*N I2 = I1 + N*N I3 = I2 + N*N I4 = I3 + N*N I5 = I4 + N2 I6 = I5 + N2 I7 = I6 + N2 I8 = I7 + N2*N2 I9 = I8 + N2*N2 C IWRK = I9 + N2*N2 LWAMAX = 0 C C Compute Cr = C'*C . C CALL DSYRK( 'U', 'T', N, NP, ONE, C, LDC, ZERO, DWORK( I2+1 ), N ) C C Compute Dr = B*B' . C CALL DSYRK( 'U', 'N', N, M, ONE, B, LDB, ZERO, DWORK( I3+1 ), N ) C -1 C Solution of the Riccati equation A'*P*(In + Dr*P) *A - P + Cr = 0. C CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, A, LDA, $ DWORK( I3+1 ), N, DWORK( I2+1 ), N, DWORK, M, DWORK, $ N, RCOND( 1 ), DWORK, N, DWORK( I4+1 ), $ DWORK( I5+1 ), DWORK( I6+1 ), DWORK( I7+1 ), N2, $ DWORK( I8+1 ), N2, DWORK( I9+1 ), N2, -ONE, IWORK, $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 1 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX ) C C Transpose A in AK (used as workspace). C DO 40 J = 1, N DO 30 I = 1, N AK( I,J ) = A( J,I ) 30 CONTINUE 40 CONTINUE C -1 C Solution of the Riccati equation A*Q*(In + Cr*Q) *A' - Q + Dr = 0. C CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, AK, LDAK, $ DWORK( I2+1 ), N, DWORK( I3+1 ), N, DWORK, M, DWORK, $ N, RCOND( 2 ), DWORK( I1+1 ), N, DWORK( I4+1 ), $ DWORK( I5+1 ), DWORK( I6+1 ), DWORK( I7+1 ), N2, $ DWORK( I8+1 ), N2, DWORK( I9+1 ), N2, -ONE, IWORK, $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 2 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX ) C C Compute gamma. C CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1+1 ), N, DWORK, N, $ ZERO, AK, LDAK ) CALL DGEES( 'N', 'N', SELECT, N, AK, LDAK, SDIM, DWORK( I6+1 ), $ DWORK( I7+1 ), DWORK( IWRK+1 ), N, DWORK( IWRK+1 ), $ LDWORK-IWRK, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 4 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX ) GAMMA = ZERO DO 50 I = 1, N GAMMA = MAX( GAMMA, DWORK( I6+I ) ) 50 CONTINUE GAMMA = FACTOR*SQRT( ONE + GAMMA ) C C Workspace usage. C I3 = I2 + N*NP I4 = I3 + NP*NP I5 = I4 + NP*NP I6 = I5 + NP*NP I7 = I6 + NP I8 = I7 + NP*NP I9 = I8 + NP*NP I10 = I9 + NP*NP I11 = I10 + N*NP I12 = I11 + N*NP I13 = I12 + ( NP+M )*( NP+M ) I14 = I13 + N*( NP+M ) I15 = I14 + N*( NP+M ) I16 = I15 + N*N I17 = I16 + N2 I18 = I17 + N2 I19 = I18 + N2 I20 = I19 + ( N2+NP+M )*( N2+NP+M ) I21 = I20 + ( N2+NP+M )*N2 C IWRK = I21 + N2*N2 C C Compute Q*C' . C CALL DGEMM( 'N', 'T', N, NP, N, ONE, DWORK( I1+1 ), N, C, LDC, $ ZERO, DWORK( I2+1 ), N ) C C Compute Ip + C*Q*C' . C CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK( I3+1 ), NP ) CALL DGEMM( 'N', 'N', NP, NP, N, ONE, C, LDC, DWORK( I2+1 ), N, $ ONE, DWORK( I3+1 ), NP ) C C Compute the eigenvalues and eigenvectors of Ip + C'*Q*C C CALL DLACPY( 'U', NP, NP, DWORK( I3+1 ), NP, DWORK( I5+1 ), NP ) CALL DSYEV( 'V', 'U', NP, DWORK( I5+1 ), NP, DWORK( I6+1 ), $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 4 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX ) C -1 C Compute ( Ip + C'*Q*C ) . C DO 70 J = 1, NP DO 60 I = 1, NP DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP ) / $ DWORK( I6+I ) 60 CONTINUE 70 CONTINUE CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, $ DWORK( I9+1 ), NP, ZERO, DWORK( I4+1 ), NP ) C C Compute Z2 . C DO 90 J = 1, NP DO 80 I = 1, NP DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP ) / $ SQRT( DWORK( I6+I ) ) 80 CONTINUE 90 CONTINUE CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, $ DWORK( I9+1 ), NP, ZERO, DWORK( I7+1 ), NP ) C -1 C Compute Z2 . C DO 110 J = 1, NP DO 100 I = 1, NP DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP )* $ SQRT( DWORK( I6+I ) ) 100 CONTINUE 110 CONTINUE CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, $ DWORK( I9+1 ), NP, ZERO, DWORK( I8+1 ), NP ) C C Compute A*Q*C' . C CALL DGEMM( 'N', 'N', N, NP, N, ONE, A, LDA, DWORK( I2+1 ), N, $ ZERO, DWORK( I10+1 ), N ) C -1 C Compute H = -A*Q*C'*( Ip + C*Q*C' ) . C CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I10+1 ), N, $ DWORK( I4+1 ), NP, ZERO, DWORK( I11+1 ), N ) C C Compute Rx . C CALL DLASET( 'F', NP+M, NP+M, ZERO, ONE, DWORK( I12+1 ), NP+M ) DO 130 J = 1, NP DO 120 I = 1, NP DWORK( I12+I+(J-1)*(NP+M) ) = DWORK( I3+I+(J-1)*NP ) 120 CONTINUE DWORK( I12+J+(J-1)*(NP+M) ) = DWORK( I3+J+(J-1)*NP ) - $ GAMMA*GAMMA 130 CONTINUE C C Compute Bx . C CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I11+1 ), N, $ DWORK( I8+1 ), NP, ZERO, DWORK( I13+1 ), N ) DO 150 J = 1, M DO 140 I = 1, N DWORK( I13+N*NP+I+(J-1)*N ) = B( I, J ) 140 CONTINUE 150 CONTINUE C C Compute Sx . C CALL DGEMM( 'T', 'N', N, NP, NP, ONE, C, LDC, DWORK( I8+1 ), NP, $ ZERO, DWORK( I14+1 ), N ) CALL DLASET( 'F', N, M, ZERO, ZERO, DWORK( I14+N*NP+1 ), N ) C C Solve the Riccati equation C -1 C X = A'*X*A + Cx - (Sx + A'*X*Bx)*(Rx + Bx'*X*B ) *(Sx'+Bx'*X*A). C CALL SB02OD( 'D', 'B', 'C', 'U', 'N', 'S', N, NP+M, NP, A, LDA, $ DWORK( I13+1 ), N, C, LDC, DWORK( I12+1 ), NP+M, $ DWORK( I14+1 ), N, RCOND( 3 ), DWORK( I15+1 ), N, $ DWORK( I16+1 ), DWORK( I17+1 ), DWORK( I18+1 ), $ DWORK( I19+1 ), N2+NP+M, DWORK( I20+1 ), N2+NP+M, $ DWORK( I21+1 ), N2, -ONE, IWORK, DWORK( IWRK+1 ), $ LDWORK-IWRK, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX ) C I22 = I16 I23 = I22 + ( NP+M )*N I24 = I23 + ( NP+M )*( NP+M ) I25 = I24 + ( NP+M )*N I26 = I25 + M*N C IWRK = I25 C C Compute Bx'*X . C CALL DGEMM( 'T', 'N', NP+M, N, N, ONE, DWORK( I13+1 ), N, $ DWORK( I15+1 ), N, ZERO, DWORK( I22+1 ), NP+M ) C C Compute Rx + Bx'*X*Bx . C CALL DLACPY( 'F', NP+M, NP+M, DWORK( I12+1 ), NP+M, $ DWORK( I23+1 ), NP+M ) CALL DGEMM( 'N', 'N', NP+M, NP+M, N, ONE, DWORK( I22+1 ), NP+M, $ DWORK( I13+1 ), N, ONE, DWORK( I23+1 ), NP+M ) C C Compute -( Sx' + Bx'*X*A ) . C DO 170 J = 1, N DO 160 I = 1, NP+M DWORK( I24+I+(J-1)*(NP+M) ) = DWORK( I14+J+(I-1)*N ) 160 CONTINUE 170 CONTINUE CALL DGEMM( 'N', 'N', NP+M, N, N, -ONE, DWORK( I22+1 ), NP+M, $ A, LDA, -ONE, DWORK( I24+1 ), NP+M ) C C Factorize Rx + Bx'*X*Bx . C RNORM = DLANSY( '1', 'U', NP+M, DWORK( I23+1 ), NP+M, $ DWORK( IWRK+1 ) ) CALL DSYTRF( 'U', NP+M, DWORK( I23+1 ), NP+M, IWORK, $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 5 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX ) CALL DSYCON( 'U', NP+M, DWORK( I23+1 ), NP+M, IWORK, RNORM, $ RCOND( 4 ), DWORK( IWRK+1 ), IWORK( NP+M+1), INFO2 ) C -1 C Compute F = -( Rx + Bx'*X*Bx ) ( Sx' + Bx'*X*A ) . C CALL DSYTRS( 'U', NP+M, N, DWORK( I23+1 ), NP+M, IWORK, $ DWORK( I24+1 ), NP+M, INFO2 ) C C Compute B'*X . C CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK( I15+1 ), N, $ ZERO, DWORK( I25+1 ), M ) C C Compute Im + B'*X*B . C CALL DLASET( 'F', M, M, ZERO, ONE, DWORK( I23+1 ), M ) CALL DGEMM( 'N', 'N', M, M, N, ONE, DWORK( I25+1 ), M, B, LDB, $ ONE, DWORK( I23+1 ), M ) C C Factorize Im + B'*X*B . C CALL DPOTRF( 'U', M, DWORK( I23+1 ), M, INFO2 ) C -1 C Compute ( Im + B'*X*B ) B'*X . C CALL DPOTRS( 'U', M, N, DWORK( I23+1 ), M, DWORK( I25+1 ), M, $ INFO2 ) C -1 C Compute Dk = ( Im + B'*X*B ) B'*X*H . C CALL DGEMM( 'N', 'N', M, NP, N, ONE, DWORK( I25+1 ), M, $ DWORK( I11+1 ), N, ZERO, DK, LDDK ) C C Compute Bk = -H + B*Dk . C CALL DLACPY( 'F', N, NP, DWORK( I11+1 ), N, BK, LDBK ) CALL DGEMM( 'N', 'N', N, NP, M, ONE, B, LDB, DK, LDDK, -ONE, $ BK, LDBK ) C -1 C Compute Dk*Z2 . C CALL DGEMM( 'N', 'N', M, NP, NP, ONE, DK, LDDK, DWORK( I8+1 ), $ NP, ZERO, DWORK( I26+1 ), M ) C C Compute F1 + Z2*C . C CALL DLACPY( 'F', NP, N, DWORK( I24+1 ), NP+M, DWORK( I12+1 ), $ NP ) CALL DGEMM( 'N', 'N', NP, N, NP, ONE, DWORK( I7+1 ), NP, C, LDC, $ ONE, DWORK( I12+1 ), NP ) C -1 C Compute Ck = F2 - Dk*Z2 *( F1 + Z2*C ) . C CALL DLACPY( 'F', M, N, DWORK( I24+NP+1 ), NP+M, CK, LDCK ) CALL DGEMM( 'N', 'N', M, N, NP, -ONE, DWORK( I26+1 ), M, $ DWORK( I12+1 ), NP, ONE, CK, LDCK ) C C Compute Ak = A + H*C + B*Ck . C CALL DLACPY( 'F', N, N, A, LDA, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I11+1 ), N, C, LDC, $ ONE, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, ONE, AK, $ LDAK ) C C Workspace usage. C I1 = M*N I2 = I1 + N2*N2 I3 = I2 + N2 C IWRK = I3 + N2 C C Compute Dk*C . C CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, $ DWORK, M ) C C Compute the closed-loop state matrix. C CALL DLACPY( 'F', N, N, A, LDA, DWORK( I1+1 ), N2 ) CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, DWORK, M, ONE, $ DWORK( I1+1 ), N2 ) CALL DGEMM( 'N', 'N', N, N, NP, -ONE, BK, LDBK, C, LDC, ZERO, $ DWORK( I1+N+1 ), N2 ) CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, ZERO, $ DWORK( I1+N2*N+1 ), N2 ) CALL DLACPY( 'F', N, N, AK, LDAK, DWORK( I1+N2*N+N+1 ), N2 ) C C Compute the closed-loop poles. C CALL DGEES( 'N', 'N', SELECT, N2, DWORK( I1+1 ), N2, SDIM, $ DWORK( I2+1 ), DWORK( I3+1 ), DWORK( IWRK+1 ), N, $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 4 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX ) C C Check the stability of the closed-loop system. C NS = 0 DO 180 I = 1, N2 IF( DLAPY2( DWORK( I2+I ), DWORK( I3+I ) ).GT.ONE ) NS = NS + 1 180 CONTINUE IF( NS.GT.0 ) THEN INFO = 6 RETURN END IF C DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10KD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03KE.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03KE.f0000644000175000017500000006676515012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE MB03KE( TRANA, TRANB, ISGN, K, M, N, PREC, SMIN, S, A, $ B, C, SCALE, DWORK, LDWORK, INFO ) C C PURPOSE C C To solve small periodic Sylvester-like equations (PSLE) C C op(A(i))*X( i ) + isgn*X(i+1)*op(B(i)) = -scale*C(i), S(i) = 1, C op(A(i))*X(i+1) + isgn*X( i )*op(B(i)) = -scale*C(i), S(i) = -1. C C i = 1, ..., K, where op(A) means A or A**T, for the K-periodic C matrix sequence X(i) = X(i+K), where A, B and C are K-periodic C matrix sequences and A and B are in periodic real Schur form. The C matrices A(i) are M-by-M and B(i) are N-by-N, with 1 <= M, N <= 2. C C ARGUMENTS C C Mode Parameters C C TRANA LOGICAL C Specifies the form of op(A) to be used, as follows: C = .FALSE.: op(A) = A, C = .TRUE. : op(A) = A**T. C C TRANB LOGICAL C Specifies the form of op(B) to be used, as follows: C = .FALSE.: op(B) = B, C = .TRUE. : op(B) = B**T. C C ISGN INTEGER C Specifies which sign variant of the equations to solve. C ISGN = 1 or ISGN = -1. C C Input/Output Parameters C C K (input) INTEGER C The period of the periodic matrix sequences A, B, C and X. C K >= 2. (For K = 1, a standard Sylvester equation is C obtained.) C C M (input) INTEGER C The order of the matrices A(i) and the number of rows of C the matrices C(i) and X(i), i = 1, ..., K. 1 <= M <= 2. C C N (input) INTEGER C The order of the matrices B(i) and the number of columns C of the matrices C(i) and X(i), i = 1, ..., K. C 1 <= N <= 2. C C PREC (input) DOUBLE PRECISION C The relative machine precision. See the LAPACK Library C routine DLAMCH. C C SMIN (input) DOUBLE PRECISION C The machine safe minimum divided by PREC. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures (exponents) of the factors in the K-periodic C matrix sequences for A and B. Each entry in S must be C either 1 or -1. Notice that it is assumed that the same C exponents are tied to both A and B on reduction to the C periodic Schur form. C C A (input) DOUBLE PRECISION array, dimension (M*M*K) C On entry, this array must contain the M-by-M matrices C A(i), for i = 1, ..., K, stored with the leading dimension C M. Matrix A(i) is stored starting at position M*M*(i-1)+1. C C B (input) DOUBLE PRECISION array, dimension (N*N*K) C On entry, this array must contain the N-by-N matrices C B(i), for i = 1, ..., K, stored with the leading dimension C N. Matrix B(i) is stored starting at position N*N*(i-1)+1. C C C (input/output) DOUBLE PRECISION array, dimension (M*N*K) C On entry, this array must contain the M-by-N matrices C C(i), for i = 1, ..., K, stored with the leading dimension C M. Matrix C(i) is stored starting at position M*N*(i-1)+1. C On exit, the matrices C(i) are overwritten by the solution C sequence X(i). C C SCALE (output) DOUBLE PRECISION C The scale factor, scale, set less than or equal to 1 to C avoid overflow in X. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -21, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= (4*K-3) * (M*N)**2 + K * M*N. C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C < 0: if INFO = -21, then LDWORK is too small; appropriate C value for LDWORK is returned in DWORK(1); the other C arguments are not tested, for efficiency; C = 1: the solution would overflow with scale = 1, so C SCALE was set less than 1. This is a warning, not C an error. C C METHOD C C A version of the algorithm described in [1] is used. The routine C uses a sparse Kronecker product representation Z of the PSLE and C solves for X(i) from an associated linear system Z*x = c using C structured (overlapping) variants of QR factorization and backward C substitution. C C REFERENCES C C [1] Granat, R., Kagstrom, B. and Kressner, D. C Computing periodic deflating subspaces associated with a C specified set of eigenvalues. C BIT Numerical Mathematics, vol. 47, 763-791, 2007. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Mar. 2010, an essentially new version of the PEP routine C PEP_DGESY2, by R. Granat, Umea University, Sweden, Apr. 2008. C C REVISIONS C C V. Sima, Apr. 2010, Oct. 2010, Aug. 2011. C C KEYWORDS C C Orthogonal transformation, periodic QZ algorithm, periodic C Sylvester-like equations, QZ algorithm. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) C .. C .. Scalar Arguments .. LOGICAL TRANA, TRANB INTEGER INFO, ISGN, K, LDWORK, M, N DOUBLE PRECISION PREC, SCALE, SMIN C .. C .. Array Arguments .. INTEGER S( * ) DOUBLE PRECISION A( * ), B( * ), C( * ), DWORK( * ) C .. C .. Local Scalars .. LOGICAL DOSCAL, LQUERY INTEGER CB, I, IA1, IA3, IB1, IB3, IC1, II, IM1, IXA, $ IXB, IXC, IZ, J, KM2, KM3, KMN, L, LDW, LEN, $ MINWRK, MM, MN, MN6, MN7, NN, ZC, ZD, ZI, ZI2, $ ZIS DOUBLE PRECISION AC, AD, BETA, BIGNUM, DMIN, ELEM, SCALOC, SGN, $ SPIV, TAU, TEMP C .. C .. External Functions .. INTEGER IDAMAX C .. C .. External Subroutines .. EXTERNAL DAXPY, DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, MOD C .. C .. Executable Statements .. C C Decode the input parameters. C For efficiency reasons, the parameters are not checked. C INFO = 0 LQUERY = LDWORK.EQ.-1 C MN = M*N KMN = K*MN C MINWRK = ( 4*K - 3 ) * MN**2 + KMN IF( .NOT. LQUERY .AND. LDWORK.LT.MINWRK ) $ INFO = -21 C C Quick return if possible. C DWORK( 1 ) = DBLE( MINWRK ) IF( LQUERY ) THEN RETURN ELSE IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03KE', -INFO ) RETURN END IF C C Find the overflow threshold. C BIGNUM = PREC / SMIN C C --- Use QR-factorizations and backward substitution --- C C This variant does not utilize the sparsity structure of the C individual blocks of the matrix Z - storage of each block Z_i,i C is compatible with the BLAS. Numerics is stable since excessive C pivot growth is avoided. C MM = M*M NN = N*N SGN = DBLE( ISGN ) LDW = 3*MN IF( M.EQ.2 .AND. N.EQ.2 ) THEN MN6 = LDW + LDW MN7 = MN6 + LDW KM2 = KMN + KMN KM3 = KM2 + KMN END IF C C Divide workspace for superdiagonal + diagonal + subdiagonal blocks C and right-most block column stored in a "block-packed" format. For C simplicity, an additional block Z_{0,1} appears in the first block C column in Z. C ZD = 1 ZC = ZD + LDW*MN*( K - 1 ) C C Also give workspace for right hand side in CB. C CB = ZC + MN*KMN C C Fill the Z part of the workspace with zeros. C DO 10 J = 1, CB - 1 DWORK( J ) = ZERO 10 CONTINUE C C Build matrix Z in ZD and ZC. C IXA = 1 IXB = 1 IXC = 1 IM1 = K ZI = ZD + MN C DO 20 I = 1, K - 1 C C Build Z_{i,i}, i = 1,...,K-1. C IF( S( IM1 ).EQ.-1 ) THEN C IA1 = ( IM1 - 1 )*MM + 1 DWORK( ZI ) = A( IA1 ) IF( M.EQ.2 ) THEN IA3 = IA1 + 2 IF( .NOT. TRANA ) THEN DWORK( ZI + 1 ) = A( IA1 + 1 ) DWORK( ZI + LDW ) = A( IA3 ) ELSE DWORK( ZI + 1 ) = A( IA3 ) DWORK( ZI + LDW ) = A( IA1 + 1 ) END IF DWORK( ZI + LDW + 1 ) = A( IA3 + 1 ) END IF IF( N.EQ.2 ) THEN ZI2 = ZI + ( LDW + 1 )*M DWORK( ZI2 ) = DWORK( ZI ) IF( M.EQ.2 ) THEN DWORK( ZI2 + 1 ) = DWORK( ZI + 1 ) DWORK( ZI2 + LDW ) = DWORK( ZI + LDW ) DWORK( ZI2 + LDW + 1 ) = DWORK( ZI + LDW + 1 ) END IF END IF C ELSE C IB1 = ( IM1 - 1 )*NN + 1 DWORK( ZI ) = SGN*B( IB1 ) IF( .NOT. TRANB ) THEN IF( M.EQ.2 ) THEN DWORK( ZI + LDW + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB3 ) DWORK( ZI + LDW + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + MN6 ) = SGN*B( IB1 + 1 ) DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + MN7 + 1 ) = DWORK( ZI + MN6 ) DWORK( ZI + MN7 + 3 ) = DWORK( ZI + MN6 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB3 ) DWORK( ZI + LDW ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 ) END IF ELSE IF( M.EQ.2 ) THEN DWORK( ZI + LDW + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + MN6 ) = SGN*B( IB3 ) DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + MN7 + 1 ) = DWORK( ZI + MN6 ) DWORK( ZI + MN7 + 3 ) = DWORK( ZI + MN6 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW ) = SGN*B( IB3 ) DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 ) END IF END IF C END IF C C Build Z_{i+1,i}, i = 1,...,K-1. C ZI = ZI + MN IF( S( I ).EQ.1 ) THEN C IA1 = IXA DWORK( ZI ) = A( IA1 ) IF( M.EQ.2 ) THEN IA3 = IA1 + 2 IF( .NOT. TRANA ) THEN DWORK( ZI + 1 ) = A( IA1 + 1 ) DWORK( ZI + LDW ) = A( IA3 ) ELSE DWORK( ZI + 1 ) = A( IA3 ) DWORK( ZI + LDW ) = A( IA1 + 1 ) END IF DWORK( ZI + LDW + 1 ) = A( IA3 + 1 ) END IF IF( N.EQ.2 ) THEN ZI2 = ZI + ( LDW + 1 )*M DWORK( ZI2 ) = DWORK( ZI ) IF( M.EQ.2 ) THEN DWORK( ZI2 + 1 ) = DWORK( ZI + 1 ) DWORK( ZI2 + LDW ) = DWORK( ZI + LDW ) DWORK( ZI2 + LDW + 1 ) = DWORK( ZI + LDW + 1 ) END IF END IF C ELSE C IB1 = IXB DWORK( ZI ) = SGN*B( IB1 ) IF( .NOT. TRANB ) THEN IF( M.EQ.2 ) THEN DWORK( ZI + LDW + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB3 ) DWORK( ZI + LDW + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + MN6 ) = SGN*B( IB1 + 1 ) DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + MN7 + 1 ) = DWORK( ZI + MN6 ) DWORK( ZI + MN7 + 3 ) = DWORK( ZI + MN6 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB3 ) DWORK( ZI + LDW ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 ) END IF ELSE IF( M.EQ.2 ) THEN DWORK( ZI + LDW + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + MN6 ) = SGN*B( IB3 ) DWORK( ZI + MN6 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + MN7 + 1 ) = DWORK( ZI + MN6 ) DWORK( ZI + MN7 + 3 ) = DWORK( ZI + MN6 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB1 + 1 ) DWORK( ZI + LDW ) = SGN*B( IB3 ) DWORK( ZI + LDW + 1 ) = SGN*B( IB3 + 1 ) END IF END IF END IF C IXA = IXA + MM IXB = IXB + NN IM1 = I ZI = ZI + MN*( LDW - 1 ) 20 CONTINUE C C Build Z_{K,K}. C IXA = IXA - MM IXB = IXB - NN ZI = ZC + KMN - MN IF( S( K - 1 ).EQ.-1 ) THEN C IA1 = IXA DWORK( ZI ) = A( IA1 ) IF( M.EQ.2 ) THEN IA3 = IA1 + 2 IF( .NOT. TRANA ) THEN DWORK( ZI + 1 ) = A( IA1 + 1 ) DWORK( ZI + KMN ) = A( IA3 ) ELSE DWORK( ZI + 1 ) = A( IA3 ) DWORK( ZI + KMN ) = A( IA1 + 1 ) END IF DWORK( ZI + KMN + 1 ) = A( IA3 + 1 ) END IF IF( N.EQ.2 ) THEN ZI2 = ZI + ( KMN + 1 )*M DWORK( ZI2 ) = DWORK( ZI ) IF( M.EQ.2 ) THEN DWORK( ZI2 + 1 ) = DWORK( ZI + 1 ) DWORK( ZI2 + KMN ) = DWORK( ZI + KMN ) DWORK( ZI2 + KMN + 1 ) = DWORK( ZI + KMN + 1 ) END IF END IF C ELSE C IB1 = IXB DWORK( ZI ) = SGN*B( IB1 ) IF( .NOT. TRANB ) THEN IF( M.EQ.2 ) THEN DWORK( ZI + KMN + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB3 ) DWORK( ZI + KMN + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + KM2 ) = SGN*B( IB1 + 1 ) DWORK( ZI + KM2 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + KM3 + 1 ) = DWORK( ZI + KM2 ) DWORK( ZI + KM3 + 3 ) = DWORK( ZI + KM2 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB3 ) DWORK( ZI + KMN ) = SGN*B( IB1 + 1 ) DWORK( ZI + KMN + 1 ) = SGN*B( IB3 + 1 ) END IF ELSE IF( M.EQ.2 ) THEN DWORK( ZI + KMN + 1 ) = DWORK( ZI ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 2 ) = SGN*B( IB1 + 1 ) DWORK( ZI + KMN + 3 ) = DWORK( ZI + 2 ) DWORK( ZI + KM2 ) = SGN*B( IB3 ) DWORK( ZI + KM2 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZI + KM3 + 1 ) = DWORK( ZI + KM2 ) DWORK( ZI + KM3 + 3 ) = DWORK( ZI + KM2 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZI + 1 ) = SGN*B( IB1 + 1 ) DWORK( ZI + KMN ) = SGN*B( IB3 ) DWORK( ZI + KMN + 1 ) = SGN*B( IB3 + 1 ) END IF END IF END IF C C Build Z_{1,K}. C IF( S( K ).EQ.1 ) THEN C IA1 = IA1 + MM DWORK( ZC ) = A( IA1 ) IF( M.EQ.2 ) THEN IA3 = IA1 + 2 IF( .NOT. TRANA ) THEN DWORK( ZC + 1 ) = A( IA1 + 1 ) DWORK( ZC + KMN ) = A( IA3 ) ELSE DWORK( ZC + 1 ) = A( IA3 ) DWORK( ZC + KMN ) = A( IA1 + 1 ) END IF DWORK( ZC + KMN + 1 ) = A( IA3 + 1 ) END IF IF( N.EQ.2 ) THEN ZI2 = ZC + ( KMN + 1 )*M DWORK( ZI2 ) = DWORK( ZC ) IF( M.EQ.2 ) THEN DWORK( ZI2 + 1 ) = DWORK( ZC + 1 ) DWORK( ZI2 + KMN ) = DWORK( ZC + KMN ) DWORK( ZI2 + KMN + 1 ) = DWORK( ZC + KMN + 1 ) END IF END IF C ELSE C IB1 = IB1 + NN DWORK( ZC ) = SGN*B( IB1 ) IF( .NOT. TRANB ) THEN IF( M.EQ.2 ) THEN DWORK( ZC + KMN + 1 ) = DWORK( ZC ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZC + 2 ) = SGN*B( IB3 ) DWORK( ZC + KMN + 3 ) = DWORK( ZC + 2 ) DWORK( ZC + KM2 ) = SGN*B( IB1 + 1 ) DWORK( ZC + KM2 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZC + KM3 + 1 ) = DWORK( ZC + KM2 ) DWORK( ZC + KM3 + 3 ) = DWORK( ZC + KM2 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZC + 1 ) = SGN*B( IB3 ) DWORK( ZC + KMN ) = SGN*B( IB1 + 1 ) DWORK( ZC + KMN + 1 ) = SGN*B( IB3 + 1 ) END IF ELSE IF( M.EQ.2 ) THEN DWORK( ZC + KMN + 1 ) = DWORK( ZC ) IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZC + 2 ) = SGN*B( IB1 + 1 ) DWORK( ZC + KMN + 3 ) = DWORK( ZC + 2 ) DWORK( ZC + KM2 ) = SGN*B( IB3 ) DWORK( ZC + KM2 + 2 ) = SGN*B( IB3 + 1 ) DWORK( ZC + KM3 + 1 ) = DWORK( ZC + KM2 ) DWORK( ZC + KM3 + 3 ) = DWORK( ZC + KM2 + 2 ) END IF ELSE IF( N.EQ.2 ) THEN IB3 = IB1 + 2 DWORK( ZC + 1 ) = SGN*B( IB1 + 1 ) DWORK( ZC + KMN ) = SGN*B( IB3 ) DWORK( ZC + KMN + 1 ) = SGN*B( IB3 + 1 ) END IF END IF END IF C C Prepare right hand side in CB. C ZI = CB + MN DO 30 L = 1, K - 1 IC1 = IXC DWORK( ZI ) = -C( IC1 ) IF( M.EQ.1 ) THEN IF( N.EQ.2 ) $ DWORK( ZI + 1 ) = -C( IC1 + 1 ) ELSE DWORK( ZI + 1 ) = -C( IC1 + 1 ) IF( N.EQ.2 ) THEN DWORK( ZI + 2 ) = -C( IC1 + 2 ) DWORK( ZI + 3 ) = -C( IC1 + 3 ) END IF END IF IXC = IXC + MN ZI = ZI + MN 30 CONTINUE C ZI = CB IC1 = IXC DWORK( ZI ) = -C( IC1 ) IF( M.EQ.1 ) THEN IF( N.EQ.2 ) $ DWORK( ZI + 1 ) = -C( IC1 + 1 ) ELSE DWORK( ZI + 1 ) = -C( IC1 + 1 ) IF( N.EQ.2 ) THEN DWORK( ZI + 2 ) = -C( IC1 + 2 ) DWORK( ZI + 3 ) = -C( IC1 + 3 ) END IF END IF C C Solve the Kronecker product system for X_i, i = 1,...,K C using overlapping (structured) QR-factorization and C backward substitution. C C Step 1: Reduce the system to triangular form via overlapping C QR-factorizations. C C The method here is based on successively formed C Householder reflections which are applied one by one C to the matrix Z and the right hand side c. The size C of each reflection is chosen as the number of elements C in each column from the last non-zero element up to C the diagonal. C C Notation: C L = current position of the column to work with; C I = corresponding block column in Z; C II = corresponding row and column position in Z-block; C LEN = length of the current Householder reflection. C I = 1 II = 0 ZIS = ZD + MN ZI2 = ZD + MN*LDW C C Treat Z_{K,K} separately from [Z_{i,i}',Z_{i+1,i}']' (see below). C DMIN is the minimum modulus of the final diagonal values. C DMIN = BIGNUM C DO 50 L = 1, KMN - MN II = II + 1 ZI = ZIS + 2*MN LEN = 2*MN - II + 1 C C REPEAT 40 CONTINUE ZI = ZI - 1 ELEM = DWORK( ZI ) IF( ELEM.EQ.ZERO ) THEN LEN = LEN - 1 GO TO 40 END IF C UNTIL ELEM.NE.ZERO. C IF( LEN.GT.1 ) THEN C C Generate Householder reflection to zero out the current C column. The new main diagonal value is stored temporarily C in BETA. C ZI = ZI - LEN + 1 CALL DLARFG( LEN, DWORK( ZI ), DWORK( ZI + 1 ), 1, TAU ) BETA = DWORK( ZI ) DWORK( ZI ) = ONE C C Apply reflection to Z and c: first to the rest of the C corresponding rows and columns of [Z_{i,i}',Z_{i+1,i}']' C of size LEN-by-(MN-II) ... C CALL DLARFX( 'Left', LEN, MN - II, DWORK( ZI ), TAU, $ DWORK( ZI + LDW ), LDW, DWORK ) C C ... then to the corresponding part of C [Z_{i,i+1}',Z_{i+1,i+1}']' of size LEN-by-MN ... C IF( I.LT.K - 1 ) $ CALL DLARFX( 'Left', LEN, MN, DWORK( ZI ), TAU, $ DWORK( ZI2 ), LDW, DWORK ) C C ... next to the corresponding part of C [Z_{i,K}',Z_{i+1,K}']' of size LEN-by-MN ... C CALL DLARFX( 'Left', LEN, MN, DWORK( ZI ), TAU, $ DWORK( ZC + L - 1 ), KMN, DWORK ) C C ... and finally to c(L:L+LEN-1). C CALL DLARFX( 'Left', LEN, 1, DWORK( ZI ), TAU, $ DWORK( CB + L - 1 ), KMN, DWORK ) C C Store the new diagonal value. C DWORK( ZI ) = BETA DMIN = MIN( DMIN, ABS( BETA ) ) END IF C ZIS = ZIS + LDW ZI2 = ZI2 + 1 IF( MOD( L, MN ).EQ.0 ) THEN I = I + 1 II = 0 ZI2 = ZD + I*MN*LDW END IF 50 CONTINUE C II = 0 ZI = ZC + KMN - MN C C Z_{K,K} is treated separately. C DO 60 L = KMN - MN + 1, KMN II = II + 1 LEN = MN - II + 1 IF( LEN.GT.1 ) THEN C C Generate Householder reflection. C CALL DLARFG( LEN, DWORK( ZI ), DWORK( ZI + 1 ), 1, TAU ) BETA = DWORK( ZI ) DWORK( ZI ) = ONE C C Apply reflection to Z and c: first to Z_{i,i} ... C CALL DLARFX( 'Left', LEN, MN - II, DWORK( ZI ), TAU, $ DWORK( ZI + KMN ), KMN, DWORK ) C C ... and finally to c(L:L+LEN-1). C CALL DLARFX( 'Left', LEN, 1, DWORK( ZI ), TAU, $ DWORK( CB + L - 1 ), KMN, DWORK ) C C Store the new diagonal value. C DWORK( ZI ) = BETA DMIN = MIN( DMIN, ABS( BETA ) ) END IF ZI = ZI + KMN + 1 C 60 CONTINUE C C Step 2: Use backward substitution on the computed triangular C system. C C Here, we take the possible irregularities above the C diagonal of the resulting R-factor into account by C checking the number of elements from the main diagonal C to the last non-zero element above the diagonal that C resides in the current column. C Pivots less than SPIV = MAX( PREC*DMIN, SMIN ) are set C to SPIV. C SCALE = ONE DOSCAL = .FALSE. DMIN = MAX( DMIN, SMIN ) SPIV = MAX( PREC*DMIN, SMIN ) C C Check for scaling. C I = IDAMAX( KMN, DWORK( CB ), 1 ) AC = ABS( DWORK( CB + I - 1 ) ) IF( TWO*SMIN*AC.GT.DMIN ) THEN TEMP = ( ONE / TWO ) / AC CALL DSCAL( KMN, TEMP, DWORK( CB ), 1 ) SCALE = SCALE*TEMP END IF C ZI = CB - 1 C DO 70 I = KMN, KMN - MN + 1, -1 C AD = ABS( DWORK( ZI ) ) AC = ABS( DWORK( CB + I - 1 ) ) IF( AD.LT.SPIV ) THEN AD = SPIV DWORK( ZI ) = SPIV END IF SCALOC = ONE IF( AD.LT.ONE .AND. AC.GT.ONE ) THEN IF( AC.GT.BIGNUM*AD ) THEN INFO = 1 SCALOC = BIGNUM*AD / AC DOSCAL = .TRUE. SCALE = SCALE * SCALOC END IF END IF TEMP = ( DWORK( CB + I - 1 ) * SCALOC ) / DWORK( ZI ) IF( DOSCAL ) THEN DOSCAL = .FALSE. CALL DSCAL( KMN, SCALOC, DWORK( CB ), 1 ) END IF DWORK( CB + I - 1 ) = TEMP C CALL DAXPY( I - 1, -TEMP, DWORK( ZI - I + 1 ), 1, DWORK( CB ), $ 1 ) C ZI = ZI - KMN - 1 70 CONTINUE C ZIS = ZC - LDW ZI = ZIS + 2*MN - 1 IZ = 0 C DO 90 I = KMN - MN, 1, -1 AD = ABS( DWORK( ZI ) ) AC = ABS( DWORK( CB + I - 1 ) ) IF( AD.LT.SPIV ) THEN AD = SPIV DWORK( ZI ) = SPIV END IF SCALOC = ONE IF( AD.LT.ONE .AND. AC.GT.ONE ) THEN IF( AC.GT.BIGNUM*AD ) THEN INFO = 1 SCALOC = BIGNUM*AD / AC DOSCAL = .TRUE. SCALE = SCALE * SCALOC END IF END IF TEMP = ( DWORK( CB + I - 1 ) * SCALOC ) / DWORK( ZI ) IF( DOSCAL ) THEN DOSCAL = .FALSE. CALL DSCAL( KMN, SCALOC, DWORK( CB ), 1 ) END IF DWORK( CB + I - 1 ) = TEMP LEN = MN + MOD( I - 1, MN ) + 1 ZI2 = ZIS 80 CONTINUE IF( DWORK( ZI2 ).EQ.ZERO ) THEN LEN = LEN - 1 ZI2 = ZI2 + 1 GO TO 80 END IF C J = MAX( 1, I - LEN + 1 ) CALL DAXPY( I - J, -TEMP, DWORK( ZI - I + J ), 1, $ DWORK( CB + J - 1 ), 1 ) C IF( MN.GT.1 ) THEN IF( MOD( I, MN ).EQ.1 ) THEN IZ = 1 - MN ELSE IZ = 1 END IF END IF ZI = ZI - LDW - IZ ZIS = ZIS - LDW 90 CONTINUE C C Reshape the solution into C. C IC1 = 1 ZI = CB C DO 100 L = 1, K C( IC1 ) = DWORK( ZI ) IF( M.EQ.1 ) THEN IF( N.EQ.2 ) $ C( IC1 + 1 ) = DWORK( ZI + 1 ) ELSE C( IC1 + 1 ) = DWORK( ZI + 1 ) IF( N.EQ.2 ) THEN C( IC1 + 2 ) = DWORK( ZI + 2 ) C( IC1 + 3 ) = DWORK( ZI + 3 ) END IF END IF IC1 = IC1 + MN ZI = ZI + MN 100 CONTINUE C C Store the minimal workspace on output. C DWORK( 1 ) = DBLE( MINWRK ) RETURN C C *** Last line of MB03KE *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01RH.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01RH.f0000644000175000017500000002551315012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE MB01RH( UPLO, TRANS, N, ALPHA, BETA, R, LDR, H, LDH, $ X, LDX, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the matrix formula C C R := alpha*R + beta*op( H )*X*op( H )', C C where alpha and beta are scalars, R and X are symmetric matrices, C H is an upper Hessenberg matrix, and op( H ) is one of C C op( H ) = H or op( H ) = H'. 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( 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 N (input) INTEGER C The order of the matrices R, H, and X. 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 H and X are not C referenced. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) C On entry with 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 R. C On entry with 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 R. C In both cases, the other strictly triangular part is not C referenced. C On exit, the leading N-by-N 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 the computed matrix R. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C H (input) DOUBLE PRECISION array, dimension (LDH,N) C On entry, the leading N-by-N upper Hessenberg part of this C array must contain the upper Hessenberg matrix H. C If TRANS = 'N', the entries 3, 4,..., N of the first C column are modified internally, but are restored on exit. C The remaining part of this array is not referenced. C C LDH INTEGER C The leading dimension of array H. LDH >= MAX(1,N). 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 N = 0. C C LDWORK The length of the array DWORK. C LDWORK >= N*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 = U + L, with U and L upper and C lower triangular matrices, defined by C C U = triu( X ) - (1/2)*diag( X ), C L = tril( X ) - (1/2)*diag( X ), C C where triu, tril, and diag denote the upper triangular part, lower C triangular part, and diagonal part of X, respectively. Then, C if UPLO = 'U', C C H*X*H' = ( H*U )*H' + H*( H*U )', for TRANS = 'N', C H'*X*H = H'*( U*H ) + ( U*H )'*H, for TRANS = 'T', or 'C', C C and if UPLO = 'L', C C H*X*H' = ( H*L' )*H' + H*( H*L' )', for TRANS = 'N', C H'*X*H = H'*( L'*H ) + ( L'*H )'*H, for TRANS = 'T', or 'C', C C which involve operations like in BLAS 2 and 3 (DTRMV and DSYR2K). C This approach ensures that the matrices H*U, U*H, H*L', or L'*H C are upper Hessenberg. C C NUMERICAL ASPECTS C C The algorithm requires approximately N**3/2 operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2019. C C REVISIONS C C V. Sima, Apr. 2019. 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, LDH, LDR, LDWORK, LDX, N DOUBLE PRECISION ALPHA, BETA C .. Array Arguments .. DOUBLE PRECISION DWORK(*), H(LDH,*), R(LDR,*), X(LDX,*) C .. Local Scalars .. LOGICAL LTRANS, LUPLO INTEGER I, J, J1 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DSCAL, DSWAP, $ DTRMV, MB01OH, 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( N.LT.0 ) THEN INFO = -3 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDH.LT.1 .OR. ( LTRANS .AND. LDH.LT.N ) .OR. $ ( .NOT.LTRANS .AND. LDH.LT.N ) ) THEN INFO = -9 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.N*N ) $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.0 ) ) THEN INFO = -13 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01RH', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C IF ( BETA.EQ.ZERO ) THEN IF ( ALPHA.EQ.ZERO ) THEN C C Special case alpha = 0. C CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) ELSE C C Special case beta = 0. C IF ( ALPHA.NE.ONE ) $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, N, N, R, LDR, INFO ) END IF RETURN END IF C C General case: beta <> 0. C Compute W = H*T or W = T*H in DWORK, and apply the updating C formula (see METHOD section). C Workspace: need N*N. C CALL DSCAL( N, HALF, X, LDX+1 ) C IF ( .NOT.LTRANS ) THEN C C For convenience, swap the subdiagonal entries in H with C those in the first column, and finally restore them. C IF ( N.GT.2 ) $ CALL DSWAP( N-2, H(3,1), 1, H(3,2), LDH+1 ) C IF ( LUPLO ) THEN C DO 20 J = 1, N - 1 J1 = J + 1 CALL DCOPY( J, X(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, H, LDH, $ DWORK(1+(J-1)*N), 1 ) DO 10 I = 2, J DWORK(I+(J-1)*N) = DWORK(I+(J-1)*N) + H(I,1)*X(I-1,J) 10 CONTINUE DWORK(J1+(J-1)*N) = H(J1,1)*X(J,J) 20 CONTINUE C CALL DCOPY( N, X(1,N), 1, DWORK(1+(N-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', N, H, LDH, $ DWORK(1+(N-1)*N), 1 ) C DO 30 I = 2, N DWORK(I+(N-1)*N) = DWORK(I+(N-1)*N) + H(I,1)*X(I-1,N) 30 CONTINUE C ELSE C DO 50 J = 1, N - 1 J1 = J + 1 CALL DCOPY( J, X(J,1), LDX, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', J, H, LDH, $ DWORK(1+(J-1)*N), 1 ) DO 40 I = 2, J DWORK(I+(J-1)*N) = DWORK(I+(J-1)*N) + H(I,1)*X(J,I-1) 40 CONTINUE DWORK(J1+(J-1)*N) = H(J1,1)*X(J,J) 50 CONTINUE C CALL DCOPY( N, X(N,1), LDX, DWORK(1+(N-1)*N), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', N, H, LDH, $ DWORK(1+(N-1)*N), 1 ) C DO 60 I = 2, N DWORK(I+(N-1)*N) = DWORK(I+(N-1)*N) + H(I,1)*X(N,I-1) 60 CONTINUE C END IF C IF ( N.GT.2 ) $ CALL DSWAP( N-2, H(3,1), 1, H(3,2), LDH+1 ) C ELSE C IF ( LUPLO ) THEN C DO 70 J = 1, N - 1 J1 = J + 1 CALL DCOPY( J, H(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, X, LDX, $ DWORK(1+(J-1)*N), 1 ) CALL DAXPY( J, H(J1,J), X(1,J1), 1, DWORK(1+(J-1)*N), 1 ) DWORK(J1+(J-1)*N) = H(J1,J)*X(J1,J1) 70 CONTINUE C CALL DCOPY( N, H(1,N), 1, DWORK(1+(N-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', N, X, LDX, $ DWORK(1+(N-1)*N), 1 ) C ELSE C DO 80 J = 1, N - 1 J1 = J + 1 CALL DCOPY( J, H(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'Tran', 'NoDiag', J, X, LDX, $ DWORK(1+(J-1)*N), 1 ) CALL DAXPY( J, H(J1,J), X(J1,1), LDX, DWORK(1+(J-1)*N), $ 1 ) DWORK(J1+(J-1)*N) = H(J1,J)*X(J1,J1) 80 CONTINUE C CALL DCOPY( N, H(1,N), 1, DWORK(1+(N-1)*N), 1 ) CALL DTRMV( UPLO, 'Tran', 'NoDiag', N, X, LDX, $ DWORK(1+(N-1)*N), 1 ) C END IF C END IF C CALL DSCAL( N, TWO, X, LDX+1 ) C CALL MB01OH( UPLO, TRANS, N, ALPHA, BETA, R, LDR, H, LDH, DWORK, $ N ) C RETURN C *** Last line of MB01RH *** END control-4.1.2/src/slicot/src/PaxHeaders/zlatzm.f0000644000000000000000000000013215012430707016616 xustar0030 mtime=1747595719.993101108 30 atime=1747595719.993101108 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/zlatzm.f0000644000175000017500000001377415012430707020026 0ustar00lilgelilge00000000000000*> \brief \b ZLATZM * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download ZLATZM + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N * COMPLEX*16 TAU * .. * .. Array Arguments .. * COMPLEX*16 C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine ZUNMRZ. *> *> ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix. *> *> Let P = I - tau*u*u**H, u = ( 1 ), *> ( v ) *> where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if *> SIDE = 'R'. *> *> If SIDE equals 'L', let *> C = [ C1 ] 1 *> [ C2 ] m-1 *> n *> Then C is overwritten by P*C. *> *> If SIDE equals 'R', let *> C = [ C1, C2 ] m *> 1 n-1 *> Then C is overwritten by C*P. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form P * C *> = 'R': form C * P *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is COMPLEX*16 array, dimension *> (1 + (M-1)*abs(INCV)) if SIDE = 'L' *> (1 + (N-1)*abs(INCV)) if SIDE = 'R' *> The vector v in the representation of P. V is not used *> if TAU = 0. *> \endverbatim *> *> \param[in] INCV *> \verbatim *> INCV is INTEGER *> The increment between elements of v. INCV <> 0 *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is COMPLEX*16 *> The value tau in the representation of P. *> \endverbatim *> *> \param[in,out] C1 *> \verbatim *> C1 is COMPLEX*16 array, dimension *> (LDC,N) if SIDE = 'L' *> (M,1) if SIDE = 'R' *> On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 *> if SIDE = 'R'. *> *> On exit, the first row of P*C if SIDE = 'L', or the first *> column of C*P if SIDE = 'R'. *> \endverbatim *> *> \param[in,out] C2 *> \verbatim *> C2 is COMPLEX*16 array, dimension *> (LDC, N) if SIDE = 'L' *> (LDC, N-1) if SIDE = 'R' *> On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the *> m x (n - 1) matrix C2 if SIDE = 'R'. *> *> On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P *> if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the arrays C1 and C2. *> LDC >= max(1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is COMPLEX*16 array, dimension *> (N) if SIDE = 'L' *> (M) if SIDE = 'R' *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \ingroup complex16OTHERcomputational * * ===================================================================== SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N COMPLEX*16 TAU * .. * .. Array Arguments .. COMPLEX*16 C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. External Subroutines .. EXTERNAL ZAXPY, ZCOPY, ZGEMV, ZGERC, ZGERU, ZLACGV * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) ) $ RETURN * IF( LSAME( SIDE, 'L' ) ) THEN * * w := ( C1 + v**H * C2 )**H * CALL ZCOPY( N, C1, LDC, WORK, 1 ) CALL ZLACGV( N, WORK, 1 ) CALL ZGEMV( 'Conjugate transpose', M-1, N, ONE, C2, LDC, V, $ INCV, ONE, WORK, 1 ) * * [ C1 ] := [ C1 ] - tau* [ 1 ] * w**H * [ C2 ] [ C2 ] [ v ] * CALL ZLACGV( N, WORK, 1 ) CALL ZAXPY( N, -TAU, WORK, 1, C1, LDC ) CALL ZGERU( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC ) * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * w := C1 + C2 * v * CALL ZCOPY( M, C1, 1, WORK, 1 ) CALL ZGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE, $ WORK, 1 ) * * [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**H] * CALL ZAXPY( M, -TAU, WORK, 1, C1, 1 ) CALL ZGERC( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC ) END IF * RETURN * * End of ZLATZM * END control-4.1.2/src/slicot/src/PaxHeaders/TG01LD.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01LD.f0000644000175000017500000004543315012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE TG01LD( JOB, JOBA, COMPQ, COMPZ, N, M, P, A, LDA, $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NF, ND, $ NIBLCK, IBLCK, TOL, IWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute orthogonal transformation matrices Q and Z which C reduce the regular pole pencil A-lambda*E of the descriptor system C (A-lambda*E,B,C) to the form (if JOB = 'F') C C ( Af * ) ( Ef * ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) , (1) C ( 0 Ai ) ( 0 Ei ) C C or to the form (if JOB = 'I') C C ( Ai * ) ( Ei * ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) , (2) C ( 0 Af ) ( 0 Ef ) C C where the subpencil Af-lambda*Ef, with Ef nonsingular and upper C triangular, contains the finite eigenvalues, and the subpencil C Ai-lambda*Ei, with Ai nonsingular and upper triangular, contains C the infinite eigenvalues. The subpencil Ai-lambda*Ei is in a C staircase form (see METHOD). If JOBA = 'H', the submatrix Af C is further reduced to an upper Hessenberg form. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C = 'F': perform the finite-infinite separation; C = 'I': perform the infinite-finite separation. C C JOBA CHARACTER*1 C = 'H': reduce Af further to an upper Hessenberg form; C = 'N': keep Af unreduced. C C COMPQ CHARACTER*1 C = 'N': do not compute Q; C = 'I': Q is initialized to the unit matrix, and the C orthogonal matrix Q is returned; C = 'U': Q must contain an orthogonal matrix Q1 on entry, C and the product Q1*Q is returned. C C COMPZ CHARACTER*1 C = 'N': do not compute Z; C = 'I': Z is initialized to the unit matrix, and the C orthogonal matrix Z is returned; C = 'U': Z must contain an orthogonal matrix Z1 on entry, C and the product Z1*Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix B, the number of columns C of the matrix C and the order of the square matrices A C and E. N >= 0. C C M (input) INTEGER C The number of columns of the matrix B. M >= 0. C C P (input) INTEGER C The number of rows of the matrix C. 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 N-by-N state matrix A. C On exit, the leading N-by-N part of this array contains C the transformed state matrix Q'*A*Z, C C ( Af * ) ( Ai * ) C Q'*A*Z = ( ) , or Q'*A*Z = ( ) , C ( 0 Ai ) ( 0 Af ) C C depending on JOB, with Af an NF-by-NF matrix, and Ai an C (N-NF)-by-(N-NF) nonsingular and upper triangular matrix. C If JOBA = 'H', Af is in an upper Hessenberg form. C Otherwise, Af is unreduced. C Ai has a block structure as in (3) or (4), where A0,0 is C ND-by-ND and Ai,i , for i = 1, ..., NIBLCK, is C IBLCK(i)-by-IBLCK(i). 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, the leading N-by-N part of this array must C contain the N-by-N descriptor matrix E. C On exit, the leading N-by-N part of this array contains C the transformed descriptor matrix Q'*E*Z, C C ( Ef * ) ( Ei * ) C Q'*E*Z = ( ) , or Q'*E*Z = ( ) , C ( 0 Ei ) ( 0 Ef ) C C depending on JOB, with Ef an NF-by-NF nonsingular matrix, C and Ei an (N-NF)-by-(N-NF) nilpotent matrix in an upper C block triangular form, as in (3) or (4). C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,K), C where K = M if JOB = 'F', and K = MAX(M,P) if JOB = 'I'. C On entry, the leading N-by-M part of this array must C contain the N-by-M input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix Q'*B. C C LDB INTEGER C The leading dimension of the 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Z. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,K), C where K = P if JOB = 'F', and K = MAX(M,P) if JOB = 'I'. C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C If COMPQ = 'N': Q is not referenced. C If COMPQ = 'I': on entry, Q need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Q, C where Q' is the product of Householder C transformations applied to A, E, and B on C the left. C If COMPQ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix C Q1; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Q1*Q. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1,N), if COMPQ = 'I' or 'U'. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C If COMPZ = 'N': Z is not referenced. C If COMPZ = 'I': on entry, Z need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Z, C which is the product of Householder C transformations applied to A, E, and C on C the right. C If COMPZ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix C Z1; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Z1*Z. C C LDZ INTEGER C The leading dimension of the array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= MAX(1,N), if COMPZ = 'I' or 'U'. C C NF (output) INTEGER. C The order of the reduced matrices Af and Ef; also, the C number of finite generalized eigenvalues of the pencil C A-lambda*E. C C ND (output) INTEGER. C The number of non-dynamic infinite eigenvalues of the C pair (A,E). Note: N-ND is the rank of the matrix E. C C NIBLCK (output) INTEGER C If ND > 0, the number of infinite blocks minus one. C If ND = 0, then NIBLCK = 0. C C IBLCK (output) INTEGER array, dimension (N) C IBLCK(i) contains the dimension of the i-th block in the C staircase form (3) or (4), with i = 1,2, ..., NIBLCK. 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 factorization with column pivoting whose estimated C condition number is less than 1/TOL. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C TOLDEF = N**2*EPS, is used instead, where EPS is the C machine precision (see LAPACK Library routine DLAMCH). C 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) returns the optimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 1, and if N > 0, C LDWORK >= N + MAX(3*N,M,P). C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 = 1: the pencil A-lambda*E is not regular. C C METHOD C C The subroutine is based on the reduction algorithm of [1]. C If JOB = 'F', the matrices Ai and Ei have the form C C ( A0,0 A0,k ... A0,1 ) ( 0 E0,k ... E0,1 ) C Ai = ( 0 Ak,k ... Ak,1 ) , Ei = ( 0 0 ... Ek,1 ) ; (3) C ( : : . : ) ( : : . : ) C ( 0 0 ... A1,1 ) ( 0 0 ... 0 ) C C if JOB = 'I', the matrices Ai and Ei have the form C C ( A1,1 ... A1,k A1,0 ) ( 0 ... E1,k E1,0 ) C Ai = ( : . : : ) , Ei = ( : . : : ) , (4) C ( : ... Ak,k Ak,0 ) ( : ... 0 Ek,0 ) C ( 0 ... 0 A0,0 ) ( 0 ... 0 0 ) C C where Ai,i , for i = 0, 1, ..., k, are nonsingular upper C triangular matrices. A0,0 corresponds to the non-dynamic infinite C modes of the system. C C REFERENCES C C [1] Misra, P., Van Dooren, P., and Varga, A. C Computation of structural invariants of generalized C state-space systems. C Automatica, 30, pp. 1921-1936, 1994. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N**3 ) floating point operations. C C FURTHER COMMENTS C C The number of infinite poles is computed as C C NIBLCK C NINFP = Sum IBLCK(i) = N - ND - NF. C i=1 C C The multiplicities of infinite poles can be computed as follows: C there are IBLCK(k)-IBLCK(k+1) infinite poles of multiplicity C k, for k = 1, ..., NIBLCK, where IBLCK(NIBLCK+1) = 0. C Note that each infinite pole of multiplicity k corresponds to C an infinite eigenvalue of multiplicity k+1. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C July 1999. Based on the RASP routines SRISEP and RPDSGH. C C REVISIONS C C A. Varga, 3-11-2002. C V. Sima, Dec. 2016, June 2017. C C KEYWORDS C C Generalized eigenvalue problem, system poles, multivariable C system, orthogonal transformation, structural invariant. C C ****************************************************************** C C .. C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB, JOBA INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, M, $ N, ND, NF, NIBLCK, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IBLCK( * ), IWORK(*) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), $ Z( LDZ, * ) C .. Local Scalars .. CHARACTER JOBQ, JOBZ LOGICAL ILQ, ILZ, LQUERY, REDA, REDIF INTEGER I, ICOMPQ, ICOMPZ, IHI, ILO, MINWRK, RANKE, $ RNKA22, WRKOPT C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB07MD, DSWAP, MA02BD, MA02CD, TB01XD, TG01BD, $ TG01FD, TG01LY, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C C Decode COMPQ. C IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'U' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF C C Decode COMPZ. C IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'U' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF REDIF = LSAME( JOB, 'I' ) REDA = LSAME( JOBA, 'H' ) C C Test the input parameters. C INFO = 0 IF( .NOT.LSAME( JOB, 'F' ) .AND. .NOT.REDIF ) THEN INFO = -1 ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA ) THEN INFO = -2 ELSE IF( ICOMPQ.LE.0 ) THEN INFO = -3 ELSE IF( ICOMPZ.LE.0 ) 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( ( .NOT.REDIF .AND. LDC.LT.MAX( 1, P ) ) .OR. $ ( REDIF .AND. LDC.LT.MAX( 1, M, P ) ) )THEN INFO = -15 ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -17 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -19 ELSE IF( TOL.GE.ONE ) THEN INFO = -24 ELSE LQUERY = LDWORK.EQ.-1 IF( N.EQ.0 ) THEN MINWRK = 1 ELSE MINWRK = N + MAX( 3*N, M, P ) END IF IF( LQUERY ) THEN RANKE = MAX( 1, INT( N/2 ) ) RNKA22 = N - RANKE C IF( REDIF ) THEN CALL TG01FD( COMPZ, COMPQ, 'Trapezoidal', N, N, P, M, A, $ LDA, E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, $ RANKE, RNKA22, TOL, IWORK, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) CALL TG01LY( ILZ, ILQ, N, P, M, RANKE, RNKA22, A, LDA, $ E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NF, $ NIBLCK, IBLCK, TOL, IWORK, DWORK, -1, INFO ) ELSE CALL TG01FD( COMPQ, COMPZ, 'Trapezoidal', N, N, M, P, A, $ LDA, E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, $ RANKE, RNKA22, TOL, IWORK, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) CALL TG01LY( ILQ, ILZ, N, M, P, RANKE, RNKA22, A, LDA, $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NF, $ NIBLCK, IBLCK, TOL, IWORK, DWORK, -1, INFO ) END IF WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -27 END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01LD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible C IF( N.EQ.0 ) THEN NF = 0 ND = 0 NIBLCK = 0 DWORK(1) = ONE RETURN END IF C IF( REDIF ) THEN C C Build the dual system. C CALL AB07MD( 'Z', N, M, P, A, LDA, B, LDB, C, LDC, DUM, 1, $ INFO ) DO 10 I = 2, N CALL DSWAP( I-1, E(I,1), LDE, E(1,I), 1 ) 10 CONTINUE C C Reduce to SVD-like form with A22 in QR-form. C CALL TG01FD( COMPZ, COMPQ, 'Trapezoidal', N, N, P, M, A, LDA, $ E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, RANKE, $ RNKA22, TOL, IWORK, DWORK, LDWORK, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) C C Perform finite-infinite separation. C CALL TG01LY( ILZ, ILQ, N, P, M, RANKE, RNKA22, A, LDA, $ E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NF, $ NIBLCK, IBLCK, TOL, IWORK, DWORK, LDWORK, INFO ) ILO = N - NF + 1 IHI = N ELSE C C Reduce to SVD-like form with A22 in QR-form. C CALL TG01FD( COMPQ, COMPZ, 'Trapezoidal', N, N, M, P, A, LDA, $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, $ RNKA22, TOL, IWORK, DWORK, LDWORK, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) C C Perform finite-infinite separation. C CALL TG01LY( ILQ, ILZ, N, M, P, RANKE, RNKA22, A, LDA, $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NF, $ NIBLCK, IBLCK, TOL, IWORK, DWORK, LDWORK, INFO ) ILO = 1 IHI = NF END IF C IF( INFO.NE.0 ) $ RETURN WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C ND = N - RANKE C IF( REDIF ) THEN C C Compute the pertransposed dual system exploiting matrix shapes. C CALL TB01XD( 'Z', N, P, M, MAX( 0, NF-1 ), MAX( 0, N-1 ), $ A, LDA, B, LDB, C, LDC, DUM, 1, INFO ) CALL MA02CD( N, 0, MAX( 0, N-1 ), E, LDE ) IF( ILQ ) $ CALL MA02BD( 'Right', N, N, Q, LDQ ) IF( ILZ ) $ CALL MA02BD( 'Right', N, N, Z, LDZ ) END IF C C If required, reduce (A,E) to generalized Hessenberg form. C IF( REDA ) THEN IF( ILQ) THEN JOBQ = 'V' ELSE JOBQ = 'N' END IF IF( ILZ) THEN JOBZ = 'V' ELSE JOBZ = 'N' END IF CALL TG01BD( 'Upper', JOBQ, JOBZ, N, M, P, ILO, IHI, A, LDA, $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, DWORK, $ LDWORK, INFO ) END IF C DWORK(1) = WRKOPT C RETURN C *** Last line of TG01LD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10PD.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10PD.f0000644000175000017500000004152715012430707017373 0ustar00lilgelilge00000000000000 SUBROUTINE SB10PD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, $ D, LDD, TU, LDTU, TY, LDTY, RCOND, TOL, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To reduce the matrices D12 and D21 of the linear time-invariant C system C C | A | B1 B2 | | A | B | C P = |----|---------| = |---|---| C | C1 | D11 D12 | | C | D | C | C2 | D21 D22 | C C to unit diagonal form, to transform the matrices B, C, and D11 to C satisfy the formulas in the computation of an H2 and H-infinity C (sub)optimal controllers and to check the rank conditions. 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 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/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, the leading N-by-M part of this array must C contain the system input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed system input matrix B. C C LDB INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) C On entry, the leading NP-by-N part of this array must C contain the system output matrix C. C On exit, the leading NP-by-N part of this array contains C the transformed system output matrix C. C C LDC INTEGER C The leading dimension of the array C. LDC >= max(1,NP). C C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) C On entry, the leading NP-by-M part of this array must C contain the system input/output matrix D. The C NMEAS-by-NCON trailing submatrix D22 is not referenced. C On exit, the leading (NP-NMEAS)-by-(M-NCON) part of this C array contains the transformed submatrix D11. C The transformed submatrices D12 = [ 0 Im2 ]' and C D21 = [ 0 Inp2 ] are not stored. The corresponding part C of this array contains no useful information. C C LDD INTEGER C The leading dimension of the array D. LDD >= max(1,NP). C C TU (output) DOUBLE PRECISION array, dimension (LDTU,M2) C The leading M2-by-M2 part of this array contains the C control transformation matrix TU. C C LDTU INTEGER C The leading dimension of the array TU. LDTU >= max(1,M2). C C TY (output) DOUBLE PRECISION array, dimension (LDTY,NP2) C The leading NP2-by-NP2 part of this array contains the C measurement transformation matrix TY. C C LDTY INTEGER C The leading dimension of the array TY. C LDTY >= max(1,NP2). C C RCOND (output) DOUBLE PRECISION array, dimension (2) C RCOND(1) contains the reciprocal condition number of the C control transformation matrix TU; C RCOND(2) contains the reciprocal condition number of the C measurement transformation matrix TY. C RCOND is set even if INFO = 3 or INFO = 4; if INFO = 3, C then RCOND(2) was not computed, but it is set to 0. C C Tolerances C C TOL DOUBLE PRECISION C Tolerance used for controlling the accuracy of the applied C transformations. Transformation matrices TU and TY whose C reciprocal condition numbers are less than TOL are not C 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 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(1,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 = 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 with M1 = M - M2 and NP1 = NP - NP2. C For good performance, LDWORK must generally be larger. C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is C MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+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: if the matrix | A B2 | had not full column rank C | C1 D12 | C in respect to the tolerance EPS; C = 2: if the matrix | A B1 | had not full row rank in C | C2 D21 | C 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 C METHOD C C The routine performs the transformations described in [2]. 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 NUMERICAL ASPECTS C C The precision of the transformations can be controlled by the C condition numbers of the matrices TU and TY as given by the C values of RCOND(1) and RCOND(2), respectively. An error return C with INFO = 3 or INFO = 4 will be obtained if the condition C number of TU or TY, respectively, would exceed 1/TOL. 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 Feb. 2000. C C KEYWORDS C C H-infinity optimal control, robust control, singular value C decomposition. 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, LDB, LDC, LDD, LDTU, LDTY, LDWORK, $ M, N, NCON, NMEAS, NP DOUBLE PRECISION TOL C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), DWORK( * ), RCOND( 2 ), $ TU( LDTU, * ), TY( LDTY, * ) C .. C .. Local Scalars .. INTEGER IEXT, INFO2, IQ, IWRK, J, LWAMAX, M1, M2, $ MINWRK, ND1, ND2, NP1, NP2 DOUBLE PRECISION EPS, TOLL C .. C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. C .. External Subroutines .. EXTERNAL DGEMM, DGESVD, DLACPY, DSCAL, DSWAP, 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -11 ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN INFO = -13 ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN INFO = -15 ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN INFO = -17 ELSE C C Compute workspace. C MINWRK = MAX( 1, $ ( N + NP1 + 1 )*( N + M2 ) + $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), $ ( N + NP2 )*( N + M1 + 1 ) + $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), $ M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, $ 5*M2 ), $ NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, $ 5*NP2 ) ) IF( LDWORK.LT.MINWRK ) $ INFO = -21 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10PD', -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 DWORK( 1 ) = ONE RETURN END IF C ND1 = NP1 - M2 ND2 = M1 - NP2 EPS = DLAMCH( 'Epsilon' ) TOLL = TOL IF( TOLL.LE.ZERO ) THEN C C Set the default value of the tolerance for condition tests. C TOLL = SQRT( EPS ) END IF C C Determine if |A-jwI B2 | has full column rank at w = 0. C | C1 D12| C Workspace: need (N+NP1+1)*(N+M2) + C max(3*(N+M2)+N+NP1,5*(N+M2)); C prefer larger. C IEXT = N + M2 + 1 IWRK = IEXT + ( N + NP1 )*( N + M2 ) CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP1 ) CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( IEXT+N ), N+NP1 ) CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, $ DWORK( IEXT+(N+NP1)*N ), N+NP1 ) CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, $ DWORK( IEXT+(N+NP1)*N+N ), N+NP1 ) CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK( IEXT ), N+NP1, DWORK, $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 5 RETURN END IF IF( DWORK( N+M2 )/DWORK( 1 ).LE.EPS ) THEN INFO = 1 RETURN END IF LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 C C Determine if |A-jwI B1 | has full row rank at w = 0. C | C2 D21| C Workspace: need (N+NP2)*(N+M1+1) + C max(3*(N+NP2)+N+M1,5*(N+NP2)); C prefer larger. C IEXT = N + NP2 + 1 IWRK = IEXT + ( N + NP2 )*( N + M1 ) CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP2 ) CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( IEXT+N ), $ N+NP2 ) CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IEXT+(N+NP2)*N ), $ N+NP2 ) CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, $ DWORK( IEXT+(N+NP2)*N+N ), N+NP2 ) CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK( IEXT ), N+NP2, DWORK, $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 5 RETURN END IF IF( DWORK( N+NP2 )/DWORK( 1 ).LE.EPS ) THEN INFO = 2 RETURN END IF LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Determine SVD of D12, D12 = U12 S12 V12', and check if D12 has C full column rank. V12' is stored in TU. C Workspace: need M2 + NP1*NP1 + max(3*M2+NP1,5*M2); C prefer larger. C IQ = M2 + 1 IWRK = IQ + NP1*NP1 C CALL DGESVD( 'A', 'A', NP1, M2, D( 1, M1+1 ), LDD, DWORK, $ DWORK( IQ ), NP1, TU, LDTU, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 5 RETURN END IF C RCOND( 1 ) = DWORK( M2 )/DWORK( 1 ) IF( RCOND( 1 ).LE.TOLL ) THEN RCOND( 2 ) = ZERO INFO = 3 RETURN END IF LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Determine Q12. C IF( ND1.GT.0 ) THEN CALL DLACPY( 'Full', NP1, M2, DWORK( IQ ), NP1, D( 1, M1+1 ), $ LDD ) CALL DLACPY( 'Full', NP1, ND1, DWORK( IQ+NP1*M2 ), NP1, $ DWORK( IQ ), NP1 ) CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, $ DWORK( IQ+NP1*ND1 ), NP1 ) END IF C C Determine Tu by transposing in-situ and scaling. C DO 10 J = 1, M2 - 1 CALL DSWAP( J, TU( J+1, 1 ), LDTU, TU( 1, J+1 ), 1 ) 10 CONTINUE C DO 20 J = 1, M2 CALL DSCAL( M2, ONE/DWORK( J ), TU( 1, J ), 1 ) 20 CONTINUE C C Determine C1 =: Q12'*C1. C Workspace: M2 + NP1*NP1 + NP1*N. C CALL DGEMM( 'T', 'N', NP1, N, NP1, ONE, DWORK( IQ ), NP1, C, LDC, $ ZERO, DWORK( IWRK ), NP1 ) CALL DLACPY( 'Full', NP1, N, DWORK( IWRK ), NP1, C, LDC ) LWAMAX = MAX( IWRK + NP1*N - 1, LWAMAX ) C C Determine D11 =: Q12'*D11. C Workspace: M2 + NP1*NP1 + NP1*M1. C CALL DGEMM( 'T', 'N', NP1, M1, NP1, ONE, DWORK( IQ ), NP1, D, LDD, $ ZERO, DWORK( IWRK ), NP1 ) CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) C C Determine SVD of D21, D21 = U21 S21 V21', and check if D21 has C full row rank. U21 is stored in TY. C Workspace: need NP2 + M1*M1 + max(3*NP2+M1,5*NP2); C prefer larger. C IQ = NP2 + 1 IWRK = IQ + M1*M1 C CALL DGESVD( 'A', 'A', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, TY, $ LDTY, DWORK( IQ ), M1, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 5 RETURN END IF C RCOND( 2 ) = DWORK( NP2 )/DWORK( 1 ) IF( RCOND( 2 ).LE.TOLL ) THEN INFO = 4 RETURN END IF LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Determine Q21. C IF( ND2.GT.0 ) THEN CALL DLACPY( 'Full', NP2, M1, DWORK( IQ ), M1, D( NP1+1, 1 ), $ LDD ) CALL DLACPY( 'Full', ND2, M1, DWORK( IQ+NP2 ), M1, DWORK( IQ ), $ M1 ) CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, $ DWORK( IQ+ND2 ), M1 ) END IF C C Determine Ty by scaling and transposing in-situ. C DO 30 J = 1, NP2 CALL DSCAL( NP2, ONE/DWORK( J ), TY( 1, J ), 1 ) 30 CONTINUE C DO 40 J = 1, NP2 - 1 CALL DSWAP( J, TY( J+1, 1 ), LDTY, TY( 1, J+1 ), 1 ) 40 CONTINUE C C Determine B1 =: B1*Q21'. C Workspace: NP2 + M1*M1 + N*M1. C CALL DGEMM( 'N', 'T', N, M1, M1, ONE, B, LDB, DWORK( IQ ), M1, $ ZERO, DWORK( IWRK ), N ) CALL DLACPY( 'Full', N, M1, DWORK( IWRK ), N, B, LDB ) LWAMAX = MAX( IWRK + N*M1 - 1, LWAMAX ) C C Determine D11 =: D11*Q21'. C Workspace: NP2 + M1*M1 + NP1*M1. C CALL DGEMM( 'N', 'T', NP1, M1, M1, ONE, D, LDD, DWORK( IQ ), M1, $ ZERO, DWORK( IWRK ), NP1 ) CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) C C Determine B2 =: B2*Tu. C Workspace: N*M2. C CALL DGEMM( 'N', 'N', N, M2, M2, ONE, B( 1, M1+1 ), LDB, TU, LDTU, $ ZERO, DWORK, N ) CALL DLACPY( 'Full', N, M2, DWORK, N, B( 1, M1+1 ), LDB ) C C Determine C2 =: Ty*C2. C Workspace: NP2*N. C CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, TY, LDTY, $ C( NP1+1, 1 ), LDC, ZERO, DWORK, NP2 ) CALL DLACPY( 'Full', NP2, N, DWORK, NP2, C( NP1+1, 1 ), LDC ) C LWAMAX = MAX( N*MAX( M2, NP2 ), LWAMAX ) DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10PD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04QD.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04QD.f0000644000175000017500000003171315012430707017373 0ustar00lilgelilge00000000000000 SUBROUTINE SB04QD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, $ DWORK, LDWORK, INFO ) 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 If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 > 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 July 2011. 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 .. LOGICAL BLAS3, BLOCK, LQUERY INTEGER BL, CHUNK, I, IEIG, IFAIL, IHI, ILO, IND, ITAU, $ JWORK, MINDW, SDIM, WRKOPT C .. Local Arrays .. LOGICAL BWORK(1) C .. External Functions .. LOGICAL SELECT EXTERNAL 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 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( 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 ILO = 1 IHI = N MINDW = MAX( 1, 2*N*N + 9*N, 5*M, N + M ) IF( LQUERY ) THEN CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, $ SDIM, DWORK, DWORK, Z, LDZ, DWORK, -1, BWORK, $ IFAIL ) WRKOPT = MAX( MINDW, 2*M + INT( DWORK(1) ) ) CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK, DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) ) CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, $ DWORK, C, LDC, DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) ) CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, $ DWORK, C, LDC, DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) ) ELSE IF( LDWORK.LT.MINDW ) THEN INFO = -13 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB04QD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT 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 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 DWORK(1) = WRKOPT RETURN C *** Last line of SB04QD *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02BZ.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02BZ.f0000644000175000017500000000555415012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE MA02BZ( SIDE, M, N, A, LDA ) C C PURPOSE C C To reverse the order of rows and/or columns of a given matrix A C by pre-multiplying and/or post-multiplying it, respectively, with C a permutation matrix P, where P is a square matrix of appropriate C order, with ones down the secondary diagonal. C C ARGUMENTS C C Mode Parameters C C SIDE CHARACTER*1 C Specifies the operation to be performed, as follows: C = 'L': the order of rows of A is to be reversed by C pre-multiplying A with P; C = 'R': the order of columns of A is to be reversed by C post-multiplying A with P; C = 'B': both the order of rows and the order of columns C of A is to be reversed by pre-multiplying and C post-multiplying A with P. 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) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading M-by-N part of this array must C contain the given matrix whose rows and/or columns are to C be permuted. C On exit, the leading M-by-N part of this array contains C the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or C P*A*P if SIDE = 'B'. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, March 1998. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C - C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER SIDE INTEGER LDA, M, N C .. Array Arguments .. COMPLEX*16 A(LDA,*) C .. Local Scalars .. LOGICAL BSIDES INTEGER I, J, K, M2, N2 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL ZSWAP C .. Executable Statements .. C BSIDES = LSAME( SIDE, 'B' ) C IF( ( LSAME( SIDE, 'L' ) .OR. BSIDES ) .AND. M.GT.1 ) THEN C C Compute P*A. C M2 = M/2 K = M - M2 + 1 DO 10 J = 1, N CALL ZSWAP( M2, A(1,J), -1, A(K,J), 1 ) 10 CONTINUE END IF IF( ( LSAME( SIDE, 'R' ) .OR. BSIDES ) .AND. N.GT.1 ) THEN C C Compute A*P. C N2 = N/2 K = N - N2 + 1 DO 20 I = 1, M CALL ZSWAP( N2, A(I,1), -LDA, A(I,K), LDA ) 20 CONTINUE END IF C RETURN C *** Last line of MA02BZ *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01LD.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01LD.f0000644000175000017500000002672715012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, $ LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To reduce the system state matrix A to an ordered upper real C Schur form by using an orthogonal similarity transformation C A <-- U'*A*U and to apply the transformation to the matrices C B and C: B <-- U'*B and C <-- C*U. C The leading block of the resulting A has eigenvalues in a C suitably defined domain of interest. 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 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 JOBA CHARACTER*1 C Specifies the shape of the state dynamics matrix on entry C as follows: C = 'S': A is in an upper real Schur form; C = 'G': A is a general square dense matrix. C C Input/Output Parameters C C N (input) INTEGER C The order of the state-space representation, C i.e. the order of the matrix A. N >= 0. C C M (input) INTEGER C The number of system inputs, or of columns of B. M >= 0. C C P (input) INTEGER C The number of system outputs, or of rows of C. P >= 0. C C ALPHA (input) DOUBLE PRECISION. C Specifies the boundary of the domain of interest for the C eigenvalues of A. For a continuous-time system C (DICO = 'C'), ALPHA is the boundary value for the real C parts of eigenvalues, while for a discrete-time system C (DICO = 'D'), ALPHA >= 0 represents the boundary value C for the moduli of 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 the unreduced state dynamics matrix A. C If JOBA = 'S' then A must be a matrix in real Schur form. C On exit, the leading N-by-N part of this array contains C the ordered real Schur matrix U' * A * U with the elements C below the first subdiagonal set to zero. C The leading NDIM-by-NDIM part of A has eigenvalues in the C domain of interest and the trailing (N-NDIM)-by-(N-NDIM) C part has eigenvalues outside the domain of interest. C The domain of interest for lambda(A), the eigenvalues C of A, is defined by the parameters ALPHA, DICO and STDOM C as follows: C For a continuous-time system (DICO = 'C'): C Real(lambda(A)) < ALPHA if STDOM = 'S'; C Real(lambda(A)) > ALPHA if STDOM = 'U'; C For a discrete-time system (DICO = 'D'): C Abs(lambda(A)) < ALPHA if STDOM = 'S'; C Abs(lambda(A)) > ALPHA if STDOM = 'U'. 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 matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix U' * B. 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 output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed output matrix C * U. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C NDIM (output) INTEGER C The number of eigenvalues of A lying inside the domain of C interest for eigenvalues. C C U (output) DOUBLE PRECISION array, dimension (LDU,N) C The leading N-by-N part of this array contains the C orthogonal transformation matrix used to reduce A to the C real Schur form and/or to reorder the diagonal blocks of C real Schur form of A. The first NDIM columns of U form C an orthogonal basis for the invariant subspace of A C corresponding to the first NDIM eigenvalues. C C LDU INTEGER C The leading dimension of array U. LDU >= max(1,N). C C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) C WR and WI contain the real and imaginary parts, C respectively, of the computed eigenvalues of A. The C eigenvalues will be in the same order that they appear on C the diagonal of the output real Schur form of A. Complex C conjugate pairs of eigenvalues will appear consecutively C with the eigenvalue having the positive imaginary part C first. 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,N) if JOBA = 'S'; C LDWORK >= MAX(1,3*N) if JOBA = 'G'. 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: the QR algorithm failed to compute all the C eigenvalues of A; C = 2: a failure occured during the ordering of the real C Schur form of A. C C METHOD C C Matrix A is reduced to an ordered upper real Schur form using an C orthogonal similarity transformation A <-- U'*A*U. This C transformation is determined so that the leading block of the C resulting A has eigenvalues in a suitably defined domain of C interest. Then, the transformation is applied to the matrices B C and C: B <-- U'*B and C <-- C*U. C C NUMERICAL ASPECTS C 3 C The algorithm requires about 14N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, March 1998. C Based on the RASP routine SRSFOD. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. C C KEYWORDS C C Invariant subspace, orthogonal transformation, real Schur form, C similarity transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOBA, STDOM INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, NDIM, P DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), $ WI(*), WR(*) C .. Local Scalars .. LOGICAL DISCR, LJOBG INTEGER I, IERR, LDWP, SDIM DOUBLE PRECISION WRKOPT C .. Local Arrays .. LOGICAL BWORK( 1 ) C .. External Functions .. LOGICAL LSAME, SELECT EXTERNAL LSAME, SELECT C .. External Subroutines .. EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, DLASET, $ MB03QD, MB03QX, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C C .. Executable Statements .. C INFO = 0 DISCR = LSAME( DICO, 'D' ) LJOBG = LSAME( JOBA, 'G' ) C C Check input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR. $ LSAME( STDOM, 'U' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( LSAME( JOBA, 'S' ) .OR. LJOBG ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDU.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LDWORK.LT.MAX( 1, N ) .OR. $ LDWORK.LT.MAX( 1, 3*N ) .AND. LJOBG ) THEN INFO = -20 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01LD', -INFO ) RETURN END IF C C Quick return if possible. C NDIM = 0 IF( N.EQ.0 ) $ RETURN C IF( LSAME( JOBA, 'G' ) ) THEN C C Reduce A to real Schur form using an orthogonal similarity C transformation A <- U'*A*U, accumulate the transformation in U C and compute the eigenvalues of A in (WR,WI). C C Workspace: need 3*N; C prefer larger. C CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) WRKOPT = DWORK( 1 ) IF( INFO.NE.0 ) THEN INFO = 1 RETURN END IF ELSE C C Initialize U with an identity matrix. C CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) WRKOPT = 0 END IF C C Separate the spectrum of A. The leading NDIM-by-NDIM submatrix of C A corresponds to the eigenvalues of interest. C Workspace: need N. C CALL MB03QD( DICO, STDOM, 'Update', N, 1, N, ALPHA, A, LDA, $ U, LDU, NDIM, DWORK, INFO ) IF( INFO.NE.0 ) $ RETURN C C Compute the eigenvalues. C CALL MB03QX( N, A, LDA, WR, WI, IERR ) C C Apply the transformation: B <-- U'*B. C IF( LDWORK.LT.N*M ) THEN C C Not enough working space for using DGEMM. C DO 10 I = 1, M CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, $ B(1,I), 1 ) 10 CONTINUE C ELSE CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU, $ DWORK, N, ZERO, B, LDB ) WRKOPT = MAX( WRKOPT, DBLE( N*M ) ) END IF C C Apply the transformation: C <-- C*U. C IF( LDWORK.LT.N*P ) THEN C C Not enough working space for using DGEMM. C DO 20 I = 1, P CALL DCOPY( N, C(I,1), LDC, DWORK, 1 ) CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, $ C(I,1), LDC ) 20 CONTINUE C ELSE LDWP = MAX( 1, P ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP ) CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, $ DWORK, LDWP, U, LDU, ZERO, C, LDC ) WRKOPT = MAX( WRKOPT, DBLE( N*P ) ) END IF C DWORK( 1 ) = WRKOPT C RETURN C *** Last line of TB01LD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04IZ.f0000644000000000000000000000013215012430707016202 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04IZ.f0000644000175000017500000002076115012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE MB04IZ( N, M, P, L, A, LDA, B, LDB, TAU, ZWORK, LZWORK, $ INFO ) C C PURPOSE C C To compute a QR factorization of an n-by-m matrix A (A = Q * R), C having a p-by-min(p,m) zero triangle in the lower left-hand side C corner, as shown below, for n = 8, m = 7, and p = 2: C C [ x x x x x x x ] C [ x x x x x x x ] C [ x x x x x x x ] C [ x x x x x x x ] C A = [ x x x x x x x ], C [ x x x x x x x ] C [ 0 x x x x x x ] C [ 0 0 x x x x x ] C C and optionally apply the transformations to an n-by-l matrix B C (from the left). The problem structure is exploited. This C computation is useful, for instance, in combined measurement and C time update of one iteration of the time-invariant Kalman filter C (square root information filter). C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix A. N >= 0. C C M (input) INTEGER C The number of columns of the matrix A. M >= 0. C C P (input) INTEGER C The order of the zero triagle. P >= 0. C C L (input) INTEGER C The number of columns of the matrix B. L >= 0. C C A (input/output) COMPLEX*16 array, dimension (LDA,M) C On entry, the leading N-by-M part of this array must C contain the matrix A. The elements corresponding to the C zero P-by-MIN(P,M) lower trapezoidal/triangular part C (if P > 0) are not referenced. C On exit, the elements on and above the diagonal of this C array contain the MIN(N,M)-by-M upper trapezoidal matrix C R (R is upper triangular, if N >= M) of the QR C factorization, and the relevant elements below the C diagonal contain the trailing components (the vectors v, C see Method) of the elementary reflectors used in the C factorization. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C B (input/output) COMPLEX*16 array, dimension (LDB,L) C On entry, the leading N-by-L part of this array must C contain the matrix B. C On exit, the leading N-by-L part of this array contains C the updated matrix B. C If L = 0, this array is not referenced. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,N) if L > 0; C LDB >= 1 if L = 0. C C TAU (output) COMPLEX*16 array, dimension MIN(N,M) C The scalar factors of the elementary reflectors used. C C Workspace C C ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal value C of LZWORK. C C LZWORK The length of the array ZWORK. C LZWORK >= MAX(1,M-1,M-P,L). C For optimum performance LZWORK should be larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK 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 uses min(N,M) Householder transformations exploiting C the zero pattern of the 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 an (N-P+I-2)-vector. The components of v are stored C i i C in the i-th column of A, beginning from the location i+1, and C tau is stored in TAU(i). C i C C NUMERICAL ASPECTS C C The algorithm is backward stable. C C CONTRIBUTORS C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009, C Apr. 2011. C C KEYWORDS C C Elementary reflector, QR factorization, unitary transformation. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. INTEGER INFO, L, LDA, LDB, LZWORK, M, N, P C .. Array Arguments .. COMPLEX*16 A(LDA,*), B(LDB,*), TAU(*), ZWORK(*) C .. Local Scalars .. LOGICAL LQUERY INTEGER I, WRKOPT COMPLEX*16 FIRST C .. External Subroutines .. EXTERNAL XERBLA, ZGEQRF, ZLARF, ZLARFG, ZUNMQR C .. Intrinsic Functions .. INTRINSIC DCONJG, INT, MAX, MIN C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 LQUERY = LZWORK.EQ.-1 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( L.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.1 .OR. ( L.GT.0 .AND. LDB.LT.N ) ) THEN INFO = -8 ELSE I = MAX( 1, M - 1, M - P, L ) IF( LQUERY ) THEN IF( M.GT.P ) THEN CALL ZGEQRF( N-P, M-P, A, LDA, TAU, ZWORK, -1, INFO ) WRKOPT = MAX( I, INT( ZWORK( 1 ) ) ) IF ( L.GT.0 ) THEN CALL ZUNMQR( 'Left', 'Conjugate', N-P, L, MIN(N,M)-P, $ A, LDA, TAU, B, LDB, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK( 1 ) ) ) END IF END IF ELSE IF( LZWORK.LT.I ) THEN INFO = -11 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB04IZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN ZWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF( MIN( M, N ).EQ.0 ) THEN ZWORK(1) = ONE RETURN ELSE IF( N.LE.P+1 ) THEN DO 5 I = 1, MIN( N, M ) TAU(I) = ZERO 5 CONTINUE ZWORK(1) = ONE RETURN END IF C C Annihilate the subdiagonal elements of A and apply the C transformations to B, if L > 0. C Workspace: need MAX(M-1,L). C C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of complex 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 10 I = 1, MIN( P, M ) C C Exploit the structure of the I-th column of A. C CALL ZLARFG( N-P, A(I,I), A(I+1,I), 1, TAU(I) ) IF( TAU(I).NE.ZERO ) THEN C FIRST = A(I,I) A(I,I) = ONE C IF ( I.LT.M ) CALL ZLARF( 'Left', N-P, M-I, A(I,I), 1, $ DCONJG( TAU(I) ), A(I,I+1), LDA, $ ZWORK ) IF ( L.GT.0 ) CALL ZLARF( 'Left', N-P, L, A(I,I), 1, $ DCONJG( TAU(I) ), B(I,1), LDB, $ ZWORK ) C A(I,I) = FIRST END IF 10 CONTINUE C WRKOPT = MAX( 1, M - 1, L ) C C Fast QR factorization of the remaining right submatrix, if any. C Workspace: need M-P; prefer (M-P)*NB. C IF( M.GT.P ) THEN CALL ZGEQRF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), ZWORK, $ LZWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) C IF ( L.GT.0 ) THEN C C Apply the transformations to B. C Workspace: need L; prefer L*NB. C CALL ZUNMQR( 'Left', 'Conjugate', N-P, L, MIN(N,M)-P, $ A(P+1,P+1), LDA, TAU(P+1), B(P+1,1), LDB, $ ZWORK, LZWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) END IF END IF C ZWORK(1) = WRKOPT RETURN C *** Last line of MB04IZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04ID.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04ID.f0000644000175000017500000002042715012430707017355 0ustar00lilgelilge00000000000000 SUBROUTINE MB04ID( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute a QR factorization of an n-by-m matrix A (A = Q * R), C having a p-by-min(p,m) zero triangle in the lower left-hand side C corner, as shown below, for n = 8, m = 7, and p = 2: C C [ x x x x x x x ] C [ x x x x x x x ] C [ x x x x x x x ] C [ x x x x x x x ] C A = [ x x x x x x x ], C [ x x x x x x x ] C [ 0 x x x x x x ] C [ 0 0 x x x x x ] C C and optionally apply the transformations to an n-by-l matrix B C (from the left). The problem structure is exploited. This C computation is useful, for instance, in combined measurement and C time update of one iteration of the time-invariant Kalman filter C (square root information filter). C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix A. N >= 0. C C M (input) INTEGER C The number of columns of the matrix A. M >= 0. C C P (input) INTEGER C The order of the zero triagle. P >= 0. C C L (input) INTEGER C The number of columns of the matrix B. L >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) C On entry, the leading N-by-M part of this array must C contain the matrix A. The elements corresponding to the C zero P-by-MIN(P,M) lower trapezoidal/triangular part C (if P > 0) are not referenced. C On exit, the elements on and above the diagonal of this C array contain the MIN(N,M)-by-M upper trapezoidal matrix C R (R is upper triangular, if N >= M) of the QR C factorization, and the relevant elements below the C diagonal contain the trailing components (the vectors v, C see Method) of the elementary reflectors used in the C factorization. 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,L) C On entry, the leading N-by-L part of this array must C contain the matrix B. C On exit, the leading N-by-L part of this array contains C the updated matrix B. C If L = 0, this array is not referenced. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,N) if L > 0; C LDB >= 1 if L = 0. C C TAU (output) DOUBLE PRECISION array, dimension MIN(N,M) C The scalar factors of the elementary reflectors used. 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 The length of the array DWORK. C LDWORK >= MAX(1,M-1,M-P,L). 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 uses min(N,M) Householder transformations exploiting C the zero pattern of the 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 an (N-P+I-2)-vector. The components of v are stored C i i C in the i-th column of A, beginning from the location i+1, and C tau is stored in TAU(i). C i C C NUMERICAL ASPECTS C C The algorithm is backward stable. 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, Jan. 2009, C Apr. 2009, Apr. 2011. C C KEYWORDS C C Elementary reflector, QR factorization, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, L, LDA, LDB, LDWORK, M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*) C .. Local Scalars .. LOGICAL LQUERY INTEGER I, WRKOPT DOUBLE PRECISION FIRST C .. External Subroutines .. EXTERNAL DGEQRF, DLARF, DLARFG, DORMQR, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 LQUERY = LDWORK.EQ.-1 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( L.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.1 .OR. ( L.GT.0 .AND. LDB.LT.N ) ) THEN INFO = -8 ELSE I = MAX( 1, M - 1, M - P, L ) IF( LQUERY ) THEN IF( M.GT.P ) THEN CALL DGEQRF( N-P, M-P, A, LDA, TAU, DWORK, -1, INFO ) WRKOPT = MAX( I, INT( DWORK( 1 ) ) ) IF ( L.GT.0 ) THEN CALL DORMQR( 'Left', 'Transpose', N-P, L, MIN(N,M)-P, $ A, LDA, TAU, B, LDB, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK( 1 ) ) ) END IF END IF ELSE IF( LDWORK.LT.I ) THEN INFO = -11 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB04ID', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF( MIN( M, N ).EQ.0 ) THEN DWORK(1) = ONE RETURN ELSE IF( N.LE.P+1 ) THEN DO 5 I = 1, MIN( N, M ) TAU(I) = ZERO 5 CONTINUE DWORK(1) = ONE RETURN END IF C C Annihilate the subdiagonal elements of A and apply the C transformations to B, if L > 0. C Workspace: need MAX(M-1,L). 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 10 I = 1, MIN( P, M ) C C Exploit the structure of the I-th column of A. C CALL DLARFG( N-P, A(I,I), A(I+1,I), 1, TAU(I) ) IF( TAU(I).NE.ZERO ) THEN C FIRST = A(I,I) A(I,I) = ONE C IF ( I.LT.M ) CALL DLARF( 'Left', N-P, M-I, A(I,I), 1, $ TAU(I), A(I,I+1), LDA, DWORK ) IF ( L.GT.0 ) CALL DLARF( 'Left', N-P, L, A(I,I), 1, TAU(I), $ B(I,1), LDB, DWORK ) C A(I,I) = FIRST END IF 10 CONTINUE C WRKOPT = MAX( 1, M - 1, L ) C C Fast QR factorization of the remaining right submatrix, if any. C Workspace: need M-P; prefer (M-P)*NB. C IF( M.GT.P ) THEN CALL DGEQRF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), DWORK, $ LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C IF ( L.GT.0 ) THEN C C Apply the transformations to B. C Workspace: need L; prefer L*NB. C CALL DORMQR( 'Left', 'Transpose', N-P, L, MIN(N,M)-P, $ A(P+1,P+1), LDA, TAU(P+1), B(P+1,1), LDB, $ DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF END IF C DWORK(1) = WRKOPT RETURN C *** Last line of MB04ID *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02YD.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02YD.f0000644000175000017500000002634415012430707017377 0ustar00lilgelilge00000000000000 SUBROUTINE MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANK, X, TOL, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To determine a vector x which solves the system of linear C equations C C A*x = b , D*x = 0 , C C in the least squares sense, where A is an m-by-n matrix, C D is an n-by-n diagonal matrix, and b is an m-vector. C It is assumed that a QR factorization, with column pivoting, of A C is available, that is, A*P = Q*R, where P is a permutation matrix, C Q has orthogonal columns, and R is an upper triangular matrix C with diagonal elements of nonincreasing magnitude. C The routine needs the full upper triangle of R, the permutation C matrix P, and the first n components of Q'*b (' denotes the C transpose). The system A*x = b, D*x = 0, is then equivalent to C C R*z = Q'*b , P'*D*P*z = 0 , (1) C C where x = P*z. If this system does not have full rank, then a C least squares solution is obtained. On output, MB02YD also C provides an upper triangular matrix S such that C C P'*(A'*A + D*D)*P = S'*S . C C The system (1) is equivalent to S*z = c , where c contains the C first n components of the vector obtained by applying to C [ (Q'*b)' 0 ]' the transformations which triangularized C [ R' P'*D*P ]', getting S. C C ARGUMENTS C C Mode Parameters C C COND CHARACTER*1 C Specifies whether the condition of the matrix S should be C estimated, as follows: C = 'E' : use incremental condition estimation and store C the numerical rank of S in RANK; C = 'N' : do not use condition estimation, but check the C diagonal entries of S for zero values; C = 'U' : use the rank already stored in RANK. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix R. N >= 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 full upper triangle is unaltered, and the C strict lower triangle contains the strict upper triangle C (transposed) of the upper triangular matrix S. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C IPVT (input) INTEGER array, dimension (N) C This array must define the permutation matrix P such that C A*P = Q*R. Column j of P is column IPVT(j) of the identity C matrix. C C DIAG (input) DOUBLE PRECISION array, dimension (N) C This array must contain the diagonal elements of the C matrix D. C C QTB (input) DOUBLE PRECISION array, dimension (N) C This array must contain the first n elements of the C vector Q'*b. C C RANK (input or output) INTEGER C On entry, if COND = 'U', this parameter must contain the C (numerical) rank of the matrix S. C On exit, if COND = 'E' or 'N', this parameter contains C the numerical rank of the matrix S, estimated according C to the value of COND. C C X (output) DOUBLE PRECISION array, dimension (N) C This array contains the least squares solution of the C system A*x = b, D*x = 0. C C Tolerances C C TOL DOUBLE PRECISION C If COND = 'E', the tolerance to be used for finding the C rank of the matrix S. If the user sets TOL > 0, then the C given value of TOL is used as a lower bound for the C reciprocal condition number; a (sub)matrix whose C estimated condition number is less than 1/TOL is C considered to be of full rank. If the user sets TOL <= 0, C then an implicitly computed, default tolerance, defined by C TOLDEF = N*EPS, is used instead, where EPS is the machine C precision (see LAPACK Library routine DLAMCH). C This parameter is not relevant if COND = 'U' or 'N'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, the first N elements of this array contain the C diagonal elements of the upper triangular matrix S, and C the next N elements contain the solution z. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 4*N, if COND = 'E'; C LDWORK >= 2*N, if COND <> 'E'. 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 Standard plane rotations are used to annihilate the elements of C the diagonal matrix D, updating the upper triangular matrix R C and the first n elements of the vector Q'*b. A basic least squares C solution is computed. C C REFERENCES C C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. C User's Guide for MINPACK-1. C Applied Math. Division, Argonne National Laboratory, Argonne, C Illinois, Report ANL-80-74, 1980. C C NUMERICAL ASPECTS C 2 C The algorithm requires 0(N ) operations and is backward stable. C C FURTHER COMMENTS C C This routine is a LAPACK-based modification of QRSOLV from the C MINPACK package [1], and with optional condition estimation. C The option COND = 'U' is useful when dealing with several C right-hand side vectors. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. C C KEYWORDS C C Linear system of equations, matrix operations, plane rotations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, SVLMAX PARAMETER ( ZERO = 0.0D0, SVLMAX = 0.0D0 ) C .. Scalar Arguments .. CHARACTER COND INTEGER INFO, LDR, LDWORK, N, RANK DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IPVT(*) DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*) C .. Local Scalars .. DOUBLE PRECISION CS, QTBPJ, SN, TEMP, TOLDEF INTEGER I, J, K, L LOGICAL ECOND, NCOND, UCOND C .. Local Arrays .. DOUBLE PRECISION DUM(3) C .. External Functions .. DOUBLE PRECISION DLAMCH LOGICAL LSAME EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLARTG, DROT, DSWAP, MB03OD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C .. C .. Executable Statements .. C C Check the scalar input parameters. C ECOND = LSAME( COND, 'E' ) NCOND = LSAME( COND, 'N' ) UCOND = LSAME( COND, 'U' ) INFO = 0 IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN INFO = -1 ELSEIF( N.LT.0 ) THEN INFO = -2 ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN INFO = -4 ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN INFO = -8 ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN INFO = -12 ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02YD', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( N.EQ.0 ) THEN IF ( .NOT.UCOND ) $ RANK = 0 RETURN END IF C C Copy R and Q'*b to preserve input and initialize S. C In particular, save the diagonal elements of R in X. C DO 20 J = 1, N X(J) = R(J,J) DO 10 I = J, N R(I,J) = R(J,I) 10 CONTINUE 20 CONTINUE C CALL DCOPY( N, QTB, 1, DWORK(N+1), 1 ) C C Eliminate the diagonal matrix D using Givens rotations. C DO 50 J = 1, N C C Prepare the row of D to be eliminated, locating the C diagonal element using P from the QR factorization. C L = IPVT(J) IF ( DIAG(L).NE.ZERO ) THEN QTBPJ = ZERO DWORK(J) = DIAG(L) C DO 30 K = J + 1, N DWORK(K) = ZERO 30 CONTINUE C C The transformations to eliminate the row of D modify only C a single element of Q'*b beyond the first n, which is C initially zero. C DO 40 K = J, N C C Determine a Givens rotation which eliminates the C appropriate element in the current row of D. C IF ( DWORK(K).NE.ZERO ) THEN C CALL DLARTG( R(K,K), DWORK(K), CS, SN, TEMP ) C C Compute the modified diagonal element of R and C the modified elements of (Q'*b,0). C Accumulate the tranformation in the row of S. C TEMP = CS*DWORK(N+K) + SN*QTBPJ QTBPJ = -SN*DWORK(N+K) + CS*QTBPJ DWORK(N+K) = TEMP CALL DROT( N-K+1, R(K,K), 1, DWORK(K), 1, CS, SN ) C END IF 40 CONTINUE C END IF C C Store the diagonal element of S and, if COND <> 'E', restore C the corresponding diagonal element of R. C DWORK(J) = R(J,J) IF ( .NOT.ECOND ) $ R(J,J) = X(J) 50 CONTINUE C C Solve the triangular system for z. If the system is singular, C then obtain a least squares solution. C IF ( ECOND ) THEN TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance in rank determination. C TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) END IF C C Interchange the strict upper and lower triangular parts of R. C DO 60 J = 2, N CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR ) 60 CONTINUE C C Estimate the reciprocal condition number of S and set the rank. C Additional workspace: 2*N. C CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TOLDEF, SVLMAX, $ DWORK, RANK, DUM, DWORK(2*N+1), LDWORK-2*N, $ INFO ) R(1,1) = X(1) C C Restore the strict upper and lower triangular parts of R. C DO 70 J = 2, N CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR ) R(J,J) = X(J) 70 CONTINUE C ELSEIF ( NCOND ) THEN C C Determine rank(S) by checking zero diagonal entries. C RANK = N C DO 80 J = 1, N IF ( DWORK(J).EQ.ZERO .AND. RANK.EQ.N ) $ RANK = J - 1 80 CONTINUE C END IF C DUM(1) = ZERO IF ( RANK.LT.N ) $ CALL DCOPY( N-RANK, DUM, 0, DWORK(N+RANK+1), 1 ) C C Solve S*z = c using back substitution. C DO 100 J = RANK, 1, -1 TEMP = ZERO C DO 90 I = J + 1, RANK TEMP = TEMP + R(I,J)*DWORK(N+I) 90 CONTINUE C DWORK(N+J) = ( DWORK(N+J) - TEMP )/DWORK(J) 100 CONTINUE C C Permute the components of z back to components of x. C DO 110 J = 1, N L = IPVT(J) X(L) = DWORK(N+J) 110 CONTINUE C RETURN C C *** Last line of MB02YD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04PD.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04PD.f0000644000175000017500000006001115012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE SB04PD( DICO, FACTA, FACTB, TRANA, TRANB, ISGN, M, N, $ A, LDA, U, LDU, B, LDB, V, LDV, C, LDC, SCALE, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To solve for X either the real continuous-time Sylvester equation C C op(A)*X + ISGN*X*op(B) = scale*C, (1) C C or the real discrete-time Sylvester equation C C op(A)*X*op(B) + ISGN*X = scale*C, (2) C C where op(M) = M or M**T, and ISGN = 1 or -1. A is M-by-M and C B is N-by-N; the right hand side C and the solution X are M-by-N; C and scale is an output scale factor, set less than or equal to 1 C to avoid overflow in X. The solution matrix X is overwritten C onto C. C C If A and/or B are not (upper) quasi-triangular, that is, block C upper triangular with 1-by-1 and 2-by-2 diagonal blocks, they are C reduced to Schur canonical form, that is, quasi-triangular with C each 2-by-2 diagonal block having its diagonal elements equal and C its off-diagonal elements of opposite sign. 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 FACTA 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 = 'S': The matrix A is quasi-triangular (or Schur). C C FACTB CHARACTER*1 C Specifies whether or not the real Schur factorization C of the matrix B is supplied on entry, as follows: C = 'F': On entry, B and V contain the factors from the C real Schur factorization of the matrix B; C = 'N': The Schur factorization of B will be computed C and the factors will be stored in B and V; C = 'S': The matrix B is quasi-triangular (or Schur). 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 TRANB CHARACTER*1 C Specifies the form of op(B) to be used, as follows: C = 'N': op(B) = B (No transpose); C = 'T': op(B) = B**T (Transpose); C = 'C': op(B) = B**T (Conjugate transpose = Transpose). C C ISGN INTEGER C Specifies the sign of the equation as described before. C ISGN may only be 1 or -1. C C Input/Output Parameters C C M (input) INTEGER C The order of the matrix A, and the number of rows in the C matrices X and C. M >= 0. C C N (input) INTEGER C The order of the matrix B, and the number of columns in C the matrices X and C. N >= 0. C C A (input or input/output) DOUBLE PRECISION array, C dimension (LDA,M) C On entry, the leading M-by-M part of this array must C contain the matrix A. If FACTA = 'S', then A contains C a quasi-triangular matrix, and if FACTA = 'F', then A C is in Schur canonical form; the elements below the upper C Hessenberg part of the array A are not referenced. C On exit, if FACTA = 'N', and INFO = 0 or INFO >= M+1, the C leading M-by-M upper Hessenberg part of this array C contains the upper quasi-triangular matrix in Schur C canonical form from the Schur factorization of A. The C contents of array A is not modified if FACTA = 'F' or 'S'. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C U (input or output) DOUBLE PRECISION array, dimension C (LDU,M) C If FACTA = 'F', then U is an input argument and on entry C the leading M-by-M part of this array must contain the C orthogonal matrix U of the real Schur factorization of A. C If FACTA = 'N', then U is an output argument and on exit, C if INFO = 0 or INFO >= M+1, it contains the orthogonal C M-by-M matrix from the real Schur factorization of A. C If FACTA = 'S', the array U is not referenced. C C LDU INTEGER C The leading dimension of array U. C LDU >= MAX(1,M), if FACTA = 'F' or 'N'; C LDU >= 1, if FACTA = 'S'. C C B (input or input/output) DOUBLE PRECISION array, C dimension (LDB,N) C On entry, the leading N-by-N part of this array must C contain the matrix B. If FACTB = 'S', then B contains C a quasi-triangular matrix, and if FACTB = 'F', then B C is in Schur canonical form; the elements below the upper C Hessenberg part of the array B are not referenced. C On exit, if FACTB = 'N', and INFO = 0 or INFO = M+N+1, C the leading N-by-N upper Hessenberg part of this array C contains the upper quasi-triangular matrix in Schur C canonical form from the Schur factorization of B. The C contents of array B is not modified if FACTB = 'F' or 'S'. C C LDB (input) INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C V (input or output) DOUBLE PRECISION array, dimension C (LDV,N) C If FACTB = 'F', then V is an input argument and on entry C the leading N-by-N part of this array must contain the C orthogonal matrix V of the real Schur factorization of B. C If FACTB = 'N', then V is an output argument and on exit, C if INFO = 0 or INFO = M+N+1, it contains the orthogonal C N-by-N matrix from the real Schur factorization of B. C If FACTB = 'S', the array V is not referenced. C C LDV INTEGER C The leading dimension of array V. C LDV >= MAX(1,N), if FACTB = 'F' or 'N'; C LDV >= 1, if FACTB = 'S'. 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 right hand side matrix C. C On exit, if INFO = 0 or INFO = M+N+1, the leading M-by-N C part of this array contains the solution matrix X. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,M). 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 Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or M+N+1, then: DWORK(1) returns the C optimal value of LDWORK; if FACTA = 'N', DWORK(1+i) and C DWORK(1+M+i), i = 1,...,M, contain the real and imaginary C parts, respectively, of the eigenvalues of A; and, if C FACTB = 'N', DWORK(1+f+j) and DWORK(1+f+N+j), j = 1,...,N, C with f = 2*M if FACTA = 'N', and f = 0, otherwise, contain C the real and imaginary parts, respectively, of the C eigenvalues of B. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( 1, a+MAX( c, b+d, b+e ) ), C where a = 1+2*M, if FACTA = 'N', C a = 0, if FACTA <> 'N', C b = 2*N, if FACTB = 'N', FACTA = 'N', C b = 1+2*N, if FACTB = 'N', FACTA <> 'N', C b = 0, if FACTB <> 'N', C c = 3*M, if FACTA = 'N', C c = M, if FACTA = 'F', C c = 0, if FACTA = 'S', C d = 3*N, if FACTB = 'N', C d = N, if FACTB = 'F', C d = 0, if FACTB = 'S', C e = M, if DICO = 'C', FACTA <> 'S', C e = 0, if DICO = 'C', FACTA = 'S', C e = 2*M, if DICO = 'D'. C An upper bound is C LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M ). C For good performance, LDWORK should be larger, e.g., C LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M, 2*N+M*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 = i: if INFO = i, i = 1,...,M, the QR algorithm failed C to compute all the eigenvalues of the matrix A C (see LAPACK Library routine DGEES); the elements C 2+i:1+M and 2+i+M:1+2*M of DWORK contain the real C and imaginary parts, respectively, of the C eigenvalues of A which have converged, and the C array A contains the partially converged Schur form; C = M+j: if INFO = M+j, j = 1,...,N, the QR algorithm C failed to compute all the eigenvalues of the matrix C B (see LAPACK Library routine DGEES); the elements C 2+f+j:1+f+N and 2+f+j+N:1+f+2*N of DWORK contain the C real and imaginary parts, respectively, of the C eigenvalues of B which have converged, and the C array B contains the partially converged Schur form; C as defined for the parameter DWORK, C f = 2*M, if FACTA = 'N', C f = 0, if FACTA <> 'N'; C = M+N+1: if DICO = 'C', and the matrices A and -ISGN*B C have common or very close eigenvalues, or C if DICO = 'D', and the matrices A and -ISGN*B have C almost reciprocal eigenvalues (that is, if lambda(i) C and mu(j) are eigenvalues of A and -ISGN*B, then C lambda(i) = 1/mu(j) for some i and j); C perturbed values were used to solve the equation C (but the matrices A and B are unchanged). C C METHOD C C An extension and refinement of the algorithms in [1,2] is used. C If the matrices A and/or B are not quasi-triangular (see PURPOSE), C they are reduced to Schur canonical form C C A = U*S*U', B = V*T*V', C C where U, V are orthogonal, and S, T are block upper triangular C with 1-by-1 and 2-by-2 blocks on their diagonal. The right hand C side matrix C is updated accordingly, C C C = U'*C*V; C C then, the solution matrix X of the "reduced" Sylvester equation C (with A and B in (1) or (2) replaced by S and T, respectively), C is computed column-wise via a back substitution scheme. A set of C equivalent linear algebraic systems of equations of order at most C four are formed and solved using Gaussian elimination with C complete pivoting. Finally, the solution X of the original C equation is obtained from the updating formula C C X = U*X*V'. C C If A and/or B are already quasi-triangular (or in Schur form), the C initial factorizations and the corresponding updating steps are C omitted. C C REFERENCES C C [1] 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 [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C The algorithm is stable and reliable, since orthogonal C transformations and Gaussian elimination with complete pivoting C are used. If INFO = M+N+1, the Sylvester equation is numerically C singular. C C CONTRIBUTORS C C D. Sima, University of Bucharest, April 2000. C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. C C REVISIONS C C - C C KEYWORDS C C Matrix algebra, orthogonal transformation, real Schur form, C Sylvester equation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER DICO, FACTA, FACTB, TRANA, TRANB INTEGER INFO, ISGN, LDA, LDB, LDC, LDU, LDV, LDWORK, M, $ N DOUBLE PRECISION SCALE C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), U( LDU, * ), V( LDV, * ) C .. C .. Local Scalars .. LOGICAL BLAS3A, BLAS3B, BLOCKA, BLOCKB, CONT, NOFACA, $ NOFACB, NOTRNA, NOTRNB, SCHURA, SCHURB INTEGER AVAILW, BL, CHUNKA, CHUNKB, I, IA, IB, IERR, J, $ JWORK, MAXWRK, MINWRK, SDIM C .. C .. Local Arrays .. LOGICAL BWORK( 1 ) C .. C .. External Functions .. LOGICAL LSAME, SELECT EXTERNAL LSAME, SELECT C .. C .. External Subroutines .. EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, DTRSYL, $ SB04PY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C C Decode and Test input parameters C CONT = LSAME( DICO, 'C' ) NOFACA = LSAME( FACTA, 'N' ) NOFACB = LSAME( FACTB, 'N' ) SCHURA = LSAME( FACTA, 'S' ) SCHURB = LSAME( FACTB, 'S' ) NOTRNA = LSAME( TRANA, 'N' ) NOTRNB = LSAME( TRANB, 'N' ) C INFO = 0 IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN INFO = -1 ELSE IF( .NOT.NOFACA .AND. .NOT.LSAME( FACTA, 'F' ) .AND. $ .NOT.SCHURA ) THEN INFO = -2 ELSE IF( .NOT.NOFACB .AND. .NOT.LSAME( FACTB, 'F' ) .AND. $ .NOT.SCHURB ) THEN INFO = -3 ELSE IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. $ .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -4 ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. $ .NOT.LSAME( TRANB, 'C' ) ) THEN INFO = -5 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -6 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( N.LT.0 ) THEN INFO = -8 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDU.LT.1 .OR. ( .NOT.SCHURA .AND. LDU.LT.M ) ) THEN INFO = -12 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDV.LT.1 .OR. ( .NOT.SCHURB .AND. LDV.LT.N ) ) THEN INFO = -16 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -18 ELSE IF ( NOFACA ) THEN IA = 1 + 2*M MINWRK = 3*M ELSE IA = 0 END IF IF ( SCHURA ) THEN MINWRK = 0 ELSE IF ( .NOT.NOFACA ) THEN MINWRK = M END IF IB = 0 IF ( NOFACB ) THEN IB = 2*N IF ( .NOT.NOFACA ) $ IB = IB + 1 MINWRK = MAX( MINWRK, IB + 3*N ) ELSE IF ( .NOT.SCHURB ) THEN MINWRK = MAX( MINWRK, N ) END IF IF ( CONT ) THEN IF ( .NOT.SCHURA ) $ MINWRK = MAX( MINWRK, IB + M ) ELSE MINWRK = MAX( MINWRK, IB + 2*M ) END IF MINWRK = MAX( 1, IA + MINWRK ) IF( LDWORK.LT.MINWRK ) $ INFO = -21 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB04PD', -INFO ) RETURN END IF C C Quick return if possible. C IF( M.EQ.0 .OR. N.EQ.0 ) THEN SCALE = ONE DWORK( 1 ) = ONE RETURN END IF MAXWRK = MINWRK C IF( NOFACA ) THEN C C Compute the Schur factorization of A. C Workspace: need 1+5*M; 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 JWORK = 2*M + 2 IA = JWORK AVAILW = LDWORK - JWORK + 1 CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, A, LDA, SDIM, $ DWORK( 2 ), DWORK( M+2 ), U, LDU, DWORK( JWORK ), $ AVAILW, BWORK, IERR ) IF( IERR.GT.0 ) THEN INFO = IERR RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) ELSE JWORK = 1 IA = 2 AVAILW = LDWORK END IF C IF( .NOT.SCHURA ) THEN C C Transform the right-hand side: C <-- U'*C. C Workspace: need a+M, C prefer a+M*N, C where a = 1+2*M, if FACTA = 'N', C a = 0, if FACTA <> 'N'. C CHUNKA = AVAILW / M BLOCKA = MIN( CHUNKA, N ).GT.1 BLAS3A = CHUNKA.GE.N .AND. BLOCKA C IF ( BLAS3A ) THEN C C Enough workspace for a fast BLAS 3 algorithm. C CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, ONE, $ U, LDU, DWORK( JWORK ), M, ZERO, C, LDC ) ELSE IF ( BLOCKA ) THEN C C Use as many columns of C as possible. C DO 10 J = 1, N, CHUNKA BL = MIN( N-J+1, CHUNKA ) CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC, $ DWORK( JWORK ), M ) CALL DGEMM( 'Transpose', 'NoTranspose', M, BL, M, ONE, $ U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ), $ LDC ) 10 CONTINUE C ELSE C C Use a BLAS 2 algorithm. C DO 20 J = 1, N CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 ) CALL DGEMV( 'Transpose', M, M, ONE, U, LDU, $ DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 ) 20 CONTINUE C END IF MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 ) END IF C IF( NOFACB ) THEN C C Compute the Schur factorization of B. C Workspace: need 1+MAX(a-1,0)+5*N, C prefer larger. C JWORK = IA + 2*N AVAILW = LDWORK - JWORK + 1 CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, B, LDB, SDIM, $ DWORK( IA ), DWORK( N+IA ), V, LDV, DWORK( JWORK ), $ AVAILW, BWORK, IERR ) IF( IERR.GT.0 ) THEN INFO = IERR + M RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) C IF( .NOT.SCHURA ) THEN C C Recompute the blocking parameters. C CHUNKA = AVAILW / M BLOCKA = MIN( CHUNKA, N ).GT.1 BLAS3A = CHUNKA.GE.N .AND. BLOCKA END IF END IF C IF( .NOT.SCHURB ) THEN C C Transform the right-hand side: C <-- C*V. C Workspace: need a+b+N, C prefer a+b+M*N, C where b = 2*N, if FACTB = 'N', FACTA = 'N', C b = 1+2*N, if FACTB = 'N', FACTA <> 'N', C b = 0, if FACTB <> 'N'. C CHUNKB = AVAILW / N BLOCKB = MIN( CHUNKB, M ).GT.1 BLAS3B = CHUNKB.GE.M .AND. BLOCKB C IF ( BLAS3B ) THEN C C Enough workspace for a fast BLAS 3 algorithm. C CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, ONE, $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) ELSE IF ( BLOCKB ) THEN C C Use as many rows of C as possible. C DO 30 I = 1, M, CHUNKB BL = MIN( M-I+1, CHUNKB ) CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, $ DWORK( JWORK ), BL ) CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE, $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), $ LDC ) 30 CONTINUE C ELSE C C Use a BLAS 2 algorithm. C DO 40 I = 1, M CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) 40 CONTINUE C END IF MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 ) END IF C C Solve the (transformed) equation. C Workspace for DICO = 'D': a+b+2*M. C IF ( CONT ) THEN CALL DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, $ SCALE, IERR ) ELSE CALL SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, $ SCALE, DWORK( JWORK ), IERR ) MAXWRK = MAX( MAXWRK, JWORK + 2*M - 1 ) END IF IF( IERR.GT.0 ) $ INFO = M + N + 1 C C Transform back the solution, if needed. C IF( .NOT.SCHURA ) THEN C C Transform the right-hand side: C <-- U*C. C Workspace: need a+b+M; C prefer a+b+M*N. C IF ( BLAS3A ) THEN C C Enough workspace for a fast BLAS 3 algorithm. C CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE, $ U, LDU, DWORK( JWORK ), M, ZERO, C, LDC ) ELSE IF ( BLOCKA ) THEN C C Use as many columns of C as possible. C DO 50 J = 1, N, CHUNKA BL = MIN( N-J+1, CHUNKA ) CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC, $ DWORK( JWORK ), M ) CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE, $ U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ), $ LDC ) 50 CONTINUE C ELSE C C Use a BLAS 2 algorithm. C DO 60 J = 1, N CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 ) CALL DGEMV( 'NoTranspose', M, M, ONE, U, LDU, $ DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 ) 60 CONTINUE C END IF END IF C IF( .NOT.SCHURB ) THEN C C Transform the right-hand side: C <-- C*V'. C Workspace: need a+b+N; C prefer a+b+M*N. C IF ( BLAS3B ) THEN C C Enough workspace for a fast BLAS 3 algorithm. C CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, ONE, $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) ELSE IF ( BLOCKB ) THEN C C Use as many rows of C as possible. C DO 70 I = 1, M, CHUNKB BL = MIN( M-I+1, CHUNKB ) CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, $ DWORK( JWORK ), BL ) CALL DGEMM( 'NoTranspose', 'Transpose', BL, N, N, ONE, $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), $ LDC ) 70 CONTINUE C ELSE C C Use a BLAS 2 algorithm. C DO 80 I = 1, M CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) 80 CONTINUE C END IF END IF C DWORK( 1 ) = DBLE( MAXWRK ) C RETURN C *** Last line of SB04PD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01JD.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01JD.f0000644000175000017500000005560615012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE TG01JD( JOB, SYSTYP, EQUIL, N, M, P, A, LDA, E, LDE, $ B, LDB, C, LDC, NR, INFRED, TOL, IWORK, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To find a reduced (controllable, observable, or irreducible) C descriptor representation (Ar-lambda*Er,Br,Cr) for an original C descriptor representation (A-lambda*E,B,C). C The pencil Ar-lambda*Er is in an upper block Hessenberg form, with C either Ar or Er upper triangular. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Indicates whether the user wishes to remove the C uncontrollable and/or unobservable parts as follows: C = 'I': Remove both the uncontrollable and unobservable C parts to get an irreducible descriptor C representation; C = 'C': Remove the uncontrollable part only to get a C controllable descriptor representation; C = 'O': Remove the unobservable part only to get an C observable descriptor representation. C C SYSTYP CHARACTER*1 C Indicates the type of descriptor system algorithm C to be applied according to the assumed C transfer-function matrix as follows: C = 'R': Rational transfer-function matrix; C = 'S': Proper (standard) transfer-function matrix; C = 'P': Polynomial transfer-function matrix. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily scale C the system (A-lambda*E,B,C) as follows: C = 'S': Perform scaling; C = 'N': Do not perform scaling. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the descriptor state vector; also the C order of square matrices A and E, the number of rows of C matrix B, and the number of columns of matrix C. N >= 0. C C M (input) INTEGER C The dimension of descriptor system input vector; also the C number of columns of matrix B. M >= 0. C C P (input) INTEGER C The dimension of descriptor system output vector; also the C number of rows of matrix C. 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 original state matrix A. C On exit, the leading NR-by-NR part of this array contains C the reduced order state matrix Ar of an irreducible, C controllable, or observable realization for the original C system, depending on the value of JOB, JOB = 'I', C JOB = 'C', or JOB = 'O', respectively. C The matrix Ar is upper triangular if SYSTYP = 'R' or 'P'. C If SYSTYP = 'S' and JOB = 'C', the matrix [Br Ar] C is in a controllable staircase form (see TG01HD). C If SYSTYP = 'S' and JOB = 'I' or 'O', the matrix ( Ar ) C ( Cr ) C is in an observable staircase form (see TG01HD). C The block structure of staircase forms is contained C in the leading INFRED(7) elements of IWORK. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the original descriptor matrix E. C On exit, the leading NR-by-NR part of this array contains C the reduced order descriptor matrix Er of an irreducible, C controllable, or observable realization for the original C system, depending on the value of JOB, JOB = 'I', C JOB = 'C', or JOB = 'O', respectively. C The resulting Er has INFRED(6) nonzero sub-diagonals. C If at least for one k = 1,...,4, INFRED(k) >= 0, then the C resulting Er is structured being either upper triangular C or block Hessenberg, in accordance to the last C performed order reduction phase (see METHOD). C The block structure of staircase forms is contained C in the leading INFRED(7) elements of IWORK. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), C if JOB = 'C', or (LDB,MAX(M,P)), otherwise. C On entry, the leading N-by-M part of this array must C contain the original input matrix B; if JOB = 'I', C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) C part is used as internal workspace. C On exit, the leading NR-by-M part of this array contains C the reduced input matrix Br of an irreducible, C controllable, or observable realization for the original C system, depending on the value of JOB, JOB = 'I', C JOB = 'C', or JOB = 'O', respectively. C If JOB = 'C', only the first IWORK(1) rows of B are C nonzero. 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 original output matrix C; if JOB = 'I', C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N C part is used as internal workspace. C On exit, the leading P-by-NR part of this array contains C the transformed state/output matrix Cr of an irreducible, C controllable, or observable realization for the original C system, depending on the value of JOB, JOB = 'I', C JOB = 'C', or JOB = 'O', respectively. C If JOB = 'I', or JOB = 'O', only the last IWORK(1) columns C (in the first NR columns) of C are nonzero. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,M,P) if N > 0. C LDC >= 1 if N = 0. C C NR (output) INTEGER C The order of the reduced descriptor representation C (Ar-lambda*Er,Br,Cr) of an irreducible, controllable, C or observable realization for the original system, C depending on JOB = 'I', JOB = 'C', or JOB = 'O', C respectively. C C INFRED (output) INTEGER array, dimension 7 C This array contains information on performed reduction C and on structure of resulting system matrices as follows: C INFRED(k) >= 0 (k = 1, 2, 3, or 4) if Phase k of reduction C (see METHOD) has been performed. In this C case, INFRED(k) is the achieved order C reduction in Phase k. C INFRED(k) < 0 (k = 1, 2, 3, or 4) if Phase k was not C performed. C INFRED(5) - the number of nonzero sub-diagonals of A. C INFRED(6) - the number of nonzero sub-diagonals of E. C INFRED(7) - the number of blocks in the resulting C staircase form at last performed reduction C phase. The block dimensions are contained C in the first INFRED(7) elements of IWORK. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determinations when C transforming (A-lambda*E,B,C). If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C reciprocal condition numbers in rank determinations; a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*N*EPS, is used instead, where C EPS is the machine precision (see LAPACK Library routine C DLAMCH). TOL < 1. C C Workspace C C IWORK INTEGER array, dimension ((c*N+MAX(M,P)), where C c = 2, if JOB = 'I' or SYSTYP = 'R', and c = 1, otherwise. C On exit, if INFO = 0, the leading INFRED(7) elements of C IWORK contain the orders of the diagonal blocks of C Ar-lambda*Er. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(8*N,2*M,2*P), if EQUIL = 'S'; C LDWORK >= MAX(N,2*M,2*P), if EQUIL = 'N'. C If LDWORK >= 2*N*N+N*M+N*P+MAX(N,2*M,2*P) then more C accurate results are to be expected by performing only C those reductions phases (see METHOD), where effective C order reduction occurs. This is achieved by saving the C system matrices before each phase and restoring them if no C order reduction took place. 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 subroutine is based on the reduction algorithms of [1]. C The order reduction is performed in 4 phases: C Phase 1: Eliminate all finite uncontrollable eigenvalues. C The resulting matrix ( Br Ar ) is in a controllable C staircase form (see SLICOT Library routine TG01HD), and C Er is upper triangular. C This phase is performed if JOB = 'I' or 'C' and C SYSTYP = 'R' or 'S'. C Phase 2: Eliminate all infinite and finite nonzero uncontrollable C eigenvalues. The resulting matrix ( Br Er ) is in a C controllable staircase form (see TG01HD), and Ar is C upper triangular. C This phase is performed if JOB = 'I' or 'C' and C SYSTYP = 'R' or 'P'. C Phase 3: Eliminate all finite unobservable eigenvalues. C The resulting matrix ( Ar ) is in an observable C ( Cr ) C staircase form (see SLICOT Library routine TG01ID), and C Er is upper triangular. C This phase is performed if JOB = 'I' or 'O' and C SYSTYP = 'R' or 'S'. C Phase 4: Eliminate all infinite and finite nonzero unobservable C eigenvalues. The resulting matrix ( Er ) is in an C ( Cr ) C observable staircase form (see TG01ID), and Ar is C upper triangular. C This phase is performed if JOB = 'I' or 'O' and C SYSTYP = 'R' or 'P'. C C REFERENCES C C [1] A. Varga C Computation of Irreducible Generalized State-Space C Realizations. C Kybernetika, vol. 26, pp. 89-106, 1990. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N**3 ) floating point operations. C C FURTHER COMMENTS C C If the pencil (A-lambda*E) has no zero eigenvalues, then an C irreducible realization can be computed skipping Phases 1 and 3 C by using the setting: JOB = 'I' and SYSTYP = 'P'. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C April 1999. Based on the RASP routine RPDSIR. C C REVISIONS C C July 1999, V. Sima, Research Institute for Informatics, Bucharest. C May 2003, A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C May 2003, March 2004, March 2017, April 2017, V. Sima. C C KEYWORDS C C Controllability, irreducible realization, observability, C orthogonal canonical form, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL, JOB, SYSTYP INTEGER INFO, LDA, LDB, LDC, LDE, LDWORK, M, N, NR, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER INFRED(*), IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), E(LDE,*) C .. Local Scalars .. CHARACTER JOBQ, JOBZ LOGICAL DONE1, DONE2, DONE3, FINCON, FINOBS, INFCON, $ INFOBS, LEQUIL, LJOBC, LJOBIR, LJOBO, LSPACE, $ LSYSP, LSYSR, LSYSS INTEGER I, IB, KWA, KWB, KWC, KWE, LBA, LBE, LDM, LDP, $ LDQ, LDZ, M1, MAXMP, N1, NBLCK, NC, P1 C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLACPY, MA02CD, TB01XD, TG01AD, TG01HX, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C INFO = 0 MAXMP = MAX( M, P ) N1 = MAX( 1, N ) C C Decode JOB. C LJOBIR = LSAME( JOB, 'I' ) LJOBC = LJOBIR .OR. LSAME( JOB, 'C' ) LJOBO = LJOBIR .OR. LSAME( JOB, 'O' ) C C Decode SYSTYP. C LSYSR = LSAME( SYSTYP, 'R' ) LSYSS = LSYSR .OR. LSAME( SYSTYP, 'S' ) LSYSP = LSYSR .OR. LSAME( SYSTYP, 'P' ) C LEQUIL = LSAME( EQUIL, 'S' ) C C Test the input scalar arguments. C IF( .NOT.LJOBC .AND. .NOT.LJOBO ) THEN INFO = -1 ELSE IF( .NOT.LSYSS .AND. .NOT.LSYSP ) THEN INFO = -2 ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.N1 ) THEN INFO = -8 ELSE IF( LDE.LT.N1 ) THEN INFO = -10 ELSE IF( LDB.LT.N1 ) THEN INFO = -12 ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN INFO = -14 ELSE IF( TOL.GE.ONE ) THEN INFO = -17 ELSE IF( ( .NOT.LEQUIL .AND. LDWORK.LT.MAX( N, 2*MAXMP ) ) .OR. $ ( LEQUIL .AND. LDWORK.LT.MAX( 8*N, 2*MAXMP ) ) ) THEN INFO = -20 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01JD', -INFO ) RETURN END IF C C Quick return if possible. C INFRED(1) = -1 INFRED(2) = -1 INFRED(3) = -1 INFRED(4) = -1 INFRED(5) = 0 INFRED(6) = 0 INFRED(7) = 0 C IF( MAX( N, MAXMP ).EQ.0 ) THEN NR = 0 RETURN END IF C M1 = MAX( 1, M ) P1 = MAX( 1, P ) LDM = MAX( LDC, M ) LDP = MAX( LDC, P ) C C Set controllability/observability determination options. C FINCON = LJOBC .AND. LSYSS INFCON = LJOBC .AND. LSYSP FINOBS = LJOBO .AND. LSYSS INFOBS = LJOBO .AND. LSYSP C C Set large workspace option and determine offsets. C LSPACE = LDWORK.GE.N*( 2*N + M + P ) + MAX( N, 2*MAXMP ) KWA = MAX( N, 2*MAXMP ) + 1 KWE = KWA + N*N KWB = KWE + N*N KWC = KWB + N*M C C If required, scale the system (A-lambda*E,B,C). C Workspace: need 8*N. C IF( LEQUIL ) THEN CALL TG01AD( 'All', N, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, $ C, LDP, DWORK(1), DWORK(N+1), DWORK(2*N+1), INFO ) END IF C JOBQ = 'N' JOBZ = 'N' LDQ = 1 LDZ = 1 LBA = MAX( 0, N-1 ) LBE = LBA NC = N NR = N IB = 1 C DONE1 = .FALSE. DONE2 = .FALSE. DONE3 = .FALSE. C IF( FINCON ) THEN C C Phase 1: Eliminate all finite uncontrollable eigenvalues. C IF( LSPACE ) THEN C C Save system matrices. C CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) END IF C C Perform finite controllability form reduction. C Workspace: need MAX(N,2*M). C CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBE, A, LDA, $ E, LDE, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR, $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) DONE1 = NR.LT.NC .OR. .NOT.LSPACE IF( DONE1 ) THEN IF( NBLCK.GT.1 ) THEN LBA = IWORK(1) + IWORK(2) - 1 ELSE IF( NBLCK.EQ.1 ) THEN LBA = IWORK(1) - 1 ELSE LBA = 0 END IF LBE = 0 INFRED(1) = NC - NR INFRED(7) = NBLCK NC = NR IB = N + 1 ELSE C C Restore system matrices. C CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) END IF END IF C IF( INFCON ) THEN C C Phase 2: Eliminate all infinite and all finite nonzero C uncontrollable eigenvalues. C IF( LSPACE .AND. ( .NOT.FINCON .OR. DONE1 ) ) THEN C C Save system matrices. C CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) END IF C C Perform infinite controllability form reduction. C Workspace: need MAX(N,2*M). C CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBA, E, LDE, $ A, LDA, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR, $ NBLCK, IWORK(IB), TOL, IWORK(IB+N), DWORK, INFO ) DONE2 = NR.LT.NC .OR. .NOT.LSPACE IF( DONE2 ) THEN IF( NBLCK.GT.1 ) THEN LBE = IWORK(IB) + IWORK(IB+1) - 1 ELSE IF( NBLCK.EQ.1 ) THEN LBE = IWORK(IB) - 1 ELSE LBE = 0 END IF LBA = 0 INFRED(2) = NC - NR INFRED(7) = NBLCK NC = NR IF ( DONE1 ) THEN DO 10 I = 1, NBLCK IWORK(I) = IWORK(IB+I-1) 10 CONTINUE ELSE IB = N + 1 END IF ELSE C C Restore system matrices. C CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) END IF END IF C IF( FINOBS .OR. INFOBS ) THEN C C Compute the pertransposed dual system exploiting matrix shapes. C CALL TB01XD( 'Z', NC, M, P, LBA, MAX( 0, NC-1 ), A, LDA, $ B, LDB, C, LDC, DUM, 1, INFO ) CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) END IF C IF( FINOBS ) THEN C C Phase 3: Eliminate all finite unobservable eigenvalues. C IF( LSPACE ) THEN C C Save system matrices. C CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) END IF C C Perform finite observability form reduction. C Workspace: need MAX(N,2*P). C CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBE, A, LDA, $ E, LDE, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR, $ NBLCK, IWORK(IB), TOL, IWORK(IB+N), DWORK, INFO ) DONE3 = NR.LT.NC .OR. .NOT.LSPACE IF( DONE3 ) THEN IF( NBLCK.GT.1 ) THEN LBA = IWORK(IB) + IWORK(IB+1) - 1 ELSE IF( NBLCK.EQ.1 ) THEN LBA = IWORK(IB) - 1 ELSE LBA = 0 END IF LBE = 0 INFRED(3) = NC - NR INFRED(7) = NBLCK NC = NR IF ( DONE1 .OR. DONE2 ) THEN DO 20 I = 1, NBLCK IWORK(I) = IWORK(IB+I-1) 20 CONTINUE ELSE IB = N + 1 END IF ELSE C C Restore system matrices. C CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) END IF END IF C IF( INFOBS ) THEN C C Phase 4: Eliminate all infinite and all finite nonzero C unobservable eigenvalues. C IF( LSPACE .AND. ( .NOT.FINOBS .OR. DONE3 ) ) THEN C C C Save system matrices. C CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) END IF C C Perform infinite observability form reduction. C Workspace: need MAX(N,2*P). C CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBA, E, LDE, $ A, LDA, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR, $ NBLCK, IWORK(IB), TOL, IWORK(IB+N), DWORK, INFO ) IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN IF( NBLCK.GT.1 ) THEN LBE = IWORK(IB) + IWORK(IB+1) - 1 ELSE IF( NBLCK.EQ.1 ) THEN LBE = IWORK(IB) - 1 ELSE LBE = 0 END IF LBA = 0 INFRED(4) = NC - NR INFRED(7) = NBLCK NC = NR IF ( DONE1 .OR. DONE2 .OR. DONE3 ) THEN DO 30 I = 1, NBLCK IWORK(I) = IWORK(IB+I-1) 30 CONTINUE END IF ELSE C C Restore system matrices. C CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) END IF END IF C IF( FINOBS .OR. INFOBS ) THEN C C Compute the pertransposed dual system exploiting matrix shapes. C CALL TB01XD( 'Z', NC, P, M, LBA, MAX( 0, NC-1 ), A, LDA, $ B, LDB, C, LDC, DUM, 1, INFO ) CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) END IF C C Set structural information on A and E. C INFRED(5) = LBA INFRED(6) = LBE C RETURN C *** Last line of TG01JD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04MW.f0000644000000000000000000000013215012430707016211 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04MW.f0000644000175000017500000001072415012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE SB04MW( M, D, IPR, INFO ) 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 control-4.1.2/src/slicot/src/PaxHeaders/SB04NW.f0000644000000000000000000000013215012430707016212 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04NW.f0000644000175000017500000001040715012430707017410 0ustar00lilgelilge00000000000000 SUBROUTINE SB04NW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) C C PURPOSE C C To construct the right-hand side D for a system of equations in C Hessenberg form solved via SB04NY (case with 1 right-hand side). C C ARGUMENTS C C Mode Parameters C C ABSCHR CHARACTER*1 C Indicates whether AB contains A or B, as follows: C = 'A': AB contains A; C = 'B': AB contains B. C C UL CHARACTER*1 C Indicates whether AB is upper or lower Hessenberg matrix, C as follows: C = 'U': AB is upper Hessenberg; C = 'L': AB is lower Hessenberg. 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 C (input) DOUBLE PRECISION array, dimension (LDC,M) C The leading N-by-M part of this array must contain both C the not yet modified part of the coefficient matrix C of C the Sylvester equation AX + XB = C, and both the currently C computed part of the solution of the Sylvester equation. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,N). C C INDX (input) INTEGER C The position of the column/row of C to be used in the C construction of the right-hand side D. C C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) C The leading N-by-N or M-by-M part of this array must C contain either A or B of the Sylvester equation C AX + XB = C. C C LDAB INTEGER C The leading dimension of array AB. C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on C ABSCHR = 'A' or ABSCHR = 'B', respectively). C C D (output) DOUBLE PRECISION array, dimension (*) C The leading N or M part of this array (depending on C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the C right-hand side. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB04BW by M. Vanbegin, and C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. C C REVISIONS C C - C C KEYWORDS C C Hessenberg form, orthogonal transformation, real Schur form, C Sylvester equation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER ABSCHR, UL INTEGER INDX, LDAB, LDC, M, N C .. Array Arguments .. DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMV C .. Executable Statements .. C C For speed, no tests on the input scalar arguments are made. C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 ) $ RETURN C IF ( LSAME( ABSCHR, 'B' ) ) THEN C C Construct the column of the right-hand side. C CALL DCOPY( N, C(1,INDX), 1, D, 1 ) IF ( LSAME( UL, 'U' ) ) THEN IF ( INDX.GT.1 ) THEN CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, $ ONE, D, 1 ) END IF ELSE IF ( INDX.LT.M ) THEN CALL DGEMV( 'N', N, M-INDX, -ONE, C(1,INDX+1), LDC, $ AB(INDX+1,INDX), 1, ONE, D, 1 ) END IF END IF ELSE C C Construct the row of the right-hand side. C CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) IF ( LSAME( UL, 'U' ) ) THEN IF ( INDX.LT.N ) THEN CALL DGEMV( 'T', N-INDX, M, -ONE, C(INDX+1,1), LDC, $ AB(INDX,INDX+1), LDAB, ONE, D, 1 ) END IF ELSE IF ( INDX.GT.1 ) THEN CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), $ LDAB, ONE, D, 1 ) END IF END IF END IF C RETURN C *** Last line of SB04NW *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03AG.f0000644000000000000000000000013215012430707016146 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03AG.f0000644000175000017500000002352615012430707017352 0ustar00lilgelilge00000000000000 SUBROUTINE MB03AG( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, C1, $ S1, C2, S2, IWORK, DWORK ) C C PURPOSE C C To compute two Givens rotations (C1,S1) and (C2,S2) such that the C orthogonal matrix C C [ Q 0 ] [ C1 S1 0 ] [ 1 0 0 ] C Z = [ ], Q := [ -S1 C1 0 ] * [ 0 C2 S2 ], C [ 0 I ] [ 0 0 1 ] [ 0 -S2 C2 ] C C makes the first column of the real Wilkinson double shift C polynomial of the product of matrices in periodic upper Hessenberg C form, stored in the array A, parallel to the first unit vector. C Only the rotation defined by C1 and S1 is used for the real C Wilkinson single shift polynomial (see SLICOT Library routines C MB03BE or MB03BF). All factors whose exponents differ from that of C the Hessenberg factor are assumed nonsingular. The matrix product C is evaluated. C C ARGUMENTS C C Mode Parameters C C SHFT CHARACTER*1 C Specifies the number of shifts employed by the shift C polynomial, as follows: C = 'D': two shifts (assumes N > 2); C = 'S': one real shift. C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of the factors. N >= 2. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C AMAP(1) is the pointer to the Hessenberg matrix. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input) DOUBLE PRECISION array, dimension (LDA1,LDA2,K) C The leading N-by-N-by-K part of this array must contain C the product (implicitly represented by its K factors) C in periodic upper Hessenberg form. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= N. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= N. C C C1 (output) DOUBLE PRECISION C S1 (output) DOUBLE PRECISION C On exit, C1 and S1 contain the parameters for the first C Givens rotation. C C C2 (output) DOUBLE PRECISION C S2 (output) DOUBLE PRECISION C On exit, if SHFT = 'D', C2 and S2 contain the parameters C for the second Givens rotation. Otherwise, C2 = 1, S2 = 0. C C Workspace C C IWORK INTEGER array, dimension (2*N) C C DWORK DOUBLE PRECISION array, dimension (2*N*N) C On exit, DWORK(N*N+1:N*N+N) and DWORK(N*N+N+1:N*N+2*N) C contain the real and imaginary parts, respectively, of the C eigenvalues of the matrix product. C C METHOD C C The necessary elements of the real Wilkinson double shift C polynomial are computed, and suitable Givens rotations are C found. For numerical reasons, this routine should be called C when convergence difficulties are encountered for small order C matrices and small K, e.g., N, K <= 6. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Jan. 2019. C C REVISIONS C C V. Sima, Sep. 2019, Dec. 2019. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO, ZERO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER SHFT INTEGER K, LDA1, LDA2, N, SINV DOUBLE PRECISION C1, C2, S1, S2 C .. Array Arguments .. INTEGER AMAP(*), IWORK(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*), DWORK(*) C .. Local Scalars .. LOGICAL FC, SGLE INTEGER I, IC, II, IM, IR, IS, J, L, NN DOUBLE PRECISION E1, E2, MC, MN, MX, P1, P2, P3, PR, SM C .. Local Arrays .. DOUBLE PRECISION Z(1) C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAPY2 EXTERNAL DLAPY2, IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGESC2, DGETC2, DLAHQR, DLARTG, DLASET, $ DTRMV C .. Intrinsic Functions .. INTRINSIC ABS C C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked for errors. C C Evaluate the matrix product. C SGLE = LSAME( SHFT, 'S' ) C NN = N*N IR = NN + 1 II = IR + N I = AMAP(K) IC = 1 C Z(1) = ZERO C IF ( K.GT.1 ) THEN C IF ( S(I).EQ.SINV ) THEN IS = 1 C DO 10 L = 1, N CALL DCOPY( L, A(1,L,I), 1, DWORK(IC), 1 ) CALL DCOPY( N-L, Z, 0, DWORK(IC+L), 1 ) IC = IC + N 10 CONTINUE C ELSE IS = 0 CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK, N ) END IF C DO 50 J = K - IS, 2, -1 I = AMAP(J) IF ( S(I).EQ.SINV ) THEN IC = 1 C DO 20 L = 1, N CALL DTRMV( 'Upper', 'NoTran', 'NonUnit', L, A(1,1,I), $ LDA1, DWORK(IC), 1 ) IC = IC + N 20 CONTINUE C ELSE IC = IR C DO 30 L = 1, N CALL DCOPY( L, A(1,L,I), 1, DWORK(IC), 1 ) CALL DCOPY( N-L, Z, 0, DWORK(IC+L), 1 ) IC = IC + N 30 CONTINUE C C Complete pivoting is used for triangular factors whose C exponents differ from SINV. It is assumed that SM = 1, C i.e., no overflow could appear when calling DGESC2. C CALL DGETC2( N, DWORK(IR), N, IWORK, IWORK(N+1), IM ) C DO 40 IC = 1, NN, N CALL DGESC2( N, DWORK(IR), N, DWORK(IC), IWORK, $ IWORK(N+1), SM ) 40 CONTINUE C END IF 50 CONTINUE C I = AMAP(1) IC = 1 C DO 70 J = 1, N - 1 CALL DCOPY( J, DWORK(IC), 1, DWORK(IR), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', J, A(1,1,I), LDA1, $ DWORK(IC), 1 ) C DO 60 L = 1, J DWORK(IC+L) = DWORK(IC+L) + A(L+1,L,I)*DWORK(IR+L-1) 60 CONTINUE C IC = IC + N 70 CONTINUE C CALL DCOPY( N, DWORK(IC), 1, DWORK(IR), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', N, A(1,1,I), LDA1, $ DWORK(IC), 1 ) C DO 80 L = 1, N DWORK(IC+L) = DWORK(IC+L) + A(L+1,L,I)*DWORK(IR+L-1) 80 CONTINUE C ELSE I = AMAP(1) C DO 90 L = 1, N - 1 CALL DCOPY( L+1, A(1,L,I), 1, DWORK(IC), 1 ) CALL DCOPY( N-L-1, Z, 0, DWORK(IC+L+1), 1 ) IC = IC + N 90 CONTINUE C CALL DCOPY( N, A(1,N,I), 1, DWORK(IC), 1 ) END IF C IF ( SGLE ) THEN CALL DLARTG( DWORK(1) - DWORK(NN), DWORK(2), C1, S1, E1 ) C2 = ONE S2 = ZERO ELSE C C Save the needed elements of the product. C E1 = DWORK(1) E2 = DWORK(2) P1 = DWORK(N+1) P2 = DWORK(N+2) P3 = DWORK(N+3) C C Compute eigenvalues of the product. C CALL DLAHQR( .FALSE., .FALSE., N, 1, N, DWORK, N, DWORK(IR), $ DWORK(II), 1, 1, Z, 1, IM ) C C Find two eigenvalues with the smallest moduli. C If there are complex eigenvalues, selection is based on them. C I = IDAMAX( N, DWORK(II), 1 ) IF ( DWORK(II+I-1).EQ.ZERO ) THEN IM = IR + IDAMAX( N, DWORK(IR), 1 ) - 1 MX = ABS( DWORK(IM) ) MN = MX C DO 100 I = IR, IR + N - 1 MC = ABS( DWORK(I) ) IF ( MC.LT.MN ) THEN MN = MC IM = I END IF 100 CONTINUE C PR = DWORK(IM) MN = MX DWORK(IM) = MX IS = IM MX = PR C DO 110 I = IR, IR + N - 1 MC = ABS( DWORK(I) ) IF ( MC.LT.MN ) THEN MN = MC IM = I END IF 110 CONTINUE C SM = PR + DWORK(IM) PR = PR * DWORK(IM) DWORK(IS) = MX C ELSE C I = II FC = .FALSE. C C WHILE ( I <= II+N-1 ) DO C 120 CONTINUE IF ( I.LE.II + N - 1 ) THEN IF ( DWORK(I).NE.ZERO ) THEN MC = DLAPY2( DWORK(I-N), DWORK(I) ) IF ( .NOT.FC ) THEN FC = .TRUE. IM = I MN = MC ELSE IF ( MC.LT.MN ) THEN MN = MC IM = I END IF I = I + 2 ELSE I = I + 1 END IF GO TO 120 END IF C C END WHILE 120 C SM = TWO*DWORK(IM-N) PR = MN**2 END IF C C Compute a multiple of the first column of the real Wilkinson C double shift polynomial, having only three nonzero elements. C P1 = P1 + ( ( E1 - SM )*E1 + PR )/E2 P2 = P2 + E1 - SM C C Compute the rotations to annihilate P2 and P3. C CALL DLARTG( P2, P3, C2, S2, E1 ) CALL DLARTG( P1, E1, C1, S1, E2 ) END IF C RETURN C *** Last line of MB03AG *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04DL.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04DL.f0000644000175000017500000006736215012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE MB04DL( JOB, N, THRESH, A, LDA, B, LDB, ILO, IHI, $ LSCALE, RSCALE, DWORK, IWARN, INFO ) C C PURPOSE C C To balance a pair of N-by-N real matrices (A,B). This involves, C first, permuting A and B by equivalence transformations to isolate C eigenvalues in the first 1 to ILO-1 and last IHI+1 to N elements C on the diagonal of A and B; and second, applying a diagonal C equivalence transformation to rows and columns ILO to IHI to make C the rows and columns as close in 1-norm as possible. Both steps C are optional. Balancing may reduce the 1-norms of the matrices, C and improve the accuracy of the computed eigenvalues and/or C eigenvectors in the generalized eigenvalue problem C A*x = lambda*B*x. C C This routine may optionally improve the conditioning of the C scaling transformation compared to the LAPACK routine DGGBAL. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the operations to be performed on A and B: C = 'N': none: simply set ILO = 1, LSCALE(I) = 1.0 and C RSCALE(I) = 1.0 for I = 1,...,N. C = 'P': permute only; C = 'S': scale only; C = 'B': both permute and scale. C C Input/Output Parameters C C N (input) INTEGER C The order of matrices A and B. N >= 0. C C THRESH (input) DOUBLE PRECISION C If JOB = 'S' or JOB = 'B', and THRESH >= 0, threshold C value for magnitude of the elements to be considered in C the scaling process: elements with magnitude less than or C equal to THRESH*MXNORM are ignored for scaling, where C MXNORM is the maximum of the 1-norms of the original C submatrices A(s,s) and B(s,s), with s = ILO:IHI. C If THRESH < 0, the subroutine finds the scaling factors C for which some conditions, detailed below, are fulfilled. C A sequence of increasing strictly positive threshold C values is used. C If THRESH = -1, the condition is that C max( norm(A(s,s),1)/norm(B(s,s),1), C norm(B(s,s),1)/norm(S(s,s),1) ) (1) C has the smallest value, for the threshold values used, C where A(s,s) and B(s,s) are the scaled submatrices. C If THRESH = -2, the norm ratio reduction (1) is tried, but C the subroutine may return IWARN = 1 and reset the scaling C factors to 1, if this seems suitable. See the description C of the argument IWARN and FURTHER COMMENTS. C If THRESH = -3, the condition is that C norm(A(s,s),1)*norm(B(s,s),1) (2) C has the smallest value for the scaled submatrices. C If THRESH = -4, the norm reduction in (2) is tried, but C the subroutine may return IWARN = 1 and reset the scaling C factors to 1, as for THRESH = -2 above. C If THRESH = -VALUE, with VALUE >= 10, the condition C numbers of the left and right scaling transformations will C be bounded by VALUE, i.e., the ratios between the largest C and smallest entries in LSCALE(s) and RSCALE(s), will be C at most VALUE. VALUE should be a power of 10. C If JOB = 'N' or JOB = 'P', the value of THRESH is C irrelevant. 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. C On exit, the leading N-by-N part of this array contains C the balanced matrix A. C In particular, the strictly lower triangular part of the C first ILO-1 columns and the last N-IHI rows of A is zero. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB, N) C On entry, the leading N-by-N part of this array must C contain the matrix B. C On exit, the leading N-by-N part of this array contains C the balanced matrix B. C In particular, the strictly lower triangular part of the C first ILO-1 columns and the last N-IHI rows of B is zero. C If JOB = 'N', the arrays A and B are not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N). C C ILO (output) INTEGER C IHI (output) INTEGER C ILO and IHI are set to integers such that on exit C A(i,j) = 0 and B(i,j) = 0 if i > j and C j = 1,...,ILO-1 or i = IHI+1,...,N. C If JOB = 'N' or 'S', ILO = 1 and IHI = N. C C LSCALE (output) DOUBLE PRECISION array, dimension (N) C Details of the permutations and scaling factors applied C to the left side of A and B. If P(j) is the index of the C row interchanged with row j, and D(j) is the scaling C factor applied to row j, then C LSCALE(j) = P(j) for j = 1,...,ILO-1 C = D(j) for j = ILO,...,IHI C = P(j) for j = IHI+1,...,N. C The order in which the interchanges are made is N to C IHI+1, then 1 to ILO-1. C C RSCALE (output) DOUBLE PRECISION array, dimension (N) C Details of the permutations and scaling factors applied C to the right side of A and B. If P(j) is the index of the C column interchanged with column j, and D(j) is the scaling C factor applied to column j, then C RSCALE(j) = P(j) for j = 1,...,ILO-1 C = D(j) for j = ILO,...,IHI C = P(j) for j = IHI+1,...,N. C The order in which the interchanges are made is N to C IHI+1, then 1 to ILO-1. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) where C LDWORK = 0, if JOB = 'N' or JOB = 'P', or N = 0; C LDWORK = 6*N, if (JOB = 'S' or JOB = 'B') and THRESH >= 0; C LDWORK = 8*N, if (JOB = 'S' or JOB = 'B') and THRESH < 0. C On exit, if JOB = 'S' or JOB = 'B', DWORK(1) and DWORK(2) C contain the initial 1-norms of A(s,s) and B(s,s), and C DWORK(3) and DWORK(4) contain their final 1-norms, C respectively. Moreover, DWORK(5) contains the THRESH value C used (irrelevant if IWARN = 1 or ILO = IHI). C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: scaling has been requested, for THRESH = -2 or C THRESH = -4, but it most probably would not improve C the accuracy of the computed solution for a related C eigenproblem (since maximum norm increased C significantly compared to the original pencil C matrices and (very) high and/or small scaling C factors occurred). The returned scaling factors have C been reset to 1, but information about permutations, C if requested, has been preserved. 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 Balancing consists of applying an equivalence transformation C to isolate eigenvalues and/or to make the 1-norms of the rows C and columns ILO,...,IHI of A and B nearly equal. If THRESH < 0, C a search is performed to find those scaling factors giving the C smallest norm ratio or product defined above (see the description C of the parameter THRESH). C C Assuming JOB = 'S', let Dl and Dr be diagonal matrices containing C the vectors LSCALE and RSCALE, respectively. The returned matrices C are obtained using the equivalence transformation C C Dl*A*Dr and Dl*B*Dr. C C For THRESH = 0, the routine returns essentially the same results C as the LAPACK subroutine DGGBAL [1]. Setting THRESH < 0, usually C gives better results than DGGBAL for badly scaled matrix pencils. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C No rounding errors appear if JOB = 'P'. C C FURTHER COMMENTS C C If THRESH = -2, the increase of the maximum norm of the scaled C submatrices, compared to the maximum norm of the initial C submatrices, is bounded by MXGAIN = 100. C If THRESH = -2, or THRESH = -4, the maximum condition number of C the scaling transformations is bounded by MXCOND = 1/SQRT(EPS), C where EPS is the machine precision (see LAPACK Library routine C DLAMCH). C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2015. C C REVISIONS C C V. Sima, Jan. 2016, Jan. 2017, Feb. 2017. C C KEYWORDS C C Balancing, eigenvalue, equivalence transformation, matrix algebra, C matrix operations. C C ********************************************************************* C C .. Parameters .. DOUBLE PRECISION HALF, ONE, TEN, THREE, ZERO PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, TEN = 1.0D+1, $ THREE = 3.0D+0, ZERO = 0.0D+0 ) DOUBLE PRECISION MXGAIN, SCLFAC PARAMETER ( MXGAIN = 1.0D+2, SCLFAC = 1.0D+1 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER IHI, ILO, INFO, IWARN, LDA, LDB, N DOUBLE PRECISION THRESH C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), LSCALE(*), $ RSCALE(*) C .. Local Scalars .. LOGICAL EVNORM, LOOP, LPERM, LSCAL, STORMN INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, ITER, ITH, $ J, JC, JP1, K, KOUNT, KS, KW1, KW2, KW3, KW4, $ KW5, KW6, KW7, L, LM1, LRAB, LSFMAX, LSFMIN, M, $ NR, NRP2 DOUBLE PRECISION AB, ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, DENOM, EPS, EW, EWC, GAMMA, GAP, $ MINPRO, MINRAT, MN, MX, MXCOND, MXNORM, MXS, $ NA, NA0, NAS, NB, NB0, NBS, PGAMMA, PROD, RAB, $ RATIO, SFMAX, SFMIN, SUM, T, TA, TB, TC, TH, $ TH0, THS C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH, DLANGE EXTERNAL DDOT, DLAMCH, DLANGE, IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSCAL, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN, SQRT C C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IWARN = 0 LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) C IF( .NOT.LPERM .AND. .NOT.LSCAL .AND. .NOT.LSAME( JOB, 'N' ) ) $ THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04DL', -INFO ) RETURN END IF C ILO = 1 IHI = N C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN IF( ( .NOT.LPERM .AND. .NOT.LSCAL ) .OR. N.EQ.1 ) THEN DUM(1) = ONE CALL DCOPY( N, DUM, 0, LSCALE, 1 ) CALL DCOPY( N, DUM, 0, RSCALE, 1 ) IF( N.EQ.1 .AND. LSCAL ) THEN NA0 = ABS( A(1,1) ) NB0 = ABS( B(1,1) ) DWORK(1) = NA0 DWORK(2) = NB0 DWORK(3) = NA0 DWORK(4) = NB0 DWORK(5) = THRESH END IF RETURN END IF C K = 1 L = N C IF( LPERM ) THEN C C Permute the matrices A and B to isolate the eigenvalues. C C Find row with one nonzero in columns 1 through L. C 10 CONTINUE LM1 = L - 1 DO 60 I = L, 1, -1 DO 20 J = 1, LM1 JP1 = J + 1 IF( A(I,J).NE.ZERO .OR. B(I,J).NE.ZERO ) $ GO TO 30 20 CONTINUE J = L GO TO 50 C 30 CONTINUE DO 40 J = JP1, L IF( A(I,J).NE.ZERO .OR. B(I,J).NE.ZERO ) $ GO TO 60 40 CONTINUE J = JP1 - 1 C 50 CONTINUE M = L IFLOW = 1 GO TO 130 60 CONTINUE C C Find column with one nonzero in rows K through N. C 70 CONTINUE DO 120 J = K, L DO 80 I = K, LM1 IP1 = I + 1 IF( A(I,J).NE.ZERO .OR. B(I,J).NE.ZERO ) $ GO TO 90 80 CONTINUE I = L GO TO 110 C 90 CONTINUE DO 100 I = IP1, L IF( A(I,J).NE.ZERO .OR. B(I,J).NE.ZERO ) $ GO TO 120 100 CONTINUE I = IP1 - 1 C 110 CONTINUE M = K IFLOW = 2 GO TO 130 120 CONTINUE GO TO 140 C C Permute rows M and I. C 130 CONTINUE LSCALE(M) = I IF( I.NE.M ) THEN CALL DSWAP( N-K+1, A(I,K), LDA, A(M,K), LDA ) CALL DSWAP( N-K+1, B(I,K), LDB, B(M,K), LDB ) END IF C C Permute columns M and J. C RSCALE(M) = J IF( J.NE.M ) THEN CALL DSWAP( L, A(1,J), 1, A(1,M), 1 ) CALL DSWAP( L, B(1,J), 1, B(1,M), 1 ) END IF C IF( IFLOW.EQ.1 ) THEN L = LM1 IF( L.NE.1 ) $ GO TO 10 C RSCALE(1) = ONE LSCALE(1) = ONE ELSE K = K + 1 GO TO 70 END IF END IF C 140 CONTINUE ILO = K IHI = L C IF( .NOT.LSCAL ) THEN DO 150 I = ILO, IHI LSCALE(I) = ONE RSCALE(I) = ONE 150 CONTINUE RETURN END IF C NR = IHI - ILO + 1 C C Compute initial 1-norms and return if ILO = N. C NA0 = DLANGE( '1-norm', NR, NR, A(ILO,ILO), LDA, DWORK ) NB0 = DLANGE( '1-norm', NR, NR, B(ILO,ILO), LDB, DWORK ) C IF( ILO.EQ.IHI ) THEN DWORK(1) = NA0 DWORK(2) = NB0 DWORK(3) = NA0 DWORK(4) = NB0 DWORK(5) = THRESH RETURN END IF C C Balance the submatrices in rows ILO to IHI. C C Initialize balancing and allocate work storage. C KW1 = N KW2 = KW1 + N KW3 = KW2 + N KW4 = KW3 + N KW5 = KW4 + N DUM(1) = ZERO C C Prepare for scaling. C SFMIN = DLAMCH( 'Safe minimum' ) SFMAX = ONE / SFMIN BASL = LOG10( SCLFAC ) LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) MXNORM = MAX( NA0, NB0 ) LOOP = THRESH.LT.ZERO C IF( LOOP ) THEN C C Compute relative threshold. C NA = NA0 NAS = NA0 NB = NB0 NBS = NB0 C ITH = THRESH MXS = MXNORM MX = ZERO MN = SFMAX IF( ITH.GE.-2 ) THEN IF( NA.LT.NB ) THEN RATIO = MIN( NB/NA, SFMAX ) ELSE RATIO = MIN( NA/NB, SFMAX ) END IF MINRAT = RATIO ELSE IF( ITH.LE.-10 ) THEN MXCOND = -THRESH ELSE DENOM = MAX( ONE, MXNORM ) PROD = ( NA/DENOM )*( NB/DENOM ) MINPRO = PROD END IF STORMN = .FALSE. EVNORM = .FALSE. C C Find maximum order of magnitude of the differences in sizes of C the nonzero entries, not considering diag(A) and diag(B). C DO 170 J = ILO, IHI DO 160 I = ILO, IHI IF( I.NE.J ) THEN AB = ABS( A(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) END IF 160 CONTINUE 170 CONTINUE C DO 190 J = ILO, IHI DO 180 I = ILO, IHI IF( I.NE.J ) THEN AB = ABS( B(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) END IF 180 CONTINUE 190 CONTINUE C IF( MX*SFMIN.LE.MN ) THEN GAP = MX/MN ELSE GAP = SFMAX END IF EPS = DLAMCH( 'Precision' ) ITER = MIN( INT( LOG10( GAP ) ), -INT( LOG10( EPS ) ) ) + 1 TH = MAX( MN, MX*EPS )/MAX( MXNORM, SFMIN ) THS = TH KW6 = KW5 + N + ILO KW7 = KW6 + N CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) C C Set the maximum condition number of the transformations. C IF( ITH.GT.-10 ) $ MXCOND = ONE/SQRT( EPS ) ELSE TH = MXNORM*THRESH ITER = 1 EVNORM = .TRUE. END IF TH0 = TH C COEF = ONE / DBLE( 2*NR ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = NR + 2 BETA = ZERO C C If THRESH < 0, use a loop to reduce the norm ratio. C DO 400 K = 1, ITER C C Compute right side vector in resulting linear equations. C CALL DCOPY( 6*N, DUM, 0, DWORK, 1 ) CALL DCOPY( NR, DUM, 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM, 0, RSCALE(ILO), 1 ) DO 210 I = ILO, IHI DO 200 J = ILO, IHI TA = ABS( A(I,J) ) TB = ABS( B(I,J) ) IF( TA.GT.TH ) THEN TA = LOG10( TA ) / BASL ELSE TA = ZERO END IF IF( TB.GT.TH ) THEN TB = LOG10( TB ) / BASL ELSE TB = ZERO END IF DWORK(I+KW4) = DWORK(I+KW4) - TA - TB DWORK(J+KW5) = DWORK(J+KW5) - TA - TB 200 CONTINUE 210 CONTINUE C IT = 1 C C Start generalized conjugate gradient iteration. C 220 CONTINUE C GAMMA = DDOT( NR, DWORK(ILO+KW4), 1, DWORK(ILO+KW4), 1 ) + $ DDOT( NR, DWORK(ILO+KW5), 1, DWORK(ILO+KW5), 1 ) C EW = ZERO EWC = ZERO DO 230 I = ILO, IHI EW = EW + DWORK(I+KW4) EWC = EWC + DWORK(I+KW5) 230 CONTINUE C GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - $ COEF5*( EW - EWC )**2 IF( GAMMA.EQ.ZERO ) $ GO TO 300 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = COEF5*( EWC - THREE*EW ) TC = COEF5*( EW - THREE*EWC ) C CALL DSCAL( NR, BETA, DWORK(ILO), 1 ) CALL DSCAL( NR, BETA, DWORK(ILO+KW1), 1 ) C CALL DAXPY( NR, COEF, DWORK(ILO+KW4), 1, DWORK(ILO+KW1), 1 ) CALL DAXPY( NR, COEF, DWORK(ILO+KW5), 1, DWORK(ILO), 1 ) C DO 240 J = ILO, IHI DWORK(J) = DWORK(J) + TC DWORK(J+KW1) = DWORK(J+KW1) + T 240 CONTINUE C C Apply matrix to vector. C DO 260 I = ILO, IHI KOUNT = 0 SUM = ZERO DO 250 J = ILO, IHI KS = KOUNT IF( A(I,J).NE.ZERO ) $ KOUNT = KOUNT + 1 IF( B(I,J).NE.ZERO ) $ KOUNT = KOUNT + 1 SUM = SUM + DBLE( KOUNT - KS )*DWORK(J) 250 CONTINUE DWORK(I+KW2) = DBLE( KOUNT )*DWORK(I+KW1) + SUM 260 CONTINUE C DO 280 J = ILO, IHI KOUNT = 0 SUM = ZERO DO 270 I = ILO, IHI KS = KOUNT IF( A(I,J).NE.ZERO ) $ KOUNT = KOUNT + 1 IF( B(I,J).NE.ZERO ) $ KOUNT = KOUNT + 1 SUM = SUM + DBLE( KOUNT - KS )*DWORK(I+KW1) 270 CONTINUE DWORK(J+KW3) = DBLE( KOUNT )*DWORK(J) + SUM 280 CONTINUE C SUM = DDOT( NR, DWORK(ILO+KW1), 1, DWORK(ILO+KW2), 1 ) + $ DDOT( NR, DWORK(ILO), 1, DWORK(ILO+KW3), 1 ) ALPHA = GAMMA / SUM C C Determine correction to current iteration. C CMAX = ZERO DO 290 I = ILO, IHI COR = ALPHA*DWORK(I+KW1) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE(I) = LSCALE(I) + COR COR = ALPHA*DWORK(I) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE(I) = RSCALE(I) + COR 290 CONTINUE C IF( CMAX.GE.HALF ) THEN C CALL DAXPY( NR, -ALPHA, DWORK(ILO+KW2), 1, DWORK(ILO+KW4), $ 1 ) CALL DAXPY( NR, -ALPHA, DWORK(ILO+KW3), 1, DWORK(ILO+KW5), $ 1 ) C PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 220 END IF C C End generalized conjugate gradient iteration. C 300 CONTINUE C C Compute diagonal scaling matrices. C DO 310 I = ILO, IHI IRAB = IDAMAX( N-ILO+1, A(I,ILO), LDA ) RAB = ABS( A(I,ILO+IRAB-1) ) IRAB = IDAMAX( N-ILO+1, B(I,ILO), LDB ) RAB = MAX( RAB, ABS( B(I,ILO+IRAB-1) ) ) LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) IR = LSCALE(I) + SIGN( HALF, LSCALE(I) ) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE(I) = SCLFAC**IR C ICAB = IDAMAX( IHI, A(1,I), 1 ) CAB = ABS( A(ICAB,I) ) ICAB = IDAMAX( IHI, B(1,I), 1 ) CAB = MAX( CAB, ABS( B(ICAB,I) ) ) LRAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) JC = RSCALE(I) + SIGN( HALF, RSCALE(I) ) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LRAB ) RSCALE(I) = SCLFAC**JC 310 CONTINUE C DO 320 I = ILO, IHI IF( LSCALE(I).NE.ONE .OR. RSCALE(I).NE.ONE ) $ GO TO 330 320 CONTINUE C C Finish the procedure for all scaling factors equal to 1. C NAS = NA0 NBS = NB0 THS = TH0 GO TO 460 C 330 CONTINUE C IF( LOOP ) THEN IF( ITH.LE.-10 ) THEN C C Compute the reciprocal condition number of the left and C right transformations. Continue the loop if it is too C small. C IR = IDAMAX( NR, LSCALE(ILO), 1 ) JC = IDAMAX( NR, RSCALE(ILO), 1 ) T = LSCALE(ILO+IR-1) MN = T DO 340 I = ILO, IHI IF( LSCALE(I).LT.MN ) $ MN = LSCALE(I) 340 CONTINUE T = MN/T TA = RSCALE(ILO+JC-1) MN = TA DO 350 I = ILO, IHI IF( RSCALE(I).LT.MN ) $ MN = RSCALE(I) 350 CONTINUE T = MIN( T, MN/TA ) IF( T.LT.ONE/MXCOND ) THEN TH = TH*TEN GO TO 400 ELSE THS = TH EVNORM = .TRUE. GO TO 430 END IF END IF C C Compute the 1-norms of the scaled submatrices, C without actually scaling them. C NA = ZERO DO 370 J = ILO, IHI T = ZERO DO 360 I = ILO, IHI T = T + ABS( A(I,J) )*LSCALE(I)*RSCALE(J) 360 CONTINUE IF( T.GT.NA ) $ NA = T 370 CONTINUE C NB = ZERO DO 390 J = ILO, IHI T = ZERO DO 380 I = ILO, IHI T = T + ABS( B(I,J) )*LSCALE(I)*RSCALE(J) 380 CONTINUE IF( T.GT.NB ) $ NB = T 390 CONTINUE C IF( ITH.GE.-4 .AND. ITH.LT.-2 ) THEN PROD = ( NA/DENOM )*( NB/DENOM ) IF( MINPRO.GT.PROD ) THEN MINPRO = PROD STORMN = .TRUE. CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) NAS = NA NBS = NB THS = TH END IF ELSE IF( ITH.GE.-2 ) THEN IF( NA.LT.NB ) THEN RATIO = MIN( NB/NA, SFMAX ) ELSE RATIO = MIN( NA/NB, SFMAX ) END IF IF( MINRAT.GT.RATIO ) THEN MINRAT = RATIO STORMN = .TRUE. CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) MXS = MAX( NA, NB ) NAS = NA NBS = NB THS = TH END IF END IF TH = TH*TEN END IF 400 CONTINUE C C Prepare for scaling. C IF( LOOP ) THEN IF( ITH.LE.-10 ) THEN C C Could not find enough well conditioned transformations C for THRESH <= -10. Set scaling factors to 1 and return. C DUM(1) = ONE CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 ) IWARN = 1 GO TO 460 END IF C C Check if scaling might reduce the accuracy when solving related C eigenproblems, and set the scaling factors to 1 in this case, C if THRESH = -2 or THRESH = -4. C IF( ( MXNORM.LT.MXS .AND. MXNORM.LT.MXS/MXGAIN .AND. ITH.EQ.-2) $ .OR. ITH.EQ.-4 ) THEN IR = IDAMAX( NR, DWORK(KW6), 1 ) JC = IDAMAX( NR, DWORK(KW7), 1 ) T = DWORK(KW6+IR-1) MN = T DO 410 I = KW6, KW6+NR-1 IF( DWORK(I).LT.MN ) $ MN = DWORK(I) 410 CONTINUE T = MN/T TA = DWORK(KW7+JC-1) MN = TA DO 420 I = KW7, KW7+NR-1 IF( DWORK(I).LT.MN ) $ MN = DWORK(I) 420 CONTINUE T = MIN( T, MN/TA ) IF( T.LT.ONE/MXCOND ) THEN DUM(1) = ONE CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 ) IWARN = 1 NAS = NA0 NBS = NB0 THS = TH0 GO TO 460 END IF END IF IF( STORMN ) THEN CALL DCOPY( NR, DWORK(KW6), 1, LSCALE(ILO), 1 ) CALL DCOPY( NR, DWORK(KW7), 1, RSCALE(ILO), 1 ) ELSE NAS = NA NBS = NB THS = TH END IF END IF C 430 CONTINUE C C Row scaling. C DO 440 I = ILO, IHI CALL DSCAL( N-ILO+1, LSCALE(I), A(I,ILO), LDA ) CALL DSCAL( N-ILO+1, LSCALE(I), B(I,ILO), LDB ) 440 CONTINUE C C Column scaling. C DO 450 J = ILO, IHI CALL DSCAL( IHI, RSCALE(J), A(1,J), 1 ) CALL DSCAL( IHI, RSCALE(J), B(1,J), 1 ) 450 CONTINUE C C Set DWORK(1:5). C 460 CONTINUE IF( EVNORM ) THEN NAS = DLANGE( '1-norm', NR, NR, A(ILO,ILO), LDA, DWORK ) NBS = DLANGE( '1-norm', NR, NR, B(ILO,ILO), LDB, DWORK ) END IF C DWORK(1) = NA0 DWORK(2) = NB0 DWORK(3) = NAS DWORK(4) = NBS IF( LOOP ) THEN DWORK(5) = THS/MAX( MXNORM, SFMIN ) ELSE DWORK(5) = THRESH END IF C RETURN C *** Last line of MB04DL *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03MY.f0000644000000000000000000000013215012430707016204 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03MY.f0000644000175000017500000000353715012430707017410 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION MB03MY( NX, X, INCX ) C C PURPOSE C C To compute the absolute minimal value of NX elements in an array. C The function returns the value zero if NX < 1. C C ARGUMENTS C C NX (input) INTEGER C The number of elements in X to be examined. C C X (input) DOUBLE PRECISION array, dimension (NX * INCX) C The one-dimensional array of which the absolute minimal C value of the elements is to be computed. C This array is not referenced if NX < 1. C C INCX (input) INTEGER C The increment to be taken in the array X, defining the C distance between two consecutive elements. INCX >= 1. C INCX = 1, if all elements are contiguous in memory. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MB03AZ by S. Van Huffel, Katholieke C University, Leuven, Belgium. C C REVISIONS C C June 16, 1997. C C KEYWORDS C C None. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER INCX, NX C .. Array Arguments .. DOUBLE PRECISION X(*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION DX C .. Intrinsic Functions .. INTRINSIC ABS C .. Executable Statements .. C C Quick return if possible. C IF ( NX.LE.0 ) THEN MB03MY = ZERO RETURN END IF C MB03MY = ABS( X(1) ) C DO 20 I = 1+INCX, NX*INCX, INCX DX = ABS( X(I) ) IF ( DX.LT.MB03MY ) MB03MY = DX 20 CONTINUE C RETURN C *** Last line of MB03MY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB3PYZ.f0000644000000000000000000000013015012430707016257 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB3PYZ.f0000644000175000017500000003251215012430707017460 0ustar00lilgelilge00000000000000 SUBROUTINE MB3PYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, $ TAU, DWORK, ZWORK, INFO ) C C PURPOSE C C To compute a rank-revealing RQ factorization of a complex 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 MB3PYZ 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) COMPLEX*16 array, dimension ( 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 unitary 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) COMPLEX*16 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 ( 2*M ) C C ZWORK COMPLEX*16 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 complex scalar, and v is a complex vector with C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored C on exit 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 stable. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. C C KEYWORDS C C Eigenvalue problem, matrix operations, unitary transformation, C singular values. C C ****************************************************************** C C .. Parameters .. INTEGER IMAX, IMIN PARAMETER ( IMAX = 1, IMIN = 2 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. INTEGER INFO, LDA, M, N, RANK DOUBLE PRECISION RCOND, SVLMAX C .. Array Arguments .. INTEGER JPVT( * ) COMPLEX*16 A( LDA, * ), TAU( * ), ZWORK( * ) DOUBLE PRECISION DWORK( * ), SVAL( 3 ) C .. Local Scalars .. INTEGER I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI, $ PVT COMPLEX*16 AII, C1, C2, S1, S2 DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2, TOLZ C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL DLAMCH, DZNRM2, IDAMAX C .. C .. External Subroutines .. EXTERNAL XERBLA, ZCOPY, ZLACGV, ZLAIC1, ZLARF, ZLARFG, $ ZSCAL, ZSWAP C .. 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( 'MB3PYZ', -INFO ) RETURN END IF C C Quick return if possible. C K = MIN( M, N ) IF( K.EQ.0 ) THEN RANK = 0 SVAL( 1 ) = ZERO SVAL( 2 ) = ZERO SVAL( 3 ) = ZERO RETURN END IF C TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) ISMIN = 1 ISMAX = ISMIN + M JWORK = ISMAX + M C C Initialize partial row norms and pivoting vector. The first m C elements of DWORK store the exact row norms. C DO 10 I = 1, M DWORK( I ) = DZNRM2( N, A( I, 1 ), LDA ) DWORK( M+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.K ) THEN I = K - RANK C C Determine ith pivot row and swap if necessary. C MKI = M - RANK NKI = N - RANK PVT = IDAMAX( MKI, DWORK, 1 ) C IF( PVT.NE.MKI ) THEN CALL ZSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( MKI ) JPVT( MKI ) = ITEMP DWORK( PVT ) = DWORK( MKI ) DWORK( M+PVT ) = DWORK( M+MKI ) END IF C IF( NKI.GT.1 ) THEN C C Save A(m-k+i,n-k+i) and generate elementary reflector H(i) C to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n). C A(m-k+i,1:n-k+i) * H(tau,v) = [0 , *] <=> C H(conj(tau),v) A(m-k+i,1:n-k+i)^H = [0 ; *], C using H(tau,v)^H = H(conj(tau),v). C CALL ZLACGV( NKI, A( MKI, 1 ), LDA ) AII = A( MKI, NKI ) CALL ZLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) $ ) END IF C IF( RANK.EQ.0 ) THEN C C Initialize; exit if matrix is zero (RANK = 0). C SMAX = ABS( A( M, N ) ) IF ( SMAX.EQ.ZERO ) THEN SVAL( 1 ) = ZERO SVAL( 2 ) = ZERO SVAL( 3 ) = ZERO RETURN END IF SMIN = SMAX SMAXPR = SMAX SMINPR = SMIN C1 = CONE C2 = CONE ELSE C C One step of incremental condition estimation. C CALL ZCOPY ( RANK, A( MKI, NKI+1 ), LDA, ZWORK( JWORK ), 1 ) CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN, $ ZWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 ) CALL ZLAIC1( IMAX, RANK, ZWORK( ISMAX ), SMAX, $ ZWORK( JWORK ), A( MKI, NKI ), 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 IF( MKI.GT.1 ) THEN C C Continue factorization, as rank is at least RANK. C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. C AII = A( MKI, NKI ) A( MKI, NKI ) = CONE CALL ZLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, $ TAU( I ), A, LDA, ZWORK( JWORK ) ) A( MKI, NKI ) = AII C C Update partial row norms. C DO 30 J = 1, MKI - 1 IF( DWORK( J ).NE.ZERO ) THEN TEMP = ABS( A( J, NKI ) ) / DWORK( J ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), $ ZERO ) TEMP2 = TEMP*( DWORK( J ) / DWORK( M+J ) )**2 IF( TEMP2.LE.TOLZ ) THEN DWORK( J ) = DZNRM2( NKI-1, A( J, 1 ), $ LDA ) DWORK( M+J ) = DWORK( J ) ELSE DWORK( J ) = DWORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE C END IF C DO 40 I = 1, RANK ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 ) ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 ) 40 CONTINUE C ZWORK( ISMIN+RANK ) = C1 ZWORK( ISMAX+RANK ) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA ) GO TO 20 END IF END IF END IF END IF C C Restore the changed part of the (M-RANK)-th row and set SVAL. C IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA ) CALL ZSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA ) A( MKI, NKI ) = AII END IF SVAL( 1 ) = SMAX SVAL( 2 ) = SMIN SVAL( 3 ) = SMINPR C RETURN C *** Last line of MB3PYZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02JD.f0000644000000000000000000000013215012430707016153 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02JD.f0000644000175000017500000004730615012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE MB02JD( JOB, K, L, M, N, P, S, TC, LDTC, TR, LDTR, Q, $ LDQ, R, LDR, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute a lower triangular matrix R and a matrix Q with C Q^T Q = I such that C T C T = Q R , C C where T is a K*M-by-L*N block Toeplitz matrix with blocks of size C (K,L). The first column of T will be denoted by TC and the first C row by TR. It is assumed that the first MIN(M*K, N*L) columns of T C have full rank. C C By subsequent calls of this routine the factors Q and R can be C computed block column by block column. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the output of the routine as follows: C = 'Q': computes Q and R; C = 'R': only computes R. C C Input/Output Parameters C C K (input) INTEGER C The number of rows in one block of T. K >= 0. C C L (input) INTEGER C The number of columns in one block of T. L >= 0. C C M (input) INTEGER C The number of blocks in one block column of T. M >= 0. C C N (input) INTEGER C The number of blocks in one block row of T. N >= 0. C C P (input) INTEGER C The number of previously computed block columns of R. C P*L < MIN( M*K,N*L ) + L and P >= 0. C C S (input) INTEGER C The number of block columns of R to compute. C (P+S)*L < MIN( M*K,N*L ) + L and S >= 0. C C TC (input) DOUBLE PRECISION array, dimension (LDTC, L) C On entry, if P = 0, the leading M*K-by-L part of this C array must contain the first block column of T. C C LDTC INTEGER C The leading dimension of the array TC. C LDTC >= MAX(1,M*K). C C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) C On entry, if P = 0, the leading K-by-(N-1)*L part of this C array must contain the first block row of T without the C leading K-by-L block. C C LDTR INTEGER C The leading dimension of the array TR. C LDTR >= MAX(1,K). C C Q (input/output) DOUBLE PRECISION array, dimension C (LDQ,MIN( S*L, MIN( M*K,N*L )-P*L )) C On entry, if JOB = 'Q' and P > 0, the leading M*K-by-L C part of this array must contain the last block column of Q C from a previous call of this routine. C On exit, if JOB = 'Q' and INFO = 0, the leading C M*K-by-MIN( S*L, MIN( M*K,N*L )-P*L ) part of this array C contains the P-th to (P+S)-th block columns of the factor C Q. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= MAX(1,M*K), if JOB = 'Q'; C LDQ >= 1, if JOB = 'R'. C C R (input/output) DOUBLE PRECISION array, dimension C (LDR,MIN( S*L, MIN( M*K,N*L )-P*L )) C On entry, if P > 0, the leading (N-P+1)*L-by-L C part of this array must contain the nozero part of the C last block column of R from a previous call of this C routine. C One exit, if INFO = 0, the leading C MIN( N, N-P+1 )*L-by-MIN( S*L, MIN( M*K,N*L )-P*L ) C part of this array contains the nonzero parts of the P-th C to (P+S)-th block columns of the lower triangular C factor R. C Note that elements in the strictly upper triangular part C will not be referenced. C C LDR INTEGER C The leading dimension of the array R. C LDR >= MAX( 1, MIN( N, N-P+1 )*L ) 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 On exit, if INFO = -17, DWORK(1) returns the minimum C value of LDWORK. C If JOB = 'Q', the first 1 + ( (N-1)*L + M*K )*( 2*K + L ) C elements of DWORK should be preserved during successive C calls of the routine. C If JOB = 'R', the first 1 + (N-1)*L*( 2*K + L ) elements C of DWORK should be preserved during successive calls of C the routine. C C LDWORK INTEGER C The length of the array DWORK. C JOB = 'Q': C LDWORK >= 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L C + MAX( M*K,( N - MAX( 1,P )*L ) ); C JOB = 'R': C If P = 0, C LDWORK >= MAX( 1 + ( N - 1 )*L*( L + 2*K ) + 6*L C + (N-1)*L, M*K*( L + 1 ) + L ); C If P > 0, C LDWORK >= 1 + (N-1)*L*( L + 2*K ) + 6*L + (N-P)*L. 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 = 1: the full rank condition for the first MIN(M*K, N*L) C columns of T is (numerically) violated. C C METHOD C C Block Householder transformations and modified hyperbolic C rotations are used in the Schur algorithm [1], [2]. C C REFERENCES C C [1] Kailath, T. and Sayed, A. C Fast Reliable Algorithms for Matrices with Structure. C SIAM Publications, Philadelphia, 1999. C C [2] Kressner, D. and Van Dooren, P. C Factorizations and linear system solvers for matrices with C Toeplitz structure. C SLICOT Working Note 2000-2, 2000. C C NUMERICAL ASPECTS C C The implemented method yields a factor R which has comparable C accuracy with the Cholesky factor of T^T * T. Q is implicitly C computed from the formula Q = T * inv(R^T R) * R, i.e., for ill C conditioned problems this factor is of very limited value. C 2 C The algorithm requires 0(K*L *M*N) floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, June 2001. C D. Kressner, Technical Univ. Berlin, Germany, July 2002. C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004, C Aug. 2011. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK, $ M, N, P, S C .. Array Arguments .. DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*), $ TR(LDTR,*) C .. Local Scalars .. INTEGER COLR, I, IERR, KK, LEN, NB, NBMIN, PDQ, PDW, $ PNQ, PNR, PRE, PT, RNK, SHFR, STPS, WRKMIN, $ WRKOPT LOGICAL COMPQ, LQUERY C .. Local Arrays .. INTEGER IPVT(1) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL ILAENV, LSAME C .. External Subroutines .. EXTERNAL DGELQF, DGEQRF, DLACPY, DLASET, DORGQR, MA02AD, $ MB02CU, MB02CV, MB02KD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 COMPQ = LSAME( JOB, 'Q' ) IF ( COMPQ ) THEN WRKMIN = 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L $ + MAX( M*K, ( N - MAX( 1, P ) )*L ) ELSE WRKMIN = 1 + ( N - 1 )*L*( L + 2*K ) + 6*L $ + ( N - MAX( P, 1 ) )*L IF ( P.EQ.0 ) THEN WRKMIN = MAX( WRKMIN, M*K*( L + 1 ) + L ) END IF END IF C C Check the scalar input parameters. C IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN INFO = -1 ELSE IF ( K.LT.0 ) THEN INFO = -2 ELSE IF ( L.LT.0 ) THEN INFO = -3 ELSE IF ( M.LT.0 ) THEN INFO = -4 ELSE IF ( N.LT.0 ) THEN INFO = -5 ELSE IF ( P*L.GE.MIN( M*K, N*L ) + L .OR. P.LT.0 ) THEN INFO = -6 ELSE IF ( ( P + S )*L.GE.MIN( M*K, N*L ) + L .OR. S.LT.0 ) THEN INFO = -7 ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN INFO = -9 ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN INFO = -11 ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.M*K ) ) THEN INFO = -13 ELSE IF ( LDR.LT.MAX( 1, MIN( N, N - P + 1 )*L ) ) THEN INFO = -15 ELSE LQUERY = LDWORK.EQ.-1 IF ( LQUERY ) THEN WRKOPT = 1 IF ( M*K.LE.L ) THEN PDW = M*K*L + M*K CALL DGEQRF( M*K, L, DWORK, M*K, DWORK, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW ) CALL DORGQR( M*K, M*K, M*K, DWORK, M*K, DWORK, DWORK, -1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW ) IF ( N.GT.1 ) THEN PDW = M*K*M*K CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, M*K, $ ONE, ZERO, TC, LDTC, TR, LDTR, DWORK, $ M*K, R, LDR, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW ) END IF C ELSE IF ( P.EQ.0 ) THEN IF ( COMPQ ) THEN CALL DGEQRF( M*K, L, Q, LDQ, DWORK, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + L ) CALL DORGQR( M*K, L, L, Q, LDQ, DWORK, DWORK, -1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + L ) IF ( N.GT.1 ) THEN CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, $ ONE, ZERO, TC, LDTC, TR, LDTR, Q, LDQ, $ R, LDR, DWORK, LDWORK, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF ELSE PDW = M*K*L CALL DGEQRF( M*K, L, DWORK, M*K, DWORK, DWORK, -1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW + L ) CALL DORGQR( M*K, L, L, DWORK, M*K, DWORK, DWORK, -1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW + L ) IF ( N.GT.1 ) THEN CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, $ ONE, ZERO, TC, LDTC, TR, LDTR, DWORK, $ M*K, R, LDR, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW ) END IF END IF PRE = 1 END IF C IF ( M*K.GT.L .OR. P.GT.0 .OR. $ ( P.EQ.0 .AND. N.GT.1 ) ) THEN PRE = MAX( 1, P ) IF ( COMPQ ) THEN PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 1 LEN = MAX( L + M*K, ( N - PRE + 1 )*L ) ELSE PDW = ( 2*K + L )*( N - 1 )*L + 1 LEN = ( N - PRE + 1 )*L END IF C CALL DGELQF( LEN, L, DWORK, MAX( 1, LEN ), DWORK, DWORK, $ -1, IERR ) WRKOPT = MAX( WRKOPT, PDW + 6*L + INT( DWORK(1) ) ) END IF ELSE IF ( LDWORK.LT.WRKMIN ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = -17 END IF END IF C C Return if there were illegal values. C IF ( INFO .NE. 0 ) THEN CALL XERBLA( 'MB02JD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF ( MIN( M, N, K*L, S ) .EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Catch M*K <= L. C WRKOPT = 1 IF ( M*K.LE.L ) THEN CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) PDW = M*K*L + 1 CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW), $ DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 ) CALL MA02AD( 'Upper part', M*K, L, DWORK, M*K, R, LDR ) CALL DORGQR( M*K, M*K, M*K, DWORK, M*K, DWORK(PDW), $ DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 ) IF ( COMPQ ) THEN CALL DLACPY( 'All', M*K, M*K, DWORK, M*K, Q, LDQ ) END IF PDW = M*K*M*K + 1 IF ( N.GT.1 ) THEN CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, M*K, ONE, $ ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, R(L+1,1), $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) END IF DWORK(1) = DBLE( WRKOPT ) RETURN END IF C C Compute the generator if P = 0. C IF ( P.EQ.0 ) THEN C C 1st column of the generator. C IF ( COMPQ ) THEN CALL DLACPY( 'All', M*K, L, TC, LDTC, Q, LDQ ) CALL DGEQRF( M*K, L, Q, LDQ, DWORK, DWORK(L+1), $ LDWORK-L, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) CALL MA02AD( 'Upper part', L, L, Q, LDQ, R, LDR ) CALL DORGQR( M*K, L, L, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) IF ( N.GT.1 ) THEN CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, $ ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1), $ LDR, DWORK, LDWORK, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF ELSE PDW = M*K*L + 1 CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW), DWORK(PDW+L), $ LDWORK-PDW-L+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 ) CALL MA02AD( 'Upper part', L, L, DWORK, M*K, R, LDR ) CALL DORGQR( M*K, L, L, DWORK, M*K, DWORK(PDW), $ DWORK(PDW+L), LDWORK-PDW-L+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 ) IF ( N.GT.1 ) THEN CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, $ ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, $ R(L+1,1), LDR, DWORK(PDW), LDWORK-PDW+1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) END IF END IF C C Quick return if N = 1. C IF ( N.EQ.1 ) THEN DWORK(1) = DBLE( WRKOPT ) RETURN END IF C C 2nd column of the generator. C PNR = ( N - 1 )*L*K + 2 CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(2), (N-1)*L ) C C 3rd and 4th column of the generator. C CALL DLACPY( 'All', (N-1)*L, L, R(L+1,1), LDR, DWORK(PNR), $ (N-1)*L ) PT = ( M - 1 )*K + 1 PDW = PNR + ( N - 1 )*L*L C DO 10 I = 1, MIN( M, N-1 ) CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), $ (N-1)*L ) PT = PT - K PDW = PDW + L 10 CONTINUE C PT = 1 C DO 20 I = M + 1, N - 1 CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), $ (N-1)*L ) PT = PT + L PDW = PDW + L 20 CONTINUE C IF ( COMPQ ) THEN PDQ = ( 2*K + L )*( N - 1 )*L + 2 PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2 PNQ = PDQ + M*K*K CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(PDQ), M*K ) CALL DLASET( 'All', (M-1)*K, K, ZERO, ZERO, DWORK(PDQ+K), $ M*K ) CALL DLACPY( 'All', M*K, L, Q, LDQ, DWORK(PNQ), M*K ) CALL DLASET( 'All', M*K, K, ZERO, ZERO, DWORK(PNQ+M*L*K), $ M*K ) ELSE PDW = ( 2*K + L )*( N - 1 )*L + 2 END IF PRE = 1 STPS = S - 1 ELSE C C Set workspace pointers. C PNR = ( N - 1 )*L*K + 2 IF ( COMPQ ) THEN PDQ = ( 2*K + L )*( N - 1 )*L + 2 PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2 PNQ = PDQ + M*K*K ELSE PDW = ( 2*K + L )*( N - 1 )*L + 2 END IF PRE = P STPS = S END IF C C Determine suitable size for the block Housholder reflectors. C IF ( COMPQ ) THEN LEN = MAX( L + M*K, ( N - PRE + 1 )*L ) ELSE LEN = ( N - PRE + 1 )*L END IF NB = MIN( ( LDWORK - PDW - 6*L + 1 ) / LEN, L ) NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LEN, L, -1, -1 ) ) IF ( NB.LT.NBMIN ) NB = 0 COLR = L + 1 C C Generator reduction process. C LEN = ( N - PRE )*L SHFR = ( PRE - 1 )*L DO 30 I = PRE, PRE + STPS - 1 C C IF M*K < N*L the last block might have less than L columns. C KK = MIN( L, M*K - I*L ) CALL DLACPY( 'Lower', LEN, KK, R(COLR-L,COLR-L), LDR, $ R(COLR,COLR), LDR ) CALL MB02CU( 'Column', KK, KK+K, L+K, NB, R(COLR,COLR), LDR, $ DWORK(SHFR+2), (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, $ RNK, IPVT, DWORK(PDW), ZERO, DWORK(PDW+6*L), $ LDWORK-PDW-6*L+1, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The rank condition is (numerically) not C satisfied. C INFO = 1 RETURN END IF IF ( LEN.GT.KK ) THEN CALL MB02CV( 'Column', 'NoStructure', KK, LEN-KK, KK+K, L+K, $ NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2), $ (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, $ R(COLR+KK,COLR), LDR, DWORK(SHFR+KK+2), $ (N-1)*L, DWORK(PNR+SHFR+KK), (N-1)*L, $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, $ IERR ) END IF IF ( COMPQ ) THEN CALL DLASET( 'All', K, KK, ZERO, ZERO, Q(1,COLR), LDQ ) IF ( M.GT.1 ) THEN CALL DLACPY( 'All', (M-1)*K, KK, Q(1,COLR-L), LDQ, $ Q(K+1,COLR), LDQ ) END IF CALL MB02CV( 'Column', 'NoStructure', KK, M*K, KK+K, L+K, $ NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2), $ (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, Q(1,COLR), $ LDQ, DWORK(PDQ), M*K, DWORK(PNQ), M*K, $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, $ IERR ) END IF LEN = LEN - L COLR = COLR + L SHFR = SHFR + L 30 CONTINUE C DWORK(1) = DBLE( WRKOPT ) RETURN C C *** Last line of MB02JD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04TW.f0000644000000000000000000000013215012430707016212 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04TW.f0000644000175000017500000001334015012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE MB04TW( UPDATQ, M, N, NRE, NCE, IFIRE, IFICE, IFICA, A, $ LDA, E, LDE, Q, LDQ ) C C PURPOSE C C To reduce a submatrix E(k) of E to upper triangular form by row C Givens rotations only. C Here E(k) = E(IFIRE:me,IFICE:ne), where me = IFIRE - 1 + NRE, C ne = IFICE - 1 + NCE. C Matrix E(k) is assumed to have full column rank on entry. Hence, C no pivoting is done during the reduction process. See Algorithm C 2.3.1 and Remark 2.3.4 in [1]. C The constructed row transformations are also applied to matrix C A(k) = A(IFIRE:me,IFICA:N). C Note that in A(k) rows are transformed with the same row indices C as in E but with column indices different from those in E. C C ARGUMENTS C C Mode Parameters C C UPDATQ LOGICAL C Indicates whether the user wishes to accumulate in a C matrix Q the orthogonal row transformations, as follows: C = .FALSE.: Do not form Q; C = .TRUE.: The given matrix Q is updated by the orthogonal C row transformations used in the reduction. C C Input/Output Parameters C C M (input) INTEGER C Number of rows of A and E. M >= 0. C C N (input) INTEGER C Number of columns of A and E. N >= 0. C C NRE (input) INTEGER C Number of rows in E to be transformed. 0 <= NRE <= M. C C NCE (input) INTEGER C Number of columns in E to be transformed. 0 <= NCE <= N. C C IFIRE (input) INTEGER C Index of first row in E to be transformed. C C IFICE (input) INTEGER C Index of first column in E to be transformed. C C IFICA (input) INTEGER C Index of first column in A to be transformed. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, this array contains the submatrix A(k). C On exit, it contains the transformed matrix A(k). C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, this array contains the submatrix E(k) of full C column rank to be reduced to upper triangular form. C On exit, it contains the transformed matrix E. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,M). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) C On entry, if UPDATQ = .TRUE., then the leading M-by-M C part of this array must contain a given matrix Q (e.g. C from a previous call to another SLICOT routine), and on C exit, the leading M-by-M part of this array contains the C product of the input matrix Q and the row transformation C matrix that has transformed the rows of the matrices A C and E. C If UPDATQ = .FALSE., the array Q is not referenced and C can be supplied as a dummy array (i.e. set parameter C LDQ = 1 and declare this array to be Q(1,1) in the calling C program). C C LDQ INTEGER C The leading dimension of array Q. If UPDATQ = .TRUE., C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. C C REFERENCES C C [1] Beelen, Th. C New Algorithms for Computing the Kronecker structure of a C Pencil with Applications to Systems and Control Theory. C Ph.D.Thesis, Eindhoven University of Technology, C The Netherlands, 1987. 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, Apr. 1997. C Supersedes Release 2.0 routine MB04FW by Th.G.J. Beelen, C Philips Glass Eindhoven, Holland. C C REVISIONS C C June 13, 1997. V. Sima. C December 30, 1997. A. Varga: Corrected column range to apply C transformations on the matrix E. C C KEYWORDS C C Generalized eigenvalue problem, orthogonal transformation, C staircase form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. LOGICAL UPDATQ INTEGER IFICA, IFICE, IFIRE, LDA, LDE, LDQ, M, N, NCE, $ NRE C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*) C .. Local Scalars .. INTEGER I, IPVT, J DOUBLE PRECISION SC, SS C .. External Subroutines .. EXTERNAL DROT, DROTG C .. Executable Statements .. C IF ( M.LE.0 .OR. N.LE.0 .OR. NRE.LE.0 .OR. NCE.LE.0 ) $ RETURN C IPVT = IFIRE - 1 C DO 40 J = IFICE, IFICE + NCE - 1 IPVT = IPVT + 1 C DO 20 I = IPVT + 1, IFIRE + NRE - 1 C C Determine the Givens transformation on rows i and ipvt C to annihilate E(i,j). C Apply the transformation to these rows (in whole E-matrix) C from columns j up to n . C Apply the transformations also to the A-matrix C (from columns ifica up to n). C Update the row transformation matrix Q, if needed. C CALL DROTG( E(IPVT,J), E(I,J), SC, SS ) CALL DROT( N-J, E(IPVT,J+1), LDE, E(I,J+1), LDE, SC, SS ) E(I,J) = ZERO CALL DROT( N-IFICA+1, A(IPVT,IFICA), LDA, A(I,IFICA), LDA, $ SC, SS ) IF( UPDATQ ) $ CALL DROT( M, Q(1,IPVT), 1, Q(1,I), 1, SC, SS ) 20 CONTINUE C 40 CONTINUE C RETURN C *** Last line of MB04TW *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03AF.f0000644000000000000000000000013215012430707016145 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03AF.f0000644000175000017500000002727215012430707017353 0ustar00lilgelilge00000000000000 SUBROUTINE MB03AF( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, C1, $ S1, C2, S2 ) C C PURPOSE C C To compute two Givens rotations (C1,S1) and (C2,S2) such that the C orthogonal matrix C C [ Q 0 ] [ C1 S1 0 ] [ 1 0 0 ] C Z = [ ], Q := [ -S1 C1 0 ] * [ 0 C2 S2 ], C [ 0 I ] [ 0 0 1 ] [ 0 -S2 C2 ] C C makes the first column of the real Wilkinson double shift C polynomial of the product of matrices in periodic upper Hessenberg C form, stored in the array A, parallel to the first unit vector. C Only the rotation defined by C1 and S1 is used for the real C Wilkinson single shift polynomial (see SLICOT Library routines C MB03BE or MB03BF). C C ARGUMENTS C C Mode Parameters C C SHFT CHARACTER*1 C Specifies the number of shifts employed by the shift C polynomial, as follows: C = 'D': two real shifts; C = 'S': one real shift. C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of the factors in the array A. C N >= 2, for a single shift polynomial; C N >= 3, for a double shift polynomial. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C AMAP(K) is the pointer to the Hessenberg matrix. C Before calling this routine, AMAP returned by SLICOT C Library routine MB03BA should be modified as follows: C J = AMAP(1), AMAP(I) = AMAP(I+1), I = 1:K-1, AMAP(K) = J. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C S(K) is not used, but assumed to be 1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input) DOUBLE PRECISION array, dimension (LDA1,LDA2,K) C On entry, the leading N-by-N-by-K part of this array must C contain a n-by-n product (implicitly represented by its K C factors) in periodic upper Hessenberg form. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= N. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= N. C C C1 (output) DOUBLE PRECISION C S1 (output) DOUBLE PRECISION C On exit, C1 and S1 contain the parameters for the first C Givens rotation. C C C2 (output) DOUBLE PRECISION C S2 (output) DOUBLE PRECISION C On exit, if SHFT = 'D', C2 and S2 contain the parameters C for the second Givens rotation. Otherwise, C2 = 1, S2 = 0. C C METHOD C C Givens rotations are properly computed and applied. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Dec. 2018, Dec. 2020. C C REVISIONS C C V. Sima, Dec. 2019. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER SHFT INTEGER K, LDA1, LDA2, N, SINV DOUBLE PRECISION C1, C2, S1, S2 C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*) C .. Local Scalars .. LOGICAL SGLE INTEGER AI, I, M DOUBLE PRECISION ALPHA, BETA, C2R, C3, C3R, C4, C4R, C5, C5R, C6, $ C6R, CS, CX, DELTA, EPSIL, ETA, GAMMA, S2R, S3, $ S3R, S4, S4R, S5, S5R, S6, S6R, SS, SSS, SSSS, $ SX, TEMP, THETA, VAL1, VAL2, VAL3, VAL4, VAL5, $ ZETA C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARTG C C .. Executable Statements .. C SGLE = LSAME( SHFT, 'S' ) M = N - 1 AI = AMAP(K) CALL DLARTG( A(1,1,AI), A(2,1,AI), C1, S1, TEMP ) CALL DLARTG( TEMP, ONE, C2, S2, TEMP ) C DO 10 I = K - 1, 1, -1 AI = AMAP(I) IF ( S(AI).EQ.SINV ) THEN ALPHA = C2 * ( C1 * A(1,1,AI) + S1 * A(1,2,AI) ) BETA = S1 * C2 * A(2,2,AI) GAMMA = S2 * A(N,N,AI) CALL DLARTG( ALPHA, BETA, C1, S1, TEMP ) CALL DLARTG( TEMP, GAMMA, C2, S2, VAL1 ) ELSE ALPHA = C1 * S2 * A(1,1,AI) GAMMA = S1 * A(1,1,AI) BETA = S2 * ( C1 * A(1,2,AI) + S1 * A(2,2,AI) ) DELTA = C1 * A(2,2,AI) - S1 * A(1,2,AI) CALL DLARTG( DELTA, GAMMA, C1, S1, TEMP ) ALPHA = C1 * ALPHA + S1 * BETA BETA = C2 * A(N,N,AI) CALL DLARTG( BETA, ALPHA, C2, S2, TEMP ) END IF 10 CONTINUE C I = K AI = AMAP(I) ALPHA = S2 * A(N,N,AI) - C1 * C2 BETA = -S1 * C2 C IF ( SGLE ) THEN C C This is sufficient for single real shifts. C CALL DLARTG( ALPHA, BETA, C1, S1, TEMP ) C ELSE C GAMMA = -S2 * A(N,M,AI) CALL DLARTG( ALPHA, GAMMA, C2, S2, TEMP ) CALL DLARTG( TEMP, BETA, C1, S1, TEMP ) CX = C1 * C2 SX = C1 * S2 BETA = S1 * A(N,M,AI) ALPHA = CX * A(N,M,AI) + SX * A(N,N,AI) GAMMA = S1 * A(M,M,AI) DELTA = CX * A(M,M,AI) + SX * A(M,N,AI) VAL1 = S1 * A(3,2,AI) VAL2 = CX * A(2,1,AI) + S1 * A(2,2,AI) VAL3 = CX * A(1,1,AI) + S1 * A(1,2,AI) CALL DLARTG( ALPHA, BETA, C1, S1, TEMP ) CALL DLARTG( GAMMA, TEMP, C2, S2, TEMP ) CALL DLARTG( DELTA, TEMP, C3, S3, TEMP ) CALL DLARTG( VAL1, TEMP, C4, S4, TEMP ) CALL DLARTG( VAL2, TEMP, C5, S5, TEMP ) CALL DLARTG( VAL3, TEMP, C6, S6, TEMP ) C DO 20 I = K - 1, 1, -1 AI = AMAP(I) C IF ( S(AI).EQ.SINV ) THEN SS = S3 * S4 SSS = S2 * SS SSSS = S1 * SSS VAL1 = C4 * A(1,3,AI) VAL2 = C4 * A(2,3,AI) VAL3 = C4 * A(3,3,AI) ALPHA = S4 * C3 * A(M,M,AI) + SSS * C1 * A(M,N,AI) BETA = SS * C2 * A(M,M,AI) + SSSS * A(M,N,AI) GAMMA = SSS * C1 * A(N,N,AI) DELTA = SSSS * A(N,N,AI) C SS = S5 * S6 CS = C5 * S6 VAL1 = SS * VAL1 + CS * A(1,2,AI) + C6 * A(1,1,AI) VAL2 = SS * VAL2 + CS * A(2,2,AI) VAL3 = SS * VAL3 ALPHA = SS * ALPHA BETA = SS * BETA GAMMA = SS * GAMMA DELTA = SS * DELTA C CALL DLARTG( GAMMA, DELTA, C1, S1, TEMP ) CALL DLARTG( BETA, TEMP, C2, S2, TEMP ) CALL DLARTG( ALPHA, TEMP, C3, S3, TEMP ) CALL DLARTG( VAL3, TEMP, C4, S4, TEMP ) CALL DLARTG( VAL2, TEMP, C5, S5, TEMP ) CALL DLARTG( VAL1, TEMP, C6, S6, TEMP ) C ELSE C DELTA = C1 * A(N,N,AI) EPSIL = S1 * A(N,N,AI) C ALPHA = C2 * A(M,M,AI) BETA = S2 * DELTA GAMMA = -S2 * A(M,M,AI) ZETA = C2 * A(M,N,AI) + S2 * EPSIL ETA = -S2 * A(M,N,AI) + C2 * EPSIL C C Update the entry (2n+1,2n+1) for G1'. C DELTA = C1 * C2 * DELTA + S1*ETA C C Compute the new, right rotation G2. C CALL DLARTG( DELTA, -GAMMA, C2R, S2R, TEMP ) C C Apply G3 to the 2-by-4 submatrix in C (n+1:n+2,[n+1:n+2 2n+1:2n+1]). C DELTA = C3 * A(M,M,AI) EPSIL = S3 * ALPHA ETA = C3 * A(M,N,AI) + S3 * BETA THETA = S3 * ZETA GAMMA = -S3 * A(M,M,AI) BETA = -S3 * A(M,N,AI) + C3 * BETA C C Update the entry (n+2,n+2) for G1' and G2R'. C ALPHA = C2R * C3 * ALPHA + S2R * ( C1 * BETA + $ S1 * C3 * ZETA ) C C Compute the new G3. C CALL DLARTG( ALPHA, -GAMMA, C3R, S3R, TEMP ) C C Apply G4 to the 2-by-5 submatrix in C ([3 n+1],[3 n+1:n+2 2n+1:2n+1]). C VAL1 = C4 * A(3,3,AI) VAL2 = S4 * DELTA VAL3 = S4 * EPSIL VAL4 = S4 * ETA VAL5 = S4 * THETA BETA = -S4 * A(3,3,AI) DELTA = C4 * DELTA EPSIL = C4 * EPSIL ZETA = C4 * ETA ETA = C4 * THETA C C Update the entry (n+1,n+1) for G1', G2R', and G3R'. C ALPHA = C3R * DELTA + S3R * ( C2R * EPSIL + S2R * $ ( C1 * ZETA + S1 * ETA ) ) C C Compute the new G4. C CALL DLARTG( ALPHA, -BETA, C4R, S4R, TEMP ) C C Apply G5 to the 2-by-6 submatrix in C (2:3,[2:3 n+1:n+2 2n+1:2n+2]). C BETA = C5 * A(2,2,AI) DELTA = C5 * A(2,3,AI) + S5 * VAL1 EPSIL = S5 * VAL2 ZETA = S5 * VAL3 ETA = S5 * VAL4 THETA = S5 * VAL5 GAMMA = -S5 * A(2,2,AI) VAL1 = C5 * VAL1 - S5 * A(2,3,AI) VAL2 = C5 * VAL2 VAL3 = C5 * VAL3 VAL4 = C5 * VAL4 VAL5 = C5 * VAL5 C C Update the entry (3,3) for G1', G2R', G3R', and G4R'. C ALPHA = C4R * VAL1 + S4R * ( C3R * VAL2 + S3R * $ ( C2R * VAL3 + S2R * $ ( C1 * VAL4 + S1 * VAL5 ) ) ) C C Compute the new G5. C CALL DLARTG( ALPHA, -GAMMA, C5R, S5R, TEMP ) C C Apply G6 to the 2-by-7 submatrix in C (1:2,[1:3 n+1:n+2 2n+1:2n+2]). C GAMMA = -S6 * A(1,1,AI) BETA = C6 * BETA - S6 * A(1,2,AI) DELTA = C6 * DELTA - S6 * A(1,3,AI) EPSIL = C6 * EPSIL ZETA = C6 * ZETA ETA = C6 * ETA THETA = C6 * THETA C C Update the entry (2,2) for G1', G2R', G3R', G4R', and C G5R'. C ALPHA = C5R * BETA + S5R * ( C4R * DELTA + S4R * $ ( C3R * EPSIL + S3R * $ ( C2R * ZETA + S2R * $ ( C1 * ETA + S1 * THETA ) $ ) ) ) C C Compute the new G5. C CALL DLARTG( ALPHA, -GAMMA, C6R, S6R, TEMP ) C C2 = C2R S2 = S2R C3 = C3R S3 = S3R C4 = C4R S4 = S4R C5 = C5R S5 = S5R C6 = C6R S6 = S6R C END IF C 20 CONTINUE C C Last step: let the rotations collap into the first factor. C VAL1 = S5 * S6 VAL2 = S4 * VAL1 VAL3 = S3 * VAL2 ALPHA = C3 * VAL2 - C6 BETA = C2 * VAL3 - C5 * S6 GAMMA = -C4 * VAL1 CALL DLARTG( BETA, GAMMA, C2, S2, TEMP ) CALL DLARTG( ALPHA, TEMP, C1, S1, VAL1 ) C END IF C RETURN C *** Last line of MB03AF *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04TU.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04TU.f0000644000175000017500000000372015012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE MB04TU( N, X, INCX, Y, INCY, C, S ) C C PURPOSE C C To perform the Givens transformation, defined by C (cos) and S C (sin), and interchange the vectors involved, i.e. C C |X(i)| | 0 1 | | C S | |X(i)| C | | := | | x | | x | |, i = 1,...N. C |Y(i)| | 1 0 | |-S C | |Y(i)| C C REMARK. This routine is a modification of DROT from BLAS. C This routine is called only by the SLICOT routines MB04TX C and MB04VX. 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, Apr. 1997. C Supersedes Release 2.0 routine MB04FU by Th.G.J. Beelen, C Philips Glass Eindhoven, Holland. C C REVISIONS C C January 26, 1998. C C KEYWORDS C C Othogonal transformation. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INCX, INCY, N DOUBLE PRECISION C, S C .. Array Arguments .. DOUBLE PRECISION X(*), Y(*) C .. Local Scalars .. DOUBLE PRECISION DTEMP INTEGER I, IX, IY C .. Executable Statements .. C IF ( N.LE.0 ) RETURN IF ( ( INCX.NE.1 ) .OR. ( INCY.NE.1 ) ) THEN C C Code for unequal increments or equal increments not equal to 1. C IX = 1 IY = 1 IF ( INCX.LT.0 ) IX = (-N+1)*INCX + 1 IF ( INCY.LT.0 ) IY = (-N+1)*INCY + 1 C DO 20 I = 1, N DTEMP = C*Y(IY) - S*X(IX) Y(IY) = C*X(IX) + S*Y(IY) X(IX) = DTEMP IX = IX + INCX IY = IY + INCY 20 CONTINUE C ELSE C C Code for both increments equal to 1. C DO 40 I = 1, N DTEMP = C*Y(I) - S*X(I) Y(I) = C*X(I) + S*Y(I) X(I) = DTEMP 40 CONTINUE C END IF C RETURN C *** Last line of MB04TU *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01PD.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01PD.f0000644000175000017500000002764615012430707017402 0ustar00lilgelilge00000000000000 SUBROUTINE TB01PD( JOB, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, $ NR, TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To find a reduced (controllable, observable, or minimal) state- C space representation (Ar,Br,Cr) for any original state-space C representation (A,B,C). The matrix Ar is in upper block C Hessenberg form. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Indicates whether the user wishes to remove the C uncontrollable and/or unobservable parts as follows: C = 'M': Remove both the uncontrollable and unobservable C parts to get a minimal state-space representation; C = 'C': Remove the uncontrollable part only to get a C controllable state-space representation; C = 'O': Remove the unobservable part only to get an C observable state-space representation. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily balance C the triplet (A,B,C) 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 order of the original state-space representation, i.e. C the order of the 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/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the original state dynamics matrix A. C On exit, the leading NR-by-NR part of this array contains C the upper block Hessenberg state dynamics matrix Ar of a C minimal, controllable, or observable realization for the C original system, depending on the value of JOB, JOB = 'M', C JOB = 'C', or JOB = 'O', respectively. 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 if JOB = 'C', or (LDB,MAX(M,P)), otherwise. C On entry, the leading N-by-M part of this array must C contain the original input/state matrix B; if JOB = 'M', C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) C part is used as internal workspace. C On exit, the leading NR-by-M part of this array contains C the transformed input/state matrix Br of a minimal, C controllable, or observable realization for the original C system, depending on the value of JOB, JOB = 'M', C JOB = 'C', or JOB = 'O', respectively. C If JOB = 'C', only the first IWORK(1) rows of B are C nonzero. 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 original state/output matrix C; if JOB = 'M', C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N C part is used as internal workspace. C On exit, the leading P-by-NR part of this array contains C the transformed state/output matrix Cr of a minimal, C controllable, or observable realization for the original C system, depending on the value of JOB, JOB = 'M', C JOB = 'C', or JOB = 'O', respectively. C If JOB = 'M', or JOB = 'O', only the last IWORK(1) columns C (in the first NR columns) of C are nonzero. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,M,P) if N > 0. C LDC >= 1 if N = 0. C C NR (output) INTEGER C The order of the reduced state-space representation C (Ar,Br,Cr) of a minimal, controllable, or observable C realization for the original system, depending on C JOB = 'M', JOB = 'C', or JOB = 'O'. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determination when C transforming (A, B, C). If the user sets TOL > 0, then C the given value of TOL is used as a lower bound for the C reciprocal condition number (see the description of the C argument RCOND in the SLICOT routine MB03OD); a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance C (determined by the SLICOT routine TB01UD) is used instead. C C Workspace C C IWORK INTEGER array, dimension (N+MAX(M,P)) C On exit, if INFO = 0, the first nonzero elements of C IWORK(1:N) return the orders of the diagonal blocks of A. 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, N + MAX(N, 3*M, 3*P)). 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 C METHOD C C If JOB = 'M', the matrices A and B are operated on by orthogonal C similarity transformations (made up of products of Householder C transformations) so as to produce an upper block Hessenberg matrix C A1 and a matrix B1 with all but its first rank(B) rows zero; this C separates out the controllable part of the original system. C Applying the same algorithm to the dual of this subsystem, C therefore separates out the controllable and observable (i.e. C minimal) part of the original system representation, with the C final Ar upper block Hessenberg (after using pertransposition). C If JOB = 'C', or JOB = 'O', only the corresponding part of the C above procedure is applied. C C REFERENCES C C [1] Van Dooren, P. C The Generalized Eigenstructure Problem in Linear System C Theory. (Algorithm 1) C IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations and is backward stable. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. C C REVISIONS C C A. Varga, DLR Oberpfaffenhofen, July 1998. C A. Varga, DLR Oberpfaffenhofen, April 28, 1999. C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. C C KEYWORDS C C Hessenberg form, minimal realization, multivariable system, C orthogonal transformation, state-space model, state-space C representation. C C ****************************************************************** C C .. Parameters .. INTEGER LDIZ PARAMETER ( LDIZ = 1 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL, JOB INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, NR, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) C .. Local Scalars .. LOGICAL LEQUIL, LNJOBC, LNJOBO INTEGER I, INDCON, ITAU, IZ, JWORK, KL, MAXMP, NCONT, $ WRKOPT DOUBLE PRECISION MAXRED C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB07MD, TB01ID, TB01UD, TB01XD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C INFO = 0 MAXMP = MAX( M, P ) LNJOBC = .NOT.LSAME( JOB, 'C' ) LNJOBO = .NOT.LSAME( JOB, 'O' ) LEQUIL = LSAME( EQUIL, 'S' ) C C Test the input scalar arguments. C IF( LNJOBC .AND. LNJOBO .AND. .NOT.LSAME( JOB, 'M' ) ) THEN INFO = -1 ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) 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.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN INFO = -11 ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ) ) ) THEN INFO = -16 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01PD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. ( LNJOBC .AND. MIN( N, P ).EQ.0 ) .OR. $ ( LNJOBO .AND. MIN( N, M ).EQ.0 ) ) THEN NR = 0 C DO 5 I = 1, N IWORK(I) = 0 5 CONTINUE C DWORK(1) = ONE RETURN END IF C C If required, balance the triplet (A,B,C) (default MAXRED). C Workspace: need N. C C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of real workspace needed at that point in the code, C as well as the preferred amount for good performance.) C IF ( LEQUIL ) THEN MAXRED = ZERO CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) WRKOPT = N ELSE WRKOPT = 1 END IF C IZ = 1 ITAU = 1 JWORK = ITAU + N IF ( LNJOBO ) THEN C C Separate out controllable subsystem (of order NCONT): C A <-- Z'*A*Z, B <-- Z'*B, C <-- C*Z. C C Workspace: need N + MAX(N, 3*M, P). C prefer larger. C CALL TB01UD( 'No Z', N, M, P, A, LDA, B, LDB, C, LDC, NCONT, $ INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL, $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 ELSE NCONT = N END IF C IF ( LNJOBC ) THEN C C Separate out the observable subsystem (of order NR): C Form the dual of the subsystem of order NCONT (which is C controllable, if JOB = 'M'), leaving rest as it is. C CALL AB07MD( 'Z', NCONT, M, P, A, LDA, B, LDB, C, LDC, DWORK, $ 1, INFO ) C C And separate out the controllable part of this dual subsystem. C C Workspace: need NCONT + MAX(NCONT, 3*P, M). C prefer larger. C CALL TB01UD( 'No Z', NCONT, P, M, A, LDA, B, LDB, C, LDC, NR, $ INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL, $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Transpose and reorder (to get a block upper Hessenberg C matrix A), giving, for JOB = 'M', the controllable and C observable (i.e., minimal) part of original system. C IF( INDCON.GT.0 ) THEN KL = IWORK(1) - 1 IF ( INDCON.GE.2 ) $ KL = KL + IWORK(2) ELSE KL = 0 END IF CALL TB01XD( 'Zero D', NR, P, M, KL, MAX( 0, NR-1 ), A, LDA, $ B, LDB, C, LDC, DWORK, 1, INFO ) ELSE NR = NCONT END IF C C Annihilate the trailing components of IWORK(1:N). C DO 10 I = INDCON + 1, N IWORK(I) = 0 10 CONTINUE C C Set optimal workspace dimension. C DWORK(1) = WRKOPT RETURN C *** Last line of TB01PD *** END control-4.1.2/src/slicot/src/PaxHeaders/MC03NX.f0000644000000000000000000000013015012430707016203 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MC03NX.f0000644000175000017500000001003615012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE MC03NX( MP, NP, DP, P, LDP1, LDP2, A, LDA, E, LDE ) C C PURPOSE C C Given an MP-by-NP polynomial matrix of degree dp C dp-1 dp C P(s) = P(0) + ... + P(dp-1) * s + P(dp) * s (1) C C the routine composes the related pencil s*E-A where C C | I | | O -P(dp) | C | . | | I . . | C A = | . | and E = | . . . |. (2) C | . | | . O . | C | I | | I O -P(2) | C | P(0) | | I -P(1) | C C ================================================================== C REMARK: This routine is intended to be called only from the SLICOT C routine MC03ND. C ================================================================== C C ARGUMENTS C C Input/Output Parameters C C MP (input) INTEGER C The number of rows of the polynomial matrix P(s). C MP >= 0. C C NP (input) INTEGER C The number of columns of the polynomial matrix P(s). C NP >= 0. C C DP (input) INTEGER C The degree of the polynomial matrix P(s). DP >= 1. C C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) C The leading MP-by-NP-by-(DP+1) part of this array must C contain the coefficients of the polynomial matrix P(s) C in (1) in increasing powers of s. C C LDP1 INTEGER C The leading dimension of array P. LDP1 >= MAX(1,MP). C C LDP2 INTEGER C The second dimension of array P. LDP2 >= MAX(1,NP). C C A (output) DOUBLE PRECISION array, dimension C (LDA,(DP-1)*MP+NP) C The leading DP*MP-by-((DP-1)*MP+NP) part of this array C contains the matrix A as described in (2). C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,DP*MP). C C E (output) DOUBLE PRECISION array, dimension C (LDE,(DP-1)*MP+NP) C The leading DP*MP-by-((DP-1)*MP+NP) part of this array C contains the matrix E as described in (2). C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,DP*MP). C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC03BX by G.J.H.H. van den Hurk. C C REVISIONS C C - C C KEYWORDS C C Elementary polynomial operations, input output description, C polynomial matrix, polynomial operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER DP, LDA, LDE, LDP1, LDP2, MP, NP C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), E(LDE,*), P(LDP1,LDP2,*) C .. Local Scalars .. INTEGER H1, HB, HE, HI, J, K C .. External Subroutines .. EXTERNAL DLACPY, DLASET, DSCAL C .. Executable Statements .. C IF ( MP.LE.0 .OR. NP.LE.0 ) $ RETURN C C Initialisation of matrices A and E. C H1 = DP*MP HB = H1 - MP HE = HB + NP CALL DLASET( 'Full', H1, HE, ZERO, ONE, A, LDA ) CALL DLASET( 'Full', MP, HB, ZERO, ZERO, E, LDE ) CALL DLACPY( 'Full', HB, HB, A, LDA, E(MP+1,1), LDE ) C C Insert the matrices P(0), P(1), ..., P(dp) at the right places C in the matrices A and E. C HB = HB + 1 CALL DLACPY( 'Full', MP, NP, P(1,1,1), LDP1, A(HB,HB), LDA ) HI = 1 C DO 20 K = DP + 1, 2, -1 CALL DLACPY( 'Full', MP, NP, P(1,1,K), LDP1, E(HI,HB), LDE ) HI = HI + MP 20 CONTINUE C DO 40 J = HB, HE CALL DSCAL( H1, -ONE, E(1,J), 1 ) 40 CONTINUE C RETURN C *** Last line of MC03NX *** END control-4.1.2/src/slicot/src/PaxHeaders/TB04AY.f0000644000000000000000000000013215012430707016200 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB04AY.f0000644000175000017500000001773615012430707017412 0ustar00lilgelilge00000000000000 SUBROUTINE TB04AY( N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, $ LDD, NCONT, INDEXD, DCOEFF, LDDCOE, UCOEFF, $ LDUCO1, LDUCO2, AT, N1, TAU, TOL1, TOL2, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C Calculates the (PWORK x MWORK) transfer matrix T(s), in the form C of polynomial row vectors over monic least common denominator C polynomials, of a given state-space representation (ssr). Each C such row of T(s) is simply a single-output relatively left prime C polynomial matrix representation (pmr), so can be calculated by C applying a simplified version of the Orthogonal Structure C Theorem to a minimal ssr for the corresponding row of the given C system: such an ssr is obtained by using the Orthogonal Canon- C ical Form to first separate out a completely controllable one C for the overall system and then, for each row in turn, applying C it again to the resulting dual SIMO system. The Orthogonal C Structure Theorem produces non-monic denominator and V:I(s) C polynomials: this is avoided here by first scaling AT (the C transpose of the controllable part of A, found in this routine) C by suitable products of its sub-diagonal elements (these are then C no longer needed, so freeing the entire lower triangle for C storing the coefficients of V(s) apart from the leading 1's, C which are treated implicitly). These polynomials are calculated C in reverse order (IW = NMINL - 1,...,1), the monic denominator C D:I(s) found exactly as if it were V:0(s), and finally the C numerator vector U:I(s) obtained from the Orthogonal Structure C Theorem relation. C C ****************************************************************** C DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, $ LDUCO2, LDWORK, MWORK, N, N1, NCONT, PWORK DOUBLE PRECISION TOL1, TOL2 C .. Array Arguments .. INTEGER INDEXD(*), IWORK(*) DOUBLE PRECISION A(LDA,*), AT(N1,*), B(LDB,*), C(LDC,*), $ D(LDD,*), DCOEFF(LDDCOE,*), DWORK(*), $ UCOEFF(LDUCO1,LDUCO2,*), TAU(*) C .. Local Scalars .. INTEGER I, IB, IBI, IC, INDCON, IS, IV, IVMIN1, IWPLUS, $ IZ, J, JWORK, K, L, LWORK, MAXM, NMINL, NPLUS, $ WRKOPT DOUBLE PRECISION TEMP C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSCAL, TB01UD, TB01ZD C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C C Separate out controllable subsystem (of order NCONT). C C Workspace: MAX(N, 3*MWORK, PWORK). C CALL TB01UD( 'No Z', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, $ NCONT, INDCON, IWORK, AT, 1, TAU, TOL2, IWORK(N+1), $ DWORK, LDWORK, INFO ) WRKOPT = INT( DWORK(1) ) C IS = 1 IC = IS + NCONT IZ = IC IB = IC + NCONT LWORK = IB + MWORK*NCONT MAXM = MAX( 1, MWORK ) C C Calculate each row of T(s) in turn. C DO 140 I = 1, PWORK C C Form the dual of I-th NCONT-order MISO subsystem ... C CALL DCOPY( NCONT, C(I,1), LDC, DWORK(IC), 1 ) C DO 10 J = 1, NCONT CALL DCOPY( NCONT, A(J,1), LDA, AT(1,J), 1 ) CALL DCOPY( MWORK, B(J,1), LDB, DWORK((J-1)*MAXM+IB), 1 ) 10 CONTINUE C C and separate out its controllable part, giving minimal C state-space realization for row I. C C Workspace: MWORK*NCONT + 2*NCONT + MAX(NCONT,MWORK). C CALL TB01ZD( 'No Z', NCONT, MWORK, AT, N1, DWORK(IC), $ DWORK(IB), MAXM, NMINL, DWORK(IZ), 1, TAU, TOL1, $ DWORK(LWORK), LDWORK-LWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(LWORK) )+LWORK-1 ) C C Store degree of (monic) denominator, and leading coefficient C vector of numerator. C INDEXD(I) = NMINL DCOEFF(I,1) = ONE CALL DCOPY( MWORK, D(I,1), LDD, UCOEFF(I,1,1), LDUCO1 ) C IF ( NMINL.EQ.1 ) THEN C C Finish off numerator, denominator for simple case NMINL=1. C TEMP = -AT(1,1) DCOEFF(I,2) = TEMP CALL DCOPY( MWORK, D(I,1), LDD, UCOEFF(I,1,2), LDUCO1 ) CALL DSCAL( MWORK, TEMP, UCOEFF(I,1,2), LDUCO1 ) CALL DAXPY( MWORK, DWORK(IC), DWORK(IB), 1, UCOEFF(I,1,2), $ LDUCO1 ) ELSE IF ( NMINL.GT.1 ) THEN C C Set up factors for scaling upper triangle of AT ... C CALL DCOPY( NMINL-1, AT(2,1), N1+1, DWORK(IC+1), 1 ) NPLUS = NMINL + 1 C DO 20 L = IS, IS + NMINL - 1 DWORK(L) = ONE 20 CONTINUE C C and scale it, row by row, starting with row NMINL. C DO 40 JWORK = NMINL, 1, -1 C DO 30 J = JWORK, NMINL AT(JWORK,J) = DWORK(IS+J-1)*AT(JWORK,J) 30 CONTINUE C C Update scale factors for next row. C CALL DSCAL( NMINL-JWORK+1, DWORK(IC+JWORK-1), $ DWORK(IS+JWORK-1), 1 ) 40 CONTINUE C C Calculate each monic polynomial V:JWORK(s) in turn: C K-th coefficient stored as AT(IV,K-1). C DO 70 IV = 2, NMINL JWORK = NPLUS - IV IWPLUS = JWORK + 1 IVMIN1 = IV - 1 C C Set up coefficients due to leading 1's of existing C V:I(s)'s. C DO 50 K = 1, IVMIN1 AT(IV,K) = -AT(IWPLUS,JWORK+K) 50 CONTINUE C IF ( IV.NE.2 ) THEN C C Then add contribution from s * V:JWORK+1(s) term. C CALL DAXPY( IV-2, ONE, AT(IVMIN1,1), N1, AT(IV,1), $ N1 ) C C Finally, add effect of lower coefficients of existing C V:I(s)'s. C DO 60 K = 2, IVMIN1 AT(IV,K) = AT(IV,K) - DDOT( K-1, $ AT(IWPLUS,JWORK+1), N1, $ AT(IV-K+1,1), -(N1+1) ) 60 CONTINUE C END IF 70 CONTINUE C C Determine denominator polynomial D(s) as if it were V:0(s). C DO 80 K = 2, NPLUS DCOEFF(I,K) = -AT(1,K-1) 80 CONTINUE C CALL DAXPY( NMINL-1, ONE, AT(NMINL,1), N1, DCOEFF(I,2), $ LDDCOE ) C DO 90 K = 3, NPLUS DCOEFF(I,K) = DCOEFF(I,K) - DDOT( K-2, AT, N1, $ AT(NMINL-K+3,1), -(N1+1) ) 90 CONTINUE C C Scale (B' * Z), stored in DWORK(IB). C IBI = IB C DO 100 L = 1, NMINL CALL DSCAL( MWORK, DWORK(IS+L-1), DWORK(IBI), 1 ) IBI = IBI + MAXM 100 CONTINUE C C Evaluate numerator polynomial vector (V(s) * B) + (D(s) C * D:I): first set up coefficients due to D:I and leading C 1's of V(s). C IBI = IB C DO 110 K = 2, NPLUS CALL DCOPY( MWORK, DWORK(IBI), 1, UCOEFF(I,1,K), LDUCO1 ) CALL DAXPY( MWORK, DCOEFF(I,K), D(I,1), LDD, $ UCOEFF(I,1,K), LDUCO1 ) IBI = IBI + MAXM 110 CONTINUE C C Add contribution from lower coefficients of V(s). C DO 130 K = 3, NPLUS C DO 120 J = 1, MWORK UCOEFF(I,J,K) = UCOEFF(I,J,K) + DDOT( K-2, $ AT(NMINL-K+3,1), -(N1+1), $ DWORK(IB+J-1), MAXM ) 120 CONTINUE C 130 CONTINUE C END IF 140 CONTINUE C C Set optimal workspace dimension. C DWORK(1) = WRKOPT C RETURN C *** Last line of TB04AY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03ZD.f0000644000000000000000000000013215012430707016174 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03ZD.f0000644000175000017500000012104515012430707017373 0ustar00lilgelilge00000000000000 SUBROUTINE MB03ZD( WHICH, METH, STAB, BALANC, ORTBAL, SELECT, N, $ MM, ILO, SCALE, S, LDS, T, LDT, G, LDG, U1, $ LDU1, U2, LDU2, V1, LDV1, V2, LDV2, M, WR, WI, $ US, LDUS, UU, LDUU, LWORK, IWORK, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To compute the stable and unstable invariant subspaces for a C Hamiltonian matrix with no eigenvalues on the imaginary axis, C using the output of the SLICOT Library routine MB03XD. C C ARGUMENTS C C Mode Parameters C C WHICH CHARACTER*1 C Specifies the cluster of eigenvalues for which the C invariant subspaces are computed: C = 'A': select all n eigenvalues; C = 'S': select a cluster of eigenvalues specified by C SELECT. C C METH CHARACTER*1 C If WHICH = 'A' this parameter specifies the method to be C used for computing bases of the invariant subspaces: C = 'S': compute the n-dimensional basis from a set of C n vectors; C = 'L': compute the n-dimensional basis from a set of C 2*n vectors; C = 'Q': quick return of the set of n vectors; C = 'R': quick return of the set of 2*n vectors. C When in doubt, use METH = 'S'. In some cases, METH = 'L' C may result in more accurately computed invariant C subspaces, see [1]. C Options METH = 'Q' or METH = 'R' return the range vectors C Y = [ Y1; Y2 ], where Y1 and Y2 have 2*n rows and n or 2*n C columns, respectively, which can be directly used, e.g., C for finding the (stabilizing) solution of a Riccati C equation, by solving X*Y1 = Y2. Note that Y1 might be C singular when METH = 'Q'. C C STAB CHARACTER*1 C Specifies the type of invariant subspaces to be computed: C = 'S': compute the stable invariant subspace, i.e., the C invariant subspace belonging to those selected C eigenvalues that have negative real part; C = 'U': compute the unstable invariant subspace, i.e., C the invariant subspace belonging to those C selected eigenvalues that have positive real C part; C = 'B': compute both the stable and unstable invariant C subspaces. C C BALANC CHARACTER*1 C Specifies the type of inverse balancing transformation C required: C = 'N': do nothing; C = 'P': do inverse transformation for permutation only; C = 'S': do inverse transformation for scaling only; C = 'B': do inverse transformations for both permutation C and scaling. C BALANC must be the same as the argument BALANC supplied to C MB03XD. Note that if the data is further post-processed, C e.g., for solving an algebraic Riccati equation, it is C recommended to delay inverse balancing (in particular the C scaling part) and apply it to the final result only, C see [2]. Inverse balancing is not used by this routine C if METH = 'Q' or METH = 'R'. C C ORTBAL CHARACTER*1 C If BALANC <> 'N', this option specifies how inverse C balancing is applied to the computed invariant subspaces: C = 'B': apply inverse balancing before orthogonal bases C for the invariant subspaces are computed; C = 'A': apply inverse balancing after orthogonal bases C for the invariant subspaces have been computed; C this may yield non-orthogonal bases if C BALANC = 'S' or BALANC = 'B'. C C SELECT (input) LOGICAL array, dimension (N) C If WHICH = 'S', SELECT specifies the eigenvalues C corresponding to the positive and negative square C roots of the eigenvalues of S*T in the selected cluster. C To select a real eigenvalue w(j), SELECT(j) must be set C to .TRUE.. To select a complex conjugate pair of C eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 C diagonal block, both SELECT(j) and SELECT(j+1) must be set C to .TRUE.; a complex conjugate pair of eigenvalues must be C either both included in the cluster or both excluded. C This array is not referenced if WHICH = 'A'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices S, T and G. N >= 0. C C MM (input) INTEGER C The number of columns in the arrays US and/or UU. C If WHICH = 'A' and (METH = 'S' or METH = 'Q'), MM = N; C if WHICH = 'A' and (METH = 'L' or METH = 'R'), MM = 2*N; C if WHICH = 'S', MM = M. C The values above for MM give the numbers of vectors to be C returned, if METH = 'Q' or METH = 'R', or the numbers of C vectors to be used for computing a basis for the invariant C subspace(s), if METH = 'S' or METH = 'L', or WHICH = 'S'. C C ILO (input) INTEGER C If BALANC <> 'N', then ILO is the integer returned by C MB03XD. 1 <= ILO <= N+1. C C SCALE (input) DOUBLE PRECISION array, dimension (N) C If BALANC <> 'N', the leading N elements of this array C must contain details of the permutation and scaling C factors, as returned by MB03XD. C This array is not referenced if BALANC = 'N'. C C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) C On entry, the leading N-by-N part of this array must C contain the matrix S in real Schur form. C On exit, the leading N-by-N part of this array is C overwritten. C C LDS INTEGER C The leading dimension of the array S. LDS >= max(1,N). C C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) C On entry, the leading N-by-N part of this array must C contain the upper triangular matrix T. C On exit, the leading N-by-N part of this array is C overwritten. C C LDT INTEGER C The leading dimension of the array T. LDT >= max(1,N). C C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) C On entry, if METH = 'L' or METH = 'R', the leading N-by-N C part of this array must contain a general matrix G. C On exit, if METH = 'L' or METH = 'R', the leading N-by-N C part of this array is overwritten. C This array is not referenced if METH = 'S' or METH = 'Q'. C C LDG INTEGER C The leading dimension of the array G. LDG >= 1. C LDG >= max(1,N) if METH = 'L' or METH = 'R'. C C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) C On entry, the leading N-by-N part of this array must C contain the (1,1) block of an orthogonal symplectic C matrix U. C On exit, this array is overwritten. C C LDU1 INTEGER C The leading dimension of the array U1. LDU1 >= MAX(1,N). C C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) C On entry, the leading N-by-N part of this array must C contain the (2,1) block of an orthogonal symplectic C matrix U. C On exit, this array is overwritten. C C LDU2 INTEGER C The leading dimension of the array U2. LDU2 >= MAX(1,N). C C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) C On entry, the leading N-by-N part of this array must C contain the (1,1) block of an orthogonal symplectic C matrix V. C On exit, this array is overwritten. C C LDV1 INTEGER C The leading dimension of the array V1. LDV1 >= MAX(1,N). C C V2 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) C On entry, the leading N-by-N part of this array must C contain the (2,1) block of an orthogonal symplectic C matrix V. C On exit, this array is overwritten. C C LDV2 INTEGER C The leading dimension of the array V2. LDV2 >= MAX(1,N). C C M (output) INTEGER C The number of selected eigenvalues. C C WR (output) DOUBLE PRECISION array, dimension (M) C WI (output) DOUBLE PRECISION array, dimension (M) C On exit, the leading M elements of WR and WI contain the C real and imaginary parts, respectively, of the selected C eigenvalues that have nonpositive real part. Complex C conjugate pairs of eigenvalues with real part not equal C to zero will appear consecutively with the eigenvalue C having the positive imaginary part first. Note that, due C to roundoff errors, these numbers may differ from the C eigenvalues computed by MB03XD. C C US (output) DOUBLE PRECISION array, dimension (LDUS,MM) C On exit, if STAB = 'S' or STAB = 'B', the leading C 2*N-by-MM part of this array contains a basis for the C stable invariant subspace belonging to the selected C eigenvalues, if METH = 'S' or METH = 'L', or the range C vectors Y, if METH = 'Q' or METH = 'R' (see parameter C METH). This basis is orthogonal unless ORTBAL = 'A'. C C LDUS INTEGER C The leading dimension of the array US. LDUS >= 1. C If STAB = 'S' or STAB = 'B', LDUS >= 2*N. C C UU (output) DOUBLE PRECISION array, dimension (LDUU,MM) C On exit, if STAB = 'U' or STAB = 'B', the leading C 2*N-by-MM part of this array contains a basis for the C unstable invariant subspace belonging to the selected C eigenvalues, if METH = 'S' or METH = 'L', or the range C vectors Y, if METH = 'Q' or METH = 'R' (see parameter C METH). This basis is orthogonal unless ORTBAL = 'A'. C C LDUU INTEGER C The leading dimension of the array UU. LDUU >= 1. C If STAB = 'U' or STAB = 'B', LDUU >= 2*N. C C Workspace C C LWORK LOGICAL array, dimension (2*N) C This array is only referenced if WHICH = 'A' and C (METH = 'L' or METH = 'R'). C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = 2*N, if WHICH = 'A' and METH = 'L'; C LIWORK = N, if WHICH = 'A' and METH = 'S'; C LIWORK = 0, if WHICH = 'A' and METH = 'Q' or METH = 'R'; C LIWORK = M, if WHICH = 'S'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -35, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C If WHICH = 'S' or METH = 'S' or METH = 'Q': C LDWORK >= MAX( 1, 4*M*M + MAX( 8*M, 4*N ) ). C If WHICH = 'A' and (METH = 'L' or METH = 'R') and C ( STAB = 'U' or STAB = 'S' ): C LDWORK >= MAX( 1, 2*N*N + 2*N, 8*N ). C If WHICH = 'A' and (METH = 'L' or METH = 'R') and C STAB = 'B': C LDWORK >= 8*N + 1. 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 = 1: some of the selected eigenvalues are on or too close C to the imaginary axis; C = 2: reordering of the product S*T in routine MB03ZA C failed because some eigenvalues are too close to C separate; C = 3: the QR algorithm failed to compute some Schur form C in MB03ZA; C = 4: reordering of the Hamiltonian Schur form in routine C MB03TD failed because some eigenvalues are too close C to separate; C = 5: the computed stable invariant subspace for C METH = 'S' is inaccurate. This may be taken as a C warning and a suggestion to try METH = 'L'; C = 6: the computed unstable invariant subspace for C METH = 'S' is inaccurate. This may be taken as a C warning and a suggestion to try METH = 'L'. C C METHOD C C This is an implementation of Algorithm 1 in [1]. C C NUMERICAL ASPECTS C C The method is strongly backward stable for an embedded C (skew-)Hamiltonian matrix, see [1]. Although good results have C been reported if the eigenvalues are not too close to the C imaginary axis, the method is not backward stable for the original C Hamiltonian matrix itself. C C REFERENCES C C [1] Benner, P., Mehrmann, V., and Xu, H. C A new method for computing the stable invariant subspace of a C real Hamiltonian matrix, J. Comput. Appl. Math., 86, C pp. 17-43, 1997. C C [2] Benner, P. C Symplectic balancing of Hamiltonian matrices. C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2001. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHASUB). C V. Sima, Aug. 2011, Mar. 2015, Apr. 2015. C C KEYWORDS C C Hamiltonian matrix, invariant subspace. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HUNDRD PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HUNDRD = 1.0D2 ) C .. Scalar Arguments .. CHARACTER BALANC, METH, ORTBAL, STAB, WHICH INTEGER ILO, INFO, LDG, LDS, LDT, LDU1, LDU2, LDUS, $ LDUU, LDV1, LDV2, LDWORK, M, MM, N C .. Array Arguments .. LOGICAL LWORK(*), SELECT(*) INTEGER IWORK(*) DOUBLE PRECISION DWORK(*), G(LDG,*), S(LDS,*), SCALE(*), $ T(LDT,*), U1(LDU1,*), U2(LDU2,*), US(LDUS,*), $ UU(LDUU,*), V1(LDV1,*), V2(LDV2,*), WI(*), $ WR(*) C .. Local Scalars .. LOGICAL LALL, LBAL, LBEF, LEXT, LQUERY, LRIC, LUS, LUU, $ PAIR INTEGER I, IERR, J, K, PDW, PW, WRKMIN, WRKOPT DOUBLE PRECISION NRMIN, RCOND, TEMP, TOL C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DASUM, DLAMCH, DLANGE EXTERNAL DASUM, DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DGEMM, DGEQP3, DGEQRF, DLACPY, DLASCL, $ DLASET, DORGQR, DSCAL, DTRCON, MB01UX, MB03TD, $ MB03ZA, MB04DI, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C C .. Executable Statements .. C C Decode and check input parameters. C LALL = LSAME( WHICH, 'A' ) IF ( LALL ) THEN LEXT = LSAME( METH, 'L' ) .OR. LSAME( METH, 'R' ) ELSE LEXT = .FALSE. END IF LRIC = LSAME( METH, 'Q' ) .OR. LSAME( METH, 'R' ) LUS = LSAME( STAB, 'S' ) .OR. LSAME( STAB, 'B' ) LUU = LSAME( STAB, 'U' ) .OR. LSAME( STAB, 'B' ) LBAL = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'S' ) .OR. $ LSAME( BALANC, 'B' ) LBEF = .FALSE. IF ( LBAL ) $ LBEF = LSAME( ORTBAL, 'B' ) C INFO = 0 C IF ( .NOT.LALL .AND. .NOT.LSAME( WHICH, 'S' ) ) THEN INFO = -1 ELSE IF ( LALL .AND. ( .NOT.LEXT .AND. .NOT.LRIC .AND. $ .NOT.LSAME( METH, 'S' ) ) ) THEN INFO = -2 ELSE IF ( .NOT.LUS .AND. .NOT.LUU ) THEN INFO = -3 ELSE IF ( .NOT.LBAL .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN INFO = -4 ELSE IF ( LBAL .AND. ( .NOT.LBEF .AND. $ .NOT.LSAME( ORTBAL, 'A' ) ) ) THEN INFO = -5 ELSE IF ( LALL ) THEN M = N ELSE C C Set M to the dimension of the specified invariant subspace. C M = 0 PAIR = .FALSE. DO 10 K = 1, N IF ( PAIR ) THEN PAIR = .FALSE. ELSE IF ( K.LT.N ) THEN IF ( S(K+1,K).EQ.ZERO ) THEN IF ( SELECT(K) ) $ M = M + 1 ELSE PAIR = .TRUE. IF ( SELECT(K) .OR. SELECT(K+1) ) $ M = M + 2 END IF ELSE IF ( SELECT(N) ) $ M = M + 1 END IF END IF 10 CONTINUE END IF C C Compute workspace requirements. C IF ( MIN( M, MM ).EQ.0 ) THEN WRKMIN = 1 ELSE IF ( .NOT.LEXT ) THEN WRKMIN = MAX( 1, 4*M*M + MAX( 8*M, 4*N ) ) ELSE IF ( LUS.AND.LUU ) THEN WRKMIN = MAX( 1, 8*N + 1 ) ELSE WRKMIN = MAX( 1, 2*N*N + 2*N, 8*N ) END IF END IF WRKOPT = WRKMIN LQUERY = LDWORK.EQ.-1 C IF ( N.LT.0 ) THEN INFO = -7 ELSE IF ( MM.LT.M .OR. ( LEXT .AND. MM.LT.2*N ) ) THEN INFO = -8 ELSE IF ( LBAL .AND. ( ILO.LT.1 .OR. ILO.GT.N+1 ) ) THEN INFO = -9 ELSE IF ( LDS.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF ( LDT.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF ( LDG.LT.1 .OR. ( LEXT .AND. LDG.LT.N ) ) THEN INFO = -16 ELSE IF ( LDU1.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE IF ( LDU2.LT.MAX( 1, N ) ) THEN INFO = -20 ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN INFO = -22 ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN INFO = -24 ELSE IF ( LDUS.LT.1 .OR. ( LUS .AND. LDUS.LT.2*N ) ) THEN INFO = -29 ELSE IF ( LDUU.LT.1 .OR. ( LUU .AND. LDUU.LT.2*N ) ) THEN INFO = -31 ELSE IF ( LQUERY ) THEN IF ( MIN( N, MM ).EQ.0 ) THEN DWORK(1) = ONE RETURN ELSE IF ( .NOT.LEXT ) THEN CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, $ DWORK, M, V1, LDV1, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + 2*M*M ) IF ( LUS .OR. LUU ) THEN CALL DGEQRF( 2*N, M, DWORK, 2*N, DWORK, DWORK, -1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + M ) CALL DORGQR( 2*N, M, M, DWORK, 2*N, DWORK, DWORK, -1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + M ) END IF ELSE CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, $ ONE, DWORK, N, DWORK, 2*N, DWORK, -1, IERR ) IF ( ( LUS .AND.( .NOT.LUU ) ) .OR. $ ( LUU .AND.( .NOT.LUS ) ) ) THEN I = 2*N*N ELSE I = 0 END IF WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + I ) IF ( LUS .OR. LUU ) THEN CALL DGEQP3( 2*N, 2*N, DWORK, 2*N, IWORK, DWORK, $ DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + 2*N ) CALL DORGQR( 2*N, 2*N, N, DWORK, 2*N, DWORK, DWORK, $ -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + 2*N ) END IF END IF DWORK(1) = DBLE( WRKOPT ) RETURN ELSE IF ( LDWORK.LT.WRKMIN ) THEN INFO = -35 DWORK(1) = DBLE( WRKMIN ) END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03ZD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( MM, N ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF WRKOPT = WRKMIN C IF ( .NOT.LEXT ) THEN C C Workspace requirements: 4*M*M + MAX( 8*M, 4*N ). C PW = 1 PDW = PW + 4*M*M CALL MB03ZA( 'No Update', 'Update', 'Update', 'Init', WHICH, $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, U2, $ LDU2, V1, LDV1, V2, LDV2, DWORK(PW), 2*M, WR, WI, $ M, DWORK(PDW), LDWORK-PDW+1, IERR ) IF ( IERR.NE.0 ) $ GO TO 250 C PDW = PW + 2*M*M CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, $ DWORK(PW), 2*M, V1, LDV1, DWORK(PDW), $ LDWORK-PDW+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) C IF ( LUS ) $ CALL DLACPY( 'All', N, M, V1, LDV1, US, LDUS ) IF ( LUU ) $ CALL DLACPY( 'All', N, M, V1, LDV1, UU, LDUU ) C CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, $ DWORK(PW+M), 2*M, U1, LDU1, DWORK(PDW), $ LDWORK-PDW+1, IERR ) C IF ( LUS ) THEN DO 20 J = 1, M CALL DAXPY( N, -ONE, U1(1,J), 1, US(1,J), 1 ) 20 CONTINUE END IF IF ( LUU ) THEN DO 30 J = 1, M CALL DAXPY( N, ONE, U1(1,J), 1, UU(1,J), 1 ) 30 CONTINUE END IF C CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, -ONE, $ DWORK(PW), 2*M, V2, LDV2, DWORK(PDW), $ LDWORK-PDW+1, IERR ) C IF ( LUS ) $ CALL DLACPY( 'All', N, M, V2, LDV2, US(N+1,1), LDUS ) IF ( LUU ) $ CALL DLACPY( 'All', N, M, V2, LDV2, UU(N+1,1), LDUU ) C CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, $ DWORK(PW+M), 2*M, U2, LDU2, DWORK(PDW), $ LDWORK-PDW+1, IERR ) C C Save the base vectors and quick check of their independence. C NRMIN = DLAMCH( 'Overflow' ) TOL = DLAMCH( 'Precision' )*HUNDRD IF ( LUS ) THEN DO 40 J = 1, M CALL DAXPY( N, ONE, U2(1,J), 1, US(N+1,J), 1 ) TEMP = DASUM( 2*M, US(1,J), 1 ) IF ( TEMP.LT.NRMIN ) $ NRMIN = TEMP 40 CONTINUE IF ( NRMIN.LE.MAX( DLANGE( '1', 2*M, M, US, LDUS, DWORK ), $ ONE )*TOL ) $ INFO = 5 END IF IF ( LUU ) THEN DO 50 J = 1, M CALL DAXPY( N, -ONE, U2(1,J), 1, UU(N+1,J), 1 ) TEMP = DASUM( 2*M, UU(1,J), 1 ) IF ( TEMP.LT.NRMIN ) $ NRMIN = TEMP 50 CONTINUE IF ( NRMIN.LE.MAX( DLANGE( '1', 2*M, M, UU, LDUU, DWORK ), $ ONE )*TOL ) $ INFO = 6 END IF C C Quick return of the range vectors. C IF ( LRIC ) THEN IF ( LBAL ) THEN IF ( LUS ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, US, $ LDUS, US(N+1,1), LDUS, IERR ) IF ( LUU ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, UU, $ LDUU, UU(N+1,1), LDUU, IERR ) END IF RETURN END IF C C Orthonormalize obtained bases and apply inverse balancing C transformation. C IF ( LBAL .AND. LBEF ) THEN IF ( LUS ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, US, $ LDUS, US(N+1,1), LDUS, IERR ) IF ( LUU ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, UU, $ LDUU, UU(N+1,1), LDUU, IERR ) END IF C IF ( LUS ) THEN CALL DGEQRF( 2*N, M, US, LDUS, DWORK, DWORK(M+1), LDWORK-M, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) CALL DTRCON( '1', 'Upper', 'NotUnit', M, US, LDUS, RCOND, $ DWORK(M+1), IWORK, IERR ) IF ( RCOND.LE.TOL ) $ INFO = 5 CALL DORGQR( 2*N, M, M, US, LDUS, DWORK, DWORK(M+1), $ LDWORK-M, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) END IF IF ( LUU ) THEN CALL DGEQRF( 2*N, M, UU, LDUU, DWORK, DWORK(M+1), LDWORK-M, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) CALL DTRCON( '1', 'Upper', 'NotUnit', M, UU, LDUU, RCOND, $ DWORK(M+1), IWORK, IERR ) IF ( RCOND.LE.TOL ) $ INFO = 6 CALL DORGQR( 2*N, M, M, UU, LDUU, DWORK, DWORK(M+1), $ LDWORK-M, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) END IF C IF ( LBAL .AND. .NOT.LBEF ) THEN IF ( LUS ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, US, $ LDUS, US(N+1,1), LDUS, IERR ) IF ( LUU ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, UU, $ LDUU, UU(N+1,1), LDUU, IERR ) END IF C ELSE C DO 60 I = 1, 2*N LWORK(I) = .TRUE. 60 CONTINUE C IF ( LUS .AND.( .NOT.LUU ) ) THEN C C Workspace requirements: MAX( 2*N*N + 2*N, 8*N ) C CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, $ U2, LDU2, V1, LDV1, V2, LDV2, US, LDUS, WR, $ WI, M, DWORK, LDWORK, IERR ) IF ( IERR.NE.0 ) $ GO TO 250 C CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, $ US(N+1,N+1), LDUS, G, LDG, DWORK, LDWORK, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ US(1,N+1), LDUS, G, LDG, DWORK, LDWORK, $ IERR ) C DO 70 J = 1, N CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) 70 CONTINUE PDW = 2*N*N+1 C C DW <- -[V1;V2]*W11 C CALL DLACPY( 'All', N, N, V1, LDV1, DWORK, 2*N ) CALL DLACPY( 'All', N, N, V2, LDV2, DWORK(N+1), 2*N ) CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, -ONE, $ US, LDUS, DWORK, 2*N, DWORK(PDW), LDWORK-PDW+1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) C C DW2 <- DW2 + U2*W21 C CALL DLACPY( 'All', N, N, U2, LDU2, US, LDUS ) CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, ONE, $ US(N+1,1), LDUS, US, LDUS, DWORK(PDW), $ LDWORK-PDW+1, IERR ) DO 80 J = 1, N CALL DAXPY( N, ONE, US(1,J), 1, DWORK(N+2*(J-1)*N+1), 1 ) 80 CONTINUE C C US11 <- -U1*W21 - DW1 C CALL DLACPY( 'All', N, N, U1, LDU1, US, LDUS ) CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, -ONE, $ US(N+1,1), LDUS, US, LDUS, DWORK(PDW), $ LDWORK-PDW+1, IERR ) DO 90 J = 1, N CALL DAXPY( N, -ONE, DWORK(2*(J-1)*N+1), 1, US(1,J), 1 ) 90 CONTINUE C C US21 <- DW2 C CALL DLACPY( 'All', N, N, DWORK(N+1), 2*N, US(N+1,1), LDUS ) C CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ US(1,N+1), LDUS, V1, LDV1, DWORK, LDWORK, $ IERR ) CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ US(1,N+1), LDUS, V2, LDV2, DWORK, LDWORK, $ IERR ) CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ US(N+1,N+1), LDUS, U1, LDU1, DWORK, LDWORK, $ IERR ) CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ US(N+1,N+1), LDUS, U2, LDU2, DWORK, LDWORK, $ IERR ) CALL DLACPY( 'All', N, N, V1, LDV1, US(1,N+1), LDUS ) CALL DLACPY( 'All', N, N, V2, LDV2, US(N+1,N+1), LDUS ) DO 100 J = 1, N CALL DAXPY( N, -ONE, U1(1,J), 1, US(1,N+J), 1 ) 100 CONTINUE DO 110 J = 1, N CALL DAXPY( N, -ONE, U2(1,J), 1, US(N+1,N+J), 1 ) 110 CONTINUE C CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, $ S, LDS, G, LDG, US(1,N+1), LDUS, US(N+1,N+1), $ LDUS, WR, WI, M, DWORK, LDWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 4 RETURN END IF CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, US(N+1,N+1), $ LDUS, IERR ) C ELSE IF ( ( .NOT.LUS ).AND.LUU ) THEN C C Workspace requirements: MAX( 2*N*N + 2*N, 8*N ) C CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, $ U2, LDU2, V1, LDV1, V2, LDV2, UU, LDUU, WR, $ WI, M, DWORK, LDWORK, IERR ) IF ( IERR.NE.0 ) $ GO TO 250 CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, $ UU(N+1,N+1), LDUU, G, LDG, DWORK, LDWORK, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ UU(1,N+1), LDUU, G, LDG, DWORK, LDWORK, $ IERR ) DO 120 J = 1, N CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) 120 CONTINUE PDW = 2*N*N+1 C C DW <- -[V1;V2]*W11 C CALL DLACPY( 'All', N, N, V1, LDV1, DWORK, 2*N ) CALL DLACPY( 'All', N, N, V2, LDV2, DWORK(N+1), 2*N ) CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, -ONE, $ UU, LDUU, DWORK, 2*N, DWORK(PDW), LDWORK-PDW+1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) C C DW2 <- DW2 - U2*W21 C CALL DLACPY( 'All', N, N, U2, LDU2, UU, LDUU ) CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, -ONE, $ UU(N+1,1), LDUU, UU, LDUU, DWORK(PDW), $ LDWORK-PDW+1, IERR ) DO 130 J = 1, N CALL DAXPY( N, ONE, UU(1,J), 1, DWORK(N+2*(J-1)*N+1), 1 ) 130 CONTINUE C C UU11 <- U1*W21 - DW1 C CALL DLACPY( 'All', N, N, U1, LDU1, UU, LDUU ) CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, ONE, $ UU(N+1,1), LDUU, UU, LDUU, DWORK(PDW), $ LDWORK-PDW+1, IERR ) DO 140 J = 1, N CALL DAXPY( N, -ONE, DWORK(2*(J-1)*N+1), 1, UU(1,J), 1 ) 140 CONTINUE C C UU21 <- DW2 C CALL DLACPY( 'All', N, N, DWORK(N+1), 2*N, UU(N+1,1), LDUU ) C CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ UU(1,N+1), LDUU, V1, LDV1, DWORK, LDWORK, $ IERR ) CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ UU(1,N+1), LDUU, V2, LDV2, DWORK, LDWORK, $ IERR ) CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ UU(N+1,N+1), LDUU, U1, LDU1, DWORK, LDWORK, $ IERR ) CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ UU(N+1,N+1), LDUU, U2, LDU2, DWORK, LDWORK, $ IERR ) CALL DLACPY( 'All', N, N, V1, LDV1, UU(1,N+1), LDUU ) CALL DLACPY( 'All', N, N, V2, LDV2, UU(N+1,N+1), LDUU ) DO 150 J = 1, N CALL DAXPY( N, ONE, U1(1,J), 1, UU(1,N+J), 1 ) 150 CONTINUE DO 160 J = 1, N CALL DAXPY( N, ONE, U2(1,J), 1, UU(N+1,N+J), 1 ) 160 CONTINUE C CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, $ S, LDS, G, LDG, UU(1,N+1), LDUU, UU(N+1,N+1), $ LDUU, WR, WI, M, DWORK, LDWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 4 RETURN END IF CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, UU(N+1,N+1), $ LDUU, IERR ) ELSE C C Workspace requirements: 8*N C CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, $ U2, LDU2, V1, LDV1, V2, LDV2, US, LDUS, WR, $ WI, M, DWORK, LDWORK, IERR ) IF ( IERR.NE.0 ) $ GO TO 250 CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, $ US(N+1,N+1), LDUS, G, LDG, DWORK, LDWORK, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ US(1,N+1), LDUS, G, LDG, DWORK, LDWORK, $ IERR ) DO 170 J = 1, N CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) 170 CONTINUE C C UU = [ V1 U1; -V2 -U2 ]*diag(W11,W21) C CALL DLACPY( 'All', N, N, V1, LDV1, UU, LDUU ) CALL DLACPY( 'All', N, N, V2, LDV2, UU(N+1,1), LDUU ) CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, ONE, $ US, LDUS, UU, LDUU, DWORK, LDWORK, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) CALL DLACPY( 'All', N, N, U1, LDU1, UU(1,N+1), LDUU ) CALL DLACPY( 'All', N, N, U2, LDU2, UU(N+1,N+1), LDUU ) CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, ONE, $ US(N+1,1), LDUS, UU(1,N+1), LDUU, DWORK, $ LDWORK, IERR ) CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, 2*N, UU(N+1,1), $ LDUU, IERR ) C CALL DLACPY( 'All', 2*N, N, UU, LDUU, US, LDUS ) DO 180 J = 1, N CALL DAXPY( 2*N, -ONE, UU(1,N+J), 1, US(1,J), 1 ) 180 CONTINUE DO 190 J = 1, N CALL DAXPY( 2*N, ONE, UU(1,N+J), 1, UU(1,J), 1 ) 190 CONTINUE C C V1 <- V1*W12-U1*W22 C U1 <- V1*W12+U1*W22 C V2 <- V2*W12-U2*W22 C U2 <- V2*W12+U2*W22 C CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ US(1,N+1), LDUS, V1, LDV1, DWORK, LDWORK, $ IERR ) CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ US(1,N+1), LDUS, V2, LDV2, DWORK, LDWORK, $ IERR ) CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ US(N+1,N+1), LDUS, U1, LDU1, DWORK, LDWORK, $ IERR ) CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, $ US(N+1,N+1), LDUS, U2, LDU2, DWORK, LDWORK, $ IERR ) DO 210 J = 1, N DO 200 I = 1, N TEMP = V1(I,J) V1(I,J) = TEMP - U1(I,J) U1(I,J) = TEMP + U1(I,J) 200 CONTINUE 210 CONTINUE DO 230 J = 1, N DO 220 I = 1, N TEMP = V2(I,J) V2(I,J) = TEMP - U2(I,J) U2(I,J) = TEMP + U2(I,J) 220 CONTINUE 230 CONTINUE C CALL DLASET( 'All', 2*N, N, ZERO, ONE, US(1,N+1), LDUS ) CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, $ S, LDS, G, LDG, US(1,N+1), LDUS, US(N+1,N+1), $ LDUS, WR, WI, M, DWORK, LDWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 4 RETURN END IF CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ U1, LDU1, US(1,N+1), LDUS, ZERO, UU(1,N+1), $ LDUU ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, $ U2, LDU2, US(N+1,N+1), LDUS, ONE, UU(1,N+1), $ LDUU ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, $ U1, LDU1, US(N+1,N+1), LDUS, ZERO, UU(N+1,N+1), $ LDUU ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, $ U2, LDU2, US(1,N+1), LDUS, ONE, UU(N+1,N+1), $ LDUU ) CALL DLACPY( 'All', N, N, US(1,N+1), LDUS, U1, LDU1 ) CALL DLACPY( 'All', N, N, US(N+1,N+1), LDUS, U2, LDU2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ V1, LDV1, U1, LDU1, ZERO, US(1,N+1), LDUS ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, $ V2, LDV2, U2, LDU2, ONE, US(1,N+1), LDUS ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, $ V1, LDV1, U2, LDU2, ZERO, US(N+1,N+1), LDUS ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, $ V2, LDV2, U1, LDU1, ONE, US(N+1,N+1), LDUS ) END IF C C Quick return of the range vectors. C IF ( LRIC ) THEN IF ( LBAL ) THEN IF ( LUS ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, MM, $ US, LDUS, US(N+1,1), LDUS, IERR ) IF ( LUU ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, MM, $ UU, LDUU, UU(N+1,1), LDUU, IERR ) END IF RETURN END IF C C Orthonormalize obtained bases and apply inverse balancing C transformation. C IF ( LBAL .AND. LBEF ) THEN IF ( LUS ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, MM, US, $ LDUS, US(N+1,1), LDUS, IERR ) IF ( LUU ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, MM, UU, $ LDUU, UU(N+1,1), LDUU, IERR ) END IF C C Workspace requirements: 8*N+1 C DO 240 J = 1, 2*N IWORK(J) = 0 240 CONTINUE IF ( LUS ) THEN CALL DGEQP3( 2*N, MM, US, LDUS, IWORK, DWORK, DWORK(2*N+1), $ LDWORK-2*N, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) CALL DORGQR( 2*N, MM, N, US, LDUS, DWORK, DWORK(2*N+1), $ LDWORK-2*N, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) END IF IF ( LUU ) THEN CALL DGEQP3( 2*N, MM, UU, LDUU, IWORK, DWORK, DWORK(2*N+1), $ LDWORK-2*N, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) CALL DORGQR( 2*N, MM, N, UU, LDUU, DWORK, DWORK(2*N+1), $ LDWORK-2*N, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) END IF C IF ( LBAL .AND. .NOT.LBEF ) THEN IF ( LUS ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, US, $ LDUS, US(N+1,1), LDUS, IERR ) IF ( LUU ) $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, UU, $ LDUU, UU(N+1,1), LDUU, IERR ) END IF END IF C CALL DSCAL( M, -ONE, WR, 1 ) DWORK(1) = DBLE( WRKOPT ) C RETURN 250 CONTINUE IF ( IERR.EQ.1 ) THEN INFO = 2 ELSE IF ( IERR.EQ.2 .OR. IERR.EQ.4 ) THEN INFO = 1 ELSE IF ( IERR.EQ.3 ) THEN INFO = 3 END IF RETURN C *** Last line of MB03ZD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03ND.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03ND.f0000644000175000017500000001532415012430707017361 0ustar00lilgelilge00000000000000 INTEGER FUNCTION MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) C C PURPOSE C C To find the number of singular values of the bidiagonal matrix C C |q(1) e(1) . ... 0 | C | 0 q(2) e(2) . | C J = | . . | C | . e(N-1)| C | 0 ... ... 0 q(N) | C C which are less than or equal to a given bound THETA. C C This routine is intended to be called only by other SLICOT C routines. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the bidiagonal matrix J. N >= 0. C C THETA (input) DOUBLE PRECISION C Given bound. C Note: If THETA < 0.0 on entry, then MB03ND is set to 0 C as the singular values of J are non-negative. C C Q2 (input) DOUBLE PRECISION array, dimension (N) C This array must contain the squares of the diagonal C elements q(1),q(2),...,q(N) of the bidiagonal matrix J. C That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N. C C E2 (input) DOUBLE PRECISION array, dimension (N-1) C This array must contain the squares of the superdiagonal C elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J. C That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1. C C PIVMIN (input) DOUBLE PRECISION C The minimum absolute value of a "pivot" in the Sturm C sequence loop. C PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ), C where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at C least the smallest number that can divide one without C overflow (see LAPACK Library routine DLAMCH). C Note that this condition is not checked by the routine. 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 computation of the number of singular values s(i) of J which C are less than or equal to THETA is based on applying Sylvester's C Law of Inertia, or equivalently, Sturm sequences [1,p.52] to the C unreduced symmetric tridiagonal matrices associated with J as C follows. Let T be the following 2N-by-2N symmetric matrix C associated with J: C C | 0 J'| C T = | |. C | J 0 | C C (The eigenvalues of T are given by s(1),s(2),...,s(N),-s(1),-s(2), C ...,-s(N)). Then, by permuting the rows and columns of T into the C order 1, N+1, 2, N+2, ..., N, 2N it follows that T is orthogonally C similar to the tridiagonal matrix T" with zeros on its diagonal C and q(1), e(1), q(2), e(2), ..., e(N-1), q(N) on its offdiagonals C [3,4]. If q(1),q(2),...,q(N) and e(1),e(2),...,e(N-1) are nonzero, C Sylvester's Law of Inertia may be applied directly to T". C Otherwise, T" is block diagonal and each diagonal block (which is C then unreduced) must be analysed separately by applying C Sylvester's Law of Inertia. C C REFERENCES C C [1] Parlett, B.N. C The Symmetric Eigenvalue Problem. C Prentice Hall, Englewood Cliffs, New Jersey, 1980. C C [2] Demmel, J. and Kahan, W. C Computing Small Singular Values of Bidiagonal Matrices with C Guaranteed High Relative Accuracy. C Technical Report, Courant Inst., New York, March 1988. C C [3] Van Huffel, S. and Vandewalle, J. C The Partial Total Least-Squares Algorithm. C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. C C [4] Golub, G.H. and Kahan, W. C Calculating the Singular Values and Pseudo-inverse of a C Matrix. C SIAM J. Numer. Anal., Ser. B, 2, pp. 205-224, 1965. C C [5] Demmel, J.W., Dhillon, I. and Ren, H. C On the Correctness of Parallel Bisection in Floating Point. C Computer Science Division Technical Report UCB//CSD-94-805, C University of California, Berkeley, CA 94720, March 1994. C C NUMERICAL ASPECTS C C The singular values s(i) could also be obtained with the use of C the symmetric tridiagonal matrix T = J'J, whose eigenvalues are C the squared singular values of J [4,p.213]. However, the method C actually used by the routine is more accurate and equally C efficient (see [2]). C C To avoid overflow, matrix J should be scaled so that its largest C element is no greater than overflow**(1/2) * underflow**(1/4) C in absolute value (and not much smaller than that, for maximal C accuracy). C C With respect to accuracy the following condition holds (see [2]): C C If the established value is denoted by p, then at least p C singular values of J are less than or equal to C THETA/(1 - (3 x N - 1.5) x EPS) and no more than p singular values C are less than or equal to C THETA x (1 - (6 x N-2) x EPS)/(1 - (3 x N - 1.5) x EPS). C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. C Supersedes Release 2.0 routine MB03BD by S. Van Huffel, Katholieke C University, Leuven, Belgium. C C REVISIONS C C July 10, 1997. C C KEYWORDS C C Bidiagonal matrix, singular values. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER INFO, N DOUBLE PRECISION PIVMIN, THETA C .. Array Arguments .. DOUBLE PRECISION E2(*), Q2(*) C .. Local Scalars .. INTEGER J, NUMEIG DOUBLE PRECISION R, T C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC ABS C .. Executable Statements .. C C Test the input scalar arguments. PIVMIN is not checked. C INFO = 0 IF( N.LT.0 ) THEN INFO = -1 C C Error return. C CALL XERBLA( 'MB03ND', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. THETA.LT.ZERO ) THEN MB03ND = 0 RETURN END IF C NUMEIG = N T = -THETA R = T IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN C DO 20 J = 1, N - 1 R = T - Q2(J)/R IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 R = T - E2(J)/R IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 20 CONTINUE C R = T - Q2(N)/R IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 MB03ND = NUMEIG C RETURN C *** Last line of MB03ND *** END control-4.1.2/src/slicot/src/PaxHeaders/FB01QD.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/FB01QD.f0000644000175000017500000004101415012430707017346 0ustar00lilgelilge00000000000000 SUBROUTINE FB01QD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B, $ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL, $ IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To calculate a combined measurement and time update of one C iteration of the time-varying Kalman filter. This update is given C for the square root covariance filter, using dense matrices. C C ARGUMENTS C C Mode Parameters C C JOBK CHARACTER*1 C Indicates whether the user wishes to compute the Kalman C filter gain matrix K as follows: C i C = 'K': K is computed and stored in array K; C i C = 'N': K is not required. C i C C MULTBQ CHARACTER*1 1/2 C Indicates how matrices B and Q are to be passed to C i i C the routine as follows: C = 'P': Array Q is not used and the array B must contain C 1/2 C the product B Q ; C i i C = 'N': Arrays B and Q must contain the matrices as C described below. C C Input/Output Parameters C C N (input) INTEGER C The actual state dimension, i.e., the order of the C matrices S and A . N >= 0. C i-1 i C C M (input) INTEGER C The actual input dimension, i.e., the order of the matrix C 1/2 C Q . M >= 0. C i C C P (input) INTEGER C The actual output dimension, i.e., the order of the matrix C 1/2 C R . P >= 0. C i C C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) C On entry, the leading N-by-N lower triangular part of this C array must contain S , the square root (left Cholesky C i-1 C factor) of the state covariance matrix at instant (i-1). C On exit, the leading N-by-N lower triangular part of this C array contains S , the square root (left Cholesky factor) C i C of the state covariance matrix at instant i. C The strict upper triangular part of this array is not C referenced. C C LDS INTEGER C The leading dimension of array S. LDS >= MAX(1,N). C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must contain A , C i C the state transition matrix of the discrete system at C instant i. 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 B , C 1/2 i C the input weight matrix (or the product B Q if C i i C MULTBQ = 'P') of the discrete system at instant i. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C Q (input) DOUBLE PRECISION array, dimension (LDQ,*) C If MULTBQ = 'N', then the leading M-by-M lower triangular C 1/2 C part of this array must contain Q , the square root C i C (left Cholesky factor) of the input (process) noise C covariance matrix at instant i. C The strict upper triangular part of this array is not C referenced. C If MULTBQ = 'P', Q is not referenced and can be supplied C as a dummy array (i.e., set parameter LDQ = 1 and declare C this array to be Q(1,1) in the calling program). C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= MAX(1,M) if MULTBQ = 'N'; C LDQ >= 1 if MULTBQ = 'P'. C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C The leading P-by-N part of this array must contain C , the C i C output weight matrix of the discrete system at instant i. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C R (input/output) DOUBLE PRECISION array, dimension (LDR,P) C On entry, the leading P-by-P lower triangular part of this C 1/2 C array must contain R , the square root (left Cholesky C i C factor) of the output (measurement) noise covariance C matrix at instant i. C On exit, the leading P-by-P lower triangular part of this C 1/2 C array contains (RINOV ) , the square root (left Cholesky C i C factor) of the covariance matrix of the innovations at C instant i. C The strict upper triangular part of this array is not C referenced. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,P). C C K (output) DOUBLE PRECISION array, dimension (LDK,P) C If JOBK = 'K', and INFO = 0, then the leading N-by-P part C of this array contains K , the Kalman filter gain matrix C i C at instant i. C If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the C leading N-by-P part of this array contains AK , a matrix C i C related to the Kalman filter gain matrix at instant i (see C -1/2 C METHOD). Specifically, AK = A P C'(RINOV') . C i i i|i-1 i i C C LDK INTEGER C The leading dimension of array K. LDK >= MAX(1,N). C C Tolerances C C TOL DOUBLE PRECISION C If JOBK = 'K', then TOL is used to test for near C 1/2 C singularity of the matrix (RINOV ) . If the user sets C i C TOL > 0, then the given value of TOL is used as a C lower bound for the reciprocal condition number of that C matrix; a matrix whose estimated condition number is less C than 1/TOL is considered to be nonsingular. If the user C sets TOL <= 0, then an implicitly computed, default C tolerance, defined by TOLDEF = P*P*EPS, is used instead, C where EPS is the machine precision (see LAPACK Library C routine DLAMCH). C Otherwise, TOL is not referenced. C C Workspace C C IWORK INTEGER array, dimension (LIWORK), C where LIWORK = P if JOBK = 'K', C and LIWORK = 1 otherwise. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK. If INFO = 0 and JOBK = 'K', DWORK(2) returns C an estimate of the reciprocal of the condition number C 1/2 C (in the 1-norm) of (RINOV ) . C i C C LDWORK The length of the array DWORK. C LDWORK >= MAX(1,N*(P+N)+2*P,N*(N+M+2)), if JOBK = 'N'; C LDWORK >= MAX(2,N*(P+N)+2*P,N*(N+M+2),3*P), if JOBK = 'K'. 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/2 C = 1: if JOBK = 'K' and the matrix (RINOV ) is singular, C i 1/2 C i.e., the condition number estimate of (RINOV ) C i C (in the 1-norm) exceeds 1/TOL. The matrices S, AK , C 1/2 i C and (RINOV ) have been computed. C i C C METHOD C C The routine performs one recursion of the square root covariance C filter algorithm, summarized as follows: C C | 1/2 | | 1/2 | C | R C x S 0 | | (RINOV ) 0 0 | C | i i i-1 | | i | C | 1/2 | T = | | C | 0 A x S B x Q | | AK S 0 | C | i i-1 i i | | i i | C C (Pre-array) (Post-array) C C where T is an orthogonal transformation triangularizing the C pre-array. C C The state covariance matrix P is factorized as C i|i-1 C P = S S' C i|i-1 i i C C and one combined time and measurement update for the state X C i|i-1 C is given by C C X = A X + K (Y - C X ), C i+1|i i i|i-1 i i i i|i-1 C C -1/2 C where K = AK (RINOV ) is the Kalman filter gain matrix and Y C i i i i C is the observed output of the system. C C The triangularization is done entirely via Householder C transformations exploiting the zero pattern of the pre-array. C C REFERENCES C C [1] Anderson, B.D.O. and Moore, J.B. C Optimal Filtering. C Prentice Hall, Englewood Cliffs, New Jersey, 1979. C C [2] Verhaegen, M.H.G. and Van Dooren, P. C Numerical Aspects of Different Kalman Filter Implementations. C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. C C [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. C Algorithm 675: FORTRAN Subroutines for Computing the Square C Root Covariance Filter and Square Root Information Filter in C Dense or Hessenberg Forms. C ACM Trans. Math. Software, 15, pp. 243-256, 1989. C C NUMERICAL ASPECTS C C The algorithm requires C C 3 2 2 2 C (7/6)N + N x (5/2 x P + M) + N x (1/2 x M + P ) C C operations and is backward stable (see [2]). C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C Supersedes Release 2.0 routine FB01ED by M. Vanbegin, C P. Van Dooren, and M.H.G. Verhaegen. C C REVISIONS C C February 20, 1998, November 20, 2003. C C KEYWORDS C C Kalman filtering, optimal filtering, orthogonal transformation, C recursive estimation, square-root covariance filtering, C square-root filtering. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER JOBK, MULTBQ INTEGER INFO, LDA, LDB, LDC, LDK, LDQ, LDR, LDS, LDWORK, $ M, N, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), $ K(LDK,*), Q(LDQ,*), R(LDR,*), S(LDS,*) C .. Local Scalars .. LOGICAL LJOBK, LMULTB INTEGER I12, ITAU, JWORK, N1, PN, WRKOPT DOUBLE PRECISION RCOND C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGELQF, DLACPY, DTRMM, MB02OD, MB04LD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C PN = P + N N1 = MAX( 1, N ) INFO = 0 LJOBK = LSAME( JOBK, 'K' ) LMULTB = LSAME( MULTBQ, 'P' ) C C Test the input scalar arguments. C IF( .NOT.LJOBK .AND. .NOT.LSAME( JOBK, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LMULTB .AND. .NOT.LSAME( MULTBQ, 'N' ) ) 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( LDS.LT.N1 ) THEN INFO = -7 ELSE IF( LDA.LT.N1 ) THEN INFO = -9 ELSE IF( LDB.LT.N1 ) THEN INFO = -11 ELSE IF( LDQ.LT.1 .OR. ( .NOT.LMULTB .AND. LDQ.LT.M ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDR.LT.MAX( 1, P ) ) THEN INFO = -17 ELSE IF( LDK.LT.N1 ) THEN INFO = -19 ELSE IF( ( LJOBK .AND. LDWORK.LT.MAX( 2, PN*N + 2*P, $ N*(N + M + 2), 3*P ) ) .OR. $ ( .NOT.LJOBK .AND. LDWORK.LT.MAX( 1, PN*N + 2*P, $ N*(N + M + 2) ) ) ) THEN INFO = -23 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'FB01QD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN IF ( LJOBK ) THEN DWORK(1) = TWO DWORK(2) = ONE ELSE DWORK(1) = ONE END IF RETURN END IF C C Construction of the needed part of the pre-array in DWORK. C To save workspace, only the blocks (1,2), (2,2), and (2,3) will be C constructed as shown below. C C Storing A x S and C x S in the (1,1) and (2,1) blocks of DWORK, C respectively. C Workspace: need (N+P)*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, 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 DLACPY( 'Full', N, N, A, LDA, DWORK, PN ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK(N+1), PN ) CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', PN, N, $ ONE, S, LDS, DWORK, PN ) C C Triangularization (2 steps). C C Step 1: annihilate the matrix C x S. C Workspace: need (N+P)*N + 2*P. C ITAU = PN*N + 1 JWORK = ITAU + P C CALL MB04LD( 'Full', P, N, N, R, LDR, DWORK(N+1), PN, DWORK, PN, $ K, LDK, DWORK(ITAU), DWORK(JWORK) ) WRKOPT = PN*N + 2*P C C Now, the workspace for C x S is no longer needed. C Adjust the leading dimension of DWORK, to save space for the C following computations. C CALL DLACPY( 'Full', N, N, DWORK, PN, DWORK, N ) I12 = N*N + 1 C C Storing B x Q in the (1,2) block of DWORK. C Workspace: need N*(N+M). C CALL DLACPY( 'Full', N, M, B, LDB, DWORK(I12), N ) IF ( .NOT.LMULTB ) $ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', N, M, $ ONE, Q, LDQ, DWORK(I12), N ) WRKOPT = MAX( WRKOPT, N*( N + M ) ) C C Step 2: LQ triangularization of the matrix [ A x S B x Q ], where C A x S was modified at Step 1. C Workspace: need N*(N+M+2); prefer N*(N+M+1)+N*NB. C ITAU = N*( N + M ) + 1 JWORK = ITAU + N C CALL DGELQF( N, N+M, DWORK, N, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Output S and K (if needed) and set the optimal workspace C dimension (and the reciprocal of the condition number estimate). C CALL DLACPY( 'Lower', N, N, DWORK, N, S, LDS ) C IF ( LJOBK ) THEN C C Compute K. C Workspace: need 3*P. C CALL MB02OD( 'Right', 'Lower', 'No transpose', 'Non-unit', $ '1-norm', N, P, ONE, R, LDR, K, LDK, RCOND, TOL, $ IWORK, DWORK, INFO ) IF ( INFO.EQ.0 ) THEN WRKOPT = MAX( WRKOPT, 3*P ) DWORK(2) = RCOND END IF END IF C DWORK(1) = WRKOPT C RETURN C *** Last line of FB01QD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01UD.f0000644000000000000000000000013215012430707016165 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01UD.f0000644000175000017500000001537315012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE MB01UD( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, B, $ LDB, INFO ) 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 PARAMETER ( ZERO = 0.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 control-4.1.2/src/slicot/src/PaxHeaders/MB01RU.f0000644000000000000000000000013215012430707016203 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01RU.f0000644000175000017500000002150015012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE MB01RU( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, $ X, LDX, DWORK, LDWORK, INFO ) 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. When R is identified with X in C the call, after exit, the diagonal entries of R must be C divided by 2. 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 M x N + 1/2 x N 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 Sep. 2013, Dec. 2013. 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 control-4.1.2/src/slicot/src/PaxHeaders/MA02HZ.f0000644000000000000000000000013215012430707016176 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02HZ.f0000644000175000017500000001022415012430707017371 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION MA02HZ( JOB, M, N, DIAG, A, LDA ) C C PURPOSE C C To check if A = DIAG*I, where I is an M-by-N matrix with ones on C the diagonal and zeros elsewhere, A is a complex matrix and DIAG C is a complex scalar. C C FUNCTION VALUE C C MA02HZ LOGICAL C The function value is set to .TRUE. if A = DIAG*I, and to C .FALSE., otherwise. If min(M,N) = 0, the value is .FALSE. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the part of the matrix A to be checked out, C as follows: C = 'U': Upper triangular/trapezoidal part; C = 'L': Lower triangular/trapezoidal part. C Otherwise: All of the matrix A. 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 DIAG (input) COMPLEX*16 C The scalar DIAG. C C A (input) COMPLEX*16 array, dimension (LDA,N) C The leading M-by-N part of this array must contain the C matrix A. If JOB = 'U', only the upper triangle or C trapezoid is accessed; if JOB = 'L', only the lower C triangle or trapezoid is accessed. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C METHOD C C The routine returns immediately after detecting a diagonal element C which differs from DIAG, or a nonzero off-diagonal element in the C searched part of A. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2015. C C REVISIONS C C V. Sima, Jan. 2016. C C KEYWORDS C C Elementary operations. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. CHARACTER JOB INTEGER LDA, M, N COMPLEX*16 DIAG C .. Array Arguments .. COMPLEX*16 A(LDA,*) C .. Local Scalars .. INTEGER I, J C .. External Functions LOGICAL LSAME EXTERNAL LSAME C .. Intrinsic Functions .. INTRINSIC MIN C C .. Executable Statements .. C C Do not check parameters, for efficiency. C Quick return if possible. C IF( MIN( M, N ).EQ.0 ) THEN MA02HZ = .FALSE. RETURN END IF C IF( LSAME( JOB, 'U' ) ) THEN C DO 20 J = 1, N C DO 10 I = 1, MIN( J-1, M ) IF( A(I,J).NE.ZERO ) THEN MA02HZ = .FALSE. RETURN END IF 10 CONTINUE C IF( J.LE.M ) THEN IF( A(J,J).NE.DIAG ) THEN MA02HZ = .FALSE. RETURN END IF END IF 20 CONTINUE C ELSE IF( LSAME( JOB, 'L' ) ) THEN C DO 40 J = 1, MIN( M, N ) IF( A(J,J).NE.DIAG ) THEN MA02HZ = .FALSE. RETURN END IF C IF( J.LT.M ) THEN C DO 30 I = J+1, M IF( A(I,J).NE.ZERO ) THEN MA02HZ = .FALSE. RETURN END IF 30 CONTINUE C END IF 40 CONTINUE C ELSE C DO 70 J = 1, N C DO 50 I = 1, MIN( J-1, M ) IF( A(I,J).NE.ZERO ) THEN MA02HZ = .FALSE. RETURN END IF 50 CONTINUE C IF( J.LE.M ) THEN IF( A(J,J).NE.DIAG ) THEN MA02HZ = .FALSE. RETURN END IF END IF C IF ( J.LT.M ) THEN C DO 60 I = J+1, M IF( A(I,J).NE.ZERO ) THEN MA02HZ = .FALSE. RETURN END IF 60 CONTINUE C END IF 70 CONTINUE C END IF C MA02HZ = .TRUE. C RETURN C *** Last line of MA02HZ *** END control-4.1.2/src/slicot/src/PaxHeaders/BD01AD.f0000644000000000000000000000013215012430707016130 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/BD01AD.f0000644000175000017500000010307015012430707017325 0ustar00lilgelilge00000000000000 SUBROUTINE BD01AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, 1 LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK, 2 LDWORK, INFO ) C C PURPOSE C C To generate benchmark examples for time-invariant, C continuous-time dynamical systems C C . C E x(t) = A x(t) + B u(t) C C y(t) = C x(t) + D u(t) C C E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and C D is P-by-M. In many examples, E is the identity matrix and D is C the zero matrix. C C This routine is an implementation of the benchmark library C CTDSX (Version 1.0) described in [1]. C C ARGUMENTS C C Mode Parameters C C DEF CHARACTER*1 C Specifies the kind of values used as parameters when C generating parameter-dependent and scalable examples C (i.e., examples with NR(1) = 2, 3, or 4): C = 'D': Default values defined in [1] are used; C = 'N': Values set in DPAR and IPAR are used. C This parameter is not referenced if NR(1) = 1. C Note that the scaling parameter of examples with C NR(1) = 3 or 4 is considered as a regular parameter in C this context. C C Input/Output Parameters C C NR (input) INTEGER array, dimension (2) C Specifies the index of the desired example according C to [1]. C NR(1) defines the group: C 1 : parameter-free problems of fixed size C 2 : parameter-dependent problems of fixed size C 3 : parameter-free problems of scalable size C 4 : parameter-dependent problems of scalable size C NR(2) defines the number of the benchmark example C within a certain group according to [1]. C C DPAR (input/output) DOUBLE PRECISION array, dimension (7) C On entry, if DEF = 'N' and the desired example depends on C real parameters, then the array DPAR must contain the C values for these parameters. C For an explanation of the parameters see [1]. C For Examples 2.1 and 2.2, DPAR(1) defines the parameter C 'epsilon'. C For Example 2.4, DPAR(1), ..., DPAR(7) define 'b', 'mu', C 'r', 'r_c', 'k_l', 'sigma', 'a', respectively. C For Example 2.7, DPAR(1) and DPAR(2) define 'mu' and 'nu', C respectively. C For Example 4.1, DPAR(1), ..., DPAR(7) define 'a', 'b', C 'c', 'beta_1', 'beta_2', 'gamma_1', 'gamma_2', C respectively. C For Example 4.2, DPAR(1), ..., DPAR(3) define 'mu', C 'delta', 'kappa', respectively. C On exit, if DEF = 'D' and the desired example depends on C real parameters, then the array DPAR is overwritten by the C default values given in [1]. C C IPAR (input/output) INTEGER array, dimension (1) C On entry, if DEF = 'N' and the desired example depends on C integer parameters, then the array IPAR must contain the C values for these parameters. C For an explanation of the parameters see [1]. C For Examples 2.3, 2.5, and 2.6, IPAR(1) defines the C parameter 's'. C For Example 3.1, IPAR(1) defines 'q'. C For Examples 3.2 and 3.3, IPAR(1) defines 'n'. C For Example 3.4, IPAR(1) defines 'l'. C For Example 4.1, IPAR(1) defines 'n'. C For Example 4.2, IPAR(1) defines 'l'. C On exit, if DEF = 'D' and the desired example depends on C integer parameters, then the array IPAR is overwritten by C the default values given in [1]. C C VEC (output) LOGICAL array, dimension (8) C Flag vector which displays the availabilty of the output C data: C VEC(1), ..., VEC(3) refer to N, M, and P, respectively, C and are always .TRUE.. C VEC(4) is .TRUE. iff E is NOT the identity matrix. C VEC(5), ..., VEC(7) refer to A, B, and C, respectively, C and are always .TRUE.. C VEC(8) is .TRUE. iff D is NOT the zero matrix. C C N (output) INTEGER C The actual state dimension, i.e., the order of the C matrices E and A. C C M (output) INTEGER C The number of columns in the matrices B and D. C C P (output) INTEGER C The number of rows in the matrices C and D. C C E (output) DOUBLE PRECISION array, dimension (LDE,N) C The leading N-by-N part of this array contains the C matrix E. C NOTE that this array is overwritten (by the identity C matrix), if VEC(4) = .FALSE.. C C LDE INTEGER C The leading dimension of array E. LDE >= N. C C A (output) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array contains the C matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= N. C C B (output) DOUBLE PRECISION array, dimension (LDB,M) C The leading N-by-M part of this array contains the C matrix B. C C LDB INTEGER C The leading dimension of array B. LDB >= N. C C C (output) DOUBLE PRECISION array, dimension (LDC,N) C The leading P-by-N part of this array contains the C matrix C. C C LDC INTEGER C The leading dimension of array C. LDC >= P. C C D (output) DOUBLE PRECISION array, dimension (LDD,M) C The leading P-by-M part of this array contains the C matrix D. C NOTE that this array is overwritten (by the zero C matrix), if VEC(8) = .FALSE.. C C LDD INTEGER C The leading dimension of array D. LDD >= P. C C NOTE (output) CHARACTER*70 C String containing short information about the chosen C example. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C For Example 3.4, LDWORK >= 4*IPAR(1) is required. C For the other examples, no workspace is needed, i.e., C LDWORK >= 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; in particular, INFO = -3 or -4 indicates C that at least one of the parameters in DPAR or C IPAR, respectively, has an illegal value; C = 1: data file can not be opened or has wrong format. C C C REFERENCES C C [1] Kressner, D., Mehrmann, V. and Penzl, T. C CTDSX - a Collection of Benchmark Examples for State-Space C Realizations of Continuous-Time Dynamical Systems. C SLICOT Working Note 1998-9. 1998. C C NUMERICAL ASPECTS C C None C C CONTRIBUTOR C C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) C C For questions concerning the collection or for the submission of C test examples, please contact Volker Mehrmann C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). C C REVISIONS C C June 1999, V. Sima. C C KEYWORDS C C continuous-time dynamical systems C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 1 THREE = 3.0D0, FOUR = 4.0D0, 2 PI = .3141592653589793D1 ) C .. Scalar Arguments .. CHARACTER DEF CHARACTER*70 NOTE INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, P C .. Array Arguments .. LOGICAL VEC(8) INTEGER IPAR(*), NR(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DPAR(*), 1 DWORK(*), E(LDE,*) C .. Local Scalars .. CHARACTER*12 DATAF INTEGER I, J, L, STATUS DOUBLE PRECISION APPIND, B1, B2, C1, C2, TEMP, TTEMP C .. Local Arrays .. LOGICAL VECDEF(8) C .. External Functions .. C . LAPACK . LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. C . BLAS . EXTERNAL DSCAL C . LAPACK . EXTERNAL DLASET C .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD C .. Data Statements .. C . default values for availabities . DATA VECDEF /.TRUE., .TRUE., .TRUE., .FALSE., 1 .TRUE., .TRUE., .TRUE., .FALSE./ C C .. Executable Statements .. C INFO = 0 DO 10 I = 1, 8 VEC(I) = VECDEF(I) 10 CONTINUE C IF (NR(1) .EQ. 1) THEN C IF (NR(2) .EQ. 1) THEN NOTE = 'Laub 1979, Ex.1' N = 2 M = 1 P = 2 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) A(1,2) = ONE B(1,1) = ZERO B(2,1) = ONE CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 2) THEN NOTE = 'Laub 1979, Ex.2: uncontrollable-unobservable data' N = 2 M = 1 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) A(1,1) = FOUR A(2,1) = -.45D1 A(1,2) = .3D1 A(2,2) = -.35D1 B(1,1) = ONE B(2,1) = -ONE C(1,1) = THREE C(1,2) = TWO CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 3) THEN NOTE = 'Beale/Shafai 1989: model of L-1011 aircraft' N = 4 M = 2 P = 4 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 4) THEN NOTE = 'Bhattacharyya et al. 1983: binary distillation column' N = 8 M = 2 P = 8 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 5) THEN NOTE = 'Patnaik et al. 1980: tubular ammonia reactor' N = 9 M = 3 P = 9 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 6) THEN NOTE = 'Davison/Gesing 1978: J-100 jet engine' N = 30 M = 3 P = 5 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 7) THEN NOTE = 'Davison 1967: binary distillation column' N = 11 M = 3 P = 3 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) C(2,1) = ONE C(1,10) = ONE C(3,11) = ONE CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) ELSE IF (NR(2) .EQ. 8) THEN NOTE = 'Chien/Ergin/Ling/Lee 1958: drum boiler' N = 9 M = 3 P = 2 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) C(1,6) = ONE C(2,9) = ONE CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 9) THEN NOTE = 'Ly, Gangsaas 1981: B-767 airplane' N = 55 M = 2 P = 2 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 10) THEN NOTE = 'control surface servo for an underwater vehicle' N = 8 M = 2 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) C(1,7) = ONE CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) ELSE INFO = -2 END IF C IF ((NR(2) .GE. 3) .AND. (NR(2) .LE. 10)) THEN C .. loading data files WRITE (DATAF(1:11), '(A,I2.2,A)') 'BD011', NR(2), '.dat' OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:11)) IF (STATUS .NE. 0) THEN INFO = 1 ELSE DO 110 I = 1, N READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) IF (STATUS .NE. 0) INFO = 1 110 CONTINUE DO 120 I = 1, N READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) IF (STATUS .NE. 0) INFO = 1 120 CONTINUE IF ((NR(2) .EQ. 6) .OR. (NR(2) .EQ. 9)) THEN DO 130 I = 1, P READ (1, FMT = *, IOSTAT = STATUS) (C(I,J), J = 1, N) IF (STATUS .NE. 0) INFO = 1 130 CONTINUE END IF END IF CLOSE(1) END IF C ELSE IF (NR(1) .EQ. 2) THEN IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN INFO = -1 RETURN END IF C IF (NR(2) .EQ. 1) THEN NOTE = 'Chow/Kokotovic 1976: magnetic tape control system' IF (LSAME(DEF,'D')) DPAR(1) = 1D-6 IF (DPAR(1) .EQ. ZERO) INFO = -3 N = 4 M = 1 P = 2 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) A(1,2) = .400D0 A(2,3) = .345D0 A(3,2) = -.524D0/DPAR(1) A(3,3) = -.465D0/DPAR(1) A(3,4) = .262D0/DPAR(1) A(4,4) = -ONE/DPAR(1) CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) B(4,1) = ONE/DPAR(1) CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) C(1,1) = ONE C(2,3) = ONE CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 2) THEN NOTE = 'Arnold/Laub 1984' IF (LSAME(DEF,'D')) DPAR(1) = 1D-6 N = 4 M = 1 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) A(1,1) = -DPAR(1) A(2,1) = -ONE A(1,2) = ONE A(2,2) = -DPAR(1) A(4,3) = -ONE A(3,4) = ONE CALL DLASET('A', N, M, ONE, ONE, B, LDB) CALL DLASET('A', P, N, ONE, ONE, C, LDC) D(1,1) = ZERO C ELSE IF (NR(2) .EQ. 3) THEN NOTE = 'Vertical acceleration of a rigid guided missile' IF (LSAME(DEF,'D')) IPAR(1) = 1 IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 10)) INFO = -4 N = 3 M = 1 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) A(2,1) = ONE A(3,3) = -.19D3 CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) B(3,1) = .19D3 D(1,1) = ZERO OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01203.dat') IF (STATUS .NE. 0) THEN INFO = 1 ELSE DO 210 I = 1, IPAR(1) READ (1, FMT = *, IOSTAT = STATUS) (A(1,J), J = 1, N) IF (STATUS .NE. 0) INFO = 1 READ (1, FMT = *, IOSTAT = STATUS) (A(2,J), J = 2, N) IF (STATUS .NE. 0) INFO = 1 READ (1, FMT = *, IOSTAT = STATUS) (C(1,J), J = 1, N) IF (STATUS .NE. 0) INFO = 1 210 CONTINUE END IF CLOSE(1) C ELSE IF (NR(2) .EQ. 4) THEN NOTE = 'Senning 1980: hydraulic positioning system' IF (LSAME(DEF,'D')) THEN DPAR(1) = .14D5 DPAR(2) = .1287D0 DPAR(3) = .15D0 DPAR(4) = .1D-1 DPAR(5) = .2D-2 DPAR(6) = .24D0 DPAR(7) = .1075D2 END IF IF (((DPAR(1) .LE. .9D4) .OR. (DPAR(1) .GE. .16D5)) .OR. 1 ((DPAR(2) .LE. .5D-1) .OR. (DPAR(2) .GE. .3D0)) .OR. 2 ((DPAR(3) .LE. .5D-1) .OR. (DPAR(3) .GE. .5D1)) .OR. 3 ((DPAR(4) .LE. ZERO) .OR. (DPAR(4) .GE. .5D-1)) .OR. 4 ((DPAR(5) .LE. .103D-3) .OR. (DPAR(5) .GE. .35D-2)) .OR. 5 ((DPAR(6) .LE. .1D-2) .OR. (DPAR(6) .GE. .15D2)) .OR. 6 ((DPAR(7) .LE. .105D2) .OR. (DPAR(7) .GE. .111D2))) THEN INFO = -3 END IF N = 3 M = 1 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) A(1,2) = ONE A(2,2) = -(DPAR(3) + FOUR*DPAR(4)/PI) / DPAR(2) A(2,3) = DPAR(7) / DPAR(2) A(3,2) = -FOUR * DPAR(7) * DPAR(1) / .874D3 A(3,3) = -FOUR * DPAR(1) * (DPAR(6) + DPAR(5)) / .874D3 CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) B(3,1) = -FOUR * DPAR(1) / .874D3 CALL DLASET('A', P, N, ZERO, ONE, C, LDC) D(1,1) = 0 C ELSE IF (NR(2) .EQ. 5) THEN NOTE = 'Kwakernaak/Westdyk 1985: cascade of inverted pendula' IF (LSAME(DEF,'D')) IPAR(1) = 1 IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 7)) INFO = -4 IF (IPAR(1) .LE. 6) THEN M = IPAR(1) ELSE M = 10 END IF N = 2 * M P = M IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) WRITE (DATAF(1:12), '(A,I1,A)') 'BD01205', IPAR(1), '.dat' OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:12)) IF (STATUS .NE. 0) THEN INFO = 1 ELSE DO 220 I = 1, N READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) IF (STATUS .NE. 0) INFO = 1 220 CONTINUE DO 230 I = 1, N READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) IF (STATUS .NE. 0) INFO = 1 230 CONTINUE DO 240 I = 1, P READ (1, FMT = *, IOSTAT = STATUS) (C(I,J), J = 1, N) IF (STATUS .NE. 0) INFO = 1 240 CONTINUE END IF CLOSE(1) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 6) THEN NOTE = 'Kallstrom/Astrom 1981: regulation of a ship heading' IF (LSAME(DEF,'D')) IPAR(1) = 1 IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 5)) INFO = -4 N = 3 M = 1 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) A(3,2) = ONE B(3,1) = ZERO CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) C(1,3) = ONE D(1,1) = ZERO OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01206.dat') IF (STATUS .NE. 0) THEN INFO = 1 ELSE DO 250 I = 1, IPAR(1) READ (1, FMT = *, IOSTAT = STATUS) (A(1,J), J = 1, 2) IF (STATUS .NE. 0) INFO = 1 READ (1, FMT = *, IOSTAT = STATUS) (A(2,J), J = 1, 2) IF (STATUS .NE. 0) INFO = 1 READ (1, FMT = *, IOSTAT = STATUS) (B(J,1), J = 1, 2) IF (STATUS .NE. 0) INFO = 1 250 CONTINUE END IF CLOSE(1) C ELSE IF (NR(2) .EQ. 7) THEN NOTE = 'Ackermann 1989: track-guided bus' IF (LSAME(DEF,'D')) THEN DPAR(1) = .15D2 DPAR(2) = .1D2 END IF IF ((DPAR(1) .LT. .995D1) .OR. (DPAR(1) .GT. .16D2)) INFO = -3 IF ((DPAR(1) .LT. .1D1) .OR. (DPAR(1) .GT. .2D2)) INFO = -3 N = 5 M = 1 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) A(1,1) = -.668D3 / (DPAR(1)*DPAR(2)) A(1,2) = -ONE + .1804D3 / (DPAR(1)*DPAR(2)**2) A(2,1) = .1804D3 / (.1086D2*DPAR(1)) A(2,2) = -.44175452D4 / (.1086D2*DPAR(1)*DPAR(2)) A(1,5) = 198 / (DPAR(1)*DPAR(2)) A(2,5) = .72666D3 / (.1086D2*DPAR(1)) A(3,1) = DPAR(2) A(3,4) = DPAR(2) A(4,2) = ONE CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) B(5,1) = ONE CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) C(1,3) = ONE C(1,4) = .612D1 D(1,1) = 0 C ELSE INFO = -2 END IF C ELSE IF (NR(1) .EQ. 3) THEN IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN INFO = -1 RETURN END IF C IF (NR(2) .EQ. 1) THEN NOTE = 'Laub 1979, Ex.4: string of high speed vehicles' IF (LSAME(DEF,'D')) IPAR(1) = 20 IF (IPAR(1) .LT. 2) INFO = -4 N = 2*IPAR(1) - 1 M = IPAR(1) P = IPAR(1) - 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) DO 310 I = 1, N IF (MOD(I,2) .EQ. 1) THEN A(I,I) = -ONE B(I,(I+1)/2) = ONE ELSE A(I,I-1) = ONE A(I,I+1) = -ONE C(I/2,I) = ONE END IF 310 CONTINUE CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 2) THEN NOTE = 'Hodel et al. 1996: heat flow in a thin rod' IF (LSAME(DEF,'D')) IPAR(1) = 100 IF (IPAR(1) .LT. 1) INFO = -4 N = IPAR(1) M = 1 P = N IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C TEMP = DBLE(N + 1) CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, -TWO * TEMP, A, LDA) A(1,1) = -TEMP DO 320 I = 1, N - 1 A(I,I+1) = TEMP A(I+1,I) = TEMP 320 CONTINUE CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) B(N,1) = TEMP CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 3) THEN NOTE = 'Laub 1979, Ex.6' IF (LSAME(DEF,'D')) IPAR(1) = 21 IF (IPAR(1) .LT. 1) INFO = -4 N = IPAR(1) M = 1 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) CALL DLASET('A', N-1, N-1, ZERO, ONE, A(1,2), LDA) CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) B(N,1) = ONE CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) C(1,1) = ONE CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 4) THEN NOTE = 'Lang/Penzl 1994: rotating axle' IF (LSAME(DEF,'D')) IPAR(1) = 211 IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 211)) INFO = -4 N = 2*IPAR(1) - 1 M = IPAR(1) P = IPAR(1) IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (LDWORK .LT. M*4) INFO = -21 IF (INFO .NE. 0) RETURN C OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01304.dat') IF (STATUS .NE. 0) THEN INFO = 1 ELSE DO 330 I = 1, M*4 READ (1, FMT = *, IOSTAT = STATUS) DWORK(I) IF (STATUS .NE. 0) INFO = 1 330 CONTINUE END IF CLOSE(1) IF (INFO .NE. 0) RETURN CALL DLASET('A', N, N, ZERO, ONE, E, LDE) E(1,1) = DWORK(1) DO 340 I = 2, M E(I,I-1) = DWORK((I-2) * 4 + 1) E(I,I) = -DWORK((I-1) * 4 + 1) 340 CONTINUE E(M,M) = -E(M,M) DO 350 I = M-1, 1, -1 DO 345 J = I, M IF (I .EQ. 1) THEN E(J,I) = E(J,I) - E(J,I+1) ELSE E(J,I) = E(J,I+1) - E(J,I) END IF 345 CONTINUE 350 CONTINUE CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) DO 360 I = 2, M A(I-1,I) = DWORK((I-2) * 4 + 3) A(I,I) = -TWO * DWORK((I-2) * 4 + 3) - DWORK((I-1) * 4 + 2) A(I,1) = DWORK((I-1) * 4 + 2) - DWORK((I-2) * 4 + 2) A(I-1,M+I-1) = DWORK((I-1) * 4) A(I,M+I-1) = -TWO * DWORK((I-1) * 4) IF (I .LT. M) THEN A(I+1,I) = DWORK((I-2) * 4 + 3) DO 355 J = I+1, M A(J,I) = A(J,I) + DWORK((J-2) * 4 + 2) 1 - DWORK((J-1) * 4 + 2) 355 CONTINUE A(I+1,M+I-1) = DWORK((I-1) * 4) END IF 360 CONTINUE A(1,1) = -DWORK(2) A(1,2) = -DWORK(3) A(1,M+1) = -A(1,M+1) CALL DLASET('A', M-1, M-1, ZERO, ONE, A(M+1,2), LDA) CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) DO 370 I = 2, M B(I,I) = -ONE B(I,I-1) = ONE C(I,I) = DWORK((I-2) * 4 + 3) C(I,M+I-1) = DWORK((I-1) * 4) 370 CONTINUE B(1,1) = ONE C(1,1) = ONE CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE INFO = -2 END IF C ELSE IF (NR(1) .EQ. 4) THEN IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN INFO = -1 RETURN END IF C IF (NR(2) .EQ. 1) THEN NOTE = 'Rosen/Wang 1995: control of 1-dim. heat flow' IF (LSAME(DEF,'D')) THEN IPAR(1) = 100 DPAR(1) = .1D-1 DPAR(2) = ONE DPAR(3) = ONE DPAR(4) = .2D0 DPAR(5) = .3D0 DPAR(6) = .2D0 DPAR(7) = .3D0 END IF IF (IPAR(1) .LT. 2) INFO = -4 N = IPAR(1) M = 1 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C VEC(4) = .TRUE. APPIND = DBLE(N + 1) TTEMP = -DPAR(1) * APPIND TEMP = 1 / (.6D1 * APPIND) CALL DLASET('A', N, N, ZERO, FOUR*TEMP, E, LDE) CALL DLASET('A', N, N, ZERO, TWO*TTEMP, A, LDA) DO 410 I = 1, N - 1 A(I+1,I) = -TTEMP A(I,I+1) = -TTEMP E(I+1,I) = TEMP E(I,I+1) = TEMP 410 CONTINUE DO 420 I = 1, N B1 = MAX(DBLE(I-1)/APPIND, DPAR(4)) B2 = MIN(DBLE(I+1)/APPIND, DPAR(5)) C1 = MAX(DBLE(I-1)/APPIND, DPAR(6)) C2 = MIN(DBLE(I+1)/APPIND, DPAR(7)) IF (B1 .GE. B2) THEN B(I,1) = ZERO ELSE B(I,1) = B2 - B1 TEMP = MIN(B2, DBLE(I)/APPIND) IF (B1 .LT. TEMP) THEN B(I,1) = B(I,1) + APPIND*(TEMP**2 - B1**2)/TWO B(I,1) = B(I,1) + DBLE(I)*(B1 - TEMP) END IF TEMP = MAX(B1, DBLE(I)/APPIND) IF (TEMP .LT. B2) THEN B(I,1) = B(I,1) - APPIND*(B2**2 - TEMP**2)/TWO B(I,1) = B(I,1) - DBLE(I)*(TEMP - B2) END IF END IF IF (C1 .GE. C2) THEN C(1,I) = ZERO ELSE C(1,I) = C2 - C1 TEMP = MIN(C2, DBLE(I)/APPIND) IF (C1 .LT. TEMP) THEN C(1,I) = C(1,I) + APPIND*(TEMP**2 - C1**2)/TWO C(1,I) = C(1,I) + DBLE(I)*(C1 - TEMP) END IF TEMP = MAX(C1, DBLE(I)/APPIND) IF (TEMP .LT. C2) THEN C(1,I) = C(1,I) - APPIND*(C2**2 - TEMP**2)/TWO C(1,I) = C(1,I) - DBLE(I)*(TEMP - C2) END IF END IF 420 CONTINUE CALL DSCAL(N, DPAR(2), B(1,1), 1) CALL DSCAL(N, DPAR(3), C(1,1), LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 2) THEN NOTE = 'Hench et al. 1995: coupled springs, dashpots, masses' IF (LSAME(DEF,'D')) THEN IPAR(1) = 30 DPAR(1) = FOUR DPAR(2) = FOUR DPAR(3) = ONE END IF IF (IPAR(1) .LT. 2) INFO = -4 L = IPAR(1) N = 2*L M = 2 P = 2*L IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C VEC(4) = .TRUE. CALL DLASET('A', N, N, ZERO, DPAR(1), E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) TEMP = -TWO * DPAR(3) DO 430 I = 1, L E(I,I) = ONE A(I,I+L) = ONE A(I+L,I+L) = -DPAR(2) IF (I .LT. L) THEN A(I+L,I+1) = DPAR(3) A(I+L+1,I) = DPAR(3) IF (I .GT. 1) THEN A(I+L,I) = TEMP END IF END IF 430 CONTINUE A(L+1,1) = -DPAR(3) A(N,L) = -DPAR(3) CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) B(L+1,1) = ONE B(N,2) = -ONE CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE INFO = -2 END IF ELSE INFO = -2 END IF C RETURN C *** Last Line of BD01AD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02MS.f0000644000000000000000000000013015012430707016201 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB02MS.f0000644000175000017500000000256215012430707017404 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION SB02MS( REIG, IEIG ) C C PURPOSE C C To select the unstable eigenvalues for solving the discrete-time C algebraic Riccati equation. C C ARGUMENTS C C Input/Output Parameters C C REIG (input) DOUBLE PRECISION C The real part of the current eigenvalue considered. C C IEIG (input) DOUBLE PRECISION C The imaginary part of the current eigenvalue considered. C C METHOD C C The function value SB02MS is set to .TRUE. for an unstable C eigenvalue (i.e., with modulus greater than or equal to one) and C to .FALSE., otherwise. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C C REVISIONS C C - C C KEYWORDS C C Algebraic Riccati equation, closed loop system, discrete-time C system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION IEIG, REIG C .. External Functions .. DOUBLE PRECISION DLAPY2 EXTERNAL DLAPY2 C .. Executable Statements .. C SB02MS = DLAPY2( REIG, IEIG ).GE.ONE C RETURN C *** Last line of SB02MS *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03BD.f0000644000000000000000000000013215012430707016144 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03BD.f0000644000175000017500000022122515012430707017344 0ustar00lilgelilge00000000000000 SUBROUTINE MB03BD( JOB, DEFL, COMPQ, QIND, K, N, H, ILO, IHI, S, $ A, LDA1, LDA2, Q, LDQ1, LDQ2, ALPHAR, ALPHAI, $ BETA, SCAL, IWORK, LIWORK, DWORK, LDWORK, $ IWARN, INFO ) C C PURPOSE C C To find the eigenvalues of the generalized matrix product C C S(1) S(2) S(K) C A(:,:,1) * A(:,:,2) * ... * A(:,:,K) C C where A(:,:,H) is upper Hessenberg and A(:,:,i), i <> H, is upper C triangular, using a double-shift version of the periodic C QZ method. In addition, A may be reduced to periodic Schur form: C A(:,:,H) is upper quasi-triangular and all the other factors C A(:,:,I) are upper triangular. Optionally, the 2-by-2 triangular C matrices corresponding to 2-by-2 diagonal blocks in A(:,:,H) C are so reduced that their product is a 2-by-2 diagonal matrix. C C If COMPQ = 'U' or COMPQ = 'I', then the orthogonal factors are C computed and stored in the array Q so that for S(I) = 1, C C T C Q(:,:,I)(in) A(:,:,I)(in) Q(:,:,MOD(I,K)+1)(in) C T (1) C = Q(:,:,I)(out) A(:,:,I)(out) Q(:,:,MOD(I,K)+1)(out), C C and for S(I) = -1, C C T C Q(:,:,MOD(I,K)+1)(in) A(:,:,I)(in) Q(:,:,I)(in) C T (2) C = Q(:,:,MOD(I,K)+1)(out) A(:,:,I)(out) Q(:,:,I)(out). C C A partial generation of the orthogonal factors can be realized C via the array QIND. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; A will not C necessarily be put into periodic Schur form; C = 'S': put A into periodic Schur form, and return the C eigenvalues in ALPHAR, ALPHAI, BETA, and SCAL; C = 'T': as JOB = 'S', but A is put into standardized C periodic Schur form, that is, the general product C of the 2-by-2 triangular matrices corresponding to C a complex eigenvalue is diagonal. C C DEFL CHARACTER*1 C Specifies the deflation strategy to be used, as follows: C = 'C': apply a careful deflation strategy, that is, C the criteria are based on the magnitudes of C neighboring elements and infinite eigenvalues are C only deflated at the top; this is the recommended C option; C = 'A': apply a more aggressive strategy, that is, C elements on the subdiagonal or diagonal are set C to zero as soon as they become smaller in magnitude C than eps times the norm of the corresponding C factor; this option is only recommended if C balancing is applied beforehand and convergence C problems are observed. C C COMPQ CHARACTER*1 C Specifies whether or not the orthogonal transformations C should be accumulated in the array Q, as follows: C = 'N': do not modify Q; C = 'U': modify (update) the array Q by the orthogonal C transformations that are applied to the matrices in C the array A to reduce them to periodic Schur form; C = 'I': like COMPQ = 'U', except that each matrix in the C array Q will be first initialized to the identity C matrix; C = 'P': use the parameters as encoded in QIND. C C QIND INTEGER array, dimension (K) C If COMPQ = 'P', then this array describes the generation C of the orthogonal factors as follows: C If QIND(I) > 0, then the array Q(:,:,QIND(I)) is C modified by the transformations corresponding to the C i-th orthogonal factor in (1) and (2). C If QIND(I) < 0, then the array Q(:,:,-QIND(I)) is C initialized to the identity and modified by the C transformations corresponding to the i-th orthogonal C factor in (1) and (2). C If QIND(I) = 0, then the transformations corresponding C to the i-th orthogonal factor in (1), (2) are not applied. C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of each factor in the array A. N >= 0. C C H (input) INTEGER C Hessenberg index. The factor A(:,:,H) is on entry in upper C Hessenberg form. 1 <= H <= K. C C ILO (input) INTEGER C IHI (input) INTEGER C It is assumed that each factor in A is already upper C triangular in rows and columns 1:ILO-1 and IHI+1:N. C 1 <= ILO <= IHI <= N, if N > 0; C ILO = 1 and IHI = 0, if N = 0. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures of the factors. Each entry in S must be either C 1 or -1. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA1,LDA2,K) C On entry, the leading N-by-N-by-K part of this array C must contain the factors in upper Hessenberg-triangular C form, that is, A(:,:,H) is upper Hessenberg and the other C factors are upper triangular. C On exit, if JOB = 'S' and INFO = 0, the leading C N-by-N-by-K part of this array contains the factors of C A in periodic Schur form, that is, A(:,:,H) is upper quasi C triangular and the other factors are upper triangular. C On exit, if JOB = 'T' and INFO = 0, the leading C N-by-N-by-K part of this array contains the factors of C A as for the option JOB = 'S', but the product of the C triangular factors corresponding to a 2-by-2 block in C A(:,:,H) is diagonal. C On exit, if JOB = 'E', then the leading N-by-N-by-K part C of this array contains meaningless elements in the off- C diagonal blocks. Consequently, the formulas (1) and (2) C do not hold for the returned A and Q (if COMPQ <> 'N') C in this case. C C LDA1 INTEGER C The first leading dimension of the array A. C LDA1 >= MAX(1,N). C C LDA2 INTEGER C The second leading dimension of the array A. C LDA2 >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension C (LDQ1,LDQ2,K) C On entry, if COMPQ = 'U', the leading N-by-N-by-K part C of this array must contain the initial orthogonal factors C as described in (1) and (2). C On entry, if COMPQ = 'P', only parts of the leading C N-by-N-by-K part of this array must contain some C orthogonal factors as described by the parameters QIND. C If COMPQ = 'I', this array should not be set on entry. C On exit, if COMPQ = 'U' or COMPQ = 'I', the leading C N-by-N-by-K part of this array contains the modified C orthogonal factors as described in (1) and (2). C On exit, if COMPQ = 'P', only parts of the leading C N-by-N-by-K part contain some modified orthogonal factors C as described by the parameters QIND. C This array is not referenced if COMPQ = 'N'. C C LDQ1 INTEGER C The first leading dimension of the array Q. LDQ1 >= 1, C and, if COMPQ <> 'N', LDQ1 >= MAX(1,N). C C LDQ2 INTEGER C The second leading dimension of the array Q. LDQ2 >= 1, C and, if COMPQ <> 'N', LDQ2 >= MAX(1,N). C C ALPHAR (output) DOUBLE PRECISION array, dimension (N) C On exit, if INFO = 0, the leading N elements of this array C contain the scaled real parts of the eigenvalues of the C matrix product A. The i-th eigenvalue of A is given by C C (ALPHAR(I) + ALPHAI(I)*SQRT(-1))/BETA(I) * BASE**SCAL(I), C C where BASE is the machine base (often 2.0). Complex C conjugate eigenvalues appear in consecutive locations. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N) C On exit, if INFO = 0, the leading N elements of this array C contain the scaled imaginary parts of the eigenvalues C of A. C C BETA (output) DOUBLE PRECISION array, dimension (N) C On exit, if INFO = 0, the leading N elements of this array C contain indicators for infinite eigenvalues. That is, if C BETA(I) = 0.0, then the i-th eigenvalue is infinite. C Otherwise BETA(I) is set to 1.0. C C SCAL (output) INTEGER array, dimension (N) C On exit, if INFO = 0, the leading N elements of this array C contain the scaling parameters for the eigenvalues of A. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK, C and if IWARN > N, the nonzero absolute values in IWORK(2), C ..., IWORK(N+1) are indices of the possibly inaccurate C eigenvalues, as well as of the corresponding 1-by-1 or C 2-by-2 diagonal blocks of the factors in the array A. C The 2-by-2 blocks correspond to negative values in IWORK. C One negative value is stored for each such eigenvalue C pair. Its modulus indicates the starting index of a C 2-by-2 block. This is also done for any value of IWARN, C if a 2-by-2 block is found to have two real eigenvalues. C On exit, if INFO = -22, IWORK(1) returns the minimum value C of LIWORK. C C LIWORK INTEGER C The length of the array IWORK. LIWORK >= 2*K+N. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK, C and DWORK(2), ..., DWORK(1+K) contain the Frobenius norms C of the factors of the formal matrix product used by the C algorithm. C On exit, if INFO = -24, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= K + MAX( 2*N, 8*K ). C C Warning Indicator C C IWARN INTEGER C = 0 : no warnings; C = 1,..,N-1 : A is in periodic Schur form, but the C algorithm was not able to reveal information C about the eigenvalues from the 2-by-2 C blocks. C ALPHAR(i), ALPHAI(i), BETA(i) and SCAL(i), C can be incorrect for i = 1, ..., IWARN+1; C = N : some eigenvalues might be inaccurate; C = N+1 : some eigenvalues might be inaccurate, and C details can be found in IWORK. C C Error Indicator C C INFO INTEGER C = 0 : succesful exit; C < 0 : if INFO = -i, the i-th argument had an illegal C value; C = 1,..,N : the periodic QZ iteration did not converge. C A is not in periodic Schur form, but C ALPHAR(i), ALPHAI(i), BETA(i) and SCAL(i), for C i = INFO+1,...,N should be correct. C C METHOD C C A modified version of the periodic QZ algorithm is used [1], [2]. C C REFERENCES C C [1] Bojanczyk, A., Golub, G. H. and Van Dooren, P. C The periodic Schur decomposition: algorithms and applications. C In F.T. Luk (editor), Advanced Signal Processing Algorithms, C Architectures, and Implementations III, Proc. SPIE Conference, C vol. 1770, pp. 31-42, 1992. C C [2] Kressner, D. C An efficient and reliable implementation of the periodic QZ C algorithm. IFAC Workshop on Periodic Control Systems (PSYCO C 2001), Como (Italy), August 27-28 2001. Periodic Control C Systems 2001 (IFAC Proceedings Volumes), Pergamon. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C 3 C The algorithm requires 0(K N ) floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PHGEQZ. C V. Sima, June 2010, July 2010, Nov. 2010, Sep. 2011, Oct. 2011, C Jan. 2013, Feb. 2013, July 2013, Sep. 2016, Nov. 2016, Apr. 2018. C Dec. 2018, Jan. 2019, Feb. 2019, Mar. 2019, Aug.-Sep. 2019, Dec. C 2019, Jan.-Apr. 2020. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. C .. NITER is the number of consecutive iterations for a deflated .. C .. subproblem before switching from implicit to explicit shifts... C .. MCOUNT is, similarly, the maximum number of consecutive .. C .. iterations before switching from explicit to implicit shifts... C INTEGER MCOUNT, NITER PARAMETER ( MCOUNT = 1, NITER = 10 ) DOUBLE PRECISION ZERO, ONE, TEN PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1 ) C .. Scalar Arguments .. CHARACTER COMPQ, DEFL, JOB INTEGER H, IHI, ILO, INFO, IWARN, K, LDA1, LDA2, LDQ1, $ LDQ2, LDWORK, LIWORK, N C .. Array Arguments .. INTEGER IWORK(*), QIND(*), S(*), SCAL(*) DOUBLE PRECISION A(LDA1,LDA2,*), ALPHAI(*), ALPHAR(*), BETA(*), $ DWORK(*), Q(LDQ1,LDQ2,*) C .. Local Arrays .. DOUBLE PRECISION MACPAR(5) C .. Local Scalars .. LOGICAL ADEFL, ISINF, LCMPQ, LINIQ, LPARQ, LSCHR, LSVD CHARACTER SHFT INTEGER AIND, COUNT, COUNTE, I, IERR, IFIRST, IFRSTM, $ IITER, ILAST, ILASTM, IN, IO, J, J1, JDEF, $ JITER, JLO, L, LDEF, LM, MAXIT, NTRA, OPTDW, $ OPTIW, QI, SINV, TITER, ZITER DOUBLE PRECISION A1, A2, A3, A4, BASE, CS, CS1, CS2, LGBAS, NRM, $ SAFMAX, SAFMIN, SDET, SMLNUM, SN, SN1, SN2, $ SVMN, TEMP, TEMP2, TOL, TOLL, ULP, W1, W2 C .. Workspace Pointers .. INTEGER MAPA, MAPH, MAPQ, PDW, PFREE, PNORM C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2, DLAPY3 EXTERNAL DLAMCH, DLANHS, DLAPY2, DLAPY3, LSAME C .. External Subroutines .. EXTERNAL DLABAD, DLADIV, DLARTG, DLAS2, DLASET, DROT, $ MA01BD, MB03AB, MB03AF, MB03BA, MB03BB, MB03BC, $ MB03BF, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, MOD, SIGN, SQRT C C .. Executable Statements .. C C Decode the scalar input parameters. C LSVD = LSAME( JOB, 'T' ) LSCHR = LSAME( JOB, 'S' ) .OR. LSVD LINIQ = LSAME( COMPQ, 'I' ) LCMPQ = LSAME( COMPQ, 'U' ) .OR. LINIQ LPARQ = LSAME( COMPQ, 'P' ) ADEFL = LSAME( DEFL, 'A' ) IWARN = 0 OPTDW = K + MAX( 2*N, 8*K ) OPTIW = 2*K + N C C Check the scalar input parameters. C INFO = 0 IF ( .NOT. ( LSCHR .OR. LSAME( JOB, 'E' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( ADEFL .OR. LSAME( DEFL, 'C' ) ) ) THEN INFO = -2 ELSE IF ( .NOT.( LCMPQ .OR. LPARQ .OR. LSAME( COMPQ, 'N' ) ) ) $ THEN INFO = -3 ELSE IF ( K.LT.1 ) THEN INFO = -5 ELSE IF ( N.LT.0 ) THEN INFO = -6 ELSE IF ( H.LT.1 .OR. H.GT.K ) THEN INFO = -7 ELSE IF ( ILO.LT.1 ) THEN INFO = -8 ELSE IF ( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -9 ELSE IF ( LDA1.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF ( LDA2.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF ( LDQ1.LT.1 .OR. ( ( LCMPQ .OR. LPARQ ) $ .AND. LDQ1.LT.N ) ) THEN INFO = -15 ELSE IF ( LDQ2.LT.1 .OR. ( ( LCMPQ .OR. LPARQ ) $ .AND. LDQ2.LT.N ) ) THEN INFO = -16 ELSE IF ( LIWORK.LT.OPTIW ) THEN IWORK(1) = OPTIW INFO = -22 ELSE IF ( LDWORK.LT.OPTDW ) THEN DWORK(1) = DBLE( OPTDW ) INFO = -24 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03BD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = ONE IWORK(1) = 1 RETURN END IF C C Compute Maps for accessing A and Q. C MAPA = 0 MAPH = 2 MAPQ = K QI = 0 CALL MB03BA( K, H, S, SINV, IWORK(MAPA+1), IWORK(MAPQ+1) ) C C Machine Constants. C IN = IHI + 1 - ILO SAFMIN = DLAMCH( 'SafeMinimum' ) SAFMAX = ONE / SAFMIN ULP = DLAMCH( 'Precision' ) TOLL = TEN*ULP CALL DLABAD( SAFMIN, SAFMAX ) SMLNUM = SAFMIN*( IN / ULP ) BASE = DLAMCH( 'Base' ) LGBAS = LOG( BASE ) C MACPAR(2) = DLAMCH( 'Underflow' ) IF ( LSVD ) THEN MACPAR(1) = DLAMCH( 'ORmax' ) MACPAR(3) = SAFMIN MACPAR(4) = DLAMCH( 'Epsilon' ) MACPAR(5) = BASE END IF IF ( K.GE.INT( LOG( MACPAR(2) ) / LOG( ULP ) ) ) THEN C C Start Iteration with a controlled zero shift. C ZITER = -1 ELSE ZITER = 0 END IF C C Initialize IWORK (needed in case of loosing accuracy). C DO 10 I = 2*K + 1, 2*K + N IWORK(I) = 0 10 CONTINUE C C Compute norms and initialize Q. C PNORM = 0 PFREE = K DO 20 I = 1, K AIND = IWORK(MAPA+I) DWORK(I) = DLANHS( 'Frobenius', IN, A(ILO,ILO,AIND), LDA1, $ DWORK ) J = 0 IF ( LINIQ ) THEN J = I ELSE IF ( LPARQ ) THEN J = -QIND(I) END IF IF ( J.NE.0 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q(1,1,J), LDQ1 ) 20 CONTINUE C C Set Eigenvalues IHI+1:N. C DO 30 J = IHI + 1, N CALL MA01BD( BASE, LGBAS, K, S, A(J,J,1), LDA1*LDA2, ALPHAR(J), $ BETA(J), SCAL(J) ) ALPHAI(J) = ZERO 30 CONTINUE C C If IHI < ILO, skip QZ steps. C IF ( IHI.LT.ILO ) $ GO TO 550 C C MAIN PERIODIC QZ ITERATION LOOP. C C Initialize dynamic indices. C C Eigenvalues ILAST+1:N have been found. C Column operations modify rows IFRSTM:whatever. C Row operations modify columns whatever:ILASTM. C C If only eigenvalues are being computed, then C IFRSTM is the row of the last splitting row above row ILAST; C this is always at least ILO. C IITER counts iterations since the last eigenvalue was found, C to tell when to use an observed zero or exceptional shift. C MAXIT is the maximum number of QZ sweeps allowed. C ILAST = IHI IF ( LSCHR ) THEN IFRSTM = 1 ILASTM = N ELSE IFRSTM = ILO ILASTM = IHI END IF IITER = 0 TITER = 0 COUNT = 0 COUNTE = 0 MAXIT = 120 * IN C DO 540 JITER = 1, MAXIT C C Special Case: ILAST = ILO. C IF ( ILAST.EQ.ILO ) $ GO TO 390 C C ************************************************************** C * CHECK FOR DEFLATION * C ************************************************************** C C Test 1: Deflation in the Hessenberg matrix. C IF ( ADEFL ) $ TOL = MAX( SAFMIN, DWORK(PNORM+1)*ULP ) AIND = IWORK(MAPA+1) JLO = ILO DO 40 J = ILAST, ILO + 1, -1 IF ( .NOT.ADEFL ) THEN TOL = ABS( A(J-1,J-1,AIND) ) + ABS( A(J,J,AIND) ) IF ( TOL.EQ.ZERO ) $ TOL = DLANHS( '1', J-ILO+1, A(ILO,ILO,AIND), LDA1, $ DWORK ) TOL = MAX( ULP*TOL, SMLNUM ) END IF IF ( ABS( A(J,J-1,AIND) ).LE.TOL ) THEN A(J,J-1,AIND) = ZERO JLO = J IF ( J.EQ.ILAST ) $ GO TO 390 GO TO 50 END IF 40 CONTINUE C 50 CONTINUE C C Test 2: Deflation in the triangular matrices with index 1. C DO 70 LDEF = 2, K AIND = IWORK(MAPA+LDEF) IF ( S(AIND).EQ.SINV ) THEN IF ( ADEFL ) $ TOL = MAX( SAFMIN, DWORK(PNORM+LDEF)*ULP ) DO 60 J = ILAST, JLO, -1 IF ( .NOT.ADEFL ) THEN IF ( J.EQ.ILAST ) THEN TOL = ABS( A(J-1,J,AIND) ) ELSE IF ( J.EQ.JLO ) THEN TOL = ABS( A(J,J+1,AIND) ) ELSE TOL = ABS( A(J-1,J,AIND) ) $ + ABS( A(J,J+1,AIND) ) END IF IF ( TOL.EQ.ZERO ) $ TOL = DLANHS( '1', J-JLO+1, A(JLO,JLO,AIND), $ LDA1, DWORK ) TOL = MAX( ULP*TOL, SMLNUM ) END IF IF ( ABS( A(J,J,AIND) ).LE.TOL ) THEN A(J,J,AIND) = ZERO GO TO 170 END IF 60 CONTINUE END IF 70 CONTINUE C C Test 3: Deflation in the triangular matrices with index -1. C DO 90 LDEF = 2, K AIND = IWORK(MAPA+LDEF) IF ( S(AIND).NE.SINV ) THEN IF ( ADEFL ) $ TOL = MAX( SAFMIN, DWORK(PNORM+LDEF)*ULP ) DO 80 J = ILAST, JLO, -1 IF ( .NOT.ADEFL ) THEN IF ( J.EQ.ILAST ) THEN TOL = ABS( A(J-1,J,AIND) ) ELSE IF ( J.EQ.JLO ) THEN TOL = ABS( A(J,J+1,AIND) ) ELSE TOL = ABS( A(J-1,J,AIND) ) $ + ABS( A(J,J+1,AIND) ) END IF IF ( TOL.EQ.ZERO ) $ TOL = DLANHS( '1', J-JLO+1, A(JLO,JLO,AIND), $ LDA1, DWORK ) TOL = MAX( ULP*TOL, SMLNUM ) END IF IF ( ABS( A(J,J,AIND) ).LE.TOL ) THEN A(J,J,AIND) = ZERO GO TO 320 END IF 80 CONTINUE END IF 90 CONTINUE C C Test 4: Controlled zero shift. C IF ( ZITER.GE.7 .OR. ZITER.LT.0 ) THEN C C Make Hessenberg matrix upper triangular. C AIND = IWORK(MAPA+1) PDW = PFREE + 1 DO 100 J = JLO, ILAST - 1 TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 100 CONTINUE IF ( LCMPQ ) THEN QI = IWORK(MAPQ+1) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+1)) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 110 J = JLO, ILAST - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) 110 CONTINUE END IF C C Propagate transformations back to A_1. C DO 150 L = K, 2, -1 AIND = IWORK(MAPA+L) PDW = PFREE + 1 IF ( ADEFL ) $ TOL = MAX( SAFMIN, DWORK(PNORM+L)*ULP ) IF ( S(AIND).EQ.SINV ) THEN DO 120 J = JLO, ILAST - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) IF ( SN.NE.ZERO ) THEN CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) C C Check for deflation. C IF ( .NOT.ADEFL ) THEN TOL = ABS( A(J,J,AIND) ) + $ ABS( A(J+1,J+1,AIND) ) IF ( TOL.EQ.ZERO ) $ TOL = DLANHS( '1', J-JLO+2, $ A(JLO,JLO,AIND), LDA1, $ DWORK ) TOL = MAX( ULP*TOL, SMLNUM ) END IF IF ( ABS( A(J+1,J,AIND) ).LE.TOL ) THEN CS = ONE SN = ZERO A(J+1,J,AIND) = ZERO END IF END IF IF ( SN.NE.ZERO ) THEN TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS, SN ) END IF DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 120 CONTINUE ELSE DO 130 J = JLO, ILAST - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) IF ( SN.NE.ZERO ) THEN CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS, SN ) C C Check for deflation. C IF ( .NOT.ADEFL ) THEN TOL = ABS( A(J,J,AIND) ) + $ ABS( A(J+1,J+1,AIND) ) IF ( TOL.EQ.ZERO ) $ TOL = DLANHS( '1', J-JLO+2, $ A(JLO,JLO,AIND), LDA1, $ DWORK ) TOL = MAX( ULP*TOL, SMLNUM ) END IF IF ( ABS( A(J+1,J,AIND) ).LE.TOL ) THEN CS = ONE SN = ZERO A(J+1,J,AIND) = ZERO END IF END IF IF ( SN.NE.ZERO ) THEN TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, -A(J+1,J,AIND), CS, SN, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) END IF DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 130 CONTINUE END IF IF ( LCMPQ ) THEN QI = IWORK(MAPQ+L) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+L)) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 140 J = JLO, ILAST - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 IF ( SN.NE.ZERO ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, $ SN ) 140 CONTINUE END IF 150 CONTINUE C C Apply the transformations to the right hand side of the C Hessenberg factor. C AIND = IWORK(MAPA+1) PDW = PFREE + 1 ZITER = 0 DO 160 J = JLO, ILAST - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 IF ( SN.NE.ZERO ) THEN CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) ELSE ZITER = -1 END IF 160 CONTINUE C C No QZ iteration. C GO TO 530 END IF C C ************************************************************** C * HANDLE DEFLATIONS * C ************************************************************** C C Case I: Deflation occurs in the Hessenberg matrix. The QZ C iteration is only applied to the JLO:ILAST part. C IFIRST = JLO C C Go to the periodic QZ steps. C GO TO 420 C C Case II: Deflation occurs in a triangular matrix with index 1. C C Do an unshifted periodic QZ step. C 170 CONTINUE JDEF = J AIND = IWORK(MAPA+1) PDW = PFREE + 1 DO 180 J = JLO, JDEF - 1 TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, A(J+1,J+1,AIND), $ LDA1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 180 CONTINUE IF ( LCMPQ ) THEN QI = IWORK(MAPQ+1) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+1)) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 190 J = JLO, JDEF - 1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) 190 CONTINUE END IF C C Propagate the transformations through the triangular matrices. C Due to the zero element on the diagonal of the LDEF-th factor, C the number of transformations drops by one. C DO 230 L = K, 2, -1 AIND = IWORK(MAPA+L) IF ( L.LT.LDEF ) THEN NTRA = JDEF - 2 ELSE NTRA = JDEF - 1 END IF PDW = PFREE + 1 IF ( S(AIND).EQ.SINV ) THEN DO 200 J = JLO, NTRA CS = DWORK(PDW) SN = DWORK(PDW+1) CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 200 CONTINUE ELSE DO 210 J = JLO, NTRA CS = DWORK(PDW) SN = DWORK(PDW+1) CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS, SN ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, -A(J+1,J,AIND), CS, SN, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 210 CONTINUE END IF IF ( LCMPQ ) THEN QI = IWORK(MAPQ+L) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+L)) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 220 J = JLO, NTRA CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) 220 CONTINUE END IF 230 CONTINUE C C Apply the transformations to the right hand side of the C Hessenberg factor. C AIND = IWORK(MAPA+1) PDW = PFREE + 1 DO 240 J = JLO, JDEF - 2 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) 240 CONTINUE C C Do an unshifted periodic QZ step. C PDW = PFREE + 1 DO 250 J = ILAST, JDEF + 1, -1 TEMP = A(J,J,AIND) CALL DLARTG( TEMP, -A(J,J-1,AIND), CS, SN, A(J,J,AIND) ) A(J,J-1,AIND) = ZERO CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 250 CONTINUE IF ( LCMPQ ) THEN QI = IWORK(MAPQ+2) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+2)) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 260 J = ILAST, JDEF + 1, -1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN ) 260 CONTINUE END IF C C Propagate the transformations through the triangular matrices. C DO 300 L = 2, K AIND = IWORK(MAPA+L) IF ( L.GT.LDEF ) THEN NTRA = JDEF + 2 ELSE NTRA = JDEF + 1 END IF PDW = PFREE + 1 IF ( S(AIND).NE.SINV ) THEN DO 270 J = ILAST, NTRA, -1 CS = DWORK(PDW) SN = DWORK(PDW+1) CALL DROT( J+1-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) TEMP = A(J-1,J-1,AIND) CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN, $ A(J-1,J-1,AIND) ) A(J,J-1,AIND) = ZERO CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1, $ A(J,J,AIND), LDA1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 270 CONTINUE ELSE DO 280 J = ILAST, NTRA, -1 CS = DWORK(PDW) SN = DWORK(PDW+1) CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1, $ A(J,J-1,AIND), LDA1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, -A(J,J-1,AIND), CS, SN, $ A(J,J,AIND) ) A(J,J-1,AIND) = ZERO CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) DWORK(PDW) = CS DWORK(PDW+1) = SN PDW = PDW + 2 280 CONTINUE END IF LM = MOD( L, K ) + 1 IF ( LCMPQ ) THEN QI = IWORK(MAPQ+LM) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+LM)) ) END IF IF ( QI.NE.0 ) THEN PDW = PFREE + 1 DO 290 J = ILAST, NTRA, -1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN ) 290 CONTINUE END IF 300 CONTINUE C C Apply the transformations to the left hand side of the C Hessenberg factor. C AIND = IWORK(MAPA+1) PDW = PFREE + 1 DO 310 J = ILAST, JDEF + 2, -1 CS = DWORK(PDW) SN = DWORK(PDW+1) PDW = PDW + 2 CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1, A(J,J-1,AIND), $ LDA1, CS, SN ) 310 CONTINUE C C No QZ iteration. C GO TO 530 C C Case III: Deflation occurs in a triangular matrix with C index -1. C 320 CONTINUE JDEF = J IF ( JDEF.GT.( ( ILAST - JLO + 1 )/2 ) ) THEN C C Chase the zero downwards to the last position. C DO 340 J1 = JDEF, ILAST - 1 J = J1 AIND = IWORK(MAPA+LDEF) TEMP = A(J,J+1,AIND) CALL DLARTG( TEMP, A(J+1,J+1,AIND), CS, SN, $ A(J,J+1,AIND) ) A(J+1,J+1,AIND) = ZERO CALL DROT( ILASTM-J-1, A(J,J+2,AIND), LDA1, $ A(J+1,J+2,AIND), LDA1, CS, SN ) LM = MOD( LDEF, K ) + 1 IF ( LCMPQ ) THEN QI = IWORK(MAPQ+LM) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+LM)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) DO 330 L = 1, K - 1 AIND = IWORK(MAPA+LM) IF ( LM.EQ.1 ) THEN CALL DROT( ILASTM-J+2, A(J,J-1,AIND), LDA1, $ A(J+1,J-1,AIND), LDA1, CS, SN ) TEMP = A(J+1,J,AIND) CALL DLARTG( TEMP, -A(J+1,J-1,AIND), CS, SN, $ A(J+1,J,AIND) ) A(J+1,J-1,AIND) = ZERO CALL DROT( J-IFRSTM+1, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) J = J - 1 ELSE IF ( S(AIND).EQ.SINV ) THEN CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS, SN ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, -A(J+1,J,AIND), CS, SN, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( J-IFRSTM+1, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) ELSE CALL DROT( J-IFRSTM+2, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS, SN ) END IF LM = MOD( LM, K ) + 1 IF ( LCMPQ ) THEN QI = IWORK(MAPQ+LM) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+LM)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, $ SN ) 330 CONTINUE AIND = IWORK(MAPA+LDEF) CALL DROT( J-IFRSTM+1, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) 340 CONTINUE C C Deflate the last element in the Hessenberg matrix. C AIND = IWORK(MAPA+1) J = ILAST TEMP = A(J,J,AIND) CALL DLARTG( TEMP, -A(J,J-1,AIND), CS, SN, A(J,J,AIND) ) A(J,J-1,AIND) = ZERO CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) IF ( LCMPQ ) THEN QI = IWORK(MAPQ+2) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+2)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN ) DO 350 L = 2, LDEF - 1 AIND = IWORK(MAPA+L) IF ( S(AIND).NE.SINV ) THEN CALL DROT( J+1-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) TEMP = A(J-1,J-1,AIND) CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN, $ A(J-1,J-1,AIND) ) A(J,J-1,AIND) = ZERO CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1, $ A(J,J,AIND), LDA1, CS, SN ) ELSE CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1, $ A(J,J-1,AIND), LDA1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, -A(J,J-1,AIND), CS, SN, $ A(J,J,AIND) ) A(J,J-1,AIND) = ZERO CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) END IF LM = L + 1 IF ( LCMPQ ) THEN QI = IWORK(MAPQ+LM) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+LM)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN ) 350 CONTINUE AIND = IWORK(MAPA+LDEF) CALL DROT( J+1-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) ELSE C C Chase the zero upwards to the first position. C DO 370 J1 = JDEF, JLO + 1, -1 J = J1 AIND = IWORK(MAPA+LDEF) TEMP = A(J-1,J,AIND) CALL DLARTG( TEMP, -A(J-1,J-1,AIND), CS, SN, $ A(J-1,J,AIND) ) A(J-1,J-1,AIND) = ZERO CALL DROT( J-IFRSTM-1, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) IF ( LCMPQ ) THEN QI = IWORK(MAPQ+LDEF) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+LDEF)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, SN ) LM = LDEF - 1 DO 360 L = 1, K - 1 AIND = IWORK(MAPA+LM) IF ( LM.EQ.1 ) THEN CALL DROT( J-IFRSTM+2, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) TEMP = A(J,J-1,AIND) CALL DLARTG( TEMP, A(J+1,J-1,AIND), CS, SN, $ A(J,J-1,AIND) ) A(J+1,J-1,AIND) = ZERO CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS, SN ) J = J + 1 ELSE IF ( S(AIND).NE.SINV ) THEN CALL DROT( ILASTM-J+2, A(J-1,J-1,AIND), LDA1, $ A(J,J-1,AIND), LDA1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, -A(J,J-1,AIND), CS, SN, $ A(J,J,AIND) ) A(J,J-1,AIND) = ZERO CALL DROT( J-IFRSTM, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) ELSE CALL DROT( J-IFRSTM+1, A(IFRSTM,J-1,AIND), 1, $ A(IFRSTM,J,AIND), 1, CS, SN ) TEMP = A(J-1,J-1,AIND) CALL DLARTG( TEMP, A(J,J-1,AIND), CS, SN, $ A(J-1,J-1,AIND) ) A(J,J-1,AIND) = ZERO CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1, $ A(J,J,AIND), LDA1, CS, SN ) END IF IF ( LCMPQ ) THEN QI = IWORK(MAPQ+LM) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+LM)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J-1,QI), 1, Q(1,J,QI), 1, CS, $ SN ) LM = LM - 1 IF ( LM.LE.0 ) $ LM = K 360 CONTINUE AIND = IWORK(MAPA+LDEF) CALL DROT( ILASTM-J+1, A(J-1,J,AIND), LDA1, A(J,J,AIND), $ LDA1, CS, SN ) 370 CONTINUE C C Deflate the first element in the Hessenberg matrix. C AIND = IWORK(MAPA+1) J = JLO TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, A(J+1,J+1,AIND), $ LDA1, CS, SN ) IF ( LCMPQ ) THEN QI = IWORK(MAPQ+1) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+1)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) DO 380 L = K, LDEF + 1, -1 AIND = IWORK(MAPA+L) IF ( S(AIND).EQ.SINV ) THEN CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS, SN, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS, SN ) ELSE CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS, SN ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, -A(J+1,J,AIND), CS, SN, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS, SN ) END IF IF ( LCMPQ ) THEN QI = IWORK(MAPQ+L) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+L)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS, SN ) 380 CONTINUE AIND = IWORK(MAPA+LDEF) CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, A(J+1,J+1,AIND), $ LDA1, CS, SN ) END IF C C No QZ iteration. C GO TO 530 C C Special case: A 1x1 block splits off at the bottom. C 390 CONTINUE CALL MA01BD( BASE, LGBAS, K, S, A(ILAST,ILAST,1), LDA1*LDA2, $ ALPHAR(ILAST), BETA(ILAST), SCAL(ILAST) ) ALPHAI(ILAST) = ZERO C C Check for possible loss of accuracy. C IF ( BETA(ILAST).NE.ZERO ) THEN DO 400 L = 1, K AIND = IWORK(MAPA+L) TEMP = A(ILAST,ILAST,AIND) IF ( TEMP.NE.ZERO ) THEN IF ( ABS( TEMP ).LT.DWORK(L)*TOLL ) THEN IWARN = N + 1 IWORK(2*K+ILAST) = ILAST GO TO 410 END IF END IF 400 CONTINUE END IF C C Go to next block - exit if finished. C 410 CONTINUE ILAST = ILAST - 1 IF ( ILAST.LT.ILO ) $ GO TO 550 C C Reset iteration counters. C IITER = 0 TITER = 0 COUNT = 0 COUNTE = 0 IF ( ZITER.NE.-1 ) $ ZITER = 0 IF ( .NOT.LSCHR ) THEN ILASTM = ILAST IF ( IFRSTM.GT.ILAST ) $ IFRSTM = ILO END IF C C No QZ iteration. C GO TO 530 C C ************************************************************** C * PERIODIC QZ STEP * C ************************************************************** C C It is assumed that IFIRST < ILAST. C 420 CONTINUE C IITER = IITER + 1 ZITER = ZITER + 1 IF( .NOT.LSCHR ) $ IFRSTM = IFIRST IF ( IFIRST+1.EQ.ILAST ) THEN C C Special case -- 2x2 block. C J = ILAST - 1 IF ( TITER.LT.2 ) THEN TITER = TITER + 1 C C Try to deflate the 2-by-2 problem. C PDW = PFREE + 1 DO 430 L = 1, K DWORK(PDW ) = A(J,J,L) DWORK(PDW+1) = A(J+1,J,L) DWORK(PDW+2) = A(J,J+1,L) DWORK(PDW+3) = A(J+1,J+1,L) PDW = PDW + 4 430 CONTINUE IF ( SINV.LT.0 ) THEN I = IWORK(MAPQ+1) IWORK(MAPQ+1) = IWORK(MAPA+1) END IF CALL MB03BF( K, IWORK(MAPH), S, SINV, DWORK(PFREE+1), $ 2, 2, ULP ) IF ( SINV.LT.0 ) $ IWORK(MAPQ+1) = I I = PFREE + 4*( H - 1 ) IF ( ABS( DWORK(I+2) ).LT. $ ULP*( MAX( ABS( DWORK(I+1) ), ABS( DWORK(I+3) ), $ ABS( DWORK(I+4) ) ) ) ) THEN C C Construct a perfect shift polynomial. This may fail, C so we try it twice (indicated by TITER). C CS1 = ONE SN1 = ONE DO 440 L = K, 2, -1 AIND = IWORK(MAPA+L) TEMP = DWORK(PFREE+AIND*4) IF ( S(AIND).EQ.SINV ) THEN CALL DLARTG( CS1*A(J,J,AIND), SN1*TEMP, CS1, $ SN1, TEMP ) ELSE CALL DLARTG( CS1*TEMP, SN1*A(J,J,AIND), CS1, $ SN1, TEMP ) END IF 440 CONTINUE AIND = IWORK(MAPA+1) TEMP = DWORK(PFREE+AIND*4) CALL DLARTG( A(J,J,AIND)*CS1-TEMP*SN1, $ A(J+1,J,AIND)*CS1, CS1, SN1, TEMP ) GO TO 510 END IF END IF C C Looks like a complex block. C 1. Compute the product SVD of the triangular matrices C (optionally). C IF ( LSVD ) THEN CALL MB03BC( K, IWORK(MAPA+1), S, SINV, A(J,J,1), LDA1, $ LDA2, MACPAR, DWORK(PFREE+1), $ DWORK(PFREE+K+1), DWORK(PFREE+2*K+1) ) C C Update factors and transformations. C AIND = IWORK(MAPA+1) CS2 = DWORK(PFREE+1) SN2 = DWORK(PFREE+K+1) CALL DROT( ILASTM-IFRSTM+1, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS2, SN2 ) DO 450 L = 2, K AIND = IWORK(MAPA+L) IF ( LCMPQ ) THEN QI = IWORK(MAPQ+L) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+L)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS2, $ SN2 ) CS1 = CS2 SN1 = SN2 CS2 = DWORK(PFREE+L) SN2 = DWORK(PFREE+K+L) IF (S(AIND).EQ.SINV) THEN CALL DROT( ILASTM-J-1, A(J,J+2,AIND), LDA1, $ A(J+1,J+2,AIND), LDA1, CS1, SN1 ) CALL DROT( J-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS2, SN2 ) ELSE CALL DROT( ILASTM-J-1, A(J,J+2,AIND), LDA1, $ A(J+1,J+2,AIND), LDA1, CS2, SN2 ) CALL DROT( J-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) END IF 450 CONTINUE IF ( LCMPQ ) THEN QI = IWORK(MAPQ+1) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+1)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS2, SN2 ) AIND = IWORK(MAPA+1) CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS2, SN2 ) END IF C C 2. Compute complex eigenvalues. C CALL MB03BB( BASE, LGBAS, ULP, K, IWORK(MAPA+1), S, SINV, $ A(J,J,1), LDA1, LDA2, ALPHAR(J), ALPHAI(J), $ BETA(J), SCAL(J), DWORK(PFREE+1), IERR ) IF ( IERR.EQ.1 ) THEN C C The single shift periodic QZ did not converge, set C IWARN = J to indicate that the eigenvalues are not C assigned. C IWARN = MAX( J, IWARN ) ELSE IF ( IERR.EQ.2 ) THEN C C Some computed eigenvalues might be inaccurate. C IF ( IWARN.EQ.0 ) $ IWARN = N END IF C C Check for real eigenvalues and possible loss of accuracy. C Also, set zero or infinite eigenvalues where appropriate. C DO 460 L = 1, K AIND = IWORK(MAPA+L) IF ( ALPHAI(J).EQ.ZERO .AND. BETA(J).NE.ZERO ) THEN IF ( ABS( A(J,J,AIND) ).LT.DWORK(L)*TOLL ) THEN IWARN = N + 1 IWORK(2*K+J) = -J GO TO 470 END IF ELSE A1 = A(J,J,AIND) A3 = A(J,J+1,AIND) A4 = A(J+1,J+1,AIND) NRM = DLAPY3( A1, A3, A4 ) IF ( L.EQ.IWORK(MAPA+1) ) THEN A2 = A(J+1,J,L) NRM = DLAPY2( NRM, A2 ) END IF SDET = ( MAX( ABS( A1 ), ABS( A4 ) )/NRM ) $ *MIN( ABS( A1 ), ABS( A4 ) )* $ SIGN( ONE, A1 )*SIGN( ONE, A4 ) IF ( L.EQ.IWORK(MAPA+1) ) $ SDET = SDET - ( MAX( ABS( A2 ), ABS( A3 ) )/NRM ) $ *MIN( ABS( A2 ), ABS( A3 ) )* $ SIGN( ONE, A2 )*SIGN( ONE, A3 ) IF ( ABS( SDET ).LT.DWORK(L)*TOLL ) THEN C C Make a more accurate singularity test using SVD. C IF ( L.EQ.IWORK(MAPA+1) ) THEN IF ( ABS( A1 ).GE.ABS( A4 ) ) THEN CALL DLARTG( A1, A2, CS, SN, TEMP ) A1 = TEMP TEMP = CS*A3 + SN*A4 A4 = CS*A4 - SN*A3 A3 = TEMP ELSE CALL DLARTG( A4, A2, CS, SN, TEMP ) A4 = TEMP TEMP = CS*A3 + SN*A1 A1 = CS*A1 - SN*A3 A3 = TEMP END IF END IF CALL DLAS2( A1, A3, A4, SVMN, TEMP ) IF ( SVMN.LT.DWORK(L)*TOLL ) THEN IWARN = N + 1 IWORK(2*K+J) = -J GO TO 470 END IF END IF END IF 460 CONTINUE C C Go to next block and reset counters. C 470 CONTINUE ILAST = IFIRST - 1 IF ( ILAST.LT.ILO ) $ GO TO 550 IITER = 0 TITER = 0 COUNT = 0 COUNTE = 0 IF ( ZITER.NE.-1 ) $ ZITER = 0 IF ( .NOT.LSCHR ) THEN ILASTM = ILAST IF ( IFRSTM.GT.ILAST ) $ IFRSTM = ILO END IF GO TO 530 END IF C C Now, it is assumed that ILAST-IFIRST+1 >= 3. C IF ( COUNT.LT.NITER ) THEN C C Use the normal periodic QZ step routine. C Note that the pointer to IWORK is increased by 1. C The fact that, for SINV = 1, IWORK(MAPQ+1) = IWORK(MAPA+1) C is used. C COUNT = COUNT + 1 IF ( SINV.LT.0 ) THEN I = IWORK(MAPQ+1) IWORK(MAPQ+1) = IWORK(MAPA+1) END IF CALL MB03AF( 'Double', K, ILAST-IFIRST+1, IWORK(MAPH), S, $ SINV, A(IFIRST,IFIRST,1), LDA1, LDA2, CS1, $ SN1, CS2, SN2 ) IF ( SINV.LT.0 ) $ IWORK(MAPQ+1) = I ELSE IF ( COUNTE.LT.MCOUNT ) THEN C C Compute the two trailing eigenvalues for finding the shifts. C Deal with special case of infinite eigenvalues, if needed. C I = ILAST - 1 IF ( SINV.LT.0 ) THEN AIND = IWORK(MAPA+1) A1 = A(I,I,AIND) A2 = A(I+1,I,AIND) A3 = A(I,I+1,AIND) A4 = A(I+1,I+1,AIND) NRM = DLANHS( 'Frobenius', 2, A(ILO,ILO,AIND), LDA1, $ DWORK ) SDET = ( MAX( ABS( A1 ), ABS( A4 ) )/NRM ) $ *MIN( ABS( A1 ), ABS( A4 ) )* $ SIGN( ONE, A1 )*SIGN( ONE, A4 ) - $ ( MAX( ABS( A2 ), ABS( A3 ) )/NRM ) $ *MIN( ABS( A2 ), ABS( A3 ) )* $ SIGN( ONE, A2 )*SIGN( ONE, A3 ) ISINF = ABS( SDET ).LT.DWORK(AIND)*TOLL IF ( ISINF ) THEN ALPHAR(I) = ONE/DWORK(PNORM+1) ALPHAR(ILAST) = ONE/DWORK(PNORM+1) SCAL(I) = 1 SCAL(ILAST) = 1 END IF IERR = 0 ELSE ISINF = .FALSE. END IF IF ( .NOT.ISINF ) THEN CALL MB03BB( BASE, LGBAS, ULP, K, IWORK(MAPA+1), S, SINV, $ A(I,I,1), LDA1, LDA2, ALPHAR(I), ALPHAI(I), $ BETA(I), SCAL(I), DWORK(PFREE+1), IERR ) IF ( SINV.LT.0 ) THEN C C Use the reciprocals of the eigenvalues returned above. C IF ( ALPHAI(I).EQ.ZERO ) THEN ALPHAR(I) = SIGN( ONE, ALPHAR(I) )/ $ MAX( SAFMIN, ABS( ALPHAR(I) ) ) ALPHAR(ILAST) = SIGN( ONE, ALPHAR(ILAST) )/ $ MAX( SAFMIN, ABS( ALPHAR(ILAST) ) ) SCAL(I) = -SCAL(I) SCAL(ILAST) = -SCAL(ILAST) ELSE CALL DLADIV( ONE, ZERO, ALPHAR(ILAST), $ -ALPHAI(ILAST), ALPHAR(I), ALPHAI(I) ) SCAL(I) = -SCAL(I) END IF END IF C IF ( IERR.NE.0 ) THEN C C Try an exceptional transformation if MB03BB does not C converge on some special cases. C TEMP2 = BASE**SCAL(I) IF ( ALPHAI(I).NE.ZERO ) THEN TEMP = ( ABS( ALPHAR(I) ) + ABS( ALPHAI(I) ) )* $ TEMP2 ELSE TEMP = MAX( ABS( ALPHAR(ILAST) )*BASE**SCAL(ILAST), $ ABS( ALPHAR(I) )*TEMP2 ) END IF IF ( TEMP.LE.SQRT( ULP )*DWORK(PNORM+1) ) THEN ALPHAR(I) = DWORK(PNORM+1) SCAL(I) = 1 ALPHAR(ILAST) = DWORK(PNORM+1) SCAL(ILAST) = 1 IERR = 0 END IF END IF END IF C IF ( IERR.NE.0 ) THEN C C Use the normal periodic QZ step routine. C IERR = 0 IN = ILAST - IFIRST + 1 IF ( SINV.LT.0 ) THEN J1 = IWORK(MAPQ+1) IWORK(MAPQ+1) = IWORK(MAPA+1) END IF CALL MB03AF( 'Double', K, IN, IWORK(MAPH), S, SINV, $ A(IFIRST,IFIRST,1), LDA1, LDA2, CS1, SN1, $ CS2, SN2 ) IF ( SINV.LT.0 ) $ IWORK(MAPQ+1) = J1 COUNT = 0 COUNTE = 0 ELSE C C Use explict shifts. C COUNTE = COUNTE + 1 W1 = ALPHAR(I)*BASE**SCAL(I) C IF ( ALPHAI(I).NE.ZERO ) THEN C C Use complex conjugate shifts. C SHFT = 'C' W2 = ALPHAI(I)*BASE**SCAL(I) C ELSE C C Two identical real shifts are tried first. If there is C no convergence after MCOUNT/2 consecutive iterations, C a single shift is applied. The eigenvalue closer to C the last element of the current product is used. C W2 = ALPHAR(ILAST)*BASE**SCAL(ILAST) C CALL MA01BD( BASE, LGBAS, K, S, A(ILAST,ILAST,1), $ LDA1*LDA2, TEMP, TEMP2, I ) TEMP = TEMP*BASE**I A1 = ABS( TEMP - W1 ) A2 = ABS( TEMP - W2 ) C IF ( COUNTE.LE.MAX( 1, MCOUNT/2 ) ) THEN SHFT = 'D' IF ( A1.LT.A2 ) THEN W2 = W1 ELSE W1 = W2 END IF ELSE SHFT = 'S' IF ( A1.LT.A2 ) $ W2 = W1 END IF C END IF C C Compute an initial transformation using the selected C shifts. C CALL MB03AB( SHFT, K, ILAST-IFIRST+1, IWORK(MAPA+1), S, $ SINV, A(IFIRST,IFIRST,1), LDA1, LDA2, W1, $ W2, CS1, SN1, CS2, SN2 ) END IF C IF ( COUNT+COUNTE.GE.NITER+MCOUNT ) THEN C C Reset the two counters. C COUNT = 0 COUNTE = 0 END IF END IF C C Do the sweeps. C IF ( K.GT.1 ) THEN C C The propagation of the initial transformation is processed C here separately. C IN = IFIRST + 1 IO = ILAST - 2 J = IFIRST AIND = IWORK(MAPA+1) CALL DROT( ILAST-IFRSTM+1, A(IFRSTM,J+1,AIND), 1, $ A(IFRSTM,J+2,AIND), 1, CS2, SN2 ) CALL DROT( ILAST-IFRSTM+1, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) IF ( LCMPQ ) THEN QI = IWORK(MAPQ+2) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+2)) ) END IF IF ( QI.NE.0 ) THEN CALL DROT( N, Q(1,J+1,QI), 1, Q(1,J+2,QI), 1, CS2, SN2 ) CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 ) END IF C C Propagate information from the right to A_k. C DO 480 L = 2, K AIND = IWORK(MAPA+L) IF ( S(AIND).EQ.SINV ) THEN CALL DROT( ILASTM-J+1, A(J+1,J,AIND), LDA1, $ A(J+2,J,AIND), LDA1, CS2, SN2 ) TEMP = A(J+2,J+2,AIND) CALL DLARTG( TEMP, -A(J+2,J+1,AIND), CS2, SN2, $ A(J+2,J+2,AIND) ) A(J+2,J+1,AIND) = ZERO CALL DROT( J-IFRSTM+2, A(IFRSTM,J+1,AIND), 1, $ A(IFRSTM,J+2,AIND), 1, CS2, SN2 ) C CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS1, SN1 ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, -A(J+1,J,AIND), CS1, SN1, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( J-IFRSTM+1, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) C ELSE C CALL DROT( J+3-IFRSTM, A(IFRSTM,J+1,AIND), 1, $ A(IFRSTM,J+2,AIND), 1, CS2, SN2 ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, A(J+2,J+1,AIND), CS2, SN2, $ A(J+1,J+1,AIND) ) A(J+2,J+1,AIND) = ZERO CALL DROT( ILASTM-J-1, A(J+1,J+2,AIND), LDA1, $ A(J+2,J+2,AIND), LDA1, CS2, SN2 ) C CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS1, SN1, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS1, SN1 ) END IF IF ( LCMPQ ) THEN QI = IWORK(MAPQ+MOD(L,K)+1) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+MOD(L,K)+1)) ) END IF IF ( QI.NE.0 ) THEN CALL DROT( N, Q(1,J+1,QI), 1, Q(1,J+2,QI), 1, CS2, $ SN2 ) CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 ) END IF 480 CONTINUE C AIND = IWORK(MAPA+1) CALL DROT( ILASTM-IFIRST+1, A(J+1,IFIRST,AIND), LDA1, $ A(J+2,IFIRST,AIND), LDA1, CS2, SN2 ) CALL DROT( ILASTM-IFIRST+1, A(J,IFIRST,AIND), LDA1, $ A(J+1,IFIRST,AIND), LDA1, CS1, SN1 ) ELSE IN = IFIRST - 1 IO = ILAST - 3 END IF C DO 500 J1 = IN, IO AIND = IWORK(MAPA+1) IF ( LCMPQ ) THEN QI = IWORK(MAPQ+1) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+1)) ) END IF C C Create a bulge if J1 = IFIRST - 1, otherwise chase the C bulge. C IF ( J1.LT.IFIRST ) THEN J = J1 + 1 CALL DROT( ILASTM-J+1, A(J+1,J,AIND), LDA1, $ A(J+2,J,AIND), LDA1, CS2, SN2 ) CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS1, SN1 ) ELSE IF ( K.EQ.1 ) THEN J = J + 1 ELSE J = J1 END IF TEMP = A(J+1,J-1,AIND) CALL DLARTG( TEMP, A(J+2,J-1,AIND), CS2, SN2, $ TEMP2 ) TEMP = A(J,J-1,AIND) CALL DLARTG( TEMP, TEMP2, CS1, SN1, A(J,J-1,AIND) ) A(J+1,J-1,AIND) = ZERO A(J+2,J-1,AIND) = ZERO CALL DROT( ILASTM-J+1, A(J+1,J,AIND), LDA1, $ A(J+2,J,AIND), LDA1, CS2, SN2 ) CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS1, SN1 ) END IF IF ( QI.NE.0 ) THEN CALL DROT( N, Q(1,J+1,QI), 1, Q(1,J+2,QI), 1, CS2, SN2 ) CALL DROT( N, Q(1,J, QI), 1, Q(1,J+1,QI), 1, CS1, SN1 ) END IF C C Propagate information from the right to A_1. C DO 490 L = K, 2, -1 AIND = IWORK(MAPA+L) IF ( S(AIND).EQ.SINV ) THEN CALL DROT( J+3-IFRSTM, A(IFRSTM,J+1,AIND), 1, $ A(IFRSTM,J+2,AIND), 1, CS2, SN2 ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, A(J+2,J+1,AIND), CS2, SN2, $ A(J+1,J+1,AIND) ) A(J+2,J+1,AIND) = ZERO CALL DROT( ILASTM-J-1, A(J+1,J+2,AIND), LDA1, $ A(J+2,J+2,AIND), LDA1, CS2, SN2 ) CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS1, SN1, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS1, SN1 ) ELSE CALL DROT( ILASTM-J+1, A(J+1,J,AIND), LDA1, $ A(J+2,J,AIND), LDA1, CS2, SN2 ) TEMP = A(J+2,J+2,AIND) CALL DLARTG( TEMP, -A(J+2,J+1,AIND), CS2, SN2, $ A(J+2,J+2,AIND) ) A(J+2,J+1,AIND) = ZERO CALL DROT( J+2-IFRSTM, A(IFRSTM,J+1,AIND), 1, $ A(IFRSTM,J+2,AIND), 1, CS2, SN2 ) CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS1, SN1 ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, -A(J+1,J,AIND), CS1, SN1, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) END IF IF ( LCMPQ ) THEN QI = IWORK(MAPQ+L) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+L)) ) END IF IF ( QI.NE.0 ) THEN CALL DROT( N, Q(1,J+1,QI), 1, Q(1,J+2,QI), 1, CS2, $ SN2 ) CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 ) END IF 490 CONTINUE AIND = IWORK(MAPA+1) LM = MIN( J+3, ILASTM ) - IFRSTM + 1 CALL DROT( LM, A(IFRSTM,J+1,AIND), 1, $ A(IFRSTM,J+2,AIND), 1, CS2, SN2 ) CALL DROT( LM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) 500 CONTINUE C C To avoid IF statements, there is an extra piece of code for C the last step. C J = ILAST - 1 TEMP = A(J,J-1,AIND) CALL DLARTG( TEMP, A(J+1,J-1,AIND), CS1, SN1, A(J,J-1,AIND) ) A(J+1,J-1,AIND) = ZERO C 510 CONTINUE C CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS1, SN1 ) IF ( LCMPQ ) THEN QI = IWORK(MAPQ+1) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+1)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 ) C C Propagate information from the right to A_1. C DO 520 L = K, 2, -1 AIND = IWORK(MAPA+L) IF ( S(AIND).EQ.SINV ) THEN CALL DROT( J+2-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) TEMP = A(J,J,AIND) CALL DLARTG( TEMP, A(J+1,J,AIND), CS1, SN1, $ A(J,J,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( ILASTM-J, A(J,J+1,AIND), LDA1, $ A(J+1,J+1,AIND), LDA1, CS1, SN1 ) ELSE CALL DROT( ILASTM-J+1, A(J,J,AIND), LDA1, $ A(J+1,J,AIND), LDA1, CS1, SN1 ) TEMP = A(J+1,J+1,AIND) CALL DLARTG( TEMP, -A(J+1,J,AIND), CS1, SN1, $ A(J+1,J+1,AIND) ) A(J+1,J,AIND) = ZERO CALL DROT( J+1-IFRSTM, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) END IF IF ( LCMPQ ) THEN QI = IWORK(MAPQ+L) ELSE IF ( LPARQ ) THEN QI = ABS( QIND(IWORK(MAPQ+L)) ) END IF IF ( QI.NE.0 ) $ CALL DROT( N, Q(1,J,QI), 1, Q(1,J+1,QI), 1, CS1, SN1 ) 520 CONTINUE AIND = IWORK(MAPA+1) CALL DROT( ILASTM-IFRSTM+1, A(IFRSTM,J,AIND), 1, $ A(IFRSTM,J+1,AIND), 1, CS1, SN1 ) C C End of iteration loop. C 530 CONTINUE 540 CONTINUE C C Drop through = non-convergence. C INFO = ILAST GO TO 580 C C Successful completion of all QZ steps. C 550 CONTINUE C C Set eigenvalues 1:ILO-1. C DO 560 J = 1, ILO - 1 CALL MA01BD( BASE, LGBAS, K, S, A(J,J,1), LDA1*LDA2, ALPHAR(J), $ BETA(J), SCAL(J) ) ALPHAI(J) = ZERO 560 CONTINUE C C Store information about the splitted 2-by-2 blocks and possible C loss of accuracy. C DO 570 I = 2, N + 1 IWORK(I) = IWORK(2*K+I-1) 570 CONTINUE C 580 CONTINUE C DO 590 L = K + 1, 2, -1 DWORK(PNORM+L) = DWORK(PNORM+L-1) 590 CONTINUE C DWORK(1) = DBLE( OPTDW ) IWORK(1) = OPTIW C RETURN C *** Last line of MB03BD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04BZ.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04BZ.f0000644000175000017500000010325315012430707017373 0ustar00lilgelilge00000000000000 SUBROUTINE MB04BZ( JOB, COMPQ, N, A, LDA, DE, LDDE, B, LDB, FG, $ LDFG, Q, LDQ, ALPHAR, ALPHAI, BETA, IWORK, $ DWORK, LDWORK, ZWORK, LZWORK, BWORK, INFO ) C C PURPOSE C C To compute the eigenvalues of a complex N-by-N skew-Hamiltonian/ C Hamiltonian pencil aS - bH, with C C ( A D ) ( B F ) C S = ( H ) and H = ( H ). (1) C ( E A ) ( G -B ) C C This routine computes the eigenvalues using an embedding to a real C skew-Hamiltonian/skew-Hamiltonian pencil aB_S - bB_T, defined as C C ( Re(A) -Im(A) | Re(D) -Im(D) ) C ( | ) C ( Im(A) Re(A) | Im(D) Re(D) ) C ( | ) C B_S = (-----------------+-----------------) , and C ( | T T ) C ( Re(E) -Im(E) | Re(A ) Im(A ) ) C ( | T T ) C ( Im(E) Re(E) | -Im(A ) Re(A ) ) C (2) C ( -Im(B) -Re(B) | -Im(F) -Re(F) ) C ( | ) C ( Re(B) -Im(B) | Re(F) -Im(F) ) C ( | ) C B_T = (-----------------+-----------------) , T = i*H. C ( | T T ) C ( -Im(G) -Re(G) | -Im(B ) Re(B ) ) C ( | T T ) C ( Re(G) -Im(G) | -Re(B ) -Im(B ) ) C C Optionally, if JOB = 'T', the pencil aB_S - bB_H (B_H = -i*B_T) is C transformed by a unitary matrix Q to the structured Schur form C C ( BA BD ) ( BB BF ) C B_Sout = ( H ) and B_Hout = ( H ), (3) C ( 0 BA ) ( 0 -BB ) C C where BA and BB are upper triangular, BD is skew-Hermitian, and C BF is Hermitian. The embedding doubles the multiplicities of the C eigenvalues of the pencil aS - bH. Optionally, if COMPQ = 'C', the C unitary matrix Q is computed. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; S and H will not C necessarily be transformed as in (3). C = 'T': put S and H into the forms in (3) and return the C eigenvalues in ALPHAR, ALPHAI and BETA. C C COMPQ CHARACTER*1 C Specifies whether to compute the unitary transformation C matrix Q, as follows: C = 'N': Q is not computed; C = 'C': compute the unitary transformation matrix Q. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) COMPLEX*16 array, dimension (LDA, K) C where K = N/2, if JOB = 'E', and K = N, if JOB = 'T'. C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix A. C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the upper triangular matrix BA in (3) (see C also METHOD). The strictly lower triangular part is not C zeroed, but it is preserved. C If JOB = 'E', this array is unchanged on exit. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, K). C C DE (input/output) COMPLEX*16 array, dimension C (LDDE, MIN(K+1,N)) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C skew-Hermitian matrix E, and the N/2-by-N/2 upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array must contain the upper triangular part of C the skew-Hermitian matrix D. C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the skew-Hermitian matrix BD in (3) (see C also METHOD). The strictly lower triangular part of the C input matrix is preserved. C If JOB = 'E', this array is unchanged on exit. C C LDDE INTEGER C The leading dimension of the array DE. LDDE >= MAX(1, K). C C B (input/output) COMPLEX*16 array, dimension (LDB, K) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the upper triangular matrix BB in (3) (see C also METHOD). The strictly lower triangular part is not C zeroed; the elements below the first subdiagonal of the C input matrix are preserved. C If JOB = 'E', this array is unchanged on exit. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, K). C C FG (input/output) COMPLEX*16 array, dimension C (LDFG, MIN(K+1,N)) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C Hermitian matrix G, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C Hermitian matrix F. C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the Hermitian matrix BF in (3) (see also C METHOD). The strictly lower triangular part of the input C matrix is preserved. The diagonal elements might have tiny C imaginary parts. C If JOB = 'E', this array is unchanged on exit. C C LDFG INTEGER C The leading dimension of the array FG. LDFG >= MAX(1, K). C C Q (output) COMPLEX*16 array, dimension (LDQ, 2*N) C On exit, if COMPQ = 'C', the leading 2*N-by-2*N part of C this array contains the unitary transformation matrix Q C that reduced the matrices B_S and B_H to the form in (3). C However, if JOB = 'E', the reduction was possibly not C completed: the matrix B_H may have 2-by-2 diagonal blocks, C and the array Q returns the orthogonal matrix that C performed the partial reduction. C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, 2*N), if COMPQ = 'C'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C C Workspace C C IWORK INTEGER array, dimension (2*N+4) C On exit, IWORK(1) contains the number, q, of unreliable, C possibly inaccurate (pairs of) eigenvalues, and the C absolute values in IWORK(2), ..., IWORK(q+1) are their C indices, as well as of the corresponding 1-by-1 and 2-by-2 C diagonal blocks of the arrays B and A on exit, if C JOB = 'T'. Specifically, a positive value is an index of C a real or purely imaginary eigenvalue, corresponding to a C 1-by-1 block, while the absolute value of a negative entry C in IWORK is an index to the first eigenvalue in a pair of C consecutively stored eigenvalues, corresponding to a C 2-by-2 block. Moreover, IWORK(q+2),..., IWORK(2*q+1) C contain pointers to the starting elements in DWORK where C each block pair is stored. Specifically, if IWORK(i+1) > 0 C then DWORK(r) and DWORK(r+1) store corresponding diagonal C elements of T11 and S11, respectively, and if C IWORK(i+1) < 0, then DWORK(r:r+3) and DWORK(r+4:r+7) store C the elements of the block in T11 and S11, respectively C (see Section METHOD), where r = IWORK(q+1+i). Moreover, C IWORK(2*q+2) contains the number of the 1-by-1 blocks, and C IWORK(2*q+3) contains the number of the 2-by-2 blocks, C corresponding to unreliable eigenvalues. IWORK(2*q+4) C contains the total number t of the 2-by-2 blocks. C If INFO = 0, then q = 0, therefore IWORK(1) = 0. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or INFO = 3, DWORK(1) returns the C optimal LDWORK, and DWORK(2) and DWORK(3) contain the C Frobenius norms of the matrices B_S and B_T. These norms C are used in the tests to decide that some eigenvalues are C considered as numerically unreliable. Moreover, DWORK(4), C ..., DWORK(3+2*s) contain the s pairs of values of the C 1-by-1 diagonal elements of T11 and S11. The eigenvalue of C such a block pair is obtained from -i*T11(i,i)/S11(i,i). C Similarly, DWORK(4+2*s), ..., DWORK(3+2*s+8*t) contain the C t groups of pairs of 2-by-2 diagonal submatrices of T11 C and S11, stored column-wise. The spectrum of such a block C pair is obtained from -i*ev, where ev are the eigenvalues C of (T11(i:i+1,i:i+1),S11(i:i+1,i:i+1)). C On exit, if INFO = -19, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. If COMPQ = 'N', C LDWORK >= MAX( 3, 4*N*N + 3*N ), if JOB = 'E'; C LDWORK >= MAX( 3, 5*N*N + 3*N ), if JOB = 'T'; C LDWORK >= MAX( 3, 11*N*N + 2*N ), if COMPQ = 'C'. C For good performance LDWORK should be generally 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 ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal LZWORK. C On exit, if INFO = -21, ZWORK(1) returns the minimum value C of LZWORK. C C LZWORK INTEGER C The dimension of the array ZWORK. C LZWORK >= 1, if JOB = 'E'; otherwise, C LZWORK >= 6*N + 4, if COMPQ = 'N'; C LZWORK >= 8*N + 4, if COMPQ = 'C'. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK C is issued by XERBLA. C C BWORK LOGICAL array, dimension (LBWORK) C LBWORK >= 0, if JOB = 'E'; C LBWORK >= N, if JOB = 'T'. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: QZ iteration failed in the SLICOT Library routine C MB04FD (QZ iteration did not converge or computation C of the shifts failed); C = 2: QZ iteration failed in the LAPACK routine ZHGEQZ when C trying to triangularize the 2-by-2 blocks; C = 3: warning: the pencil is numerically singular. C C METHOD C C First, T = i*H is set. Then, the embeddings, B_S and B_T, of the C matrices S and T, are determined and, subsequently, the SLICOT C Library routine MB04FD is applied to compute the structured Schur C form, i.e., the factorizations C C ~ T T ( S11 S12 ) C B_S = J Q J B_S Q = ( T ) and C ( 0 S11 ) C C ~ T T ( T11 T12 ) C B_T = J Q J B_T Q = ( T ), C ( 0 T11 ) C C where Q is real orthogonal, S11 is upper triangular, and T11 is C upper quasi-triangular. If JOB = 'T', then the matrices above are C ~ C further transformed so that the 2-by-2 blocks in i*B_T are split C into 1-by-1 blocks. If COMPQ = 'C', the transformations are C accumulated in the unitary matrix Q. C See also page 22 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C complex floating point operations. C C FURTHER COMMENTS C C The returned eigenvalues are those of the pencil (-i*T11,S11), C where i is the purely imaginary unit. C C If JOB = 'E', the returned matrix T11 is quasi-triangular. Note C that the off-diagonal elements of the 2-by-2 blocks of S11 are C zero by construction. C C If JOB = 'T', the returned eigenvalues correspond to the diagonal C elements of BB and BA. C C This routine does not perform any scaling of the matrices. Scaling C might sometimes be useful, and it should be done externally. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Nov. 2011. C C REVISIONS C C V. Sima, July 2012, Sep. 2016, Nov. 2016, Apr. 2020. C C KEYWORDS C C Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian C pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, THREE, ZERO PARAMETER ( ONE = 1.0D+0, THREE = 3.0D+0, ZERO = 0.0D+0 ) COMPLEX*16 CZERO, CONE, CIMAG PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ), $ CIMAG = ( 0.0D+0, 1.0D+0 ) ) C C .. Scalar Arguments .. CHARACTER COMPQ, JOB INTEGER INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK, $ LZWORK, N C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), DWORK( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ), DE( LDDE, * ), $ FG( LDFG, * ), Q( LDQ, * ), ZWORK( * ) C C .. Local Scalars .. LOGICAL LCMPQ, LQUERY, LTRI, UNREL CHARACTER*14 CMPQ, JOBF INTEGER I, I1, IA, IB, IDE, IEV, IFG, IQ, IQ2, IQB, IS, $ IW, IW1, IWRK, J, J1, J2, JM1, JP2, K, L, M, $ MINDB, MINDW, MINZW, N2, NB, NC, NN, OPTDW, $ OPTZW DOUBLE PRECISION NRMBS, NRMBT COMPLEX*16 TMP C C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C C .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DSCAL, MB04FD, XERBLA, ZGEMM, $ ZGEQRF, ZHGEQZ, ZLACPY, ZSCAL C C .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 NN = N*N N2 = 2*N LTRI = LSAME( JOB, 'T' ) LCMPQ = LSAME( COMPQ, 'C' ) C IF( LTRI ) THEN K = N ELSE K = M END IF C IF( N.EQ.0 ) THEN MINDW = 3 MINZW = 1 ELSE IF( LCMPQ ) THEN MINDB = 8*NN + N2 MINDW = 11*NN + N2 MINZW = 8*N + 4 ELSE MINDB = 4*NN + N2 IF( LTRI ) THEN MINDW = 5*NN + 3*N ELSE MINDW = 4*NN + 3*N END IF MINZW = 6*N + 4 END IF C LQUERY = LDWORK.EQ.-1 .OR. LZWORK.EQ.-1 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, K ) ) THEN INFO = -5 ELSE IF( LDDE.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, K ) ) THEN INFO = -9 ELSE IF( LDFG.LT.MAX( 1, K ) ) THEN INFO = -11 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N2 ) ) THEN INFO = -13 ELSE IF( .NOT. LQUERY ) THEN IF( LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -19 ELSE IF( LZWORK.LT.MINZW ) THEN ZWORK( 1 ) = MINZW INFO = -21 END IF END IF C IF( INFO.NE.0) THEN CALL XERBLA( 'MB04BZ', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN C C Compute optimal workspace. C OPTZW = MINZW IF( LCMPQ ) THEN CMPQ = 'Initialize' ELSE CMPQ = 'No Computation' END IF C IF( LTRI ) THEN JOBF = 'Triangularize' CALL ZGEQRF( N, N, ZWORK, N, ZWORK, ZWORK, -1, INFO ) I = INT( ZWORK( 1 ) ) NB = MAX( I/N, 2 ) ELSE JOBF = 'Eigenvalues' END IF C IF( LQUERY ) THEN CALL MB04FD( JOBF, CMPQ, N2, DWORK, N, DWORK, N, DWORK, N, $ DWORK, N, DWORK, N2, ALPHAI, ALPHAR, BETA, $ IWORK, DWORK, -1, INFO ) OPTDW = MAX( MINDW, MINDB + INT( DWORK( 1 ) ) ) DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW RETURN END IF ELSE IF( LQUERY ) THEN DWORK( 1 ) = MINDW ZWORK( 1 ) = MINZW RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IWORK( 1 ) = 0 DWORK( 1 ) = THREE DWORK( 2 ) = ZERO DWORK( 3 ) = ZERO ZWORK( 1 ) = CONE RETURN END IF C C Set up the embeddings of the matrices S and H. C C Set the pointers for the inputs and outputs of MB04FD. C Real workspace: need 4*N**2 + 2*N, if COMPQ = 'N'; C 8*N**2 + 2*N, if COMPQ = 'C'. C IQ = 1 IF( LCMPQ ) THEN IA = IQ + N2*N2 ELSE IA = 1 END IF C IDE = IA + NN IB = IDE + NN + N IFG = IB + NN IWRK = IFG + NN + N C C Build the embedding of A. C IW = IA IS = IW + N*M DO 30 J = 1, M IW1 = IW DO 10 I = 1, M DWORK( IW ) = DBLE( A( I, J ) ) IW = IW + 1 10 CONTINUE C DO 20 I = 1, M DWORK( IW ) = DIMAG( A( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 20 CONTINUE CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IS = IS + M 30 CONTINUE C C Build the embedding of D and E. C IW = IDE DO 60 J = 1, M + 1 DO 40 I = 1, M DWORK( IW ) = DBLE( DE( I, J ) ) IW = IW + 1 40 CONTINUE C IW = IW + J - 1 IS = IW DO 50 I = J, M DWORK( IW ) = DIMAG( DE( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 50 CONTINUE 60 CONTINUE C IW1 = IW I1 = IW DO 80 J = 2, M + 1 IS = I1 I1 = I1 + 1 DO 70 I = 1, J - 1 DWORK( IW ) = -DIMAG( DE( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 70 CONTINUE IW = IW + N - J + 1 80 CONTINUE CALL DLACPY( 'Full', M, M+1, DWORK( IDE ), N, DWORK( IW1-M ), N ) C C Build the embedding of B. C IW = IB IS = IW + N*M DO 110 J = 1, M IW1 = IW DO 90 I = 1, M DWORK( IW ) = -DIMAG( B( I, J ) ) IW = IW + 1 90 CONTINUE C DO 100 I = 1, M DWORK( IW ) = DBLE( B( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 100 CONTINUE CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IS = IS + M 110 CONTINUE C C Build the embedding of F and G. C IW = IFG DO 140 J = 1, M + 1 DO 120 I = 1, M DWORK( IW ) = -DIMAG( FG( I, J ) ) IW = IW + 1 120 CONTINUE C IW = IW + J - 1 IS = IW DO 130 I = J, M DWORK( IW ) = DBLE( FG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 130 CONTINUE 140 CONTINUE C IW1 = IW I1 = IW DO 160 J = 2, M + 1 IS = I1 I1 = I1 + 1 DO 150 I = 1, J - 1 DWORK( IW ) = -DBLE( FG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 150 CONTINUE IW = IW + N - J + 1 160 CONTINUE CALL DLACPY( 'Full', M, M+1, DWORK( IFG ), N, DWORK( IW1-M ), N ) C C STEP 1: Apply MB04FD to transform the extended pencil to real C skew-Hamiltonian/skew-Hamiltonian Schur form. C C Real workspace: C need 4*N*N + 2*N + max(3,N), if JOB = 'E' and COMPQ = 'N'; C 4*N*N + 2*N + max(3,N*N+N), if JOB = 'T' and COMPQ = 'N'; C 11*N*N + 2*N, if COMPQ = 'C'. C prefer larger. C CALL MB04FD( JOBF, CMPQ, N2, DWORK( IA ), N, DWORK( IDE ), N, $ DWORK( IB ), N, DWORK( IFG ), N, DWORK( IQ ), N2, $ ALPHAI, ALPHAR, BETA, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) IF( INFO.EQ.1 ) THEN RETURN ELSE IF( INFO.EQ.2 ) THEN INFO = 3 END IF OPTDW = MAX( MINDW, MINDB + INT( DWORK( IWRK ) ) ) NRMBS = DWORK( IWRK+1 ) NRMBT = DWORK( IWRK+2 ) C C Scale the eigenvalues. C CALL DSCAL( N, -ONE, ALPHAI, 1 ) C IF( LCMPQ ) THEN C C Set the transformation matrix. C IW = IQ DO 180 J = 1, N2 DO 170 I = 1, N2 Q( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 170 CONTINUE 180 CONTINUE END IF C C Count the numbers of pairs of diagonal 1-by-1 and 2-by-2 blocks of C B and A with possibly unreliable eigenvalues. C I = IWORK( 1 ) IS = 0 IW = 0 DO 190 J = 1, I IF( IWORK( J+1 ).GT.0 ) THEN IS = IS + 1 ELSE IF( IWORK( J+1 ).LT.0 ) THEN IW = IW + 1 END IF 190 CONTINUE C I = 2*I + 2 IWORK( I ) = IS IWORK( I+1 ) = IW C IF( LTRI ) THEN C C Convert the results to complex datatype. D and F start in the C first column of DE and FG, respectively. C IW = IA DO 210 J = 1, N DO 200 I = 1, J A( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 200 CONTINUE IW = IW + N - J 210 CONTINUE C IW = IDE + N DO 230 J = 1, N DO 220 I = 1, J - 1 DE( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 220 CONTINUE DE( J, J ) = CZERO IW = IW + N - J + 1 230 CONTINUE C IW = IB DO 250 J = 1, N DO 240 I = 1, MIN( J + 1, N ) B( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 240 CONTINUE IW = IW + N - J - 1 250 CONTINUE C IW = IFG + N DO 270 J = 1, N DO 260 I = 1, J - 1 FG( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 260 CONTINUE FG( J, J ) = CZERO IW = IW + N - J + 1 270 CONTINUE C END IF C C Count the number of diagonal 2-by-2 blocks of B and A. C I1 = 0 I = 1 C WHILE( I.LT.N ) DO 280 CONTINUE IF ( I.LT.N ) THEN IF( ALPHAR( I ).NE.ZERO .AND. BETA( I ).NE.ZERO .AND. $ ALPHAR( I ).NE.ZERO ) THEN I1 = I1 + 1 I = I + 2 ELSE I = I + 1 END IF GO TO 280 END IF C END WHILE 280 C I = 2*IWORK( 1 ) + 4 IWORK( I ) = I1 C C Save in DWORK the pairs of diagonal 1-by-1 and 2-by-2 blocks of C B and A. Also, save in IWORK the pointers to the starting element C of each pair corresponding to unreliable eigenvalues. C CALL DCOPY( N, DWORK( IA ), N+1, DWORK( IFG ), 1 ) DWORK( 1 ) = OPTDW DWORK( 2 ) = NRMBS DWORK( 3 ) = NRMBT C K = 4 I = 1 IW = IWORK( 1 ) J = 1 L = ( N - 2*I1 )*2 + K C WHILE( I.LE.N ) DO 290 CONTINUE IF ( I.LE.N ) THEN IF ( J.LE.IW ) $ UNREL = I.EQ.ABS( IWORK( J+1 ) ) IF( ALPHAR( I ).NE.ZERO .AND. BETA( I ).NE.ZERO .AND. $ ALPHAI( I ).NE.ZERO ) THEN IF ( UNREL ) THEN J = J + 1 IWORK( J+IW ) = L UNREL = .FALSE. END IF CALL DLACPY( 'Full', 2, 2, DWORK( IB+(I-1)*(N+1) ), N, $ DWORK( L ), 2 ) L = L + 4 CALL DCOPY( 2, DWORK( IFG+I-1 ), 1, DWORK( L ), 3 ) DWORK( L+1 ) = ZERO DWORK( L+2 ) = ZERO L = L + 4 I = I + 2 ELSE IF ( UNREL ) THEN J = J + 1 IWORK( J+IW ) = K UNREL = .FALSE. END IF DWORK( K ) = DWORK( IB+(I-1)*(N+1) ) DWORK( K+1 ) = DWORK( IFG+I-1 ) K = K + 2 I = I + 1 END IF GO TO 290 END IF C END WHILE 290 C IF( .NOT.LTRI ) THEN C C Return. C ZWORK( 1 ) = OPTZW RETURN END IF C C Triangularize the 2-by-2 diagonal blocks in B using the complex C version of the QZ algorithm. C C Set up pointers on the outputs of ZHGEQZ. C A block algorithm is used for large N. C IQ2 = 1 IEV = 5 IQ = 9 IWRK = IQ + 4*( N - 1 ) C J = 1 J1 = 1 J2 = MIN( N, NB ) C WHILE( J.LT.N ) DO 300 CONTINUE IF( J.LT.N ) THEN IF( B( J+1, J ).NE.CZERO ) THEN C C Triangularization step. C Complex workspace: need 4*N + 6. C Real workspace: need 4*N + 5. C NC = MAX( J2-J-1, 0 ) JM1 = MAX( J-1, 1 ) JP2 = MIN( J+2, N ) TMP = A( J+1, J ) A( J+1, J ) = CZERO CALL ZHGEQZ( 'Schur Form', 'Initialize', 'Initialize', 2, 1, $ 2, B( J, J ), LDB, A( J, J ), LDA, $ ZWORK( IEV ), ZWORK( IEV+2 ), ZWORK( IQ ), 2, $ ZWORK( IQ2 ), 2, ZWORK( IWRK ), LZWORK-IWRK+1, $ DWORK( 4*N+4 ), IW ) A( J+1, J ) = TMP IF( IW.GT.0 ) THEN INFO = 2 RETURN END IF C C Update A, DE, B, and FG. C Complex workspace: need 6*N + 4. C C Update A. C CALL ZGEMM( 'No Transpose', 'No Transpose', J-1, 2, 2, $ CONE, A( 1, J ), LDA, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), JM1 ) CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, A( 1, J ), $ LDA ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, NC, $ 2, CONE, ZWORK( IQ ), 2, A( J, JP2 ), LDA, $ CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, A( J, JP2 ), $ LDA ) C C Update DE. C TMP = DE( J+1, J ) DE( J+1, J ) = -DE( J, J+1 ) CALL ZGEMM( 'No Transpose', 'No Transpose', J+1, 2, 2, $ CONE, DE( 1, J ), LDDE, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), J+1 ) CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, DE( 1, J ), $ LDDE ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ J2-J+1, 2, CONE, ZWORK( IQ ), 2, DE( J, J ), $ LDDE, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2, $ DE( J, J ), LDDE ) DE( J+1, J ) = TMP C C Update B. C CALL ZGEMM( 'No Transpose', 'No Transpose', J-1, 2, 2, $ CONE, B( 1, J ), LDB, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), JM1 ) CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, B( 1, J ), $ LDB ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, NC, $ 2, CONE, ZWORK( IQ ), 2, B( J, JP2 ), LDB, $ CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, B( J, JP2 ), $ LDB ) C C Update FG. C TMP = FG( J+1, J ) FG( J+1, J ) = -FG( J, J+1 ) CALL ZGEMM( 'No Transpose', 'No Transpose', J+1, 2, 2, $ CONE, FG( 1, J ), LDFG, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), J+1 ) CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, FG( 1, J ), $ LDFG ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ J2-J+1, 2, CONE, ZWORK( IQ ), 2, FG( J, J ), $ LDFG, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2, $ FG( J, J ), LDFG ) FG( J+1, J ) = TMP C IF( LCMPQ ) THEN C C Update Q. C Complex workspace: need 8*N + 4. C CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, $ CONE, Q( 1, J ), LDQ, ZWORK( IQ2 ), 2, $ CZERO, ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, Q( 1, J ), $ LDQ ) CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, $ CONE, Q( 1, N+J ), LDQ, ZWORK( IQ ), 2, $ CZERO, ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, $ Q( 1, N+J ), LDQ ) END IF C BWORK( J ) = .TRUE. J = J + 2 IQ = IQ + 4 ELSE BWORK( J ) = .FALSE. B( J+1, J ) = CZERO J = J + 1 END IF C IF( J.GE.J2 ) THEN J1 = J2 + 1 J2 = MIN( N, J1 + NB - 1 ) NC = J2 - J1 + 1 C C Update the columns J1 to J2 of A, DE, B, and FG for previous C transformations. C I = 1 IQB = 9 C WHILE( I.LT.J ) DO 310 CONTINUE IF( I.LT.J ) THEN IF( BWORK( I ) ) THEN CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, A( I, J1 ), $ LDA, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ A( I, J1 ), LDA ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, $ DE( I, J1 ), LDDE, CZERO, ZWORK( IWRK ), $ 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ DE( I, J1 ), LDDE ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, B( I, J1 ), $ LDB, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ B( I, J1 ), LDB ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, $ FG( I, J1 ), LDFG, CZERO, ZWORK( IWRK ), $ 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ FG( I, J1 ), LDFG ) IQB = IQB + 4 C I = I + 2 ELSE I = I + 1 END IF GO TO 310 END IF C END WHILE 310 END IF GO TO 300 END IF C END WHILE 300 C C Scale B and FG by -i. C DO 320 I = 1, N CALL ZSCAL( I, -CIMAG, B( 1, I ), 1 ) 320 CONTINUE C DO 330 I = 1, N CALL ZSCAL( I, -CIMAG, FG( 1, I ), 1 ) 330 CONTINUE C ZWORK( 1 ) = OPTZW RETURN C *** Last line of MB04BZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03LP.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03LP.f0000644000175000017500000007254415012430707017402 0ustar00lilgelilge00000000000000 SUBROUTINE MB03LP( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG, $ LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA, $ IWORK, LIWORK, DWORK, LDWORK, BWORK, INFO ) C C PURPOSE C C To compute the relevant eigenvalues of a real N-by-N skew- C Hamiltonian/Hamiltonian pencil aS - bH, with C C ( A D ) ( B F ) C S = ( ) and H = ( ), (1) C ( E A' ) ( G -B' ) C C where the notation M' denotes the transpose of the matrix M. C Optionally, if COMPQ = 'C', an orthogonal basis of the right C deflating subspace of aS - bH corresponding to the eigenvalues C with strictly negative real part is computed. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether to compute the right deflating subspace C corresponding to the eigenvalues of aS - bH with strictly C negative real part. C = 'N': do not compute the deflating subspace; C = 'C': compute the deflating subspace and store it in the C leading subarray of Q. C C ORTH CHARACTER*1 C If COMPQ = 'C', specifies the technique for computing an C orthogonal basis of the deflating subspace, as follows: C = 'P': QR factorization with column pivoting; C = 'S': singular value decomposition. C If COMPQ = 'N', the ORTH value is not used. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix A. C On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of C this array contains the upper triangular matrix Aout C (see METHOD); otherwise, it contains the upper triangular C matrix A obtained just before the application of the C periodic QZ algorithm (see SLICOT Library routine MB04BP). C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C DE (input/output) DOUBLE PRECISION array, dimension C (LDDE, N/2+1) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C skew-symmetric matrix E, and the N/2-by-N/2 upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array must contain the upper triangular part of the C skew-symmetric matrix D. C The entries on the diagonal and the first superdiagonal of C this array need not be set, but are assumed to be zero. C On exit, if COMPQ = 'C', the leading N/2-by-N/2 lower C triangular part and the first superdiagonal contain the C transpose of the upper quasi-triangular matrix C2out (see C METHOD), and the (N/2-1)-by-(N/2-1) upper triangular part C of the submatrix in the columns 3 to N/2+1 of this array C contains the strictly upper triangular part of the C skew-symmetric matrix Dout (see METHOD), without the main C diagonal, which is zero. C On exit, if COMPQ = 'N', the leading N/2-by-N/2 lower C triangular part and the first superdiagonal contain the C transpose of the upper Hessenberg matrix C2, and the C (N/2-1)-by-(N/2-1) upper triangular part of the submatrix C in the columns 3 to N/2+1 of this array contains the C strictly upper triangular part of the skew-symmetric C matrix D (without the main diagonal) just before the C application of the periodic QZ algorithm. C C LDDE INTEGER C The leading dimension of the array DE. C LDDE >= MAX(1, N/2). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of C this array contains the upper triangular matrix C1out C (see METHOD); otherwise, it contains the upper triangular C matrix C1 obtained just before the application of the C periodic QZ algorithm. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C FG (input/output) DOUBLE PRECISION array, dimension C (LDFG, N/2+1) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C symmetric matrix G, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C symmetric matrix F. C On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of C the submatrix in the columns 2 to N/2+1 of this array C contains the matrix Vout (see METHOD); otherwise, it C contains the matrix V obtained just before the application C of the periodic QZ algorithm. C C LDFG INTEGER C The leading dimension of the array FG. C LDFG >= MAX(1, N/2). C C NEIG (output) INTEGER C If COMPQ = 'C', the number of eigenvalues in aS - bH with C strictly negative real part. C C Q (output) DOUBLE PRECISION array, dimension (LDQ, 2*N) C On exit, if COMPQ = 'C', the leading N-by-NEIG part of C this array contains an orthogonal basis of the right C deflating subspace corresponding to the eigenvalues of C aA - bB with strictly negative real part. The remaining C part of this array is used as workspace. C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, 2*N), if COMPQ = 'C'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C Due to the skew-Hamiltonian/Hamiltonian structure of the C pencil, for every eigenvalue lambda, -lambda is also an C eigenvalue, and thus it has only to be saved once in C ALPHAR, ALPHAI and BETA. C Specifically, only eigenvalues with imaginary parts C greater than or equal to zero are stored; their conjugate C eigenvalues are not stored. If imaginary parts are zero C (i.e., for real eigenvalues), only positive eigenvalues C are stored. The remaining eigenvalues have opposite signs. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = -19, IWORK(1) returns the minimum value C of LIWORK. C C LIWORK INTEGER C The dimension of the array IWORK. LIWORK = 1, if N = 0, C LIWORK >= MAX( N + 12, 2*N + 3 ), if COMPQ = 'N', C LIWORK >= MAX( 32, 6*N - 3 ), if COMPQ = 'C'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -21, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. LDWORK = 1, if N = 0, C LDWORK >= 3*(N/2)**2 + N**2 + MAX( L, 36 ), C if COMPQ = 'N', C where L = 4*N + 4, if N/2 is even, and C L = 4*N , if N/2 is odd; C LDWORK >= 8*N**2 + MAX( 13*N + 32, 272 ), if COMPQ = 'C'. C For good performance LDWORK should be generally larger. C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C BWORK LOGICAL array, dimension (N/2) C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: periodic QZ iteration failed in the SLICOT Library C routines MB04BP or MB04HD (QZ iteration did not C converge or computation of the shifts failed); C = 2: standard QZ iteration failed in the SLICOT Library C routines MB04HD or MB03DD (called by MB03JP); C = 3: a numerically singular matrix was found in the SLICOT C Library routine MB03HD (called by MB03JP); C = 4: the singular value decomposition failed in the LAPACK C routine DGESVD (for ORTH = 'S'); C = 5: some eigenvalues might be inaccurate. This is a C warning. C C METHOD C C First, the decompositions of S and H are computed via orthogonal C transformations Q1 and Q2 as follows: C C ( Aout Dout ) C Q1' S J Q1 J' = ( ), C ( 0 Aout' ) C C ( Bout Fout ) C J' Q2' J S Q2 = ( ) =: T, (2) C ( 0 Bout' ) C C ( C1out Vout ) ( 0 I ) C Q1' H Q2 = ( ), where J = ( ), C ( 0 C2out' ) ( -I 0 ) C C and Aout, Bout, C1out are upper triangular, C2out is upper quasi- C triangular and Dout and Fout are skew-symmetric. C C Then, orthogonal matrices Q3 and Q4 are found, for the extended C matrices C C ( Aout 0 ) ( 0 C1out ) C Se = ( ) and He = ( ), C ( 0 Bout ) ( -C2out 0 ) C C such that S11 := Q4' Se Q3 is upper triangular and C H11 := Q4' He Q3 is upper quasi-triangular. The following matrices C are computed: C C ( Dout 0 ) ( 0 Vout ) C S12 := Q4' ( ) Q4 and H12 := Q4' ( ) Q4. C ( 0 Fout ) ( Vout' 0 ) C C Then, an orthogonal matrix Q is found such that the eigenvalues C with strictly negative real parts of the pencil C C ( S11 S12 ) ( H11 H12 ) C a ( ) - b ( ) C ( 0 S11' ) ( 0 -H11' ) C C are moved to the top of this pencil. C C Finally, an orthogonal basis of the right deflating subspace C corresponding to the eigenvalues with strictly negative real part C is computed. See also page 12 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C floating point operations. C C FURTHER COMMENTS C C This routine does not perform any scaling of the matrices. Scaling C might sometimes be useful, and it should be done externally. C For large values of N, the routine applies the transformations on C panels of columns. The user may specify in INFO the desired number C of columns. If on entry INFO <= 0, then the routine estimates a C suitable value of this number. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Oct. 2010. C C REVISIONS C C V. Sima, Nov. 2010, Dec. 2010, Mar. 2011, Aug. 2011, Nov. 2011, C Oct. 2012, July 2013, Nov. 2014, June 2015, Jan. 2017, May 2020. C M. Voigt, Jan. 2012. C C KEYWORDS C C Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian C pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) C C .. Scalar Arguments .. CHARACTER COMPQ, ORTH INTEGER INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK, $ LIWORK, N, NEIG C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), DE( LDDE, * ), $ DWORK( * ), FG( LDFG, * ), Q( LDQ, * ) C C .. Local Scalars .. LOGICAL LINIQ, LQUERY, QR, QRP, SVD CHARACTER*14 CMPQ INTEGER IB, IC2, IFO, IH11, IH12, IQ1, IQ2, IQ3, IQ4, $ IRT, IS11, IS12, IW, IWRK, J, M, MINDW, MINIW, $ MM, N2, NB, NM, NMM, NN, OPTDW C C .. Local Arrays .. DOUBLE PRECISION DUM( 3 ) C C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEQP3, DGEQRF, DGESVD, $ DLACPY, DORGQR, DSCAL, DSYR2K, DTRMM, MA02AD, $ MB01KD, MB01LD, MB03JP, MB04BP, MB04HD, XERBLA C C .. Intrinsic Functions .. INTRINSIC INT, MAX, MOD, SQRT C C .. Executable Statements .. C C Decode the input arguments. C Using ORTH = 'Q' is not safe, but sometimes gives better results. C NB = INFO M = N/2 N2 = N*2 NN = N*N MM = M*M NEIG = 0 LINIQ = LSAME( COMPQ, 'C' ) IF( LINIQ ) THEN QR = LSAME( ORTH, 'Q' ) QRP = LSAME( ORTH, 'P' ) SVD = LSAME( ORTH, 'S' ) END IF IF( N.EQ.0 ) THEN MINIW = 1 MINDW = 1 ELSE IF( LINIQ ) THEN MINIW = MAX( 32, 3*N2 - 3 ) MINDW = 8*NN + MAX( 13*N + 32, 272 ) ELSE IF( MOD( M, 2 ).EQ.0 ) THEN J = MAX( 4*N, 32 ) + 4 ELSE J = MAX( 4*N, 36 ) END IF MINIW = MAX( N + 12, N2 + 3 ) MINDW = 3*M**2 + NN + J END IF LQUERY = LDWORK.EQ.-1 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LINIQ ) ) THEN INFO = -1 ELSE IF( LINIQ ) THEN IF( .NOT.( QR .OR. QRP .OR. SVD ) ) $ INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LDDE.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( LDFG.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LDQ.LT.1 .OR. ( LINIQ .AND. LDQ.LT.N2 ) ) THEN INFO = -14 ELSE IF( LIWORK.LT.MINIW ) THEN IWORK( 1 ) = MINIW INFO = -19 ELSE IF( .NOT. LQUERY .AND. LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -21 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03LP', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN C C Compute optimal workspace. C IF( LQUERY ) THEN IF( LINIQ ) THEN CALL MB04HD( 'I', 'I', N, DWORK, N, DWORK, N, DWORK, N, $ DWORK, N, IWORK, LIWORK, DUM, -1, BWORK, $ INFO ) IF( SVD ) THEN CALL DGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, DWORK, $ LDQ, DWORK, 1, DUM( 2 ), -1, INFO ) J = N + INT( DUM( 2 ) ) ELSE IF( QR ) THEN CALL DGEQRF( N, M, Q, LDQ, DWORK, DUM( 2 ), -1, $ INFO ) J = M ELSE CALL DGEQP3( N, N, Q, LDQ, IWORK, DWORK, DUM( 2 ), $ -1, INFO ) J = N END IF CALL DORGQR( N, J, J, Q, LDQ, DWORK, DUM( 3 ), -1, $ INFO ) J = J + MAX( INT( DUM( 2 ) ), INT( DUM( 3 ) ) ) END IF OPTDW = MAX( MINDW, 6*NN + INT( DUM( 1 ) ), J ) ELSE OPTDW = MINDW END IF DWORK( 1 ) = OPTDW RETURN END IF END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK( 1 ) = ONE RETURN END IF C IFO = 1 C C STEP 1: Apply MB04BP to transform the pencil to real C skew-Hamiltonian/Hamiltonian Schur form. C C Set the computation option and pointers for the inputs and outputs C of MB04BP. If possible, array Q is used as vectorized workspace. C C Real workspace: need w1 + w0 + MAX(L,36), where C w1 = 2*N**2, w0 = 2*N**2, if COMPQ = 'C'; C w1 = 3*M**2, w0 = N**2, if COMPQ = 'N'; C L = 4*N + 4, if N/2 is even, and C L = 4*N , if N/2 is odd. C Integer workspace: need MAX(N+12,2*N+3). C INFO = NB IF( LINIQ ) THEN CMPQ = 'Initialize' IQ1 = 1 IQ2 = IQ1 + NN IWRK = IQ2 + NN IF( MOD( M, 4 ).EQ.0 ) THEN IC2 = M/4 ELSE IC2 = INT( M/4 ) + 1 END IF IB = 2*IC2 + 1 IC2 = IC2 + 1 CALL MB04BP( 'Triangularize', CMPQ, CMPQ, N, A, LDA, DE, LDDE, $ B, LDB, FG, LDFG, DWORK( IQ1 ), N, DWORK( IQ2 ), $ N, Q( 1, IB ), M, Q( 1, IFO ), M, Q( 1, IC2 ), M, $ ALPHAR, ALPHAI, BETA, IWORK, LIWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) ELSE CMPQ = 'No Computation' IB = IFO + MM IC2 = IB + MM IWRK = IC2 + MM CALL MB04BP( 'Eigenvalues', CMPQ, CMPQ, N, A, LDA, DE, LDDE, B, $ LDB, FG, LDFG, DWORK, N, DWORK, N, DWORK( IB ), M, $ DWORK( IFO ), M, DWORK( IC2 ), M, ALPHAR, ALPHAI, $ BETA, IWORK, LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) END IF OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C IF( INFO.GT.0 .AND. INFO.LT.3 ) THEN INFO = 1 RETURN ELSE IF( INFO.EQ.3 ) THEN IW = 5 ELSE IW = 0 END IF C IF( .NOT.LINIQ ) THEN CALL MA02AD( 'Upper', M, M, DWORK( IC2 ), M, DE, LDDE ) CALL DCOPY( M-1, DWORK( IC2+1 ), M+1, DE( 1, 2 ), LDDE+1 ) DWORK( 1 ) = OPTDW INFO = IW RETURN END IF C C STEP 2: Build the needed parts of the extended matrices Se and He, C and compute the transformed matrices and the orthogonal matrices C Q3 and Q4. C C Real workspace: need w1 + w2 + 2*N**2 + MAX(M+168,272), with C w2 = 4*N**2 (COMPQ = 'C'); C prefer larger. C Integer workspace: need MAX(M+1,32). C NM = N*M NMM = NM + M IQ3 = IWRK IQ4 = IQ3 + NN IS11 = IQ4 + NN IH11 = IS11 + NN IWRK = IH11 + NN C CALL DLACPY( 'Full', M, M, A, LDA, DWORK( IS11 ), N ) CALL DLACPY( 'Full', M, M, Q( 1, IB ), M, DWORK( IS11+NMM ), N ) CALL DSCAL( MM, -ONE, Q( 1, IC2 ), 1 ) CALL DLACPY( 'Full', M, M, Q( 1, IC2 ), M, DWORK( IH11+M ), N ) CALL DLACPY( 'Full', M, M, B, LDB, DWORK( IH11+NM ), N ) C CALL MB04HD( CMPQ, CMPQ, N, DWORK( IS11 ), N, DWORK( IH11 ), N, $ DWORK( IQ3 ), N, DWORK( IQ4 ), N, IWORK, LIWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO ) IF( INFO.GT.0 ) THEN IF( INFO.GT.2 ) $ INFO = 2 RETURN END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C STEP 3: Update S12 and H12, building the upper triangular parts, C and exploiting the structure. Note that S12 is skew-symmetric and C H12 is symmetric. C C Real workspace: need w1 + w2 + w3, where C w3 = N**2 + M**2. C IS12 = IWRK IH12 = IS12 + NN IWRK = IH12 C IF( M.GT.1 ) THEN C C [ Qa Qc ] C Compute Qa'*Do*Qc + Qb'*Fo*Qd, where Q4 =: [ ], C [ Qb Qd ] C with Do := Dout, etc. C Compute also Qc'*Do*Qc + Qd'*Fo*Qd, using MB01KD. C Part of the array Q and DWORK(IS12) are used as workspace. C CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NM+1 ), N, $ DWORK( IS12 ), M ) CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NM ), N, Q( 2, IB ), $ M ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', M-1, $ M, ONE, DE( 1, 3 ), LDDE, DWORK( IS12 ), M ) C CALL MB01KD( 'Upper', 'Transpose', M, M-1, ONE, $ DWORK( IQ4+NM ), N, DWORK( IS12 ), M, ZERO, $ DWORK( IS12+NMM ), N, INFO ) C CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-Unit', M-1, M, $ -ONE, DE( 1, 3 ), LDDE, Q( 2, IB ), M ) DUM( 1 ) = ZERO CALL DCOPY( M, DUM, 0, DWORK( IS12+M-1 ), M ) CALL DCOPY( M, DUM, 0, Q( 1, IB ), M ) CALL DAXPY( MM, ONE, Q( 1, IB ), 1, DWORK( IS12 ), 1 ) C CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NMM+1 ), N, $ DWORK( IWRK ), M ) CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NMM ), N, Q( 2, IB ), $ M ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', M-1, $ M, ONE, Q( M+1, IFO ), M, DWORK( IWRK ), M ) C CALL MB01KD( 'Upper', 'Transpose', M, M-1, ONE, $ DWORK( IQ4+NMM ), N, DWORK( IWRK ), M, ONE, $ DWORK( IS12+NMM ), N, INFO ) C CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-Unit', M-1, $ M, -ONE, Q( M+1, IFO ), M, Q( 2, IB ), M ) CALL DCOPY( M, DUM, 0, DWORK( IWRK+M-1 ), M ) CALL DAXPY( MM, ONE, Q( 1, IB ), 1, DWORK( IWRK ), 1 ) C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4 ), N, DWORK( IS12 ), M, ZERO, $ DWORK( IS12+NM ), N ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4+M ), N, DWORK( IWRK ), M, ONE, $ DWORK( IS12+NM ), N ) C C Compute Qa'*Do*Qa + Qb'*Fo*Qb. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, $ DWORK( IS12 ), N, DWORK( IQ4 ), N, DE( 1, 2 ), $ LDDE, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) CALL MB01LD( 'Upper', 'Transpose', M, M, ONE, ONE, $ DWORK( IS12 ), N, DWORK( IQ4+M ), N, Q( 1, IFO ), $ M, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) END IF C C Compute Qb'*Vo'*Qc + Qa'*Vo*Qd. C Real workspace: need w1 + w2 + w3, where C w3 = 2*N**2. C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ FG( 1, 2 ), LDFG, DWORK( IQ4+NM ), N, ZERO, $ Q( 1, IFO ), M ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ FG( 1, 2 ), LDFG, DWORK( IQ4 ), N, ZERO, $ DWORK( IH12+NMM ), N ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4+M ), N, Q( 1, IFO ), M, ZERO, $ DWORK( IH12+NM ), N ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IH12+NMM ), N, DWORK( IQ4+NMM ), N, ONE, $ DWORK( IH12+NM ), N ) C C Compute the upper triangle of Qa'*Vo*Qb + (Qa'*Vo*Qb)'. C CALL DSYR2K( 'Upper', 'Transpose', M, M, ONE, DWORK( IH12+NMM ), $ N, DWORK( IQ4+M ), N, ZERO, DWORK( IH12 ), N ) C C Compute the upper triangle of Qc'*Vo*Qd + (Qc'*Vo*Qd)'. C CALL DSYR2K( 'Upper', 'Transpose', M, M, ONE, Q( 1, IFO ), M, $ DWORK( IQ4+NMM ), N, ZERO, DWORK( IH12+NMM ), N ) C C Return C2out. C CALL DSCAL( MM, -ONE, Q( 1, IC2 ), 1 ) CALL MA02AD( 'Upper', M, M, Q( 1, IC2 ), M, DE, LDDE ) CALL DCOPY( M-1, Q( 2, IC2 ), M+1, DE( 1, 2 ), LDDE+1 ) C C STEP 4: Apply MB03JP to reorder the eigenvalues with strictly C negative real part to the top. C C Real workspace: need w1 + w2 + w3 + MAX(8*N+32,108)+5*N, C w3 = 2*N**2. C Integer workspace: need 6*N - 3. C IWRK = IH12 + NN C INFO = NB CALL MB03JP( CMPQ, N2, DWORK( IS11 ), N, DWORK( IS12 ), N, $ DWORK( IH11 ), N, DWORK( IH12 ), N, Q, LDQ, NEIG, $ IWORK, LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN INFO = INFO + 1 RETURN END IF C C STEP 5: Compute the deflating subspace corresponding to the C eigenvalues with strictly negative real part. C C Real workspace: need w2 + 3*N**2, if ORTH = 'QR'; C w2 + 4*N**2, otherwise. C IWRK = IS11 IF( QR ) $ NEIG = NEIG/2 C C Compute [ J*Q1*J' Q2 ]. C CALL DLACPY( 'Full', M, M, DWORK( IQ1+NMM ), N, DWORK( IWRK ), N ) CALL DLACPY( 'Full', M, M, DWORK( IQ1+NM ), N, DWORK( IWRK+M ), $ N ) DO 10 J = 1, M CALL DSCAL( M, -ONE, DWORK( IWRK+M+(J-1)*N ), 1 ) 10 CONTINUE CALL DLACPY( 'Full', M, M, DWORK( IQ1+M ), N, DWORK( IWRK+NM ), $ N ) DO 20 J = 1, M CALL DSCAL( M, -ONE, DWORK( IWRK+NM+(J-1)*N ), 1 ) 20 CONTINUE CALL DLACPY( 'Full', M, M, DWORK( IQ1 ), N, DWORK( IWRK+NMM ), N ) C CALL DLACPY( 'Full', N, N, DWORK( IQ2 ), N, DWORK( IWRK+NN ), N ) C C Compute the first NEIG columns of P*[ Q3 0; 0 Q4 ]*Q. C IRT = IWRK + N*N2 CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ3 ), N, Q, LDQ, ZERO, DWORK( IRT ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ4 ), N, Q( N+1, 1 ), LDQ, ZERO, $ DWORK( IRT+M ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ3+M ), N, Q, LDQ, ZERO, DWORK( IRT+N ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ4+M ), N, Q( N+1, 1 ), LDQ, ZERO, $ DWORK( IRT+N+M ), N2 ) C C Compute the deflating subspace. C CALL DGEMM( 'No Transpose', 'No Transpose', N, NEIG, N2, $ SQRT( TWO )/TWO, DWORK( IWRK ), N, DWORK( IRT ), N2, $ ZERO, Q, LDQ ) C C Orthogonalize the basis given in Q(1:n,1:neig). C IWRK = NEIG + 1 IF( SVD ) THEN C C Real workspace: need N + MAX(1,5*N); C prefer larger. C CALL DGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK, $ DWORK, 1, DWORK, 1, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) IF( INFO.GT.0 ) THEN INFO = 4 RETURN END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) NEIG = NEIG/2 C ELSE IF( QR ) THEN C C Real workspace: need N; C prefer M+M*NB, where NB is the optimal C blocksize. C CALL DGEQRF( N, NEIG, Q, LDQ, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) ELSE C C Real workspace: need 4*N+1; C prefer 3*N+(N+1)*NB. C DO 30 J = 1, NEIG IWORK( J ) = 0 30 CONTINUE CALL DGEQP3( N, NEIG, Q, LDQ, IWORK, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Real workspace: need 2*NEIG; C prefer NEIG + NEIG*NB. C CALL DORGQR( N, NEIG, NEIG, Q, LDQ, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) IF( QRP ) $ NEIG = NEIG/2 END IF C DWORK( 1 ) = OPTDW INFO = IW RETURN C *** Last line of MB03LP *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02OU.f0000644000000000000000000000013015012430707016205 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB02OU.f0000644000175000017500000000323715012430707017410 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION SB02OU( ALPHAR, ALPHAI, BETA ) C C PURPOSE C C To select the unstable generalized eigenvalues for solving the C continuous-time algebraic Riccati equation. C C ARGUMENTS C C Input/Output Parameters C C ALPHAR (input) DOUBLE PRECISION C The real part of the numerator of the current eigenvalue C considered. C C ALPHAI (input) DOUBLE PRECISION C The imaginary part of the numerator of the current C eigenvalue considered. C C BETA (input) DOUBLE PRECISION C The (real) denominator of the current eigenvalue C considered. It is assumed that BETA <> 0 (regular case). C C METHOD C C The function value SB02OU is set to .TRUE. for an unstable C eigenvalue and to .FALSE., otherwise. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. C Supersedes Release 2.0 routine SB02CW by P. Van Dooren, Philips C Research Laboratory, Brussels, Belgium. C C REVISIONS C C - C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, optimal regulator, Schur form. C C ****************************************************************** C DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION ALPHAR, ALPHAI, BETA C .. Executable Statements .. C SB02OU = ( ALPHAR.LT.ZERO .AND. BETA.LT.ZERO ) .OR. $ ( ALPHAR.GT.ZERO .AND. BETA.GT.ZERO ) C RETURN C *** Last line of SB02OU *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01OE.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01OE.f0000644000175000017500000002112215012430707017352 0ustar00lilgelilge00000000000000 SUBROUTINE MB01OE( UPLO, TRANS, N, ALPHA, BETA, R, LDR, H, LDH, E, $ LDE ) C C PURPOSE C C To compute one of the symmetric rank 2k operations C C R := alpha*R + beta*H*E' + beta*E*H', C C or C C R := alpha*R + beta*H'*E + beta*E'*H, C C where alpha and beta are scalars, R, E, and H are N-by-N matrices, C with H upper Hessenberg and E upper triangular. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies which triangle of the symmetric matrix R is C 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 H to be used in the matrix C multiplication as follows: C = 'N': R := alpha*R + beta*H*E' + beta*E*H'; C = 'T': R := alpha*R + beta*H'*E + beta*E'*H; C = 'C': R := alpha*R + beta*H'*E + beta*E'*H. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices R, E, and H. 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 E and H are not C referenced. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) C On entry with 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 R. C On entry with 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 R. C In both cases, the other strictly triangular part is not C referenced. C On exit, the leading N-by-N 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 the computed matrix R. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C H (input) DOUBLE PRECISION array, dimension (LDH,N) C On entry, the leading N-by-N upper Hessenberg part of this C array must contain the upper Hessenberg matrix H. C The remaining part of this array is not referenced. C C LDH INTEGER C The leading dimension of array H. LDH >= MAX(1,N). C C E (input) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the upper triangular matrix E. C The remaining part of this array is not referenced. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). C C METHOD C C E particularization of the algorithm used in the BLAS 3 routine C DSYR2K is used. C C NUMERICAL ASPECTS C C The algorithm requires approximately N**3/3 operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2019. 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, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. C .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER LDE, LDH, LDR, N CHARACTER TRANS, UPLO C .. C .. Array Arguments .. DOUBLE PRECISION E(LDE,*), H(LDH,*), R(LDR,*) C .. C .. Local Scalars .. DOUBLE PRECISION BETA2, TEMP INTEGER I, INFO, J, J1 LOGICAL LTRANS, UPPER C .. C .. Local Arrays .. DOUBLE PRECISION TMP(1) C .. C .. External Functions .. DOUBLE PRECISION DDOT LOGICAL LSAME EXTERNAL DDOT, LSAME C .. C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input parameters. C UPPER = LSAME( UPLO, 'U' ) LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) C INFO = 0 IF ( .NOT.UPPER .AND. .NOT. LSAME( UPLO, 'L' ) ) THEN INFO = 1 ELSE IF ( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LTRANS ) THEN INFO = 2 ELSE IF ( N.LT.0 ) THEN INFO = 3 ELSE IF ( LDR.LT.MAX( 1,N ) ) THEN INFO = 7 ELSE IF ( LDH.LT.MAX( 1,N ) ) THEN INFO = 9 ELSE IF ( LDE.LT.MAX( 1, N ) ) THEN INFO = 11 END IF IF ( INFO.NE.0) THEN CALL XERBLA( 'MB01OE', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. ( BETA.EQ.ZERO .AND. ALPHA.EQ.ONE ) ) $ RETURN C IF ( BETA.EQ.ZERO ) THEN IF ( ALPHA.EQ.ZERO ) THEN C C Special case alpha = 0. C CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) ELSE C C Special case beta = 0. C IF ( ALPHA.NE.ONE ) $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, N, N, R, LDR, INFO ) END IF RETURN END IF C C Start the operations. C IF ( .NOT.LTRANS ) THEN C C Form R := alpha*R + beta*H*E' + beta*E*H'. C IF ( UPPER ) THEN C BETA2 = TWO*BETA IF ( ALPHA.EQ.ZERO ) THEN R(1,1) = ZERO ELSE IF ( ALPHA.NE.ONE ) THEN R(1,1) = ALPHA*R(1,1) END IF C R(1,1) = R(1,1) + BETA2*DDOT( N, H, LDH, E, LDE ) C DO 20 J = 2, N IF ( ALPHA.EQ.ZERO ) THEN TMP(1) = ZERO CALL DCOPY( J, TMP, 0, R(1,J), 1 ) ELSE IF ( ALPHA.NE.ONE ) THEN CALL DSCAL( J, ALPHA, R(1,J), 1 ) END IF C CALL DAXPY( J-1, BETA*H(J,J-1), E(1,J-1), 1, R(1,J), 1 ) C DO 10 I = J, N CALL DAXPY( J, BETA*E(J,I), H(1,I), 1, R(1,J), 1 ) CALL DAXPY( J, BETA*H(J,I), E(1,I), 1, R(1,J), 1 ) 10 CONTINUE C 20 CONTINUE C ELSE C DO 40 J = 1, N IF ( ALPHA.EQ.ZERO ) THEN TMP(1) = ZERO CALL DCOPY( N-J+1, TMP, 0, R(J,J), 1 ) ELSE IF ( ALPHA.NE.ONE ) THEN CALL DSCAL( N-J+1, ALPHA, R(J,J), 1 ) END IF C DO 30 I = J, N - 1 CALL DAXPY( I-J+2, BETA*E(J,I), H(J,I), 1, R(J,J), 1 ) CALL DAXPY( I-J+1, BETA*H(J,I), E(J,I), 1, R(J,J), 1 ) 30 CONTINUE C CALL DAXPY( N-J+1, BETA*E(J,N), H(J,N), 1, R(J,J), 1 ) CALL DAXPY( N-J+1, BETA*H(J,N), E(J,N), 1, R(J,J), 1 ) 40 CONTINUE C END IF C ELSE C C Form R := alpha*R + beta*H'*E + beta*E'*H. C BETA2 = TWO*BETA C IF ( UPPER ) THEN C DO 60 J = 1, N C DO 50 I = 1, J - 1 TEMP = BETA*( DDOT( I+1, H(1,I), 1, E(1,J), 1 ) + $ DDOT( I, E(1,I), 1, H(1,J), 1 ) ) IF ( ALPHA.EQ.ZERO ) THEN R(I,J) = TEMP ELSE R(I,J) = ALPHA*R(I,J) + TEMP END IF 50 CONTINUE C TEMP = BETA2*DDOT( J, H(1,J), 1, E(1,J), 1 ) IF ( ALPHA.EQ.ZERO ) THEN R(J,J) = TEMP ELSE R(J,J) = ALPHA*R(J,J) + TEMP END IF 60 CONTINUE C ELSE C DO 80 J = 1, N C TEMP = BETA2*DDOT( J, H(1,J), 1, E(1,J), 1 ) IF ( ALPHA.EQ.ZERO ) THEN R(J,J) = TEMP ELSE R(J,J) = ALPHA*R(J,J) + TEMP END IF J1 = J + 1 C DO 70 I = J1, N TEMP = BETA*( DDOT( J, H(1,I), 1, E(1,J), 1 ) + $ DDOT( J1, E(1,I), 1, H(1,J), 1 ) ) IF ( ALPHA.EQ.ZERO ) THEN R(I,J) = TEMP ELSE R(I,J) = ALPHA*R(I,J) + TEMP END IF 70 CONTINUE C 80 CONTINUE C END IF C END IF C RETURN C *** Last line of MB01OE *** END control-4.1.2/src/slicot/src/PaxHeaders/BB02AD.f0000644000000000000000000000013215012430707016127 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/BB02AD.f0000644000175000017500000011123315012430707017324 0ustar00lilgelilge00000000000000 SUBROUTINE BB02AD(DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, 1 A, LDA, B, LDB, C, LDC, Q, LDQ, R, LDR, S, LDS, 2 X, LDX, DWORK, LDWORK, INFO) C C PURPOSE C C To generate the benchmark examples for the numerical solution of C discrete-time algebraic Riccati equations (DAREs) of the form C C T T T -1 T T C 0 = A X A - X - (A X B + S) (R + B X B) (B X A + S ) + Q C C as presented in [1]. Here, A,Q,X are real N-by-N matrices, B,S are C N-by-M, and R is M-by-M. The matrices Q and R are symmetric and Q C may be given in factored form C C T C (I) Q = C Q0 C . C C Here, C is P-by-N and Q0 is P-by-P. If R is nonsingular and S = 0, C the DARE can be rewritten equivalently as C C T -1 C 0 = X - A X (I_n + G X) A - Q, C C where I_n is the N-by-N identity matrix and C C -1 T C (II) G = B R B . C C ARGUMENTS C C Mode Parameters C C DEF CHARACTER C This parameter specifies if the default parameters are C to be used or not. C = 'N' or 'n' : The parameters given in the input vectors C xPAR (x = 'D', 'I', 'B', 'CH') are used. C = 'D' or 'd' : The default parameters for the example C are used. C This parameter is not meaningful if NR(1) = 1. C C Input/Output Parameters C C NR (input) INTEGER array, dimension (2) C This array determines the example for which DAREX returns C data. NR(1) is the group of examples. C NR(1) = 1 : parameter-free problems of fixed size. C NR(1) = 2 : parameter-dependent problems of fixed size. C NR(1) = 3 : parameter-free problems of scalable size. C NR(1) = 4 : parameter-dependent problems of scalable size. C NR(2) is the number of the example in group NR(1). C Let NEXi be the number of examples in group i. Currently, C NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1. C 1 <= NR(1) <= 4; C 0 <= NR(2) <= NEXi, where i = NR(1). C C DPAR (input/output) DOUBLE PRECISION array, dimension (4) C Double precision parameter vector. For explanation of the C parameters see [1]. C DPAR(1) defines the parameter 'epsilon' for C examples NR = 2.2,2.3,2.4, the parameter 'tau' C for NR = 2.5, and the 1-by-1 matrix R for NR = 2.1,4.1. C For Example 2.5, DPAR(2) - DPAR(4) define in C consecutive order 'D', 'K', and 'r'. C NOTE that DPAR is overwritten with default values C if DEF = 'D' or 'd'. C C IPAR (input/output) INTEGER array, dimension (3) C On input, IPAR(1) determines the actual state dimension, C i.e., the order of the matrix A as follows: C NR(1) = 1, NR(1) = 2 : IPAR(1) is ignored. C NR = NR(1).NR(2) = 4.1 : IPAR(1) determines the order of C the output matrix A. C NOTE that IPAR(1) is overwritten for Examples 1.1-2.3. For C the other examples, IPAR(1) is overwritten if the default C parameters are to be used. C On output, IPAR(1) contains the order of the matrix A. C C On input, IPAR(2) is the number of colums in the matrix B C and the order of the matrix R (in control problems, the C number of inputs of the system). Currently, IPAR(2) is C fixed for all examples and thus is not referenced on C input. C On output, IPAR(2) is the number of columns of the C matrix B from (I). C C On input, IPAR(3) is the number of rows in the matrix C C (in control problems, the number of outputs of the C system). Currently, IPAR(3) is fixed for all examples C and thus is not referenced on input. C On output, IPAR(3) is the number of rows of the matrix C C from (I). C C NOTE that IPAR(2) and IPAR(3) are overwritten and C IPAR(2) <= IPAR(1) and IPAR(3) <= IPAR(1) for all C examples. C C BPAR (input) LOGICAL array, dimension (7) C This array defines the form of the output of the examples C and the storage mode of the matrices Q, G or R. C BPAR(1) = .TRUE. : Q is returned. C BPAR(1) = .FALSE. : Q is returned in factored form, i.e., C Q0 and C from (I) are returned. C BPAR(2) = .TRUE. : The matrix returned in array Q (i.e., C Q if BPAR(1) = .TRUE. and Q0 if C BPAR(1) = .FALSE.) is stored as full C matrix. C BPAR(2) = .FALSE. : The matrix returned in array Q is C provided in packed storage mode. C BPAR(3) = .TRUE. : If BPAR(2) = .FALSE., the matrix C returned in array Q is stored in upper C packed mode, i.e., the upper triangle C of a symmetric n-by-n matrix is stored C by columns, e.g., the matrix entry C Q(i,j) is stored in the array entry C Q(i+j*(j-1)/2) for i <= j. C Otherwise, this entry is ignored. C BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix C returned in array Q is stored in lower C packed mode, i.e., the lower triangle C of a symmetric n-by-n matrix is stored C by columns, e.g., the matrix entry C Q(i,j) is stored in the array entry C Q(i+(2*n-j)*(j-1)/2) for j <= i. C Otherwise, this entry is ignored. C BPAR(4) = .TRUE. : The product G in (II) is returned. C BPAR(4) = .FALSE. : G is returned in factored form, i.e., C B and R from (II) are returned. C BPAR(5) = .TRUE. : The matrix returned in array R (i.e., C G if BPAR(4) = .TRUE. and R if C BPAR(4) = .FALSE.) is stored as full C matrix. C BPAR(5) = .FALSE. : The matrix returned in array R is C provided in packed storage mode. C BPAR(6) = .TRUE. : If BPAR(5) = .FALSE., the matrix C returned in array R is stored in upper C packed mode (see above). C Otherwise, this entry is ignored. C BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix C returned in array R is stored in lower C packed mode (see above). C Otherwise, this entry is ignored. C BPAR(7) = .TRUE. : The coefficient matrix S of the DARE C is returned in array S. C BPAR(7) = .FALSE. : The coefficient matrix S of the DARE C is not returned. C NOTE that there are no default values for BPAR. If all C entries are declared to be .TRUE., then matrices Q, G or R C are returned in conventional storage mode, i.e., as C N-by-N or M-by-M arrays where the array element Z(I,J) C contains the matrix entry Z_{i,j}. C C CHPAR (output) CHARACTER*255 C On output, this string contains short information about C the chosen example. C C VEC (output) LOGICAL array, dimension (10) C Flag vector which displays the availability of the output C data: C VEC(j), j=1,2,3, refer to N, M, and P, respectively, and C are always .TRUE. C VEC(4) refers to A and is always .TRUE. C VEC(5) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors B C and R from (II) are returned. C VEC(6) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors C C and Q0 from (I) are returned. C VEC(7) refers to Q and is always .TRUE. C VEC(8) refers to R and is always .TRUE. C VEC(9) is .TRUE. if BPAR(7) = .TRUE., i.e., the matrix S C is returned. C VEC(10) refers to X and is .TRUE. if the exact solution C matrix is available. C NOTE that VEC(i) = .FALSE. for i = 1 to 10 if on exit C INFO .NE. 0. C C N (output) INTEGER C The order of the matrices A, X, G if BPAR(4) = .TRUE., and C Q if BPAR(1) = .TRUE. C C M (output) INTEGER C The number of columns in the matrix B (or the dimension of C the control input space of the underlying dynamical C system). C C P (output) INTEGER C The number of rows in the matrix C (or the dimension of C the output space of the underlying dynamical system). C C A (output) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array contains the C coefficient matrix A of the DARE. C C LDA INTEGER C The leading dimension of array A. LDA >= N. C C B (output) DOUBLE PRECISION array, dimension (LDB,M) C If (BPAR(4) = .FALSE.), then the leading N-by-M part C of this array contains the coefficient matrix B of C the DARE. Otherwise, B is used as workspace. C C LDB INTEGER C The leading dimension of array B. LDB >= N. C C C (output) DOUBLE PRECISION array, dimension (LDC,N) C If (BPAR(1) = .FALSE.), then the leading P-by-N part C of this array contains the matrix C of the factored C form (I) of Q. Otherwise, C is used as workspace. C C LDC INTEGER C The leading dimension of array C. LDC >= P. C C Q (output) DOUBLE PRECISION array, dimension (NQ) C If (BPAR(1) = .TRUE.) and (BPAR(2) = .TRUE.), then C NQ = LDQ*N. C IF (BPAR(1) = .TRUE.) and (BPAR(2) = .FALSE.), then C NQ = N*(N+1)/2. C If (BPAR(1) = .FALSE.) and (BPAR(2) = .TRUE.), then C NQ = LDQ*P. C IF (BPAR(1) = .FALSE.) and (BPAR(2) = .FALSE.), then C NQ = P*(P+1)/2. C The symmetric matrix contained in array Q is stored C according to BPAR(2) and BPAR(3). C C LDQ INTEGER C If conventional storage mode is used for Q, i.e., C BPAR(2) = .TRUE., then Q is stored like a 2-dimensional C array with leading dimension LDQ. If packed symmetric C storage mode is used, then LDQ is irrelevant. C LDQ >= N if BPAR(1) = .TRUE.; C LDQ >= P if BPAR(1) = .FALSE.. C C R (output) DOUBLE PRECISION array, dimension (MR) C If (BPAR(4) = .TRUE.) and (BPAR(5) = .TRUE.), then C MR = LDR*N. C IF (BPAR(4) = .TRUE.) and (BPAR(5) = .FALSE.), then C MR = N*(N+1)/2. C If (BPAR(4) = .FALSE.) and (BPAR(5) = .TRUE.), then C MR = LDR*M. C IF (BPAR(4) = .FALSE.) and (BPAR(5) = .FALSE.), then C MR = M*(M+1)/2. C The symmetric matrix contained in array R is stored C according to BPAR(5) and BPAR(6). C C LDR INTEGER C If conventional storage mode is used for R, i.e., C BPAR(5) = .TRUE., then R is stored like a 2-dimensional C array with leading dimension LDR. If packed symmetric C storage mode is used, then LDR is irrelevant. C LDR >= N if BPAR(4) = .TRUE.; C LDR >= M if BPAR(4) = .FALSE.. C C S (output) DOUBLE PRECISION array, dimension (LDS,M) C If (BPAR(7) = .TRUE.), then the leading N-by-M part of C this array contains the coefficient matrix S of the DARE. C C LDS INTEGER C The leading dimension of array S. LDS >= 1, and C LDS >= N if BPAR(7) = .TRUE.. C C X (output) DOUBLE PRECISION array, dimension (LDX,NX) C If an exact solution is available (NR = 1.1,1.3,1.4,2.1, C 2.3,2.4,2.5,4.1), then NX = N and the leading N-by-N part C of this array contains the solution matrix X. C Otherwise, X is not referenced. C C LDX INTEGER C The leading dimension of array X. LDX >= 1, and C LDX >= N if an exact solution is available. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= N*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 : data file could not be opened or had wrong format; C = 2 : division by zero; C = 3 : G can not be computed as in (II) due to a singular R C matrix. This error can only occur if C BPAR(4) = .TRUE.. C C REFERENCES C C [1] Abels, J. and Benner, P. C DAREX - A Collection of Benchmark Examples for Discrete-Time C Algebraic Riccati Equations (Version 2.0). C SLICOT Working Note 1999-16, November 1999. Available from C http://www.win.tue.nl/niconet/NIC2/reports.html. C C This is an updated and extended version of C C [2] Benner, P., Laub, A.J., and Mehrmann, V. C A Collection of Benchmark Examples for the Numerical Solution C of Algebraic Riccati Equations II: Discrete-Time Case. C Technical Report SPC 95_23, Fak. f. Mathematik, C TU Chemnitz-Zwickau (Germany), December 1995. C C FURTHER COMMENTS C C Some benchmark examples read data from the data files provided C with the collection. C C CONTRIBUTOR C C Peter Benner (Universitaet Bremen), November 25, 1999. C C For questions concerning the collection or for the submission of C test examples, please send e-mail to benner@math.uni-bremen.de. C C REVISIONS C C 1999, December 23 (V. Sima). C C KEYWORDS C C Discrete-time algebraic Riccati equation. C C ****************************************************************** C C .. Parameters .. C . # of examples available , # of examples with fixed size. . INTEGER NEX1, NEX2, NEX3, NEX4, NMAX PARAMETER ( NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1 ) PARAMETER ( NMAX = 13 ) DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, FIVE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 1 THREE = 3.0D0, FOUR = 4.0D0, FIVE = 5.0D0 ) C C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDQ, LDR, LDS, LDWORK, LDX, $ M, N, P CHARACTER DEF C C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*), 1 Q(*), R(*), S(LDS,*), X(LDX,*) INTEGER IPAR(3), NR(2) CHARACTER CHPAR*255 LOGICAL BPAR(7), VEC(10) C C .. Local Scalars .. INTEGER I, IOS, ISYMM, J, MSYMM, NSYMM, PSYMM, QDIMM, 1 RDIMM DOUBLE PRECISION ALPHA, BETA, TEMP C C ..Local Arrays .. INTEGER MDEF(2,NMAX), NDEF(4,NMAX), NEX(4), PDEF(2,NMAX) CHARACTER IDENT*4 CHARACTER*255 NOTES(4,NMAX) C C .. External Functions .. C . LAPACK . LOGICAL LSAME EXTERNAL LSAME C C .. External Subroutines .. C . BLAS . EXTERNAL DCOPY, DGEMV, DSPMV, DSPR, DSYMM, DSYRK C . LAPACK . EXTERNAL DLASET, DPPTRF, DPPTRI, DRSCL, XERBLA C . SLICOT . EXTERNAL MA02DD, MA02ED C C .. Intrinsic Functions .. INTRINSIC SQRT C C .. Data Statements .. C . default values for dimensions . DATA NEX /NEX1, NEX2, NEX3, NEX4/ DATA (NDEF(1,I), I = 1, NEX1) /2, 2, 2, 3, 4, 4, 4, 5, 6, 9, 1 11, 13, 26/ DATA (NDEF(2,I), I = 1, NEX2) /2, 2, 2, 3, 4/ DATA (NDEF(4,I), I = 1, NEX4) /100/ DATA (MDEF(1,I), I = 1, NEX1) /1, 2, 1, 2, 2, 2, 4, 2, 2, 3, 1 2, 2, 6/ DATA (MDEF(2,I), I = 1, NEX2) /1, 2, 1, 3, 1/ DATA (PDEF(1,I), I = 1, NEX1) /1, 2, 2, 3, 4, 4, 4, 5, 2, 2, 1 4, 4, 12/ DATA (PDEF(2,I), I = 1, NEX2) /2, 2, 2, 3, 1/ C . comments on examples . DATA (NOTES(1,I), I = 1, 10) / 1'Van Dooren 1981, Ex. II: singular R matrix', 'Ionescu/Weiss 1992 2: singular R matrix, nonzero S matrix', 'Jonckheere 1981: (A,B) co 3ntrollable, no solution X <= 0', 'Sun 1998: R singular, Q non-defi 4nite', 'Ackerson/Fu 1970 : satellite control problem', 'Litkouhi 1 5983 : system with slow and fast modes', 'Lu/Lin 1993, Ex. 4.3', 'G 6ajic/Shen 1993, Section 2.7.4: chemical plant', 'Davison/Wang 1974 7: nonzero S matrix', 'Patnaik et al. 1980: tubular ammonia reactor 8'/ DATA (NOTES(1,I), I = 11, NEX1) / 1'Sima 1996, Sec. 1.2.2: paper machine model error integrators', 'S 2ima 1996, Ex. 2.6: paper machine model with with disturbances', 'P 3ower plant model, Katayama et al., 1985'/ DATA (NOTES(2,I), I = 1, NEX2) / 1'Laub 1979, Ex. 2: uncontrollable-unobservable data', 'Laub 1979, 2Ex. 3: increasingly ill-conditioned R-matrix', 'increasingly bad s 3caled system as eps -> oo','Petkov et. al. 1989 : increasingly bad 4 scaling as eps -> oo', 'Pappas et al. 1980: process control of pa 5per machine'/ DATA (NOTES(4,I), I = 1, NEX4) /'Pappas et al. 1980, Ex. 3'/ C C .. Executable Statements .. C INFO = 0 DO 1 I = 1, 10 VEC(I) = .FALSE. 1 CONTINUE C IF (NR(1) .GE. 3) THEN IF (LSAME(DEF, 'D')) IPAR(1) = NDEF(NR(1),NR(2)) IPAR(2) = 1 IPAR(3) = IPAR(1) ELSE IPAR(1) = NDEF(NR(1),NR(2)) IPAR(2) = MDEF(NR(1),NR(2)) IPAR(3) = PDEF(NR(1),NR(2)) END IF C IF ((NR(1) .GE. 2) .AND. .NOT. ((LSAME(DEF,'D')) .OR. $ (LSAME(DEF,'N')))) THEN INFO = -1 ELSE IF ((NR(1) .LT. 1) .OR. (NR(1) .GT. 4) .OR. (NR(2) .LT. 0) 1 .OR. (NR(2) .GT. NEX(NR(1)))) THEN INFO = -2 ELSE IF (IPAR(1) .LT. 1) THEN INFO = -4 ELSE IF (IPAR(1) .GT. LDA) THEN INFO = -12 ELSE IF (IPAR(1) .GT. LDB) THEN INFO = -14 ELSE IF (IPAR(3) .GT. LDC) THEN INFO = -16 ELSE IF (BPAR(2) .AND. (((.NOT. BPAR(1)) .AND. 1 (IPAR(3) .GT. LDQ)) .OR. (BPAR(1) .AND. 2 (IPAR(1) .GT. LDQ)))) THEN INFO = -18 ELSE IF (BPAR(5) .AND. ((BPAR(4) .AND. (IPAR(1) .GT. LDR)) .OR. 1 ((.NOT. BPAR(4)) .AND. (IPAR(2) .GT. LDR)))) THEN INFO = -20 ELSE IF (LDS .LT. 1 .OR. (BPAR(7) .AND. (IPAR(1) .GT. LDS))) THEN INFO = -22 ELSE IF (LDX .LT. 1) THEN INFO = -24 ELSE IF (((NR(1) .EQ. 1) .AND. ((NR(2) .EQ. 1) .OR. 1 (NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4))) .OR. 2 ((NR(1) .EQ. 2) .AND. ((NR(2). EQ. 1) .OR. 3 (NR(2) .GE. 3))) .OR. (NR(1) .EQ. 4)) THEN C .. solution X available .. IF (IPAR(1) .GT. LDX) THEN INFO = -24 ELSE CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, X, LDX) END IF ELSE IF (LDWORK .LT. N*N) THEN INFO = -26 END IF IF (INFO .NE. 0) THEN CALL XERBLA( 'BB02AD', -INFO ) RETURN END IF C NSYMM = (IPAR(1)*(IPAR(1)+1))/2 MSYMM = (IPAR(2)*(IPAR(2)+1))/2 PSYMM = (IPAR(3)*(IPAR(3)+1))/2 C CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, A, LDA) CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, B, LDB) CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ZERO, C, LDC) CALL DLASET('L', PSYMM, 1, ZERO, ZERO, Q, 1) CALL DLASET('L', MSYMM, 1, ZERO, ZERO, R, 1) IF (BPAR(7)) CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, 1 S, LDS) C IF(NR(1) .EQ. 1) THEN C IF (NR(2) .EQ. 1) THEN A(1,1) = TWO A(2,1) = ONE A(1,2) = -ONE B(1,1) = ONE Q(1) = ONE C(1,2) = ONE R(1) = ZERO CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ONE, X, LDX) IDENT = '0000' C ELSE IF (NR(2) .EQ. 2) THEN A(1,2) = ONE A(2,2) = -ONE B(1,1) = ONE B(2,1) = TWO B(2,2) = ONE R(1) = 9.0D0 R(2) = THREE R(3) = ONE CALL DLASET('A', PSYMM, 1, -FOUR, -FOUR, Q, PSYMM) Q(3) = 7.0D0 CALL DRSCL(MSYMM, 11.0D0, Q, 1) IF (BPAR(7)) THEN S(1,1) = THREE S(2,1) = -ONE S(1,2) = ONE S(2,2) = 7.0D0 END IF IDENT = '0100' C ELSE IF (NR(2) .EQ. 3) THEN A(1,2) = ONE B(2,1) = ONE Q(1) = ONE Q(2) = TWO Q(3) = FOUR X(1,1) = ONE X(2,1) = TWO X(1,2) = TWO X(2,2) = TWO + SQRT(FIVE) IDENT = '0101' C ELSE IF (NR(2) .EQ. 4) THEN A(1,2) = .1000D+00 A(2,3) = .0100D+00 B(1,1) = ONE B(3,2) = ONE R(3) = ONE Q(1) = .1D+06 Q(4) = .1D+04 Q(6) = -.1D+02 X(1,1) = .1D+06 X(2,2) = .1D+04 IDENT = '0100' C ELSE IF (((NR(2) .GE. 5) .AND. (NR(2) .LE. 8)) .OR. 1 (NR(2) .EQ. 10) .OR. (NR(2) .EQ. 11) .OR. 2 (NR(2) .EQ. 13)) THEN IF (NR(2) .LT. 10) THEN WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') 1 'BB02', NR(1), '0', NR(2), '.dat' OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) ELSE WRITE (CHPAR(1:11), '(A,I1,I2,A)') 1 'BB02', NR(1), NR(2), '.dat' OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) END IF IF (IOS .NE. 0) THEN INFO = 1 ELSE IF (.NOT. (NR(2) .EQ. 13)) THEN DO 10 I = 1, IPAR(1) READ (1, FMT = *, IOSTAT = IOS) (A(I,J), J = 1, IPAR(1)) IF (IOS .NE. 0) INFO = 1 10 CONTINUE DO 20 I = 1, IPAR(1) READ (1, FMT = *, IOSTAT = IOS) (B(I,J), J = 1, IPAR(2)) IF (IOS .NE. 0) INFO = 1 20 CONTINUE END IF IF (NR(2) .EQ. 5) THEN Q(1) = .187D1 Q(4) = -.244D0 Q(5) = .744D0 Q(6) = .205D0 Q(8) = .589D0 Q(10) = .1048D1 ELSE IF (NR(2) .EQ. 6) THEN Q(1) = .1D-1 Q(5) = .1D-1 Q(8) = .1D-1 Q(10) = .1D-1 ELSE IF (NR(2) .EQ. 7) THEN CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) C(1,3) = TWO C(1,4) = FOUR C(2,4) = TWO Q(1) = TWO Q(2) = -ONE Q(5) = TWO Q(6) = -ONE Q(8) = TWO ELSE IF (NR(2) .EQ. 10) THEN C(1,1) = ONE C(2,5) = ONE Q(1) = 50.0D0 Q(3) = 50.0D0 ELSE IF (NR(2) .EQ. 11) THEN A(10,10) = ONE A(11,11) = ONE C(1,6) = 15.0D0 C(2,7) = 7.0D0 C(2,8) = -.5357D+01 C(2,9) = -.3943D+01 C(3,10) = ONE C(4,11) = ONE Q(1) = 0.5D0 Q(5) = 5.0D0 Q(8) = 0.5D0 Q(10) = 5.0D0 R(1) = 400.0D0 R(3) = 700.0D0 IDENT = '0000' C ELSE IF (NR(2) .EQ. 13) THEN DO 24 I = 1, IPAR(1)-6 READ (1, FMT = *, IOSTAT = IOS) 1 (A(I,J), J = 1, IPAR(1)-6) IF (IOS .NE. 0) INFO = 1 24 CONTINUE DO 25 I = 1, IPAR(1)-6 READ (1, FMT = *, IOSTAT = IOS) 1 (B(I,J), J = 1, IPAR(2)) IF (IOS .NE. 0) INFO = 1 25 CONTINUE DO 26 I = 1, IPAR(2) READ (1, FMT = *, IOSTAT = IOS) 1 (C(I,J), J = 1, IPAR(1)-6) IF (IOS .NE. 0) INFO = 1 26 CONTINUE DO 27 I = 1, 6 A(20+I,20+I) = ONE C(6+I,20+I) = ONE 27 CONTINUE J = 58 DO 28 I = 7, 12 READ (1, FMT = *, IOSTAT = IOS) Q(J) IF (IOS .NE. 0) INFO = 1 J = J + (13 - I) 28 CONTINUE J = 1 DO 29 I = 1, 6 READ (1, FMT = *, IOSTAT = IOS) R(J) IF (IOS .NE. 0) INFO = 1 J = J + (7 - I) 29 CONTINUE DO 31 I = 1, 6 DO 30 J = 1, 20 A(I+20,J) = -C(I,J) 30 CONTINUE 31 CONTINUE IDENT = '0000' END IF END IF CLOSE(1) IF ((NR(2) .EQ. 5) .OR. (NR(2) .EQ. 6)) THEN IDENT = '0101' ELSE IF ((NR(2) .EQ. 7) .OR. (NR(2) .EQ. 10)) THEN IDENT = '0001' ELSE IF (NR(2) .EQ. 8) THEN IDENT = '0111' END IF C ELSE IF (NR(2). EQ. 9) THEN A(1,2) = ONE A(2,3) = ONE A(4,5) = ONE A(5,6) = ONE B(3,1) = ONE B(6,2) = ONE C(1,1) = ONE C(1,2) = ONE C(2,4) = ONE C(2,5) = -ONE R(1) = THREE R(3) = ONE IF (BPAR(7)) THEN S(1,1) = ONE S(2,1) = ONE S(4,1) = ONE S(5,1) = -ONE END IF IDENT = '0010' ELSE IF (NR(2) .EQ. 12) THEN DO 32 I = 1, 10 A(I,I+1) = ONE 32 CONTINUE A(6,7) = ZERO A(8,9) = ZERO A(12,12) = ONE A(13,13) = ONE A(12,1) = -.3318D+01 A(13,1) = -.15484D+01 A(6,6) = .7788D+00 A(8,7) = -.4724D+00 A(13,7) = .3981D+00 A(8,8) = .13746D+01 A(13,8) = .5113D+00 A(13,9) = .57865D+01 A(11,11) = .8071D+00 B(6,1) = ONE B(8,2) = ONE C(1,1) = .3318D+01 C(2,1) = .15484D+01 C(2,7) = -.3981D+00 C(2,8) = -.5113D+00 C(2,9) = -.57865D+01 C(3,12) = ONE C(4,13) = ONE Q(1) = 0.5D0 Q(5) = 5.0D0 Q(8) = 0.5D0 Q(10) = 5.0D0 R(1) = 400.0D0 R(3) = 700.0D0 IDENT = '0000' END IF C ELSE IF (NR(1) .EQ. 2) THEN IF (NR(2) .EQ. 1) THEN IF (LSAME(DEF, 'D')) DPAR(1) = .1D+07 A(1,1) = FOUR A(2,1) = -.45D1 A(1,2) = THREE A(2,2) = -.35D1 CALL DLASET('A', IPAR(1), IPAR(2), -ONE, ONE, B, LDB) R(1) = DPAR(1) Q(1) = 9.0D0 Q(2) = 6.0D0 Q(3) = FOUR TEMP = (ONE + SQRT(ONE+FOUR*DPAR(1))) / TWO X(1,1) = TEMP*Q(1) X(2,1) = TEMP*Q(2) X(1,2) = X(2,1) X(2,2) = TEMP*Q(3) IDENT = '0100' C ELSE IF (NR(2) .EQ. 2) THEN IF (LSAME(DEF, 'D')) DPAR(1) = .1D+07 IF (DPAR(1) .EQ. ZERO) THEN INFO = 2 ELSE A(1,1) = .9512D0 A(2,2) = .9048D0 CALL DLASET('A', 1, IPAR(2), .4877D1, .4877D1, B, LDB) B(2,1) = -.11895D1 B(2,2) = .3569D1 R(1) = ONE / (THREE*DPAR(1)) R(3) = THREE*DPAR(1) Q(1) = .5D-2 Q(3) = .2D-1 IDENT = '0100' END IF C ELSE IF (NR(2) .EQ. 3) THEN IF (LSAME(DEF,'D')) DPAR(1) = .1D7 A(1,2) = DPAR(1) B(2,1) = ONE X(1,1) = ONE X(2,2) = ONE + DPAR(1)*DPAR(1) IDENT = '0111' C ELSE IF (NR(2) .EQ. 4) THEN IF (LSAME(DEF,'D')) DPAR(1) = .1D7 A(2,2) = ONE A(3,3) = THREE R(1) = DPAR(1) R(4) = DPAR(1) R(6) = DPAR(1) C .. set C = V .. TEMP = TWO/THREE CALL DLASET('A', IPAR(3), IPAR(1), -TEMP, ONE - TEMP, C, LDC) C .. and compute A <- C' A C CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, A, LDA, 1 ZERO, DWORK, IPAR(1)) CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, 1 IPAR(1), ZERO, A, LDA) Q(1) = DPAR(1) Q(4) = DPAR(1) Q(6) = DPAR(1) X(1,1) = DPAR(1) X(2,2) = DPAR(1) * (ONE + SQRT(FIVE)) / TWO X(3,3) = DPAR(1) * (9.0D0 + SQRT(85.0D0)) / TWO CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, X, LDX, 1 ZERO, DWORK, IPAR(1)) CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, 1 IPAR(1), ZERO, X, LDX) IDENT = '1000' C ELSE IF (NR(2) .EQ. 5) THEN IF (LSAME(DEF, 'D')) THEN DPAR(4) = .25D0 DPAR(3) = ONE DPAR(2) = ONE DPAR(1) = .1D9 END IF IF (DPAR(1) .EQ. ZERO) THEN INFO = 2 ELSE TEMP = DPAR(2) / DPAR(1) BETA = DPAR(3) * TEMP ALPHA = ONE - TEMP A(1,1) = ALPHA CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(2,1), 1 LDA) B(1,1) = BETA C(1,4) = ONE R(1) = DPAR(4) IF (BETA .EQ. ZERO) THEN INFO = 2 ELSE CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ONE, X, LDX) BETA = BETA * BETA TEMP = DPAR(4) * (ALPHA + ONE) * (ALPHA - ONE) + BETA X(1,1) = (TEMP + SQRT(TEMP*TEMP + FOUR*BETA*DPAR(4))) X(1,1) = X(1,1) / TWO / BETA END IF IDENT = '0010' END IF END IF C ELSE IF (NR(1) .EQ. 4) THEN IF (NR(2) .EQ. 1) THEN IF (LSAME(DEF,'D')) DPAR(1) = ONE CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(1,2), LDA) B(IPAR(1),1) = ONE R(1) = DPAR(1) DO 40 I = 1, IPAR(1) X(I,I) = DBLE(I) 40 CONTINUE IDENT = '0110' END IF END IF C IF (INFO .NE. 0) GOTO 2001 C .. set up data in required format .. C IF (BPAR(4)) THEN C .. G is to be returned in product form .. RDIMM = IPAR(1) IF (IDENT(4:4) .EQ. '0') THEN C .. invert R using Cholesky factorization, .. CALL DPPTRF('L', IPAR(2), R, INFO) IF (INFO .EQ. 0) THEN CALL DPPTRI('L', IPAR(2), R, INFO) IF (IDENT(1:1) .EQ. '0') THEN C .. B is not identity matrix .. DO 100 I = 1, IPAR(1) CALL DSPMV('L', IPAR(2), ONE, R, B(I,1), LDB, ZERO, 1 DWORK((I-1)*IPAR(1)+1), 1) 100 CONTINUE CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), 1 B(1,1), LDB, ZERO, R, 1) ISYMM = IPAR(1) + 1 DO 110 I = 2, IPAR(1) CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), 1 B(I,1), LDB, ZERO, B(1,1), LDB) CALL DCOPY(IPAR(1) - I + 1, B(1,I), LDB, R(ISYMM), 1) ISYMM = ISYMM + (IPAR(1) - I + 1) 110 CONTINUE END IF ELSE IF (INFO .GT. 0) THEN INFO = 3 GOTO 2001 END IF END IF ELSE C .. R = identity .. IF (IDENT(1:1) .EQ. '0') THEN C .. B not identity matrix .. IF (IPAR(2) .EQ. 1) THEN CALL DLASET('L', NSYMM, 1, ZERO, ZERO, R, 1) CALL DSPR('L', IPAR(1), ONE, B, 1, R) ELSE CALL DSYRK('L', 'N', IPAR(1), IPAR(2), ONE, B, LDB, ZERO, 1 DWORK, IPAR(1)) CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), R) END IF ELSE C .. B = R = identity .. ISYMM = 1 DO 120 I = IPAR(1), 1, -1 R(ISYMM) = ONE ISYMM = ISYMM + I 120 CONTINUE END IF END IF ELSE RDIMM = IPAR(2) IF (IDENT(1:1) .EQ. '1') 1 CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ONE, B, LDB) IF (IDENT(4:4) .EQ. '1') THEN ISYMM = 1 DO 130 I = IPAR(2), 1, -1 R(ISYMM) = ONE ISYMM = ISYMM + I 130 CONTINUE END IF END IF C IF (BPAR(1)) THEN C .. Q is to be returned in product form .. QDIMM = IPAR(1) IF (IDENT(3:3) .EQ. '0') THEN IF (IDENT(2:2) .EQ. '0') THEN C .. C is not identity matrix .. DO 140 I = 1, IPAR(1) CALL DSPMV('L', IPAR(3), ONE, Q, C(1,I), 1, ZERO, 1 DWORK((I-1)*IPAR(1)+1), 1) 140 CONTINUE C .. use Q(1:IPAR(1)) as workspace and compute the first column C of Q at the end .. ISYMM = IPAR(1) + 1 DO 150 I = 2, IPAR(1) CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), 1 C(1,I), 1, ZERO, Q(1), 1) CALL DCOPY(IPAR(1) - I + 1, Q(I), 1, Q(ISYMM), 1) ISYMM = ISYMM + (IPAR(1) - I + 1) 150 CONTINUE CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), 1 C(1,1), 1, ZERO, Q, 1) END IF ELSE C .. Q = identity .. IF (IDENT(2:2) .EQ. '0') THEN C .. C is not identity matrix .. IF (IPAR(3) .EQ. 1) THEN CALL DLASET('L', NSYMM, 1, ZERO, ZERO, Q, 1) CALL DSPR('L', IPAR(1), ONE, C, LDC, Q) ELSE CALL DSYRK('L', 'T', IPAR(1), IPAR(3), ONE, C, LDC, ZERO, 1 DWORK, IPAR(1)) CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) END IF ELSE C .. C = Q = identity .. ISYMM = 1 DO 160 I = IPAR(1), 1, -1 Q(ISYMM) = ONE ISYMM = ISYMM + I 160 CONTINUE END IF END IF ELSE QDIMM = IPAR(3) IF (IDENT(2:2) .EQ. '1') 1 CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ONE, C, LDC) IF (IDENT(3:3) .EQ. '1') THEN ISYMM = 1 DO 170 I = IPAR(3), 1, -1 Q(ISYMM) = ONE ISYMM = ISYMM + I 170 CONTINUE END IF END IF C C .. unpack symmetric matrices if required .. IF (BPAR(2)) THEN ISYMM = (QDIMM * (QDIMM + 1)) / 2 CALL DCOPY(ISYMM, Q, 1, DWORK, 1) CALL MA02DD('Unpack', 'Lower', QDIMM, Q, LDQ, DWORK) CALL MA02ED('Lower', QDIMM, Q, LDQ) ELSE IF (BPAR(3)) THEN CALL MA02DD('Unpack', 'Lower', QDIMM, DWORK, QDIMM, Q) CALL MA02ED('Lower', QDIMM, DWORK, QDIMM) CALL MA02DD('Pack', 'Upper', QDIMM, DWORK, QDIMM, Q) END IF IF (BPAR(5)) THEN ISYMM = (RDIMM * (RDIMM + 1)) / 2 CALL DCOPY(ISYMM, R, 1, DWORK, 1) CALL MA02DD('Unpack', 'Lower', RDIMM, R, LDR, DWORK) CALL MA02ED('Lower', RDIMM, R, LDR) ELSE IF (BPAR(6)) THEN CALL MA02DD('Unpack', 'Lower', RDIMM, DWORK, RDIMM, R) CALL MA02ED('Lower', RDIMM, DWORK, RDIMM) CALL MA02DD('Pack', 'Upper', RDIMM, DWORK, RDIMM, R) END IF C C ...set VEC... VEC(1) = .TRUE. VEC(2) = .TRUE. VEC(3) = .TRUE. VEC(4) = .TRUE. VEC(5) = .NOT. BPAR(4) VEC(6) = .NOT. BPAR(1) VEC(7) = .TRUE. VEC(8) = .TRUE. VEC(9) = BPAR(7) IF (((NR(1) .EQ. 1) .AND. ((NR(2) .EQ. 1) .OR. 1 (NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4))) .OR. 2 ((NR(1) .EQ. 2) .AND. ((NR(2). EQ. 1) .OR. 3 (NR(2) .GE. 3))) .OR. (NR(1) .EQ. 4)) THEN VEC(10) = .TRUE. END IF CHPAR = NOTES(NR(1),NR(2)) N = IPAR(1) M = IPAR(2) P = IPAR(3) C 2001 CONTINUE RETURN C *** Last line of BB02AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04RB.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04RB.f0000644000175000017500000002743415012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE MB04RB( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To reduce a skew-Hamiltonian matrix, C C [ A G ] C W = [ T ] , C [ Q A ] C C where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric C matrices, to Paige/Van Loan (PVL) form. That is, an orthogonal C symplectic matrix U is computed so that C C T [ Aout Gout ] C U W U = [ T ] , C [ 0 Aout ] C C where Aout is in upper Hessenberg form. C Blocked version. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C ILO (input) INTEGER C It is assumed that A is already upper triangular and Q is C zero in rows and columns 1:ILO-1. ILO is normally set by a C previous call to the SLICOT Library routine MB04DS; C otherwise it should be set to 1. C 1 <= ILO <= N+1, if N > 0; ILO = 1, if 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. C On exit, the leading N-by-N part of this array contains C the matrix Aout and, in the zero part of Aout, C information about the elementary reflectors used to C compute the PVL factorization. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input/output) DOUBLE PRECISION array, dimension C (LDQG,N+1) C On entry, the leading N-by-N+1 part of this array must C contain in columns 1:N the strictly lower triangular part C of the matrix Q and in columns 2:N+1 the strictly upper C triangular part of the matrix G. The parts containing the C diagonal and the first superdiagonal of this array are not C referenced. C On exit, the leading N-by-N+1 part of this array contains C in its first N-1 columns information about the elementary C reflectors used to compute the PVL factorization and in C its last N columns the strictly upper triangular part of C the matrix Gout. C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C CS (output) DOUBLE PRECISION array, dimension (2N-2) C On exit, the first 2N-2 elements of this array contain the C cosines and sines of the symplectic Givens rotations used C to compute the PVL factorization. C C TAU (output) DOUBLE PRECISION array, dimension (N-1) C On exit, the first N-1 elements of this array contain the C scalar factors of some of the elementary reflectors. 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, 8*N*NB + 3*NB, where NB is the optimal C block size. C On exit, if INFO = -10, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,N-1). 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 An algorithm similar to the block algorithm for the symplectic C URV factorization described in [2] is used. C C The matrix U is represented as a product of symplectic reflectors C and Givens rotations C C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). C C Each H(i) has the form C C H(i) = I - tau * v * v' C C where tau is a real scalar, and v is a real vector with v(1:i) = 0 C and v(i+1) = 1; v(i+2:n) is stored on exit in QG(i+2:n,i), and C tau in QG(i+1,i). C C Each F(i) has the form C C F(i) = I - nu * w * w' C C where nu is a real scalar, and w is a real vector with w(1:i) = 0 C and w(i+1) = 1; w(i+2:n) is stored on exit in A(i+2:n,i), and C nu in TAU(i). C C Each G(i) is a Givens rotation acting on rows i+1 and n+i+1, where C the cosine is stored in CS(2*i-1) and the sine in CS(2*i). C C NUMERICAL ASPECTS C C The algorithm requires O(N**3) floating point operations and is C strongly backward stable. C C REFERENCES C C [1] Van Loan, C.F. C A symplectic method for approximating all the eigenvalues of C a Hamiltonian matrix. C Linear Algebra and its Applications, 61, pp. 233-251, 1984. C C [2] Kressner, D. C Block algorithms for orthogonal symplectic factorizations. C BIT, 43(4), pp. 775-790, 2003. C C CONTRIBUTORS C C D. Kressner (Technical Univ. Berlin, Germany) and C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. C C REVISIONS C C V. Sima, Nov. 2011 (SLICOT version of the HAPACK routine DSHPVB). C V. Sima, Oct. 2012. C C KEYWORDS C C Elementary matrix operations, skew-Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER ILO, INFO, LDA, LDQG, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) C .. Local Scalars .. LOGICAL LQUERY INTEGER I, IB, IERR, MINWRK, NB, NBMIN, NH, NIB, NNB, $ NX, PDW, PXA, PXG, PXQ, PYA, WRKOPT C .. External Functions .. INTEGER UE01MD EXTERNAL UE01MD C .. External Subroutines .. EXTERNAL DGEHRD, DGEMM, MB01KD, MB04PA, MB04RU, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 MINWRK = MAX( 1, N-1 ) IF ( N.LT.0 ) THEN INFO = -1 ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN INFO = -2 ELSE IF ( LDA.LT.MAX( 1,N ) ) THEN INFO = -4 ELSE IF ( LDQG.LT.MAX( 1,N ) ) THEN INFO = -6 ELSE LQUERY = LDWORK.EQ.-1 IF ( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN DWORK(1) = DBLE( MINWRK ) INFO = -10 ELSE IF ( N.LE.ILO ) THEN WRKOPT = ONE ELSE CALL DGEHRD( N, 1, N, DWORK, N, DWORK, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) NB = MIN( INT( WRKOPT/N ), N ) WRKOPT = MAX( WRKOPT, 8*N*NB + 3*NB ) END IF IF ( LQUERY ) THEN DWORK(1) = DBLE( WRKOPT ) RETURN END IF END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04RB', -INFO ) RETURN END IF C C Set elements 1:ILO-1 of TAU and CS. C DO 10 I = 1, ILO - 1 TAU( I ) = ZERO CS(2*I-1) = ONE CS(2*I) = ZERO 10 CONTINUE C C Quick return if possible. C IF ( N.LE.ILO ) THEN DWORK(1) = ONE RETURN END IF C C Determine the block size. C NH = N - ILO + 1 NBMIN = 2 IF ( NB.GT.1 .AND. NB.LT.NH ) THEN C C Determine when to cross over from blocked to unblocked code. C NX = MAX( NB, UE01MD( 3, 'MB04RB', ' ', N, ILO, -1 ) ) IF ( NX.LT.NH ) THEN C C Check whether workspace is large enough for blocked code. C IF ( LDWORK.LT.WRKOPT ) THEN C C Not enough workspace available. Determine minimum value C of NB, and reduce NB. C NBMIN = MAX( 2, UE01MD( 2, 'MB04RB', ' ', N, ILO, -1 ) ) NB = LDWORK / ( 8*N + 3 ) END IF END IF END IF C IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN C C Use unblocked code. C I = ILO C ELSE NNB = N*NB PXA = 1 PYA = PXA + 2*NNB PXQ = PYA + 2*NNB PXG = PXQ + 2*NNB PDW = PXG + 2*NNB C DO 20 I = ILO, N-NX-1, NB IB = MIN( NB, N-I ) NIB = N*IB C C Reduce rows and columns i:i+nb-1 to PVL form and return the C matrices XA, XG, XQ, and YA which are needed to update the C unreduced parts of the matrices. C CALL MB04PA( .FALSE., N-I+1, I-1, IB, A(1,I), LDA, QG(1,I), $ LDQG, DWORK(PXA), N, DWORK(PXG), N, DWORK(PXQ), $ N, DWORK(PYA), N, CS(2*I-1), TAU(I), $ DWORK(PDW) ) C IF ( N.GT.I+IB ) THEN C C Update the submatrix A(1:n,i+ib+1:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, $ IB, ONE, QG(I+IB+1,I), LDQG, DWORK(PXA+IB+1), $ N, ONE, A(I+IB+1,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, $ IB, ONE, A(I+IB+1,I), LDA, $ DWORK(PXA+NIB+IB+1), N, ONE, $ A(I+IB+1,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, $ ONE, DWORK(PYA), N, QG(I+IB+1,I), LDQG, ONE, $ A(1,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, $ ONE, DWORK(PYA+NIB), N, A(I+IB+1,I), LDA, $ ONE, A(1,I+IB+1), LDA ) C C Update the submatrix Q(i+ib+1:n,i+ib+1:n). C CALL MB01KD( 'Lower', 'No Transpose', N-I-IB, IB, ONE, $ DWORK(PXQ+IB+1), N, QG(I+IB+1,I), LDQG, ONE, $ QG(I+IB+1,I+IB+1), LDQG, IERR ) CALL MB01KD( 'Lower', 'No Transpose', N-I-IB, IB, ONE, $ DWORK(PXQ+NIB+IB+1), N, A(I+IB+1,I), LDA, $ ONE, QG(I+IB+1,I+IB+1), LDQG, IERR ) C C Update the submatrix G(1:n,1:n). C CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, $ IB, ONE, DWORK(PXG), N, QG(I+IB+1,I), LDQG, $ ONE, QG(1,I+IB+2), LDQG ) CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, $ IB, ONE, DWORK(PXG+NIB), N, A(I+IB+1,I), $ LDA, ONE, QG(1,I+IB+2), LDQG ) CALL MB01KD( 'Upper', 'No Transpose', N-I-IB, IB, ONE, $ DWORK(PXG+IB+I), N, QG(I+IB+1,I), LDQG, ONE, $ QG(I+IB+1,I+IB+2), LDQG, IERR ) CALL MB01KD( 'Upper', 'No Transpose', N-I-IB, IB, ONE, $ DWORK(PXG+NIB+IB+I), N, A(I+IB+1,I), LDA, $ ONE, QG(I+IB+1,I+IB+2), LDQG, IERR ) END IF 20 CONTINUE END IF C C Unblocked code to reduce the rest of the matrices. C CALL MB04RU( N, I, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK, $ IERR ) C DWORK( 1 ) = DBLE( WRKOPT ) C RETURN C *** Last line of MB04RB *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03MW.f0000644000000000000000000000013015012430707016206 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03MW.f0000644000175000017500000002053515012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE SB03MW( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, $ XNORM, INFO ) C C PURPOSE C C To solve for the 2-by-2 symmetric matrix X in C C op(T)'*X + X*op(T) = SCALE*B, C C where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T', C where T' denotes the transpose of T. C C ARGUMENTS C C Mode Parameters C C LTRAN LOGICAL C Specifies the form of op(T) to be used, as follows: C = .FALSE.: op(T) = T, C = .TRUE. : op(T) = T'. C C LUPPER LOGICAL C Specifies which triangle of the matrix B is used, and C which triangle of the matrix X is computed, as follows: C = .TRUE. : The upper triangular part; C = .FALSE.: The lower triangular part. C C Input/Output Parameters C C T (input) DOUBLE PRECISION array, dimension (LDT,2) C The leading 2-by-2 part of this array must contain the C matrix T. C C LDT INTEGER C The leading dimension of array T. LDT >= 2. C C B (input) DOUBLE PRECISION array, dimension (LDB,2) C On entry with LUPPER = .TRUE., the leading 2-by-2 upper C triangular part of this array must contain the upper C triangular part of the symmetric matrix B and the strictly C lower triangular part of B is not referenced. C On entry with LUPPER = .FALSE., the leading 2-by-2 lower C triangular part of this array must contain the lower C triangular part of the symmetric matrix B and the strictly C upper triangular part of B is not referenced. C C LDB INTEGER C The leading dimension of array B. LDB >= 2. C C SCALE (output) DOUBLE PRECISION C The scale factor. SCALE is chosen less than or equal to 1 C to prevent the solution overflowing. C C X (output) DOUBLE PRECISION array, dimension (LDX,2) C On exit with LUPPER = .TRUE., the leading 2-by-2 upper C triangular part of this array contains the upper C triangular part of the symmetric solution matrix X and the C strictly lower triangular part of X is not referenced. C On exit with LUPPER = .FALSE., the leading 2-by-2 lower C triangular part of this array contains the lower C triangular part of the symmetric solution matrix X and the C strictly upper triangular part of X is not referenced. C Note that X may be identified with B in the calling C statement. C C LDX INTEGER C The leading dimension of array X. LDX >= 2. C C XNORM (output) DOUBLE PRECISION C The infinity-norm of the solution. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if T and -T have too close eigenvalues, so T C is perturbed to get a nonsingular equation. C C NOTE: In the interests of speed, this routine does not C check the inputs for errors. C C METHOD C C The equivalent linear algebraic system of equations is formed and C solved using Gaussian elimination with complete pivoting. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C The algorithm is stable and reliable, since Gaussian elimination C with complete pivoting is used. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. C Based on DLALY2 by P. Petkov, Tech. University of Sofia, September C 1993. C C REVISIONS C C - C C KEYWORDS C C Continuous-time system, Lyapunov equation, matrix algebra. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, FOUR PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, $ FOUR = 4.0D+0 ) C .. C .. Scalar Arguments .. LOGICAL LTRAN, LUPPER INTEGER INFO, LDB, LDT, LDX DOUBLE PRECISION SCALE, XNORM C .. C .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), T( LDT, * ), X( LDX, * ) C .. C .. Local Scalars .. INTEGER I, IP, IPSV, J, JP, JPSV, K DOUBLE PRECISION EPS, SMIN, SMLNUM, TEMP, XMAX C .. C .. Local Arrays .. INTEGER JPIV( 3 ) DOUBLE PRECISION BTMP( 3 ), T9( 3, 3 ), TMP( 3 ) C .. C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. C .. External Subroutines .. EXTERNAL DSWAP C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. C .. Executable Statements .. C C Do not check the input parameters for errors C INFO = 0 C C Set constants to control overflow C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS C C Solve equivalent 3-by-3 system using complete pivoting. C Set pivots less than SMIN to SMIN. C SMIN = MAX( MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ), $ ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) )*EPS, $ SMLNUM ) T9( 1, 3 ) = ZERO T9( 3, 1 ) = ZERO T9( 1, 1 ) = T( 1, 1 ) T9( 2, 2 ) = T( 1, 1 ) + T( 2, 2 ) T9( 3, 3 ) = T( 2, 2 ) IF( LTRAN ) THEN T9( 1, 2 ) = T( 1, 2 ) T9( 2, 1 ) = T( 2, 1 ) T9( 2, 3 ) = T( 1, 2 ) T9( 3, 2 ) = T( 2, 1 ) ELSE T9( 1, 2 ) = T( 2, 1 ) T9( 2, 1 ) = T( 1, 2 ) T9( 2, 3 ) = T( 2, 1 ) T9( 3, 2 ) = T( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 )/TWO IF ( LUPPER ) THEN BTMP( 2 ) = B( 1, 2 ) ELSE BTMP( 2 ) = B( 2, 1 ) END IF BTMP( 3 ) = B( 2, 2 )/TWO C C Perform elimination C DO 50 I = 1, 2 XMAX = ZERO C DO 20 IP = I, 3 C DO 10 JP = I, 3 IF( ABS( T9( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( T9( IP, JP ) ) IPSV = IP JPSV = JP END IF 10 CONTINUE C 20 CONTINUE C IF( IPSV.NE.I ) THEN CALL DSWAP( 3, T9( IPSV, 1 ), 3, T9( I, 1 ), 3 ) TEMP = BTMP( I ) BTMP( I ) = BTMP( IPSV ) BTMP( IPSV ) = TEMP END IF IF( JPSV.NE.I ) $ CALL DSWAP( 3, T9( 1, JPSV ), 1, T9( 1, I ), 1 ) JPIV( I ) = JPSV IF( ABS( T9( I, I ) ).LT.SMIN ) THEN INFO = 1 T9( I, I ) = SMIN END IF C DO 40 J = I + 1, 3 T9( J, I ) = T9( J, I ) / T9( I, I ) BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I ) C DO 30 K = I + 1, 3 T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K ) 30 CONTINUE C 40 CONTINUE C 50 CONTINUE C IF( ABS( T9( 3, 3 ) ).LT.SMIN ) $ T9( 3, 3 ) = SMIN SCALE = ONE IF( ( FOUR*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T9( 1, 1 ) ) .OR. $ ( FOUR*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T9( 2, 2 ) ) .OR. $ ( FOUR*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T9( 3, 3 ) ) ) THEN SCALE = ( ONE / FOUR ) / MAX( ABS( BTMP( 1 ) ), $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE BTMP( 3 ) = BTMP( 3 )*SCALE END IF C DO 70 I = 1, 3 K = 4 - I TEMP = ONE / T9( K, K ) TMP( K ) = BTMP( K )*TEMP C DO 60 J = K + 1, 3 TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J ) 60 CONTINUE C 70 CONTINUE C DO 80 I = 1, 2 IF( JPIV( 3-I ).NE.3-I ) THEN TEMP = TMP( 3-I ) TMP( 3-I ) = TMP( JPIV( 3-I ) ) TMP( JPIV( 3-I ) ) = TEMP END IF 80 CONTINUE C X( 1, 1 ) = TMP( 1 ) IF ( LUPPER ) THEN X( 1, 2 ) = TMP( 2 ) ELSE X( 2, 1 ) = TMP( 2 ) END IF X( 2, 2 ) = TMP( 3 ) XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 2 ) ), $ ABS( TMP( 2 ) ) + ABS( TMP( 3 ) ) ) C RETURN C *** Last line of SB03MW *** END control-4.1.2/src/slicot/src/PaxHeaders/AG08BY.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AG08BY.f0000644000175000017500000005361215012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE AG08BY( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE, $ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL, $ TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To extract from the (N+P)-by-(M+N) descriptor system pencil C C S(lambda) = ( B A - lambda*E ) C ( D C ) C C with E nonsingular and upper triangular a C (NR+PR)-by-(M+NR) "reduced" descriptor system pencil C C ( Br Ar-lambda*Er ) C Sr(lambda) = ( ) C ( Dr Cr ) C C having the same finite Smith zeros as the pencil C S(lambda) but with Dr, a PR-by-M full row rank C left upper trapezoidal matrix, and Er, an NR-by-NR C upper triangular nonsingular matrix. C C ARGUMENTS C C Mode Parameters C C FIRST LOGICAL C Specifies if AG08BY is called first time or it is called C for an already reduced system, with D full column rank C with the last M rows in upper triangular form: C FIRST = .TRUE., first time called; C FIRST = .FALSE., not first time called. C C Input/Output Parameters C C N (input) INTEGER C The number of rows of matrix B, the number of columns of C matrix C and the order of square matrices A and E. C N >= 0. C C M (input) INTEGER C The number of columns of matrices B and D. M >= 0. C M <= P if FIRST = .FALSE. . C C P (input) INTEGER C The number of rows of matrices C and D. P >= 0. 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 matrix C ( B A ) , C ( D C ) C where A is an N-by-N matrix, B is an N-by-M matrix, C C is a P-by-N matrix and D is a P-by-M matrix. C If FIRST = .FALSE., then D must be a full column C rank matrix with the last M rows in upper triangular form. C On exit, the leading (NR+PR)-by-(M+NR) part of ABCD C contains the reduced compound matrix C ( Br Ar ) , C ( Dr Cr ) C where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix, C Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank C left upper trapezoidal matrix with the first PR columns C in upper triangular form. C C LDABCD INTEGER C The leading dimension of array ABCD. C LDABCD >= MAX(1,N+P). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the upper triangular nonsingular matrix E. C On exit, the leading NR-by-NR part contains the reduced C upper triangular nonsingular matrix Er. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). C C NR (output) INTEGER C The order of the reduced matrices Ar and Er; also the C number of rows of the reduced matrix Br and the number C of columns of the reduced matrix Cr. C If Dr is invertible, NR is also the number of finite C Smith zeros. C C PR (output) INTEGER C The rank of the resulting matrix Dr; also the number of C rows of reduced matrices Cr and Dr. C C NINFZ (output) INTEGER C Number of infinite zeros. NINFZ = 0 if FIRST = .FALSE. . C C DINFZ (output) INTEGER C The maximal multiplicity of infinite zeros. C DINFZ = 0 if FIRST = .FALSE. . C C NKRONL (output) INTEGER C The maximal dimension of left elementary Kronecker blocks. C C INFZ (output) INTEGER array, dimension (N) C INFZ(i) contains the number of infinite zeros of C degree i, where i = 1,2,...,DINFZ. C INFZ is not referenced if FIRST = .FALSE. . C C KRONL (output) INTEGER array, dimension (N+1) C KRONL(i) contains the number of left elementary Kronecker C blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL. 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 <= 0, then an implicitly computed, C default tolerance TOLDEF = (N+P)*(N+M)*EPS, is used C instead, where EPS is the machine precision C (see LAPACK Library routine DLAMCH). C NOTE that when SVLMAX > 0, the estimated ranks could be C less than those defined above (see SVLMAX). TOL <= 1. C C Workspace C C IWORK INTEGER array, dimension (M) C If FIRST = .FALSE., IWORK is not referenced. 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 >= 1, if P = 0; otherwise C LDWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 5*P ), C if FIRST = .TRUE.; C LDWORK >= MAX( 1, N+M-1, 5*P ), if FIRST = .FALSE. . C The second term is not needed if M = 0. 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 subroutine is based on the reduction algorithm of [1]. C C REFERENCES C C [1] P. Misra, P. Van Dooren and A. Varga. C Computation of structural invariants of generalized C state-space systems. C Automatica, 30, pp. 1921-1936, 1994. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( (P+N)*(M+N)*N ) floating point operations. C C FURTHER COMMENTS C C The number of infinite zeros is computed as C C DINFZ C NINFZ = Sum (INFZ(i)*i) . C i=1 C Note that each infinite zero of multiplicity k corresponds to C an infinite eigenvalue of multiplicity k+1. C The multiplicities of the infinite eigenvalues can be determined C from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows: C C DINFZ C - there are PR - Sum (INFZ(i)) simple infinite eigenvalues; C i=1 C C - there are INFZ(i) infinite eigenvalues with multiplicity i+1, C for i = 1, ..., DINFZ. C C The left Kronecker indices are: C C [ 0 0 ... 0 | 1 1 ... 1 | .... | NKRONL ... NKRONL ] C |<- KRONL(1) ->|<- KRONL(2) ->| |<- KRONL(NKRONL) ->| C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C May 1999. Based on the RASP routine SRISEP. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999, C Jan. 2009, Apr. 2009. C A. Varga, DLR Oberpfaffenhofen, March 2002. C V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. C V. Sima, Apr. 2011, Mar. 2019. C C KEYWORDS C C Generalized eigenvalue problem, Kronecker indices, multivariable C system, orthogonal transformation, structural invariant. C C ****************************************************************** C C .. Parameters .. INTEGER IMAX, IMIN PARAMETER ( IMAX = 1, IMIN = 2 ) DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER DINFZ, INFO, LDABCD, LDE, LDWORK, M, N, NINFZ, $ NKRONL, NR, P, PR DOUBLE PRECISION SVLMAX, TOL LOGICAL FIRST C .. Array Arguments .. INTEGER INFZ( * ), IWORK(*), KRONL( * ) DOUBLE PRECISION ABCD( LDABCD, * ), DWORK( * ), E( LDE, * ) C .. Local Scalars .. LOGICAL LQUERY INTEGER I, ICOL, ILAST, IRC, IROW, ISMAX, ISMIN, ITAU, $ J, JLAST, JWORK1, JWORK2, K, MN, MN1, MNR, $ MNTAU, MP1, MPM, MUI, MUIM1, N1, NBLCKS, PN, $ RANK, RO, RO1, SIGMA, TAUI, WRKOPT DOUBLE PRECISION C, C1, C2, RCOND, S, S1, S2, SMAX, SMAXPR, $ SMIN, SMINPR, T, TOLZ, TT C .. Local Arrays .. DOUBLE PRECISION DUM(1), SVAL(3) C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL DLAMCH, DNRM2, IDAMAX C .. External Subroutines .. EXTERNAL DCOPY, DLAIC1, DLAPMT, DLARFG, DLARTG, DLASET, $ DLATZM, DORMQR, DROT, DSWAP, MB03OY, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C C Test the input parameters. C LQUERY = ( LDWORK.EQ.-1 ) INFO = 0 PN = P + N MN = M + N MPM = MIN( P, M ) IF( N.LT.0 ) THEN INFO = -2 ELSE IF( M.LT.0 .OR. ( .NOT.FIRST .AND. M.GT.P ) ) THEN INFO = -3 ELSE IF( P.LT.0 ) THEN INFO = -4 ELSE IF( SVLMAX.LT.ZERO ) THEN INFO = -5 ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN INFO = -7 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( TOL.GT.ONE ) THEN INFO = -17 ELSE WRKOPT = MAX( 1, 5*P ) IF( P.GT.0 ) THEN IF( M.GT.0 ) THEN WRKOPT = MAX( WRKOPT, MN-1 ) IF( FIRST ) THEN WRKOPT = MAX( WRKOPT, MPM + MAX( 3*M-1, N ) ) IF( LQUERY ) THEN CALL DORMQR( 'Left', 'Transpose', P, N, MPM, ABCD, $ LDABCD, DWORK, ABCD, LDABCD, DWORK, $ -1, INFO ) WRKOPT = MAX( WRKOPT, MPM + INT( DWORK(1) ) ) END IF END IF END IF END IF IF( LDWORK.LT.WRKOPT .AND. .NOT.LQUERY ) THEN INFO = -20 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'AG08BY', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Initialize output variables. C PR = P NR = N DINFZ = 0 NINFZ = 0 NKRONL = 0 C C Quick return if possible. C IF( P.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF IF( N.EQ.0 .AND. M.EQ.0 ) THEN PR = 0 NKRONL = 1 KRONL(1) = P DWORK(1) = ONE RETURN END IF C TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) RCOND = TOL IF( RCOND.LE.ZERO ) THEN C C Use the default tolerance in rank determination. C RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' ) END IF C C The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and C SIGMA = 0 for FIRST = .TRUE. and SIGMA = M for FIRST = .FALSE.. C The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column C rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular. C IF( FIRST ) THEN SIGMA = 0 ELSE SIGMA = M END IF RO = P - SIGMA MP1 = M + 1 MUI = 0 DUM(1) = ZERO C ITAU = 1 JWORK1 = ITAU + MPM ISMIN = 2*P + 1 ISMAX = ISMIN + P JWORK2 = ISMAX + P NBLCKS = 0 WRKOPT = 1 C 10 IF( PR.EQ.0 ) GO TO 90 C C (NR+1,ICOL+1) points to the current position of matrix D. C RO1 = RO MNR = M + NR IF( M.GT.0 ) THEN C C Compress rows of D; first exploit the trapezoidal shape of the C (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D; C compress the first SIGMA columns without column pivoting: C C ( x x x x x ) ( x x x x x ) C ( x x x x x ) ( 0 x x x x ) C ( x x x x x ) - > ( 0 0 x x x ) C ( 0 x x x x ) ( 0 0 0 x x ) C ( 0 0 x x x ) ( 0 0 0 x x ) C C where SIGMA = 3 and RO = 2. C Workspace: need maximum M+N-1. C IROW = NR DO 20 ICOL = 1, SIGMA IROW = IROW + 1 CALL DLARFG( RO+1, ABCD(IROW,ICOL), ABCD(IROW+1,ICOL), 1, $ T ) CALL DLATZM( 'L', RO+1, MNR-ICOL, ABCD(IROW+1,ICOL), 1, T, $ ABCD(IROW,ICOL+1), ABCD(IROW+1,ICOL+1), $ LDABCD, DWORK ) CALL DCOPY( PR-ICOL, DUM, 0, ABCD(IROW+1,ICOL), 1 ) 20 CONTINUE WRKOPT = MAX( WRKOPT, MN - 1 ) C IF( FIRST ) THEN C C Continue with Householder with column pivoting. C C ( x x x x x ) ( x x x x x ) C ( 0 x x x x ) ( 0 x x x x ) C ( 0 0 x x x ) - > ( 0 0 x x x ) C ( 0 0 0 x x ) ( 0 0 0 x x ) C ( 0 0 0 x x ) ( 0 0 0 0 0 ) C C Real workspace: need maximum min(P,M)+3*M-1; C Integer workspace: need maximum M. C IROW = MIN( NR+SIGMA+1, PN ) ICOL = MIN( SIGMA+1, M ) CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, $ RCOND, SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU), $ DWORK(JWORK1), INFO ) WRKOPT = MAX( WRKOPT, JWORK1 + 3*M - 2 ) C C Apply the column permutations to B and part of D. C CALL DLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL), $ LDABCD, IWORK ) C IF( RANK.GT.0 ) THEN C C Apply the Householder transformations to the submatrix C. C Workspace: need maximum min(P,M) + N; C prefer maximum min(P,M) + N*NB. C CALL DORMQR( 'Left', 'Transpose', RO1, NR, RANK, $ ABCD(IROW,ICOL), LDABCD, DWORK(ITAU), $ ABCD(IROW,MP1), LDABCD, DWORK(JWORK1), $ LDWORK-JWORK1+1, INFO ) WRKOPT = MAX( WRKOPT, JWORK1 + INT( DWORK(JWORK1) ) - 1 ) CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, $ ZERO, ABCD(MIN( IROW+1, PN ),ICOL), LDABCD ) RO1 = RO1 - RANK END IF END IF C C Terminate if Dr has maximal row rank. C IF( RO1.EQ.0 ) GO TO 90 C END IF C C Update SIGMA. C SIGMA = PR - RO1 C NBLCKS = NBLCKS + 1 TAUI = RO1 C C Compress the columns of current C to separate a TAUI-by-MUI C full column rank block. C IF( NR.EQ.0 ) THEN C C Finish for zero state dimension. C PR = SIGMA RANK = 0 ELSE C C Perform RQ-decomposition with row pivoting on the current C C while keeping E upper triangular. C The current C is the TAUI-by-NR matrix delimited by rows C IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD. C The rank of current C is computed in MUI. C Workspace: need maximum 5*P. C IRC = NR + SIGMA N1 = NR IF( TAUI.GT.1 ) THEN C C Compute norms. C DO 30 I = 1, TAUI DWORK(I) = DNRM2( NR, ABCD(IRC+I,MP1), LDABCD ) DWORK(P+I) = DWORK(I) 30 CONTINUE END IF C RANK = 0 MNTAU = MIN( TAUI, NR ) C C ICOL and IROW will point to the current pivot position in C. C ILAST = NR + PR JLAST = M + NR IROW = ILAST ICOL = JLAST I = TAUI 40 IF( RANK.LT.MNTAU ) THEN MN1 = M + N1 C C Pivot if necessary. C IF( I.NE.1 ) THEN J = IDAMAX( I, DWORK, 1 ) IF( J.NE.I ) THEN DWORK(J) = DWORK(I) DWORK(P+J) = DWORK(P+I) CALL DSWAP( N1, ABCD(IROW,MP1), LDABCD, $ ABCD(IRC+J,MP1), LDABCD ) END IF END IF C C Zero elements left to ABCD(IROW,ICOL). C DO 50 K = 1, N1-1 J = M + K C C Rotate columns J, J+1 to zero ABCD(IROW,J). C T = ABCD(IROW,J+1) CALL DLARTG( T, ABCD(IROW,J), C, S, ABCD(IROW,J+1) ) ABCD(IROW,J) = ZERO CALL DROT( IROW-1, ABCD(1,J+1), 1, ABCD(1,J), 1, C, S ) CALL DROT( K+1, E(1,K+1), 1, E(1,K), 1, C, S ) C C Rotate rows K, K+1 to zero E(K+1,K). C T = E(K,K) CALL DLARTG( T, E(K+1,K), C, S, E(K,K) ) E(K+1,K) = ZERO CALL DROT( N1-K, E(K,K+1), LDE, E(K+1,K+1), LDE, C, S ) CALL DROT( MN1, ABCD(K,1), LDABCD, ABCD(K+1,1), LDABCD, $ C, S ) 50 CONTINUE C IF( RANK.EQ.0 ) THEN C C Initialize; exit if matrix is zero (RANK = 0). C SMAX = ABS( ABCD(ILAST,JLAST) ) IF ( SMAX.EQ.ZERO ) GO TO 80 SMIN = SMAX SMAXPR = SMAX SMINPR = SMIN C1 = ONE C2 = ONE ELSE C C One step of incremental condition estimation. C CALL DCOPY( RANK, ABCD(IROW,ICOL+1), LDABCD, $ DWORK(JWORK2), 1 ) CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, $ DWORK(JWORK2), ABCD(IROW,ICOL), SMINPR, S1, $ C1 ) CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, $ DWORK(JWORK2), ABCD(IROW,ICOL), SMAXPR, S2, $ C2 ) WRKOPT = MAX( WRKOPT, 5*P ) END IF C C Check the rank; finish the loop if rank loss occurs. C IF( SVLMAX*RCOND.LE.SMAXPR ) THEN IF( SVLMAX*RCOND.LE.SMINPR ) THEN IF( SMAXPR*RCOND.LT.SMINPR ) THEN C C Finish the loop if last row. C IF( N1.EQ.0 ) THEN RANK = RANK + 1 GO TO 80 END IF C IF( N1.GT.1 ) THEN C C Update norms. C IF( I-1.GT.1 ) THEN DO 60 J = 1, I - 1 IF( DWORK(J).NE.ZERO ) THEN T = ABS( ABCD(IRC+J,ICOL) ) / DWORK(J) T = MAX( ( ONE + T )*( ONE - T ), ZERO) TT = T*( DWORK(J)/DWORK(P+J) )**2 IF( TT.GT.TOLZ ) THEN DWORK(J) = DWORK(J)*SQRT( T ) ELSE DWORK(J) = DNRM2( N1-1, $ ABCD(IRC+J,MP1), LDABCD ) DWORK(P+J) = DWORK(J) END IF END IF 60 CONTINUE END IF END IF C DO 70 J = 1, RANK DWORK( ISMIN+J-1 ) = S1*DWORK( ISMIN+J-1 ) DWORK( ISMAX+J-1 ) = S2*DWORK( ISMAX+J-1 ) 70 CONTINUE C DWORK( ISMIN+RANK ) = C1 DWORK( ISMAX+RANK ) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 ICOL = ICOL - 1 IROW = IROW - 1 N1 = N1 - 1 I = I - 1 GO TO 40 END IF END IF END IF END IF END IF C 80 CONTINUE MUI = RANK NR = NR - MUI PR = SIGMA + MUI C C Set number of left Kronecker blocks of order (i-1)-by-i. C KRONL(NBLCKS) = TAUI - MUI C C Set number of infinite divisors of order i-1. C IF( FIRST .AND. NBLCKS.GT.1 ) $ INFZ(NBLCKS-1) = MUIM1 - TAUI MUIM1 = MUI RO = MUI C C Continue reduction if rank of current C is positive. C IF( MUI.GT.0 ) $ GO TO 10 C C Determine the maximal degree of infinite zeros and C the number of infinite zeros. C 90 CONTINUE IF( FIRST ) THEN IF( MUI.EQ.0 ) THEN DINFZ = MAX( 0, NBLCKS - 1 ) ELSE DINFZ = NBLCKS INFZ(NBLCKS) = MUI END IF K = DINFZ DO 100 I = K, 1, -1 IF( INFZ(I).NE.0 ) GO TO 110 DINFZ = DINFZ - 1 100 CONTINUE 110 CONTINUE DO 120 I = 1, DINFZ NINFZ = NINFZ + INFZ(I)*I 120 CONTINUE END IF C C Determine the maximal order of left elementary Kronecker blocks. C NKRONL = NBLCKS DO 130 I = NBLCKS, 1, -1 IF( KRONL(I).NE.0 ) GO TO 140 NKRONL = NKRONL - 1 130 CONTINUE 140 CONTINUE C DWORK(1) = WRKOPT RETURN C *** Last line of AG08BY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03SD.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03SD.f0000644000175000017500000006006315012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE SB03SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To estimate the conditioning and compute an error bound on the C solution of the real discrete-time Lyapunov matrix equation C C op(A)'*X*op(A) - X = scale*C C C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The C matrix A is N-by-N, the right hand side C and the solution X are C N-by-N symmetric matrices, and scale is a given scale factor. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'C': Compute the reciprocal condition number only; C = 'E': Compute the error bound only; C = 'B': Compute both the reciprocal condition number and C the error bound. 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, T and U (if LYAPUN = 'O') contain the C factors from the real Schur factorization of the C matrix A; C = 'N': The Schur factorization of A will be computed C and the factors will be stored in T and U (if C LYAPUN = 'O'). 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 UPLO CHARACTER*1 C Specifies which part of the symmetric matrix C is to be C used, as follows: C = 'U': Upper triangular part; C = 'L': Lower triangular part. C C LYAPUN CHARACTER*1 C Specifies whether or not the original Lyapunov equations C should be solved in the iterative estimation process, C as follows: C = 'O': Solve the original Lyapunov equations, updating C the right-hand sides and solutions with the C matrix U, e.g., X <-- U'*X*U; C = 'R': Solve reduced Lyapunov equations only, without C updating the right-hand sides and solutions. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, X and C. N >= 0. C C SCALE (input) DOUBLE PRECISION C The scale factor, scale, set by a Lyapunov solver. C 0 <= SCALE <= 1. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of C this array must contain the original matrix A. C If FACT = 'F' and LYAPUN = 'R', A is not referenced. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O'; C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. C C T (input/output) DOUBLE PRECISION array, dimension C (LDT,N) C If FACT = 'F', then on entry the leading N-by-N upper C Hessenberg part of this array must contain the upper C quasi-triangular matrix T in Schur canonical form from a C Schur factorization of A. C If FACT = 'N', then this array need not be set on input. C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the C leading N-by-N upper Hessenberg part of this array C contains the upper quasi-triangular matrix T in Schur C canonical form from a Schur factorization of A. C C LDT INTEGER C The leading dimension of the array T. LDT >= MAX(1,N). C C U (input or output) DOUBLE PRECISION array, dimension C (LDU,N) C If LYAPUN = 'O' and FACT = 'F', then U is an input C argument and on entry, the leading N-by-N part of this C array must contain the orthogonal matrix U from a real C Schur factorization of A. C If LYAPUN = 'O' and FACT = 'N', then U is an output C argument and on exit, if INFO = 0 or INFO = N+1, it C contains the orthogonal N-by-N matrix from a real Schur C factorization of A. C If LYAPUN = 'R', the array U is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= 1, if LYAPUN = 'R'; C LDU >= MAX(1,N), if LYAPUN = 'O'. C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C If UPLO = 'U', the leading N-by-N upper triangular part of C this array must contain the upper triangular part of the C matrix C of the original Lyapunov equation (with C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov C equation (with matrix T), if LYAPUN = 'R'. C If UPLO = 'L', the leading N-by-N lower triangular part of C this array must contain the lower triangular part of the C matrix C of the original Lyapunov equation (with C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov C equation (with matrix T), if LYAPUN = 'R'. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,N). C C X (input) DOUBLE PRECISION array, dimension (LDX,N) C The leading N-by-N part of this array must contain the C symmetric solution matrix X of the original Lyapunov C equation (with matrix A), if LYAPUN = 'O', or of the C reduced Lyapunov equation (with matrix T), if C LYAPUN = 'R'. C The array X is modified internally, but restored on exit. C C LDX INTEGER C The leading dimension of the array X. LDX >= MAX(1,N). C C SEPD (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'B', the estimated quantity C sepd(op(A),op(A)'). C If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced. C C RCOND (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal C condition number of the discrete-time Lyapunov equation. C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. C If JOB = 'E', RCOND is not referenced. C C FERR (output) DOUBLE PRECISION C If JOB = 'E' or JOB = 'B', an estimated forward error C bound for the solution X. If XTRUE is the true solution, C FERR bounds the magnitude of the largest entry in C (X - XTRUE) divided by the magnitude of the largest entry C in X. C If N = 0 or X = 0, FERR is set to 0. C If JOB = 'C', FERR is not referenced. C C Workspace C C IWORK INTEGER array, dimension (N*N) 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 dimension of the array DWORK. C LDWORK >= 1, if N = 0; else, C LDWORK >= MAX(3,2*N*N) + N*N, if JOB = 'C', C FACT = 'F'; C LDWORK >= MAX(MAX(3,2*N*N) + N*N, 5*N), if JOB = 'C', C FACT = 'N'; C LDWORK >= MAX(3,2*N*N) + N*N + 2*N, if JOB = 'E', or C JOB = 'B'. C For optimum performance LDWORK should sometimes 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 > 0: if INFO = i, i <= N, the QR algorithm failed to C complete the reduction to Schur canonical form (see C LAPACK Library routine DGEES); on exit, the matrix C T(i+1:N,i+1:N) contains the partially converged C Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N) C contain the real and imaginary parts, respectively, C of the converged eigenvalues; this error is unlikely C to appear; C = N+1: if the matrix T has almost reciprocal eigenvalues; C perturbed values were used to solve Lyapunov C equations, but the matrix T, if given (for C FACT = 'F'), is unchanged. C C METHOD C C The condition number of the discrete-time Lyapunov equation is C estimated as C C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), C C where Omega and Theta are linear operators defined by C C Omega(W) = op(A)'*W*op(A) - W, C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). C C The routine estimates the quantities C C sepd(op(A),op(A)') = 1 / norm(inv(Omega)) C C and norm(Theta) using 1-norm condition estimators. C C The forward error bound is estimated using a practical error bound C similar to the one proposed in [1]. C C REFERENCES C C [1] Higham, N.J. C Perturbation theory and backward error for AX-XB=C. C BIT, vol. 33, pp. 124-136, 1993. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C The accuracy of the estimates obtained depends on the solution C accuracy and on the properties of the 1-norm estimator. C C FURTHER COMMENTS C C The option LYAPUN = 'R' may occasionally produce slightly worse C or better estimates, and it is much faster than the option 'O'. C When SEPD is computed and it is zero, the routine returns C immediately, with RCOND and FERR (if requested) set to 0 and 1, C respectively. In this case, the equation is singular. C C CONTRIBUTORS C C P. Petkov, Tech. University of Sofia, December 1998. C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, March 2003, July 2012. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, THREE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, THREE = 3.0D0 ) C .. C .. Scalar Arguments .. CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N DOUBLE PRECISION FERR, RCOND, SCALE, SEPD C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), $ T( LDT, * ), U( LDU, * ), X( LDX, * ) C .. C .. Local Scalars .. LOGICAL JOBB, JOBC, JOBE, LOWER, LQUERY, NOFACT, $ NOTRNA, UPDATE CHARACTER SJOB, TRANAT INTEGER I, IABS, IRES, IWRK, IXMA, J, LDW, NN, SDIM, $ WRKOPT DOUBLE PRECISION ANORM, CNORM, DENOM, EPS, EPSN, TEMP, THNORM, $ TMAX, XANORM, XNORM C .. C .. Local Arrays .. LOGICAL BWORK( 1 ) C .. C .. External Functions .. LOGICAL LSAME, SELECT DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT C .. C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEES, DGEMM, DLACPY, DLASET, $ MA02ED, MB01RU, MB01RX, MB01RY, MB01UD, SB03SX, $ SB03SY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C C Decode and Test input parameters. C JOBC = LSAME( JOB, 'C' ) JOBE = LSAME( JOB, 'E' ) JOBB = LSAME( JOB, 'B' ) NOFACT = LSAME( FACT, 'N' ) NOTRNA = LSAME( TRANA, 'N' ) LOWER = LSAME( UPLO, 'L' ) UPDATE = LSAME( LYAPUN, 'O' ) C NN = N*N LDW = MAX( 3, 2*NN ) + NN C INFO = 0 IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN INFO = -1 ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. $ LSAME( TRANA, 'C' ) ) ) THEN INFO = -3 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -4 ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) THEN INFO = -7 ELSE IF( LDA.LT.1 .OR. $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN INFO = -9 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( JOBC ) THEN IF( NOFACT ) THEN IWRK = MAX( LDW, 5*N ) ELSE IWRK = LDW END IF ELSE IWRK = LDW + 2*N END IF IWRK = MAX( 1, IWRK ) LQUERY = LDWORK.EQ.-1 IF( NOFACT ) THEN IF( UPDATE ) THEN SJOB = 'V' ELSE SJOB = 'N' END IF END IF IF( LQUERY ) THEN IF( NOFACT ) THEN CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK, DWORK, U, LDU, DWORK, -1, BWORK, $ INFO ) WRKOPT = MAX( IWRK, INT( DWORK( 1 ) ) + 2*N ) ELSE WRKOPT = IWRK END IF END IF IF( LDWORK.LT.IWRK .AND. .NOT. LQUERY ) $ INFO = -23 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03SD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK( 1 ) = WRKOPT RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IF( .NOT.JOBE ) $ RCOND = ONE IF( .NOT.JOBC ) $ FERR = ZERO DWORK( 1 ) = ONE RETURN END IF C C Compute the 1-norm of the matrix X. C XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) IF( XNORM.EQ.ZERO ) THEN C C The solution is zero. C IF( .NOT.JOBE ) $ RCOND = ZERO IF( .NOT.JOBC ) $ FERR = ZERO DWORK( 1 ) = DBLE( N ) RETURN END IF C C Compute the 1-norm of A or T. C IF( NOFACT .OR. UPDATE ) THEN ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) ELSE ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) END IF C C For the special case A = I, set SEPD and RCOND to 0. C For the special case A = 0, set SEPD and RCOND to 1. C A quick test is used in general. C IF( ANORM.EQ.ONE ) THEN IF( NOFACT .OR. UPDATE ) THEN CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) ELSE CALL DLACPY( 'Full', N, N, T, LDT, DWORK, N ) IF( N.GT.2 ) $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK( 3 ), $ N ) END IF DWORK( NN+1 ) = ONE CALL DAXPY( N, -ONE, DWORK( NN+1 ), 0, DWORK, N+1 ) IF( DLANGE( 'Max', N, N, DWORK, N, DWORK ).EQ.ZERO ) THEN IF( .NOT.JOBE ) THEN SEPD = ZERO RCOND = ZERO END IF IF( .NOT.JOBC ) $ FERR = ONE DWORK( 1 ) = DBLE( NN + 1 ) RETURN END IF C ELSE IF( ANORM.EQ.ZERO ) THEN IF( .NOT.JOBE ) THEN SEPD = ONE RCOND = ONE END IF IF( JOBC ) THEN DWORK( 1 ) = DBLE( N ) RETURN ELSE C C Set FERR for the special case A = 0. C CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) C IF( LOWER ) THEN DO 10 J = 1, N CALL DAXPY( N-J+1, SCALE, C( J, J ), 1, $ DWORK( (J-1)*N+J ), 1 ) 10 CONTINUE ELSE DO 20 J = 1, N CALL DAXPY( J, SCALE, C( 1, J ), 1, $ DWORK( (J-1)*N+1 ), 1 ) 20 CONTINUE END IF C FERR = MIN( ONE, DLANSY( '1-norm', UPLO, N, DWORK, N, $ DWORK( NN+1 ) ) / XNORM ) DWORK( 1 ) = DBLE( NN + N ) RETURN END IF END IF C C General case. C CNORM = DLANSY( '1-norm', UPLO, N, C, LDC, DWORK ) C C Workspace usage. C IABS = NN IXMA = MAX( 3, 2*NN ) IRES = IXMA IWRK = IXMA + NN WRKOPT = 0 C IF( NOFACT ) THEN C C Compute the Schur factorization of A, A = U*T*U'. C Workspace: need 5*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 CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK( 1 ), DWORK( N+1 ), U, LDU, DWORK( 2*N+1 ), $ LDWORK-2*N, BWORK, INFO ) IF( INFO.GT.0 ) $ RETURN WRKOPT = INT( DWORK( 2*N+1 ) ) + 2*N END IF C C Compute X*op(A) or X*op(T). C IF( UPDATE ) THEN CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, X, LDX, A, LDA, $ ZERO, DWORK( IXMA+1 ), N ) ELSE CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, $ DWORK( IXMA+1 ), N, INFO ) END IF C IF( .NOT.JOBE ) THEN C C Estimate sepd(op(A),op(A)') = sepd(op(T),op(T)') and C norm(Theta). C Workspace max(3,2*N*N) + N*N. C CALL SB03SY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, $ DWORK( IXMA+1 ), N, SEPD, THNORM, IWORK, DWORK, $ IXMA, INFO ) C WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN ) C C Return if the equation is singular. C IF( SEPD.EQ.ZERO ) THEN RCOND = ZERO IF( JOBB ) $ FERR = ONE DWORK( 1 ) = DBLE( WRKOPT ) RETURN END IF C C Estimate the reciprocal condition number. C TMAX = MAX( SEPD, XNORM, ANORM ) IF( TMAX.LE.ONE ) THEN TEMP = SEPD*XNORM DENOM = ( SCALE*CNORM ) + ( SEPD*ANORM )*THNORM ELSE TEMP = ( SEPD / TMAX )*( XNORM / TMAX ) DENOM = ( ( SCALE / TMAX )*( CNORM / TMAX ) ) + $ ( ( SEPD / TMAX )*( ANORM / TMAX ) )*THNORM END IF IF( TEMP.GE.DENOM ) THEN RCOND = ONE ELSE RCOND = TEMP / DENOM END IF END IF C IF( .NOT.JOBC ) THEN C C Form a triangle of the residual matrix C R = scale*C + X - op(A)'*X*op(A), or C R = scale*C + X - op(T)'*X*op(T), C exploiting the symmetry. For memory savings, R is formed in the C leading N-by-N upper/lower triangular part of DWORK, and it is C finally moved in the location where X*op(A) or X*op(T) was C stored, freeing workspace for the SB03SX call. C IF( NOTRNA ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF C CALL DLACPY( UPLO, N, N, C, LDC, DWORK, N ) C IF( UPDATE ) THEN CALL MB01RX( 'Left', UPLO, TRANAT, N, N, SCALE, -ONE, DWORK, $ N, A, LDA, DWORK( IXMA+1 ), N, INFO ) ELSE CALL MB01RY( 'Left', UPLO, TRANAT, N, SCALE, -ONE, DWORK, N, $ T, LDT, DWORK( IXMA+1 ), N, DWORK( IWRK+1 ), $ INFO ) END IF C IF( LOWER ) THEN DO 30 J = 1, N CALL DAXPY( N-J+1, ONE, X( J, J ), 1, DWORK( (J-1)*N+J ), $ 1 ) 30 CONTINUE ELSE DO 40 J = 1, N CALL DAXPY( J, ONE, X( 1, J ), 1, DWORK( (J-1)*N+1 ), 1 ) 40 CONTINUE END IF C CALL DLACPY( UPLO, N, N, DWORK, N, DWORK( IRES+1 ), N ) C C Get the machine precision. C EPS = DLAMCH( 'Epsilon' ) EPSN = EPS*DBLE( 2*N + 2 ) C C Add to abs(R) a term that takes account of rounding errors in C forming R: C abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) + C 2*(n+1)*abs(op(A))'*abs(X)*abs(op(A))), or C abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) + C 2*(n+1)*abs(op(T))'*abs(X)*abs(op(T))), C where EPS is the machine precision. C Workspace max(3,2*N*N) + N*N + 2*N. C Note that the lower or upper triangular part of X specified by C UPLO is used as workspace, but it is finally restored. C IF( UPDATE ) THEN DO 60 J = 1, N DO 50 I = 1, N DWORK( IABS+(J-1)*N+I ) = ABS( A( I, J ) ) 50 CONTINUE 60 CONTINUE ELSE DO 80 J = 1, N DO 70 I = 1, MIN( J+1, N ) DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) 70 CONTINUE 80 CONTINUE END IF C CALL DCOPY( N, X, LDX+1, DWORK( IWRK+1 ), 1 ) C IF( LOWER ) THEN DO 100 J = 1, N DO 90 I = J, N TEMP = ABS( X( I, J ) ) X( I, J ) = TEMP DWORK( IRES+(J-1)*N+I ) = $ ABS( DWORK( IRES+(J-1)*N+I ) ) + $ EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP ) 90 CONTINUE 100 CONTINUE ELSE DO 120 J = 1, N DO 110 I = 1, J TEMP = ABS( X( I, J ) ) X( I, J ) = TEMP DWORK( IRES+(J-1)*N+I ) = $ ABS( DWORK( IRES+(J-1)*N+I ) ) + $ EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP ) 110 CONTINUE 120 CONTINUE END IF C IF( UPDATE ) THEN CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPSN, DWORK( IRES+1 ), $ N, DWORK( IABS+1 ), N, X, LDX, DWORK, NN, $ INFO ) ELSE C C Compute W = abs(X)*abs(op(T)), and then premultiply by C abs(T)' and add in the result. C CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N, $ X, LDX, DWORK, N, INFO ) CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN, $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, DWORK, $ N, DWORK( IWRK+N+1 ), INFO ) END IF C WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN + 2*N ) C C Restore X. C CALL DCOPY( N, DWORK( IWRK+1 ), 1, X, LDX+1 ) IF( LOWER ) THEN CALL MA02ED( 'Upper', N, X, LDX ) ELSE CALL MA02ED( 'Lower', N, X, LDX ) END IF C C Compute forward error bound, using matrix norm estimator. C Workspace max(3,2*N*N) + N*N. C XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) C CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, $ INFO ) END IF C DWORK( 1 ) = DBLE( WRKOPT ) RETURN C C *** Last line of SB03SD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10AD.f0000644000000000000000000000013215012430707016147 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10AD.f0000644000175000017500000007312615012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE SB10AD( JOB, N, M, NP, NCON, NMEAS, GAMMA, A, LDA, $ B, LDB, C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, $ LDCK, DK, LDDK, AC, LDAC, BC, LDBC, CC, LDCC, $ DC, LDDC, RCOND, GTOL, ACTOL, IWORK, LIWORK, $ DWORK, LDWORK, BWORK, LBWORK, INFO ) C C PURPOSE C C To compute the matrices of an H-infinity 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 the estimated minimal possible value of gamma with respect C to GTOL, where B2 has as column size the number of control inputs C (NCON) and C2 has as row size the number of measurements (NMEAS) C being provided to the controller, and then to compute the matrices C of the closed-loop system C C | AC | BC | C G = |----|----|, C | CC | DC | C C if the stabilizing controller exists. 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 JOB (input) INTEGER C Indicates the strategy for reducing the GAMMA value, as C follows: C = 1: Use bisection method for decreasing GAMMA from GAMMA C to GAMMAMIN until the closed-loop system leaves C stability. C = 2: Scan from GAMMA to 0 trying to find the minimal GAMMA C for which the closed-loop system retains stability. C = 3: First bisection, then scanning. C = 4: Find suboptimal controller only. 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/output) DOUBLE PRECISION C The initial value of gamma on input. It is assumed that C gamma is sufficiently large so that the controller is C admissible. GAMMA >= 0. C On output it contains the minimal estimated gamma. 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 AC (output) DOUBLE PRECISION array, dimension (LDAC,2*N) C The leading 2*N-by-2*N part of this array contains the C closed-loop system state matrix AC. C C LDAC INTEGER C The leading dimension of the array AC. C LDAC >= max(1,2*N). C C BC (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON) C The leading 2*N-by-(M-NCON) part of this array contains C the closed-loop system input matrix BC. C C LDBC INTEGER C The leading dimension of the array BC. C LDBC >= max(1,2*N). C C CC (output) DOUBLE PRECISION array, dimension (LDCC,2*N) C The leading (NP-NMEAS)-by-2*N part of this array contains C the closed-loop system output matrix CC. C C LDCC INTEGER C The leading dimension of the array CC. C LDCC >= max(1,NP-NMEAS). C C DC (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON) C The leading (NP-NMEAS)-by-(M-NCON) part of this array C contains the closed-loop system input/output matrix DC. C C LDDC INTEGER C The leading dimension of the array DC. C LDDC >= max(1,NP-NMEAS). C C RCOND (output) DOUBLE PRECISION array, dimension (4) C For the last successful step: 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 GTOL DOUBLE PRECISION C Tolerance used for controlling the accuracy of GAMMA C and its distance to the estimated minimal possible C value of GAMMA. C If GTOL <= 0, then a default value equal to sqrt(EPS) C is used, where EPS is the relative machine precision. C C ACTOL DOUBLE PRECISION C Upper bound for the poles of the closed-loop system C used for determining if it is stable. C ACTOL <= 0 for stable systems. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= max(2*max(N,M-NCON,NP-NMEAS,NCON,NMEAS),N*N) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) contains the optimal C value of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= LW1 + max(1,LW2,LW3,LW4,LW5 + MAX(LW6,LW7)), C where C LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2; C LW2 = max( ( N + NP1 + 1 )*( N + M2 ) + C max( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), C ( N + NP2 )*( N + M1 + 1 ) + C max( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), C M2 + NP1*NP1 + max( NP1*max( N, M1 ), C 3*M2 + NP1, 5*M2 ), C NP2 + M1*M1 + max( max( N, NP1 )*M1, C 3*NP2 + M1, 5*NP2 ) ); C LW3 = max( ND1*M1 + max( 4*min( ND1, M1 ) + max( ND1,M1 ), C 6*min( ND1, M1 ) ), C NP1*ND2 + max( 4*min( NP1, ND2 ) + C max( NP1,ND2 ), C 6*min( NP1, ND2 ) ) ); C LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; C LW5 = 2*N*N + M*N + N*NP; C LW6 = max( M*M + max( 2*M1, 3*N*N + C 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 LW7 = M2*NP2 + NP2*NP2 + M2*M2 + C max( ND1*ND1 + max( 2*ND1, ( ND1 + ND2 )*NP2 ), C ND2*ND2 + max( 2*ND2, ND2*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 M1 = M - M2, NP1 = NP - NP2, C ND1 = NP1 - M2, ND2 = M1 - NP2. C For good performance, LDWORK must generally be larger. C C BWORK LOGICAL array, dimension (LBWORK) C C LBWORK INTEGER C The dimension of the array BWORK. LBWORK >= 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 SQRT(EPS); C = 4: if the matrix D21 had not full row rank in respect C to the tolerance SQRT(EPS); 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 = 10: if there are numerical problems when estimating C singular values of D1111, D1112, D1111', D1121'; C = 11: if the matrices Inp2 - D22*DK or Im2 - DK*D22 C are singular to working precision; C = 12: if a stabilizing controller cannot be found. 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 JOB = 1: It tries with a decreasing value of GAMMA, starting with C the given, and with the newly obtained controller estimates of the C closed-loop system. If it is stable, (i.e., max(eig(AC)) < ACTOL) C the iterations can be continued until the given tolerance between C GAMMA and the estimated GAMMAMIN is reached. Otherwise, in the C next step GAMMA is increased. The step in the all next iterations C is step = step/2. The closed-loop system is obtained by the C formulas given in [2]. C C JOB = 2: The same as for JOB = 1, but with non-varying step till C GAMMA = 0, step = max(0.1, GTOL). C C JOB = 3: Combines the JOB = 1 and JOB = 2 cases for a quicker C procedure. C C JOB = 4: Suboptimal controller for current GAMMA only. 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, MA, 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 This approach by estimating the closed-loop system and checking C its poles seems to be reliable. C C CONTRIBUTORS C C A. Markovski, P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, C July 2003. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. C C KEYWORDS C C Algebraic Riccati equation, H-infinity optimal control, robust C control. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, P1, THOUS PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, $ P1 = 0.1D+0, THOUS = 1.0D+3 ) C .. C .. Scalar Arguments .. INTEGER INFO, JOB, LBWORK, LDA, LDAC, LDAK, LDB, LDBC, $ LDBK, LDC, LDCC, LDCK, LDD, LDDC, LDDK, LDWORK, $ LIWORK, M, N, NCON, NMEAS, NP DOUBLE PRECISION ACTOL, GAMMA, GTOL C .. C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), AK( LDAK, * ), $ B( LDB, * ), BC( LDBC, * ), BK( LDBK, * ), $ C( LDC, * ), CC( LDCC, * ), CK( LDCK, * ), $ D( LDD, * ), DC( LDDC, * ), DK( LDDK, * ), $ DWORK( * ), RCOND( 4 ) C .. C .. Local Scalars .. INTEGER I, INF, INFO2, INFO3, IWAC, IWC, IWD, IWD1, $ IWF, IWH, IWRE, IWRK, IWS1, IWS2, IWTU, IWTY, $ IWWI, IWWR, IWX, IWY, LW1, LW2, LW3, LW4, LW5, $ LW6, LW7, LWAMAX, M1, M11, M2, MINWRK, MODE, $ NP1, NP11, NP2 DOUBLE PRECISION GAMABS, GAMAMN, GAMAMX, GTOLL, MINEAC, STEPG, $ TOL2 C .. C .. External Functions .. LOGICAL SELECT DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, SELECT C .. C .. External Subroutines .. EXTERNAL DGEES, DGESVD, DLACPY, SB10LD, SB10PD, SB10QD, $ SB10RD, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C .. C .. Executable Statements .. C C Decode and test input parameters. C M1 = M - NCON M2 = NCON NP1 = NP - NMEAS NP2 = NMEAS NP11 = NP1 - M2 M11 = M1 - NP2 C INFO = 0 IF ( JOB.LT.1 .OR. JOB.GT.4 ) 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( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN INFO = -5 ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN INFO = -6 ELSE IF( GAMMA.LT.ZERO ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -13 ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN INFO = -15 ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN INFO = -19 ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN INFO = -21 ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN INFO = -23 ELSE IF( LDAC.LT.MAX( 1, 2*N ) ) THEN INFO = -25 ELSE IF( LDBC.LT.MAX( 1, 2*N ) ) THEN INFO = -27 ELSE IF( LDCC.LT.MAX( 1, NP1 ) ) THEN INFO = -29 ELSE IF( LDDC.LT.MAX( 1, NP1 ) ) THEN INFO = -31 ELSE C C Compute workspace. C LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2 LW2 = MAX( ( N + NP1 + 1 )*( N + M2 ) + $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), $ ( N + NP2 )*( N + M1 + 1 ) + $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), $ M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, $ 5*M2 ), $ NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, $ 5*NP2 ) ) LW3 = MAX( NP11*M1 + MAX( 4*MIN( NP11, M1 ) + MAX( NP11, M1 ), $ 6*MIN( NP11, M1 ) ), $ NP1*M11 + MAX( 4*MIN( NP1, M11 ) + MAX( NP1, M11 ), $ 6*MIN( NP1, M11 ) ) ) LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP LW5 = 2*N*N + M*N + N*NP LW6 = MAX( 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 ) ) ) LW7 = M2*NP2 + NP2*NP2 + M2*M2 + $ MAX( NP11*NP11 + MAX( 2*NP11, ( NP11 + M11 )*NP2 ), $ M11*M11 + MAX( 2*M11, M11*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 = LW1 + MAX( 1, LW2, LW3, LW4, LW5 + MAX( LW6, LW7 ) ) IF( LDWORK.LT.MINWRK ) THEN INFO = -38 ELSE IF( LIWORK.LT.MAX( 2*MAX( N, M1, NP1, M2, NP2 ), $ N*N ) ) THEN INFO = -36 ELSE IF( LBWORK.LT.2*N ) THEN INFO = -40 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB10AD', -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 MODE = JOB IF ( MODE.GT.2 ) $ MODE = 1 GTOLL = GTOL IF( GTOLL.LE.ZERO ) THEN C C Set the default value of the tolerance for GAMMA. C GTOLL = SQRT( DLAMCH( 'Epsilon' ) ) END IF C C Workspace usage 1. 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 ) C CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) C 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 optimal controller. C Workspace: need LW1 + MAX(1,LWP1,LWP2,LWP3,LWP4), C prefer larger, C where C LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2 C LWP1 = (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)), C LWP2 = (N+NP2)*(N+M1+1) + MAX(3*(N+NP2)+N+M1,5*(N+NP2)), C LWP3 = M2 + NP1*NP1 + MAX(NP1*MAX(N,M1),3*M2+NP1,5*M2), C LWP4 = NP2 + M1*M1 + MAX(MAX(N,NP1)*M1,3*NP2+M1,5*NP2), C with M1 = M - M2 and NP1 = NP - NP2. C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is C LW1 + MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1). C TOL2 = -ONE 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, TOL2, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO2 ) C LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 C IF ( INFO2.NE.0 ) THEN INFO = INFO2 RETURN END IF C C Workspace usage 2. C IWD1 = IWRK IWS1 = IWD1 + NP11*M1 C C Check if GAMMA < max(sigma[D1111,D1112],sigma[D1111',D1121']). C Workspace: need LW1 + MAX(1, LWS1, LWS2), C prefer larger, C where C LWS1 = NP11*M1 + MAX(4*MIN(NP11,M1)+MAX(NP11,M1),6*MIN(NP11,M1)) C LWS2 = NP1*M11 + MAX(4*MIN(NP1,M11)+MAX(NP1,M11),6*MIN(NP1,M11)) C INFO2 = 0 INFO3 = 0 C IF ( NP11.NE.0 .AND. M1.NE.0 ) THEN IWRK = IWS1 + MIN( NP11, M1 ) CALL DLACPY( 'Full', NP11, M1, DWORK(IWD), LDD, DWORK(IWD1), $ NP11 ) CALL DGESVD( 'N', 'N', NP11, M1, DWORK(IWD1), NP11, $ DWORK(IWS1), DWORK(IWS1), 1, DWORK(IWS1), 1, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) ELSE DWORK(IWS1) = ZERO END IF C IWS2 = IWD1 + NP1*M11 IF ( NP1.NE.0 .AND. M11.NE.0 ) THEN IWRK = IWS2 + MIN( NP1, M11 ) CALL DLACPY( 'Full', NP1, M11, DWORK(IWD), LDD, DWORK(IWD1), $ NP1 ) CALL DGESVD( 'N', 'N', NP1, M11, DWORK(IWD1), NP1, DWORK(IWS2), $ DWORK(IWS2), 1, DWORK(IWS2), 1, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO3 ) LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) ELSE DWORK(IWS2) = ZERO END IF C GAMAMN = MAX( DWORK(IWS1), DWORK(IWS2) ) C IF ( INFO2.GT.0 .OR. INFO3.GT.0 ) THEN INFO = 10 RETURN ELSE IF ( GAMMA.LE.GAMAMN ) THEN INFO = 6 RETURN END IF C C Workspace usage 3. C IWX = IWD1 IWY = IWX + N*N IWF = IWY + N*N IWH = IWF + M*N IWRK = IWH + N*NP IWAC = IWD1 IWWR = IWAC + 4*N*N IWWI = IWWR + 2*N IWRE = IWWI + 2*N C C Prepare some auxiliary variables for the gamma iteration. C STEPG = GAMMA - GAMAMN GAMABS = GAMMA GAMAMX = GAMMA INF = 0 C C ############################################################### C C Begin the gamma iteration. C 10 CONTINUE STEPG = STEPG/TWO C C Try to compute the state feedback and output injection C matrices for the current GAMMA. 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 ) C IF ( INFO2.NE.0 ) GOTO 30 C C Try to compute the Hinf suboptimal (yet) 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 ) C IF ( INFO2.NE.0 ) GOTO 30 C C Compute the closed-loop system. C Workspace: need LW1 + 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; C prefer larger. C CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D, $ LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC, $ LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, $ DWORK( IWD1 ), LDWORK-IWD1+1, INFO2 ) C IF ( INFO2.NE.0 ) GOTO 30 C LWAMAX = MAX( LWAMAX, INT( DWORK( IWD1 ) ) + IWD1 - 1 ) C C Compute the poles of the closed-loop system. C Workspace: need LW1 + 4*N*N + 4*N + max(1,6*N); C prefer larger. C CALL DLACPY( 'Full', 2*N, 2*N, AC, LDAC, DWORK(IWAC), 2*N ) C CALL DGEES( 'N', 'N', SELECT, 2*N, DWORK(IWAC), 2*N, IWORK, $ DWORK(IWWR), DWORK(IWWI), DWORK(IWRE), 1, $ DWORK(IWRE), LDWORK-IWRE+1, BWORK, INFO2 ) C LWAMAX = MAX( LWAMAX, INT( DWORK( IWRE ) ) + IWRE - 1 ) C C Now DWORK(IWWR+I)=Re(Lambda), DWORK(IWWI+I)=Im(Lambda), C for I=0,2*N-1. C MINEAC = -THOUS C DO 20 I = 0, 2*N - 1 MINEAC = MAX( MINEAC, DWORK(IWWR+I) ) 20 CONTINUE C C Check if the closed-loop system is stable. C 30 IF ( MODE.EQ.1 ) THEN IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN GAMABS = GAMMA GAMMA = GAMMA - STEPG INF = 1 ELSE GAMMA = MIN( GAMMA + STEPG, GAMAMX ) END IF ELSE IF ( MODE.EQ.2 ) THEN IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN GAMABS = GAMMA INF = 1 END IF GAMMA = GAMMA - MAX( P1, GTOLL ) END IF C C More iterations? C IF ( MODE.EQ.1 .AND. JOB.EQ.3 .AND. TWO*STEPG.LT.GTOLL ) THEN MODE = 2 GAMMA = GAMABS END IF C IF ( JOB.NE.4 .AND. $ ( MODE.EQ.1 .AND. TWO*STEPG.GE.GTOLL .OR. $ MODE.EQ.2 .AND. GAMMA.GT.ZERO ) ) THEN GOTO 10 END IF C C ############################################################### C C End of the gamma iteration - Return if no stabilizing controller C was found. C IF ( INF.EQ.0 ) THEN INFO = 12 RETURN END IF C C Now compute the state feedback and output injection matrices C using GAMABS. C GAMMA = GAMABS C C Integer workspace: need max(2*max(N,M-NCON,NP-NMEAS),N*N). C Workspace: need LW1P + C max(1,M*M + max(2*M1,3*N*N + C 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 prefer larger, C where LW1P = LW1 + 2*N*N + M*N + N*NP. C An upper bound of the second term after LW1P is C max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))). 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 ) C LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) C IF ( INFO2.GT.0 ) THEN INFO = INFO2 + 5 RETURN END IF C C Compute the Hinf optimal controller. C Integer workspace: need max(2*(max(NP,M)-M2-NP2,M2,N),NP2). C Workspace: need LW1P + 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 where D1 = NP1 - M2 = NP11, D2 = M1 - NP2 = M11; C prefer larger. C An upper bound of the second term after LW1P is C max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, N)))). 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 ) C LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) C IF( INFO2.EQ.1 ) THEN INFO = 6 RETURN ELSE IF( INFO2.EQ.2 ) THEN INFO = 9 RETURN END IF C C Integer workspace: need 2*max(NCON,NMEAS). C Workspace: need 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; C prefer larger. C CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D, $ LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC, $ LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, DWORK, $ LDWORK, INFO2 ) C IF( INFO2.GT.0 ) THEN INFO = 11 RETURN END IF C DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MD03BF.f0000644000000000000000000000013015012430707016146 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MD03BF.f0000644000175000017500000000613415012430707017350 0ustar00lilgelilge00000000000000 SUBROUTINE MD03BF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEVL, E, J, LDJ, DWORK, LDWORK, $ INFO ) C C PURPOSE C C This is the FCN routine for solving a standard nonlinear least C squares problem using SLICOT Library routine MD03BD. See the C parameter FCN in the routine MD03BD for the description of C parameters. C C The example programmed in this routine is adapted from that C accompanying the MINPACK routine LMDER. C C ****************************************************************** C C .. Parameters .. C .. NOUT is the unit number for printing intermediate results .. INTEGER NOUT PARAMETER ( NOUT = 6 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER IFLAG, INFO, LDJ, LDPAR1, LDPAR2, LDWORK, LIPAR, $ M, N, NFEVL C .. Array Arguments .. INTEGER IPAR(*) DOUBLE PRECISION DPAR1(*), DPAR2(*), DWORK(*), E(*), J(LDJ,*), $ X(*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION ERR, TMP1, TMP2, TMP3, TMP4 C .. External Functions .. DOUBLE PRECISION DNRM2 EXTERNAL DNRM2 C .. DATA Statements .. DOUBLE PRECISION Y(15) DATA Y(1), Y(2), Y(3), Y(4), Y(5), Y(6), Y(7), Y(8), $ Y(9), Y(10), Y(11), Y(12), Y(13), Y(14), Y(15) $ / 1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1, $ 3.2D-1, 3.5D-1, 3.9D-1, 3.7D-1, 5.8D-1, $ 7.3D-1, 9.6D-1, 1.34D0, 2.1D0, 4.39D0 / C C .. Executable Statements .. C INFO = 0 IF ( IFLAG.EQ.1 ) THEN C C Compute the error function values. C DO 10 I = 1, 15 TMP1 = I TMP2 = 16 - I IF ( I.GT.8 ) THEN TMP3 = TMP2 ELSE TMP3 = TMP1 END IF E(I) = Y(I) - ( X(1) + TMP1/( X(2)*TMP2 + X(3)*TMP3 ) ) 10 CONTINUE C ELSE IF ( IFLAG.EQ.2 ) THEN C C Compute the Jacobian. C DO 30 I = 1, 15 TMP1 = I TMP2 = 16 - I IF ( I.GT.8 ) THEN TMP3 = TMP2 ELSE TMP3 = TMP1 END IF TMP4 = ( X(2)*TMP2 + X(3)*TMP3 )**2 J(I,1) = -ONE J(I,2) = TMP1*TMP2/TMP4 J(I,3) = TMP1*TMP3/TMP4 30 CONTINUE C NFEVL = 0 C ELSE IF ( IFLAG.EQ.3 ) THEN C C Set the parameter LDJ, the length of the array J, and the sizes C of the workspace for FCN (IFLAG = 1 or 2), MD03BA and MD03BB. C LDJ = M IPAR(1) = M*N IPAR(2) = 0 IPAR(3) = 0 IPAR(4) = 4*N + 1 IPAR(5) = 4*N C ELSE IF ( IFLAG.EQ.0 ) THEN C C Special call for printing intermediate results. C ERR = DNRM2( M, E, 1 ) WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR C END IF C RETURN C C *** Last line of MD03BF *** END control-4.1.2/src/slicot/src/PaxHeaders/TD03AY.f0000644000000000000000000000013215012430707016201 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TD03AY.f0000644000175000017500000001247415012430707017405 0ustar00lilgelilge00000000000000 SUBROUTINE TD03AY( MWORK, PWORK, INDEX, DCOEFF, LDDCOE, UCOEFF, $ LDUCO1, LDUCO2, N, A, LDA, B, LDB, C, LDC, D, $ LDD, INFO ) C C PURPOSE C C Calculates a state-space representation for a (PWORK x MWORK) C transfer matrix given in the form of polynomial row vectors over C common denominators (not necessarily lcd's). Such a description C is simply the polynomial matrix representation C C T(s) = inv(D(s)) * U(s), C C where D(s) is diagonal with (I,I)-th element D:I(s) of degree C INDEX(I); applying Wolovich's Observable Structure Theorem to C this left matrix fraction then yields an equivalent state-space C representation in observable companion form, of order C N = sum(INDEX(I)). As D(s) is diagonal, the PWORK ordered C 'non-trivial' columns of C and A are very simply calculated, these C submatrices being diagonal and (INDEX(I) x 1) - block diagonal, C respectively: finding B and D is also somewhat simpler than for C general P(s) as dealt with in TC04AD. Finally, the state-space C representation obtained here is not necessarily controllable C (as D(s) and U(s) are not necessarily relatively left prime), but C it is theoretically completely observable: however, its C observability matrix may be poorly conditioned, so it is safer C not to assume observability either. C C REVISIONS C C May 13, 1998. C C KEYWORDS C C Coprime matrix fraction, elementary polynomial operations, C polynomial matrix, state-space representation, transfer matrix. C C ****************************************************************** C DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, $ LDUCO2, MWORK, N, PWORK C .. Array Arguments .. INTEGER INDEX(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DCOEFF(LDDCOE,*), UCOEFF(LDUCO1,LDUCO2,*) C .. Local Scalars .. INTEGER I, IA, IBIAS, INDCUR, JA, JMAX1, K DOUBLE PRECISION ABSDIA, ABSDMX, BIGNUM, DIAG, SMLNUM, UMAX1, $ TEMP C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, IDAMAX C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLASET, DSCAL C .. Intrinsic Functions .. INTRINSIC ABS C .. Executable Statements .. C INFO = 0 C C Initialize A and C to be zero, apart from 1's on the subdiagonal C of A. C CALL DLASET( 'Upper', N, N, ZERO, ZERO, A, LDA ) IF ( N.GT.1 ) CALL DLASET( 'Lower', N-1, N-1, ZERO, ONE, A(2,1), $ LDA ) C CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC ) C C Calculate B and D, as well as 'non-trivial' elements of A and C. C Check if any leading coefficient of D(s) nearly zero: if so, exit. C Caution is taken to avoid overflow. C SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM C IBIAS = 2 JA = 0 C DO 20 I = 1, PWORK ABSDIA = ABS( DCOEFF(I,1) ) JMAX1 = IDAMAX( MWORK, UCOEFF(I,1,1), LDUCO1 ) UMAX1 = ABS( UCOEFF(I,JMAX1,1) ) IF ( ( ABSDIA.LT.SMLNUM ) .OR. $ ( ABSDIA.LT.ONE .AND. UMAX1.GT.ABSDIA*BIGNUM ) ) THEN C C Error return. C INFO = I RETURN END IF DIAG = ONE/DCOEFF(I,1) INDCUR = INDEX(I) IF ( INDCUR.NE.0 ) THEN IBIAS = IBIAS + INDCUR JA = JA + INDCUR IF ( INDCUR.GE.1 ) THEN JMAX1 = IDAMAX( INDCUR, DCOEFF(I,2), LDDCOE ) ABSDMX = ABS( DCOEFF(I,JMAX1) ) IF ( ABSDIA.GE.ONE ) THEN IF ( UMAX1.GT.ONE ) THEN IF ( ( ABSDMX/ABSDIA ).GT.( BIGNUM/UMAX1 ) ) THEN C C Error return. C INFO = I RETURN END IF END IF ELSE IF ( UMAX1.GT.ONE ) THEN IF ( ABSDMX.GT.( BIGNUM*ABSDIA )/UMAX1 ) THEN C C Error return. C INFO = I RETURN END IF END IF END IF END IF C C I-th 'non-trivial' sub-vector of A given from coefficients C of D:I(s), while I-th row block of B given from this and C row I of U(s). C DO 10 K = 2, INDCUR + 1 IA = IBIAS - K TEMP = -DIAG*DCOEFF(I,K) A(IA,JA) = TEMP C CALL DCOPY( MWORK, UCOEFF(I,1,K), LDUCO1, B(IA,1), LDB ) CALL DAXPY( MWORK, TEMP, UCOEFF(I,1,1), LDUCO1, B(IA,1), $ LDB ) 10 CONTINUE C IF ( JA.LT.N ) A(JA+1,JA) = ZERO C C Finally, I-th 'non-trivial' entry of C and row of D obtained C also. C C(I,JA) = DIAG END IF C CALL DCOPY( MWORK, UCOEFF(I,1,1), LDUCO1, D(I,1), LDD ) CALL DSCAL( MWORK, DIAG, D(I,1), LDD ) 20 CONTINUE C RETURN C *** Last line of TD03AY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04UD.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04UD.f0000644000175000017500000003153415012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, $ Z, LDZ, RANKE, ISTAIR, TOL, DWORK, INFO ) C C PURPOSE C C To compute orthogonal transformations Q and Z such that the C transformed pencil Q'(sE-A)Z has the E matrix in column echelon C form, where E and A are M-by-N matrices. C C ARGUMENTS C C Mode Parameters C C JOBQ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Q the unitary row permutations, as follows: C = 'N': Do not form Q; C = 'I': Q is initialized to the unit matrix and the C unitary row permutation matrix Q is returned; C = 'U': The given matrix Q is updated by the unitary C row permutations used in the reduction. C C JOBZ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Z the unitary column transformations, as follows: C = 'N': Do not form Z; C = 'I': Z is initialized to the unit matrix and the C unitary transformation matrix Z is returned; C = 'U': The given matrix Z is updated by the unitary C transformations used in the reduction. C C Input/Output Parameters C C M (input) INTEGER C The number of rows in the matrices A, E and the order of C the matrix Q. M >= 0. C C N (input) INTEGER C The number of columns in the matrices A, E and the order C of the matrix Z. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading M-by-N part of this array must C contain the A matrix of the pencil sE-A. C On exit, the leading M-by-N part of this array contains C the unitary transformed matrix Q' * A * Z. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading M-by-N part of this array must C contain the E matrix of the pencil sE-A, to be reduced to C column echelon form. C On exit, the leading M-by-N part of this array contains C the unitary transformed matrix Q' * E * Z, which is in C column echelon form. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,M). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) C On entry, if JOBQ = 'U', then the leading M-by-M part of C this array must contain a given matrix Q (e.g. from a C previous call to another SLICOT routine), and on exit, the C leading M-by-M part of this array contains the product of C the input matrix Q and the row permutation matrix used to C transform the rows of matrix E. C On exit, if JOBQ = 'I', then the leading M-by-M part of C this array contains the matrix of accumulated unitary C row transformations performed. C If JOBQ = 'N', the array Q is not referenced and can be C supplied as a dummy array (i.e. set parameter LDQ = 1 and C declare this array to be Q(1,1) in the calling program). C C LDQ INTEGER C The leading dimension of array Q. If JOBQ = 'U' or C JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) C On entry, if JOBZ = 'U', then the leading N-by-N part of C this array must contain a given matrix Z (e.g. from a C previous call to another SLICOT routine), and on exit, the C leading N-by-N part of this array contains the product of C the input matrix Z and the column transformation matrix C used to transform the columns of matrix E. C On exit, if JOBZ = 'I', then the leading N-by-N part of C this array contains the matrix of accumulated unitary C column transformations performed. C If JOBZ = 'N', the array Z is not referenced and can be C supplied as a dummy array (i.e. set parameter LDZ = 1 and C declare this array to be Z(1,1) in the calling program). C C LDZ INTEGER C The leading dimension of array Z. If JOBZ = 'U' or C JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. C C RANKE (output) INTEGER C The computed rank of the unitary transformed matrix E. C C ISTAIR (output) INTEGER array, dimension (M) C This array contains information on the column echelon form C of the unitary transformed matrix E. Specifically, C ISTAIR(i) = +j if the first non-zero element E(i,j) C is a corner point and -j otherwise, for i = 1,2,...,M. C C Tolerances C C TOL DOUBLE PRECISION C A tolerance below which matrix elements are considered C to be zero. If the user sets TOL to be less than (or C equal to) zero then the tolerance is taken as C EPS * MAX(ABS(E(I,J))), where EPS is the machine C precision (see LAPACK Library routine DLAMCH), C I = 1,2,...,M and J = 1,2,...,N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (MAX(M,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 METHOD C C Given an M-by-N matrix pencil sE-A with E not necessarily regular, C the routine computes a unitary transformed pencil Q'(sE-A)Z such C that the matrix Q' * E * Z is in column echelon form (trapezoidal C form). Further details can be found in [1]. C C [An M-by-N matrix E with rank(E) = r is said to be in column C echelon form if the following conditions are satisfied: C (a) the first (N - r) columns contain only zero elements; and C (b) if E(i(k),k) is the last nonzero element in column k for C k = N-r+1,...,N, i.e. E(i(k),k) <> 0 and E(j,k) = 0 for C j > i(k), then 1 <= i(N-r+1) < i(N-r+2) < ... < i(N) <= M.] C C REFERENCES C C [1] Beelen, Th. and Van Dooren, P. C An improved algorithm for the computation of Kronecker's C canonical form of a singular pencil. C Linear Algebra and Applications, 105, pp. 9-65, 1988. C C NUMERICAL ASPECTS C C It is shown in [1] that the algorithm is numerically backward C stable. The operations count is proportional to (MAX(M,N))**3. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. C Based on Release 3.0 routine MB04SD modified by A. Varga, C German Aerospace Research Establishment, Oberpfaffenhofen, C Germany, Dec. 1997, to transform also the matrix A. C C REVISIONS C C A. Varga, DLR Oberpfaffenhofen, June 2005. C C KEYWORDS C C Echelon form, orthogonal transformation, staircase form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBQ, JOBZ INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, RANKE DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER ISTAIR(*) DOUBLE PRECISION A(LDA,*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. LOGICAL LJOBQI, LJOBZI, LZERO, UPDATQ, UPDATZ INTEGER I, K, KM1, L, LK, MNK, NR1 DOUBLE PRECISION EMX, EMXNRM, TAU, TOLER C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DLARF, DLARFG, DLASET, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. Executable Statements .. C INFO = 0 LJOBQI = LSAME( JOBQ, 'I' ) UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' ) LJOBZI = LSAME( JOBZ, 'I' ) UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' ) C C Test the input scalar arguments. C IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) 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 ) ) THEN INFO = -6 ELSE IF( LDE.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR. $ UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR. $ UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN INFO = -12 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB04UD', -INFO ) RETURN END IF C C Initialize Q and Z to the identity matrices, if needed. C IF ( LJOBQI ) $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) IF ( LJOBZI ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) C C Quick return if possible. C RANKE = MIN( M, N ) C IF ( RANKE.EQ.0 ) $ RETURN C TOLER = TOL IF ( TOLER.LE.ZERO ) $ TOLER = DLAMCH( 'Epsilon' )*DLANGE( 'M', M, N, E, LDE, DWORK ) C K = N LZERO = .FALSE. C C WHILE ( ( K > 0 ) AND ( NOT a zero submatrix encountered ) ) DO 20 IF ( ( K.GT.0 ) .AND. ( .NOT. LZERO ) ) THEN C C Intermediate form of E C C <--k--><--n-k-> C l=1 |x....x| | C | | | C | Ek | X | C | | | C l=m-n+k |x....x| | C ---------------- C | |x ... x| } C | O | x x x| } C | | x x| } n-k C | | x| } C C where submatrix Ek = E[1:m-n+k;1:k]. C C Determine row LK in submatrix Ek with largest max-norm C (starting with row m-n+k). C MNK = M - N + K EMXNRM = ZERO LK = MNK C DO 40 L = MNK, 1, -1 EMX = ABS( E(L,IDAMAX( K, E(L,1), LDE )) ) IF ( EMX.GT.EMXNRM ) THEN EMXNRM = EMX LK = L END IF 40 CONTINUE C IF ( EMXNRM.LE.TOLER ) THEN C C Set submatrix Ek to zero. C CALL DLASET( 'Full', MNK, K, ZERO, ZERO, E, LDE ) LZERO = .TRUE. RANKE = N - K ELSE C C Submatrix Ek is not considered to be identically zero. C Check whether rows have to be interchanged. C IF ( LK.NE.MNK ) THEN C C Interchange rows lk and m-n+k in whole A- and E-matrix C and update the row transformation matrix Q, if needed. C (For Q, the number of elements involved is m.) C CALL DSWAP( N, E(LK,1), LDE, E(MNK,1), LDE ) CALL DSWAP( N, A(LK,1), LDA, A(MNK,1), LDA ) IF( UPDATQ ) CALL DSWAP( M, Q(1,LK), 1, Q(1,MNK), 1 ) END IF C KM1 = K - 1 C C Determine a Householder transformation to annihilate C E(m-n+k,1:k-1) using E(m-n+k,k) as pivot. C Apply the transformation to the columns of A and Ek C (number of elements involved is m for A and m-n+k for Ek). C Update the column transformation matrix Z, if needed C (number of elements involved is n). C CALL DLARFG( K, E(MNK,K), E(MNK,1), LDE, TAU ) EMX = E(MNK,K) E(MNK,K) = ONE CALL DLARF( 'Right', MNK-1, K, E(MNK,1), LDE, TAU, E, LDE, $ DWORK ) CALL DLARF( 'Right', M, K, E(MNK,1), LDE, TAU, A, LDA, $ DWORK ) IF( UPDATZ ) CALL DLARF( 'Right', N, K, E(MNK,1), LDE, TAU, $ Z, LDZ, DWORK ) E(MNK,K) = EMX CALL DLASET( 'Full', 1, KM1, ZERO, ZERO, E(MNK,1), LDE ) C K = KM1 END IF GO TO 20 END IF C END WHILE 20 C C Initialise administration staircase form, i.e. C ISTAIR(i) = j if E(i,j) is a nonzero corner point C = -j if E(i,j) is on the boundary but is no corner C point. C Thus, C ISTAIR(m-k) = n-k for k=0,...,rank(E)-1 C = -(n-rank(E)+1) for k=rank(E),...,m-1. C DO 60 I = 0, RANKE - 1 ISTAIR(M-I) = N - I 60 CONTINUE C NR1 = -(N - RANKE + 1) C DO 80 I = 1, M - RANKE ISTAIR(I) = NR1 80 CONTINUE C RETURN C *** Last line of MB04UD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03OZ.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03OZ.f0000644000175000017500000007432015012430707017417 0ustar00lilgelilge00000000000000 SUBROUTINE SB03OZ( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B, $ LDB, SCALE, W, DWORK, ZWORK, LZWORK, INFO ) C C PURPOSE C H C To solve for X = op(U) *op(U) either the stable non-negative C definite continuous-time Lyapunov equation C H 2 H C op(A) *X + X*op(A) = -scale *op(B) *op(B), (1) C C or the convergent non-negative definite discrete-time Lyapunov C equation C H 2 H C op(A) *X*op(A) - X = -scale *op(B) *op(B), (2) C C where op(K) = K or K**H (i.e., the conjugate transpose of the C matrix K), A is an N-by-N matrix, op(B) is an M-by-N matrix, U is C an upper triangular matrix containing the Cholesky factor of the C solution matrix X, and scale is an output scale factor, set less C than or equal to 1 to avoid overflow in X. If matrix B has full C rank, then the solution matrix X will be positive definite and C hence the Cholesky factor U will be nonsingular, but if B is rank C deficient, then X may be only positive semi-definite and U will be C singular. C C In the case of equation (1) the matrix A must be stable (that is, C all the eigenvalues of A must have negative real parts), and for C equation (2) the matrix A must be convergent (that is, all the C eigenvalues of A must lie inside the unit circle). C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of Lyapunov equation to be solved, as C follows: C = 'C': Equation (1), continuous-time case; C = 'D': Equation (2), discrete-time case. C C FACT CHARACTER*1 C Specifies whether or not the Schur factorization of the C matrix A is supplied on entry, as follows: C = 'F': On entry, A and Q contain the factors from the C 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 Q. C C TRANS CHARACTER*1 C Specifies the form of op(K) to be used, as follows: C = 'N': op(K) = K (No transpose); C = 'C': op(K) = K**H (Conjugate transpose). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A and the number of columns of C the matrix op(B). N >= 0. C C M (input) INTEGER C The number of rows of the matrix op(B). M >= 0. C If M = 0, A is unchanged on exit, and Q and W are not set. C C A (input/output) COMPLEX*16 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 triangular matrix S in Schur form; the elements C below the diagonal of the array A are then not referenced. C On exit, the leading N-by-N upper triangular part of this C array contains the upper triangle of the matrix S. C The contents of the array A is not modified if FACT = 'F'. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C Q (input or output) COMPLEX*16 array, dimension (LDQ,N) C On entry, if FACT = 'F', then the leading N-by-N part of C this array must contain the unitary matrix Q of the Schur C factorization of A. C Otherwise, Q need not be set on entry. C On exit, the leading N-by-N part of this array contains C the unitary matrix Q of the Schur factorization of A. C The contents of the array Q is not modified if FACT = 'F'. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= MAX(1,N). C C B (input/output) COMPLEX*16 array, dimension (LDB,N) C if TRANS = 'N', and dimension (LDB,max(M,N)), if C TRANS = 'C'. C On entry, if TRANS = 'N', the leading M-by-N part of this C array must contain the coefficient matrix B of the C equation. C On entry, if TRANS = 'C', the leading N-by-M part of this C array must contain the coefficient matrix B of the C equation. C On exit, the leading N-by-N part of this array contains C the upper triangular Cholesky factor U of the solution C matrix X of the problem, X = op(U)**H * op(U). C If M = 0 and N > 0, then U is set to zero. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N,M), if TRANS = 'N'; C LDB >= MAX(1,N), if TRANS = 'C'. 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 W (output) COMPLEX*16 array, dimension (N) C If INFO >= 0 and INFO <= 3, W contains the eigenvalues of C the matrix A. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (N) C C ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0 or INFO = 1, ZWORK(1) returns the C optimal value of LZWORK. C On exit, if INFO = -16, ZWORK(1) returns the minimum value C of LZWORK. C C LZWORK INTEGER C The length of the array ZWORK. C If M > 0, LZWORK >= MAX(1,2*N+MAX(MIN(N,M)-2,0)); C If M = 0, LZWORK >= 1. C For optimum performance LZWORK should sometimes be larger. C C If LZWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the ZWORK C array, returns this value as the first entry of the ZWORK C array, and no error message related to LZWORK is issued by C 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 = 1: if the Lyapunov equation is (nearly) singular C (warning indicator); C if DICO = 'C' this means that while the matrix A C (or the factor S) has computed eigenvalues with C negative real parts, it is only just stable in the C sense that small perturbations in A can make one or C more of the eigenvalues have a non-negative real C part; C if DICO = 'D' this means that while the matrix A C (or the factor S) has computed eigenvalues inside C the unit circle, it is nevertheless only just C convergent, in the sense that small perturbations C in A can make one or more of the eigenvalues lie C outside the unit circle; C perturbed values were used to solve the equation; C = 2: if FACT = 'N' and DICO = 'C', but the matrix A is C not stable (that is, one or more of the eigenvalues C of A has a non-negative real part), or DICO = 'D', C but the matrix A is not convergent (that is, one or C more of the eigenvalues of A lies outside the unit C circle); however, A will still have been factored C and the eigenvalues of A returned in W; C = 3: if FACT = 'F' and DICO = 'C', but the Schur factor S C supplied in the array A is not stable (that is, one C or more of the eigenvalues of S has a non-negative C real part), or DICO = 'D', but the Schur factor S C supplied in the array A is not convergent (that is, C one or more of the eigenvalues of S lies outside the C unit circle); the eigenvalues of A are still C returned in W; C = 6: if FACT = 'N' and the LAPACK Library routine ZGEES C has failed to converge. This failure is not likely C to occur. The matrix B will be unaltered but A will C be destroyed. C C METHOD C C The method used by the routine is based on the Bartels and Stewart C method [1], except that it finds the upper triangular matrix U C directly without first finding X and without the need to form the C normal matrix op(B)**H * op(B). C C The Schur factorization of a square matrix A is given by C H C A = QSQ , C C where Q is unitary and S is an N-by-N upper triangular matrix. C If A has already been factored prior to calling the routine, then C the factors Q and S may be supplied and the initial factorization C omitted. C C If TRANS = 'N' and 6*M > 7*N, the matrix B is factored as C (QR factorization) C _ _ C B = P ( R ), C ( 0 ) C _ _ C where P is an M-by-M unitary matrix and R is a square upper C _ _ C triangular matrix. Then, the matrix B = RQ is factored as C _ C B = PR. C C If TRANS = 'N' and 6*M <= 7*N, the matrix BQ is factored as C C BQ = P ( R ), M >= N, BQ = P ( R Z ), M < N. C ( 0 ) C C If TRANS = 'C' and 6*M > 7*N, the matrix B is factored as C (RQ factorization) C _ _ C B = ( 0 R ) P, C _ _ C where P is an M-by-M unitary matrix and R is a square upper C _ H _ C triangular matrix. Then, the matrix B = Q R is factored as C _ C B = RP. C H C If TRANS = 'C' and 6*M <= 7*N, the matrix Q B is factored as C C H H ( Z ) C Q B = ( 0 R ) P, M >= N, Q B = ( ) P, M < N. C ( R ) C C These factorizations are utilised to either transform the C continuous-time Lyapunov equation to the canonical form C H H H 2 H C op(S) *op(V) *op(V) + op(V) *op(V)*op(S) = -scale *op(F) *op(F), C C or the discrete-time Lyapunov equation to the canonical form C H H H 2 H C op(S) *op(V) *op(V)*op(S) - op(V) *op(V) = -scale *op(F) *op(F), C C where V and F are upper triangular, and C C F = R, M >= N, F = ( R Z ), M < N, if TRANS = 'N'; C ( 0 0 ) C C F = R, M >= N, F = ( 0 Z ), M < N, if TRANS = 'C'. C ( 0 R ) C C The transformed equation is then solved for V, from which U is C obtained via the QR factorization of V*Q**H, if TRANS = 'N', or C via the RQ factorization of Q*V, if TRANS = 'C'. C C REFERENCES C C [1] Bartels, R.H. and Stewart, G.W. C Solution of the matrix equation A'X + XB = C. C Comm. A.C.M., 15, pp. 820-826, 1972. C C [2] 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 The Lyapunov equation may be very ill-conditioned. In particular, C if A is only just stable (or convergent) then the Lyapunov C equation will be ill-conditioned. A symptom of ill-conditioning C is "large" elements in U relative to those of A and B, or a C "small" value for scale. C C SB03OZ routine can be also used for solving "unstable" Lyapunov C equations, i.e., when matrix A has all eigenvalues with positive C real parts, if DICO = 'C', or with moduli greater than one, C if DICO = 'D'. Specifically, one may solve for X = op(U)**H*op(U) C either the continuous-time Lyapunov equation C H 2 H C op(A) *X + X*op(A) = scale *op(B) *op(B), (3) C C or the discrete-time Lyapunov equation C H 2 H C op(A) *X*op(A) - X = scale *op(B) *op(B), (4) C C provided, for equation (3), the given matrix A is replaced by -A, C or, for equation (4), the given matrices A and B are replaced by C inv(A) and B*inv(A), if TRANS = 'N' (or inv(A)*B, if TRANS = 'C'), C respectively. Although the inversion generally can rise numerical C problems, in case of equation (4) it is expected that the matrix A C is enough well-conditioned, having only eigenvalues with moduli C greater than 1. C C CONTRIBUTOR C C V. Sima, March 2022. C C REVISIONS C C V. Sima, April 2022. C C KEYWORDS C C Lyapunov equation, unitary transformation, Schur form, Sylvester C equation. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION ZERO, ONE, P95 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, P95 = 0.95D0 ) C .. Scalar Arguments .. CHARACTER DICO, FACT, TRANS INTEGER INFO, LDA, LDB, LDQ, LZWORK, M, N DOUBLE PRECISION SCALE C .. Array Arguments .. COMPLEX*16 A(LDA,*), B(LDB,*), Q(LDQ,*), W(*), ZWORK(*) DOUBLE PRECISION DWORK(*) C .. Local Scalars .. DOUBLE PRECISION BIGNMS, BIGNUM, EMAX, EPS, MA, MATO, MB, MBTO, $ MN, MX, SAFMIN, SMLNUM, T, TMP INTEGER BL, I, IFAIL, INFORM, ITAU, J, JWORK, K, L, $ MAXMN, MINMN, MINWRK, NC, NM, NR, SDIM, WRKOPT LOGICAL CONT, ISTRAN, LASCL, LBSCL, LQUERY, LSCL, $ NOFACT, NUNITQ, SCALB, SMALLM C .. Local Arrays .. LOGICAL BWORK(1) C .. External Functions .. LOGICAL LSAME, MA02HZ, SELECT DOUBLE PRECISION DLAMCH, ZLANGE, ZLANTR EXTERNAL DLAMCH, LSAME, MA02HZ, SELECT, ZLANGE, ZLANTR C .. External Subroutines .. EXTERNAL DLABAD, MB01UZ, SB03OS, XERBLA, ZCOPY, ZDSCAL, $ ZGEES, ZGEMM, ZGEMV, ZGEQRF, ZGERQF, ZLACGV, $ ZLACPY, ZLASCL, ZLASET, ZSWAP, ZTRMM C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C C Test the input scalar arguments. C CONT = LSAME( DICO, 'C' ) NOFACT = LSAME( FACT, 'N' ) ISTRAN = LSAME( TRANS, 'C' ) LQUERY = LZWORK.EQ.-1 MINMN = MIN( M, N ) MAXMN = MAX( M, N ) C INFO = 0 IF ( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN INFO = -1 ELSE IF ( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN INFO = -2 ELSE IF ( .NOT.ISTRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN INFO = -3 ELSE IF ( N.LT.0 ) THEN INFO = -4 ELSE IF ( M.LT.0 ) THEN INFO = -5 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF ( LDQ.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF ( ( ISTRAN .AND. ( LDB.LT.MAX( 1, N ) ) ) .OR. $ ( .NOT.ISTRAN .AND. ( LDB.LT.MAX( 1, MAXMN ) ) ) ) THEN INFO = -11 ELSE IF ( MINMN.EQ.0 ) THEN MINWRK = 1 ELSE MINWRK = 2*N + MAX( MINMN - 2, 0 ) END IF SMALLM = 6*M.LE.7*N IF ( LQUERY ) THEN IF ( NOFACT ) THEN CALL ZGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, $ SDIM, W, Q, LDQ, ZWORK, -1, DWORK, BWORK, $ IFAIL ) WRKOPT = MAX( MINWRK, INT( ZWORK(1) ) ) ELSE WRKOPT = MINWRK END IF CALL ZGEQRF( MAXMN, N, B, LDB, ZWORK, ZWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) + N ) ELSE IF ( LZWORK.LT.MINWRK ) THEN ZWORK(1) = MINWRK INFO = -16 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB03OZ', -INFO ) RETURN ELSE IF ( LQUERY ) THEN ZWORK(1) = WRKOPT RETURN END IF C SCALE = ONE C C Quick return if possible. C IF ( ISTRAN ) THEN K = N L = M ELSE K = M L = N END IF MB = ZLANGE( 'Max', K, L, B, LDB, DWORK ) IF ( MB.EQ.ZERO ) THEN IF ( N.GT.0 ) $ CALL ZLASET( 'Full', N, N, CZERO, CZERO, B, LDB ) ZWORK(1) = CONE RETURN END IF C C Set constants to control overflow. C EPS = DLAMCH( 'Precision' ) SAFMIN = DLAMCH( 'Safe minimum' ) SMLNUM = SAFMIN BIGNMS = ONE/SMLNUM CALL DLABAD( SMLNUM, BIGNMS ) SMLNUM = SQRT( SMLNUM )/EPS BIGNUM = ONE/SMLNUM C C Start the solution. 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 IF ( NOFACT ) THEN C C Find the Schur factorization of A, A = Q*S*Q'. C Workspace: need 2*N; C prefer larger. C CALL ZGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, $ W, Q, LDQ, ZWORK, LZWORK, DWORK, BWORK, INFORM ) IF ( INFORM.NE.0 ) THEN INFO = 6 RETURN END IF WRKOPT = ZWORK(1) ELSE C C Set the eigenvalues of the matrix A. C CALL ZCOPY( N, A, LDA+1, W, 1 ) WRKOPT = 0 END IF C C Check for identity matrix Q. C NUNITQ = .NOT.MA02HZ( 'All', N, N, CONE, Q, LDQ ) C C Check the eigenvalues for stability. C IF ( CONT ) THEN EMAX = DBLE( W(1) ) C DO 10 J = 2, N TMP = DBLE( W(J) ) IF ( TMP.GT.EMAX ) $ EMAX = TMP 10 CONTINUE C ELSE EMAX = ABS( W(1) ) C DO 20 J = 2, N TMP = ABS( W(J) ) IF ( TMP.GT.EMAX ) $ EMAX = TMP 20 CONTINUE C END IF C IF ( ( CONT ) .AND. ( EMAX.GE.ZERO ) .OR. $ ( .NOT.CONT ) .AND. ( EMAX.GE.ONE ) ) THEN IF ( NOFACT ) THEN INFO = 2 ELSE INFO = 3 END IF RETURN END IF C C Scale A if the maximum absolute value of its elements is outside C the range [SMLNUM,BIGNUM]. Scale similarly B. Scaling of B is done C before further processing if the maximum absolute value of its C elements is greater than BIGNMS; otherwise, it is postponed. C For continuous-time equations, scaling is also performed if the C maximum absolute values of A and B differ too much, or their C minimum (maximum) is too large (small). C MA = MIN( ZLANTR( 'Max', 'Upper', 'NoDiag', N, N, A, LDA, DWORK ), $ BIGNMS ) MN = MIN( MA, MB ) MX = MAX( MA, MB ) C IF ( CONT ) THEN LSCL = MN.LT.MX*SMLNUM .OR. MX.LT.SMLNUM .OR. MN.GT.BIGNUM ELSE LSCL = .FALSE. END IF C IF ( LSCL ) THEN MATO = ONE MBTO = ONE LASCL = .TRUE. LBSCL = .TRUE. ELSE IF ( MA.GT.ZERO .AND. MA.LT.SMLNUM ) THEN MATO = SMLNUM LASCL = .TRUE. ELSE IF ( MA.GT.BIGNUM ) THEN MATO = BIGNUM LASCL = .TRUE. ELSE LASCL = .FALSE. END IF C IF ( MB.GT.ZERO .AND. MB.LT.SMLNUM ) THEN MBTO = SMLNUM LBSCL = .TRUE. ELSE IF ( MB.GT.BIGNUM ) THEN MBTO = BIGNUM LBSCL = .TRUE. ELSE MBTO = ONE LBSCL = .FALSE. END IF END IF C IF ( .NOT.CONT .AND. MATO.EQ.ONE ) $ MATO = P95 IF ( LASCL ) $ CALL ZLASCL( 'Upper', 0, 0, MA, MATO, N, N, A, LDA, INFO ) C SCALB = MB.GT.BIGNMS MB = MIN( MB, BIGNMS ) IF ( LBSCL .AND. SCALB ) $ CALL ZLASCL( 'Gen', 0, 0, MB, MBTO, K, L, B, LDB, INFO ) C C Transformation of the right hand side, involving one or two RQ or C QR factorizations. Also, do scaling, if it was postponed. C C Workspace: need MIN(M,N) + N; C prefer MIN(M,N) + N*NB. C ITAU = 1 JWORK = ITAU + MINMN C IF ( ISTRAN ) THEN NM = M IF ( NUNITQ ) THEN IF ( SMALLM ) THEN C _ C Compute B := Q**H * B. C NC = INT( LZWORK / N ) C DO 30 J = 1, M, NC BL = MIN( M-J+1, NC ) CALL ZGEMM( 'CTrans', 'NoTran', N, BL, N, CONE, Q, $ LDQ, B(1,J), LDB, CZERO, ZWORK, N ) CALL ZLACPY( 'All', N, BL, ZWORK, N, B(1,J), LDB ) 30 CONTINUE C ELSE C C If M > 7*N/6, perform the RQ factorization of B, C _ _ C B = ( 0 R ) P. C NM = N CALL ZGERQF( N, M, B, LDB, ZWORK(ITAU), ZWORK(JWORK), $ LZWORK-JWORK+1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1, $ MINMN*N ) C C Form in B C _ H _ _ C B := Q R, with B an N-by-MIN(M,N) matrix. C Use a BLAS 3 operation if enough workspace, and BLAS 2, C _ C otherwise: B is formed column by column. C IF ( LZWORK.GE.MINMN*N ) THEN J = 1 C DO 40 I = 1, MINMN CALL ZCOPY( N, Q(N-MINMN+I,1), LDQ, ZWORK(J), 1 ) CALL ZLACGV( N, ZWORK(J), 1 ) J = J + N 40 CONTINUE C CALL ZTRMM( 'Right', 'Upper', 'NoTran', 'NoUnit', N, $ MINMN, CONE, B(N-MINMN+1,M-MINMN+1), LDB, $ ZWORK, N ) CALL ZLACPY( 'Full', N, MINMN, ZWORK, N, B, LDB ) ELSE C DO 50 J = 1, MINMN CALL ZCOPY( J, B(1,M-MINMN+J), 1, ZWORK, 1 ) CALL ZGEMV( 'CTrans', J, N, CONE, Q, LDQ, ZWORK, 1, $ CZERO, B(1,J), 1 ) 50 CONTINUE C END IF END IF END IF C _ C Perform the RQ factorization of B to get the factor F. C Note that if M <= 7*N/6, the factorization is C _ _ H H H C B := ( 0 F ) P, M >= N, B := ( Z F ) P, M < N. C Then, do scaling, if it was postponed. C Make the entries on the main diagonal are non-negative. C CALL ZGERQF( N, NM, B, LDB, ZWORK(ITAU), ZWORK(JWORK), $ LZWORK-JWORK+1, IFAIL ) IF ( N.GT.NM ) THEN IF ( LBSCL .AND. .NOT.SCALB ) THEN CALL ZLASCL( 'Gen', 0, 0, MB, MBTO, N-M, M, B, LDB, $ INFO ) CALL ZLASCL( 'Upper', 0, 0, MB, MBTO, M, M, B(N-M+1,1), $ LDB, INFO ) END IF C DO 60 I = M, 1, -1 CALL ZCOPY( N-M+I, B(1,I), 1, B(1,N-M+I), 1 ) 60 CONTINUE C CALL ZLASET( 'Full', N, N-M, CZERO, CZERO, B, LDB ) IF ( M.GT.1 ) $ CALL ZLASET( 'Lower', M-1, M-1, CZERO, CZERO, $ B(N-M+2,N-M+1), LDB ) ELSE IF ( M.GT.N .AND. M.EQ.NM ) $ CALL ZLACPY( 'Upper', N, N, B(1,M-N+1), LDB, B, LDB ) IF ( LBSCL .AND. .NOT.SCALB ) $ CALL ZLASCL( 'Upper', 0, 0, MB, MBTO, N, N, B, LDB, $ INFO ) END IF C DO 70 I = N - MINMN + 1, N IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( I, -ONE, B(1,I), 1 ) 70 CONTINUE C ELSE C NM = M IF ( NUNITQ ) THEN IF ( SMALLM ) THEN C _ C Compute B := B * Q. C NR = INT( LZWORK / N ) C DO 80 I = 1, M, NR BL = MIN( M-I+1, NR ) CALL ZGEMM( TRANS, 'NoTran', BL, N, N, CONE, B(I,1), $ LDB, Q, LDQ, CZERO, ZWORK, BL ) CALL ZLACPY( 'All', BL, N, ZWORK, BL, B(I,1), LDB ) 80 CONTINUE C ELSE C C If M > 7*N/6, perform the QR factorization of B, C _ _ C B = P ( R ). C ( 0 ) C CALL ZGEQRF( M, N, B, LDB, ZWORK(ITAU), ZWORK(JWORK), $ LZWORK-JWORK+1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1, $ N*N ) C C Form in B C _ _ _ C B := RQ, with B an n-by-n matrix. C Use a BLAS 3 operation if enough workspace, and BLAS 2, C _ C otherwise: B is formed row by row. C IF ( LZWORK.GE.N*N ) THEN CALL ZLACPY( 'Full', N, N, Q, LDQ, ZWORK, N ) CALL ZTRMM( 'Left', 'Upper', 'NoTran', 'NoUnit', N, $ N, CONE, B, LDB, ZWORK, N ) CALL ZLACPY( 'Full', N, N, ZWORK, MINMN, B, LDB ) ELSE CALL MB01UZ( 'Left', 'Upper', 'NoTrans', N, N, CONE, $ B, LDB, Q, LDQ, ZWORK, LZWORK, INFO ) END IF NM = N END IF END IF C _ C Perform the QR factorization of B to get the factor F. C _ _ C B = P ( F ), M >= N, B = P ( F Z ), M < N. C ( 0 ) C CALL ZGEQRF( NM, N, B, LDB, ZWORK(ITAU), ZWORK(JWORK), $ LZWORK-JWORK+1, IFAIL ) IF ( LBSCL .AND. .NOT.SCALB ) $ CALL ZLASCL( 'Upper', 0, 0, MB, MBTO, NM, N, B, LDB, INFO ) C IF ( M.LT.N ) $ CALL ZLASET( 'Upper', N-M, N-M, CZERO, CZERO, B(M+1,M+1), $ LDB ) C C Make the entries on the main diagonal of F non-negative. C DO 90 I = 1, MINMN IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( N+1-I, -ONE, B(I,I), LDB ) 90 CONTINUE C END IF IF ( MINMN.GT.1 ) $ CALL ZLASET( 'Lower', MINMN-1, MINMN-1, CZERO, CZERO, B(2,1), $ LDB ) C C Solve for U the transformed Lyapunov equation C H H H 2 H C op(S) *op(U) *op(U) + op(U) *op(U)*op(S) = -scale *op(F) *op(F), C C or C H H H 2 H C op(S) *op(U) *op(U)*op(S) - op(U) *op(U) = -scale *op(F) *op(F). C C Workspace: need 2*N - 2. C CALL SB03OS( .NOT.CONT, ISTRAN, N, A, LDA, B, LDB, SCALE, DWORK, $ ZWORK, INFO ) C C H C Form U := F*Q or U := Q*F in the array B, if Q is not identity. C IF ( ISTRAN ) THEN C IF ( NUNITQ ) THEN C C Workspace: need N; C prefer larger. C CALL MB01UZ( 'Right', 'Upper', 'NoTran', N, N, CONE, B, LDB, $ Q, LDQ, ZWORK, LZWORK, INFO ) C C Overwrite U with the triangular matrix of its C RQ-factorization and make the entries on the main diagonal C non-negative. C C Workspace: need 2*N; C prefer N + N*NB. C CALL ZGERQF( N, N, B, LDB, ZWORK, ZWORK(N+1), LZWORK-N, $ IFAIL ) IF ( N.GT.1 ) $ CALL ZLASET( 'Lower', N-1, N-1, CZERO, CZERO, B(2,1), $ LDB ) C DO 100 I = 1, N IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( I, -ONE, B(1,I), 1 ) 100 CONTINUE C END IF C ELSE C IF ( NUNITQ ) THEN C C Workspace: need N; C prefer larger. C CALL MB01UZ( 'Right', 'Upper', 'CTrans', N, N, CONE, B, LDB, $ Q, LDQ, ZWORK, LZWORK, INFO ) C DO 110 I = 1, N CALL ZSWAP( I, B(I,1), LDB, B(1,I), 1 ) 110 CONTINUE C DO 120 I = 1, N CALL ZLACGV( N, B(1,I), 1 ) 120 CONTINUE C C Overwrite U with the triangular matrix of its C QR-factorization and make the entries on the main diagonal C non-negative. C C Workspace: 2*N; C prefer N + N*NB. C CALL ZGEQRF( N, N, B, LDB, ZWORK, ZWORK(N+1), LZWORK-N, $ IFAIL ) IF ( N.GT.1 ) $ CALL ZLASET( 'Lower', N-1, N-1, CZERO, CZERO, B(2,1), $ LDB ) C DO 130 I = 1, N IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( N+1-I, -ONE, B(I,I), LDB ) 130 CONTINUE C END IF C END IF C C Undo the scaling of A and B and update SCALE. C TMP = ONE IF ( LASCL ) THEN CALL ZLASCL( 'Upper', 0, 0, MATO, MA, N, N, A, LDA, INFO ) TMP = SQRT( MATO/MA ) END IF IF ( LBSCL ) THEN MX = ZLANTR( 'Max', 'Upper', 'NoDiag', N, N, B, LDB, DWORK ) MN = MIN( TMP, MB ) T = MAX( TMP, MB ) IF ( T.GT.ONE ) THEN IF ( MN.GT.BIGNMS/T ) THEN SCALE = SCALE/T TMP = TMP/T END IF END IF TMP = TMP*MB IF ( TMP.GT.ONE ) THEN IF ( MX.GT.BIGNMS/TMP ) THEN SCALE = SCALE/MX TMP = TMP/MX END IF END IF END IF IF ( LASCL .OR. LBSCL ) $ CALL ZLASCL( 'Upper', 0, 0, MBTO, TMP, N, N, B, LDB, INFO ) C C Set the optimal workspace. C ZWORK(1) = WRKOPT C RETURN C *** Last line of SB03OZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02ND.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02ND.f0000644000175000017500000010154115012430707017355 0ustar00lilgelilge00000000000000 SUBROUTINE MB02ND( M, N, L, RANK, THETA, C, LDC, X, LDX, Q, INUL, $ TOL, RELTOL, IWORK, DWORK, LDWORK, BWORK, $ IWARN, INFO ) C C PURPOSE C C To solve the Total Least Squares (TLS) problem using a Partial C Singular Value Decomposition (PSVD) approach. C The TLS problem assumes an overdetermined set of linear equations C AX = B, where both the data matrix A as well as the observation C matrix B are inaccurate. The routine also solves determined and C underdetermined sets of equations by computing the minimum norm C solution. C It is assumed that all preprocessing measures (scaling, coordinate C transformations, whitening, ... ) of the data have been performed C in advance. C C ARGUMENTS C C Input/Output Parameters C C M (input) INTEGER C The number of rows in the data matrix A and the C observation matrix B. M >= 0. C C N (input) INTEGER C The number of columns in the data matrix A. N >= 0. C C L (input) INTEGER C The number of columns in the observation matrix B. C L >= 0. C C RANK (input/output) INTEGER C On entry, if RANK < 0, then the rank of the TLS C approximation [A+DA|B+DB] (r say) is computed by the C routine. C Otherwise, RANK must specify the value of r. C RANK <= min(M,N). C On exit, if RANK < 0 on entry and INFO = 0, then RANK C contains the computed rank of the TLS approximation C [A+DA|B+DB]. C Otherwise, the user-supplied value of RANK may be C changed by the routine on exit if the RANK-th and the C (RANK+1)-th singular values of C = [A|B] are considered C to be equal, or if the upper triangular matrix F (as C defined in METHOD) is (numerically) singular. C C THETA (input/output) DOUBLE PRECISION C On entry, if RANK < 0, then the rank of the TLS C approximation [A+DA|B+DB] is computed using THETA as C (min(M,N+L) - d), where d is the number of singular C values of [A|B] <= THETA. THETA >= 0.0. C Otherwise, THETA is an initial estimate (t say) for C computing a lower bound on the RANK largest singular C values of [A|B]. If THETA < 0.0 on entry however, then C t is computed by the routine. C On exit, if RANK >= 0 on entry, then THETA contains the C computed bound such that precisely RANK singular values C of C = [A|B] are greater than THETA + TOL. C Otherwise, THETA is unchanged. C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N+L) C On entry, the leading M-by-(N+L) part of this array must C contain the matrices A and B. Specifically, the first N C columns must contain the data matrix A and the last L C columns the observation matrix B (right-hand sides). C On exit, if INFO = 0, the first N+L components of the C columns of this array whose index i corresponds with C INUL(i) = .TRUE., are the possibly transformed (N+L-RANK) C base vectors of the right singular subspace corresponding C to the singular values of C = [A|B] which are less than or C equal to THETA. Specifically, if L = 0, or if RANK = 0 and C IWARN <> 2, these vectors are indeed the base vectors C above. Otherwise, these vectors form the matrix V2, C transformed as described in Step 4 of the PTLS algorithm C (see METHOD). The TLS solution is computed from these C vectors. The other columns of array C contain no useful C information. C C LDC INTEGER C The leading dimension of array C. LDC >= max(1,M,N+L). C C X (output) DOUBLE PRECISION array, dimension (LDX,L) C If INFO = 0, the leading N-by-L part of this array C contains the solution X to the TLS problem specified by C A and B. C C LDX INTEGER C The leading dimension of array X. LDX >= max(1,N). C C Q (output) DOUBLE PRECISION array, dimension C (max(1,2*min(M,N+L)-1)) C This array contains the partially diagonalized bidiagonal C matrix J computed from C, at the moment that the desired C singular subspace has been found. Specifically, the C leading p = min(M,N+L) entries of Q contain the diagonal C elements q(1),q(2),...,q(p) and the entries Q(p+1),Q(p+2), C ...,Q(2*p-1) contain the superdiagonal elements e(1),e(2), C ...,e(p-1) of J. C C INUL (output) LOGICAL array, dimension (N+L) C The indices of the elements of this array with value C .TRUE. indicate the columns in C containing the base C vectors of the right singular subspace of C from which C the TLS solution has been computed. C C Tolerances C C TOL DOUBLE PRECISION C This parameter defines the multiplicity of singular values C by considering all singular values within an interval of C length TOL as coinciding. TOL is used in checking how many C singular values are less than or equal to THETA. Also in C computing an appropriate upper bound THETA by a bisection C method, TOL is used as a stopping criterion defining the C minimum (absolute) subinterval width. TOL is also taken C as an absolute tolerance for negligible elements in the C QR/QL iterations. If the user sets TOL to be less than or C equal to 0, then the tolerance is taken as specified in C SLICOT Library routine MB04YD document. C C RELTOL DOUBLE PRECISION C This parameter specifies the minimum relative width of an C interval. When an interval is narrower than TOL, or than C RELTOL times the larger (in magnitude) endpoint, then it C is considered to be sufficiently small and bisection has C converged. If the user sets RELTOL to be less than C BASE * EPS, where BASE is machine radix and EPS is machine C precision (see LAPACK Library routine DLAMCH), then the C tolerance is taken as BASE * EPS. C C Workspace C C IWORK INTEGER array, dimension (N+2*L) 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) returns the reciprocal of the C condition number of the matrix F. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK = max(2, max(M,N+L) + 2*min(M,N+L), C min(M,N+L) + LW + max(6*(N+L)-5, C L*L+max(N+L,3*L)), C where C LW = (N+L)*(N+L-1)/2, if M >= N+L, C LW = M*(N+L-(M-1)/2), if M < N+L. 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 BWORK LOGICAL array, dimension (N+L) C C Warning Indicator C C IWARN INTEGER C = 0: no warnings; C = 1: if the rank of matrix C has been lowered because a C singular value of multiplicity greater than 1 was C found; C = 2: if the rank of matrix C has been lowered because the C upper triangular matrix F is (numerically) singular. 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 maximum number of QR/QL iteration steps C (30*MIN(M,N)) has been exceeded; C = 2: if the computed rank of the TLS approximation C [A+DA|B+DB] exceeds MIN(M,N). Try increasing the C value of THETA or set the value of RANK to min(M,N). C C METHOD C C The method used is the Partial Total Least Squares (PTLS) approach C proposed by Van Huffel and Vandewalle [5]. C C Let C = [A|B] denote the matrix formed by adjoining the columns of C B to the columns of A on the right. C C Total Least Squares (TLS) definition: C ------------------------------------- C C Given matrices A and B, find a matrix X satisfying C C (A + DA) X = B + DB, C C where A and DA are M-by-N matrices, B and DB are M-by-L matrices C and X is an N-by-L matrix. C The solution X must be such that the Frobenius norm of [DA|DB] C is a minimum and each column of B + DB is in the range of C A + DA. Whenever the solution is not unique, the routine singles C out the minimum norm solution X. C C Let V denote the right singular subspace of C. Since the TLS C solution can be computed from any orthogonal basis of the subspace C of V corresponding to the smallest singular values of C, the C Partial Singular Value Decomposition (PSVD) can be used instead of C the classical SVD. The dimension of this subspace of V may be C determined by the rank of C or by an upper bound for those C smallest singular values. C C The PTLS algorithm proceeds as follows (see [2 - 5]): C C Step 1: Bidiagonalization phase C ----------------------- C (a) If M is large enough than N + L, transform C into upper C triangular form R by Householder transformations. C (b) Transform C (or R) into upper bidiagonal form C (p = min(M,N+L)): C C |q(1) e(1) 0 ... 0 | C (0) | 0 q(2) e(2) . | C J = | . . | C | . e(p-1)| C | 0 ... q(p) | C C if M >= N + L, or lower bidiagonal form: C C |q(1) 0 0 ... 0 0 | C (0) |e(1) q(2) 0 . . | C J = | . . . | C | . q(p) . | C | 0 ... e(p-1) q(p)| C C if M < N + L, using Householder transformations. C In the second case, transform the matrix to the upper C bidiagonal form by applying Givens rotations. C (c) Initialize the right singular base matrix with the identity C matrix. C C Step 2: Partial diagonalization phase C ----------------------------- C If the upper bound THETA is not given, then compute THETA such C that precisely p - RANK singular values (p=min(M,N+L)) of the C bidiagonal matrix are less than or equal to THETA, using a C bisection method [5]. Diagonalize the given bidiagonal matrix J C partially, using either QL iterations (if the upper left diagonal C element of the considered bidiagonal submatrix is smaller than the C lower right diagonal element) or QR iterations, such that J is C split into unreduced bidiagonal submatrices whose singular values C are either all larger than THETA or are all less than or equal C to THETA. Accumulate the Givens rotations in V. C C Step 3: Back transformation phase C ------------------------- C Apply the Householder transformations of Step 1(b) onto the base C vectors of V associated with the bidiagonal submatrices with all C singular values less than or equal to THETA. C C Step 4: Computation of F and Y C ---------------------- C Let V2 be the matrix of the columns of V corresponding to the C (N + L - RANK) smallest singular values of C. C Compute with Householder transformations the matrices F and Y C such that: C C |VH Y| C V2 x Q = | | C |0 F| C C where Q is an orthogonal matrix, VH is an N-by-(N-RANK) matrix, C Y is an N-by-L matrix and F is an L-by-L upper triangular matrix. C If F is singular, then reduce the value of RANK by one and repeat C Steps 2, 3 and 4. C C Step 5: Computation of the TLS solution C ------------------------------- C If F is non-singular then the solution X is obtained by solving C the following equations by forward elimination: C C X F = -Y. C C Notes: C If RANK is lowered in Step 4, some additional base vectors must C be computed in Step 2. The additional computations are kept to C a minimum. C If RANK is lowered in Step 4 but the multiplicity of the RANK-th C singular value is larger than 1, then the value of RANK is further C lowered with its multiplicity defined by the parameter TOL. This C is done at the beginning of Step 2 by calling SLICOT Library C routine MB03MD (from MB04YD), which estimates THETA using a C bisection method. If F in Step 4 is singular, then the computed C solution is infinite and hence does not satisfy the second TLS C criterion (see TLS definition). For these cases, Golub and C Van Loan [1] claim that the TLS problem has no solution. The C properties of these so-called nongeneric problems are described C in [6] and the TLS computations are generalized in order to solve C them. As proven in [6], the proposed generalization satisfies the C TLS criteria for any number L of observation vectors in B provided C that, in addition, the solution | X| is constrained to be C |-I| C orthogonal to all vectors of the form |w| which belong to the C |0| C space generated by the columns of the submatrix |Y|. C |F| C C REFERENCES C C [1] Golub, G.H. and Van Loan, C.F. C An Analysis of the Total Least-Squares Problem. C SIAM J. Numer. Anal., 17, pp. 883-893, 1980. C C [2] Van Huffel, S., Vandewalle, J. and Haegemans, A. C An Efficient and Reliable Algorithm for Computing the C Singular Subspace of a Matrix Associated with its Smallest C Singular Values. C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. C C [3] Van Huffel, S. C Analysis of the Total Least Squares Problem and its Use in C Parameter Estimation. C Doctoral dissertation, Dept. of Electr. Eng., Katholieke C Universiteit Leuven, Belgium, June 1987. C C [4] Chan, T.F. C An Improved Algorithm for Computing the Singular Value C Decomposition. C ACM TOMS, 8, pp. 72-83, 1982. C C [5] Van Huffel, S. and Vandewalle, J. C The Partial Total Least Squares Algorithm. C J. Comput. Appl. Math., 21, pp. 333-341, 1988. C C [6] Van Huffel, S. and Vandewalle, J. C Analysis and Solution of the Nongeneric Total Least Squares C Problem. C SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988. C C NUMERICAL ASPECTS C C The computational efficiency of the PTLS algorithm compared with C the classical TLS algorithm (see [2 - 5]) is obtained by making C use of PSVD (see [1]) instead of performing the entire SVD. C Depending on the gap between the RANK-th and the (RANK+1)-th C singular values of C, the number (N + L - RANK) of base vectors to C be computed with respect to the column dimension (N + L) of C and C the desired accuracy RELTOL, the algorithm used by this routine is C approximately twice as fast as the classical TLS algorithm at the C expense of extra storage requirements, namely: C (N + L) x (N + L - 1)/2 if M >= N + L or C M x (N + L - (M - 1)/2) if M < N + L. C This is because the Householder transformations performed on the C rows of C in the bidiagonalization phase (see Step 1) must be kept C until the end (Step 5). C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. C Supersedes Release 2.0 routine MB02BD by S. Van Huffel, Katholieke C University, Leuven, Belgium. C C REVISIONS C C V. Sima. June 30, 1997, Oct. 19, 2003, Feb. 15, 2004, Aug. 2011. C C KEYWORDS C C Least-squares approximation, singular subspace, singular value C decomposition, singular values, total least-squares. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. INTEGER INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK DOUBLE PRECISION RELTOL, THETA, TOL C .. Array Arguments .. LOGICAL BWORK(*), INUL(*) INTEGER IWORK(*) DOUBLE PRECISION C(LDC,*), DWORK(*), Q(*), X(LDX,*) C .. Local Scalars .. LOGICAL LFIRST, LQUERY, SUFWRK, USEQR INTEGER I, I1, IFAIL, IHOUSH, IJ, IOFF, ITAUP, ITAUQ, $ IWARM, J, J1, JF, JV, JWORK, K, KF, KJ, LDF, LW, $ MC, MINWRK, MJ, MNL, N1, NJ, NL, P, WRKOPT DOUBLE PRECISION CS, EPS, FIRST, FNORM, HH, INPROD, RCOND, SN, $ TEMP C .. Local Arrays .. DOUBLE PRECISION DUMMY(2) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE, DLANTR EXTERNAL DLAMCH, DLANGE, DLANTR, ILAENV, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEBRD, DGEQRF, DGERQF, DLARF, DLARFG, $ DLARTG, DLASET, DORMBR, DORMRQ, DTRCON, DTRSM, $ MB04YD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C IWARN = 0 INFO = 0 NL = N + L K = MAX( M, NL ) P = MIN( M, NL ) IF ( M.GE.NL ) THEN LW = ( NL*( NL - 1 ) )/2 ELSE LW = M*NL - ( M*( M - 1 ) )/2 END IF JV = P + LW + MAX( 6*NL - 5, L*L + MAX( NL, 3*L ) ) C C Test the input scalar arguments. C IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( L.LT.0 ) THEN INFO = -3 ELSE IF( RANK.GT.MIN( M, N ) ) THEN INFO = -4 ELSE IF( ( RANK.LT.0 ) .AND. ( THETA.LT.ZERO ) ) THEN INFO = -5 ELSE IF( LDC.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE USEQR = M.GE.MAX( NL, ILAENV( 6, 'DGESVD', 'N' // 'N', M, NL, $ 0, 0 ) ) LQUERY = LDWORK.EQ.-1 MINWRK = MAX( 2, K + 2*P, JV ) WRKOPT = MINWRK IF ( USEQR ) THEN MNL = NL ELSE MNL = M END IF IF( LQUERY ) THEN IF ( USEQR ) THEN CALL DGEQRF( M, NL, C, LDC, DWORK, DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, NL + INT( DWORK(1) ) ) END IF CALL DGEBRD( MNL, NL, C, LDC, Q, Q, DWORK, DWORK, DWORK, -1, $ IFAIL ) CALL DORMBR( 'P vectors', 'Left', 'No transpose', NL, NL, $ MNL, DWORK, P, DWORK, DWORK, NL, DWORK(2), -1, $ IFAIL ) CALL DGERQF( L, NL, DWORK, NL, DWORK, DUMMY, -1, IFAIL ) CALL DORMRQ( 'Right', 'Transpose', N, NL, L, DWORK, NL, $ DWORK, DWORK, NL, DUMMY(2), -1, IFAIL ) TEMP = MAX( DWORK(2), DUMMY(1), DUMMY(2) ) WRKOPT = MAX( WRKOPT, 2*P + INT( DWORK(1) ), $ P + P*NL + MAX( 6*NL-5, $ NL**2 + MAX( INT( TEMP ), $ 3*L ) ) ) END IF IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -16 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB02ND', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF ( MIN( M, NL ).EQ.0 ) THEN IF ( M.EQ.0 ) THEN CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) C DO 10 I = 1, NL INUL(I) = .TRUE. 10 CONTINUE C END IF IF ( RANK.GE.0 ) $ THETA = ZERO RANK = 0 DWORK(1) = TWO DWORK(2) = ONE RETURN END IF C WRKOPT = 2 N1 = N + 1 C EPS = DLAMCH( 'Precision' ) LFIRST = .TRUE. C C Initializations. C DO 20 I = 1, P INUL(I) = .FALSE. BWORK(I) = .FALSE. 20 CONTINUE C DO 40 I = P + 1, NL INUL(I) = .TRUE. BWORK(I) = .FALSE. 40 CONTINUE C C Subroutine MB02ND solves a set of linear equations by a Total C Least Squares Approximation, based on the Partial SVD. C C Step 1: Bidiagonalization phase C ----------------------- C 1.a): If M is large enough than N+L, transform C into upper C triangular form R by Householder transformations. 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 IF ( USEQR ) THEN C C Workspace: need 2*(N+L), C prefer N+L + (N+L)*NB. C ITAUQ = 1 JWORK = ITAUQ + NL CALL DGEQRF( M, NL, C, LDC, DWORK(ITAUQ), DWORK(JWORK), $ LDWORK-JWORK+1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) IF ( NL.GT.1 ) $ CALL DLASET( 'Lower', NL-1, NL-1, ZERO, ZERO, C(2,1), LDC ) END IF C C 1.b): Transform C (or R) into bidiagonal form Q using Householder C transformations. C Workspace: need 2*min(M,N+L) + max(M,N+L), C prefer 2*min(M,N+L) + (M+N+L)*NB. C ITAUP = 1 ITAUQ = ITAUP + P JWORK = ITAUQ + P CALL DGEBRD( MNL, NL, C, LDC, Q, Q(P+1), DWORK(ITAUQ), $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C If the matrix is lower bidiagonal, rotate to be upper bidiagonal C by applying Givens rotations on the left. C IF ( M.LT.NL ) THEN IOFF = 0 C DO 60 I = 1, P - 1 CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP ) Q(I) = TEMP Q(P+I) = SN*Q(I+1) Q(I+1) = CS*Q(I+1) 60 CONTINUE C ELSE IOFF = 1 END IF C C Store the Householder transformations performed onto the rows of C C in the extra storage locations DWORK(IHOUSH). C Workspace: need LDW = min(M,N+L) + (N+L)*(N+L-1)/2, if M >= N+L, C LDW = min(M,N+L) + M*(N+L-(M-1)/2), if M < N+L; C prefer LDW = min(M,N+L) + (N+L)**2, if M >= N+L, C LDW = min(M,N+L) + M*(N+L), if M < N+L. C IHOUSH = ITAUQ MC = NL - IOFF KF = IHOUSH + P*NL SUFWRK = LDWORK.GE.( KF + MAX( 6*NL-5, $ NL**2 + MAX( NL, 3*L ) - 1 ) ) IF ( SUFWRK ) THEN C C Enough workspace for a fast algorithm. C CALL DLACPY( 'Upper', P, NL, C, LDC, DWORK(IHOUSH), P ) KJ = KF WRKOPT = MAX( WRKOPT, KF - 1 ) ELSE C C Not enough workspace for a fast algorithm. C KJ = IHOUSH C DO 80 NJ = 1, MIN( P, MC ) J = MC - NJ + 1 CALL DCOPY( J, C(NJ,NJ+IOFF), LDC, DWORK(KJ), 1 ) KJ = KJ + J 80 CONTINUE C END IF C C 1.c): Initialize the right singular base matrix V with the C identity matrix (V overwrites C). C CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) JV = KJ IWARM = 0 C C REPEAT C C Compute the Householder matrix Q and matrices F and Y such that C F is nonsingular. C C Step 2: Partial diagonalization phase. C ----------------------------- C Diagonalize the bidiagonal Q partially until convergence to C the desired right singular subspace. C Workspace: LDW + 6*(N+L)-5. C 100 CONTINUE JWORK = JV CALL MB04YD( 'No U', 'Update V', P, NL, RANK, THETA, Q, Q(P+1), $ DUMMY, 1, C, LDC, INUL, TOL, RELTOL, DWORK(JWORK), $ LDWORK-JWORK+1, IWARN, INFO ) WRKOPT = MAX( WRKOPT, JWORK + 6*NL - 6 ) C IWARN = MAX( IWARN, IWARM ) IF ( INFO.GT.0 ) $ RETURN C C Set pointers to the selected base vectors in the right singular C matrix of C. C K = 0 C DO 120 I = 1, NL IF ( INUL(I) ) THEN K = K + 1 IWORK(K) = I END IF 120 CONTINUE C IF ( K.LT.L ) THEN C C Rank of the TLS approximation is larger than min(M,N). C INFO = 2 RETURN END IF C C Step 3: Back transformation phase. C ------------------------- C Apply in backward order the Householder transformations (stored C in DWORK(IHOUSH)) performed onto the rows of C during the C bidiagonalization phase, to the selected base vectors (specified C by INUL(I) = .TRUE.). Already transformed vectors are those for C which BWORK(I) = .TRUE.. C KF = K IF ( SUFWRK.AND.LFIRST ) THEN C C Enough workspace for a fast algorithm and first pass. C IJ = JV C DO 140 J = 1, K CALL DCOPY (NL, C(1,IWORK(J)), 1, DWORK(IJ), 1 ) IJ = IJ + NL 140 CONTINUE C C Workspace: need LDW + (N+L)*K + K, C prefer LDW + (N+L)*K + K*NB. C IJ = JV JWORK = IJ + NL*K CALL DORMBR( 'P vectors', 'Left', 'No transpose', NL, K, $ MNL, DWORK(IHOUSH), P, DWORK(ITAUP), DWORK(IJ), $ NL, DWORK(JWORK), LDWORK-JWORK+1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C DO 160 I = 1, NL IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) ) $ BWORK(I) = .TRUE. 160 CONTINUE C ELSE C C Not enough workspace for a fast algorithm or subsequent passes. C DO 180 I = 1, NL IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) ) THEN KJ = JV C DO 170 NJ = MIN( P, MC ), 1, -1 J = MC - NJ + 1 KJ = KJ - J FIRST = DWORK(KJ) DWORK(KJ) = ONE CALL DLARF( 'Left', J, 1, DWORK(KJ), 1, $ DWORK(ITAUP+NJ-1), C(NJ+IOFF,I), LDC, $ DWORK(JWORK) ) DWORK(KJ) = FIRST 170 CONTINUE C BWORK(I) = .TRUE. END IF 180 CONTINUE END IF C IF ( RANK.LE.0 ) $ RANK = 0 IF ( MIN( RANK, L ).EQ.0 ) THEN IF ( SUFWRK.AND.LFIRST ) $ CALL DLACPY( 'Full', NL, K, DWORK(JV), NL, C, LDC ) DWORK(1) = WRKOPT DWORK(2) = ONE RETURN END IF C C Step 4: Compute matrices F and Y C ------------------------ C using Householder transformation Q. C C Compute the orthogonal matrix Q (in factorized form) and the C matrices F and Y using RQ factorization. It is assumed that, C generically, the last L rows of V2 matrix have full rank. C The code could not be the most efficient when RANK has been C lowered, because the already created zero pattern of the last C L rows of V2 matrix is not exploited. C IF ( SUFWRK.AND.LFIRST ) THEN C C Enough workspace for a fast algorithm and first pass. C Workspace: need LDW1 + 2*L, C prefer LDW1 + L + L*NB, where C LDW1 = LDW + (N+L)*K; C ITAUQ = JWORK JWORK = ITAUQ + L CALL DGERQF( L, K, DWORK(JV+N), NL, DWORK(ITAUQ), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Workspace: need LDW1 + N+L, C prefer LDW1 + L + N*NB. C CALL DORMRQ( 'Right', 'Transpose', N, K, L, DWORK(JV+N), NL, $ DWORK(ITAUQ), DWORK(JV), NL, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C JF = JV + NL*(K-L) + N LDF = NL JWORK = JF + LDF*L - N CALL DLASET( 'Full', L, K-L, ZERO, ZERO, DWORK(JV+N), LDF ) IF ( L.GT.1 ) $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, DWORK(JF+1), $ LDF ) IJ = JV C DO 200 J = 1, K CALL DCOPY( NL, DWORK(IJ), 1, C(1,IWORK(J)), 1 ) IJ = IJ + NL 200 CONTINUE C ELSE C C Not enough workspace for a fast algorithm or subsequent passes. C Workspace: LDW2 + N+L, where LDW2 = LDW + L*L. C I = NL JF = JV LDF = L JWORK = JF + LDF*L WRKOPT = MAX( WRKOPT, JWORK+NL-1 ) C C WHILE ( ( K >= 1 ) .AND. ( I > N ) ) DO 220 CONTINUE IF ( ( K.GE.1 ) .AND. ( I.GT.N ) ) THEN C DO 240 J = 1, K DWORK(JWORK+J-1) = C(I,IWORK(J)) 240 CONTINUE C C Compute Householder transformation. C CALL DLARFG( K, DWORK(JWORK+K-1), DWORK(JWORK), 1, TEMP ) C(I,IWORK(K)) = DWORK(JWORK+K-1) IF ( TEMP.NE.ZERO ) THEN C C Apply Householder transformation onto the selected base C vectors. C DO 300 I1 = 1, I - 1 INPROD = C(I1,IWORK(K)) C DO 260 J = 1, K - 1 INPROD = INPROD + DWORK(JWORK+J-1)*C(I1,IWORK(J)) 260 CONTINUE C HH = INPROD*TEMP C(I1,IWORK(K)) = C(I1,IWORK(K)) - HH C DO 280 J = 1, K - 1 J1 = IWORK(J) C(I1,J1) = C(I1,J1) - DWORK(JWORK+J-1)*HH C(I,J1) = ZERO 280 CONTINUE C 300 CONTINUE C END IF CALL DCOPY( I-N, C(N1,IWORK(K)), 1, DWORK(JF+(I-N-1)*L), 1 ) K = K - 1 I = I - 1 GO TO 220 END IF C END WHILE 220 END IF C C Estimate the reciprocal condition number of the matrix F. C If F singular, lower the rank of the TLS approximation. C Workspace: LDW1 + 3*L or C LDW2 + 3*L. C CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, DWORK(JF), LDF, $ RCOND, DWORK(JWORK), IWORK(KF+1), INFO ) WRKOPT = MAX( WRKOPT, JWORK + 3*L - 1 ) C DO 320 J = 1, L CALL DCOPY( N, C(1,IWORK(KF-L+J)), 1, X(1,J), 1 ) 320 CONTINUE C FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, DWORK(JF), $ LDF, DWORK(JWORK) ) IF ( RCOND.LE.EPS*FNORM ) THEN RANK = RANK - 1 GO TO 340 END IF IF ( FNORM.LE.EPS*DLANGE( '1-norm', N, L, X, LDX, $ DWORK(JWORK) ) ) THEN RANK = RANK - L GO TO 340 ELSE GO TO 400 END IF C 340 CONTINUE IWARM = 2 THETA = -ONE IF ( SUFWRK.AND.LFIRST ) THEN C C Rearrange the stored Householder transformations for C subsequent passes, taking care to avoid overwriting. C IF ( P.LT.NL ) THEN KJ = IHOUSH + NL*(NL - 1) MJ = IHOUSH + P*(NL - 1) C DO 360 NJ = 1, NL DO 350 J = P - 1, 0, -1 DWORK(KJ+J) = DWORK(MJ+J) 350 CONTINUE KJ = KJ - NL MJ = MJ - P 360 CONTINUE C END IF KJ = IHOUSH MJ = IHOUSH + NL*IOFF C DO 380 NJ = 1, MIN( P, MC ) DO 370 J = 0, MC - NJ DWORK(KJ) = DWORK(MJ+J*P) KJ = KJ + 1 370 CONTINUE MJ = MJ + NL + 1 380 CONTINUE C JV = KJ LFIRST = .FALSE. END IF GO TO 100 C UNTIL ( F nonsingular, i.e., RCOND.GT.EPS*FNORM or C FNORM.GT.EPS*norm(Y) ) 400 CONTINUE C C Step 5: Compute TLS solution. C -------------------- C Solve X F = -Y by forward elimination (F is upper triangular). C CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, $ -ONE, DWORK(JF), LDF, X, LDX ) C C Set the optimal workspace and reciprocal condition number of F. C DWORK(1) = WRKOPT DWORK(2) = RCOND C RETURN C *** Last line of MB02ND *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02JD.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02JD.f0000644000175000017500000001165315012430707017354 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION MA02JD( LTRAN1, LTRAN2, N, Q1, LDQ1, Q2, $ LDQ2, RES, LDRES ) C C PURPOSE C C To compute || Q^T Q - I ||_F for a matrix of the form C C [ op( Q1 ) op( Q2 ) ] C Q = [ ], C [ -op( Q2 ) op( Q1 ) ] C C where Q1 and Q2 are N-by-N matrices. This residual can be used to C test wether Q is numerically an orthogonal symplectic matrix. C C FUNCTION VALUE C C MA02JD DOUBLE PRECISION C The computed residual. C C ARGUMENTS C C Mode Parameters C C LTRAN1 LOGICAL C Specifies the form of op( Q1 ) as follows: C = .FALSE.: op( Q1 ) = Q1; C = .TRUE. : op( Q1 ) = Q1'. C C LTRAN2 LOGICAL C Specifies the form of op( Q2 ) as follows: C = .FALSE.: op( Q2 ) = Q2; C = .TRUE. : op( Q2 ) = Q2'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices Q1 and Q2. N >= 0. C C Q1 (input) DOUBLE PRECISION array, dimension (LDQ1,N) C On entry, the leading N-by-N part of this array must C contain the matrix op( Q1 ). C C LDQ1 INTEGER C The leading dimension of the array Q1. LDQ1 >= MAX(1,N). C C Q2 (input) DOUBLE PRECISION array, dimension (LDQ2,N) C On entry, the leading N-by-N part of this array must C contain the matrix op( Q2 ). C C LDQ2 INTEGER C The leading dimension of the array Q2. LDQ2 >= MAX(1,N). C C Workspace C C RES DOUBLE PRECISION array, dimension (LDRES,N) C C LDRES INTEGER C The leading dimension of the array RES. LDRES >= MAX(1,N). C C METHOD C C The routine computes the residual by simple elementary operations. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAORS). C C KEYWORDS C C Elementary operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. LOGICAL LTRAN1, LTRAN2 INTEGER LDQ1, LDQ2, LDRES, N C .. Array Arguments .. DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), RES(LDRES,*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION TEMP C .. Local Arrays .. DOUBLE PRECISION DUMMY(1) C .. External Subroutines .. EXTERNAL DGEMM C .. External Functions .. DOUBLE PRECISION DLANGE, DLAPY2 EXTERNAL DLANGE, DLAPY2 C .. Intrinsic Functions .. INTRINSIC SQRT C C .. Executable Statements .. C IF ( LTRAN1 ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1, $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) ELSE CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1, $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) END IF IF ( LTRAN2 ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2, $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) ELSE CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2, $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) END IF DO 10 I = 1, N RES(I,I) = RES(I,I) - ONE 10 CONTINUE TEMP = DLANGE( 'Frobenius', N, N, RES, LDRES, DUMMY ) IF ( LTRAN1 .AND. LTRAN2 ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2, $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1, $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) ELSE IF ( LTRAN1 ) THEN CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q2, $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q1, $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) ELSE IF ( LTRAN2 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q2, $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q1, $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) ELSE CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2, $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1, $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) END IF TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, LDRES, $ DUMMY ) ) MA02JD = SQRT( TWO )*TEMP RETURN C *** Last line of MA02JD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04RU.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04RU.f0000644000175000017500000002516115012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE MB04RU( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To reduce a skew-Hamiltonian matrix, C C [ A G ] C W = [ T ] , C [ Q A ] C C where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric C matrices, to Paige/Van Loan (PVL) form. That is, an orthogonal C symplectic matrix U is computed so that C C T [ Aout Gout ] C U W U = [ T ] , C [ 0 Aout ] C C where Aout is in upper Hessenberg form. C Unblocked version. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C ILO (input) INTEGER C It is assumed that A is already upper triangular and Q is C zero in rows and columns 1:ILO-1. ILO is normally set by a C previous call to the SLICOT Library routine MB04DS; C otherwise it should be set to 1. C 1 <= ILO <= N+1, if N > 0; ILO = 1, if 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. C On exit, the leading N-by-N part of this array contains C the matrix Aout and, in the zero part of Aout, information C about the elementary reflectors used to compute the C PVL factorization. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input/output) DOUBLE PRECISION array, dimension C (LDQG,N+1) C On entry, the leading N-by-N+1 part of this array must C contain in columns 1:N the strictly lower triangular part C of the matrix Q and in columns 2:N+1 the strictly upper C triangular part of the matrix G. The parts containing the C diagonal and the first superdiagonal of this array are not C referenced. C On exit, the leading N-by-N+1 part of this array contains C in its first N-1 columns information about the elementary C reflectors used to compute the PVL factorization and in C its last N columns the strictly upper triangular part of C the matrix Gout. C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C CS (output) DOUBLE PRECISION array, dimension (2N-2) C On exit, the first 2N-2 elements of this array contain the C cosines and sines of the symplectic Givens rotations used C to compute the PVL factorization. C C TAU (output) DOUBLE PRECISION array, dimension (N-1) C On exit, the first N-1 elements of this array contain the C scalar factors of some of the elementary reflectors. 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 On exit, if INFO = -10, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,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 matrix U is represented as a product of symplectic reflectors C and Givens rotations C C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). C C Each H(i) has the form C C H(i) = I - tau * v * v' C C where tau is a real scalar, and v is a real vector with v(1:i) = 0 C and v(i+1) = 1; v(i+2:n) is stored on exit in QG(i+2:n,i), and C tau in QG(i+1,i). C C Each F(i) has the form C C F(i) = I - nu * w * w' C C where nu is a real scalar, and w is a real vector with w(1:i) = 0 C and w(i+1) = 1; w(i+2:n) is stored on exit in A(i+2:n,i), and C nu in TAU(i). C C Each G(i) is a Givens rotation acting on rows i+1 and n+i+1, where C the cosine is stored in CS(2*i-1) and the sine in CS(2*i). C C NUMERICAL ASPECTS C C The algorithm requires 40/3 N**3 + O(N) floating point operations C and is strongly backward stable. C C REFERENCES C C [1] Van Loan, C.F. C A symplectic method for approximating all the eigenvalues of C a Hamiltonian matrix. C Linear Algebra and its Applications, 61, pp. 233-251, 1984. C C CONTRIBUTORS C C D. Kressner (Technical Univ. Berlin, Germany) and C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. C C REVISIONS C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DSHPVL). C V. Sima, Nov. 2011, Oct. 2012. C C KEYWORDS C C Elementary matrix operations, skew-Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER ILO, INFO, LDA, LDQG, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION ALPHA, C, NU, S, TEMP C .. External Subroutines .. EXTERNAL DLARF, DLARFG, DLARTG, DROT, MB01MD, MB01ND, $ XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 IF ( N.LT.0 ) THEN INFO = -1 ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN INFO = -2 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF ( LDWORK.LT.MAX( 1, N-1 ) ) THEN DWORK(1) = DBLE( MAX( 1, N-1 ) ) INFO = -10 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04RU', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.LE.ILO ) THEN DWORK(1) = ONE RETURN END IF C DO 10 I = ILO, N - 1 C C Generate elementary reflector H(i) to annihilate QG(i+2:n,i). C ALPHA = QG(I+1,I) CALL DLARFG( N-I, ALPHA, QG(MIN( I+2, N ),I), 1, NU ) IF ( NU.NE.ZERO ) THEN QG(I+1,I) = ONE C C Apply H(i) from both sides to QG(i+1:n,i+1:n). C Compute x := nu * QG(i+1:n,i+1:n) * v. C CALL MB01MD( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, QG(I+1,I), $ 1, ZERO, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C QG(i+1:n,i+1:n) := QG(i+1:n,i+1:n) + v * x' - x * v'. C CALL MB01ND( 'Lower', N-I, ONE, QG(I+1,I), 1, DWORK, 1, $ QG(I+1,I+1), LDQG ) C C Apply H(i) from the right hand side to QG(1:i,i+2:n+1). C CALL DLARF( 'Right', I, N-I, QG(I+1,I), 1, NU, QG(1,I+2), $ LDQG, DWORK ) C C Apply H(i) from both sides to QG(i+1:n,i+2:n+1). C Compute x := nu * QG(i+1:n,i+2:n+1) * v. C CALL MB01MD( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, QG(I+1,I), $ 1, ZERO, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) + v * x' - x * v'. C CALL MB01ND( 'Upper', N-I, ONE, QG(I+1,I), 1, DWORK, 1, $ QG(I+1,I+2), LDQG ) C C Apply H(i) from the left hand side to A(i+1:n,i:n). C CALL DLARF( 'Left', N-I, N-I+1, QG(I+1,I), 1, NU, A(I+1,I), $ LDA, DWORK ) C C Apply H(i) from the right hand side to A(1:n,i+1:n). C CALL DLARF( 'Right', N, N-I, QG(I+1,I), 1, NU, A(1,I+1), $ LDA, DWORK ) END IF QG(I+1,I) = NU C C Generate symplectic Givens rotation G(i) to annihilate C QG(i+1,i). C TEMP = A(I+1,I) CALL DLARTG( TEMP, ALPHA, C, S, A(I+1,I) ) C C Apply G(i) to [A(I+1,I+2:N); QG(I+2:N,I+1)']. C CALL DROT( N-I-1, A(I+1,I+2), LDA, QG(I+2,I+1), 1, C, -S ) C C Apply G(i) to [A(1:I,I+1) QG(1:I,I+2)]. C CALL DROT( I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) C C Apply G(i) to [A(I+2:N,I+1) QG(I+1, I+3:N+1)'] from the right. C CALL DROT( N-I-1, A(I+2,I+1), 1, QG(I+1,I+3), LDQG, C, -S ) C CS(2*I-1) = C CS(2*I) = S C C Generate elementary reflector F(i) to annihilate A(i+2:n,i). C CALL DLARFG( N-I, A(I+1,I), A(MIN( I+2, N ),I), 1, NU ) IF ( NU.NE.ZERO ) THEN TEMP = A(I+1,I) A(I+1,I) = ONE C C Apply F(i) from the left hand side to A(i+1:n,i+1:n). C CALL DLARF( 'Left', N-I, N-I, A(I+1,I), 1, NU, A(I+1,I+1), $ LDA, DWORK ) C C Apply F(i) from the right hand side to A(1:n,i+1:n). C CALL DLARF( 'Right', N, N-I, A(I+1,I), 1, NU, A(1,I+1), $ LDA, DWORK ) C C Apply F(i) from both sides to QG(i+1:n,i+1:n). C Compute x := nu * QG(i+1:n,i+1:n) * v. C CALL MB01MD( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, A(I+1,I), $ 1, ZERO, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C QG(i+1:n,i+1:n) := QG(i+1:n,i+1:n) + v * x' - x * v'. C CALL MB01ND( 'Lower', N-I, ONE, A(I+1,I), 1, DWORK, 1, $ QG(I+1,I+1), LDQG ) C C Apply F(i) from the right hand side to QG(1:i,i+2:n+1). C CALL DLARF( 'Right', I, N-I, A(I+1,I), 1, NU, QG(1,I+2), $ LDQG, DWORK ) C C Apply F(i) from both sides to QG(i+1:n,i+2:n+1). C Compute x := nu * QG(i+1:n,i+2:n+1) * v. C CALL MB01MD( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, A(I+1,I), $ 1, ZERO, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) + v * x' - x * v'. C CALL MB01ND( 'Upper', N-I, ONE, A(I+1,I), 1, DWORK, 1, $ QG(I+1,I+2), LDQG ) A(I+1,I) = TEMP END IF TAU(I) = NU 10 CONTINUE DWORK(1) = DBLE( MAX( 1, N-1 ) ) RETURN C *** Last line of MB04RU *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01KD.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01KD.f0000644000175000017500000002562515012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE TG01KD( JOBE, COMPC, COMPQ, COMPZ, N, A, LDA, E, LDE, $ B, C, INCC, Q, LDQ, Z, LDZ, INFO ) C C PURPOSE C C To compute for a single-input single-output descriptor system, C (A, E, B, C), with E upper triangular, a transformed system, C (Q'*A*Z, Q'*E*Z, Q'*B, C*Z), via an orthogonal equivalence C transformation, so that Q'*B has only the first element nonzero C and Q'*E*Z remains upper triangular. C C ARGUMENTS C C Mode Parameters C C JOBE CHARACTER*1 C Specifies whether E is an upper triangular or an identity C matrix, as follows: C = 'U': The matrix E is an upper triangular matrix; C = 'I': The matrix E is assumed identity and is not given. C C COMPC CHARACTER*1 C Indicates whether the user wishes to transform the system C output matrix C, as follows: C = 'C': Transform the system output matrix C; C = 'N': Do not transform the system output matrix C. C C COMPQ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Q the orthogonal row transformations, as follows: C = 'N': Do not form Q; C = 'I': Q is initialized to the unit matrix and the C orthogonal transformation matrix Q is returned; C = 'U': The given matrix Q is updated by the orthogonal C transformations used. C C COMPZ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal column transformations, as C follows: C = 'N': Do not form Z; C = 'I': Z is initialized to the unit matrix and the C orthogonal transformation matrix Z is returned; C = 'U': The given matrix Z is updated by the orthogonal C transformations used. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the descriptor state vector; also the C order of square matrices A and E, the number of rows of C matrix B, and the number of columns of matrix 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 original state matrix A. C On exit, the leading N-by-N part of this array contains C the transformed state matrix Q'*A*Z. 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,*) C On entry, if JOBE = 'U', the leading N-by-N upper C triangular part of this array must contain the upper C triangular part of the descriptor matrix E. The lower C triangular part under the first subdiagonal is not C referenced. C On exit, if JOBE = 'U', the leading N-by-N upper C triangular part of this array contains the upper C triangular part of the transformed descriptor matrix, C Q'*E*Z. C If JOBE = 'I', this array is not referenced. C C LDE INTEGER C The leading dimension of the array E. C LDE >= MAX(1,N), if JOBE = 'U'; C LDE >= 1, if JOBE = 'I'. C C B (input/output) DOUBLE PRECISION array, dimension (N) C On entry, the leading N part of this array must contain C the original input matrix B. C On exit, the leading N part of this array contains the C transformed input matrix Q'*B with all elements but the C first set to zero. C C C (input/output) DOUBLE PRECISION array, dimension C ((N-1)*INCC+1) C On entry, if COMPC = 'C', the elements 1, INCC+1, ..., C (N-1)*INCC+1 of this array must contain the original C output vector C. C On exit, if COMPC = 'C', the elements 1, INCC+1, ..., C (N-1)*INCC+1 of this array contain the transformed output C vector C*Z. C If COMPC = 'N', this array is not referenced. C C INCC INTEGER C If COMPC = 'C', the increment between successive values C of C. INCC > 0. C If COMPC = 'N', INCC is not used. C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) C On entry, if COMPQ = 'U', the leading N-by-N part of this C array must contain the given matrix Q1. Otherwise, this C array need not be set on input. C On exit, if COMPU <> 'N', the leading N-by-N part of this C array contains the orthogonal transformation matrix used C (Q1*Q if COMPQ = 'U'). C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= max(1,N), if COMPQ <> 'N'. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) C On entry, if COMPZ = 'U', the leading N-by-N part of this C array must contain the given matrix Z1. Otherwise, this C array need not be set on input. C On exit, if COMPZ <> 'N', the leading N-by-N part of this C array contains the orthogonal transformation matrix used C (Z1*Z if COMPZ = 'U'). C If COMPZ = 'N', this array is not referenced. C C LDZ INTEGER C The leading dimension of the array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= max(1,N), if COMPZ <> '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 METHOD C C Givens rotations are used to annihilate the last N-1 elements of B C in reverse order, but preserve the form of E. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2020. C C REVISIONS C C V. Sima, April 2021, May 2021. C C KEYWORDS C C Controllability, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER COMPC, COMPQ, COMPZ, JOBE INTEGER INCC, INFO, LDA, LDE, LDQ, LDZ, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(*), C(*), E(LDE,*), Q(LDQ,*), $ Z(LDZ,*) C .. Local Scalars .. LOGICAL LINIQ, LINIZ, LUPDQ, LUPDZ, UNITE, WITHC, WITHQ, $ WITHZ INTEGER IC, K DOUBLE PRECISION CS, SN, TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLACPY, DLARTG, DLASET, DROT, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C UNITE = LSAME( JOBE, 'I' ) WITHC = LSAME( COMPC, 'C' ) LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LINIZ = LSAME( COMPZ, 'I' ) LUPDZ = LSAME( COMPZ, 'U' ) WITHQ = LINIQ .OR. LUPDQ WITHZ = LINIZ .OR. LUPDZ INFO = 0 C C Test the input scalar arguments. C IF ( .NOT.UNITE .AND. .NOT.LSAME( JOBE, 'U' ) ) THEN INFO = -1 ELSE IF ( .NOT.WITHC .AND. .NOT.LSAME( COMPC, 'N' ) ) THEN INFO = -2 ELSE IF ( .NOT.WITHQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN INFO = -3 ELSE IF ( .NOT.WITHZ .AND. .NOT.LSAME( COMPZ, 'N' ) ) THEN INFO = -4 ELSE IF ( N.LT.0 ) THEN INFO = -5 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF ( LDE.LT.1 .OR. ( .NOT.UNITE .AND. LDE.LT.MAX( 1, N ) ) ) $ THEN INFO = -9 ELSE IF ( WITHC .AND. INCC.LE.0 ) THEN INFO = -12 ELSE IF ( LDQ.LT.1 .OR. ( WITHQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -14 ELSE IF ( LDZ.LT.1 .OR. ( WITHZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -16 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01KD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C IF ( LINIQ .OR. ( N.EQ.1 .AND. .NOT.LUPDQ ) ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) IF ( LINIZ .OR. ( N.EQ.1 .AND. .NOT.LUPDQ ) ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) IF( N.EQ.1 ) $ RETURN C IF ( WITHC ) $ IC = ( N - 1 )*INCC + 1 C DO 10 K = N, 2, -1 IF ( B(K).NE.ZERO ) THEN CALL DLARTG( B(K-1), B(K), CS, SN, TEMP ) B(K-1) = TEMP B(K) = ZERO CALL DROT( N, A(K-1,1), LDA, A(K,1), LDA, CS, SN ) IF ( WITHQ ) $ CALL DROT( N, Q(1,K-1), 1, Q(1,K), 1, CS, SN ) IF ( UNITE ) THEN CALL DROT( N, A(1,K-1), 1, A(1,K), 1, CS, SN ) IF ( WITHC ) THEN TEMP = C(IC)*SN + C(IC-INCC)*CS C(IC) = C(IC)*CS - C(IC-INCC)*SN IC = IC - INCC C(IC) = TEMP END IF IF ( WITHZ ) THEN IF ( WITHQ .AND. ( LINIQ.EQV.LINIZ .OR. $ LUPDQ.EQV.LUPDZ ) ) THEN CALL DLACPY( 'Full', N, 2, Q(1,K-1), LDQ, Z(1,K-1), $ LDZ ) ELSE CALL DROT( N, Z(1,K-1), 1, Z(1,K), 1, CS, SN ) END IF END IF ELSE E(K,K-1) = SN*E(K-1,K-1) E(K-1,K-1) = CS*E(K-1,K-1) CALL DROT( N-K+1, E(K-1,K), LDE, E(K,K), LDE, CS, SN ) IF ( E(K,K-1).NE.ZERO ) THEN CALL DLARTG( E(K,K), E(K,K-1), CS, SN, TEMP ) E(K,K) = TEMP E(K,K-1) = ZERO TEMP = E(K-1,K)*SN + E(K-1,K-1)*CS E(K-1,K) = E(K-1,K)*CS - E(K-1,K-1)*SN E(K-1,K-1) = TEMP CALL DROT( K-2, E(1,K-1), 1, E(1,K), 1, CS, SN ) CALL DROT( N, A(1,K-1), 1, A(1,K), 1, CS, SN ) IF ( WITHC ) THEN TEMP = C(IC)*SN + C(IC-INCC)*CS C(IC) = C(IC)*CS - C(IC-INCC)*SN IC = IC - INCC C(IC) = TEMP END IF IF ( WITHZ ) $ CALL DROT( N, Z(1,K-1), 1, Z(1,K), 1, CS, SN ) END IF END IF END IF 10 CONTINUE C RETURN C *** Last line of TG01KD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03BA.f0000644000000000000000000000013215012430707016141 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03BA.f0000644000175000017500000000473115012430707017342 0ustar00lilgelilge00000000000000 SUBROUTINE MB03BA( K, H, S, SMULT, AMAP, QMAP ) C C PURPOSE C C To compute the suitable maps for Hessenberg index H and C signature array S. Auxiliary routine for the periodic QZ C algorithms. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C H (input) INTEGER C Index which corresponds to A_1. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SMULT (output) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SMULT. C C AMAP (output) INTEGER array, dimension (K) C The map for accessing the factors, that is, C if AMAP(I) = J, then the factor A_I is stored at the J-th C position in A. C C QMAP (output) INTEGER array, dimension (K) C The map for accessing the orthognal transformation C matrices, that is, if QMAP(I) = J, then the matrix Q_I is C stored at the J-th position in Q. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLAIND. C C KEYWORDS C C Hessenberg matrix, QZ algorithm, periodic QZ algorithm. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER K, H, SMULT C .. Array Arguments .. INTEGER AMAP(*), QMAP(*), S(*) C .. Local Scalars .. INTEGER I, TEMP C .. Intrinsic Functions .. INTRINSIC MOD C C .. Executable Statements .. C IF ( S(H).EQ.-1 ) THEN SMULT = -1 DO 10 I = 1, H AMAP(I) = H-I+1 10 CONTINUE DO 20 I = H+1, K AMAP(I) = H+1-I+K 20 CONTINUE TEMP = MOD( H, K ) + 1 DO 30 I = TEMP, 1, -1 QMAP(TEMP-I+1) = I 30 CONTINUE DO 40 I = K, TEMP + 1, -1 QMAP(TEMP+K-I+1) = I 40 CONTINUE ELSE SMULT = 1 DO 50 I = H, K AMAP(I-H+1) = I QMAP(I-H+1) = I 50 CONTINUE DO 60 I = 1, H-1 AMAP(K-H+I+1) = I QMAP(K-H+I+1) = I 60 CONTINUE END IF C RETURN C *** Last line of MB03BA *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01CD.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01CD.f0000644000175000017500000002113515012430707017355 0ustar00lilgelilge00000000000000 SUBROUTINE TG01CD( COMPQ, L, N, M, A, LDA, E, LDE, B, LDB, Q, LDQ, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To reduce the descriptor system pair (A-lambda E,B) to the C QR-coordinate form by computing an orthogonal transformation C matrix Q such that the transformed descriptor system pair C (Q'*A-lambda Q'*E, Q'*B) has the descriptor matrix Q'*E C in an upper trapezoidal form. C The left orthogonal transformations performed to reduce E C can be optionally accumulated. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C = 'N': do not compute Q; C = 'I': Q is initialized to the unit matrix, and the C orthogonal matrix Q is returned; C = 'U': Q must contain an orthogonal matrix Q1 on entry, C and the product Q1*Q is returned. C C Input/Output Parameters C C L (input) INTEGER C The number of rows of matrices A, B, and E. L >= 0. C C N (input) INTEGER C The number of columns of matrices A and E. N >= 0. C C M (input) INTEGER C The number of columns of matrix B. M >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the state dynamics matrix A. C On exit, the leading L-by-N part of this array contains C the transformed matrix Q'*A. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,L). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the descriptor matrix E. C On exit, the leading L-by-N part of this array contains C the transformed matrix Q'*E in upper trapezoidal form, C i.e. C C ( E11 ) C Q'*E = ( ) , if L >= N , C ( 0 ) C or C C Q'*E = ( E11 E12 ), if L < N , C C where E11 is an MIN(L,N)-by-MIN(L,N) upper triangular C matrix. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,L). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, the leading L-by-M part of this array must C contain the input/state matrix B. C On exit, the leading L-by-M part of this array contains C the transformed matrix Q'*B. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) C If COMPQ = 'N': Q is not referenced. C If COMPQ = 'I': on entry, Q need not be set; C on exit, the leading L-by-L part of this C array contains the orthogonal matrix Q, C where Q' is the product of Householder C transformations which are applied to A, C E, and B on the left. C If COMPQ = 'U': on entry, the leading L-by-L part of this C array must contain an orthogonal matrix C Q1; C on exit, the leading L-by-L part of this C array contains the orthogonal matrix C Q1*Q. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. 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 length of the array DWORK. C LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)). C For optimum performance C LWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)*NB), C where NB is the optimal blocksize. 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 the QR factorization of E to reduce it C to the upper trapezoidal form. C C The transformations are also applied to the rest of system C matrices C C A <- Q' * A , B <- Q' * B. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( L*L*N ) floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C March 1999. Based on the RASP routine RPDSQR. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 1999, C May 2003. C C KEYWORDS C C Descriptor system, matrix algebra, matrix operations, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER COMPQ INTEGER INFO, L, LDA, LDB, LDE, LDQ, LDWORK, M, N C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), $ E( LDE, * ), Q( LDQ, * ) C .. Local Scalars .. LOGICAL ILQ INTEGER ICOMPQ, LN, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEQRF, DLASET, DORMQR, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C C .. Executable Statements .. C C Decode COMPQ. C IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'U' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF C C Test the input parameters. C INFO = 0 WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, M ) ) IF( ICOMPQ.EQ.0 ) THEN INFO = -1 ELSE IF( L.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, L ) ) THEN INFO = -6 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -8 ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN INFO = -10 ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN INFO = -12 ELSE IF( LDWORK.LT.WRKOPT ) THEN INFO = -14 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01CD', -INFO ) RETURN END IF C C Initialize Q if necessary. C IF( ICOMPQ.EQ.3 ) $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) C C Quick return if possible. C IF( L.EQ.0 .OR. N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C LN = MIN( L, N ) C C Compute the QR decomposition of E. C C Workspace: need MIN(L,N) + N; C prefer MIN(L,N) + N*NB. C CALL DGEQRF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) C C Apply transformation on the rest of matrices. C C A <-- Q' * A. C Workspace: need MIN(L,N) + N; C prefer MIN(L,N) + N*NB. C CALL DORMQR( 'Left', 'Transpose', L, N, LN, E, LDE, DWORK, $ A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) C C B <-- Q' * B. C Workspace: need MIN(L,N) + M; C prefer MIN(L,N) + M*NB. C IF ( M.GT.0 ) THEN CALL DORMQR( 'Left', 'Transpose', L, M, LN, E, LDE, DWORK, $ B, LDB, DWORK( LN+1 ), LDWORK-LN, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) END IF C C Q <-- Q1 * Q. C Workspace: need MIN(L,N) + L; C prefer MIN(L,N) + L*NB. C IF( ILQ ) THEN CALL DORMQR( 'Right', 'No Transpose', L, L, LN, E, LDE, DWORK, $ Q, LDQ, DWORK( LN+1 ), LDWORK-LN, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) END IF C C Set lower triangle of E to zero. C IF( L.GE.2 ) $ CALL DLASET( 'Lower', L-1, LN, ZERO, ZERO, E( 2, 1 ), LDE ) C DWORK(1) = WRKOPT C RETURN C *** Last line of TG01CD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04DY.f0000644000000000000000000000013215012430707016174 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04DY.f0000644000175000017500000002562715012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO ) C C PURPOSE C C To perform a symplectic scaling on the Hamiltonian matrix C C ( A G ) C H = ( T ), (1) C ( Q -A ) C C i.e., perform either the symplectic scaling transformation C C -1 C ( A' G' ) ( D 0 ) ( A G ) ( D 0 ) C H' <-- ( T ) = ( ) ( T ) ( -1 ), (2) C ( Q' -A' ) ( 0 D ) ( Q -A ) ( 0 D ) C C where D is a diagonal scaling matrix, or the symplectic norm C scaling transformation C C ( A'' G'' ) 1 ( A G/tau ) C H'' <-- ( T ) = --- ( T ), (3) C ( Q'' -A'' ) tau ( tau Q -A ) C C where tau is a real scalar. Note that if tau is not equal to 1, C then (3) is NOT a similarity transformation. The eigenvalues C of H are then tau times the eigenvalues of H''. C C For symplectic scaling (2), D is chosen to give the rows and C columns of A' approximately equal 1-norms and to give Q' and G' C approximately equal norms. (See METHOD below for details.) For C norm scaling, tau = MAX(1, ||A||, ||G||, ||Q||) where ||.|| C denotes the 1-norm (column sum norm). C C ARGUMENTS C C Mode Parameters C C JOBSCL CHARACTER*1 C Indicates which scaling strategy is used, as follows: C = 'S' : do the symplectic scaling (2); C = '1' or 'O': do the 1-norm scaling (3); C = 'N' : do nothing; set INFO and return. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, G, and Q. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On input, if JOBSCL <> 'N', the leading N-by-N part of C this array must contain the upper left block A of the C Hamiltonian matrix H in (1). C On output, if JOBSCL <> 'N', the leading N-by-N part of C this array contains the leading N-by-N part of the scaled C Hamiltonian matrix H' in (2) or H'' in (3), depending on C the setting of JOBSCL. C If JOBSCL = 'N', this array is not referenced. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,N), if JOBSCL <> 'N'; C LDA >= 1, if JOBSCL = 'N'. C C QG (input/output) DOUBLE PRECISION array, dimension C (LDQG,N+1) C On input, if JOBSCL <> 'N', the leading N-by-N lower C triangular part of this array must contain the lower C triangle of the lower left symmetric block Q of the C Hamiltonian matrix H in (1), and the N-by-N upper C triangular part of the submatrix in the columns 2 to N+1 C of this array must contain the upper triangle of the upper C right symmetric block G of H in (1). C So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j) C and G(i,j) = G(j,i) is stored in QG(j,i+1). C On output, if JOBSCL <> 'N', the leading N-by-N lower C triangular part of this array contains the lower triangle C of the lower left symmetric block Q' or Q'', and the C N-by-N upper triangular part of the submatrix in the C columns 2 to N+1 of this array contains the upper triangle C of the upper right symmetric block G' or G'' of the scaled C Hamiltonian matrix H' in (2) or H'' in (3), depending on C the setting of JOBSCL. C If JOBSCL = 'N', this array is not referenced. C C LDQG INTEGER C The leading dimension of the array QG. C LDQG >= MAX(1,N), if JOBSCL <> 'N'; C LDQG >= 1, if JOBSCL = 'N'. C C D (output) DOUBLE PRECISION array, dimension (nd) C If JOBSCL = 'S', then nd = N and D contains the diagonal C elements of the diagonal scaling matrix in (2). C If JOBSCL = '1' or 'O', then nd = 1 and D(1) is set to tau C from (3). In this case, no other elements of D are C referenced. C If JOBSCL = 'N', this array is not referenced. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (N) C If JOBSCL = 'N', this array is not referenced. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C < 0: if INFO = -i, then the i-th argument had an illegal C value. C C METHOD C C 1. Symplectic scaling (JOBSCL = 'S'): C C First, LAPACK subroutine DGEBAL is used to equilibrate the 1-norms C of the rows and columns of A using a diagonal scaling matrix D_A. C Then, H is similarily transformed by the symplectic diagonal C matrix D1 = diag(D_A,D_A**(-1)). Next, the off-diagonal blocks of C the resulting Hamiltonian matrix are equilibrated in the 1-norm C using the symplectic diagonal matrix D2 of the form C C ( I/rho 0 ) C D2 = ( ) C ( 0 rho*I ) C C where rho is a real scalar. Thus, in (2), D = D1*D2. C C 2. Norm scaling (JOBSCL = '1' or 'O'): C C The norm of the matrices A and G of (1) is reduced by setting C A := A/tau and G := G/(tau**2) where tau is the power of the C base of the arithmetic closest to MAX(1, ||A||, ||G||, ||Q||) and C ||.|| denotes the 1-norm. C C REFERENCES C C [1] Benner, P., Byers, R., and Barth, E. C Fortran 77 Subroutines for Computing the Eigenvalues of C Hamiltonian Matrices. I: The Square-Reduced Method. C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. C C NUMERICAL ASPECTS C C For symplectic scaling, the complexity of the used algorithms is C hard to estimate and depends upon how well the rows and columns of C A in (1) are equilibrated. In one sweep, each row/column of A is C scaled once, i.e., the cost of one sweep is N**2 multiplications. C Usually, 3-6 sweeps are enough to equilibrate the norms of the C rows and columns of a matrix. Roundoff errors are possible as C LAPACK routine DGEBAL does NOT use powers of the machine base for C scaling. The second stage (equilibrating ||G|| and ||Q||) requires C N**2 multiplications. C For norm scaling, 3*N**2 + O(N) multiplications are required and C NO rounding errors occur as all multiplications are performed with C powers of the machine base. C C CONTRIBUTOR C C P. Benner, Universitaet Bremen, Germany, and C R. Byers, University of Kansas, Lawrence, USA. C Aug. 1998, routine DHABL. C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Oct. 1998, SLICOT Library version. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, May 2009. C C KEYWORDS C C Balancing, Hamiltonian matrix, norms, symplectic similarity C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C C .. Scalar Arguments .. INTEGER INFO, LDA, LDQG, N CHARACTER JOBSCL C .. C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), D(*), DWORK(*), QG(LDQG,*) C .. C .. Local Scalars .. DOUBLE PRECISION ANRM, BASE, EPS, GNRM, OFL, QNRM, $ RHO, SFMAX, SFMIN, TAU, UFL, Y INTEGER I, IERR, IHI, ILO, J LOGICAL NONE, NORM, SYMP C .. C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE, DLANSY LOGICAL LSAME EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME C .. C .. External Subroutines .. EXTERNAL DGEBAL, DLABAD, DLASCL, DRSCL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C .. C .. Executable Statements .. C INFO = 0 SYMP = LSAME( JOBSCL, 'S' ) NORM = LSAME( JOBSCL, '1' ) .OR. LSAME( JOBSCL, 'O' ) NONE = LSAME( JOBSCL, 'N' ) C IF( .NOT.SYMP .AND. .NOT.NORM .AND. .NOT.NONE ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.1 .OR. ( .NOT.NONE .AND. LDA.LT.N ) ) THEN INFO = -4 ELSE IF( LDQG.LT.1 .OR. ( .NOT.NONE .AND. LDQG.LT.N ) ) THEN INFO = -6 END IF C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04DY', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 .OR. NONE ) $ RETURN C C Set some machine dependant constants. C BASE = DLAMCH( 'Base' ) EPS = DLAMCH( 'Precision' ) UFL = DLAMCH( 'Safe minimum' ) OFL = ONE/UFL CALL DLABAD( UFL, OFL ) SFMAX = ( EPS/BASE )/UFL SFMIN = ONE/SFMAX C IF ( NORM ) THEN C C Compute norms. C ANRM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK ) QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK ) Y = MAX( ONE, ANRM, GNRM, QNRM ) TAU = ONE C C WHILE ( TAU < Y ) DO 10 CONTINUE IF ( ( TAU.LT.Y ) .AND. ( TAU.LT.SQRT( SFMAX ) ) ) THEN TAU = TAU*BASE GO TO 10 END IF C END WHILE 10 IF ( TAU.GT.ONE ) THEN IF ( ABS( TAU/BASE - Y ).LT.ABS( TAU - Y ) ) $ TAU = TAU/BASE CALL DLASCL( 'General', 0, 0, TAU, ONE, N, N, A, LDA, IERR ) CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG, $ IERR ) CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG, $ IERR ) END IF C D(1) = TAU C ELSE CALL DGEBAL( 'Scale', N, A, LDA, ILO, IHI, D, IERR ) C DO 30 J = 1, N C DO 20 I = J, N QG(I,J) = QG(I,J)*D(J)*D(I) 20 CONTINUE C 30 CONTINUE C DO 50 J = 2, N + 1 C DO 40 I = 1, J - 1 QG(I,J) = QG(I,J)/D(J-1)/D(I) 40 CONTINUE C 50 CONTINUE C GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK ) QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK ) IF ( GNRM.EQ.ZERO ) THEN IF ( QNRM.EQ.ZERO ) THEN RHO = ONE ELSE RHO = SFMAX END IF ELSE IF ( QNRM.EQ.ZERO ) THEN RHO = SFMIN ELSE RHO = SQRT( QNRM )/SQRT( GNRM ) END IF C CALL DLASCL( 'Lower', 0, 0, RHO, ONE, N, N, QG, LDQG, IERR ) CALL DLASCL( 'Upper', 0, 0, ONE, RHO, N, N, QG(1,2), LDQG, $ IERR ) CALL DRSCL( N, SQRT( RHO ), D, 1 ) END IF C RETURN C *** Last line of MB04DY *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03BX.f0000644000000000000000000000013215012430707016203 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SG03BX.f0000644000175000017500000006264515012430707017414 0ustar00lilgelilge00000000000000 SUBROUTINE SG03BX( DICO, TRANS, A, LDA, E, LDE, B, LDB, U, LDU, $ SCALE, M1, LDM1, M2, LDM2, INFO ) C C PURPOSE C C To solve for X = op(U)**T * op(U) either the generalized c-stable C continuous-time Lyapunov equation C C T T C op(A) * X * op(E) + op(E) * X * op(A) C C 2 T C = - SCALE * op(B) * op(B), (1) C C or the generalized d-stable discrete-time Lyapunov equation C C T T C op(A) * X * op(A) - op(E) * X * op(E) C C 2 T C = - SCALE * op(B) * op(B), (2) C C where op(K) is either K or K**T for K = A, B, E, U. The Cholesky C factor U of the solution is computed without first finding X. C C Furthermore, the auxiliary matrices C C -1 -1 C M1 := op(U) * op(A) * op(E) * op(U) C C -1 -1 C M2 := op(B) * op(E) * op(U) C C are computed in a numerically reliable way. C C The matrices A, B, E, M1, M2, and U are real 2-by-2 matrices. The C pencil A - lambda * E must have a pair of complex conjugate C eigenvalues. The eigenvalues must be in the open right half plane C (in the continuous-time case) or inside the unit circle (in the C discrete-time case). The matrices E and B are upper triangular. C C The resulting matrix U is upper triangular. The entries on its C main diagonal are non-negative. SCALE is an output scale factor C set to avoid overflow in U. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies whether the continuous-time or the discrete-time C equation is to be solved: C = 'C': Solve continuous-time equation (1); C = 'D': Solve discrete-time equation (2). C C TRANS CHARACTER*1 C Specifies whether the transposed equation is to be solved C or not: C = 'N': op(K) = K, K = A, B, E, U; C = 'T': op(K) = K**T, K = A, B, E, U. C C Input/Output Parameters C C A (input) DOUBLE PRECISION array, dimension (LDA,2) C The leading 2-by-2 part of this array must contain the C matrix A. C C LDA INTEGER C The leading dimension of the array A. LDA >= 2. C C E (input) DOUBLE PRECISION array, dimension (LDE,2) C The leading 2-by-2 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 >= 2. C C B (input) DOUBLE PRECISION array, dimension (LDB,2) C The leading 2-by-2 upper triangular part of this array C must contain the matrix B. C C LDB INTEGER C The leading dimension of the array B. LDB >= 2. C C U (output) DOUBLE PRECISION array, dimension (LDU,2) C The leading 2-by-2 part of this array contains the upper C triangular matrix U. C C LDU INTEGER C The leading dimension of the array U. LDU >= 2. C C SCALE (output) DOUBLE PRECISION C The scale factor set to avoid overflow in U. C 0 < SCALE <= 1. C C M1 (output) DOUBLE PRECISION array, dimension (LDM1,2) C The leading 2-by-2 part of this array contains the C matrix M1. C C LDM1 INTEGER C The leading dimension of the array M1. LDM1 >= 2. C C M2 (output) DOUBLE PRECISION array, dimension (LDM2,2) C The leading 2-by-2 part of this array contains the C matrix M2. C C LDM2 INTEGER C The leading dimension of the array M2. LDM2 >= 2. C C Error indicator C C INFO INTEGER C = 0: successful exit; C = 2: the eigenvalues of the pencil A - lambda * E are not C a pair of complex conjugate numbers; C = 3: the eigenvalues of the pencil A - lambda * E are C not in the open right half plane (in the continuous- C time case) or inside the unit circle (in the C discrete-time case); C = 4: the LAPACK routine ZSTEIN utilized to factorize M3 C (see SLICOT Library routine SG03BS) failed to C converge. This error is unlikely to occur. C C METHOD C C The method used by the routine is based on a generalization of the C method due to Hammarling ([1], section 6) for Lyapunov equations C of order 2. A more detailed description is given in [2]. C C REFERENCES C C [1] Hammarling, S.J. C Numerical solution of the stable, non-negative definite C Lyapunov equation. C IMA J. Num. Anal., 2, pp. 303-323, 1982. 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 FURTHER COMMENTS C C If the solution matrix U is singular, the matrices M1 and M2 are C properly set (see [1], equation (6.21)). C C CONTRIBUTOR C C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. C V. Sima, substantial changes, Dec. 2021, Jan. 2022. C C REVISIONS C C Sep. 1998, Dec. 1998. C July 2003 (V. Sima; suggested by Klaus Schnepper). C Oct. 2003 (A. Varga). C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO, ZERO, SAFETY PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0, $ SAFETY = 1.0D+2 ) C .. Scalar Arguments .. CHARACTER DICO, TRANS DOUBLE PRECISION SCALE INTEGER INFO, LDA, LDB, LDE, LDM1, LDM2, LDU C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), E(LDE,*), M1(LDM1,*), $ M2(LDM2,*), U(LDU,*) C .. Local Scalars .. COMPLEX*16 X, ZS DOUBLE PRECISION A11, A12, A21, A22, AI11, AI12, AI21, AI22, $ ALPHA, AR11, AR12, AR21, AR22, B11, B12I, B12R, $ BETAI, BETAR, BI11, BI12, BI21, BI22, BIGNUM, $ BR11, BR12, BR21, BR22, C, CL, CQ, CQB, CQBI, $ CQU, CQUI, CZ, E11, E12, E22, EI12, EI21, ER11, $ ER12, ER22, EPS, LAMI, LAMR, LI, LR, M1I12, $ M1R12, M2I12, M2R12, M2R22, M2S, MI, MR, MX, P, $ S, SCALE1, SCALE2, SI, SIQ, SIQB, SIQU, SIZ, SL, $ SMLNUM, SQTWO, SR, SRQ, SRQB, SRQU, SRZ, T, TMP, $ UI12, UI22, UR11, UR12, UR22, V, VI12, VR12, $ VR22, W, XR, XI, YR, YI INTEGER CT LOGICAL ISCONT, ISTRNS C .. Local Arrays .. COMPLEX*16 M3(1), M3C(2,1) DOUBLE PRECISION AS(2,2), D(2), DWORK(10), ES(2,2), ET(2), EV(2) INTEGER IWORK(7) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2, DLAPY3 LOGICAL LSAME EXTERNAL DLAMCH, DLAPY2, DLAPY3, LSAME C .. External Subroutines .. EXTERNAL DLABAD, DLADIV, DLAG2, DLASV2, SG03BR, ZLARFG, $ ZSTEIN C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, MAX, MIN, SQRT C C Decode input parameters. C ISTRNS = LSAME( TRANS, 'T' ) ISCONT = LSAME( DICO, 'C' ) C C Do not check input parameters for errors. C C Set constants to control overflow. C SQTWO = SQRT( TWO ) EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' )/EPS BIGNUM = ONE/SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) C C Set constant input for ZSTEIN. C IWORK(2) = 1 IWORK(3) = 0 IWORK(4) = 2 IWORK(5) = 0 EV(1) = ONE EV(2) = ZERO C INFO = 0 SCALE = ONE C C Make copies of A, E, and B. C AS(1,1) = A(1,1) AS(2,1) = A(2,1) AS(1,2) = A(1,2) AS(2,2) = A(2,2) ES(1,1) = E(1,1) ES(2,1) = ZERO ES(1,2) = E(1,2) ES(2,2) = E(2,2) BR11 = B(1,1) BR12 = B(1,2) BR22 = B(2,2) C C If the transposed equation (op(K)=K**T, K=A,B,E,U) is to be C solved, transpose the matrices A, E, B with respect to the C anti-diagonal. This results in a non-transposed equation. C IF ( ISTRNS ) THEN V = AS(1,1) AS(1,1) = AS(2,2) AS(2,2) = V V = ES(1,1) ES(1,1) = ES(2,2) ES(2,2) = V V = BR11 BR11 = BR22 BR22 = V END IF C C Perform QZ-step to transform the pencil A - lambda * E to complex C generalized Schur form. The main diagonal of the Schur factor of E C is real and positive. C C Compute eigenvalues (LAMR + LAMI * I, LAMR - LAMI * I). C CT = 0 10 CONTINUE CT = CT + 1 P = MAX( EPS*MAX( ABS( ES(1,1) ), ABS( ES(1,2) ), $ ABS( ES(2,2) ) ), SMLNUM ) IF ( MIN( ABS( ES(1,1) ), ABS( ES(2,2) ) ).LT.P ) THEN INFO = 2 RETURN END IF CALL DLAG2( AS, 2, ES, 2, SMLNUM*EPS*SAFETY, SCALE1, SCALE2, LAMR, $ W, LAMI ) IF ( LAMI.LE.ZERO ) THEN INFO = 2 RETURN END IF C IF ( ES(1,2).NE.ZERO ) THEN C C Standardize, that is, rotate so that ES is diagonal with C ES(1,1) non-negative. C CALL DLASV2( ES(1,1), ES(1,2), ES(2,2), E22, E11, SR, C, SL, $ CL ) C IF ( E11.LT.ZERO ) THEN C = -C SR = -SR E11 = -E11 E22 = -E22 END IF C C Update A using the left and right rotations. C S = CL*AS(1,1) + SL*AS(2,1) T = CL*AS(1,2) + SL*AS(2,2) V = CL*AS(2,1) - SL*AS(1,1) W = CL*AS(2,2) - SL*AS(1,2) C AS(1,1) = S*C + T*SR AS(2,1) = V*C + W*SR AS(1,2) = T*C - S*SR AS(2,1) = W*C - V*SR C ES(1,1) = E11 ES(2,1) = ZERO ES(1,2) = ZERO C C If E22 is negative, negate the second columns. C IF ( E22.LT.ZERO ) THEN ES(2,2) = -E22 AS(1,2) = -AS(1,2) AS(2,2) = -AS(2,2) ELSE ES(2,2) = E22 END IF C C Recompute the shift. C CALL DLAG2( AS, 2, ES, 2, SMLNUM*EPS*SAFETY, SCALE1, SCALE2, $ LAMR, W, LAMI ) C C If standardization has perturbed the shift onto real line, C do another (real single-shift) QR step. C IF ( LAMI.EQ.ZERO ) THEN IF ( CT.EQ.1 ) THEN GO TO 10 ELSE INFO = 2 RETURN END IF END IF END IF C C Compute left unitary transformation matrix Q. C A11 = AS(1,1) A21 = AS(2,1) A12 = AS(1,2) A22 = AS(2,2) E11 = ES(1,1) E22 = ES(2,2) CALL SG03BR( SCALE1*A11 - E11*LAMR, -E11*LAMI, SCALE1*A21, ZERO, $ CQ, SRQ, SIQ, LR, LI ) C C A := Q * A. C AR11 = CQ*A11 + SRQ*A21 AR21 = CQ*A21 - SRQ*A11 AR12 = CQ*A12 + SRQ*A22 AR22 = CQ*A22 - SRQ*A12 AI11 = SIQ*A21 AI21 = SIQ*A11 AI12 = SIQ*A22 AI22 = SIQ*A12 C C E := Q * E. C EI21 = SIQ*E11 EI12 = SIQ*E22 TMP = SRQ*E11 E11 = CQ*E11 E12 = SRQ*E22 C C Compute right unitary transformation matrix Z. C CALL SG03BR( CQ*E22, ZERO, TMP, -EI21, CZ, SRZ, SIZ, LR, LI ) C C E := E * Z**H. C ER11 = E11*CZ + E12*SRZ + EI12*SIZ ER12 = E12*CZ - E11*SRZ EI12 = EI12*CZ - E11*SIZ ER22 = LR C C The structure of the matrices A, E, Q, and Z ensures that the C diagonal elements are real and E(2,2) > 0. Make E(1,1) > 0. C IF ( ER11.LT.ZERO ) $ ER11 = -ER11 C C A := A * Z**H. C A11 = AR11 A12 = AR12 TMP = AI11 AR11 = A12*SRZ + A11*CZ + AI12*SIZ AI11 = AI12*SRZ + TMP*CZ - A12*SIZ AR12 = A12*CZ + TMP*SIZ - A11*SRZ AI12 = AI12*CZ - A11*SIZ - TMP*SRZ AR22 = AR22*CZ + AI21*SIZ - AR21*SRZ AI22 = AI22*CZ - AR21*SIZ - AI21*SRZ C C End of QZ-step. C C B := B * Z**H. C B11 = BR11 BI11 = -BR12*SIZ BI21 = -BR22*SIZ BI12 = -B11*SIZ BR11 = BR12*SRZ + B11*CZ BR21 = BR22*SRZ BR12 = BR12*CZ - B11*SRZ BR22 = BR22*CZ C C Overwrite B with the upper triangular matrix of its C QR-factorization. The elements on the main diagonal are real C and non-negative. C CALL SG03BR( BR11, BI11, BR21, BI21, CQB, SRQB, SIQB, LR, LI ) V = BR12 T = BI12 BR12 = SRQB*BR22 + CQB*V BI12 = SIQB*BR22 + CQB*T BR22 = CQB*BR22 - SRQB*V - SIQB*T BI22 = SIQB*V - SRQB*T BR11 = LR BI11 = LI C IF ( LI.NE.ZERO ) THEN V = DLAPY2( BR11, BI11 ) CALL DLADIV( V, ZERO, BR11, BI11, XR, XI ) BR11 = V T = XR*BR12 - XI*BI12 BI12 = XR*BI12 + XI*BR12 BR12 = T C CQBI = XI*CQB CQB = XR*CQB T = XR*SRQB - XI*SIQB SIQB = XR*SIQB + XI*SRQB SRQB = T END IF C IF ( BI22.NE.ZERO ) THEN V = DLAPY2( BR22, BI22 ) IF ( V.GE.MAX( EPS*MAX( BR11, DLAPY2( BR12, BI12 ) ), SMLNUM ) $ ) THEN CALL DLADIV( V, ZERO, BR22, BI22, XR, XI ) BR22 = V ELSE BR22 = ZERO END IF ELSE IF ( BR22.LT.ZERO ) THEN BR22 = -BR22 END IF C C Compute the Cholesky factor of the solution of the reduced C equation. The solution may be scaled to avoid overflow. C IF ( ISCONT ) THEN C C Continuous-time equation. C C Step I: Compute U(1,1). U(2,1) is 0. C V = -AR11 IF ( V.LE.ZERO ) THEN INFO = 3 RETURN END IF V = SQRT( V )*SQRT( ER11 ) T = ( BR11*SMLNUM )/SQTWO IF ( T.GT.V ) THEN SCALE1 = V/T SCALE = SCALE1*SCALE BR11 = SCALE1*BR11 BR12 = SCALE1*BR12 BI12 = SCALE1*BI12 BR22 = SCALE1*BR22 END IF V = V*SQTWO UR11 = BR11/V C C Step II: Compute U(1,2). C MX = MAX( ABS( AR11 ), ABS( AI11 ), V ) IF ( ER11.GT.MX*SMLNUM ) THEN MR = AR11/ER11 MI = -AI11/ER11 M2S = V/ER11 XR = M2S*BR12 XI = M2S*BI12 IF ( UR11.NE.ZERO ) THEN XR = XR + UR11*( AR12 + MR*ER12 - MI*EI12 ) XI = XI + UR11*( AI12 + MR*EI12 + MI*ER12 ) END IF YR = AR22 + MR*ER22 YI = AI22 + MI*ER22 ELSE XR = BR12*V XI = BI12*V IF ( UR11.NE.ZERO ) THEN XR = XR + UR11*( ER11*AR12 + AR11*ER12 + AI11*EI12 ) XI = XI + UR11*( ER11*AI12 + AR11*EI12 - AI11*ER12 ) END IF YR = ER11*AR22 + AR11*ER22 YI = ER11*AI22 - AI11*ER22 END IF T = DLAPY2( XR, XI )*SMLNUM W = DLAPY2( YR, YI ) IF ( T.GT.W ) THEN SCALE1 = W/T SCALE = SCALE1*SCALE BR11 = SCALE1*BR11 BR12 = SCALE1*BR12 BR22 = SCALE1*BR22 BI12 = SCALE1*BI12 UR11 = SCALE1*UR11 XR = SCALE1*XR XI = SCALE1*XI END IF CALL DLADIV( XR, XI, -YR, -YI, UR12, UI12 ) C C Step III: Compute U(2,2). C VR12 = UR11*ER12 + UR12*ER22 VI12 = UR11*EI12 + UI12*ER22 IF ( ER11.GT.MX*SMLNUM ) THEN YR = BR12 - M2S*VR12 YI = BI12 - M2S*VI12 ELSE XR = VR12*V XI = -VI12*V T = DLAPY2( XR, XI )*SMLNUM IF ( T.GT.ER11 ) THEN SCALE1 = ER11/T SCALE = SCALE1*SCALE BR11 = SCALE1*BR11 BR12 = SCALE1*BR12 BI12 = SCALE1*BI12 BR22 = SCALE1*BR22 UR11 = SCALE1*UR11 UR12 = SCALE1*UR12 UI12 = SCALE1*UI12 XR = SCALE1*XR XI = SCALE1*XI END IF YR = BR12 - XR/ER11 YI = -BI12 - XI/ER11 END IF CALL SG03BR( BR22, ZERO, YR, YI, C, SR, SI, LR, LI ) V = -AR22 IF ( V.LE.ZERO ) THEN INFO = 3 RETURN END IF V = SQRT( V )*SQRT( ER22 ) T = ( LR*SMLNUM )/SQTWO IF ( T.GT.V ) THEN SCALE1 = V/T SCALE = SCALE1*SCALE BR11 = SCALE1*BR11 BR12 = SCALE1*BR12 BR22 = SCALE1*BR22 BI12 = SCALE1*BI12 UR11 = SCALE1*UR11 UR12 = SCALE1*UR12 UI12 = SCALE1*UI12 LR = SCALE1*LR END IF V = V*SQTWO UR22 = LR/V C C Compute the needed elements of the matrices M1 and M2 for the C reduced equation. C BETAR = AR11/ER11 BETAI = AI11/ER11 ALPHA = SQRT( -BETAR )*SQTWO C VR22 = UR22*ER22 IF ( VR22.NE.ZERO ) THEN M2R22 = BR22/VR22 M2R12 = ( BR12 - ALPHA*VR12 )/VR22 M2I12 = ( BI12 - ALPHA*VI12 )/VR22 M1R12 = -ALPHA*M2R12 M1I12 = -ALPHA*M2I12 ELSE M1R12 = ZERO M1I12 = ZERO M2R12 = ZERO M2R22 = ALPHA M2I12 = ZERO END IF C ELSE C C Discrete-time equation. C C Step I: Compute U(1,1). U(2,1) is 0. C V = ER11 T = DLAPY2( AR11, AI11 ) IF ( V.LE.T ) THEN INFO = 3 RETURN END IF T = T/V V = SQRT( ONE - T )*SQRT( ONE + T )*V T = BR11*SMLNUM IF ( T.GT.V ) THEN SCALE1 = V/T SCALE = SCALE1*SCALE BR11 = SCALE1*BR11 BR12 = SCALE1*BR12 BR22 = SCALE1*BR22 BI12 = SCALE1*BI12 END IF UR11 = BR11/V C C Step II: Compute U(1,2). C MX = MAX( ABS( AR11 ), ABS( AI11 ), V ) IF ( ER11.GT.MX*SMLNUM ) THEN MR = AR11/ER11 MI = -AI11/ER11 M2S = V/ER11 XR = M2S*BR12 XI = M2S*BI12 IF ( UR11.NE.ZERO ) THEN XR = XR + UR11*( MR*AR12 - MI*AI12 - ER12 ) XI = XI + UR11*( MR*AI12 + MI*AR12 - EI12 ) END IF YR = MI*AI22 - MR*AR22 + ER22 YI = -MR*AI22 - MI*AR22 ELSE XR = -BR12*V XI = -BI12*V IF ( UR11.NE.ZERO ) THEN XR = XR + UR11*( ER11*ER12 - AR11*AR12 - AI11*AI12 ) XI = XI + UR11*( ER11*EI12 - AR11*AI12 + AI11*AR12 ) END IF YR = AR11*AR22 + AI11*AI22 - ER11*ER22 YI = AR11*AI22 - AI11*AR22 END IF T = DLAPY2( XR, XI )*SMLNUM W = DLAPY2( YR, YI ) IF ( T.GT.W ) THEN SCALE1 = W/T SCALE = SCALE1*SCALE BR11 = SCALE1*BR11 BR12 = SCALE1*BR12 BR22 = SCALE1*BR22 BI12 = SCALE1*BI12 UR11 = SCALE1*UR11 XR = SCALE1*XR XI = SCALE1*XI END IF CALL DLADIV( XR, XI, YR, YI, UR12, UI12 ) C C Step III: Compute U(2,2). C XR = UR11*AR12 + UR12*AR22 - UI12*AI22 XI = UR11*AI12 + UR12*AI22 + UI12*AR22 C IF ( ER11.GT.MX*SMLNUM ) THEN C C Compute auxiliary matrices M3 and Y. The factorization C M3 = M3C * M3C**H is found by solving the special symmetric C eigenvalue problem. (D below is the diagonal of M3.) C It is convenient to use complex arithmetic for M3 and M3C. C Only the (1,2) element of M3 is needed. C X = -M2S*DCMPLX( MR, MI ) M3(1) = X CALL ZLARFG( 1, X, M3, 1, ZS ) D(1) = DLAPY2( MR, MI )**2 D(2) = M2S**2 ET(1) = DBLE( X ) C CALL ZSTEIN( 2, D, ET, 1, EV, IWORK(2), IWORK(4), M3C, 2, $ DWORK, IWORK(6), IWORK, INFO ) IF ( INFO.NE.0 ) THEN INFO = 4 RETURN END IF C V = DBLE( M3C(1,1) )*( ONE - DBLE( ZS ) ) W = -DBLE( M3C(1,1) )*DIMAG( ZS ) T = DBLE( M3C(2,1) ) YR = V*BR12 + W*BI12 + T*XR YI = V*BI12 - W*BR12 + T*XI C C Overwrite B(2,2) with the scalar factor R of the C QR-factorization of the 2-by-1 vector [ B(2,2); y ]. C CALL SG03BR( BR22, ZERO, YR, YI, C, SR, SI, LR, LI ) ELSE T = DLAPY2( AR22, AI22 ) IF ( ER22.LE.T ) THEN INFO = 3 RETURN END IF YR = UR11*ER12 + UR12*ER22 YI = UR11*EI12 + UI12*ER22 V = DLAPY2( BR12, BI12 ) W = DLAPY2( XR, XI ) T = DLAPY2( YR, YI ) V = DLAPY3( V, BR22, W ) IF ( V.LE.T ) THEN INFO = 3 RETURN END IF T = T/V LR = SQRT( ONE - T )*SQRT( ONE + T )*V END IF C V = ER22 T = DLAPY2( AR22, AI22 ) IF ( V.LE.T ) THEN INFO = 3 RETURN END IF T = T/V V = SQRT( ONE - T )*SQRT( ONE + T )*V T = LR*SMLNUM IF ( V.LE.T ) THEN SCALE1 = V/T SCALE = SCALE1*SCALE BR11 = SCALE1*BR11 BR12 = SCALE1*BR12 BR22 = SCALE1*BR22 BI12 = SCALE1*BI12 UR11 = SCALE1*UR11 UR12 = SCALE1*UR12 UI12 = SCALE1*UI12 LR = SCALE1*LR END IF UR22 = LR/V C C Compute the needed elements of the matrices M1 and M2 for the C reduced equation. C B11 = BR11/ER11 T = ER11*ER22 B12R = ( ER11*BR12 - BR11*ER12 )/T B12I = ( ER11*BI12 - BR11*EI12 )/T C BETAR = AR11/ER11 BETAI = AI11/ER11 V = DLAPY2( BETAR, BETAI ) ALPHA = SQRT( ONE - V )*SQRT( ONE + V ) C XR = ( AI11*EI12 - AR11*ER12 )/T + AR12/ER22 XI = ( AR11*EI12 + AI11*ER12 )/T - AI12/ER22 XR = -TWO*BETAI*B12I - B11*XR XI = -TWO*BETAI*B12R - B11*XI V = ONE + ( BETAI - BETAR )*( BETAI + BETAR ) W = -TWO*BETAI*BETAR CALL DLADIV( XR, XI, V, W, YR, YI ) IF ( YR.NE.ZERO .OR. YI.NE.ZERO ) THEN M1R12 = -ALPHA*YR/UR22 M1I12 = ALPHA*YI/UR22 M2R12 = ( YR*BETAR - YI*BETAI )/UR22 M2I12 = -( YI*BETAR + YR*BETAI )/UR22 M2R22 = BR22/ER22/UR22 ELSE M1R12 = ZERO M1I12 = ZERO M2R12 = ZERO M2I12 = ZERO M2R22 = ALPHA END IF END IF C C Transform U back: U := U * Q. C VR12 = UR12*CQ + UR11*SRQ VI12 = UI12*CQ + UR11*SIQ VR22 = UR22*CQ C C Overwrite U with the upper triangular matrix of its C QR-factorization. The elements on the main diagonal are real C and non-negative. C CALL SG03BR( UR11*CQ - UR12*SRQ - UI12*SIQ, UR12*SIQ - UI12*SRQ, $ -UR22*SRQ, UR22*SIQ, CQU, SRQU, SIQU, LR, LI ) U(1,1) = LR U(2,1) = ZERO U(1,2) = CQU*VR12 + SRQU*VR22 UI12 = CQU*VI12 + SIQU*VR22 U(2,2) = CQU*VR22 - SRQU*VR12 - SIQU*VI12 UI22 = SIQU*VR12 - SRQU*VI12 IF ( LI.NE.ZERO ) THEN V = DLAPY2( LR, LI ) CALL DLADIV( V, ZERO, LR, LI, XR, XI ) CQUI = XI*CQU CQU = XR*CQU T = XR*SRQU - XI*SIQU SIQU = XR*SIQU + XI*SRQU SRQU = T C U(1,2) = XR*U(1,2) - XI*UI12 U(1,1) = V END IF C U(2,2) = DLAPY2( U(2,2), UI22 ) C C Transform the matrices M1 and M2 back. C C M1 := QU * M1 * QU**H, C M2 := QB**H * M2 * QU**H. C V = BETAR T = ( CQU*SRQU + CQUI*SIQU )*M1R12 + $ ( CQU*SIQU - CQUI*SRQU )*M1I12 C M1(1,1) = V + T M1(2,2) = V - T M1(1,2) = M1R12*( CQU - CQUI )*( CQU + CQUI ) + $ TWO*( BETAI*( SIQU*CQU + SRQU*CQUI ) - M1I12*CQUI*CQU ) M1(2,1) = SIQU*( M1R12*SIQU - TWO*BETAI*CQU - M1I12*SRQU ) - $ SRQU*( M1R12*SRQU + TWO*BETAI*CQUI + M1I12*SIQU ) C V = M2R12* CQU - M2I12*CQUI - ALPHA*SRQU W = M2R12*CQUI + M2I12*CQU - ALPHA*SIQU M2(1,1) = CQB*( ALPHA* CQU + M2R12*SRQU + M2I12*SIQU ) + $ CQBI*( M2I12*SRQU - M2R12*SIQU - ALPHA*CQUI ) - $ M2R22*( SRQB*SRQU + SIQB*SIQU ) M2(2,1) = ZERO M2(1,2) = CQB*V + CQBI*W - M2R22*( SRQB*CQU - SIQB*CQUI ) M2(2,2) = SRQB*V + SIQB*W + M2R22*( CQB*CQU - CQBI*CQUI ) C C If the transposed equation (op(K)=K**T, K=A,B,E,U) is to be C solved, transpose the matrix U with respect to the C anti-diagonal and the matrices M1, M2 with respect to the diagonal C and the anti-diagonal. C IF ( ISTRNS ) THEN V = U(1,1) U(1,1) = U(2,2) U(2,2) = V V = M1(1,1) M1(1,1) = M1(2,2) M1(2,2) = V V = M2(1,1) M2(1,1) = M2(2,2) M2(2,2) = V END IF U(2,1) = ZERO C RETURN C *** Last line of SG03BX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02UU.f0000644000000000000000000000013215012430707016207 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02UU.f0000644000175000017500000001031215012430707017400 0ustar00lilgelilge00000000000000 SUBROUTINE MB02UU( N, A, LDA, RHS, IPIV, JPIV, SCALE ) 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 control-4.1.2/src/slicot/src/PaxHeaders/MB03XS.f0000644000000000000000000000013215012430707016211 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03XS.f0000644000175000017500000004057015012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE MB03XS( JOBU, N, A, LDA, QG, LDQG, U1, LDU1, U2, LDU2, $ WR, WI, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the eigenvalues and real skew-Hamiltonian Schur form of C a skew-Hamiltonian matrix, C C [ A G ] C W = [ T ], C [ Q A ] C C where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric C matrices. Specifically, an orthogonal symplectic matrix U is C computed so that C C T [ Aout Gout ] C U W U = [ T ] , C [ 0 Aout ] C C where Aout is in Schur canonical form (as returned by the LAPACK C routine DHSEQR). That is, Aout is block upper triangular with C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has C its diagonal elements equal and its off-diagonal elements of C opposite sign. C C Optionally, the matrix U is returned in terms of its first N/2 C rows C C [ U1 U2 ] C U = [ ]. C [ -U2 U1 ] C C ARGUMENTS C C Mode Parameters C C JOBU CHARACTER*1 C Specifies whether matrix U is computed or not, as follows: C = 'N': transformation matrix U is not computed; C = 'U': transformation matrix U is computed. 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 part of this array must C contain the matrix A. C On exit, the leading N-by-N part of this array contains C the matrix Aout in Schur canonical form. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input/output) DOUBLE PRECISION array, dimension C (LDQG,N+1) C On entry, the leading N-by-N+1 part of this array must C contain in columns 1:N the strictly lower triangular part C of the matrix Q and in columns 2:N+1 the strictly upper C triangular part of the matrix G. C On exit, the leading N-by-N+1 part of this array contains C in columns 2:N+1 the strictly upper triangular part of the C skew-symmetric matrix Gout. The part which contained the C matrix Q is set to zero. C Note that the parts containing the diagonal and the first C superdiagonal of this array are not overwritten by zeros C only if JOBU = 'U' or LDWORK >= 2*N*N - N. C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C U1 (output) DOUBLE PRECISION array, dimension (LDU1,N) C On exit, if JOBU = 'U', the leading N-by-N part of this C array contains the matrix U1. C If JOBU = 'N', this array is not referenced. C C LDU1 INTEGER C The leading dimension of the array U1. C LDU1 >= MAX(1,N), if JOBU = 'U'; C LDU1 >= 1, if JOBU = 'N'. C C U2 (output) DOUBLE PRECISION array, dimension (LDU2,N) C On exit, if JOBU = 'U', the leading N-by-N part of this C array contains the matrix U2. C If JOBU = 'N', this array is not referenced. C C LDU2 INTEGER C The leading dimension of the array U2. C LDU2 >= MAX(1,N), if JOBU = 'U'; C LDU2 >= 1, if JOBU = 'N'. C C WR (output) DOUBLE PRECISION array, dimension (N) C WI (output) DOUBLE PRECISION array, dimension (N) C The real and imaginary parts, respectively, of the C eigenvalues of Aout, which are half of the eigenvalues C of W. The eigenvalues are stored in the same order as on C the diagonal of Aout, with WR(i) = Aout(i,i) and, if C Aout(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 C and WI(i+1) = -WI(i). 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 On exit, if INFO = -14, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1,(N+5)*N), if JOBU = 'U'; C LDWORK >= MAX(1,5*N,(N+1)*N), if JOBU = 'N'. 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 > 0: if INFO = i, DHSEQR failed to compute all of the C eigenvalues. Elements 1:ILO-1 and i+1:N of WR C and WI contain those eigenvalues which have been C successfully computed. The matrix A (and QG) has C been partially reduced; namely, A is upper C Hessenberg in the rows and columns ILO through i. C (See DHSEQR for details.) C C METHOD C C First, using the SLICOT Library routine MB04RB, an orthogonal C symplectic matrix UP is computed so that C C T [ AP GP ] C UP W UP = [ T ] C [ 0 AP ] C C is in Paige/Van Loan form. Next, the LAPACK routine DHSEQR is C applied to the matrix AP to compute an orthogonal matrix V so C that Aout = V'*AP*V is in Schur canonical form. C Finally, the transformations C C [ V 0 ] C U = UP * [ ], Gout = V'*G*V, C [ 0 V ] C C using the SLICOT Library routine MB01LD for the latter, are C performed. C C REFERENCES C C [1] Van Loan, C.F. C A symplectic method for approximating all the eigenvalues of C a Hamiltonian matrix. C Linear Algebra and its Applications, 61, pp. 233-251, 1984. C C [2] Kressner, D. C Block algorithms for orthogonal symplectic factorizations. C BIT, 43 (4), pp. 775-790, 2003. C C CONTRIBUTORS C C D. Kressner (Technical Univ. Berlin, Germany) and C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. C C REVISIONS C C V. Sima, Nov. 2011 (SLICOT version of the HAPACK routine DSHES). C V. Sima, Oct. 2012. C C KEYWORDS C C Schur form, eigenvalues, skew-Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBU INTEGER INFO, LDA, LDQG, LDU1, LDU2, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), U1(LDU1,*), $ U2(LDU2,*), WI(*), WR(*) C .. Local Scalars .. LOGICAL COMPU, LQUERY, SCALEW INTEGER I, I1, I2, IERR, ILO, INXT, NN, PBAL, PCS, PDV, $ PDW, PHO, PTAU, WRKMIN, WRKOPT DOUBLE PRECISION BIGNUM, CSCALE, EPS, SMLNUM, WNRM C .. External Function .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, MA02ID EXTERNAL DLAMCH, LSAME, MA02ID C .. External Subroutines .. EXTERNAL DCOPY, DHSEQR, DLABAD, DLACPY, DLASCL, DLASET, $ DSCAL, DSWAP, MB01LD, MB04DI, MB04DS, MB04QS, $ MB04RB, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 COMPU = LSAME( JOBU, 'U' ) C NN = N*N IF ( COMPU ) THEN WRKMIN = MAX( 1, NN + 5*N ) ELSE WRKMIN = MAX( 1, 5*N, NN + N ) END IF WRKOPT = WRKMIN C IF ( .NOT.COMPU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN INFO = -1 ELSE IF ( N.LT.0 ) THEN INFO = -2 ELSE IF ( LDA.LT.MAX( 1,N ) ) THEN INFO = -4 ELSE IF ( LDQG.LT.MAX( 1,N ) ) THEN INFO = -6 ELSE IF ( LDU1.LT.1 .OR. ( COMPU .AND. LDU1.LT.N ) ) THEN INFO = -8 ELSE IF ( LDU2.LT.1 .OR. ( COMPU .AND. LDU2.LT.N ) ) THEN INFO = -10 ELSE LQUERY = LDWORK.EQ.-1 IF ( LDWORK.LT.WRKMIN .AND. .NOT.LQUERY ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = -14 ELSE IF( LQUERY ) THEN IF ( N.EQ.0 ) THEN DWORK(1) = ONE ELSE I = 4*N CALL MB04RB( N, 1, A, LDA, QG, LDQG, DWORK, DWORK, DWORK, $ -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + I ) CALL DHSEQR( 'Schur', 'Initialize', N, 1, N, A, LDA, WR, $ WI, DWORK, N, DWORK, -1, IERR ) IF ( COMPU ) THEN I = I + NN WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + I ) CALL MB04QS( 'N', 'N', 'N', N, N, 1, DWORK, N, QG, $ LDQG, U1, LDU1, U2, LDU2, DWORK, DWORK, $ DWORK, -1, IERR ) ELSE I = NN WRKOPT = MAX( WRKOPT, 2*NN - N ) END IF DWORK(1) = MAX( WRKMIN, WRKOPT, INT( DWORK(1) ) + I ) END IF RETURN END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03XS', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Get machine constants. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM C C Scale W if max element outside range [SMLNUM,BIGNUM]. C WNRM = MA02ID( 'Skew-Hamiltonian', 'Max-Norm', N, A, LDA, QG, $ LDQG, DWORK ) SCALEW = .FALSE. IF ( WNRM.GT.ZERO .AND. WNRM.LT.SMLNUM ) THEN SCALEW = .TRUE. CSCALE = SMLNUM ELSE IF ( WNRM.GT.BIGNUM ) THEN SCALEW = .TRUE. CSCALE = BIGNUM END IF IF( SCALEW ) THEN CALL DLASCL( 'General', 0, 0, WNRM, CSCALE, N, N, A, LDA, $ IERR ) IF ( N.GT.1 ) THEN CALL DLASCL( 'Lower', 0, 0, WNRM, CSCALE, N-1, N-1, QG(2,1), $ LDQG, IERR ) CALL DLASCL( 'Upper', 0, 0, WNRM, CSCALE, N-1, N-1, QG(1,3), $ LDQG, IERR ) END IF END IF C C Permute to make W closer to skew-Hamiltonian Schur form. C Workspace: need N. C PBAL = 1 CALL MB04DS( 'Permute', N, A, LDA, QG, LDQG, ILO, DWORK(PBAL), $ IERR ) C C Reduce to Paige/Van Loan form. C Workspace: need 5*N-1. C PCS = N + PBAL PTAU = 2*N + PCS PDW = N + PTAU CALL MB04RB( N, ILO, A, LDA, QG, LDQG, DWORK(PCS), DWORK(PTAU), $ DWORK(PDW), LDWORK-PDW+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) IF ( COMPU ) THEN C C Copy information about Householder vectors to workspace. C PHO = PDW PDW = PDW + NN CALL DLACPY( 'L', N, N, A, LDA, DWORK(PHO), N ) C C Perform QR iteration, accumulating Schur vectors in U1. C Workspace: need N*N + 5*N; C prefer larger. C CALL DHSEQR( 'Schur', 'Initialize', N, MIN( ILO, N ), N, A, $ LDA, WR, WI, U1, LDU1, DWORK(PDW), LDWORK-PDW+1, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) C C Update G = V'*G*V. C CALL MB01LD( 'Upper', 'Transpose', N, N, ZERO, ONE, QG(1,2), $ LDQG, U1, LDU1, QG(1,2), LDQG, U2, NN, IERR ) C C Apply orthogonal symplectic matrix from PVL reduction to [V;0]. C Workspace: need N*N + 5*N; C prefer larger. C CALL DSCAL( N-1, -ONE, DWORK(PCS+1), 2 ) CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) CALL MB04QS( 'No Transpose', 'No Transpose', 'No Transpose', N, $ N, ILO, DWORK(PHO), N, QG, LDQG, U1, LDU1, U2, $ LDU2, DWORK(PCS), DWORK(PTAU), DWORK(PDW), $ LDWORK-PDW+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) C C Annihilate Q. C IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, QG(2,1), LDQG ) C C Undo balancing. C CALL MB04DI( 'Permute', 'Positive', N, ILO, DWORK(PBAL), N, U1, $ LDU1, U2, LDU2, IERR ) ELSE C C Perform QR iteration, accumulating Schur vectors in DWORK. C Workspace: need N*N + N; C prefer larger. C PDV = 1 PDW = NN + PDV CALL DHSEQR( 'Schur', 'Initialize', N, MIN( ILO, N ), N, A, $ LDA, WR, WI, DWORK(PDV), N, DWORK(PDW), $ LDWORK-PDW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) C C Update G = V'*G*V. C Workspace: need N*N + N; C prefer N*N + N*(N-1). C CALL MB01LD( 'Upper', 'Transpose', N, N, ZERO, ONE, QG(1,2), $ LDQG, DWORK(PDV), N, QG(1,2), LDQG, DWORK(PDW), $ LDWORK-PDW+1, IERR ) WRKOPT = MAX( WRKOPT, 2*NN - N ) C C Annihilate Q. C IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, QG(2,1), LDQG ) END IF C IF ( SCALEW ) THEN C C Undo scaling for the skew-Hamiltonian Schur form. C CALL DLASCL( 'Hessenberg', 0, 0, CSCALE, WNRM, N, N, A, LDA, $ IERR ) IF ( N.GT.1 ) THEN CALL DLASCL( 'Upper', 0, 0, CSCALE, WNRM, N-1, N-1, QG(1,3), $ LDQG, IERR ) END IF CALL DCOPY( N, A, LDA+1, WR, 1 ) C IF ( CSCALE.EQ.SMLNUM ) THEN C C If scaling back towards underflow, adjust WI if an C offdiagonal element of a 2-by-2 block in the Schur form C underflows. C IF( INFO.GT.0 ) THEN I1 = INFO + 1 CALL DLASCL( 'General', 0, 0, CSCALE, WNRM, ILO-1, 1, WI, $ MAX( ILO-1, 1 ), IERR ) ELSE I1 = ILO END IF I2 = N - 1 INXT = I1 - 1 DO 10 I = I1, I2 IF ( I.LT.INXT ) $ GO TO 10 IF ( WI(I).EQ.ZERO ) THEN INXT = I + 1 ELSE IF ( A(I+1,I).EQ.ZERO ) THEN WI(I) = ZERO WI(I+1) = ZERO ELSE IF ( A(I,I+1).EQ.ZERO ) $ THEN WI(I) = ZERO WI(I+1) = ZERO IF ( I.GT.1 ) $ CALL DSWAP( I-1, A(1,I), 1, A(1,I+1), 1 ) IF( N.GT.I+1 ) $ CALL DSWAP( N-I-1, A(I,I+2), LDA, $ A(I+1,I+2), LDA ) A(I,I+1) = A(I+1,I) A(I+1,I ) = ZERO C CALL DSWAP( I-1, QG(1,I+2), 1, QG(1,I+1), 1 ) IF ( N.GT.I+1 ) $ CALL DSWAP( N-I-1, QG(I+1,I+3), LDQG, QG(I,I+3), $ LDQG ) QG(I,I+2) = -QG(I,I+2) IF ( COMPU ) THEN CALL DSWAP( N, U1(1,I), 1, U1(1,I+1), 1 ) CALL DSWAP( N, U2(1,I), 1, U2(1,I+1), 1 ) END IF END IF INXT = I + 2 END IF 10 CONTINUE END IF C C Undo scaling for imaginary parts of the eigenvalues. C CALL DLASCL( 'General', 0, 0, CSCALE, WNRM, N-INFO, 1, $ WI(INFO+1), MAX( N-INFO, 1 ), IERR ) END IF C DWORK(1) = DBLE( WRKOPT ) C RETURN C *** Last line of MB03XS *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09HX.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB09HX.f0000644000175000017500000006013115012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE AB09HX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, $ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1, $ TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN, $ INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for an original C stable state-space representation (A,B,C,D) by using the C stochastic balancing approach in conjunction with the square-root C or the balancing-free square-root Balance & Truncate (B&T) or C Singular Perturbation Approximation (SPA) model reduction methods. C The state dynamics matrix A of the original system is an upper C quasi-triangular matrix in real Schur canonical form and D must be C full row rank. C C For the B&T approach, the matrices of the reduced order system C are computed using the truncation formulas: C C Ar = TI * A * T , Br = TI * B , Cr = C * T . (1) C C For the SPA approach, the matrices of a minimal realization C (Am,Bm,Cm) are computed using the truncation formulas: C C Am = TI * A * T , Bm = TI * B , Cm = C * T . (2) C C Am, Bm, Cm and D serve further for computing the SPA of the given C system. 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 JOB CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root Balance & Truncate method; C = 'F': use the balancing-free square-root C Balance & Truncate method; C = 'S': use the square-root Singular Perturbation C Approximation method; C = 'P': use the balancing-free square-root C Singular Perturbation Approximation method. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e., the order of the 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. M >= P >= 0. C C NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of C the resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. NR is set as follows: C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR C is the desired order on entry and NMIN is the order of a C minimal realization of the given system; NMIN is C determined as the number of Hankel singular values greater C than N*EPS, where EPS is the machine precision C (see LAPACK Library Routine DLAMCH); C if ORDSEL = 'A', NR is equal to the number of Hankel C singular values greater than MAX(TOL1,N*EPS). 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 in a real Schur C canonical form. C On exit, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the C reduced order system. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, it contains the Hankel singular values, C ordered decreasingly, of the phase system. All singular C values are less than or equal to 1. C C T (output) DOUBLE PRECISION array, dimension (LDT,N) C If INFO = 0 and NR > 0, the leading N-by-NR part of this C array contains the right truncation matrix T in (1), for C the B&T approach, or in (2), for the SPA approach. C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,N). C C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) C If INFO = 0 and NR > 0, the leading NR-by-N part of this C array contains the left truncation matrix TI in (1), for C the B&T approach, or in (2), for the SPA approach. C C LDTI INTEGER C The leading dimension of array TI. LDTI >= MAX(1,N). C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value lies in the C interval [0.00001,0.001]. C If TOL1 <= 0 on entry, the used default value is C TOL1 = N*EPS, where EPS is the machine C precision (see LAPACK Library Routine DLAMCH). C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the phase system (see METHOD) corresponding C to the given system. C The recommended value is TOL2 = N*EPS. C This value is used by default if TOL2 <= 0 on entry. C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension (MAX(1,2*N)) C On exit with INFO = 0, IWORK(1) contains the order of the C minimal realization of the system. 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) contains RCOND, the reciprocal C condition number of the U11 matrix from the expression C used to compute the solution X = U21*inv(U11) of the C Riccati equation for spectral factorization. C A small value RCOND indicates possible ill-conditioning C of the respective Riccati equation. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( 2, N*(MAX(N,M,P)+5), C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ). C For optimum performance LDWORK should be larger. C C BWORK LOGICAL array, dimension 2*N C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than the order of a minimal realization of the C given system. In this case, the resulting NR is C set automatically to a value corresponding to the C order of a minimal realization of the system. 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 state matrix A is not stable (if DICO = 'C') C or not convergent (if DICO = 'D'), or it is not in C a real Schur form; C = 2: the reduction of Hamiltonian matrix to real C Schur form failed; C = 3: the reordering of the real Schur form of the C Hamiltonian matrix failed; C = 4: the Hamiltonian matrix has less than N stable C eigenvalues; C = 5: the coefficient matrix U11 in the linear system C X*U11 = U21, used to determine X, is singular to C working precision; C = 6: the feedthrough matrix D has not a full row rank P; C = 7: the computation of Hankel singular values failed. C C METHOD C C Let be the stable linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t), (3) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09HX determines for C the given system (3), the matrices of a reduced NR-rder system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t), (4) C C such that C C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], C C where G and Gr are transfer-function matrices of the systems C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the C infinity-norm of G. C C If JOB = 'B', the square-root stochastic Balance & Truncate C method of [1] is used and the resulting model is balanced. C C If JOB = 'F', the balancing-free square-root version of the C stochastic Balance & Truncate method [1] is used. C C If JOB = 'S', the stochastic balancing method, in conjunction C with the square-root version of the Singular Perturbation C Approximation method [2,3] is used. C C If JOB = 'P', the stochastic balancing method, in conjunction C with the balancing-free square-root version of the Singular C Perturbation Approximation method [2,3] is used. C C By setting TOL1 = TOL2, the routine can be also used to compute C Balance & Truncate approximations. C C REFERENCES C C [1] Varga A. and Fasol K.H. C A new square-root balancing-free stochastic truncation C model reduction algorithm. C Proc. of 12th IFAC World Congress, Sydney, 1993. C C [2] Liu Y. and Anderson B.D.O. C Singular Perturbation Approximation of balanced systems. C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. C C [3] Varga A. C Balancing-free square-root algorithm for computing singular C perturbation approximations. C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, C Vol. 2, pp. 1062-1065. C C NUMERICAL ASPECTS C C The implemented method relies on accuracy enhancing square-root C or balancing-free square-root methods. The effectiveness of the C accuracy enhancing technique depends on the accuracy of the C solution of a Riccati equation. Ill-conditioned Riccati solution C typically results when D is nearly rank deficient. C 3 C The algorithm requires about 100N floating point operations. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. C D. Sima, University of Bucharest, May 2000. C V. Sima, Research Institute for Informatics, Bucharest, May 2000. C Partly based on the RASP routine SRBFS1, by A. Varga, 1992. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. C C KEYWORDS C C Balance and truncate, minimal state-space representation, C model reduction, multivariable system, C singular perturbation approximation, state-space model, C stochastic balancing. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO, ZERO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOB, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, $ LDWORK, M, N, NR, P DOUBLE PRECISION TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) LOGICAL BWORK(*) C .. Local Scalars .. LOGICAL BAL, BTA, DISCR, FIXORD, SPA INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, LW, $ NMINR, NR1, NS, WRKOPT DOUBLE PRECISION ATOL, RCOND, RICOND, SCALEC, SCALEO, TEMP, $ TOLDEF C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB04MD, AB09DD, AB09HY, DGEMM, DGEMV, DGEQRF, $ DGETRF, DGETRS, DLACPY, DORGQR, DSCAL, DTRMM, $ DTRMV, MA02AD, MB03UD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) FIXORD = LSAME( ORDSEL, 'F' ) LW = MAX( 2, N*(MAX( N, M, P )+5), $ 2*N*P+MAX( P*(M+2), 10*N*(N+1) ) ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN INFO = -2 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 .OR. P.GT.M ) THEN INFO = -6 ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN INFO = -20 ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN INFO = -22 ELSE IF( LDWORK.LT.LW ) THEN INFO = -25 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09HX', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 IWORK(1) = 0 DWORK(1) = TWO DWORK(2) = ONE RETURN END IF C C For discrete-time case, apply the discrete-to-continuous bilinear C transformation. C IF( DISCR ) THEN C C Real workspace: need N, prefer larger; C Integer workspace: need N. C CALL AB04MD( 'Discrete', N, M, P, ONE, ONE, A, LDA, B, LDB, $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF WRKOPT = MAX( N, INT( DWORK(1) ) ) ELSE WRKOPT = 0 END IF C C Compute in TI and T the Cholesky factors Su and Ru of the C controllability and observability Grammians, respectively. C Real workspace: need MAX( 2, N*(MAX(N,M,P)+5), C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ); C prefer larger. C Integer workspace: need 2*N. C CALL AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ SCALEC, SCALEO, TI, LDTI, T, LDT, IWORK, $ DWORK, LDWORK, BWORK, INFO ) IF( INFO.NE.0) $ RETURN WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) RICOND = DWORK(2) C C Save Su in V. C KU = 1 KV = KU + N*N KW = KV + N*N CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) C | x x | C Compute Ru*Su in the form | 0 x | in TI. C DO 10 J = 1, N CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, $ TI(1,J), 1 ) 10 CONTINUE C C Compute the singular value decomposition Ru*Su = V*S*UT C of the upper triangular matrix Ru*Su, with UT in TI and V in U. C C Workspace: need 2*N*N + 5*N; C prefer larger. C CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 7 RETURN ENDIF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Scale the singular values. C CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) C C Partition S, U and V conformally as: C C S = diag(S1,S2,S3), U = [U1,U2,U3] (U' in TI) and V = [V1,V2,V3] C (in U). C C Compute the order NR of reduced system, as the order of S1. C TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) ATOL = TOLDEF IF( FIXORD ) THEN IF( NR.GT.0 ) THEN IF( HSV(NR).LE.ATOL ) THEN NR = 0 IWARN = 1 FIXORD = .FALSE. ENDIF ENDIF ELSE ATOL = MAX( TOL1, ATOL ) NR = 0 ENDIF IF( .NOT.FIXORD ) THEN DO 20 J = 1, N IF( HSV(J).LE.ATOL ) GO TO 30 NR = NR + 1 20 CONTINUE 30 CONTINUE ENDIF C C Compute the order of minimal realization as the order of [S1 S2]. C NR1 = NR + 1 NMINR = NR IF( NR.LT.N ) THEN IF( SPA ) ATOL = MAX( TOL2, TOLDEF ) DO 40 J = NR1, N IF( HSV(J).LE.ATOL ) GO TO 50 NMINR = NMINR + 1 40 CONTINUE 50 CONTINUE END IF C C Finish if the order is zero. C IF( NR.EQ.0 ) THEN IF( SPA ) THEN CALL AB09DD( 'Continuous', N, M, P, NR, A, LDA, B, LDB, $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) IWORK(1) = NMINR ELSE IWORK(1) = 0 END IF DWORK(1) = WRKOPT DWORK(2) = RICOND RETURN END IF C C Compute NS, the order of S2. C Note: For BTA, NS is always zero, because NMINR = NR. C NS = NMINR - NR C C Compute the truncation matrices. C C Compute TI' = | TI1' TI2' | = Ru'*| V1 V2 | in U. C CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NMINR, $ ONE, T, LDT, DWORK(KU), N ) C C Compute T = | T1 T2 | = Su*| U1 U2 | . C CALL MA02AD( 'Full', NMINR, N, TI, LDTI, T, LDT ) CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, $ NMINR, ONE, DWORK(KV), N, T, LDT ) KTAU = KV C IF( BAL ) THEN IJ = KU C C Square-Root B&T/SPA method. C C Compute the truncation matrices for balancing C -1/2 -1/2 C T1*S1 and TI1'*S1 . C DO 70 J = 1, NR TEMP = ONE/SQRT( HSV(J) ) CALL DSCAL( N, TEMP, T(1,J), 1 ) CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) IJ = IJ + N 70 CONTINUE ELSE C C Balancing-Free B&T/SPA method. C C Compute orthogonal bases for the images of matrices T1 and C TI1'. C C Workspace: need N*MAX(N,M,P) + 2*NR; C prefer N*MAX(N,M,P) + NR*(NB+1) C (NB determined by ILAENV for DGEQRF). C KW = KTAU + NR LDW = LDWORK - KW + 1 CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, $ IERR ) CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), $ LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) ENDIF IF( NS.GT.0 ) THEN C C Compute orthogonal bases for the images of matrices T2 and C TI2'. C C Workspace: need N*MAX(N,M,P) + 2*NS; C prefer N*MAX(N,M,P) + NS*(NB+1) C (NB determined by ILAENV for DGEQRF). KW = KTAU + NS LDW = LDWORK - KW + 1 CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, $ IERR ) CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), $ LDW, IERR ) CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), $ LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), $ DWORK(KW), LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) ENDIF C C Transpose TI' in TI. C CALL MA02AD( 'Full', N, NMINR, DWORK(KU), N, TI, LDTI ) C IF( .NOT.BAL ) THEN C -1 C Compute (TI1*T1) *TI1 in TI. C CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, $ LDTI, T, LDT, ZERO, DWORK(KU), N ) CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, $ LDTI, IERR ) C IF( NS.GT.0 ) THEN C -1 C Compute (TI2*T2) *TI2 in TI2. C CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), $ N ) CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, $ TI(NR1,1), LDTI, IERR ) END IF END IF C C Compute TI*A*T (A is in RSF). C IJ = KU DO 80 J = 1, N K = MIN( J+1, N ) CALL DGEMV( 'NoTranspose', NMINR, K, ONE, TI, LDTI, A(1,J), 1, $ ZERO, DWORK(IJ), 1 ) IJ = IJ + N 80 CONTINUE CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, NMINR, N, ONE, $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) C C Compute TI*B and C*T. C CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, M, N, ONE, TI, $ LDTI, DWORK(KU), N, ZERO, B, LDB ) C CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NMINR, N, ONE, $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) C C Compute the singular perturbation approximation if possible. C Note that IERR = 1 on exit from AB09DD cannot appear here. C C Workspace: need real 4*(NMINR-NR); C need integer 2*(NMINR-NR). C CALL AB09DD( 'Continuous', NMINR, M, P, NR, A, LDA, B, LDB, $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) C C For discrete-time case, apply the continuous-to-discrete C bilinear transformation. C IF( DISCR ) THEN CALL AB04MD( 'Continuous', NR, M, P, ONE, ONE, A, LDA, B, LDB, $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, IERR ) C WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF IWORK(1) = NMINR DWORK(1) = WRKOPT DWORK(2) = RICOND C RETURN C *** Last line of AB09HX *** END control-4.1.2/src/slicot/src/PaxHeaders/TB05AD.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB05AD.f0000644000175000017500000004273415012430707017362 0ustar00lilgelilge00000000000000 SUBROUTINE TB05AD( BALEIG, INITA, N, M, P, FREQ, A, LDA, B, LDB, $ C, LDC, RCOND, G, LDG, EVRE, EVIM, HINVB, $ LDHINV, IWORK, DWORK, LDWORK, ZWORK, LZWORK, $ INFO ) C C PURPOSE C C To find the complex frequency response matrix (transfer matrix) C G(freq) of the state-space representation (A,B,C) given by C -1 C G(freq) = C * ((freq*I - A) ) * B C C where A, B and C are real N-by-N, N-by-M and P-by-N matrices C respectively and freq is a complex scalar. C C ARGUMENTS C C Mode Parameters C C BALEIG CHARACTER*1 C Determines whether the user wishes to balance matrix A C and/or compute its eigenvalues and/or estimate the C condition number of the problem as follows: C = 'N': The matrix A should not be balanced and neither C the eigenvalues of A nor the condition number C estimate of the problem are to be calculated; C = 'C': The matrix A should not be balanced and only an C estimate of the condition number of the problem C is to be calculated; C = 'B' or 'E' and INITA = 'G': The matrix A is to be C balanced and its eigenvalues calculated; C = 'A' and INITA = 'G': The matrix A is to be balanced, C and its eigenvalues and an estimate of the C condition number of the problem are to be C calculated. C C INITA CHARACTER*1 C Specifies whether or not the matrix A is already in upper C Hessenberg form as follows: C = 'G': The matrix A is a general matrix; C = 'H': The matrix A is in upper Hessenberg form and C neither balancing nor the eigenvalues of A are C required. C INITA must be set to 'G' for the first call to the C routine, unless the matrix A is already in upper C Hessenberg form and neither balancing nor the eigenvalues C of A are required. Thereafter, it must be set to 'H' for C all subsequent calls. C C Input/Output Parameters C C N (input) INTEGER C The number of states, i.e. the order of the state C transition matrix A. N >= 0. C C M (input) INTEGER C The number of inputs, i.e. the number of columns in the C matrix B. M >= 0. C C P (input) INTEGER C The number of outputs, i.e. the number of rows in the C matrix C. P >= 0. C C FREQ (input) COMPLEX*16 C The frequency freq at which the frequency response matrix C (transfer matrix) is to be evaluated. 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 transition matrix A. C If INITA = 'G', then, on exit, the leading N-by-N part of C this array contains an upper Hessenberg matrix similar to C (via an orthogonal matrix consisting of a sequence of C Householder transformations) the original state transition C matrix A. 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 B. C If INITA = 'G', then, on exit, the leading N-by-M part of C this array contains the product of the transpose of the C orthogonal transformation matrix used to reduce A to upper C Hessenberg form and the original input/state matrix B. 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 C. C If INITA = 'G', then, on exit, the leading P-by-N part of C this array contains the product of the original output/ C state matrix C and the orthogonal transformation matrix C used to reduce A to upper Hessenberg form. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C RCOND (output) DOUBLE PRECISION C If BALEIG = 'C' or BALEIG = 'A', then RCOND contains an C estimate of the reciprocal of the condition number of C matrix H with respect to inversion (see METHOD). C C G (output) COMPLEX*16 array, dimension (LDG,M) C The leading P-by-M part of this array contains the C frequency response matrix G(freq). C C LDG INTEGER C The leading dimension of array G. LDG >= MAX(1,P). C C EVRE, (output) DOUBLE PRECISION arrays, dimension (N) C EVIM If INITA = 'G' and BALEIG = 'B' or 'E' or BALEIG = 'A', C then these arrays contain the real and imaginary parts, C respectively, of the eigenvalues of the matrix A. C Otherwise, these arrays are not referenced. C C HINVB (output) COMPLEX*16 array, dimension (LDHINV,M) C The leading N-by-M part of this array contains the C -1 C product H B. C C LDHINV INTEGER C The leading dimension of array HINVB. LDHINV >= MAX(1,N). 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) returns the optimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1, N - 1 + MAX(N,M,P)), C if INITA = 'G' and BALEIG = 'N', or 'B', or 'E'; C LDWORK >= MAX(1, N + MAX(N,M-1,P-1)), C if INITA = 'G' and BALEIG = 'C', or 'A'; C LDWORK >= MAX(1, 2*N), C if INITA = 'H' and BALEIG = 'C', or 'A'; C LDWORK >= 1, otherwise. C For optimum performance when INITA = 'G' LDWORK should be C larger. C C ZWORK COMPLEX*16 array, dimension (LZWORK) C C LZWORK INTEGER C The length of the array ZWORK. C LZWORK >= MAX(1,N*N+2*N), if BALEIG = 'C', or 'A'; C LZWORK >= MAX(1,N*N), otherwise. 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 more than 30*N iterations are required to C isolate all the eigenvalues of the matrix A; the C computations are continued; C = 2: if either FREQ is too near to an eigenvalue of the C matrix A, or RCOND is less than EPS, where EPS is C the machine precision (see LAPACK Library routine C DLAMCH). C C METHOD C C The matrix A is first balanced (if BALEIG = 'B' or 'E', or C BALEIG = 'A') and then reduced to upper Hessenberg form; the same C transformations are applied to the matrix B and the matrix C. C The complex Hessenberg matrix H = (freq*I - A) is then used C -1 C to solve for C * H * B. C C Depending on the input values of parameters BALEIG and INITA, C the eigenvalues of matrix A and the condition number of C matrix H with respect to inversion are also calculated. C C REFERENCES C C [1] Laub, A.J. C Efficient Calculation of Frequency Response Matrices from C State-Space Models. C ACM TOMS, 12, pp. 26-33, 1986. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TB01FD by A.J.Laub, University of C Southern California, Los Angeles, CA 90089, United States of C America, June 1982. C C REVISIONS C C V. Sima, February 22, 1998 (changed the name of TB01RD). C V. Sima, February 12, 1999, August 7, 2003. C A. Markovski, Technical University of Sofia, September 30, 2003. C V. Sima, October 1, 2003. C C KEYWORDS C C Frequency response, Hessenberg form, matrix algebra, input output C description, multivariable system, orthogonal transformation, C similarity transformation, state-space representation, transfer C matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) ) C .. Scalar Arguments .. CHARACTER BALEIG, INITA INTEGER INFO, LDA, LDB, LDC, LDG, LDHINV, LDWORK, $ LZWORK, M, N, P DOUBLE PRECISION RCOND COMPLEX*16 FREQ C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), EVIM(*), $ EVRE(*) COMPLEX*16 ZWORK(*), G(LDG,*), HINVB(LDHINV,*) C .. Local Scalars .. CHARACTER BALANC LOGICAL LBALBA, LBALEA, LBALEB, LBALEC, LINITA INTEGER I, IGH, IJ, ITAU, J, JJ, JP, JWORK, K, LOW, $ WRKOPT DOUBLE PRECISION HNORM, T C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DASUM, DLAMCH EXTERNAL DASUM, DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DGEBAL, DGEHRD, DHSEQR, DORMHR, DSCAL, DSWAP, $ MB02RZ, MB02SZ, MB02TZ, XERBLA, ZLASET C .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, INT, MAX, MIN C .. Executable Statements .. C INFO = 0 LBALEC = LSAME( BALEIG, 'C' ) LBALEB = LSAME( BALEIG, 'B' ) .OR. LSAME( BALEIG, 'E' ) LBALEA = LSAME( BALEIG, 'A' ) LBALBA = LBALEB.OR.LBALEA LINITA = LSAME( INITA, 'G' ) C C Test the input scalar arguments. C IF( .NOT.LBALEC .AND. .NOT.LBALBA .AND. $ .NOT.LSAME( BALEIG, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LINITA .AND. .NOT.LSAME( INITA, 'H' ) ) 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 = -8 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -12 ELSE IF( LDG.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDHINV.LT.MAX( 1, N ) ) THEN INFO = -19 ELSE IF( ( LINITA .AND. .NOT.LBALEC .AND. .NOT.LBALEA .AND. $ LDWORK.LT.N - 1 + MAX( N, M, P ) ) .OR. $ ( LINITA .AND. ( LBALEC .OR. LBALEA ) .AND. $ LDWORK.LT.N + MAX( N, M-1, P-1 ) ) .OR. $ ( .NOT.LINITA .AND. ( LBALEC .OR. LBALEA ) .AND. $ LDWORK.LT.2*N ) .OR. ( LDWORK.LT.1 ) ) THEN INFO = -22 ELSE IF( ( ( LBALEC .OR. LBALEA ) .AND. LZWORK.LT.N*( N + 2 ) ) $ .OR. ( LZWORK.LT.MAX( 1, N*N ) ) ) THEN INFO = -24 END IF C IF ( INFO.NE.0 ) THEN C C Error return C CALL XERBLA( 'TB05AD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN IF ( MIN( M, P ).GT.0 ) $ CALL ZLASET( 'Full', P, M, CZERO, CZERO, G, LDG ) RCOND = ONE DWORK(1) = ONE RETURN 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 NB refers to the optimal block size for the immediately C following subroutine, as returned by ILAENV.) C WRKOPT = 1 C IF ( LINITA ) THEN BALANC = 'N' IF ( LBALBA ) BALANC = 'B' C C Workspace: need N. C CALL DGEBAL( BALANC, N, A, LDA, LOW, IGH, DWORK, INFO ) IF ( LBALBA ) THEN C C Adjust B and C matrices based on information in the C vector DWORK which describes the balancing of A and is C defined in the subroutine DGEBAL. C DO 10 J = 1, N JJ = J IF ( JJ.LT.LOW .OR. JJ.GT.IGH ) THEN IF ( JJ.LT.LOW ) JJ = LOW - JJ JP = DWORK(JJ) IF ( JP.NE.JJ ) THEN C C Permute rows of B. C IF ( M.GT.0 ) $ CALL DSWAP( M, B(JJ,1), LDB, B(JP,1), LDB ) C C Permute columns of C. C IF ( P.GT.0 ) $ CALL DSWAP( P, C(1,JJ), 1, C(1,JP), 1 ) END IF END IF 10 CONTINUE C IF ( IGH.NE.LOW ) THEN C DO 20 J = LOW, IGH T = DWORK(J) C C Scale rows of permuted B. C IF ( M.GT.0 ) $ CALL DSCAL( M, ONE/T, B(J,1), LDB ) C C Scale columns of permuted C. C IF ( P.GT.0 ) $ CALL DSCAL( P, T, C(1,J), 1 ) 20 CONTINUE C END IF END IF C C Reduce A to Hessenberg form by orthogonal similarities and C accumulate the orthogonal transformations into B and C. C Workspace: need 2*N - 1; prefer N - 1 + N*NB. C ITAU = 1 JWORK = ITAU + N - 1 CALL DGEHRD( N, LOW, IGH, A, LDA, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Workspace: need N - 1 + M; prefer N - 1 + M*NB. C CALL DORMHR( 'Left', 'Transpose', N, M, LOW, IGH, A, LDA, $ DWORK(ITAU), B, LDB, DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Workspace: need N - 1 + P; prefer N - 1 + P*NB. C CALL DORMHR( 'Right', 'No transpose', P, N, LOW, IGH, A, LDA, $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) IF ( LBALBA ) THEN C C Temporarily store Hessenberg form of A in array ZWORK. C IJ = 0 DO 40 J = 1, N C DO 30 I = 1, N IJ = IJ + 1 ZWORK(IJ) = DCMPLX( A(I,J), ZERO ) 30 CONTINUE C 40 CONTINUE C C Compute the eigenvalues of A if that option is requested. C Workspace: need N. C CALL DHSEQR( 'Eigenvalues', 'No Schur', N, LOW, IGH, A, LDA, $ EVRE, EVIM, DWORK, 1, DWORK, LDWORK, INFO ) C C Restore upper Hessenberg form of A. C IJ = 0 DO 60 J = 1, N C DO 50 I = 1, N IJ = IJ + 1 A(I,J) = DBLE( ZWORK(IJ) ) 50 CONTINUE C 60 CONTINUE C IF ( INFO.GT.0 ) THEN C C DHSEQR could not evaluate the eigenvalues of A. C INFO = 1 END IF END IF END IF C C Update H := (FREQ * I) - A with appropriate value of FREQ. C IJ = 0 JJ = 1 DO 80 J = 1, N C DO 70 I = 1, N IJ = IJ + 1 ZWORK(IJ) = -DCMPLX( A(I,J), ZERO ) 70 CONTINUE C ZWORK(JJ) = FREQ + ZWORK(JJ) JJ = JJ + N + 1 80 CONTINUE C IF ( LBALEC .OR. LBALEA ) THEN C C Efficiently compute the 1-norm of the matrix for condition C estimation. C HNORM = ZERO JJ = 1 C DO 90 J = 1, N T = ABS( ZWORK(JJ) ) + DASUM( J-1, A(1,J), 1 ) IF ( J.LT.N ) T = T + ABS( A(J+1,J) ) HNORM = MAX( HNORM, T ) JJ = JJ + N + 1 90 CONTINUE C END IF C C Factor the complex Hessenberg matrix. C CALL MB02SZ( N, ZWORK, N, IWORK, INFO ) IF ( INFO.NE.0 ) INFO = 2 C IF ( LBALEC .OR. LBALEA ) THEN C C Estimate the condition of the matrix. C C Workspace: need 2*N. C CALL MB02TZ( '1-norm', N, HNORM, ZWORK, N, IWORK, RCOND, DWORK, $ ZWORK(N*N+1), INFO ) WRKOPT = MAX( WRKOPT, 2*N ) IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) INFO = 2 END IF C IF ( INFO.NE.0 ) THEN C C Error return: Linear system is numerically or exactly singular. C RETURN END IF C C Compute (H-INVERSE)*B. C DO 110 J = 1, M C DO 100 I = 1, N HINVB(I,J) = DCMPLX( B(I,J), ZERO ) 100 CONTINUE C 110 CONTINUE C CALL MB02RZ( 'No transpose', N, M, ZWORK, N, IWORK, HINVB, LDHINV, $ INFO ) C C Compute C*(H-INVERSE)*B. C DO 150 J = 1, M C DO 120 I = 1, P G(I,J) = CZERO 120 CONTINUE C DO 140 K = 1, N C DO 130 I = 1, P G(I,J) = G(I,J) + DCMPLX( C(I,K), ZERO )*HINVB(K,J) 130 CONTINUE C 140 CONTINUE C 150 CONTINUE C C G now contains the desired frequency response matrix. C Set the optimal workspace. C DWORK(1) = WRKOPT C RETURN C *** Last line of TB05AD *** END control-4.1.2/src/slicot/src/PaxHeaders/UD01BD.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/UD01BD.f0000644000175000017500000000645715012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) C C PURPOSE C C To read the coefficients of a matrix polynomial C dp-1 dp C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . C C ARGUMENTS C C Input/Output Parameters C C MP (input) INTEGER C The number of rows of the matrix polynomial P(s). C MP >= 1. C C NP (input) INTEGER C The number of columns of the matrix polynomial P(s). C NP >= 1. C C DP (input) INTEGER C The degree of the matrix polynomial P(s). DP >= 0. C C NIN (input) INTEGER C The input channel from which the elements of P(s) are C read. NIN >= 0. C C P (output) DOUBLE PRECISION array, dimension C (LDP1,LDP2,DP+1) C The leading MP-by-NP-by-(DP+1) part of this array contains C the coefficients of the matrix polynomial P(s). C Specifically, P(i,j,k) contains the coefficient of C s**(k-1) of the polynomial which is the (i,j)-th element C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and C k = 1,2,...,DP+1. C C LDP1 INTEGER C The leading dimension of array P. LDP1 >= MP. C C LDP2 INTEGER C The second dimension of array P. LDP2 >= NP. 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 coefficients P(i), i = 0, ..., DP, which are MP-by-NP C matrices, are read from the input file NIN row by row. Each P(i) C must be preceded by a text line. This text line can be used to C indicate the coefficient matrices. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. C Based on routine RDMAPO by A.J. Geurts, Eindhoven University of C Technology, Holland. C C REVISIONS C C - C C ****************************************************************** C C .. Scalar Arguments .. INTEGER DP, INFO, LDP1, LDP2, MP, NP, NIN C .. Array Arguments .. DOUBLE PRECISION P(LDP1,LDP2,*) C .. Local Scalars .. INTEGER I, J, K C .. External Subroutines .. EXTERNAL XERBLA C C .. Executable Statements .. C INFO = 0 C C Check the input scalar arguments. C IF( MP.LT.1 ) THEN INFO = -1 ELSE IF( NP.LT.1 ) THEN INFO = -2 ELSE IF( DP.LT.0 ) THEN INFO = -3 ELSE IF( NIN.LT.0 ) THEN INFO = -4 ELSE IF( LDP1.LT.MP ) THEN INFO = -6 ELSE IF( LDP2.LT.NP ) THEN INFO = -7 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'UD01BD', -INFO ) RETURN END IF C C Skip the text line preceding P(i) and read P(i), i = 0, ..., DP, C row after row. C DO 20 K = 1, DP + 1 READ ( NIN, FMT = '()' ) C DO 10 I = 1, MP READ ( NIN, FMT = * ) ( P(I,J,K), J = 1, NP ) 10 CONTINUE C 20 CONTINUE C RETURN C *** Last line of UD01BD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01HD.f0000644000000000000000000000013215012430707016164 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01HD.f0000644000175000017500000004641015012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE TG01HD( JOBCON, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE, $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT, NIUCON, $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) C C PURPOSE C C To compute orthogonal transformation matrices Q and Z which C reduce the N-th order descriptor system (A-lambda*E,B,C) C to the form C C ( Ac * ) ( Ec * ) ( Bc ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) , Q'*B = ( ) , C ( 0 Anc ) ( 0 Enc ) ( 0 ) C C C*Z = ( Cc Cnc ) , C C where the NCONT-th order descriptor system (Ac-lambda*Ec,Bc,Cc) C is a finite and/or infinite controllable. The pencil C Anc - lambda*Enc is regular of order N-NCONT and contains the C uncontrollable finite and/or infinite eigenvalues of the pencil C A-lambda*E. C C For JOBCON = 'C' or 'I', the pencil ( Bc Ec-lambda*Ac ) has full C row rank NCONT for all finite lambda and is in a staircase form C with C _ _ _ _ C ( E1,0 E1,1 ... E1,k-1 E1,k ) C ( _ _ _ ) C ( Bc Ec ) = ( 0 E2,1 ... E2,k-1 E2,k ) , (1) C ( ... _ _ ) C ( 0 0 ... Ek,k-1 Ek,k ) C C _ _ _ C ( A1,1 ... A1,k-1 A1,k ) C ( _ _ ) C Ac = ( 0 ... A2,k-1 A2,k ) , (2) C ( ... _ ) C ( 0 ... 0 Ak,k ) C _ C where Ei,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix C _ C (with rtau(0) = M) and Ai,i is an rtau(i)-by-rtau(i) C upper triangular matrix. C C For JOBCON = 'F', the pencil ( Bc Ac-lambda*Ec ) has full C row rank NCONT for all finite lambda and is in a staircase form C with C _ _ _ _ C ( A1,0 A1,1 ... A1,k-1 A1,k ) C ( _ _ _ ) C ( Bc Ac ) = ( 0 A2,1 ... A2,k-1 A2,k ) , (3) C ( ... _ _ ) C ( 0 0 ... Ak,k-1 Ak,k ) C C _ _ _ C ( E1,1 ... E1,k-1 E1,k ) C ( _ _ ) C Ec = ( 0 ... E2,k-1 E2,k ) , (4) C ( ... _ ) C ( 0 ... 0 Ek,k ) C _ C where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix C _ C (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i) C upper triangular matrix. C C For JOBCON = 'C', the (N-NCONT)-by-(N-NCONT) regular pencil C Anc - lambda*Enc has the form C C ( Ainc - lambda*Einc * ) C Anc - lambda*Enc = ( ) , C ( 0 Afnc - lambda*Efnc ) C C where: C 1) the NIUCON-by-NIUCON regular pencil Ainc - lambda*Einc, C with Ainc upper triangular and nonsingular, contains the C uncontrollable infinite eigenvalues of A - lambda*E; C 2) the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) regular pencil C Afnc - lambda*Efnc, with Efnc upper triangular and C nonsingular, contains the uncontrollable finite C eigenvalues of A - lambda*E. C C Note: The significance of the two diagonal blocks can be C interchanged by calling the routine with the C arguments A and E interchanged. In this case, C Ainc - lambda*Einc contains the uncontrollable zero C eigenvalues of A - lambda*E, while Afnc - lambda*Efnc C contains the uncontrollable nonzero finite and infinite C eigenvalues of A - lambda*E. C C For JOBCON = 'F', the pencil Anc - lambda*Enc has the form C C Anc - lambda*Enc = Afnc - lambda*Efnc , C C where the regular pencil Afnc - lambda*Efnc, with Efnc C upper triangular and nonsingular, contains the uncontrollable C finite eigenvalues of A - lambda*E. C C For JOBCON = 'I', the pencil Anc - lambda*Enc has the form C C Anc - lambda*Enc = Ainc - lambda*Einc , C C where the regular pencil Ainc - lambda*Einc, with Ainc C upper triangular and nonsingular, contains the uncontrollable C nonzero finite and infinite eigenvalues of A - lambda*E. C C The left and/or right orthogonal transformations Q and Z C performed to reduce the system matrices can be optionally C accumulated. C C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has C the same transfer-function matrix as the original system C (A-lambda*E,B,C). C C ARGUMENTS C C Mode Parameters C C JOBCON CHARACTER*1 C = 'C': separate both finite and infinite uncontrollable C eigenvalues; C = 'F': separate only finite uncontrollable eigenvalues: C = 'I': separate only nonzero finite and infinite C uncontrollable eigenvalues. C C COMPQ CHARACTER*1 C = 'N': do not compute Q; C = 'I': Q is initialized to the unit matrix, and the C orthogonal matrix Q is returned; C = 'U': Q must contain an orthogonal matrix Q1 on entry, C and the product Q1*Q is returned. C C COMPZ CHARACTER*1 C = 'N': do not compute Z; C = 'I': Z is initialized to the unit matrix, and the C orthogonal matrix Z is returned; C = 'U': Z must contain an orthogonal matrix Z1 on entry, C and the product Z1*Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the descriptor state vector; also the C order of square matrices A and E, the number of rows of C matrix B, and the number of columns of matrix C. N >= 0. C C M (input) INTEGER C The dimension of descriptor system input vector; also the C number of columns of matrix B. M >= 0. C C P (input) INTEGER C The dimension of descriptor system output vector; also the C number of rows of matrix C. 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 N-by-N state matrix A. C On exit, the leading N-by-N part of this array contains C the transformed state matrix Q'*A*Z, C C ( Ac * ) C Q'*A*Z = ( ) , C ( 0 Anc ) C C where Ac is NCONT-by-NCONT and Anc is C (N-NCONT)-by-(N-NCONT). C If JOBCON = 'F', the matrix ( Bc Ac ) is in the C controllability staircase form (3). C If JOBCON = 'C' or 'I', the submatrix Ac is upper C triangular. C If JOBCON = 'C', the Anc matrix has the form C C ( Ainc * ) C Anc = ( ) , C ( 0 Afnc ) C C where the NIUCON-by-NIUCON matrix Ainc is nonsingular and C upper triangular. C If JOBCON = 'I', Anc is nonsingular and upper triangular. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the N-by-N descriptor matrix E. C On exit, the leading N-by-N part of this array contains C the transformed descriptor matrix Q'*E*Z, C C ( Ec * ) C Q'*E*Z = ( ) , C ( 0 Enc ) C C where Ec is NCONT-by-NCONT and Enc is C (N-NCONT)-by-(N-NCONT). C If JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the C controllability staircase form (1). C If JOBCON = 'F', the submatrix Ec is upper triangular. C If JOBCON = 'C', the Enc matrix has the form C C ( Einc * ) C Enc = ( ) , C ( 0 Efnc ) C C where the NIUCON-by-NIUCON matrix Einc is nilpotent C and the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) matrix Efnc C is nonsingular and upper triangular. C If JOBCON = 'F', Enc is nonsingular and upper triangular. C C LDE INTEGER C The leading dimension of array E. LDE >= 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 N-by-M input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix C C ( Bc ) C Q'*B = ( ) , C ( 0 ) C C where Bc is NCONT-by-M. C For JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the C controllability staircase form (1). C For JOBCON = 'F', the matrix ( Bc Ac ) is in the C controllability staircase form (3). 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Z. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C If COMPQ = 'N': Q is not referenced. C If COMPQ = 'I': on entry, Q need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Q, C where Q' is the product of transformations C which are applied to A, E, and B on C the left. C If COMPQ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix C Qc; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Qc*Q. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C If COMPZ = 'N': Z is not referenced. C If COMPZ = 'I': on entry, Z need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Z, C which is the product of transformations C applied to A, E, and C on the right. C If COMPZ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix C Zc; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Zc*Z. C C LDZ INTEGER C The leading dimension of array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. C C NCONT (output) INTEGER C The order of the reduced matrices Ac and Ec, and the C number of rows of reduced matrix Bc; also the order of C the controllable part of the pair (A-lambda*E,B). C C NIUCON (output) INTEGER C For JOBCON = 'C', the order of the reduced matrices C Ainc and Einc; also the number of uncontrollable C infinite eigenvalues of the pencil A - lambda*E. C For JOBCON = 'F' or 'I', NIUCON has no significance C and is set to zero. C C NRBLCK (output) INTEGER C For JOBCON = 'C' or 'I', the number k, of full row rank C _ C blocks Ei,i in the staircase form of the pencil C (Bc Ec-lambda*Ac) (see (1) and (2)). C For JOBCON = 'F', the number k, of full row rank blocks C _ C Ai,i in the staircase form of the pencil (Bc Ac-lambda*Ec) C (see (3) and (4)). C C RTAU (output) INTEGER array, dimension (N) C RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of C _ _ C the full row rank block Ei,i-1 or Ai,i-1 in the staircase C form (1) or (3) for JOBCON = 'C' or 'I', or C for JOBCON = 'F', respectively. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determinations when C transforming (A-lambda*E, B). If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C reciprocal condition numbers in rank determinations; a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*N*EPS, is used instead, where EPS C is the machine precision (see LAPACK Library routine C DLAMCH). TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (M) C C DWORK DOUBLE PRECISION array, dimension (MAX(N,2*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 subroutine is based on the reduction algorithms of [1]. C C REFERENCES C C [1] A. Varga C Computation of Irreducible Generalized State-Space C Realizations. C Kybernetika, vol. 26, pp. 89-106, 1990. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N**3 ) floating point operations. C C FURTHER COMMENTS C C If the system matrices A, E and B are badly scaled, it is C generally recommendable to scale them with the SLICOT routine C TG01AD, before calling TG01HD. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C March 1999. Based on the RASP routine RPDSCF. C C REVISIONS C C July 1999, V. Sima, Research Institute for Informatics, Bucharest. C C KEYWORDS C C Controllability, minimal realization, orthogonal canonical form, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOBCON INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, $ M, N, NCONT, NIUCON, NRBLCK, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK( * ), RTAU( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), $ Z( LDZ, * ) C .. Local Scalars .. CHARACTER JOBQ, JOBZ LOGICAL FINCON, ILQ, ILZ, INFCON INTEGER ICOMPQ, ICOMPZ, LBA, NR C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL TG01HX, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C C Decode JOBCON. C IF( LSAME( JOBCON, 'C' ) ) THEN FINCON = .TRUE. INFCON = .TRUE. ELSE IF( LSAME( JOBCON, 'F' ) ) THEN FINCON = .TRUE. INFCON = .FALSE. ELSE IF( LSAME( JOBCON, 'I' ) ) THEN FINCON = .FALSE. INFCON = .TRUE. ELSE FINCON = .FALSE. INFCON = .FALSE. END IF C C Decode COMPQ. C IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'U' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF C C Decode COMPZ. C IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'U' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF C C Test the input scalar parameters. C INFO = 0 IF( .NOT.FINCON .AND. .NOT.INFCON ) THEN INFO = -1 ELSE IF( ICOMPQ.LE.0 ) THEN INFO = -2 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -14 ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -16 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -18 ELSE IF( TOL.GE.ONE ) THEN INFO = -23 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01HD', -INFO ) RETURN END IF C JOBQ = COMPQ JOBZ = COMPZ C IF( FINCON ) THEN C C Perform finite controllability form reduction. C CALL TG01HX( JOBQ, JOBZ, N, N, M, P, N, MAX( 0, N-1 ), A, LDA, $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) IF( NRBLCK.GT.1 ) THEN LBA = RTAU(1) + RTAU(2) - 1 ELSE IF( NRBLCK.EQ.1 ) THEN LBA = RTAU(1) - 1 ELSE LBA = 0 END IF IF( ILQ ) JOBQ = 'U' IF( ILZ ) JOBZ = 'U' ELSE NR = N LBA = MAX( 0, N-1 ) END IF C IF( INFCON ) THEN C C Perform infinite controllability form reduction. C CALL TG01HX( JOBQ, JOBZ, N, N, M, P, NR, LBA, E, LDE, $ A, LDA, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT, $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) IF( FINCON ) THEN NIUCON = NR - NCONT ELSE NIUCON = 0 END IF ELSE NCONT = NR NIUCON = 0 END IF C RETURN C C *** Last line of TG01HD *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03BD.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SG03BD.f0000644000175000017500000010443215012430707017357 0ustar00lilgelilge00000000000000 SUBROUTINE SG03BD( DICO, FACT, TRANS, N, M, A, LDA, E, LDE, Q, $ LDQ, Z, LDZ, B, LDB, SCALE, ALPHAR, ALPHAI, $ BETA, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the Cholesky factor U of the matrix X, C C T C X = op(U) * op(U), C C which is the solution of either the generalized c-stable C continuous-time Lyapunov equation C C T T C op(A) * X * op(E) + op(E) * X * op(A) C C 2 T C = - SCALE * op(B) * op(B), (1) C C or the generalized d-stable discrete-time Lyapunov equation C C T T C op(A) * X * op(A) - op(E) * X * op(E) C C 2 T C = - SCALE * op(B) * op(B), (2) C C without first finding X and without the need to form the matrix C op(B)**T * op(B). C C op(K) is either K or K**T for K = A, B, E, U. A and E are N-by-N C matrices, op(B) is an M-by-N matrix. The resulting matrix U is an C N-by-N upper triangular matrix with non-negative entries on its C main diagonal. SCALE is an output scale factor set to avoid C overflow in U. C C In the continuous-time case (1) the pencil A - lambda * E must be C c-stable (that is, all eigenvalues must have negative real parts). C In the discrete-time case (2) the pencil A - lambda * E must be C d-stable (that is, the moduli of all eigenvalues must be smaller C than one). 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 FACT CHARACTER*1 C Specifies whether the generalized real Schur C factorization of the pencil A - lambda * E is supplied on C 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 Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C M (input) INTEGER C The number of rows in the matrix op(B). M >= 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 generalized C Schur factor A_s of the matrix A (see definition (3) in C section METHOD). A_s must be an upper quasitriangular C matrix. The elements below the upper Hessenberg part of C the array A are not referenced. C If FACT = 'N', then the leading N-by-N part of this array C must contain the matrix A. C On exit, if FACT = 'N', the leading N-by-N upper C Hessenberg part of this array contains the generalized C Schur factor A_s of the matrix A. (A_s is an upper C quasitriangular matrix.) If FACT = 'F', the leading N-by-N C upper triangular part of this array is unchanged. 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 generalized C Schur factor E_s of the matrix E (see definition (4) in C section METHOD). E_s must be an upper triangular matrix. C The elements below the upper triangular part of the array C E are not referenced. C If FACT = 'N', then the leading N-by-N part of this array C must contain the coefficient matrix E of the equation. C On exit, if FACT = 'N', the leading N-by-N upper C triangular part of this array contains the generalized C Schur factor E_s of the matrix E. (E_s is an upper C triangular matrix.) If FACT = 'F', the leading N-by-N C upper triangular part of this array is unchanged. 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 the C generalized Schur factorization (see definitions (3) and C (4) in section METHOD), or an identity matrix (if the C original equation has upper triangular matrices A and E). C If FACT = 'N', Q need not be set on entry. C On exit, if FACT = 'N', the leading N-by-N part of this C array contains the orthogonal matrix Q from the C generalized Schur factorization. If FACT = 'F', this array C is unchanged. 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 the C generalized Schur factorization (see definitions (3) and C (4) in section METHOD), or an identity matrix (if the C original equation has upper triangular matrices A and E). C If FACT = 'N', Z need not be set on entry. C On exit, if FACT = 'N', the leading N-by-N part of this C array contains the orthogonal matrix Z from the C generalized Schur factorization. If FACT = 'F', this array C is unchanged. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N1) C On entry, if TRANS = 'T', the leading N-by-M part of this C array must contain the matrix B and N1 >= MAX(M,N). C If TRANS = 'N', the leading M-by-N part of this array C must contain the matrix B and N1 >= N. C On exit, if INFO = 0, the leading N-by-N part of this C array contains the Cholesky factor U of the solution C matrix X of the problem, X = op(U)**T * op(U). C If M = 0 and N > 0, then U is set to zero. C C LDB INTEGER C The leading dimension of the array B. C If TRANS = 'T', LDB >= MAX(1,N). C If TRANS = 'N', LDB >= MAX(1,M,N). C C SCALE (output) DOUBLE PRECISION C The scale factor set to avoid overflow in U. C 0 < SCALE <= 1. 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 INFO = 0, 3, 5, 6, or 7, then C (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j = 1, ... ,N, are the C eigenvalues of the matrix pencil A - lambda * E. C All BETA(j) are non-negative numbers. C ALPHAR and ALPHAI will be always less than and usually C comparable with norm(A) in magnitude, and BETA always less C than and usually comparable with norm(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 On exit, if INFO = -21, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= MAX(1,4*N,6*N-6), if FACT = 'N'; C LDWORK >= MAX(1,2*N,6*N-6), if FACT = 'F'. C For good performance, LDWORK should be larger. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 = 1: the pencil A - lambda * E is (nearly) singular; C perturbed values were used to solve the equation C (but the reduced (quasi)triangular matrices A and E C are unchanged); C = 2: FACT = 'F' and the matrix contained in the upper C Hessenberg part of the array A is not in upper C quasitriangular form; C = 3: FACT = 'F' and there is a 2-by-2 block on the main C diagonal of the pencil A_s - lambda * E_s whose C eigenvalues are not conjugate complex; C = 4: FACT = 'N' and the pencil A - lambda * E cannot be C reduced to generalized Schur form: LAPACK routine C DGEGS (or DGGES) has failed to converge; C = 5: DICO = 'C' and the pencil A - lambda * E is not C c-stable; C = 6: DICO = 'D' and the pencil A - lambda * E is not C d-stable; C = 7: the LAPACK routine DSYEVX utilized to factorize M3 C failed to converge in the discrete-time case (see C section METHOD for SLICOT Library routine SG03BU). C This error is unlikely to occur. C C METHOD C C An extension [2] of Hammarling's method [1] to generalized C Lyapunov equations 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 the pencil A - lambda * E has already been factorized prior to C calling the routine, however, then the factors A_s, E_s, Q and Z C may be supplied and the initial factorization omitted. C C Depending on the parameters TRANS and M, the N-by-N upper C triangular matrix B_s is defined as follows. In any case Q_B is C an M-by-M orthogonal matrix, which need not be accumulated. C C 1. If TRANS = 'N' and M < N, B_s is the upper triangular matrix C from the QR-factorization C C ( Q_B O ) ( B * Z ) C ( ) * B_s = ( ), C ( O I ) ( O ) C C where the O's are zero matrices of proper size and I is the C identity matrix of order N-M. C C 2. If TRANS = 'N' and M >= N, B_s is the upper triangular matrix C from the (rectangular) QR-factorization C C ( B_s ) C Q_B * ( ) = B * Z, C ( O ) C C where O is the (M-N)-by-N zero matrix. C C 3. If TRANS = 'T' and M < N, B_s is the upper triangular matrix C from the RQ-factorization C C ( Q_B O ) C (B_s O ) * ( ) = ( Q**T * B O ). C ( O I ) C C 4. If TRANS = 'T' and M >= N, B_s is the upper triangular matrix C from the (rectangular) RQ-factorization C C ( B_s O ) * Q_B = Q**T * B, C C where O is the N-by-(M-N) zero matrix. C C Assuming SCALE = 1, the transformation of A, E and B described C above leads to the reduced continuous-time equation C C T T C op(A_s) op(U_s) op(U_s) op(E_s) C C T T C + op(E_s) op(U_s) op(U_s) op(A_s) C C T C = - op(B_s) op(B_s) (5) C C or to the reduced discrete-time equation C C T T C op(A_s) op(U_s) op(U_s) op(A_s) C C T T C - op(E_s) op(U_s) op(U_s) op(E_s) C C T C = - op(B_s) op(B_s). (6) C C For brevity we restrict ourself to equation (5) and the case C TRANS = 'N'. The other three cases can be treated in a similar C fashion. C C We use the following partitioning for the matrices A_s, E_s, B_s, C and U_s C C ( A11 A12 ) ( E11 E12 ) C A_s = ( ), E_s = ( ), C ( 0 A22 ) ( 0 E22 ) C C ( B11 B12 ) ( U11 U12 ) C B_s = ( ), U_s = ( ). (7) C ( 0 B22 ) ( 0 U22 ) C C The size of the (1,1)-blocks is 1-by-1 (iff A_s(2,1) = 0.0) or C 2-by-2. C C We compute U11, U12**T, and U22 in three steps. C C Step I: C C From (5) and (7) we get the 1-by-1 or 2-by-2 equation C C T T T T C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 C C T C = - B11 * B11. C C For brevity, details are omitted here. See [2]. The technique C for computing U11 is similar to those applied to standard C Lyapunov equations in Hammarling's algorithm ([1], section 6). C C Furthermore, the auxiliary matrices M1 and M2 defined as C follows C C -1 -1 C M1 = U11 * A11 * E11 * U11 C C -1 -1 C M2 = B11 * E11 * U11 C C are computed in a numerically reliable way. C C Step II: C C The generalized Sylvester equation C C T T T T C A22 * U12 + E22 * U12 * M1 = C C T T T T T C - B12 * M2 - A12 * U11 - E12 * U11 * M1 C C is solved for U12**T. C C Step III: C C It can be shown that C C T T T T C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = C C T T C - B22 * B22 - y * y (8) C C holds, where y is defined as C C T T T T T T C y = B12 - ( E12 * U11 + E22 * U12 ) * M2 . C C If B22_tilde is the square triangular matrix arising from the C (rectangular) QR-factorization C C ( B22_tilde ) ( B22 ) C Q_B_tilde * ( ) = ( ), C ( O ) ( y**T ) C C where Q_B_tilde is an orthogonal matrix of order N, then C C T T T C - B22 * B22 - y * y = - B22_tilde * B22_tilde. C C Replacing the right hand side in (8) by the term C - B22_tilde**T * B22_tilde leads to a reduced generalized C Lyapunov equation of lower dimension compared to (5). C C The recursive application of the steps I to III yields the C solution U_s of the equation (5). C C It remains to compute the solution matrix U of the original C problem (1) or (2) from the matrix U_s. To this end we transform C the solution back (with respect to the transformation that led C from (1) to (5) (from (2) to (6)) and apply the QR-factorization C (RQ-factorization). The upper triangular solution matrix U is C obtained by C C Q_U * U = U_s * Q**T (if TRANS = 'N'), C C or C C U * Q_U = Z * U_s (if TRANS = 'T'), C C where Q_U is an N-by-N orthogonal matrix. Again, the orthogonal C matrix Q_U need not be accumulated. C C REFERENCES C C [1] Hammarling, S.J. C Numerical solution of the stable, non-negative definite C Lyapunov equation. C IMA J. Num. Anal., 2, pp. 303-323, 1982. 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 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 C | FACT = 'F' FACT = 'N' C ---------+-------------------------------------------------- C M <= N | (13*N**3+6*M*N**2 (211*N**3+6*M*N**2 C | +6*M**2*N-2*M**3)/3 +6*M**2*N-2*M**3)/3 C | C M > N | (11*N**3+12*M*N**2)/3 (209*N**3+12*M*N**2)/3 C C FURTHER COMMENTS 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 A condition estimate can be obtained from the routine SG03AD. C When setting the error indicator INFO, the routine does not test C for near instability in the equation but only for exact C instability. C C CONTRIBUTOR C C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. C C REVISIONS C C Sep. 1998, May 1999 (V. Sima). C March 2002 (A. Varga). C Feb. 2004, July 2011, Dec. 2021 - Feb. 2022 (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 .. DOUBLE PRECISION SCALE INTEGER INFO, LDA, LDB, LDE, LDQ, LDWORK, LDZ, M, N CHARACTER DICO, FACT, TRANS C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), $ BETA(*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. DOUBLE PRECISION BIGNMS, BIGNUM, EPS, MA, MATO, MB, MBTO, ME, $ METO, MN, MX, S1, S2, SAFMIN, SMLNUM, T, TMP, $ WI, WR1, WR2 INTEGER BL, I, INFO1, J, K, L, MAXMN, MINGG, MINMN, $ MINWRK, NC, NR, OPTWRK LOGICAL ISDISC, ISFACT, ISTRAN, LASCL, LBSCL, LESCL, $ LQUERY, LSCL, NUNITQ, NUNITZ, SCALB C .. Local Arrays .. DOUBLE PRECISION E1(2,2) LOGICAL BWORK(1) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANTR, DLAPY2 LOGICAL DELCTG, LSAME, MA02HD EXTERNAL DELCTG, DLAMCH, DLANGE, DLANHS, DLANTR, DLAPY2, $ LSAME, MA02HD C .. External Subroutines .. EXTERNAL DCOPY, DGEGS, DGEMM, DGEQRF, DGERQF, DGGES, $ DLABAD, DLACPY, DLAG2, DLASCL, DLASET, DSCAL, $ DSWAP, MB01UY, SG03BU, SG03BV, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SIGN, SQRT C .. Executable Statements .. C C Decode input parameters. C ISDISC = LSAME( DICO, 'D' ) ISFACT = LSAME( FACT, 'F' ) ISTRAN = LSAME( TRANS, 'T' ) LQUERY = LDWORK.EQ.-1 C C Check the scalar input parameters. C INFO = 0 IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN INFO = -1 ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT, 'N' ) ) ) THEN INFO = -2 ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN INFO = -3 ELSEIF ( N.LT.0 ) THEN INFO = -4 ELSEIF ( M.LT.0 ) THEN INFO = -5 ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSEIF ( LDE.LT.MAX( 1, N ) ) THEN INFO = -9 ELSEIF ( LDQ.LT.MAX( 1, N ) ) THEN INFO = -11 ELSEIF ( LDZ.LT.MAX( 1, N ) ) THEN INFO = -13 ELSEIF ( ( ISTRAN .AND. ( LDB.LT.MAX( 1, N ) ) ) .OR. $ ( .NOT.ISTRAN .AND. ( LDB.LT.MAX( 1, M, N ) ) ) ) THEN INFO = -15 ELSE C C Compute minimal and optimal workspace. C IF ( ISFACT ) THEN MINWRK = MAX( 1, 2*N, 6*N-6 ) ELSE MINWRK = MAX( 1, 4*N, 6*N-6 ) END IF MINGG = MAX( MINWRK, 8*N + 16 ) MAXMN = MAX( M, N ) IF ( LQUERY ) THEN OPTWRK = MINWRK IF ( .NOT.ISFACT ) THEN CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, $ N, A, LDA, E, LDE, I, ALPHAR, ALPHAI, BETA, $ Q, LDQ, Z, LDZ, DWORK, -1, BWORK, INFO1 ) OPTWRK = MAX( MINGG, INT( DWORK(1) ) ) END IF IF ( ISTRAN ) THEN CALL DGERQF( N, MAXMN, B, LDB, DWORK, DWORK, -1, INFO1 ) ELSE CALL DGEQRF( MAXMN, N, B, LDB, DWORK, DWORK, -1, INFO1 ) END IF OPTWRK = MAX( OPTWRK, INT( DWORK(1) ) + N ) ELSEIF ( LDWORK.LT.MINWRK ) THEN DWORK(1) = MINWRK INFO = -21 END IF END IF C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'SG03BD', -INFO ) RETURN ELSE IF ( LQUERY ) THEN DWORK(1) = OPTWRK RETURN END IF C SCALE = ONE C C Quick return if possible. C IF ( ISTRAN ) THEN K = N L = M ELSE K = M L = N END IF MB = DLANGE( 'Max', K, L, B, LDB, DWORK ) IF ( MB.EQ.ZERO ) THEN IF ( N.GT.0 ) $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDB ) DWORK(1) = ONE RETURN END IF C C Set constants to control overflow. C EPS = DLAMCH( 'Precision' ) SAFMIN = DLAMCH( 'Safe minimum' ) SMLNUM = SAFMIN BIGNMS = ONE/SMLNUM CALL DLABAD( SMLNUM, BIGNMS ) SMLNUM = SQRT( SMLNUM )/EPS BIGNUM = ONE/SMLNUM C IF ( .NOT.ISFACT ) THEN C C Reduce the pencil 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 The diagonal elements of E are non-negative real numbers. C IF ( LDWORK.LT.MINGG ) THEN C C Use DGEGS for backward compatibilty with LDWORK value. 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 ) ELSE C C Use DGGES. The workspace is increased to avoid an error C return, while it should not really be larger than above. C Workspace: >= MAX(1,8*N+16) C CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N, $ A, LDA, E, LDE, I, ALPHAR, ALPHAI, BETA, Q, LDQ, $ Z, LDZ, DWORK, LDWORK, BWORK, INFO1 ) END IF IF ( INFO1.NE.0 ) THEN INFO = 4 RETURN END IF NUNITQ = .TRUE. NUNITZ = .TRUE. OPTWRK = INT( DWORK(1) ) C ELSE C C Make sure the upper Hessenberg part of A is quasitriangular. C DO 10 I = 1, N-2 IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN INFO = 2 RETURN END IF 10 CONTINUE C C Compute the eigenvalues of the matrix pencil A - lambda * E. C E1(2,1) = ZERO I = 1 C WHILE ( I.LE.N ) DO 20 CONTINUE IF ( I.LT.N ) THEN IF ( A(I+1,I).EQ.ZERO ) THEN ALPHAR(I) = A(I,I) ALPHAI(I) = ZERO BETA(I) = E(I,I) ELSE E1(1,1) = E(I,I) E1(1,2) = E(I,I+1) E1(2,2) = E(I+1,I+1) CALL DLAG2( A(I,I), LDA, E1, 2, SAFMIN, S1, S2, WR1, WR2, $ WI ) IF ( WI.EQ.ZERO ) THEN INFO = 3 RETURN END IF ALPHAR(I) = WR1 ALPHAI(I) = WI BETA(I) = S1 I = I + 1 ALPHAR(I) = WR2 ALPHAI(I) = -WI BETA(I) = S2 END IF I = I + 1 GOTO 20 ELSE IF ( I.EQ.N ) THEN ALPHAR(N) = A(N,N) ALPHAI(N) = ZERO BETA(N) = E(N,N) END IF C END WHILE 20 C C Check for identity matrices Q and/or Z. C NUNITQ = .NOT.MA02HD( 'All', N, N, ONE, Q, LDQ ) NUNITZ = .NOT.MA02HD( 'All', N, N, ONE, Z, LDZ ) OPTWRK = MINWRK END IF C C Check on the stability of the matrix pencil A - lambda * E. C DO 30 I = 1, N IF ( ISDISC ) THEN IF ( DLAPY2( ALPHAR(I), ALPHAI(I) ).GE.BETA(I) ) THEN INFO = 6 RETURN END IF ELSE IF ( ( ALPHAR(I).EQ.ZERO ) .OR. ( BETA(I).EQ.ZERO ) .OR. $ ( SIGN( ONE,ALPHAR(I) )*SIGN( ONE, BETA(I) ).GE.ZERO ) ) $ THEN INFO = 5 RETURN END IF END IF 30 CONTINUE C C Scale A if the maximum absolute value of its elements is outside C the range [SMLNUM,BIGNUM]. Scale similarly E and B. The scaling C factors of E may be set equal to those for A, to preserve C stability in the discrete-time case. Scaling of B is done before C further processing if the maximum absolute value of its elements C is greater than BIGNMS; otherwise, it is postponed. Scaling is C also performed if the maximum absolute values of A, E, B differ C too much, or their minimum (maximum) is too large (small). C MA = MIN( DLANHS( 'Max', N, A, LDA, DWORK ), BIGNMS ) ME = MIN( DLANTR( 'Max', 'Upper', 'NoDiag', N, N, E, LDE, DWORK ), $ BIGNMS ) MN = MIN( MA, ME, MB ) MX = MAX( MA, ME, MB ) C LSCL = MN.LT.MX*SMLNUM .OR. MX.LT.SMLNUM .OR. MN.GT.BIGNUM IF ( LSCL ) THEN MATO = ONE METO = ONE MBTO = ONE LASCL = .TRUE. LESCL = .TRUE. LBSCL = .TRUE. ELSE IF ( MA.GT.ZERO .AND. MA.LT.SMLNUM ) THEN MATO = SMLNUM LASCL = .TRUE. ELSE IF ( MA.GT.BIGNUM ) THEN MATO = BIGNUM LASCL = .TRUE. ELSE LASCL = .FALSE. END IF C IF ( ME.GT.ZERO .AND. ME.LT.SMLNUM ) THEN METO = SMLNUM LESCL = .TRUE. ELSE IF ( ME.GT.BIGNUM ) THEN METO = BIGNUM LESCL = .TRUE. ELSE LESCL = .FALSE. END IF C IF ( MB.GT.ZERO .AND. MB.LT.SMLNUM ) THEN MBTO = SMLNUM LBSCL = .TRUE. ELSE IF ( MB.GT.BIGNUM ) THEN MBTO = BIGNUM LBSCL = .TRUE. ELSE MBTO = ONE LBSCL = .FALSE. END IF END IF C IF ( ISDISC .AND. LASCL .AND. LESCL ) THEN IF ( MATO/MA.GT.METO/ME ) THEN ME = MA METO = MATO END IF END IF C IF ( LASCL ) $ CALL DLASCL( 'Hess', 0, 0, MA, MATO, N, N, A, LDA, INFO ) IF ( LESCL ) $ CALL DLASCL( 'Upper', 0, 0, ME, METO, N, N, E, LDE, INFO ) C SCALB = MB.GT.BIGNMS MB = MIN( MB, BIGNMS ) IF ( LBSCL .AND. SCALB ) $ CALL DLASCL( 'Gen', 0, 0, MB, MBTO, K, L, B, LDB, INFO ) C C Transformation of the right hand side: C C B := Q**T * B or B := B * Z. C C Workspace: need max(1,2*N); prefer larger. C IF ( ISTRAN ) THEN C IF ( NUNITQ ) THEN NC = INT( LDWORK / N ) C DO 40 J = 1, M, NC BL = MIN( M-J+1, NC ) CALL DGEMM( 'Trans', 'NoTrans', N, BL, N, ONE, Q, LDQ, $ B(1,J), LDB, ZERO, DWORK, N ) CALL DLACPY( 'All', N, BL, DWORK, N, B(1,J), LDB ) 40 CONTINUE C END IF C ELSE C IF ( NUNITQ ) THEN NR = INT( LDWORK / N ) C DO 50 I = 1, M, NR BL = MIN( M-I+1, NR ) CALL DGEMM( TRANS, 'NoTrans', BL, N, N, ONE, B(I,1), $ LDB, Z, LDZ, ZERO, DWORK, BL ) CALL DLACPY( 'All', BL, N, DWORK, BL, B(I,1), LDB ) 50 CONTINUE C END IF C END IF C C Overwrite B with the triangular matrix of its RQ-factorization C or its QR-factorization. C (The entries on the main diagonal are non-negative.) C Then, do scaling, if it was postponed. C C Workspace: need max(1,MIN(M,N)+N); prefer larger. C MINMN = MIN( M, N ) IF ( ISTRAN ) THEN C CALL DGERQF( N, M, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 ) IF ( N.GE.M ) THEN IF ( LBSCL .AND. .NOT.SCALB ) THEN CALL DLASCL( 'Gen', 0, 0, MB, MBTO, N-M, M, B, LDB, $ INFO ) CALL DLASCL( 'Upper', 0, 0, MB, MBTO, M, M, B(N-M+1,1), $ LDB, INFO ) END IF IF ( N.GT.M ) THEN C DO 60 I = M, 1, -1 CALL DCOPY( I+N-M, B(1,I), 1, B(1,I+N-M), 1 ) 60 CONTINUE C CALL DLASET( 'All', N, N-M, ZERO, ZERO, B, LDB ) END IF IF ( M.GT.1 ) $ CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, $ B(N-M+2,N-M+1), LDB ) ELSE IF ( LBSCL .AND. .NOT.SCALB ) $ CALL DLASCL( 'Upper', 0, 0, MB, MBTO, N, M, B, LDB, $ INFO ) C DO 70 I = 1, N CALL DCOPY( I, B(1,M-N+I), 1, B(1,I), 1 ) 70 CONTINUE C IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) END IF C DO 80 I = N - MINMN + 1, N IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( I, MONE, B(1,I), 1 ) 80 CONTINUE C ELSE C CALL DGEQRF( M, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 ) IF ( LBSCL .AND. .NOT.SCALB ) $ CALL DLASCL( 'Upper', 0, 0, MB, MBTO, M, N, B, LDB, INFO ) IF ( MAXMN.GT.1 ) $ CALL DLASET( 'Lower', MAXMN-1, MINMN, ZERO, ZERO, B(2,1), $ LDB ) IF ( N.GT.M ) $ CALL DLASET( 'All', N-M, N, ZERO, ZERO, B(M+1,1), LDB ) C DO 90 I = 1, MINMN IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( N+1-I, MONE, B(I,I), LDB ) 90 CONTINUE C END IF C C Solve the reduced generalized Lyapunov equation. C C Workspace: 6*N-6 C IF ( ISDISC ) THEN CALL SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, $ INFO1 ) IF ( INFO1.NE.0 ) THEN IF ( INFO1.EQ.1 ) $ INFO = 1 IF ( INFO1.EQ.2 ) $ INFO = 3 IF ( INFO1.EQ.3 ) $ INFO = 6 IF ( INFO1.EQ.4 ) $ INFO = 7 IF ( INFO.NE.1 ) $ RETURN END IF ELSE CALL SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, $ INFO1 ) IF ( INFO1.NE.0 ) THEN IF ( INFO1.EQ.1 ) $ INFO = 1 IF ( INFO1.GE.2 ) $ INFO = 3 IF ( INFO1.EQ.3 ) $ INFO = 5 IF ( INFO.NE.1 ) $ RETURN END IF END IF C C Transform the solution matrix back, if Z and/or Q are not unit: C C U := Z * U or U := U * Q**T ( U**T := Q * U**T). C IF ( ISTRAN ) THEN C IF ( NUNITZ ) THEN C C Workspace: max(1,N); prefer larger. C CALL MB01UY( 'Right', 'Upper', 'NoTrans', N, N, ONE, B, LDB, $ Z, LDZ, DWORK, LDWORK, INFO ) C C Overwrite U with the triangular matrix of its C RQ-factorization and make the entries on the main diagonal C non-negative. C C Workspace: >= max(1,2*N); prefer larger. C CALL DGERQF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, $ INFO1 ) IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) C DO 100 I = 1, N IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( I, MONE, B(1,I), 1 ) 100 CONTINUE C END IF C ELSE C IF ( NUNITQ ) THEN C C Workspace: max(1,N); prefer larger. C CALL MB01UY( 'Right', 'Upper', 'Trans', N, N, ONE, B, LDB, $ Q, LDQ, DWORK, LDWORK, INFO ) C DO 110 I = 1, N CALL DSWAP( I, B(I,1), LDB, B(1,I), 1 ) 110 CONTINUE C C Overwrite U with the triangular matrix of its C QR-factorization and make the entries on the main diagonal C non-negative. C C Workspace: >= max(1,2*N); prefer larger. C CALL DGEQRF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, $ INFO1 ) IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) C DO 120 I = 1, N IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( N+1-I, MONE, B(I,I), LDB ) 120 CONTINUE C END IF C END IF C C Undo the scaling of A, E, and B and update SCALE. C TMP = ONE IF ( LASCL ) THEN CALL DLASCL( 'Hess', 0, 0, MATO, MA, N, N, A, LDA, INFO ) TMP = SQRT( MATO/MA ) END IF IF ( LESCL ) THEN CALL DLASCL( 'Upper', 0, 0, METO, ME, N, N, E, LDE, INFO ) TMP = TMP*SQRT( METO/ME ) END IF IF ( LBSCL ) THEN MX = DLANTR( 'Max', 'Upper', 'NoDiag', N, N, B, LDB, DWORK ) MN = MIN( TMP, MB ) T = MAX( TMP, MB ) IF ( T.GT.ONE ) THEN IF ( MN.GT.BIGNMS/T ) THEN SCALE = SCALE/T TMP = TMP/T END IF END IF TMP = TMP*MB IF ( TMP.GT.ONE ) THEN IF ( MX.GT.BIGNMS/TMP ) THEN SCALE = SCALE/MX TMP = TMP/MX END IF END IF END IF IF ( LASCL .OR. LESCL .OR. LBSCL ) $ CALL DLASCL( 'Upper', 0, 0, MBTO, TMP, N, N, B, LDB, INFO ) C OPTWRK = MAX( OPTWRK, INT( DWORK(N+1) ) + N ) C DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) ) RETURN C *** Last line of SG03BD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04OD.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04OD.f0000644000175000017500000011321615012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE SB04OD( REDUCE, TRANS, JOBD, M, N, A, LDA, B, LDB, C, $ LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, P, $ LDP, Q, LDQ, U, LDU, V, LDV, IWORK, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To solve for R and L one of the generalized Sylvester equations C C A * R - L * B = scale * C ) C ) (1) C D * R - L * E = scale * F ) C C or C C A' * R + D' * L = scale * C ) C ) (2) C R * B' + L * E' = scale * (-F) ) C C where A and D are M-by-M matrices, B and E are N-by-N matrices and C C, F, R and L are M-by-N matrices. C C The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an C output scaling factor chosen to avoid overflow. C C The routine also optionally computes a Dif estimate, which C measures the separation of the spectrum of the matrix pair (A,D) C from the spectrum of the matrix pair (B,E), Dif[(A,D),(B,E)]. C C ARGUMENTS C C MODE PARAMETERS C C REDUCE CHARACTER*1 C Indicates whether the matrix pairs (A,D) and/or (B,E) are C to be reduced to generalized Schur form as follows: C = 'R': The matrix pairs (A,D) and (B,E) are to be reduced C to generalized (real) Schur canonical form; C = 'A': The matrix pair (A,D) only is to be reduced C to generalized (real) Schur canonical form, C and the matrix pair (B,E) already is in this form; C = 'B': The matrix pair (B,E) only is to be reduced C to generalized (real) Schur canonical form, C and the matrix pair (A,D) already is in this form; C = 'N': The matrix pairs (A,D) and (B,E) are already in C generalized (real) Schur canonical form, as C produced by LAPACK routine DGGES. C C TRANS CHARACTER*1 C Indicates which of the equations, (1) or (2), is to be C solved as follows: C = 'N': The generalized Sylvester equation (1) is to be C solved; C = 'T': The "transposed" generalized Sylvester equation C (2) is to be solved. C C JOBD CHARACTER*1 C Indicates whether the Dif estimator is to be computed as C follows: C = '1': Only the one-norm-based Dif estimate is computed C and stored in DIF; C = '2': Only the Frobenius norm-based Dif estimate is C computed and stored in DIF; C = 'D': The equation (1) is solved and the one-norm-based C Dif estimate is computed and stored in DIF; C = 'F': The equation (1) is solved and the Frobenius norm- C based Dif estimate is computed and stored in DIF; C = 'N': The Dif estimator is not required and hence DIF is C not referenced. (Solve either (1) or (2) only.) C JOBD is not referenced if TRANS = 'T'. C C Input/Output Parameters C C M (input) INTEGER C The order of the matrices A and D and the number of rows C of the matrices C, F, R and L. M >= 0. C C N (input) INTEGER C The order of the matrices B and E and the number of C columns of the matrices C, F, R and L. N >= 0. C No computations are performed if N = 0 or M = 0, but SCALE C and DIF (if JOB <> 'N') are set to 1. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) C On entry, the leading M-by-M part of this array must C contain the coefficient matrix A of the equation; A must C be in upper quasi-triangular form if REDUCE = 'B' or 'N'. C On exit, the leading M-by-M part of this array contains C the upper quasi-triangular form of A. 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 N-by-N part of this array must C contain the coefficient matrix B of the equation; B must C be in upper quasi-triangular form if REDUCE = 'A' or 'N'. C On exit, the leading N-by-N part of this array contains C the upper quasi-triangular form of B. 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 right-hand side matrix C of the first equation C in (1) or (2). C On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N C part of this array contains the solution matrix R of the C problem; if JOBD = '1' or '2' and TRANS = 'N', the leading C M-by-N part of this array contains the solution matrix R C achieved during the computation of the Dif estimate. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,M). C C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) C On entry, the leading M-by-M part of this array must C contain the coefficient matrix D of the equation; D must C be in upper triangular form if REDUCE = 'B' or 'N'. C On exit, the leading M-by-M part of this array contains C the upper triangular form of D. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,M). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the coefficient matrix E of the equation; E must C be in upper triangular form if REDUCE = 'A' or 'N'. C On exit, the leading N-by-N part of this array contains C the upper triangular form of E. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). C C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) C On entry, the leading M-by-N part of this array must C contain the right-hand side matrix F of the second C equation in (1) or (2). C On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N C part of this array contains the solution matrix L of the C problem; if JOBD = '1' or '2' and TRANS = 'N', the leading C M-by-N part of this array contains the solution matrix L C achieved during the computation of the Dif estimate. C C LDF INTEGER C The leading dimension of array F. LDF >= MAX(1,M). C C SCALE (output) DOUBLE PRECISION C The scaling factor in (1) or (2). If 0 < SCALE < 1, C and C F hold the solutions R and L, respectively, to a slightly C perturbed system, but the computed generalized (real) C Schur canonical form matrices P'*A*Q, U'*B*V, P'*D*Q and C U'*E*V (see METHOD), or input matrices A, B, D, and E (if C already reduced to these forms), have not been changed. C If SCALE = 0, C and F hold the solutions R and L, C respectively, to the homogeneous system with C = F = 0. C Normally, SCALE = 1. C C DIF (output) DOUBLE PRECISION C If TRANS = 'N' and JOBD <> 'N', then DIF contains the C value of the Dif estimator, which is an upper bound of C -1 C Dif[(A,D),(B,E)] = sigma_min(Z) = 1/||Z ||, in either the C one-norm, or Frobenius norm, respectively (see METHOD). C Otherwise, DIF is not referenced. C C P (output) DOUBLE PRECISION array, dimension (LDP,*) C If REDUCE = 'R' or 'A', then the leading M-by-M part of C this array contains the (left) transformation matrix used C to reduce (A,D) to generalized Schur form. C Otherwise, P is not referenced and can be supplied as a C dummy array (i.e. set parameter LDP = 1 and declare this C array to be P(1,1) in the calling program). C C LDP INTEGER C The leading dimension of array P. C LDP >= MAX(1,M) if REDUCE = 'R' or 'A', C LDP >= 1 if REDUCE = 'B' or 'N'. C C Q (output) DOUBLE PRECISION array, dimension (LDQ,*) C If REDUCE = 'R' or 'A', then the leading M-by-M part of C this array contains the (right) transformation matrix used C to reduce (A,D) to generalized Schur form. C Otherwise, Q is not referenced and can be supplied as a C dummy array (i.e. set parameter LDQ = 1 and declare this C array to be Q(1,1) in the calling program). C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= MAX(1,M) if REDUCE = 'R' or 'A', C LDQ >= 1 if REDUCE = 'B' or 'N'. C C U (output) DOUBLE PRECISION array, dimension (LDU,*) C If REDUCE = 'R' or 'B', then the leading N-by-N part of C this array contains the (left) transformation matrix used C to reduce (B,E) to generalized Schur form. C Otherwise, U is not referenced and can be supplied as a C dummy array (i.e. set parameter LDU = 1 and declare this C array to be U(1,1) in the calling program). C C LDU INTEGER C The leading dimension of array U. C LDU >= MAX(1,N) if REDUCE = 'R' or 'B', C LDU >= 1 if REDUCE = 'A' or 'N'. C C V (output) DOUBLE PRECISION array, dimension (LDV,*) C If REDUCE = 'R' or 'B', then the leading N-by-N part of C this array contains the (right) transformation matrix used C to reduce (B,E) to generalized Schur form. C Otherwise, V is not referenced and can be supplied as a C dummy array (i.e. set parameter LDV = 1 and declare this C array to be V(1,1) in the calling program). C C LDV INTEGER C The leading dimension of array V. C LDV >= MAX(1,N) if REDUCE = 'R' or 'B', C LDV >= 1 if REDUCE = 'A' or 'N'. C C Workspace C C IWORK INTEGER array, dimension (M+N+6) 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 If TRANS = 'N' and JOBD = 'D' or 'F', then C LDWORK = MAX(1,11*MN,10*MN+23,2*M*N) if REDUCE = 'R'; C LDWORK = MAX(1,11*M, 10*M+23, 2*M*N) if REDUCE = 'A'; C LDWORK = MAX(1,11*N, 10*N+23, 2*M*N) if REDUCE = 'B'; C LDWORK = MAX(1,2*M*N) if REDUCE = 'N', C where MN = max(M,N). C Otherwise, the term 2*M*N above should be omitted. C For optimum performance LDWORK should be larger. C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message 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 = 1: if REDUCE <> 'N' and either (A,D) and/or (B,E) C cannot be reduced to generalized Schur form; C = 2: if REDUCE = 'N' and either A or B is not in C upper quasi-triangular form; C = 3: if a singular matrix was encountered during the C computation of the solution matrices R and L, that C is (A,D) and (B,E) have common or close eigenvalues. C C METHOD C C For the case TRANS = 'N', and REDUCE = 'R' or 'N', the algorithm C used by the routine consists of four steps (see [1] and [2]) as C follows: C C (a) if REDUCE = 'R', then the matrix pairs (A,D) and (B,E) are C transformed to generalized Schur form, i.e. orthogonal C matrices P, Q, U and V are computed such that P' * A * Q C and U' * B * V are in upper quasi-triangular form and C P' * D * Q and U' * E * V are in upper triangular form; C (b) if REDUCE = 'R', then the matrices C and F are transformed C to give P' * C * V and P' * F * V respectively; C (c) if REDUCE = 'R', then the transformed system C C P' * A * Q * R1 - L1 * U' * B * V = scale * P' * C * V C P' * D * Q * R1 - L1 * U' * E * V = scale * P' * F * V C C is solved to give R1 and L1; otherwise, equation (1) is C solved to give R and L directly. The Dif estimator C is also computed if JOBD <> 'N'. C (d) if REDUCE = 'R', then the solution is transformed back C to give R = Q * R1 * V' and L = P * L1 * U'. C C By using Kronecker products, equation (1) can also be written as C the system of linear equations Z * x = scale*y (see [1]), where C C | I*A I*D | C Z = | |. C |-B'*I -E'*I | C C -1 C If JOBD <> 'N', then a lower bound on ||Z ||, in either the one- C norm or Frobenius norm, is computed, which in most cases is C a reliable estimate of the true value. Notice that since Z is a C matrix of order 2 * M * N, the exact value of Dif (i.e., in the C Frobenius norm case, the smallest singular value of Z) may be very C expensive to compute. C C The case TRANS = 'N', and REDUCE = 'A' or 'B', is similar, but C only one of the matrix pairs should be reduced and the C calculations simplify. C C For the case TRANS = 'T', and REDUCE = 'R' or 'N', the algorithm C is similar, but the steps (b), (c), and (d) are as follows: C C (b) if REDUCE = 'R', then the matrices C and F are transformed C to give Q' * C * V and P' * F * U respectively; C (c) if REDUCE = 'R', then the transformed system C C Q' * A' * P * R1 + Q' * D' * P * L1 = scale * Q' * C * V C R1 * V' * B' * U + L1 * V' * E' * U = -scale * P' * F * U C C is solved to give R1 and L1; otherwise, equation (2) is C solved to give R and L directly. C (d) if REDUCE = 'R', then the solution is transformed back C to give R = P * R1 * V' and L = P * L1 * V'. C C REFERENCES C C [1] Kagstrom, B. and Westin, L. C Generalized Schur Methods with Condition Estimators for C Solving the Generalized Sylvester Equation. C IEEE Trans. Auto. Contr., 34, pp. 745-751, 1989. C [2] Kagstrom, B. and Westin, L. C GSYLV - Fortran Routines for the Generalized Schur Method with C Dif Estimators for Solving the Generalized Sylvester C Equation. C Report UMINF-132.86, Institute of Information Processing, C Univ. of Umea, Sweden, July 1987. C [3] 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 [4] Kagstrom, B. and Van Dooren, P. C Additive Decomposition of a Transfer Function with respect to C a Specified Region. C In: "Signal Processing, Scattering and Operator Theory, and C Numerical Methods" (Eds. M.A. Kaashoek et al.). C Proceedings of MTNS-89, Vol. 3, pp. 469-477, Birkhauser Boston C Inc., 1990. C [5] Kagstrom, B. and Van Dooren, P. C A Generalized State-space Approach for the Additive C Decomposition of a Transfer Matrix. C Report UMINF-91.12, Institute of Information Processing, Univ. C of Umea, Sweden, April 1991. C C NUMERICAL ASPECTS C C The algorithm is backward stable. A reliable estimate for the C condition number of Z in the Frobenius norm, is (see [1]) C C K(Z) = SQRT( ||A||**2 + ||B||**2 + ||C||**2 + ||D||**2 )/DIF. C C If mu is an upper bound on the relative error of the elements of C the matrices A, B, C, D, E and F, then the relative error in the C actual solution is approximately mu * K(Z). C C The relative error in the computed solution (due to rounding C errors) is approximately EPS * K(Z), where EPS is the machine C precision (see LAPACK Library routine DLAMCH). C C FURTHER COMMENTS C C For applications of the generalized Sylvester equation in control C theory, see [4] and [5]. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB04CD by Bo Kagstrom and Lars C Westin. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Dec. 1999, C May 2009, Apr. 2014. C C KEYWORDS C C Generalized eigenvalue problem, orthogonal transformation, real C Schur form, Sylvester equation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBD, REDUCE, TRANS INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDF, LDP, LDQ, $ LDU, LDV, LDWORK, M, N DOUBLE PRECISION DIF, SCALE C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), E(LDE,*), F(LDF,*), P(LDP,*), $ Q(LDQ,*), U(LDU,*), V(LDV,*) C .. Local Scalars .. LOGICAL LJOB1, LJOB2, LJOBD, LJOBDF, LJOBF, LQUERY, $ LREDRA, LREDRB, LREDUA, LREDUB, LREDUC, LREDUR, $ LTRANN, SUFWRK INTEGER I, IJOB, MINWRK, MN, NBC, NBR, NC, NR, WRKOPT C .. Local Arrays .. LOGICAL BWORK(1) C .. External Functions .. LOGICAL LSAME, SELECT EXTERNAL LSAME, SELECT C .. External Subroutines .. EXTERNAL DGGES, DGEMM, DLACPY, DTGSYL, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C INFO = 0 MN = MAX( M, N ) LREDUR = LSAME( REDUCE, 'R' ) LREDUA = LSAME( REDUCE, 'A' ) LREDUB = LSAME( REDUCE, 'B' ) LREDRA = LREDUR.OR.LREDUA LREDRB = LREDUR.OR.LREDUB LREDUC = LREDRA.OR.LREDUB LQUERY = LDWORK.EQ.-1 IF ( LREDUR ) THEN MINWRK = MAX( 1, 11*MN, 10*MN+23 ) ELSE IF ( LREDUA ) THEN MINWRK = MAX( 1, 11*M, 10*M+23 ) ELSE IF ( LREDUB ) THEN MINWRK = MAX( 1, 11*N, 10*N+23 ) ELSE MINWRK = 1 END IF LTRANN = LSAME( TRANS, 'N' ) IF ( LTRANN ) THEN LJOB1 = LSAME( JOBD, '1' ) LJOB2 = LSAME( JOBD, '2' ) LJOBD = LSAME( JOBD, 'D' ) LJOBF = LSAME( JOBD, 'F' ) LJOBDF = LJOB1.OR.LJOB2.OR.LJOBD.OR.LJOBF IF ( LJOBD.OR.LJOBF ) $ MINWRK = MAX( MINWRK, 2*M*N ) END IF C C Test the input scalar arguments. C IF( .NOT.LREDUC .AND. .NOT.LSAME( REDUCE, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LTRANN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN INFO = -2 ELSE IF( LTRANN ) THEN IF( .NOT.LJOBDF .AND. .NOT.LSAME( JOBD, 'N' ) ) $ INFO = -3 END IF IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -13 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -17 ELSE IF( LDP.LT.1 .OR. LREDRA .AND. LDP.LT.M ) THEN INFO = -21 ELSE IF( LDQ.LT.1 .OR. LREDRA .AND. LDQ.LT.M ) THEN INFO = -23 ELSE IF( LDU.LT.1 .OR. LREDRB .AND. LDU.LT.N ) THEN INFO = -25 ELSE IF( LDV.LT.1 .OR. LREDRB .AND. LDV.LT.N ) THEN INFO = -27 ELSE IF( LQUERY ) THEN WRKOPT = MAX( M*N, MINWRK ) IF ( LREDUC ) THEN IF ( .NOT.LREDUB ) THEN CALL DGGES( 'V', 'V', 'N', SELECT, M, A, LDA, D, LDD, $ I, DWORK, DWORK, DWORK, P, LDP, Q, LDQ, $ DWORK, -1, BWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + 3*M ) END IF IF ( .NOT.LREDUA ) THEN CALL DGGES( 'V', 'V', 'N', SELECT, N, B, LDB, E, LDE, $ I, DWORK, DWORK, DWORK, U, LDU, V, LDV, $ DWORK, -1, BWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + 3*N ) END IF END IF DWORK(1) = WRKOPT END IF IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -30 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB04OD', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 ) THEN SCALE = ONE DWORK(1) = ONE IF ( LTRANN ) THEN IF ( LJOBDF ) $ DIF = ONE END IF RETURN END IF WRKOPT = MINWRK SUFWRK = LDWORK.GE.M*N C C STEP 1: Reduce (A,D) and/or (B,E) to generalized Schur form. 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 IF ( LREDUC ) THEN C IF ( .NOT.LREDUB ) THEN C C Reduce (A,D) to generalized Schur form. C Workspace: need MAX(11*M,10*M+23); C prefer larger. C The second term is needed due to an error in DGGES; it would C not be needed for the value 'Not ordered' of SORT argument. C CALL DGGES( 'Vectors left', 'Vectors right', 'Not ordered', $ SELECT, M, A, LDA, D, LDD, I, DWORK, DWORK(M+1), $ DWORK(2*M+1), P, LDP, Q, LDQ, DWORK(3*M+1), $ LDWORK-3*M, BWORK, INFO ) C IF ( INFO.NE.0 ) THEN INFO = 1 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(3*M+1) ) + 3*M ) END IF IF ( .NOT.LREDUA ) THEN C C Reduce (B,E) to generalized Schur form. C Workspace: need MAX(11*N,10*N+23); C prefer larger. C CALL DGGES( 'Vectors left', 'Vectors right', 'Not ordered', $ SELECT, N, B, LDB, E, LDE, I, DWORK, DWORK(N+1), $ DWORK(2*N+1), U, LDU, V, LDV, DWORK(3*N+1), $ LDWORK-3*N, BWORK, INFO ) C IF ( INFO.NE.0 ) THEN INFO = 1 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(3*N+1) ) + 3*N ) END IF END IF C IF (.NOT.LREDUR ) THEN C C Set INFO = 2 if A and/or B are/is not in quasi-triangular form. C IF (.NOT.LREDUA ) THEN I = 1 C 20 CONTINUE IF ( I.LE.M-2 ) THEN IF ( A(I+1,I).NE.ZERO ) THEN IF ( A(I+2,I+1).NE.ZERO ) THEN INFO = 2 RETURN ELSE I = I + 1 END IF END IF I = I + 1 GO TO 20 END IF END IF C IF (.NOT.LREDUB ) THEN I = 1 C 40 CONTINUE IF ( I.LE.N-2 ) THEN IF ( B(I+1,I).NE.ZERO ) THEN IF ( B(I+2,I+1).NE.ZERO ) THEN INFO = 2 RETURN ELSE I = I + 1 END IF END IF I = I + 1 GO TO 40 END IF END IF END IF C C STEP 2: Modify right hand sides (C,F). C IF ( LREDUC ) THEN WRKOPT = MAX( WRKOPT, M*N ) IF ( SUFWRK ) THEN C C Enough workspace for a BLAS 3 calculation. C IF ( LTRANN ) THEN C C Equation (1). C IF ( .NOT.LREDUB ) THEN CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, $ P, LDP, C, LDC, ZERO, DWORK, M ) ELSE CALL DLACPY( 'All', M, N, C, LDC, DWORK, M ) END IF IF ( .NOT.LREDUA ) THEN CALL DGEMM( 'No transpose', 'No transpose', M, N, N, $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) ELSE CALL DLACPY( 'All', M, N, DWORK, M, C, LDC ) END IF IF ( .NOT.LREDUB ) THEN CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, $ P, LDP, F, LDF, ZERO, DWORK, M ) ELSE CALL DLACPY( 'All', M, N, F, LDF, DWORK, M ) END IF IF ( .NOT.LREDUA ) THEN CALL DGEMM( 'No transpose', 'No transpose', M, N, N, $ ONE, DWORK, M, V, LDV, ZERO, F, LDF ) ELSE CALL DLACPY( 'All', M, N, DWORK, M, F, LDF ) END IF ELSE C C Equation (2). C IF ( .NOT.LREDUB ) THEN CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, $ Q, LDQ, C, LDC, ZERO, DWORK, M ) ELSE CALL DLACPY( 'All', M, N, C, LDC, DWORK, M ) END IF IF ( .NOT.LREDUA ) THEN CALL DGEMM( 'No transpose', 'No transpose', M, N, N, $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) ELSE CALL DLACPY( 'All', M, N, DWORK, M, C, LDC ) END IF IF ( .NOT.LREDUB ) THEN CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, $ P, LDP, F, LDF, ZERO, DWORK, M ) ELSE CALL DLACPY( 'All', M, N, F, LDF, DWORK, M ) END IF IF ( .NOT.LREDUA ) THEN CALL DGEMM( 'No transpose', 'No transpose', M, N, N, $ ONE, DWORK, M, U, LDU, ZERO, F, LDF ) ELSE CALL DLACPY( 'All', M, N, DWORK, M, F, LDF ) END IF END IF ELSE C C Use BLAS 3 calculations in a loop. C IF ( LTRANN ) THEN C C Equation (1). C IF ( .NOT.LREDUB ) THEN NBC = LDWORK/M C DO 60 I = 1, N, NBC NC = MIN( NBC, N-I+1 ) CALL DGEMM( 'Transpose', 'No transpose', M, NC, M, $ ONE, P, LDP, C(1,I), LDC, ZERO, DWORK, $ M ) CALL DLACPY( 'All', M, NC, DWORK, M, C(1,I), LDC ) 60 CONTINUE C END IF IF ( .NOT.LREDUA ) THEN NBR = LDWORK/N C DO 80 I = 1, M, NBR NR = MIN( NBR, M-I+1 ) CALL DGEMM( 'No transpose', 'No transpose', NR, N, $ N, ONE, C(I,1), LDC, V, LDV, ZERO, $ DWORK, NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC ) 80 CONTINUE C END IF IF ( .NOT.LREDUB ) THEN C DO 100 I = 1, N, NBC NC = MIN( NBC, N-I+1 ) CALL DGEMM( 'Transpose', 'No transpose', M, NC, M, $ ONE, P, LDP, F(1,I), LDF, ZERO, DWORK, $ M ) CALL DLACPY( 'All', M, NC, DWORK, M, F(1,I), LDF ) 100 CONTINUE C END IF IF ( .NOT.LREDUA ) THEN C DO 120 I = 1, M, NBR NR = MIN( NBR, M-I+1 ) CALL DGEMM( 'No transpose', 'No transpose', NR, N, $ N, ONE, F(I,1), LDF, V, LDV, ZERO, $ DWORK, NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, F(I,1), LDF ) 120 CONTINUE C END IF ELSE C C Equation (2). C IF ( .NOT.LREDUB ) THEN NBC = LDWORK/M C DO 140 I = 1, N, NBC NC = MIN( NBC, N-I+1 ) CALL DGEMM( 'Transpose', 'No transpose', M, NC, M, $ ONE, Q, LDQ, C(1,I), LDC, ZERO, DWORK, $ M ) CALL DLACPY( 'All', M, NC, DWORK, M, C(1,I), LDC ) 140 CONTINUE C END IF IF ( .NOT.LREDUA ) THEN NBR = LDWORK/N C DO 160 I = 1, M, NBR NR = MIN( NBR, M-I+1 ) CALL DGEMM( 'No transpose', 'No transpose', NR, N, $ N, ONE, C(I,1), LDC, V, LDV, ZERO, $ DWORK, NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC ) 160 CONTINUE C END IF IF ( .NOT.LREDUB ) THEN C DO 180 I = 1, N, NBC NC = MIN( NBC, N-I+1 ) CALL DGEMM( 'Transpose', 'No transpose', M, NC, M, $ ONE, P, LDP, F(1,I), LDF, ZERO, DWORK, $ M ) CALL DLACPY( 'All', M, NC, DWORK, M, F(1,I), LDF ) 180 CONTINUE C END IF IF ( .NOT.LREDUA ) THEN C DO 200 I = 1, M, NBR NR = MIN( NBR, M-I+1 ) CALL DGEMM( 'No transpose', 'No transpose', NR, N, $ N, ONE, F(I,1), LDF, U, LDU, ZERO, $ DWORK, NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, F(I,1), LDF ) 200 CONTINUE C END IF END IF END IF END IF C C STEP 3: Solve the transformed system and compute the Dif C estimator. C IF ( LTRANN ) THEN IF ( LJOBD ) THEN IJOB = 1 ELSE IF ( LJOBF ) THEN IJOB = 2 ELSE IF ( LJOB1 ) THEN IJOB = 3 ELSE IF ( LJOB2 ) THEN IJOB = 4 ELSE IJOB = 0 END IF ELSE IJOB = 0 END IF C C Workspace: need 2*M*N if TRANS = 'N' and JOBD = 'D' or 'F'; C 1, otherwise. C CALL DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, $ E, LDE, F, LDF, SCALE, DIF, DWORK, LDWORK, IWORK, $ INFO ) IF ( INFO.NE.0 ) THEN INFO = 3 RETURN END IF C C STEP 4: Back transformation of the solution. C IF ( LREDUC ) THEN IF (SUFWRK ) THEN C C Enough workspace for a BLAS 3 calculation. C IF ( LTRANN ) THEN C C Equation (1). C IF ( .NOT.LREDUB ) THEN CALL DGEMM( 'No transpose', 'No transpose', M, N, M, $ ONE, Q, LDQ, C, LDC, ZERO, DWORK, M ) ELSE CALL DLACPY( 'All', M, N, C, LDC, DWORK, M ) END IF IF ( .NOT.LREDUA ) THEN CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, $ DWORK, M, V, LDV, ZERO, C, LDC ) ELSE CALL DLACPY( 'All', M, N, DWORK, M, C, LDC ) END IF IF ( .NOT.LREDUB ) THEN CALL DGEMM( 'No transpose', 'No transpose', M, N, M, $ ONE, P, LDP, F, LDF, ZERO, DWORK, M ) ELSE CALL DLACPY( 'All', M, N, F, LDF, DWORK, M ) END IF IF ( .NOT.LREDUA ) THEN CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, $ DWORK, M, U, LDU, ZERO, F, LDF ) ELSE CALL DLACPY( 'All', M, N, DWORK, M, F, LDF ) END IF ELSE C C Equation (2). C IF ( .NOT.LREDUB ) THEN CALL DGEMM( 'No transpose', 'No transpose', M, N, M, $ ONE, P, LDP, C, LDC, ZERO, DWORK, M ) ELSE CALL DLACPY( 'All', M, N, C, LDC, DWORK, M ) END IF IF ( .NOT.LREDUA ) THEN CALL DGEMM( 'No transpose', 'Transpose', M, N, N, $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) ELSE CALL DLACPY( 'All', M, N, DWORK, M, C, LDC ) END IF IF ( .NOT.LREDUB ) THEN CALL DGEMM( 'No transpose', 'No transpose', M, N, M, $ ONE, P, LDP, F, LDF, ZERO, DWORK, M ) ELSE CALL DLACPY( 'All', M, N, F, LDF, DWORK, M ) END IF IF ( .NOT.LREDUA ) THEN CALL DGEMM( 'No transpose', 'Transpose', M, N, N, $ ONE, DWORK, M, V, LDV, ZERO, F, LDF ) ELSE CALL DLACPY( 'All', M, N, DWORK, M, F, LDF ) END IF END IF ELSE C C Use BLAS 3 calculations in a loop. C IF ( LTRANN ) THEN C C Equation (1). C IF ( .NOT.LREDUB ) THEN C DO 220 I = 1, N, NBC NC = MIN( NBC, N-I+1 ) CALL DGEMM( 'No transpose', 'No transpose', M, NC, $ M, ONE, Q, LDQ, C(1,I), LDC, ZERO, $ DWORK, M ) CALL DLACPY( 'All', M, NC, DWORK, M, C(1,I), LDC ) 220 CONTINUE C END IF IF ( .NOT.LREDUA ) THEN C DO 240 I = 1, M, NBR NR = MIN( NBR, M-I+1 ) CALL DGEMM( 'No transpose', 'Transpose', NR, N, N, $ ONE, C(I,1), LDC, V, LDV, ZERO, DWORK, $ NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC ) 240 CONTINUE C END IF IF ( .NOT.LREDUB ) THEN C DO 260 I = 1, N, NBC NC = MIN( NBC, N-I+1 ) CALL DGEMM( 'No transpose', 'No transpose', M, NC, $ M, ONE, P, LDP, F(1,I), LDF, ZERO, $ DWORK, M ) CALL DLACPY( 'All', M, NC, DWORK, M, F(1,I), LDF ) 260 CONTINUE C END IF IF ( .NOT.LREDUA ) THEN C DO 280 I = 1, M, NBR NR = MIN( NBR, M-I+1 ) CALL DGEMM( 'No transpose', 'Transpose', NR, N, N, $ ONE, F(I,1), LDF, U, LDU, ZERO, DWORK, $ NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, F(I,1), LDF ) 280 CONTINUE C END IF ELSE C C Equation (2). C IF ( .NOT.LREDUB ) THEN C DO 300 I = 1, N, NBC NC = MIN( NBC, N-I+1 ) CALL DGEMM( 'No transpose', 'No transpose', M, NC, $ M, ONE, P, LDP, C(1,I), LDC, ZERO, $ DWORK, M ) CALL DLACPY( 'All', M, NC, DWORK, M, C(1,I), LDC ) 300 CONTINUE C END IF IF ( .NOT.LREDUA ) THEN C DO 320 I = 1, M, NBR NR = MIN( NBR, M-I+1 ) CALL DGEMM( 'No transpose', 'Transpose', NR, N, N, $ ONE, C(I,1), LDC, V, LDV, ZERO, DWORK, $ NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC ) 320 CONTINUE C END IF IF ( .NOT.LREDUB ) THEN C DO 340 I = 1, N, NBC NC = MIN( NBC, N-I+1 ) CALL DGEMM( 'No transpose', 'No transpose', M, NC, $ M, ONE, P, LDP, F(1,I), LDF, ZERO, $ DWORK, M ) CALL DLACPY( 'All', M, NC, DWORK, M, F(1,I), LDF ) 340 CONTINUE C END IF IF ( .NOT.LREDUA ) THEN C DO 360 I = 1, M, NBR NR = MIN( NBR, M-I+1 ) CALL DGEMM( 'No transpose', 'Transpose', NR, N, N, $ ONE, F(I,1), LDF, V, LDV, ZERO, DWORK, $ NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, F(I,1), LDF ) 360 CONTINUE C END IF END IF END IF END IF C DWORK(1) = WRKOPT C RETURN C *** Last line of SB04OD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03QD.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03QD.f0000644000175000017500000002551115012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA, $ A, LDA, U, LDU, NDIM, DWORK, INFO ) 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 control-4.1.2/src/slicot/src/PaxHeaders/MB02TZ.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02TZ.f0000644000175000017500000001455215012430707017416 0ustar00lilgelilge00000000000000 SUBROUTINE MB02TZ( NORM, N, HNORM, H, LDH, IPIV, RCOND, DWORK, $ ZWORK, INFO ) C C PURPOSE C C To estimate the reciprocal of the condition number of a complex C upper Hessenberg matrix H, in either the 1-norm or the C infinity-norm, using the LU factorization computed by MB02SZ. C C ARGUMENTS C C Mode Parameters C C NORM CHARACTER*1 C Specifies whether the 1-norm condition number or the C infinity-norm condition number is required: C = '1' or 'O': 1-norm; C = 'I': Infinity-norm. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix H. N >= 0. C C HNORM (input) DOUBLE PRECISION C If NORM = '1' or 'O', the 1-norm of the original matrix H. C If NORM = 'I', the infinity-norm of the original matrix H. C C H (input) COMPLEX*16 array, dimension (LDH,N) C The factors L and U from the factorization H = P*L*U C as computed by MB02SZ. C C LDH INTEGER C The leading dimension of the array H. LDH >= max(1,N). C C IPIV (input) INTEGER array, dimension (N) C The pivot indices; for 1 <= i <= N, row i of the matrix C was interchanged with row IPIV(i). C C RCOND (output) DOUBLE PRECISION C The reciprocal of the condition number of the matrix H, C computed as RCOND = 1/(norm(H) * norm(inv(H))). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (N) C C ZWORK COMPLEX*16 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 C METHOD C C An estimate is obtained for norm(inv(H)), and the reciprocal of C the condition number is computed as C RCOND = 1 / ( norm(H) * norm(inv(H)) ). C C REFERENCES C C - C C NUMERICAL ASPECTS C 2 C The algorithm requires 0( N ) complex operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TB01FY by A.J. Laub, University of C Southern California, United States of America, May 1980. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2005. C C KEYWORDS C C Frequency response, Hessenberg form, matrix algebra. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. Scalar Arguments .. CHARACTER NORM INTEGER INFO, LDH, N DOUBLE PRECISION HNORM, RCOND C .. C .. Array Arguments .. INTEGER IPIV(*) DOUBLE PRECISION DWORK( * ) COMPLEX*16 H( LDH, * ), ZWORK( * ) C .. Local Scalars .. LOGICAL ONENRM CHARACTER NORMIN INTEGER IX, J, JP, KASE, KASE1 C DOUBLE PRECISION HINVNM, SCALE, SMLNUM COMPLEX*16 T, ZDUM C .. C .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, IZAMAX, LSAME C .. C .. External Subroutines .. EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATRS C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX C .. C .. Statement Functions .. DOUBLE PRECISION CABS1 C .. C .. Statement Function definitions .. CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( HNORM.LT.ZERO ) THEN INFO = -3 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02TZ', -INFO ) RETURN END IF C C Quick return if possible. C RCOND = ZERO IF( N.EQ.0 ) THEN RCOND = ONE RETURN ELSE IF( HNORM.EQ.ZERO ) THEN RETURN END IF C SMLNUM = DLAMCH( 'Safe minimum' ) C C Estimate the norm of inv(H). C HINVNM = ZERO NORMIN = 'N' IF( ONENRM ) THEN KASE1 = 1 ELSE KASE1 = 2 END IF KASE = 0 10 CONTINUE CALL ZLACON( N, ZWORK( N+1 ), ZWORK, HINVNM, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN C C Multiply by inv(L). C DO 20 J = 1, N - 1 JP = IPIV( J ) T = ZWORK( JP ) IF( JP.NE.J ) THEN ZWORK( JP ) = ZWORK( J ) ZWORK( J ) = T END IF ZWORK( J+1 ) = ZWORK( J+1 ) - T * H( J+1, J ) 20 CONTINUE C C Multiply by inv(U). C CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, $ H, LDH, ZWORK, SCALE, DWORK, INFO ) ELSE C C Multiply by inv(U'). C CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', $ NORMIN, N, H, LDH, ZWORK, SCALE, DWORK, INFO ) C C Multiply by inv(L'). C DO 30 J = N - 1, 1, -1 ZWORK( J ) = ZWORK( J ) - $ DCONJG( H( J+1, J ) ) * ZWORK( J+1 ) JP = IPIV( J ) IF( JP.NE.J ) THEN T = ZWORK( JP ) ZWORK( JP ) = ZWORK( J ) ZWORK( J ) = T END IF 30 CONTINUE END IF C C Divide X by 1/SCALE if doing so will not cause overflow. C NORMIN = 'Y' IF( SCALE.NE.ONE ) THEN IX = IZAMAX( N, ZWORK, 1 ) IF( SCALE.LT.CABS1( ZWORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO $ ) GO TO 40 CALL ZDRSCL( N, SCALE, ZWORK, 1 ) END IF GO TO 10 END IF C C Compute the estimate of the reciprocal condition number. C IF( HINVNM.NE.ZERO ) $ RCOND = ( ONE / HINVNM ) / HNORM C 40 CONTINUE RETURN C *** Last line of MB02TZ *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09IX.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB09IX.f0000644000175000017500000005772615012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE AB09IX( DICO, JOB, FACT, ORDSEL, N, M, P, NR, $ SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD, $ TI, LDTI, T, LDT, NMINR, HSV, TOL1, TOL2, $ IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for an original C state-space representation (A,B,C,D) by using the square-root or C balancing-free square-root Balance & Truncate (B&T) or C Singular Perturbation Approximation (SPA) model reduction methods. C The computation of truncation matrices TI and T is based on C the Cholesky factor S of a controllability Grammian P = S*S' C and the Cholesky factor R of an observability Grammian Q = R'*R, C where S and R are given upper triangular matrices. C C For the B&T approach, the matrices of the reduced order system C are computed using the truncation formulas: C C Ar = TI * A * T , Br = TI * B , Cr = C * T . (1) C C For the SPA approach, the matrices of a minimal realization C (Am,Bm,Cm) are computed using the truncation formulas: C C Am = TI * A * T , Bm = TI * B , Cm = C * T . (2) C C Am, Bm, Cm and D serve further for computing the SPA of the given C system. 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 JOB CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root B&T method; C = 'F': use the balancing-free square-root B&T method; C = 'S': use the square-root SPA method; C = 'P': use the balancing-free square-root SPA method. C C FACT CHARACTER*1 C Specifies whether or not, on entry, the matrix A is in a C real Schur form, as follows: C = 'S': A is in a real Schur form; C = 'N': A is a general dense square matrix. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e., the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of C the resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. NR is set as follows: C if ORDSEL = 'F', NR is equal to MIN(NR,NMINR), where NR C is the desired order on entry and NMINR is the number of C the Hankel singular values greater than N*EPS*S1, where C EPS is the machine precision (see LAPACK Library Routine C DLAMCH) and S1 is the largest Hankel singular value C (computed in HSV(1)); C NR can be further reduced to ensure HSV(NR) > HSV(NR+1); C if ORDSEL = 'A', NR is equal to the number of Hankel C singular values greater than MAX(TOL1,N*EPS*S1). C C SCALEC (input) DOUBLE PRECISION C Scaling factor for the Cholesky factor S of the C controllability Grammian, i.e., S/SCALEC is used to C compute the Hankel singular values. SCALEC > 0. C C SCALEO (input) DOUBLE PRECISION C Scaling factor for the Cholesky factor R of the C observability Grammian, i.e., R/SCALEO is used to C compute the Hankel singular values. SCALEO > 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 A. If FACT = 'S', C A is in a real Schur form. C On exit, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the C reduced order system. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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, if JOB = 'S' or JOB = 'P', the leading P-by-M C part of this array must contain the original input/output C matrix D. C On exit, if INFO = 0 and JOB = 'S' or JOB = 'P', the C leading P-by-M part of this array contains the C input/output matrix Dr of the reduced order system. C If JOB = 'B' or JOB = 'F', this array is not referenced. C C LDD INTEGER C The leading dimension of array D. C LDD >= 1, if JOB = 'B' or JOB = 'F'; C LDD >= MAX(1,P), if JOB = 'S' or JOB = 'P'. C C TI (input/output) DOUBLE PRECISION array, dimension (LDTI,N) C On entry, the leading N-by-N upper triangular part of C this array must contain the Cholesky factor S of a C controllability Grammian P = S*S'. C On exit, if INFO = 0, and NR > 0, the leading NMINR-by-N C part of this array contains the left truncation matrix C TI in (1), for the B&T approach, or in (2), for the C SPA approach. C C LDTI INTEGER C The leading dimension of array TI. LDTI >= MAX(1,N). C C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) C On entry, the leading N-by-N upper triangular part of C this array must contain the Cholesky factor R of an C observability Grammian Q = R'*R. C On exit, if INFO = 0, and NR > 0, the leading N-by-NMINR C part of this array contains the right truncation matrix C T in (1), for the B&T approach, or in (2), for the C SPA approach. C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,N). C C NMINR (output) INTEGER C The number of Hankel singular values greater than C MAX(TOL2,N*EPS*S1). C Note: If S and R are the Cholesky factors of the C controllability and observability Grammians of the C original system (A,B,C,D), respectively, then NMINR is C the order of a minimal realization of the original system. C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, it contains the Hankel singular values, C ordered decreasingly. The Hankel singular values are C singular values of the product R*S. C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of the reduced system. C For model reduction, the recommended value lies in the C interval [0.00001,0.001]. C If TOL1 <= 0 on entry, the used default value is C TOL1 = N*EPS*S1, where EPS is the machine precision C (see LAPACK Library Routine DLAMCH) and S1 is the largest C Hankel singular value (computed in HSV(1)). C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the system. C The recommended value is TOL2 = N*EPS*S1. C This value is used by default if TOL2 <= 0 on entry. C If TOL2 > 0, and ORDSEL = 'A', then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension (LIWORK), where C LIWORK = 0, if JOB = 'B'; C LIWORK = N, if JOB = 'F'; C LIWORK = 2*N, if JOB = 'S' or '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, 2*N*N + 5*N, N*MAX(M,P) ). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than NMINR, the order of a minimal realization of C the given system; in this case, the resulting NR is C set automatically to NMINR; C = 2: with ORDSEL = 'F', the selected order NR corresponds C to repeated singular values, which are neither all C included nor all excluded from the reduced model; C in this case, the resulting NR is set automatically C to the largest value such that HSV(NR) > HSV(NR+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: the computation of Hankel singular values failed. C C METHOD C C Let be the stable linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t), (3) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09IX determines for C the given system (3), the matrices of a reduced NR order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t), (4) C C by using the square-root or balancing-free square-root C Balance & Truncate (B&T) or Singular Perturbation Approximation C (SPA) model reduction methods. C C The projection matrices TI and T are determined using the C Cholesky factors S and R of a controllability Grammian P and an C observability Grammian Q. C The Hankel singular values HSV(1), ...., HSV(N) are computed as C singular values of the product R*S. C C If JOB = 'B', the square-root Balance & Truncate technique C of [1] is used. C C If JOB = 'F', the balancing-free square-root version of the C Balance & Truncate technique [2] is used. C C If JOB = 'S', the square-root version of the Singular Perturbation C Approximation method [3,4] is used. C C If JOB = 'P', the balancing-free square-root version of the C Singular Perturbation Approximation method [3,4] is used. C C REFERENCES C C [1] Tombs M.S. and Postlethwaite I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C [2] Varga A. C Efficient minimal realization procedure based on balancing. C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, C A. El Moudni, P. Borne, S. G. Tzafestas (Eds.), C Vol. 2, pp. 42-46. C C [3] Liu Y. and Anderson B.D.O. C Singular Perturbation Approximation of balanced systems. C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. C C [4] Varga A. C Balancing-free square-root algorithm for computing singular C perturbation approximations. C Proc. 30-th CDC, Brighton, Dec. 11-13, 1991, C Vol. 2, pp. 1062-1065. C C NUMERICAL ASPECTS C C The implemented method relies on accuracy enhancing square-root C or balancing-free square-root methods. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. C D. Sima, University of Bucharest, August 2000. C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, C Sep. 2001. C C KEYWORDS C C Balance and truncate, minimal state-space representation, C model reduction, multivariable system, C singular perturbation approximation, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, FACT, JOB, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, $ LDWORK, M, N, NMINR, NR, P DOUBLE PRECISION SCALEC, SCALEO, TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) C .. Local Scalars .. LOGICAL BAL, BTA, DISCR, FIXORD, RSF, SPA INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, LW, $ NRED, NR1, NS, WRKOPT DOUBLE PRECISION ATOL, RCOND, SKP, TEMP, TOLDEF C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB09DD, DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, $ DLACPY, DORGQR, DSCAL, DTRMM, DTRMV, MA02AD, $ MB03UD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) RSF = LSAME( FACT, 'S' ) FIXORD = LSAME( ORDSEL, 'F' ) C LW = MAX( 1, 2*N*N + 5*N, N*MAX( M, P ) ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN INFO = -2 ELSE IF( .NOT. ( RSF .OR. LSAME( FACT, 'N' ) ) ) THEN INFO = -3 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) 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( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -8 ELSE IF( SCALEC.LE.ZERO ) THEN INFO = -9 ELSE IF( SCALEO.LE.ZERO ) THEN INFO = -10 ELSE IF( LDA.LT.MAX( 1, 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. ( SPA .AND. LDD.LT.P ) ) THEN INFO = -18 ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN INFO = -20 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -22 ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN INFO = -26 ELSE IF( LDWORK.LT.LW ) THEN INFO = -29 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09IX', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 NMINR = 0 DWORK(1) = ONE RETURN END IF C C Save S in DWORK(KV). C KV = 1 KU = KV + N*N KW = KU + N*N CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) C | x x | C Compute R*S in the form | 0 x | in TI. C DO 10 J = 1, N CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, $ TI(1,J), 1 ) 10 CONTINUE C C Compute the singular value decomposition R*S = V*Sigma*UT of the C upper triangular matrix R*S, with UT in TI and V in DWORK(KU). C C Workspace: need 2*N*N + 5*N; C prefer larger. C CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN ENDIF WRKOPT = INT( DWORK(KW) ) + KW - 1 C C Scale the singular values. C CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) C C Partition Sigma, U and V conformally as: C C Sigma = diag(Sigma1,Sigma2,Sigma3), U = [U1,U2,U3] (U' in TI) and C V = [V1,V2,V3] (in DWORK(KU)). C C Compute NMINR, the order of a minimal realization, as the order C of [Sigma1 Sigma2]. C TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) ATOL = MAX( TOL2, TOLDEF*HSV(1) ) NMINR = N 20 IF( NMINR.GT.0 ) THEN IF( HSV(NMINR).LE.ATOL ) THEN NMINR = NMINR - 1 GO TO 20 END IF END IF C C Compute the order NR of reduced system, as the order of Sigma1. C IF( FIXORD ) THEN C C Check if the desired order is less than the order of a minimal C realization. C IF( NR.GT.NMINR ) THEN C C Reduce the order to NMINR. C NR = NMINR IWARN = 1 END IF C C Check for singular value multiplicity at cut-off point. C IF( NR.GT.0 .AND. NR.LT.NMINR ) THEN SKP = HSV(NR) IF( SKP-HSV(NR+1).LE.TOLDEF*SKP ) THEN IWARN = 2 C C Reduce the order such that HSV(NR) > HSV(NR+1). C 30 NR = NR - 1 IF( NR.GT.0 ) THEN IF( HSV(NR)-SKP.LE.TOLDEF*SKP ) GO TO 30 END IF END IF END IF ELSE C C The order is given as the number of singular values C exceeding MAX( TOL1, N*EPS*HSV(1) ). C ATOL = MAX( TOL1, ATOL ) NR = 0 DO 40 J = 1, NMINR IF( HSV(J).LE.ATOL ) GO TO 50 NR = NR + 1 40 CONTINUE 50 CONTINUE ENDIF C C Finish if the order is zero. C IF( NR.EQ.0 ) THEN IF( SPA ) $ CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, $ D, LDD, RCOND, IWORK, DWORK, IERR ) DWORK(1) = WRKOPT RETURN END IF C C Compute NS, the order of Sigma2. For BTA, NS = 0. C IF( SPA ) THEN NRED = NMINR ELSE NRED = NR END IF NS = NRED - NR C C Compute the truncation matrices. C C Compute TI' = | TI1' TI2' | = R'*| V1 V2 | in DWORK(KU). C CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NRED, $ ONE, T, LDT, DWORK(KU), N ) C C Compute T = | T1 T2 | = S*| U1 U2 | . C CALL MA02AD( 'Full', NRED, N, TI, LDTI, T, LDT ) CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, $ NRED, ONE, DWORK(KV), N, T, LDT ) C KTAU = KW IF( BAL ) THEN IJ = KU C C Square-Root B&T/SPA method. C C Compute the truncation matrices for balancing C -1/2 -1/2 C T1*Sigma1 and TI1'*Sigma1 . C DO 60 J = 1, NR TEMP = ONE/SQRT( HSV(J) ) CALL DSCAL( N, TEMP, T(1,J), 1 ) CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) IJ = IJ + N 60 CONTINUE C ELSE C C Balancing-Free B&T/SPA method. C C Compute orthogonal bases for the images of matrices T1 and C TI1'. C C Workspace: need 2*N*N + 2*N; C prefer larger. C KW = KTAU + NR LDW = LDWORK - KW + 1 CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, $ IERR ) CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), $ LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) ENDIF C IF( NS.GT.0 ) THEN C C Compute orthogonal bases for the images of matrices T2 and C TI2'. C C Workspace: need 2*N*N + 2*N; C prefer larger. C NR1 = NR + 1 KW = KTAU + NS LDW = LDWORK - KW + 1 CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, $ IERR ) CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), $ LDW, IERR ) CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), $ LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), $ DWORK(KW), LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) ENDIF C C Transpose TI' in TI. C CALL MA02AD( 'Full', N, NRED, DWORK(KU), N, TI, LDTI ) C IF( .NOT.BAL ) THEN C -1 C Compute (TI1*T1) *TI1 in TI. C CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, $ LDTI, T, LDT, ZERO, DWORK(KU), N ) CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, $ LDTI, IERR ) C IF( NS.GT.0 ) THEN C -1 C Compute (TI2*T2) *TI2 in TI2. C CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), $ N ) CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, $ TI(NR1,1), LDTI, IERR ) END IF END IF C C Compute TI*A*T. Exploit RSF of A if possible. C Workspace: need N*N. C IF( RSF ) THEN IJ = 1 DO 80 J = 1, N K = MIN( J+1, N ) CALL DGEMV( 'NoTranspose', NRED, K, ONE, TI, LDTI, $ A(1,J), 1, ZERO, DWORK(IJ), 1 ) IJ = IJ + N 80 CONTINUE ELSE CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, N, N, ONE, $ TI, LDTI, A, LDA, ZERO, DWORK, N ) END IF CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, NRED, N, ONE, $ DWORK, N, T, LDT, ZERO, A, LDA ) C C Compute TI*B and C*T. C Workspace: need N*MAX(M,P). C CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, M, N, ONE, TI, $ LDTI, DWORK, N, ZERO, B, LDB ) C CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NRED, N, ONE, $ DWORK, P, T, LDT, ZERO, C, LDC ) C C Compute the singular perturbation approximation if possible. C Note that IERR = 1 on exit from AB09DD cannot appear here. C C Workspace: need real 4*(NMINR-NR); C need integer 2*(NMINR-NR). C IF( SPA) THEN CALL AB09DD( DICO, NRED, M, P, NR, A, LDA, B, LDB, $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) ELSE NMINR = NR END IF DWORK(1) = WRKOPT C RETURN C *** Last line of AB09IX *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09MD.f0000644000000000000000000000013215012430707016151 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB09MD.f0000644000175000017500000004030515012430707017347 0ustar00lilgelilge00000000000000 SUBROUTINE AB09MD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, $ A, LDA, B, LDB, C, LDC, NS, HSV, TOL, IWORK, $ DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr) for an original C state-space representation (A,B,C) by using either the square-root C or the balancing-free square-root Balance & Truncate (B & T) C model reduction method for the ALPHA-stable part of the system. 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 JOB CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root Balance & Truncate method; C = 'N': use the balancing-free square-root C Balance & Truncate method. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of the C resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. For a system with NU ALPHA-unstable C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), C NR is set as follows: if ORDSEL = 'F', NR is equal to C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order C on entry, and NMIN is the order of a minimal realization C of the ALPHA-stable part of the given system; NMIN is C determined as the number of Hankel singular values greater C than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine C precision (see LAPACK Library Routine DLAMCH) and C HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable C part of the given system (computed in HSV(1)); C if ORDSEL = 'A', NR is the sum of NU and the number of C Hankel singular values greater than C MAX(TOL,NS*EPS*HNORM(As,Bs,Cs)). C C ALPHA (input) DOUBLE PRECISION C Specifies the ALPHA-stability boundary for the eigenvalues C of the state dynamics matrix A. For a continuous-time C system (DICO = 'C'), ALPHA <= 0 is the boundary value for C the real parts of eigenvalues, while for a discrete-time C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the C boundary value for the moduli of eigenvalues. C The ALPHA-stability domain does not include the boundary. 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, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the reduced C order system. C The resulting A has a block-diagonal form with two blocks. C For a system with NU ALPHA-unstable eigenvalues and C NS ALPHA-stable eigenvalues (NU+NS = N), the leading C NU-by-NU block contains the unreduced part of A C corresponding to ALPHA-unstable eigenvalues in an C upper real Schur form. C The trailing (NR+NS-N)-by-(NR+NS-N) block contains C the reduced part of A corresponding to ALPHA-stable C eigenvalues. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C NS (output) INTEGER C The dimension of the ALPHA-stable subsystem. C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, the leading NS elements of HSV contain the C Hankel singular values of the ALPHA-stable part of the C original system ordered decreasingly. C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. C C Tolerances C C TOL DOUBLE PRECISION C If ORDSEL = 'A', TOL contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL = c*HNORM(As,Bs,Cs), where c is a constant in the C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the C Hankel-norm of the ALPHA-stable part of the given system C (computed in HSV(1)). C If TOL <= 0 on entry, the used default value is C TOL = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of C ALPHA-stable eigenvalues of A and EPS is the machine C precision (see LAPACK Library Routine DLAMCH). C This value is appropriate to compute a minimal realization C of the ALPHA-stable part. C If ORDSEL = 'F', the value of TOL is ignored. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = 0, if JOB = 'B'; C LIWORK = N, if JOB = 'N'. 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,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than NSMIN, the sum of the order of the C ALPHA-unstable part and the order of a minimal C realization of the ALPHA-stable part of the given C system. In this case, the resulting NR is set equal C to NSMIN. C = 2: with ORDSEL = 'F', the selected order NR is less C than the order of the ALPHA-unstable part of the C given system. In this case NR is set equal to the C order of the ALPHA-unstable part. 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 computation of the ordered real Schur form of A C failed; C = 2: the separation of the ALPHA-stable/unstable diagonal C blocks failed because of very close eigenvalues; C = 3: the computation of Hankel singular values failed. C C METHOD C C Let be the following linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09MD determines for C the given system (1), the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) (2) C C such that C C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], C C where G and Gr are transfer-function matrices of the systems C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the C infinity-norm of G. C C The following procedure is used to reduce a given G: C C 1) Decompose additively G as C C G = G1 + G2 C C such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. C C 2) Determine G1r, a reduced order approximation of the C ALPHA-stable part G1. C C 3) Assemble the reduced model Gr as C C Gr = G1r + G2. C C To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root C Balance & Truncate method of [1] is used, and for an ALPHA-stable C continuous-time system (DICO = 'C'), the resulting reduced model C is balanced. For ALPHA-stable systems, setting TOL < 0, the C routine can be used to compute balanced minimal state-space C realizations. C C If JOB = 'N', the balancing-free square-root version of the C Balance & Truncate method [2] is used to reduce the ALPHA-stable C part G1. C C REFERENCES C C [1] Tombs M.S. and Postlethwaite I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C [2] Varga A. C Efficient minimal realization procedure based on balancing. C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), C Vol. 2, pp. 42-46. C C NUMERICAL ASPECTS C C The implemented methods rely on accuracy enhancing square-root or C balancing-free square-root techniques. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C February 1999. Based on the RASP routines SADSDC, SRBT and SRBFT. C C REVISIONS C C Mar. 1999, V. Sima, Research Institute for Informatics, Bucharest. C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. C C KEYWORDS C C Balancing, minimal realization, model reduction, multivariable C system, state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, C100 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, JOB, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NR, $ NS, P DOUBLE PRECISION ALPHA, TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) C .. Local Scalars .. LOGICAL DISCR, FIXORD INTEGER IERR, IWARNL, KT, KTI, KU, KW, KWI, KWR, LWR, $ NN, NRA, NU, NU1, WRKOPT DOUBLE PRECISION ALPWRK, MAXRED C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB09AX, TB01ID, TB01KD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) FIXORD = LSAME( ORDSEL, 'F' ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -3 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) 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( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -8 ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN INFO = -9 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + $ ( N*( N + 1 ) )/2 ) ) THEN INFO = -21 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09MD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 DWORK(1) = ONE RETURN END IF C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C Workspace: N. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Correct the value of ALPHA to ensure stability. C ALPWRK = ALPHA IF( DISCR ) THEN IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) ELSE IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) END IF C C Allocate working storage. C NN = N*N KU = 1 KWR = KU + NN KWI = KWR + N KW = KWI + N LWR = LDWORK - KW + 1 C C Reduce A to a block-diagonal real Schur form, with the C ALPHA-unstable part in the leading diagonal position, using a C non-orthogonal similarity transformation A <- inv(T)*A*T and C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. C C Workspace needed: N*(N+2); C Additional workspace: need 3*N; C prefer larger. C CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), $ DWORK(KWI), DWORK(KW), LWR, IERR ) C IF( IERR.NE.0 ) THEN IF( IERR.NE.3 ) THEN INFO = 1 ELSE INFO = 2 END IF RETURN END IF C WRKOPT = DWORK(KW) + DBLE( KW-1 ) C IWARNL = 0 NS = N - NU IF( FIXORD ) THEN NRA = MAX( 0, NR-NU ) IF( NR.LT.NU ) $ IWARNL = 2 ELSE NRA = 0 END IF C C Finish if only unstable part is present. C IF( NS.EQ.0 ) THEN NR = NU DWORK(1) = WRKOPT RETURN END IF C NU1 = NU + 1 C C Allocate working storage. C KT = 1 KTI = KT + NN KW = KTI + NN C C Compute a B & T approximation of the stable part. C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; C prefer larger. C CALL AB09AX( DICO, JOB, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, $ B(NU1,1), LDB, C(1,NU1), LDC, HSV, DWORK(KT), N, $ DWORK(KTI), N, TOL, IWORK, DWORK(KW), LDWORK-KW+1, $ IWARN, IERR ) IWARN = MAX( IWARN, IWARNL ) C IF( IERR.NE.0 ) THEN INFO = IERR + 1 RETURN END IF C NR = NRA + NU C DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C RETURN C *** Last line of AB09MD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01OA.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01OA.f0000644000175000017500000001243115012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE TG01OA( JOBE, N, DCBA, LDDCBA, E, LDE, INFO ) C C PURPOSE C C To compute for a single-input single-output descriptor system, C given by the system matrix C C [ D C ] C [ B A - s*E ], C C with E upper triangular, a transformed system, (Q'*A*Z, Q'*E*Z, C Q'*B, C*Z), via an orthogonal equivalence transformation, so that C Q'*B has only the first element nonzero and Q'*E*Z remains upper C triangular. C C ARGUMENTS C C Mode Parameters C C JOBE CHARACTER*1 C Specifies whether E is an upper triangular or an identity C matrix, as follows: C = 'U': The matrix E is an upper triangular matrix; C = 'I': The matrix E is assumed identity and is not given. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the descriptor state vector; also the C order of square matrices A and E, the number of rows of C matrix B, and the number of columns of matrix C. N >= 0. C C DCBA (input/output) DOUBLE PRECISION array, dimension C (LDDCBA,N+1) C On entry, the leading (N+1)-by-(N+1) part of this array C must contain the original system matrices A, B, C, and D, C stored as follows C C [ D C ] C [ B A ]. C C On exit, the leading (N+1)-by-(N+1) part of this array C contains the transformed matrices C*Z, Q'*B, and Q'*A*Z, C replacing C, B, and A. The scalar D is unchanged. C C LDDCBA INTEGER C The leading dimension of the array DCBA. C LDDCBA >= N+1. C C E (input/output) DOUBLE PRECISION array, dimension (LDE,*) C On entry, if JOBE = 'U', the leading N-by-N upper C triangular part of this array must contain the upper C triangular part of the descriptor matrix E. The lower C triangular part under the first subdiagonal is not C referenced. C On exit, if JOBE = 'U', the leading N-by-N upper C triangular part of this array contains the upper C triangular part of the transformed descriptor matrix, C Q'*E*Z. C If JOBE = 'I', this array is not referenced. C C LDE INTEGER C The leading dimension of the array E. C LDE >= MAX(1,N), if JOBE = 'U'; C LDE >= 1, if JOBE = '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 METHOD C C Givens rotations are used to annihilate the last N-1 elements of B C in reverse order, but preserve the form of E. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C V. Sima, May 2021. C C REVISIONS C C - C C KEYWORDS C C Controllability, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER JOBE INTEGER INFO, LDDCBA, LDE, N C .. Array Arguments .. DOUBLE PRECISION DCBA(LDDCBA,*), E(LDE,*) C .. Local Scalars .. LOGICAL UNITE INTEGER K, N1 DOUBLE PRECISION CS, SN, TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARTG, DROT, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C UNITE = LSAME( JOBE, 'I' ) INFO = 0 N1 = N + 1 C C Test the input scalar arguments. C IF ( .NOT.UNITE .AND. .NOT.LSAME( JOBE, 'U' ) ) THEN INFO = -1 ELSE IF ( N.LT.0 ) THEN INFO = -2 ELSE IF ( LDDCBA.LT.N1 ) THEN INFO = -4 ELSE IF ( LDE.LT.1 .OR. ( .NOT.UNITE .AND. LDE.LT.MAX( 1, N ) ) ) $ THEN INFO = -6 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01OA', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.LE.1 ) $ RETURN C DO 10 K = N, 2, -1 IF ( DCBA(K+1,1).NE.ZERO ) THEN CALL DLARTG( DCBA(K,1), DCBA(K+1,1), CS, SN, TEMP ) DCBA(K,1) = TEMP DCBA(K+1,1) = ZERO CALL DROT( N, DCBA(K,2), LDDCBA, DCBA(K+1,2), LDDCBA, CS, SN $ ) IF ( UNITE ) THEN CALL DROT( N1, DCBA(1,K), 1, DCBA(1,K+1), 1, CS, SN ) ELSE E(K,K-1) = SN*E(K-1,K-1) E(K-1,K-1) = CS*E(K-1,K-1) CALL DROT( N-K+1, E(K-1,K), LDE, E(K,K), LDE, CS, SN ) IF ( E(K,K-1).NE.ZERO ) THEN CALL DLARTG( E(K,K), E(K,K-1), CS, SN, TEMP ) E(K,K) = TEMP E(K,K-1) = ZERO CALL DROT( K-1, E(1,K-1), 1, E(1,K), 1, CS, SN ) CALL DROT( N1, DCBA(1,K), 1, DCBA(1,K+1), 1, CS, SN ) END IF END IF END IF 10 CONTINUE C RETURN C *** Last line of TG01OA *** END control-4.1.2/src/slicot/src/PaxHeaders/AB01OD.f0000644000000000000000000000013215012430707016143 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB01OD.f0000644000175000017500000004672415012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE AB01OD( STAGES, JOBU, JOBV, N, M, A, LDA, B, LDB, U, $ LDU, V, LDV, NCONT, INDCON, KSTAIR, TOL, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To reduce the matrices A and B using (and optionally accumulating) C state-space and input-space transformations U and V respectively, C such that the pair of matrices C C Ac = U' * A * U, Bc = U' * B * V C C are in upper "staircase" form. Specifically, C C [ Acont * ] [ Bcont ] C Ac = [ ], Bc = [ ], C [ 0 Auncont ] [ 0 ] C C and C C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] C Acont = [ . . . . . . . ], Bc = [ . ], C [ . . . . . . ] [ . ] C [ . . . . . ] [ . ] C [ 0 0 . . . Ap,p-1 App ] [ 0 ] C C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and C p is the controllability index of the pair. The size of the C block Auncont is equal to the dimension of the uncontrollable C subspace of the pair (A, B). The first stage of the reduction, C the "forward" stage, accomplishes the reduction to the orthogonal C canonical form (see SLICOT library routine AB01ND). The blocks C B1, A21, ..., Ap,p-1 are further reduced in a second, "backward" C stage to upper triangular form using RQ factorization. Each of C these stages is optional. C C ARGUMENTS C C Mode Parameters C C STAGES CHARACTER*1 C Specifies the reduction stages to be performed as follows: C = 'F': Perform the forward stage only; C = 'B': Perform the backward stage only; C = 'A': Perform both (all) stages. C C JOBU CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix U the state-space transformations as follows: C = 'N': Do not form U; C = 'I': U is internally initialized to the unit matrix (if C STAGES <> 'B'), or updated (if STAGES = 'B'), and C the orthogonal transformation matrix U is C returned. C C JOBV CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix V the input-space transformations as follows: C = 'N': Do not form V; C = 'I': V is initialized to the unit matrix and the C orthogonal transformation matrix V is returned. C JOBV is not referenced if STAGES = 'F'. C C Input/Output Parameters C C N (input) INTEGER C The actual state dimension, i.e. the order of the C matrix A. N >= 0. C C M (input) INTEGER C The actual input dimension. 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 state transition matrix A to be transformed. C If STAGES = 'B', A should be in the orthogonal canonical C form, as returned by SLICOT library routine AB01ND. C On exit, the leading N-by-N part of this array contains C the transformed state transition matrix U' * A * U. C The leading NCONT-by-NCONT part contains the upper block C Hessenberg state matrix Acont in Ac, given by U' * A * U, C of a controllable realization for the original system. C The elements below the first block-subdiagonal are set to C zero. If STAGES <> 'F', the subdiagonal blocks of A are C triangularized by RQ factorization, and the annihilated C elements are explicitly zeroed. 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 matrix B to be transformed. C If STAGES = 'B', B should be in the orthogonal canonical C form, as returned by SLICOT library routine AB01ND. C On exit with STAGES = 'F', the leading N-by-M part of C this array contains the transformed input matrix U' * B, C with all elements but the first block set to zero. C On exit with STAGES <> 'F', the leading N-by-M part of C this array contains the transformed input matrix C U' * B * V, with all elements but the first block set to C zero and the first block in upper triangular form. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) C If STAGES <> 'B' or JOBU = 'N', then U need not be set C on entry. C If STAGES = 'B' and JOBU = 'I', then, on entry, the C leading N-by-N part of this array must contain the C transformation matrix U that reduced the pair to the C orthogonal canonical form. C On exit, if JOBU = 'I', the leading N-by-N part of this C array contains the transformation matrix U that performed C the specified reduction. C If JOBU = 'N', the array U is not referenced and can be C supplied as a dummy array (i.e. set parameter LDU = 1 and C declare this array to be U(1,1) in the calling program). C C LDU INTEGER C The leading dimension of array U. C If JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. C C V (output) DOUBLE PRECISION array, dimension (LDV,M) C If JOBV = 'I', then the leading M-by-M part of this array C contains the transformation matrix V. C If STAGES = 'F', or JOBV = 'N', the array V is not C referenced and can be supplied as a dummy array (i.e. set C parameter LDV = 1 and declare this array to be V(1,1) in C the calling program). C C LDV INTEGER C The leading dimension of array V. C If STAGES <> 'F' and JOBV = 'I', LDV >= MAX(1,M); C if STAGES = 'F' or JOBV = 'N', LDV >= 1. C C NCONT (input/output) INTEGER C The order of the controllable state-space representation. C NCONT is input only if STAGES = 'B'. C C INDCON (input/output) INTEGER C The number of stairs in the staircase form (also, the C controllability index of the controllable part of the C system representation). C INDCON is input only if STAGES = 'B'. C C KSTAIR (input/output) INTEGER array, dimension (N) C The leading INDCON elements of this array contain the C dimensions of the stairs, or, also, the orders of the C diagonal blocks of Acont. C KSTAIR is input if STAGES = 'B', and output otherwise. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determination when C transforming (A, B). If the user sets TOL > 0, then C the given value of TOL is used as a lower bound for the C reciprocal condition number (see the description of the C argument RCOND in the SLICOT routine MB03OD); a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*N*EPS, is used instead, where EPS C is the machine precision (see LAPACK Library routine C DLAMCH). C TOL is not referenced if STAGES = 'B'. C C Workspace C C IWORK INTEGER array, dimension (M) C IWORK is not referenced if STAGES = 'B'. 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 If STAGES <> 'B', LDWORK >= MAX(1, N + MAX(N,3*M)); C If STAGES = 'B', LDWORK >= MAX(1, M + MAX(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 C METHOD C C Staircase reduction of the pencil [B|sI - A] is used. Orthogonal C transformations U and V are constructed such that C C C |B |sI-A * . . . * * | C | 1| 11 . . . | C | | A sI-A . . . | C | | 21 22 . . . | C | | . . * * | C [U'BV|sI - U'AU] = |0 | 0 . . | C | | A sI-A * | C | | p,p-1 pp | C | | | C |0 | 0 0 sI-A | C | | p+1,p+1| C C C where the i-th diagonal block of U'AU has dimension KSTAIR(i), C for i = 1,...,p. The value of p is returned in INDCON. The last C block contains the uncontrollable modes of the (A,B)-pair which C are also the generalized eigenvalues of the above pencil. C C The complete reduction is performed in two stages. The first, C forward stage accomplishes the reduction to the orthogonal C canonical form. The second, backward stage consists in further C reduction to triangular form by applying left and right orthogonal C transformations. C C REFERENCES C C [1] Van Dooren, P. C The generalized eigenvalue problem in linear system theory. C IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981. C C [2] Miminis, G. and Paige, C. C An algorithm for pole assignment of time-invariant multi-input C linear systems. C Proc. 21st IEEE CDC, Orlando, Florida, 1, pp. 62-67, 1982. C C NUMERICAL ASPECTS C C The algorithm requires O((N + M) x N**2) operations and is C backward stable (see [1]). C C FURTHER COMMENTS C C If the system matrices A and B are badly scaled, it would be C useful to scale them with SLICOT routine TB01ID, before calling C the routine. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. C Supersedes Release 2.0 routine AB01CD by M. Vanbegin, and C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. C C REVISIONS C C January 14, 1997, February 12, 1998, September 22, 2003. C C KEYWORDS C C Controllability, generalized eigenvalue problem, orthogonal C transformation, staircase form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBU, JOBV, STAGES INTEGER INDCON, INFO, LDA, LDB, LDU, LDV, LDWORK, M, N, $ NCONT DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*), KSTAIR(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), U(LDU,*), V(LDV,*) C .. Local Scalars .. LOGICAL LJOBUI, LJOBVI, LSTAGB, LSTGAB INTEGER I, I0, IBSTEP, ITAU, J0, JINI, JWORK, MCRT, MM, $ NCRT, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB01ND, DGERQF, DLACPY, DLASET, DORGRQ, DORMRQ, $ DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C INFO = 0 LJOBUI = LSAME( JOBU, 'I' ) C LSTAGB = LSAME( STAGES, 'B' ) LSTGAB = LSAME( STAGES, 'A' ).OR.LSTAGB C IF ( LSTGAB ) THEN LJOBVI = LSAME( JOBV, 'I' ) END IF C C Test the input scalar arguments. C IF( .NOT.LSTGAB .AND. .NOT.LSAME( STAGES, 'F' ) ) THEN INFO = -1 ELSE IF( .NOT.LJOBUI .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.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( LDU.LT.1 .OR. ( LJOBUI .AND. LDU.LT.N ) ) THEN INFO = -11 ELSE IF( .NOT.LSTAGB .AND. LDWORK.LT.MAX( 1, N + MAX( N, 3*M ) ) $ .OR. LSTAGB .AND. LDWORK.LT.MAX( 1, M + MAX( N, M ) ) ) $ THEN INFO = -20 ELSE IF( LSTAGB .AND. NCONT.GT.N ) THEN INFO = -14 ELSE IF( LSTAGB .AND. INDCON.GT.N ) THEN INFO = -15 ELSE IF( LSTGAB ) THEN IF( .NOT.LJOBVI .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN INFO = -3 ELSE IF( LDV.LT.1 .OR. ( LJOBVI .AND. LDV.LT.M ) ) THEN INFO = -13 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB01OD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( N, M ).EQ.0 ) THEN NCONT = 0 INDCON = 0 IF( N.GT.0 .AND. LJOBUI ) $ CALL DLASET( 'F', N, N, ZERO, ONE, U, LDU ) IF( LSTGAB ) THEN IF( M.GT.0 .AND. LJOBVI ) $ CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV ) END IF DWORK(1) = ONE RETURN 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 NB refers to the optimal block size for the immediately C following subroutine, as returned by ILAENV.) C ITAU = 1 WRKOPT = 1 C IF ( .NOT.LSTAGB ) THEN C C Perform the forward stage computations of the staircase C algorithm on B and A: reduce the (A, B) pair to orthogonal C canonical form. C C Workspace: N + MAX(N,3*M). C JWORK = N + 1 CALL AB01ND( JOBU, N, M, A, LDA, B, LDB, NCONT, INDCON, $ KSTAIR, U, LDU, DWORK(ITAU), TOL, IWORK, $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 END IF C C Exit if no further reduction to triangularize B1 and subdiagonal C blocks of A is required, or if the order of the controllable part C is 0. C IF ( .NOT.LSTGAB ) THEN DWORK(1) = WRKOPT RETURN ELSE IF ( NCONT.EQ.0 .OR. INDCON.EQ.0 ) THEN IF( LJOBVI ) $ CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV ) DWORK(1) = WRKOPT RETURN END IF C C Now perform the backward steps except the last one. C MCRT = KSTAIR(INDCON) I0 = NCONT - MCRT + 1 JWORK = M + 1 C DO 10 IBSTEP = INDCON, 2, -1 NCRT = KSTAIR(IBSTEP-1) J0 = I0 - NCRT MM = MIN( NCRT, MCRT ) C C Compute the RQ factorization of the current subdiagonal block C of A, Ai,i-1 = R*Q (where i is IBSTEP), of dimension C MCRT-by-NCRT, starting in position (I0,J0). C The matrix Q' should postmultiply U, if required. C Workspace: need M + MCRT; C prefer M + MCRT*NB. C CALL DGERQF( MCRT, NCRT, A(I0,J0), LDA, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Set JINI to the first column number in A where the current C transformation Q is to be applied, taking the block Hessenberg C form into account. C IF ( IBSTEP.GT.2 ) THEN JINI = J0 - KSTAIR(IBSTEP-2) ELSE JINI = 1 C C Premultiply the first block row (B1) of B by Q. C Workspace: need 2*M; C prefer M + M*NB. C CALL DORMRQ( 'Left', 'No transpose', NCRT, M, MM, A(I0,J0), $ LDA, DWORK(ITAU), B, LDB, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) END IF C C Premultiply the appropriate block row of A by Q. C Workspace: need M + N; C prefer M + N*NB. C CALL DORMRQ( 'Left', 'No transpose', NCRT, N-JINI+1, MM, $ A(I0,J0), LDA, DWORK(ITAU), A(J0,JINI), LDA, $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Postmultiply the appropriate block column of A by Q'. C Workspace: need M + I0-1; C prefer M + (I0-1)*NB. C CALL DORMRQ( 'Right', 'Transpose', I0-1, NCRT, MM, A(I0,J0), $ LDA, DWORK(ITAU), A(1,J0), LDA, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C IF ( LJOBUI ) THEN C C Update U, postmultiplying it by Q'. C Workspace: need M + N; C prefer M + N*NB. C CALL DORMRQ( 'Right', 'Transpose', N, NCRT, MM, A(I0,J0), $ LDA, DWORK(ITAU), U(1,J0), LDU, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) END IF C C Zero the subdiagonal elements of the current subdiagonal block C of A. C CALL DLASET( 'F', MCRT, NCRT-MCRT, ZERO, ZERO, A(I0,J0), LDA ) IF ( I0.LT.N ) $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, $ A(I0+1,I0-MCRT), LDA ) C MCRT = NCRT I0 = J0 C 10 CONTINUE C C Now perform the last backward step on B, V = Qb'. C C Compute the RQ factorization of the first block of B, B1 = R*Qb. C Workspace: need M + MCRT; C prefer M + MCRT*NB. C CALL DGERQF( MCRT, M, B, LDB, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C IF ( LJOBVI ) THEN C C Accumulate the input-space transformations V. C Workspace: need 2*M; prefer M + M*NB. C CALL DLACPY( 'F', MCRT, M-MCRT, B, LDB, V(M-MCRT+1,1), LDV ) IF ( MCRT.GT.1 ) $ CALL DLACPY( 'L', MCRT-1, MCRT-1, B(2,M-MCRT+1), LDB, $ V(M-MCRT+2,M-MCRT+1), LDV ) CALL DORGRQ( M, M, MCRT, V, LDV, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) C DO 20 I = 2, M CALL DSWAP( I-1, V(I,1), LDV, V(1,I), 1 ) 20 CONTINUE C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) END IF C C Zero the subdiagonal elements of the submatrix B1. C CALL DLASET( 'F', MCRT, M-MCRT, ZERO, ZERO, B, LDB ) IF ( MCRT.GT.1 ) $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, B(2,M-MCRT+1), $ LDB ) C C Set optimal workspace dimension. C DWORK(1) = WRKOPT RETURN C *** Last line of AB01OD *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01PD.f0000644000000000000000000000013015012430707016157 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MC01PD.f0000644000175000017500000000731315012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE MC01PD( K, REZ, IMZ, P, DWORK, INFO ) C C PURPOSE C C To compute the coefficients of a real polynomial P(x) from its C zeros. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of zeros (and hence the degree) of P(x). C K >= 0. C C REZ (input) DOUBLE PRECISION array, dimension (K) C IMZ (input) DOUBLE PRECISION array, dimension (K) C The real and imaginary parts of the i-th zero of P(x) C must be stored in REZ(i) and IMZ(i), respectively, where C i = 1, 2, ..., K. The zeros may be supplied in any order, C except that complex conjugate zeros must appear C consecutively. C C P (output) DOUBLE PRECISION array, dimension (K+1) C This array contains the coefficients of P(x) in increasing C powers of x. If K = 0, then P(1) is set to one. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (K+1) C If K = 0, this array is not referenced. 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, (REZ(i),IMZ(i)) is a complex zero but C (REZ(i-1),IMZ(i-1)) is not its conjugate. C C METHOD C C The routine computes the coefficients of the real K-th degree C polynomial P(x) as C C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) C C where r(i) = (REZ(i),IMZ(i)). C C Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j) C form a complex conjugate pair (where i <> j), and that IMZ(i) = 0 C if r(i) is real. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01DD by A.J. Geurts. C C REVISIONS C C V. Sima, May 2002. C C KEYWORDS C C Elementary polynomial operations, polynomial operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, K C .. Array Arguments .. DOUBLE PRECISION DWORK(*), IMZ(*), P(*), REZ(*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION U, V C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, XERBLA C .. Executable Statements .. C C Test the input scalar arguments. C IF( K.LT.0 ) THEN INFO = -1 C C Error return. C CALL XERBLA( 'MC01PD', -INFO ) RETURN END IF C C Quick return if possible. C INFO = 0 P(1) = ONE IF ( K.EQ.0 ) $ RETURN C I = 1 C WHILE ( I <= K ) DO 20 IF ( I.LE.K ) THEN U = REZ(I) V = IMZ(I) DWORK(1) = ZERO C IF ( V.EQ.ZERO ) THEN CALL DCOPY( I, P, 1, DWORK(2), 1 ) CALL DAXPY( I, -U, P, 1, DWORK, 1 ) I = I + 1 C ELSE IF ( I.EQ.K ) THEN INFO = K RETURN ELSE IF ( ( U.NE.REZ(I+1) ) .OR. ( V.NE.-IMZ(I+1) ) ) THEN INFO = I + 1 RETURN END IF C DWORK(2) = ZERO CALL DCOPY( I, P, 1, DWORK(3), 1 ) CALL DAXPY( I, -(U + U), P, 1, DWORK(2), 1 ) CALL DAXPY( I, U**2+V**2, P, 1, DWORK, 1 ) I = I + 2 END IF C CALL DCOPY( I, DWORK, 1, P, 1 ) GO TO 20 END IF C END WHILE 20 C RETURN C *** Last line of MC01PD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01IZ.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01IZ.f0000644000175000017500000002665515012430707017420 0ustar00lilgelilge00000000000000 SUBROUTINE TB01IZ( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ SCALE, INFO ) C C PURPOSE C C To reduce the 1-norm of a system matrix C C S = ( A B ) C ( C 0 ) C C corresponding to the triple (A,B,C), by balancing. This involves C a diagonal similarity transformation inv(D)*A*D applied C iteratively to A to make the rows and columns of C -1 C diag(D,I) * S * diag(D,I) C C as close in norm as possible. C C The balancing can be performed optionally on the following C particular system matrices C C S = A, S = ( A B ) or S = ( A ) C ( C ) C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Indicates which matrices are involved in balancing, as C follows: C = 'A': All matrices are involved in balancing; C = 'B': B and A matrices are involved in balancing; C = 'C': C and A matrices are involved in balancing; C = 'N': B and C matrices are not involved in balancing. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A, the number of rows of matrix B C and the number of columns of matrix C. C N represents the dimension of the state vector. N >= 0. C C M (input) INTEGER. C The number of columns of matrix B. C M represents the dimension of input vector. M >= 0. C C P (input) INTEGER. C The number of rows of matrix C. C P represents the dimension of output vector. P >= 0. C C MAXRED (input/output) DOUBLE PRECISION C On entry, the maximum allowed reduction in the 1-norm of C S (in an iteration) if zero rows or columns are C encountered. C If MAXRED > 0.0, MAXRED must be larger than one (to enable C the norm reduction). C If MAXRED <= 0.0, then the value 10.0 for MAXRED is C used. C On exit, if the 1-norm of the given matrix S is non-zero, C the ratio between the 1-norm of the given matrix and the C 1-norm of the balanced matrix. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the system state matrix A. C On exit, the leading N-by-N part of this array contains C the balanced matrix inv(D)*A*D. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C B (input/output) COMPLEX*16 array, dimension (LDB,M) C On entry, if M > 0, the leading N-by-M part of this array C must contain the system input matrix B. C On exit, if M > 0, the leading N-by-M part of this array C contains the balanced matrix inv(D)*B. C The array B is not referenced if M = 0. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N) if M > 0. C LDB >= 1 if M = 0. C C C (input/output) COMPLEX*16 array, dimension (LDC,N) C On entry, if P > 0, the leading P-by-N part of this array C must contain the system output matrix C. C On exit, if P > 0, the leading P-by-N part of this array C contains the balanced matrix C*D. C The array C is not referenced if P = 0. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C SCALE (output) DOUBLE PRECISION array, dimension (N) C The scaling factors applied to S. If D(j) is the scaling C factor applied to row and column j, then SCALE(j) = D(j), C for j = 1,...,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 METHOD C C Balancing consists of applying a diagonal similarity C transformation C -1 C diag(D,I) * S * diag(D,I) C C to make the 1-norms of each row of the first N rows of S and its C corresponding column nearly equal. C C Information about the diagonal matrix D is returned in the vector C SCALE. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C - C C KEYWORDS C C Balancing, eigenvalue, matrix algebra, matrix operations, C similarity transformation. C C ********************************************************************* C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC PARAMETER ( SCLFAC = 1.0D+1 ) DOUBLE PRECISION FACTOR, MAXR PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER JOB INTEGER INFO, LDA, LDB, LDC, M, N, P DOUBLE PRECISION MAXRED C .. C .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) DOUBLE PRECISION SCALE( * ) C .. C .. Local Scalars .. LOGICAL NOCONV, WITHB, WITHC INTEGER I, ICA, IRA, J DOUBLE PRECISION CA, CO, F, G, MAXNRM, RA, RO, S, SFMAX1, $ SFMAX2, SFMIN1, SFMIN2, SNORM, SRED COMPLEX*16 CDUM C .. C .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH, DZASUM EXTERNAL DLAMCH, DZASUM, IZAMAX, LSAME C .. C .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX, MIN C .. C .. Statement Functions .. DOUBLE PRECISION CABS1 C .. C .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) C .. C .. Executable Statements .. C C Test the scalar input arguments. C INFO = 0 WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) C IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, '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( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( ( M.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. $ ( M.EQ.0 .AND. LDB.LT.1 ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TB01IZ', -INFO ) RETURN END IF C IF( N.EQ.0 ) $ RETURN C C Compute the 1-norm of the required part of matrix S and exit if C it is zero. C SNORM = ZERO C DO 10 J = 1, N SCALE( J ) = ONE CO = DZASUM( N, A( 1, J ), 1 ) IF( WITHC .AND. P.GT.0 ) $ CO = CO + DZASUM( P, C( 1, J ), 1 ) SNORM = MAX( SNORM, CO ) 10 CONTINUE C IF( WITHB ) THEN C DO 20 J = 1, M SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) ) 20 CONTINUE C END IF C IF( SNORM.EQ.ZERO ) $ RETURN C C Set some machine parameters and the maximum reduction in the C 1-norm of S if zero rows or columns are encountered. C SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 C SRED = MAXRED IF( SRED.LE.ZERO ) SRED = MAXR C MAXNRM = MAX( SNORM/SRED, SFMIN1 ) C C Balance the matrix. C C Iterative loop for norm reduction. C 30 CONTINUE NOCONV = .FALSE. C DO 90 I = 1, N CO = ZERO RO = ZERO C DO 40 J = 1, N IF( J.EQ.I ) $ GO TO 40 CO = CO + CABS1( A( J, I ) ) RO = RO + CABS1( A( I, J ) ) 40 CONTINUE C ICA = IZAMAX( N, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = IZAMAX( N, A( I, 1 ), LDA ) RA = ABS( A( I, IRA ) ) C IF( WITHC .AND. P.GT.0 ) THEN CO = CO + DZASUM( P, C( 1, I ), 1 ) ICA = IZAMAX( P, C( 1, I ), 1 ) CA = MAX( CA, ABS( C( ICA, I ) ) ) END IF C IF( WITHB .AND. M.GT.0 ) THEN RO = RO + DZASUM( M, B( I, 1 ), LDB ) IRA = IZAMAX( M, B( I, 1 ), LDB ) RA = MAX( RA, ABS( B( I, IRA ) ) ) END IF C C Special case of zero CO and/or RO. C IF( CO.EQ.ZERO .AND. RO.EQ.ZERO ) $ GO TO 90 IF( CO.EQ.ZERO ) THEN IF( RO.LE.MAXNRM ) $ GO TO 90 CO = MAXNRM END IF IF( RO.EQ.ZERO ) THEN IF( CO.LE.MAXNRM ) $ GO TO 90 RO = MAXNRM END IF C C Guard against zero CO or RO due to underflow. C G = RO / SCLFAC F = ONE S = CO + RO 50 CONTINUE IF( CO.GE.G .OR. MAX( F, CO, CA ).GE.SFMAX2 .OR. $ MIN( RO, G, RA ).LE.SFMIN2 )GO TO 60 F = F*SCLFAC CO = CO*SCLFAC CA = CA*SCLFAC G = G / SCLFAC RO = RO / SCLFAC RA = RA / SCLFAC GO TO 50 C 60 CONTINUE G = CO / SCLFAC 70 CONTINUE IF( G.LT.RO .OR. MAX( RO, RA ).GE.SFMAX2 .OR. $ MIN( F, CO, G, CA ).LE.SFMIN2 )GO TO 80 F = F / SCLFAC CO = CO / SCLFAC CA = CA / SCLFAC G = G / SCLFAC RO = RO*SCLFAC RA = RA*SCLFAC GO TO 70 C C Now balance. C 80 CONTINUE IF( ( CO+RO ).GE.FACTOR*S ) $ GO TO 90 IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN IF( F*SCALE( I ).LE.SFMIN1 ) $ GO TO 90 END IF IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN IF( SCALE( I ).GE.SFMAX1 / F ) $ GO TO 90 END IF G = ONE / F SCALE( I ) = SCALE( I )*F NOCONV = .TRUE. C CALL ZDSCAL( N, G, A( I, 1 ), LDA ) CALL ZDSCAL( N, F, A( 1, I ), 1 ) IF( M.GT.0 ) CALL ZDSCAL( M, G, B( I, 1 ), LDB ) IF( P.GT.0 ) CALL ZDSCAL( P, F, C( 1, I ), 1 ) C 90 CONTINUE C IF( NOCONV ) $ GO TO 30 C C Set the norm reduction parameter. C MAXRED = SNORM SNORM = ZERO C DO 100 J = 1, N CO = DZASUM( N, A( 1, J ), 1 ) IF( WITHC .AND. P.GT.0 ) $ CO = CO + DZASUM( P, C( 1, J ), 1 ) SNORM = MAX( SNORM, CO ) 100 CONTINUE C IF( WITHB ) THEN C DO 110 J = 1, M SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) ) 110 CONTINUE C END IF MAXRED = MAXRED/SNORM RETURN C *** Last line of TB01IZ *** END control-4.1.2/src/slicot/src/PaxHeaders/TB04BX.f0000644000000000000000000000013215012430707016200 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB04BX.f0000644000175000017500000001546515012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE TB04BX( IP, IZ, A, LDA, B, C, D, PR, PI, ZR, ZI, GAIN, $ IWORK ) C C PURPOSE C C To compute the gain of a single-input single-output linear system, C given its state-space representation (A,b,c,d), and its poles and C zeros. The matrix A is assumed to be in an upper Hessenberg form. C The gain is computed using the formula C C -1 IP IZ C g = (c*( S0*I - A ) *b + d)*Prod( S0 - Pi )/Prod( S0 - Zi ) , C i=1 i=1 (1) C C where Pi, i = 1 : IP, and Zj, j = 1 : IZ, are the poles and zeros, C respectively, and S0 is a real scalar different from all poles and C zeros. C C ARGUMENTS C C Input/Output Parameters C C IP (input) INTEGER C The number of the system poles. IP >= 0. C C IZ (input) INTEGER C The number of the system zeros. IZ >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,IP) C On entry, the leading IP-by-IP part of this array must C contain the state dynamics matrix A in an upper Hessenberg C form. The elements below the second diagonal are not C referenced. C On exit, the leading IP-by-IP upper Hessenberg part of C this array contains the LU factorization of the matrix C A - S0*I, as computed by SLICOT Library routine MB02SD. C C LDA INTEGER C The leading dimension of array A. LDA >= max(1,IP). C C B (input/output) DOUBLE PRECISION array, dimension (IP) C On entry, this array must contain the system input C vector b. C On exit, this array contains the solution of the linear C system ( A - S0*I )x = b . C C C (input) DOUBLE PRECISION array, dimension (IP) C This array must contain the system output vector c. C C D (input) DOUBLE PRECISION C The variable must contain the system feedthrough scalar d. C C PR (input) DOUBLE PRECISION array, dimension (IP) C This array must contain the real parts of the system C poles. Pairs of complex conjugate poles must be stored in C consecutive memory locations. C C PI (input) DOUBLE PRECISION array, dimension (IP) C This array must contain the imaginary parts of the system C poles. C C ZR (input) DOUBLE PRECISION array, dimension (IZ) C This array must contain the real parts of the system C zeros. Pairs of complex conjugate zeros must be stored in C consecutive memory locations. C C ZI (input) DOUBLE PRECISION array, dimension (IZ) C This array must contain the imaginary parts of the system C zeros. C C GAIN (output) DOUBLE PRECISION C The gain of the linear system (A,b,c,d), given by (1). C C Workspace C C IWORK INTEGER array, dimension (IP) C On exit, it contains the pivot indices; for 1 <= i <= IP, C row i of the matrix A - S0*I was interchanged with C row IWORK(i). C C METHOD C C The routine implements the method presented in [1]. A suitable C value of S0 is chosen based on the system poles and zeros. C Then, the LU factorization of the upper Hessenberg, nonsingular C matrix A - S0*I is computed and used to solve the linear system C in (1). C C REFERENCES C C [1] Varga, A. and Sima, V. C Numerically Stable Algorithm for Transfer Function Matrix C Evaluation. C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. C C NUMERICAL ASPECTS C C The algorithm is numerically stable in practice and requires C O(IP*IP) floating point operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, May 2002. C Partly based on the BIMASC Library routine GAIN by A. Varga. C C REVISIONS C C - C C KEYWORDS C C Eigenvalue, state-space representation, transfer function, zeros. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, P1, ONEP1 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ P1 = 0.1D0, ONEP1 = 1.1D0 ) C .. Scalar Arguments .. DOUBLE PRECISION D, GAIN INTEGER IP, IZ, LDA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(*), C(*), PI(*), PR(*), ZI(*), $ ZR(*) INTEGER IWORK(*) C .. Local Scalars .. INTEGER I, INFO DOUBLE PRECISION S0, S C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. External Subroutines .. EXTERNAL MB02RD, MB02SD C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. C .. Executable Statements .. C C For efficiency, the input scalar parameters are not checked. C C Quick return if possible. C IF( IP.EQ.0 ) THEN GAIN = ZERO RETURN END IF C C Compute a suitable value for S0 . C S0 = ZERO C DO 10 I = 1, IP S = ABS( PR(I) ) IF ( PI(I).NE.ZERO ) $ S = S + ABS( PI(I) ) S0 = MAX( S0, S ) 10 CONTINUE C DO 20 I = 1, IZ S = ABS( ZR(I) ) IF ( ZI(I).NE.ZERO ) $ S = S + ABS( ZI(I) ) S0 = MAX( S0, S ) 20 CONTINUE C S0 = TWO*S0 + P1 IF ( S0.LE.ONE ) $ S0 = ONEP1 C C Form A - S0*I . C DO 30 I = 1, IP A(I,I) = A(I,I) - S0 30 CONTINUE C C Compute the LU factorization of the matrix A - S0*I C (guaranteed to be nonsingular). C CALL MB02SD( IP, A, LDA, IWORK, INFO ) C C Solve the linear system (A - S0*I)*x = b . C CALL MB02RD( 'No Transpose', IP, 1, A, LDA, IWORK, B, IP, INFO ) C -1 C Compute c*(S0*I - A) *b + d . C GAIN = D - DDOT( IP, C, 1, B, 1 ) C C Multiply by the products in terms of poles and zeros in (1). C I = 1 C C WHILE ( I <= IP ) DO C 40 IF ( I.LE.IP ) THEN IF ( PI(I).EQ.ZERO ) THEN GAIN = GAIN*( S0 - PR(I) ) I = I + 1 ELSE GAIN = GAIN*( S0*( S0 - TWO*PR(I) ) + PR(I)**2 + PI(I)**2 ) I = I + 2 END IF GO TO 40 END IF C C END WHILE 40 C I = 1 C C WHILE ( I <= IZ ) DO C 50 IF ( I.LE.IZ ) THEN IF ( ZI(I).EQ.ZERO ) THEN GAIN = GAIN/( S0 - ZR(I) ) I = I + 1 ELSE GAIN = GAIN/( S0*( S0 - TWO*ZR(I) ) + ZR(I)**2 + ZI(I)**2 ) I = I + 2 END IF GO TO 50 END IF C C END WHILE 50 C RETURN C *** Last line of TB04BX *** END control-4.1.2/src/slicot/src/PaxHeaders/SB08CD.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB08CD.f0000644000175000017500000003070615012430707017362 0ustar00lilgelilge00000000000000 SUBROUTINE SB08CD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK, LDWORK, $ IWARN, INFO ) C C PURPOSE C C To construct, for a given system G = (A,B,C,D), an output C injection matrix H, an orthogonal transformation matrix Z, and a C gain matrix V, such that the systems C C Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), V*C*Z, V*D) C and C R = (Z'*(A+H*C)*Z, Z'*H, V*C*Z, V) C C provide a stable left coprime factorization of G in the form C -1 C G = R * Q, C C where G, Q and R are the corresponding transfer-function matrices C and the denominator R is co-inner, that is, R(s)*R'(-s) = I in C the continuous-time case, or R(z)*R'(1/z) = I in the discrete-time C case. The Z matrix is not explicitly computed. C C Note: G must have no observable poles on the imaginary axis C for a continuous-time system, or on the unit circle for a C discrete-time system. If the given state-space representation C is not detectable, the undetectable part of the original C system is automatically deflated and the order of the systems C Q and R is accordingly reduced. 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 matrices B C and BR, and the number of columns of the matrix C. C N >= 0. C C M (input) INTEGER C The dimension of input vector, i.e. the number of columns C of the matrices B and D. M >= 0. C C P (input) INTEGER C The dimension of output vector, i.e. the number of rows C of the matrices C, D and DR, and the number of columns C of the matrices BR and DR. 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 A. The matrix A must not C have observable eigenvalues on the imaginary axis, if C DICO = 'C', or on the unit circle, if DICO = 'D'. C On exit, the leading NQ-by-NQ part of this array contains C the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the C state dynamics matrix of the numerator factor Q, in a C real Schur form. The leading NR-by-NR part of this matrix C represents the state dynamics matrix of a minimal C realization of the denominator factor R. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,MAX(M,P)) C On entry, the leading N-by-M part of this array must C contain the input/state matrix. C On exit, the leading NQ-by-M part of this array contains C the leading NQ-by-M part of the matrix Z'*(B+H*D), the C input/state matrix of the numerator factor Q. C The remaining part of this array is needed as workspace. 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 C. C On exit, the leading P-by-NQ part of this array contains C the leading P-by-NQ part of the matrix V*C*Z, the C state/output matrix of the numerator factor Q. C The first NR columns of this array represent the C state/output matrix of a minimal realization of the C denominator factor R. C The remaining part of this array is needed as workspace. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,M,P), if N > 0. C LDC >= 1, if N = 0. C C D (input/output) DOUBLE PRECISION array, dimension C (LDD,MAX(M,P)) C On entry, the leading P-by-M part of this array must C contain the input/output matrix. C On exit, the leading P-by-M part of this array contains C the matrix V*D representing the input/output matrix C of the numerator factor Q. C The remaining part of this array is needed as workspace. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,M,P). C C NQ (output) INTEGER C The order of the resulting factors Q and R. C Generally, NQ = N - NS, where NS is the number of C unobservable eigenvalues outside the stability region. C C NR (output) INTEGER C The order of the minimal realization of the factor R. C Generally, NR is the number of observable eigenvalues C of A outside the stability region (the number of modified C eigenvalues). C C BR (output) DOUBLE PRECISION array, dimension (LDBR,P) C The leading NQ-by-P part of this array contains the C leading NQ-by-P part of the output injection matrix C Z'*H, which reflects the eigenvalues of A lying outside C the stable region to values which are symmetric with C respect to the imaginary axis (if DICO = 'C') or the unit C circle (if DICO = 'D'). The first NR rows of this matrix C form the input/state matrix of a minimal realization of C the denominator factor R. C C LDBR INTEGER C The leading dimension of array BR. LDBR >= MAX(1,N). C C DR (output) DOUBLE PRECISION array, dimension (LDDR,P) C The leading P-by-P part of this array contains the lower C triangular matrix V representing the input/output matrix C of the denominator factor R. C C LDDR INTEGER C The leading dimension of array DR. LDDR >= MAX(1,P). C C Tolerances C C TOL DOUBLE PRECISION C The absolute tolerance level below which the elements of C C are considered zero (used for observability tests). C If the user sets TOL <= 0, then an implicitly computed, C default tolerance, defined by TOLDEF = N*EPS*NORM(C), C is used instead, where EPS is the machine precision C (see LAPACK Library routine DLAMCH) and NORM(C) denotes C the infinity-norm of C. 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, P*N + MAX( N*(N+5),P*(P+2),4*P,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(H) <= 10*NORM(A)/NORM(C) 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 + H*C)*Z C along the diagonal; C = 3: if DICO = 'C' and the matrix A has an observable C eigenvalue on the imaginary axis, or DICO = 'D' and C A has an observable eigenvalue on the unit circle. C C METHOD C C The subroutine uses the right coprime factorization algorithm with C inner denominator of [1] applied to G'. C C REFERENCES C C [1] 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 A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, July 1998. C Based on the RASP routine LCFID. 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, DLR Oberpfaffenhofen. C Nov 2003, A. Varga, DLR Oberpfaffenhofen. C C KEYWORDS C C Coprime factorization, eigenvalue, eigenvalue assignment, C feedback control, pole placement, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO INTEGER INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR, $ LDWORK, M, N, NQ, NR, P DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), BR(LDBR,*), C(LDC,*), $ D(LDD,*), DR(LDDR,*), DWORK(*) C .. Local Scalars .. INTEGER I, KBR, KW C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External subroutines .. EXTERNAL AB07MD, DLASET, DSWAP, MA02AD, MA02BD, SB08DD, $ TB01XD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C .. Executable Statements .. C IWARN = 0 INFO = 0 C C Check the scalar input parameters. C IF( .NOT.LSAME( DICO, 'C' ) .AND. $ .NOT.LSAME( DICO, 'D' ) ) 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.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) ) $ THEN INFO = -10 ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN INFO = -12 ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN INFO = -18 ELSE IF( LDWORK.LT.MAX( 1, P*N + MAX( N*(N+5), P*(P+2), 4*P, $ 4*M ) ) ) THEN INFO = -21 END IF IF( INFO.NE.0 )THEN C C Error return. C CALL XERBLA( 'SB08CD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, P ).EQ.0 ) THEN NQ = 0 NR = 0 DWORK(1) = ONE CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR ) RETURN END IF C C Compute the dual system G' = (A',C',B',D'). C CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ INFO ) C C Compute the right coprime factorization with inner C denominator of G'. C C Workspace needed: P*N; C Additional workspace: need MAX( N*(N+5), P*(P+2), 4*P, 4*M ); C prefer larger. C KBR = 1 KW = KBR + P*N CALL SB08DD( DICO, N, P, M, A, LDA, B, LDB, C, LDC, D, LDD, $ NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW), $ LDWORK-KW+1, IWARN, INFO ) IF( INFO.EQ.0 ) THEN C C Determine the elements of the left coprime factorization from C those of the computed right coprime factorization and make the C state-matrix upper real Schur. C CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ), $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) C CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR ) CALL MA02BD( 'Left', NQ, P, BR, LDBR ) C DO 10 I = 2, P CALL DSWAP( I-1, DR(I,1), LDDR, DR(1,I), 1 ) 10 CONTINUE C END IF C DWORK(1) = DWORK(KW) + DBLE( KW-1 ) C RETURN C *** Last line of SB08CD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04QS.f0000644000000000000000000000013215012430707016203 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04QS.f0000644000175000017500000002255615012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE MB04QS( TRANC, TRAND, TRANU, M, N, ILO, V, LDV, W, LDW, $ C, LDC, D, LDD, CS, TAU, DWORK, LDWORK, INFO ) C C PURPOSE C C Overwrites general real m-by-n/n-by-m matrices C and D with C C [ op(C) ] C U * [ ] if TRANU = 'N', or C [ op(D) ] C C T [ op(C) ] C U * [ ] if TRANU = 'T', C [ op(D) ] C C where U is defined as the product of symplectic reflectors and C Givens rotations, C C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ), C C with k = m-1, as returned by the SLICOT Library routines MB04PU C or MB04RU. C C ARGUMENTS C C Mode Parameters C C TRANC CHARACTER*1 C Specifies the form of op( C ) as follows: C = 'N': op( C ) = C; C = 'T': op( C ) = C'; C = 'C': op( C ) = C'. C C TRAND CHARACTER*1 C Specifies the form of op( D ) as follows: C = 'N': op( D ) = D; C = 'T': op( D ) = D'; C = 'C': op( D ) = D'. C C TRANU CHARACTER*1 C Specifies whether U or U' is applied as follows: C = 'N': apply U; C = 'T': apply U'. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrices op(C) and op(D). C M >= 0. C C N (input) INTEGER C The number of columns of the matrices op(C) and op(D). C N >= 0. C C ILO (input) INTEGER C ILO must have the same value as in the previous call of C MB04PU or MB04RU. U is equal to the unit matrix except in C the submatrix C U([ilo+1:m m+ilo+1:2*m], [ilo+1:m m+ilo+1:2*m]). C 1 <= ILO <= M+1. C C V (input) DOUBLE PRECISION array, dimension (LDV,M) C On entry, the leading M-by-M part of this array must C contain in its columns the vectors which define the C elementary reflectors H(i). C C LDV INTEGER C The leading dimension of the array V. LDV >= MAX(1,M). C C W (input) DOUBLE PRECISION array, dimension (LDW,M) C On entry, the leading M-by-M part of this array must C contain in its columns the vectors which define the C elementary reflectors F(i). C C LDW INTEGER C The leading dimension of the array W. LDW >= MAX(1,M). C C C (input/output) DOUBLE PRECISION array, dimension C (LDC,N) if TRANC = 'N', C (LDC,M) if TRANC = 'T' or TRANC = 'C'. C On entry with TRANC = 'N', the leading M-by-N part of this C array must contain the matrix C. C On entry with TRANC = 'T' or TRANC = 'C', the leading C N-by-M part of this array must contain the transpose of C the matrix C. C On exit with TRANC = 'N', the leading M-by-N part of this C array contains the updated matrix C. C On exit with TRANC = 'T' or TRANC = 'C', the leading C N-by-M part of this array contains the transpose of the C updated matrix C. C C LDC INTEGER C The leading dimension of the array C. C LDC >= MAX(1,M), if TRANC = 'N'; C LDC >= MAX(1,N), if TRANC = 'T' or TRANC = 'C'. C C D (input/output) DOUBLE PRECISION array, dimension C (LDD,N) if TRAND = 'N', C (LDD,M) if TRAND = 'T' or TRAND = 'C'. C On entry with TRAND = 'N', the leading M-by-N part of this C array must contain the matrix D. C On entry with TRAND = 'T' or TRAND = 'C', the leading C N-by-M part of this array must contain the transpose of C the matrix D. C On exit with TRAND = 'N', the leading M-by-N part of this C array contains the updated matrix D. C On exit with TRAND = 'T' or TRAND = 'C', the leading C N-by-M part of this array contains the transpose of the C updated matrix D. C C LDD INTEGER C The leading dimension of the array D. C LDD >= MAX(1,M), if TRAND = 'N'; C LDD >= MAX(1,N), if TRAND = 'T' or TRAND = 'C'. C C CS (input) DOUBLE PRECISION array, dimension (2*N-2) C On entry, the first 2*N-2 elements of this array must C contain the cosines and sines of the symplectic Givens C rotations G(i), as returned by MB04PU or MB04RU. C C TAU (input) DOUBLE PRECISION array, dimension (N-1) C On entry, the first N-1 elements of this array must C contain the scalar factors of the elementary reflectors C F(i), as returned by MB04PU or MB04RU. 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 On exit, if INFO = -18, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,N). 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 CONTRIBUTORS C C D. Kressner (Technical Univ. Berlin, Germany) and C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. C C REVISIONS C C V. Sima, Nov. 2011 (SLICOT version of the HAPACK routine DOSMPV). C C KEYWORDS C C Elementary matrix operations, orthogonal symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) C .. Scalar Arguments .. CHARACTER TRANC, TRAND, TRANU INTEGER ILO, INFO, LDC, LDD, LDV, LDW, LDWORK, M, N C .. Array Arguments .. DOUBLE PRECISION C(LDC,*), CS(*), D(LDD,*), DWORK(*), TAU(*), $ V(LDV,*), W(LDW,*) C .. Local Scalars .. LOGICAL LQUERY, LTRC, LTRD, LTRU INTEGER IC, ID, IERR, JC, JD, MH, MINWRK C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL MB04QB, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' ) LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' ) LTRU = LSAME( TRANU, 'T' ) MH = MAX( 0, M - ILO ) C C Check the scalar input parameters. C IF ( .NOT.( LTRC .OR. LSAME( TRANC, 'N' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN INFO = -2 ELSE IF ( .NOT.( LTRU .OR. LSAME( TRANU, 'N' ) ) ) THEN INFO = -3 ELSE IF ( M.LT.0 ) THEN INFO = -4 ELSE IF ( N.LT.0 ) THEN INFO = -5 ELSE IF ( ILO.LT.1 .OR. ILO.GT.M+1 ) THEN INFO = -6 ELSE IF ( LDV.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF ( LDW.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF ( ( LTRC .AND. LDC.LT.MAX( 1, N ) ).OR. $ ( .NOT.LTRC .AND. LDC.LT.MAX( 1, M ) ) ) THEN INFO = -12 ELSE IF ( ( LTRD .AND. LDD.LT.MAX( 1, N ) ).OR. $ ( .NOT.LTRD .AND. LDD.LT.MAX( 1, M ) ) ) THEN INFO = -14 ELSE LQUERY = LDWORK.EQ.-1 MINWRK = MAX( 1, N ) IF ( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN DWORK(1) = DBLE( MINWRK ) INFO = -18 ELSE IF( LQUERY ) THEN IF ( M.LE.ILO .OR. N.EQ.0 ) THEN DWORK(1) = ONE ELSE CALL MB04QB( TRANC, TRAND, TRANU, 'C', 'C', MH, N, MH, V, $ LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK, $ -1, IERR ) DWORK(1) = MAX( MINWRK, INT( DWORK(1) ) ) END IF RETURN END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04QS', -INFO ) RETURN END IF C C Quick return if possible. C IF ( M.LE.ILO .OR. N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C IF ( LTRC ) THEN IC = 1 JC = ILO + 1 ELSE IC = ILO + 1 JC = 1 END IF IF ( LTRD ) THEN ID = 1 JD = ILO + 1 ELSE ID = ILO + 1 JD = 1 END IF C CALL MB04QB( TRANC, TRAND, TRANU, 'Columnwise', 'Columnwise', MH, $ N, MH, V(ILO+1,ILO), LDV, W(ILO+1,ILO), LDW, $ C(IC,JC), LDC, D(ID,JD), LDD, CS(2*ILO-1), TAU(ILO), $ DWORK, LDWORK, IERR ) RETURN C *** Last line of MB04QS *** END control-4.1.2/src/slicot/src/PaxHeaders/AB05PD.f0000644000000000000000000000013215012430707016150 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB05PD.f0000644000175000017500000002724315012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE AB05PD( OVER, N1, M, P, N2, ALPHA, A1, LDA1, B1, LDB1, $ C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, C2, $ LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, D, $ LDD, INFO) C C PURPOSE C C To compute the state-space model G = (A,B,C,D) corresponding to C the sum G = G1 + alpha*G2, where G1 = (A1,B1,C1,D1) and C G2 = (A2,B2,C2,D2). G, G1, and G2 are the transfer-function C matrices of the corresponding state-space models. C C ARGUMENTS C C Mode Parameters C C OVER CHARACTER*1 C Indicates whether the user wishes to overlap pairs of C arrays, as follows: C = 'N': Do not overlap; C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, C C1 and C, and D1 and D, i.e. the same name is C effectively used for each pair (for all pairs) C in the routine call. In this case, setting C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD C will give maximum efficiency. C C Input/Output Parameters C C N1 (input) INTEGER C The number of state variables in the first system, i.e. C the order of the matrix A1, the number of rows of B1 and C the number of columns of C1. N1 >= 0. C C M (input) INTEGER C The number of input variables of the two systems, i.e. the C number of columns of matrices B1, D1, B2 and D2. M >= 0. C C P (input) INTEGER C The number of output variables of the two systems, i.e. C the number of rows of matrices C1, D1, C2 and D2. P >= 0. C C N2 (input) INTEGER C The number of state variables in the second system, i.e. C the order of the matrix A2, the number of rows of B2 and C the number of columns of C2. N2 >= 0. C C ALPHA (input) DOUBLE PRECISION C The coefficient multiplying G2. C C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) C The leading N1-by-N1 part of this array must contain the C state transition matrix A1 for the first system. C C LDA1 INTEGER C The leading dimension of array A1. LDA1 >= MAX(1,N1). C C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M) C The leading N1-by-M part of this array must contain the C input/state matrix B1 for the first system. C C LDB1 INTEGER C The leading dimension of array B1. LDB1 >= MAX(1,N1). C C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) C The leading P-by-N1 part of this array must contain the C state/output matrix C1 for the first system. C C LDC1 INTEGER C The leading dimension of array C1. C LDC1 >= MAX(1,P) if N1 > 0. C LDC1 >= 1 if N1 = 0. C C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M) C The leading P-by-M part of this array must contain the C input/output matrix D1 for the first system. C C LDD1 INTEGER C The leading dimension of array D1. LDD1 >= MAX(1,P). C C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) C The leading N2-by-N2 part of this array must contain the C state transition matrix A2 for the second system. C C LDA2 INTEGER C The leading dimension of array A2. LDA2 >= MAX(1,N2). C C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M) C The leading N2-by-M part of this array must contain the C input/state matrix B2 for the second system. C C LDB2 INTEGER C The leading dimension of array B2. LDB2 >= MAX(1,N2). C C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) C The leading P-by-N2 part of this array must contain the C state/output matrix C2 for the second system. C C LDC2 INTEGER C The leading dimension of array C2. C LDC2 >= MAX(1,P) if N2 > 0. C LDC2 >= 1 if N2 = 0. C C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M) C The leading P-by-M part of this array must contain the C input/output matrix D2 for the second system. C C LDD2 INTEGER C The leading dimension of array D2. LDD2 >= MAX(1,P). C C N (output) INTEGER C The number of state variables (N1 + N2) in the resulting C system, i.e. the order of the matrix A, the number of rows C of B and the number of columns of C. C C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) C The leading N-by-N part of this array contains the state C transition matrix A for the resulting system. C The array A can overlap A1 if OVER = 'O'. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N1+N2). C C B (output) DOUBLE PRECISION array, dimension (LDB,M) C The leading N-by-M part of this array contains the C input/state matrix B for the resulting system. C The array B can overlap B1 if OVER = 'O'. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N1+N2). C C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) C The leading P-by-N part of this array contains the C state/output matrix C for the resulting system. C The array C can overlap C1 if OVER = 'O'. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,P) if N1+N2 > 0. C LDC >= 1 if N1+N2 = 0. C C D (output) DOUBLE PRECISION array, dimension (LDD,M) C The leading P-by-M part of this array contains the C input/output matrix D for the resulting system. C The array D can overlap D1 if OVER = 'O'. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). 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 matrices of the resulting systems are determined as: C C ( A1 0 ) ( B1 ) C A = ( ) , B = ( ) , C ( 0 A2 ) ( B2 ) C C C = ( C1 alpha*C2 ) , D = D1 + alpha*D2 . C C REFERENCES C C None C C NUMERICAL ASPECTS C C None C C CONTRIBUTORS C C A. Varga, German Aerospace Research Establishment, C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, C Belgium, Nov. 1996. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 2003, C Feb. 2004. C C KEYWORDS C C Multivariable system, state-space model, state-space C representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO=0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER OVER INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, $ LDC1, LDC2, LDD, LDD1, LDD2, M, N, N1, N2, P DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) C .. Local Scalars .. LOGICAL LOVER INTEGER I, J, N1P1 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DLACPY, DLASCL, DLASET, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C LOVER = LSAME( OVER, 'O' ) N = N1 + N2 INFO = 0 C C Test the input scalar arguments. C IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN INFO = -1 ELSE IF( N1.LT.0 ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( P.LT.0 ) THEN INFO = -4 ELSE IF( N2.LT.0 ) THEN INFO = -5 ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN INFO = -8 ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN INFO = -10 ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P ) ) .OR. $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN INFO = -12 ELSE IF( LDD1.LT.MAX( 1, P ) ) THEN INFO = -14 ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN INFO = -16 ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN INFO = -18 ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P ) ) .OR. $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN INFO = -20 ELSE IF( LDD2.LT.MAX( 1, P ) ) THEN INFO = -22 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -25 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -27 ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN INFO = -29 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -31 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB05PD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, MIN( M, P ) ).EQ.0 ) $ RETURN C N1P1 = N1 + 1 C C ( A1 0 ) C Construct A = ( ) . C ( 0 A2 ) C IF ( LOVER .AND. LDA1.LE.LDA ) THEN IF ( LDA1.LT.LDA ) THEN C DO 20 J = N1, 1, -1 DO 10 I = N1, 1, -1 A(I,J) = A1(I,J) 10 CONTINUE 20 CONTINUE C END IF ELSE CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) END IF C IF ( N2.GT.0 ) THEN CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1P1), LDA ) CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1P1,1), LDA ) CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1P1,N1P1), LDA ) END IF C C ( B1 ) C Construct B = ( ) . C ( B2 ) C IF ( LOVER .AND. LDB1.LE.LDB ) THEN IF ( LDB1.LT.LDB ) THEN C DO 40 J = M, 1, -1 DO 30 I = N1, 1, -1 B(I,J) = B1(I,J) 30 CONTINUE 40 CONTINUE C END IF ELSE CALL DLACPY( 'F', N1, M, B1, LDB1, B, LDB ) END IF C IF ( N2.GT.0 ) $ CALL DLACPY( 'F', N2, M, B2, LDB2, B(N1P1,1), LDB ) C C Construct C = ( C1 alpha*C2 ) . C IF ( LOVER .AND. LDC1.LE.LDC ) THEN IF ( LDC1.LT.LDC ) THEN C DO 60 J = N1, 1, -1 DO 50 I = P, 1, -1 C(I,J) = C1(I,J) 50 CONTINUE 60 CONTINUE C END IF ELSE CALL DLACPY( 'F', P, N1, C1, LDC1, C, LDC ) END IF C IF ( N2.GT.0 ) THEN CALL DLACPY( 'F', P, N2, C2, LDC2, C(1,N1P1), LDC ) IF ( ALPHA.NE.ONE ) $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P, N2, C(1,N1P1), LDC, $ INFO ) END IF C C Construct D = D1 + alpha*D2 . C IF ( LOVER .AND. LDD1.LE.LDD ) THEN IF ( LDD1.LT.LDD ) THEN C DO 80 J = M, 1, -1 DO 70 I = P, 1, -1 D(I,J) = D1(I,J) 70 CONTINUE 80 CONTINUE C END IF ELSE CALL DLACPY( 'F', P, M, D1, LDD1, D, LDD ) END IF C DO 90 J = 1, M CALL DAXPY( P, ALPHA, D2(1,J), 1, D(1,J), 1 ) 90 CONTINUE C RETURN C *** Last line of AB05PD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04WD.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04WD.f0000644000175000017500000003626115012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE MB04WD( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2, $ CS, TAU, DWORK, LDWORK, INFO ) C C PURPOSE C C To generate a matrix Q with orthogonal columns (spanning an C isotropic subspace), which is defined as the first n columns C of a product of symplectic reflectors and Givens rotations, C C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). C C The matrix Q is returned in terms of its first 2*M rows C C [ op( Q1 ) op( Q2 ) ] C Q = [ ]. C [ -op( Q2 ) op( Q1 ) ] C C Blocked version of the SLICOT Library routine MB04WU. C C ARGUMENTS C C Mode Parameters C C TRANQ1 CHARACTER*1 C Specifies the form of op( Q1 ) as follows: C = 'N': op( Q1 ) = Q1; C = 'T': op( Q1 ) = Q1'; C = 'C': op( Q1 ) = Q1'. C C TRANQ2 CHARACTER*1 C Specifies the form of op( Q2 ) as follows: C = 'N': op( Q2 ) = Q2; C = 'T': op( Q2 ) = Q2'; C = 'C': op( Q2 ) = Q2'. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrices Q1 and Q2. M >= 0. C C N (input) INTEGER C The number of columns of the matrices Q1 and Q2. C M >= N >= 0. C C K (input) INTEGER C The number of symplectic Givens rotations whose product C partly defines the matrix Q. N >= K >= 0. C C Q1 (input/output) DOUBLE PRECISION array, dimension C (LDQ1,N) if TRANQ1 = 'N', C (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C' C On entry with TRANQ1 = 'N', the leading M-by-K part of C this array must contain in its i-th column the vector C which defines the elementary reflector F(i). C On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading C K-by-M part of this array must contain in its i-th row C the vector which defines the elementary reflector F(i). C On exit with TRANQ1 = 'N', the leading M-by-N part of this C array contains the matrix Q1. C On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading C N-by-M part of this array contains the matrix Q1'. C C LDQ1 INTEGER C The leading dimension of the array Q1. C LDQ1 >= MAX(1,M), if TRANQ1 = 'N'; C LDQ1 >= MAX(1,N), if TRANQ1 = 'T' or TRANQ1 = 'C'. C C Q2 (input/output) DOUBLE PRECISION array, dimension C (LDQ2,N) if TRANQ2 = 'N', C (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C' C On entry with TRANQ2 = 'N', the leading M-by-K part of C this array must contain in its i-th column the vector C which defines the elementary reflector H(i) and, on the C diagonal, the scalar factor of H(i). C On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading C K-by-M part of this array must contain in its i-th row the C vector which defines the elementary reflector H(i) and, on C the diagonal, the scalar factor of H(i). C On exit with TRANQ2 = 'N', the leading M-by-N part of this C array contains the matrix Q2. C On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading C N-by-M part of this array contains the matrix Q2'. C C LDQ2 INTEGER C The leading dimension of the array Q2. C LDQ2 >= MAX(1,M), if TRANQ2 = 'N'; C LDQ2 >= MAX(1,N), if TRANQ2 = 'T' or TRANQ2 = 'C'. C C CS (input) DOUBLE PRECISION array, dimension (2*K) C On entry, the first 2*K elements of this array must C contain the cosines and sines of the symplectic Givens C rotations G(i). C C TAU (input) DOUBLE PRECISION array, dimension (K) C On entry, the first K elements of this array must C contain the scalar factors of the elementary reflectors C F(i). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK, MAX(M+N,8*N*NB + 15*NB*NB), where NB is C the optimal block size determined by the function UE01MD. C On exit, if INFO = -13, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,M+N). 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] Kressner, D. C Block algorithms for orthogonal symplectic factorizations. C BIT, 43 (4), pp. 775-790, 2003. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSB). C V. Sima, Aug. 2011. C C KEYWORDS C C Elementary matrix operations, orthogonal symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) C .. Scalar Arguments .. CHARACTER TRANQ1, TRANQ2 INTEGER INFO, K, LDQ1, LDQ2, LDWORK, M, N C .. Array Arguments .. DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) C .. Local Scalars .. LOGICAL LQUERY, LTRQ1, LTRQ2 INTEGER I, IB, IERR, KI, KK, MINWRK, NB, NBMIN, NX, $ PDRS, PDT, PDW, WRKOPT C .. External Functions .. LOGICAL LSAME INTEGER UE01MD EXTERNAL LSAME, UE01MD C .. External Subroutines .. EXTERNAL DORGQR, MB04QC, MB04QF, MB04WU, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 LTRQ1 = LSAME( TRANQ1, 'T' ) .OR. LSAME( TRANQ1,'C' ) LTRQ2 = LSAME( TRANQ2, 'T' ) .OR. LSAME( TRANQ2,'C' ) C C Check the scalar input parameters. C IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN INFO = -2 ELSE IF ( M.LT.0 ) THEN INFO = -3 ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN INFO = -4 ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN INFO = -5 ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR. $ ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN INFO = -7 ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR. $ ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN INFO = -9 ELSE LQUERY = LDWORK.EQ.-1 MINWRK = MAX( 1, M + N ) IF ( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN DWORK(1) = DBLE( MINWRK ) INFO = -13 ELSE IF ( MIN( M, N ).EQ.0 ) THEN WRKOPT = ONE ELSE CALL DORGQR( M, N, K, DWORK, M, DWORK, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) NB = INT( WRKOPT/N ) WRKOPT = MAX( WRKOPT, 8*N*NB + 15*NB*NB ) END IF IF ( LQUERY ) THEN DWORK(1) = DBLE( WRKOPT ) RETURN END IF END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04WD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C NBMIN = 2 NX = 0 IF( NB.GT.1 .AND. NB.LT.K ) THEN C C Determine when to cross over from blocked to unblocked code. C NX = MAX( 0, UE01MD( 3, 'MB04WD', TRANQ1 // TRANQ2, M, N, K ) ) IF ( NX.LT.K ) THEN C C Determine if workspace is large enough for blocked code. C IF( LDWORK.LT.WRKOPT ) THEN C C Not enough workspace to use optimal NB: reduce NB and C determine the minimum value of NB. C NB = INT( ( SQRT( DBLE( 16*N*N + 15*LDWORK ) ) $ - DBLE( 4*N ) ) / 15.0D0 ) NBMIN = MAX( 2, UE01MD( 2, 'MB04WD', TRANQ1 // TRANQ2, M, $ N, K ) ) END IF END IF END IF C IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN C C Use blocked code after the last block. C The first kk columns are handled by the block method. C KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) ELSE KK = 0 END IF C C Use unblocked code for the last or only block. C IF ( KK.LT.N ) $ CALL MB04WU( TRANQ1, TRANQ2, M-KK, N-KK, K-KK, Q1(KK+1,KK+1), $ LDQ1, Q2(KK+1,KK+1), LDQ2, CS(2*KK+1), TAU(KK+1), $ DWORK, LDWORK, IERR ) C C Blocked code. C IF ( KK.GT.0 ) THEN PDRS = 1 PDT = PDRS + 6*NB*NB PDW = PDT + 9*NB*NB IF ( LTRQ1.AND.LTRQ2 ) THEN DO 10 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF ( I+IB.LE.N ) THEN C C Form the triangular factors of the symplectic block C reflector SH. C CALL MB04QF( 'Forward', 'Rowwise', 'Rowwise', M-I+1, $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, $ DWORK(PDT), NB, DWORK(PDW) ) C C Apply SH to Q1(i+ib:n,i:m) and Q2(i+ib:n,i:m) from C the right. C CALL MB04QC( 'Zero Structure', 'Transpose', $ 'Transpose', 'No Transpose', 'Forward', $ 'Rowwise', 'Rowwise', M-I+1, N-I-IB+1, $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, $ DWORK(PDRS), NB, DWORK(PDT), NB, $ Q2(I+IB,I), LDQ2, Q1(I+IB,I), LDQ1, $ DWORK(PDW) ) END IF C C Apply SH to columns i:m of the current block. C CALL MB04WU( 'Transpose', 'Transpose', M-I+1, IB, IB, $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), $ TAU(I), DWORK, LDWORK, IERR ) 10 CONTINUE C ELSE IF ( LTRQ1 ) THEN DO 20 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF ( I+IB.LE.N ) THEN C C Form the triangular factors of the symplectic block C reflector SH. C CALL MB04QF( 'Forward', 'Rowwise', 'Columnwise', $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, $ DWORK(PDT), NB, DWORK(PDW) ) C C Apply SH to Q1(i+ib:n,i:m) from the right and to C Q2(i:m,i+ib:n) from the left. C CALL MB04QC( 'Zero Structure', 'No Transpose', $ 'Transpose', 'No Transpose', $ 'Forward', 'Rowwise', 'Columnwise', $ M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1, $ Q2(I,I), LDQ2, DWORK(PDRS), NB, $ DWORK(PDT), NB, Q2(I,I+IB), LDQ2, $ Q1(I+IB,I), LDQ1, DWORK(PDW) ) END IF C C Apply SH to columns/rows i:m of the current block. C CALL MB04WU( 'Transpose', 'No Transpose', M-I+1, IB, IB, $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), $ TAU(I), DWORK, LDWORK, IERR ) 20 CONTINUE C ELSE IF ( LTRQ2 ) THEN DO 30 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF ( I+IB.LE.N ) THEN C C Form the triangular factors of the symplectic block C reflector SH. C CALL MB04QF( 'Forward', 'Columnwise', 'Rowwise', $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, $ DWORK(PDT), NB, DWORK(PDW) ) C C Apply SH to Q1(i:m,i+ib:n) from the left and to C Q2(i+ib:n,i:m) from the right. C CALL MB04QC( 'Zero Structure', 'Transpose', $ 'No Transpose', 'No Transpose', 'Forward', $ 'Columnwise', 'Rowwise', M-I+1, N-I-IB+1, $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, $ DWORK(PDRS), NB, DWORK(PDT), NB, $ Q2(I+IB,I), LDQ2, Q1(I,I+IB), LDQ1, $ DWORK(PDW) ) END IF C C Apply SH to columns/rows i:m of the current block. C CALL MB04WU( 'No Transpose', 'Transpose', M-I+1, IB, IB, $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), $ TAU(I), DWORK, LDWORK, IERR ) 30 CONTINUE C ELSE DO 40 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) IF ( I+IB.LE.N ) THEN C C Form the triangular factors of the symplectic block C reflector SH. C CALL MB04QF( 'Forward', 'Columnwise', 'Columnwise', $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, $ DWORK(PDT), NB, DWORK(PDW) ) C C Apply SH to Q1(i:m,i+ib:n) and Q2(i:m,i+ib:n) from C the left. C CALL MB04QC( 'Zero Structure', 'No Transpose', $ 'No Transpose', 'No Transpose', $ 'Forward', 'Columnwise', 'Columnwise', $ M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1, $ Q2(I,I), LDQ2, DWORK(PDRS), NB, $ DWORK(PDT), NB, Q2(I,I+IB), LDQ2, $ Q1(I,I+IB), LDQ1, DWORK(PDW) ) END IF C C Apply SH to rows i:m of the current block. C CALL MB04WU( 'No Transpose', 'No Transpose', M-I+1, IB, $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), $ TAU(I), DWORK, LDWORK, IERR ) 40 CONTINUE END IF END IF C DWORK(1) = DBLE( WRKOPT ) C RETURN C *** Last line of MB04WD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03XD.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03XD.f0000644000175000017500000010060215012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE MB03XD( BALANC, JOB, JOBU, JOBV, N, A, LDA, QG, LDQG, $ T, LDT, U1, LDU1, U2, LDU2, V1, LDV1, V2, LDV2, $ WR, WI, ILO, SCALE, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the eigenvalues of a Hamiltonian matrix, C C [ A G ] T T C H = [ T ], G = G, Q = Q, (1) C [ Q -A ] C C where A, G and Q are real n-by-n matrices. C C Due to the structure of H all eigenvalues appear in pairs C (lambda,-lambda). This routine computes the eigenvalues of H C using an algorithm based on the symplectic URV and the periodic C Schur decompositions as described in [1], C C T [ T G ] C U H V = [ T ], (2) C [ 0 S ] C C where U and V are 2n-by-2n orthogonal symplectic matrices, C S is in real Schur form and T is upper triangular. C C The algorithm is backward stable and preserves the eigenvalue C pairings in finite precision arithmetic. C C Optionally, a symplectic balancing transformation to improve the C conditioning of eigenvalues is computed (see MB04DD). In this C case, the matrix H in decomposition (2) must be replaced by the C balanced matrix. C C The SLICOT Library routine MB03ZD can be used to compute invariant C subspaces of H from the output of this routine. C C ARGUMENTS C C Mode Parameters C C BALANC CHARACTER*1 C Indicates how H should be diagonally scaled and/or C permuted to reduce its norm. C = 'N': Do not diagonally scale or permute; C = 'P': Perform symplectic permutations to make the matrix C closer to Hamiltonian Schur form. Do not diagonally C scale; C = 'S': Diagonally scale the matrix, i.e., replace A, G and C Q by D*A*D**(-1), D*G*D and D**(-1)*Q*D**(-1) where C D is a diagonal matrix chosen to make the rows and C columns of H more equal in norm. Do not permute; C = 'B': Both diagonally scale and permute A, G and Q. C Permuting does not change the norm of H, but scaling does. C C JOB CHARACTER*1 C Indicates whether the user wishes to compute the full C decomposition (2) or the eigenvalues only, as follows: C = 'E': compute the eigenvalues only; C = 'S': compute matrices T and S of (2); C = 'G': compute matrices T, S and G of (2). C C JOBU CHARACTER*1 C Indicates whether or not the user wishes to compute the C orthogonal symplectic matrix U of (2) as follows: C = 'N': the matrix U is not computed; C = 'U': the matrix U is computed. C C JOBV CHARACTER*1 C Indicates whether or not the user wishes to compute the C orthogonal symplectic matrix V of (2) as follows: C = 'N': the matrix V is not computed; C = 'V': the matrix V is computed. 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 part of this array must C contain the matrix A. C On exit, this array is overwritten. If JOB = 'S' or C JOB = 'G', the leading N-by-N part of this array contains C the matrix S in real Schur form of decomposition (2). C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C QG (input/output) DOUBLE PRECISION array, dimension C (LDQG,N+1) C On entry, the leading N-by-N+1 part of this array must C contain in columns 1:N the lower triangular part of the C matrix Q and in columns 2:N+1 the upper triangular part C of the matrix G. C On exit, this array is overwritten. If JOB = 'G', the C leading N-by-N+1 part of this array contains in columns C 2:N+1 the matrix G of decomposition (2). C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= max(1,N). C C T (output) DOUBLE PRECISION array, dimension (LDT,N) C On exit, if JOB = 'S' or JOB = 'G', the leading N-by-N C part of this array contains the upper triangular matrix T C of the decomposition (2). Otherwise, this array is used as C workspace. C C LDT INTEGER C The leading dimension of the array T. LDT >= MAX(1,N). C C U1 (output) DOUBLE PRECISION array, dimension (LDU1,N) C On exit, if JOBU = 'U', the leading N-by-N part of this C array contains the (1,1) block of the orthogonal C symplectic matrix U of decomposition (2). C C LDU1 INTEGER C The leading dimension of the array U1. LDU1 >= 1. C LDU1 >= N, if JOBU = 'U'. C C U2 (output) DOUBLE PRECISION array, dimension (LDU2,N) C On exit, if JOBU = 'U', the leading N-by-N part of this C array contains the (2,1) block of the orthogonal C symplectic matrix U of decomposition (2). C C LDU2 INTEGER C The leading dimension of the array U2. LDU2 >= 1. C LDU2 >= N, if JOBU = 'U'. C C V1 (output) DOUBLE PRECISION array, dimension (LDV1,N) C On exit, if JOBV = 'V', the leading N-by-N part of this C array contains the (1,1) block of the orthogonal C symplectic matrix V of decomposition (2). C C LDV1 INTEGER C The leading dimension of the array V1. LDV1 >= 1. C LDV1 >= N, if JOBV = 'V'. C C V2 (output) DOUBLE PRECISION array, dimension (LDV2,N) C On exit, if JOBV = 'V', the leading N-by-N part of this C array contains the (2,1) block of the orthogonal C symplectic matrix V of decomposition (2). C C LDV2 INTEGER C The leading dimension of the array V2. LDV2 >= 1. C LDV2 >= N, if JOBV = 'V'. C C WR (output) DOUBLE PRECISION array, dimension (N) C WI (output) DOUBLE PRECISION array, dimension (N) C On exit, the leading N elements of WR and WI contain the C real and imaginary parts, respectively, of N eigenvalues C that have nonnegative imaginary part. Their complex C conjugate eigenvalues are not stored. If imaginary parts C are zero (i.e., for real eigenvalues), only positive C eigenvalues are stored. C C ILO (output) INTEGER C ILO is an integer value determined when H was balanced. C The balanced A(i,j) = 0 if I > J and J = 1,...,ILO-1. C The balanced Q(i,j) = 0 if J = 1,...,ILO-1 or C I = 1,...,ILO-1. C C SCALE (output) DOUBLE PRECISION array, dimension (N) C On exit, if BALANC <> 'N', the leading N elements of this C array contain details of the permutation and/or scaling C factors applied when balancing H, see MB04DD. C This array is not referenced if BALANC = 'N'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK, and DWORK(2) returns the 1-norm of the C scaled (if BALANC = 'S' or 'B') Hamiltonian matrix. C On exit, if INFO = -25, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK (input) INTEGER C The dimension of the array DWORK. LDWORK >= max( 2, 8*N ). C Moreover: C If JOB = 'E' or 'S' and JOBU = 'N' and JOBV = 'N', C LDWORK >= 7*N+N*N. C If JOB = 'G' and JOBU = 'N' and JOBV = 'N', C LDWORK >= max( 7*N+N*N, 2*N+3*N*N ). C If JOB = 'G' and JOBU = 'U' and JOBV = 'N', C LDWORK >= 7*N+2*N*N. C If JOB = 'G' and JOBU = 'N' and JOBV = 'V', C LDWORK >= 7*N+2*N*N. C If JOB = 'G' and JOBU = 'U' and JOBV = 'V', C LDWORK >= 7*N+N*N. C For good performance, LDWORK must generally 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 (output) 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 periodic QR algorithm failed to C compute all the eigenvalues, elements i+1:N of WR C and WI contain eigenvalues which have converged. C C REFERENCES C C [1] Benner, P., Mehrmann, V., and Xu, H. C A numerically stable, structure preserving method for C computing the eigenvalues of real Hamiltonian or symplectic C pencils. C Numer. Math., Vol. 78(3), pp. 329-358, 1998. C C [2] Benner, P., Mehrmann, V., and Xu, H. C A new method for computing the stable invariant subspace of a C real Hamiltonian matrix, J. Comput. Appl. Math., vol. 86, C pp. 17-43, 1997. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAESU). C V. Sima, Aug. 2011, Oct. 2011, July 2012, Mar. 2015, May 2015. C C KEYWORDS C C Eigenvalues, invariant subspace, Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER BALANC, JOB, JOBU, JOBV INTEGER ILO, INFO, LDA, LDQG, LDT, LDU1, LDU2, LDV1, $ LDV2, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), SCALE(*), $ T(LDT,*), U1(LDU1,*), U2(LDU2,*), V1(LDV1,*), $ V2(LDV2,*), WI(*), WR(*) C .. Local Scalars .. CHARACTER UCHAR, VCHAR LOGICAL LPERM, LQUERY, LSCAL, SCALEH, WANTG, WANTS, $ WANTU, WANTV INTEGER I, IERR, ILO1, J, K, L, PBETA, PCSL, PCSR, PDW, $ PQ, PTAUL, PTAUR, PZ, WRKMIN, WRKOPT DOUBLE PRECISION BIGNUM, CSCALE, EPS, HNR1, HNRM, SMLNUM, TEMP, $ TEMPI, TEMPR C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, MA02ID EXTERNAL DLAMCH, LSAME, MA02ID C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DLABAD, DLACPY, DLASCL, DLASET, $ DSCAL, MA01AD, MB03XP, MB04DD, MB04QB, MB04TB, $ XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, SQRT C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 LPERM = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) LSCAL = LSAME( BALANC, 'S' ) .OR. LSAME( BALANC, 'B' ) WANTS = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'G' ) WANTG = LSAME( JOB, 'G' ) WANTU = LSAME( JOBU, 'U' ) WANTV = LSAME( JOBV, 'V' ) C IF ( WANTG ) THEN IF ( WANTU .AND. WANTV ) THEN WRKMIN = MAX( 2, 7*N + N*N ) ELSE IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN WRKMIN = MAX( 2, 7*N + N*N, 2*N + 3*N*N ) ELSE WRKMIN = MAX( 2, 7*N + 2*N*N ) END IF ELSE IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN WRKMIN = MAX( 2, 7*N + N*N ) ELSE WRKMIN = MAX( 2, 8*N ) END IF END IF C C Test the scalar input parameters. C IF ( .NOT.LPERM .AND. .NOT.LSCAL $ .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN INFO = -1 ELSE IF ( .NOT.WANTS .AND. .NOT.LSAME( JOB, 'E' ) ) THEN INFO = -2 ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN INFO = -3 ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN INFO = -4 ELSE IF ( N.LT.0 ) THEN INFO = -5 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF ( LDT.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN INFO = -13 ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN INFO = -15 ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. LDV1.LT.N ) ) THEN INFO = -17 ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. LDV2.LT.N ) ) THEN INFO = -19 ELSE LQUERY = LDWORK.EQ.-1 IF ( LQUERY ) THEN IF ( N.EQ.0 ) THEN WRKOPT = TWO ELSE PTAUR = 5*N PDW = PTAUR + N IF ( .NOT.WANTU .AND. .NOT.WANTV ) $ PDW = PDW + N*N CALL MB04TB( 'No Transpose', 'Transpose', N, N, DWORK, $ LDT, DWORK, LDT, DWORK, LDT, DWORK, LDT, $ DWORK, DWORK, DWORK, DWORK, DWORK, -1, $ IERR ) WRKOPT = MAX( WRKMIN, INT( DWORK(1) ) + PDW ) C IF ( WANTU .OR. WANTV ) THEN IF ( .NOT.WANTG ) THEN PDW = PTAUR + N IF ( WANTU .AND. WANTV ) $ PDW = PDW + N ELSE PDW = PTAUR + N*N IF ( .NOT.WANTU .AND. WANTV ) $ PDW = PDW + 2*N END IF CALL MB04QB( 'No Transpose', 'No Transpose', $ 'No Transpose','Columnwise', $ 'Columnwise', N, N, N, DWORK, LDT, DWORK, $ LDT, DWORK, LDT, DWORK, LDT, DWORK, $ DWORK, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW ) END IF END IF DWORK(1) = DBLE( WRKOPT ) RETURN ELSE IF ( LDWORK.LT.WRKMIN ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = -25 END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03XD', -INFO ) RETURN END IF C C Quick return if possible. C ILO = 0 IF( N.EQ.0 ) THEN DWORK(1) = TWO DWORK(2) = ZERO RETURN END IF C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM C C Scale H if maximal element is outside range [SMLNUM,BIGNUM]. C HNRM = MA02ID( 'Hamiltonian', 'MaxElement', N, A, LDA, QG, LDQG, $ DWORK ) SCALEH = .FALSE. IF ( HNRM.GT.ZERO .AND. HNRM.LT.SMLNUM ) THEN SCALEH = .TRUE. CSCALE = SMLNUM ELSE IF( HNRM.GT.BIGNUM ) THEN SCALEH = .TRUE. CSCALE = BIGNUM END IF IF ( SCALEH ) THEN CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N, A, LDA, IERR ) CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N+1, QG, LDQG, $ IERR ) END IF C C Balance the matrix and compute the 1-norm. C IF ( LPERM .OR. LSCAL ) THEN CALL MB04DD( BALANC, N, A, LDA, QG, LDQG, ILO, SCALE, IERR ) ELSE ILO = 1 END IF HNR1 = MA02ID( 'Hamiltonian', '1-norm', N, A, LDA, QG, LDQG, $ DWORK ) C C Copy A to T and multiply A by -1. C CALL DLACPY( 'All', N, N, A, LDA, T, LDT ) CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, A, LDA, IERR ) C C --------------------------------------------- C Step 1: Compute symplectic URV decomposition. C --------------------------------------------- C PCSL = 1 PCSR = PCSL + 2*N PTAUL = PCSR + 2*N PTAUR = PTAUL + N PDW = PTAUR + N IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN C C Copy Q and Q' to workspace. C PQ = PDW PDW = PDW + N*N DO 20 J = 1, N K = PQ + (N+1)*(J-1) L = K DWORK(K) = QG(J,J) DO 10 I = J+1, N K = K + 1 L = L + N TEMP = QG(I,J) DWORK(K) = TEMP DWORK(L) = TEMP 10 CONTINUE 20 CONTINUE ELSE IF ( WANTU ) THEN C C Copy Q and Q' to U2. C DO 40 J = 1, N U2(J,J) = QG(J,J) DO 30 I = J+1, N TEMP = QG(I,J) U2(I,J) = TEMP U2(J,I) = TEMP 30 CONTINUE 40 CONTINUE ELSE C C Copy Q and Q' to V2. C DO 60 J = 1, N V2(J,J) = QG(J,J) DO 50 I = J+1, N TEMP = QG(I,J) V2(I,J) = TEMP V2(J,I) = TEMP 50 CONTINUE 60 CONTINUE END IF C C Transpose G. C DO 80 J = 1, N DO 70 I = J+1, N QG(I,J+1) = QG(J,I+1) 70 CONTINUE 80 CONTINUE C IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN CALL MB04TB( 'No Transpose', 'Transpose', N, ILO, T, LDT, A, $ LDA, QG(1,2), LDQG, DWORK(PQ), N, DWORK(PCSL), $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), $ DWORK(PDW), LDWORK-PDW+1, IERR ) ELSE IF ( WANTU ) THEN CALL MB04TB( 'No Transpose', 'Transpose', N, ILO, T, LDT, A, $ LDA, QG(1,2), LDQG, U2, LDU2, DWORK(PCSL), $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), $ DWORK(PDW), LDWORK-PDW+1, IERR ) ELSE CALL MB04TB( 'No Transpose', 'Transpose', N, ILO, T, LDT, A, $ LDA, QG(1,2), LDQG, V2, LDV2, DWORK(PCSL), $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), $ DWORK(PDW), LDWORK-PDW+1, IERR ) END IF WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) C IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN IF ( N.GT.1 ) $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, QG(2,1), LDQG ) ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN IF ( N.GT.1 ) THEN CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG ) CALL DLACPY( 'Upper', N-1, N-1, V2(1,2), LDV2, QG(1,2), $ LDQG ) END IF ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN IF ( N.GT.1 ) THEN CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, V2(2,1), LDV2 ) CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG ) END IF ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN IF ( N.GT.1 ) $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, $ DWORK(PDW+N*N+N), N-1 ) ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN IF ( N.GT.2 ) $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, $ DWORK(PDW+N*N+N), N-2 ) ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN IF ( N.GT.1 ) $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, $ DWORK(PDW+N), N-1 ) IF ( N.GT.2 ) $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, V2(3,1), LDV2 ) END IF C C ---------------------------------------------- C Step 2: Compute periodic Schur decomposition. C ---------------------------------------------- C IF ( N.GT.2 ) $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN PBETA = 1 ELSE PBETA = PDW END IF C IF ( .NOT.WANTG ) THEN C C Workspace requirements: 2*N (8*N with U or V). C PDW = PBETA + N IF ( WANTU ) THEN UCHAR = 'I' ELSE UCHAR = 'N' END IF IF ( WANTV ) THEN VCHAR = 'I' ELSE VCHAR = 'N' END IF CALL MB03XP( JOB, VCHAR, UCHAR, N, ILO, N, A, LDA, T, LDT, V1, $ LDV1, U1, LDU1, WR, WI, DWORK(PBETA), DWORK(PDW), $ LDWORK-PDW+1, INFO ) IF ( INFO.NE.0 ) $ GO TO 90 WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) C ELSE IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN C C Workspace requirements: 3*N*N + 2*N. C PQ = PBETA + N PZ = PQ + N*N PDW = PZ + N*N CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, $ LDT, DWORK(PQ), N, DWORK(PZ), N, WR, WI, $ DWORK(PBETA), DWORK(PDW), LDWORK-PDW+1, INFO ) IF ( INFO.NE.0 ) $ GO TO 90 WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, $ DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG ) ELSE IF ( WANTU .AND. .NOT.WANTV ) THEN C C Workspace requirements: 2*N*N + 7*N. C PQ = PBETA + N PDW = PQ + N*N CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, $ LDT, DWORK(PQ), N, U1, LDU1, WR, WI, DWORK(PBETA), $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, $ INFO ) IF ( INFO.NE.0 ) $ GO TO 90 WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW $ + (N-1)*(N-1) - 1 ) IF ( N.GT.1 ) $ CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1), $ LDT ) CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, $ U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG ) C ELSE IF ( .NOT.WANTU .AND. WANTV ) THEN C C Workspace requirements: 2*N*N + 7*N C PZ = PBETA + N PDW = PZ + N*N CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, $ LDT, V1, LDV1, DWORK(PZ), N, WR, WI, DWORK(PBETA), $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, $ INFO ) IF ( INFO.NE.0 ) $ GO TO 90 WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW $ + (N-1)*(N-1) - 1 ) IF ( N.GT.2 ) $ CALL DLACPY( 'Lower', N-2, N-2, DWORK(PDW), N-2, A(3,1), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, $ DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG ) C ELSE C C Workspace requirements: N*N + 7*N. C PDW = PBETA + N CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, $ LDT, V1, LDV1, U1, LDU1, WR, WI, DWORK(PBETA), $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, $ INFO ) IF ( INFO.NE.0 ) $ GO TO 90 WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW $ + (N-1)*(N-1) - 1 ) IF ( N.GT.1 ) $ CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1), $ LDT ) IF ( N.GT.2 ) $ CALL DLACPY( 'Lower', N-2, N-2, V2(3,1), LDV2, A(3,1), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, $ U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, $ DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG ) END IF C 90 CONTINUE C C Compute square roots of eigenvalues and rescale. C I = INFO + 1 C WHILE I <= N 100 CONTINUE IF ( I.LE.N ) THEN TEMPR = WR(I) TEMPI = WI(I) TEMP = DWORK(PBETA + I - 1) IF ( TEMP.GT.ZERO ) $ TEMPR = -TEMPR TEMP = ABS( TEMP ) IF ( TEMPI.EQ.ZERO ) THEN IF ( TEMPR.LT.ZERO ) THEN WR(I) = ZERO WI(I) = SQRT( TEMP ) * SQRT( -TEMPR ) ELSE WR(I) = SQRT( TEMP ) * SQRT( TEMPR ) WI(I) = ZERO END IF I = I + 1 ELSE CALL MA01AD( TEMPR, TEMPI, WR(I), WI(I) ) WR(I) = WR(I) * SQRT( TEMP ) IF ( TEMP.GT.ZERO ) THEN WI(I) = WI(I) * SQRT( TEMP ) ELSE WI(I) = ZERO END IF WR(I+1) = -WR(I) WI(I+1) = WI(I) I = I + 2 END IF GO TO 100 C END WHILE END IF C IF ( SCALEH ) THEN C C Undo scaling. C CALL DLASCL( 'Hessenberg', 0, 0, CSCALE, HNRM, N, N, A, LDA, $ IERR ) CALL DLASCL( 'Upper', 0, 0, CSCALE, HNRM, N, N, T, LDT, IERR ) If ( WANTG ) $ CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, N, QG(1,2), $ LDQG, IERR ) CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WR, N, IERR ) CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WI, N, IERR ) HNR1 = HNR1 * HNRM / CSCALE END IF C IF ( INFO.NE.0 ) $ RETURN C IF ( ILO.GT.N ) THEN DWORK(1) = DBLE( WRKOPT ) DWORK(2) = HNR1 RETURN END IF C C ----------------------------------------------- C Step 3: Compute orthogonal symplectic factors. C ----------------------------------------------- C C Fix CSL and CSR for MB04QB. C IF ( WANTU ) $ CALL DSCAL( N, -ONE, DWORK(PCSL+1), 2 ) IF ( WANTV ) $ CALL DSCAL( N-1, -ONE, DWORK(PCSR+1), 2 ) ILO1 = MIN( N, ILO + 1 ) C IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN C C Workspace requirements: 7*N. C PDW = PTAUR CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 ) CALL DLACPY( 'Lower', N, N, U2, LDU2, T, LDT ) CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, $ QG(ILO,ILO), LDQG, T(ILO,ILO), LDT, U1(ILO,1), $ LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2), $ DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 ) IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) C ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN C C Workspace requirements: 7*N. C PDW = PTAUR + N CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', $ 'Columnwise', 'Rowwise', N-ILO, N, N-ILO, $ QG(ILO1,ILO), LDQG, QG(ILO,ILO1), LDQG, $ V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), $ DWORK(PDW), LDWORK-PDW+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) C ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN C C Workspace requirements: 8*N. C PDW = PTAUR + N CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 ) CALL DLACPY( 'Lower', N, N, V2, LDV2, T, LDT ) CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', $ 'Columnwise', 'Rowwise', N-ILO, N, N-ILO, $ QG(ILO1,ILO), LDQG, U2(ILO,ILO1), LDU2, $ V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), $ DWORK(PDW+N), LDWORK-PDW-N+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) C CALL DLACPY( 'Lower', N, N, U2, LDU2, QG, LDQG ) CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, $ T(ILO,ILO), LDT, QG(ILO,ILO), LDQG, U1(ILO,1), $ LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2), $ DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 ) IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) C ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN C C Workspace requirements: 6*N + N*N. C PQ = PTAUR PDW = PQ + N*N CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N ) CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, $ T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N, $ U1(ILO,1), LDU1, U2(ILO,1), LDU2, $ DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1), $ DWORK(PDW), LDWORK-PDW+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) C ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN C C Workspace requirements: 7*N + N*N. C PQ = PTAUR + N PDW = PQ + N*N CALL DLACPY( 'Upper', N, N, V2, LDV2, DWORK(PQ), N ) CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', $ 'Columnwise', 'Rowwise', N-ILO, N, N-ILO, $ A(ILO1,ILO), LDA, DWORK(PQ+ILO*N+ILO-1), $ N, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), $ DWORK(PDW+N), LDWORK-PDW-N+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) IF ( N.GT.2 ) $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) C ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN C C Workspace requirements: 6*N + N*N. C PDW = PTAUR + N CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', $ 'Columnwise', 'Rowwise', N-ILO, N, N-ILO, $ A(ILO1,ILO), LDA, U2(ILO,ILO1), LDU2, V1(ILO1,1), $ LDV1, V2(ILO1,1), LDV2, DWORK(PCSR+2*ILO-2), $ DWORK(PTAUR+ILO-1), DWORK(PDW), LDWORK-PDW+1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) C PQ = PTAUR PDW = PQ + N*N CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N ) CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, $ T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N, $ U1(ILO,1), LDU1, U2(ILO,1), LDU2, $ DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1), $ DWORK(PDW), LDWORK-PDW+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) IF ( N.GT.2 ) $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) END IF C DWORK(1) = DBLE( WRKOPT ) DWORK(2) = HNR1 RETURN C *** Last line of MB03XD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04QU.f0000644000000000000000000000013215012430707016205 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04QU.f0000644000175000017500000004036215012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K, $ V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To overwrite general real m-by-n matrices C and D, or their C transposes, with C C [ op(C) ] C Q * [ ] if TRANQ = 'N', or C [ op(D) ] C C T [ op(C) ] C Q * [ ] if TRANQ = 'T', C [ op(D) ] C C where Q is defined as the product of symplectic reflectors and C Givens rotations, C C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). C C Unblocked version. C C ARGUMENTS C C Mode Parameters C C TRANC CHARACTER*1 C Specifies the form of op( C ) as follows: C = 'N': op( C ) = C; C = 'T': op( C ) = C'; C = 'C': op( C ) = C'. C C STOREV CHARACTER*1 C Specifies how the vectors which define the concatenated C Householder reflectors contained in V are stored: C = 'C': columnwise; C = 'R': rowwise. C C STOREW CHARACTER*1 C Specifies how the vectors which define the concatenated C Householder reflectors contained in W are stored: C = 'C': columnwise; C = 'R': rowwise. C C TRAND CHARACTER*1 C Specifies the form of op( D ) as follows: C = 'N': op( D ) = D; C = 'T': op( D ) = D'; C = 'C': op( D ) = D'. C C TRANQ CHARACTER*1 C = 'N': apply Q; C = 'T': apply Q'. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrices op(C) and op(D). C M >= 0. C C N (input) INTEGER C The number of columns of the matrices op(C) and op(D). C N >= 0. C C K (input) INTEGER C The number of elementary reflectors whose product defines C the matrix Q. M >= K >= 0. C C V (input) DOUBLE PRECISION array, dimension C (LDV,K) if STOREV = 'C', C (LDV,M) if STOREV = 'R' C On entry with STOREV = 'C', the leading M-by-K part of C this array must contain in its columns the vectors which C define the elementary reflectors F(i). C On entry with STOREV = 'R', the leading K-by-M part of C this array must contain in its rows the vectors which C define the elementary reflectors F(i). C C LDV INTEGER C The leading dimension of the array V. C LDV >= MAX(1,M), if STOREV = 'C'; C LDV >= MAX(1,K), if STOREV = 'R'. C C W (input) DOUBLE PRECISION array, dimension C (LDW,K) if STOREW = 'C', C (LDW,M) if STOREW = 'R' C On entry with STOREW = 'C', the leading M-by-K part of C this array must contain in its columns the vectors which C define the elementary reflectors H(i). C On entry with STOREW = 'R', the leading K-by-M part of C this array must contain in its rows the vectors which C define the elementary reflectors H(i). C C LDW INTEGER C The leading dimension of the array W. C LDW >= MAX(1,M), if STOREW = 'C'; C LDW >= MAX(1,K), if STOREW = 'R'. C C C (input/output) DOUBLE PRECISION array, dimension C (LDC,N) if TRANC = 'N', C (LDC,M) if TRANC = 'T' or TRANC = 'C' C On entry with TRANC = 'N', the leading M-by-N part of C this array must contain the matrix C. C On entry with TRANC = 'C' or TRANC = 'T', the leading C N-by-M part of this array must contain the transpose of C the matrix C. C On exit with TRANC = 'N', the leading M-by-N part of C this array contains the updated matrix C. C On exit with TRANC = 'C' or TRANC = 'T', the leading C N-by-M part of this array contains the transpose of the C updated matrix C. C C LDC INTEGER C The leading dimension of the array C. C LDC >= MAX(1,M), if TRANC = 'N'; C LDC >= MAX(1,N), if TRANC = 'T' or TRANC = 'C'. C C D (input/output) DOUBLE PRECISION array, dimension C (LDD,N) if TRAND = 'N', C (LDD,M) if TRAND = 'T' or TRAND = 'C' C On entry with TRAND = 'N', the leading M-by-N part of C this array must contain the matrix D. C On entry with TRAND = 'C' or TRAND = 'T', the leading C N-by-M part of this array must contain the transpose of C the matrix D. C On exit with TRAND = 'N', the leading M-by-N part of C this array contains the updated matrix D. C On exit with TRAND = 'C' or TRAND = 'T', the leading C N-by-M part of this array contains the transpose of the C updated matrix D. C C LDD INTEGER C The leading dimension of the array D. C LDD >= MAX(1,M), if TRAND = 'N'; C LDD >= MAX(1,N), if TRAND = 'T' or TRAND = 'C'. C C CS (input) DOUBLE PRECISION array, dimension (2*K) C On entry, the first 2*K elements of this array must C contain the cosines and sines of the symplectic Givens C rotations G(i). C C TAU (input) DOUBLE PRECISION array, dimension (K) C On entry, the first K elements of this array must C contain the scalar factors of the elementary reflectors C F(i). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -20, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,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 CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSMSQ). C C KEYWORDS C C Elementary matrix operations, orthogonal symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) C .. Scalar Arguments .. CHARACTER STOREV, STOREW, TRANC, TRAND, TRANQ INTEGER INFO, K, LDC, LDD, LDV, LDW, LDWORK, M, N C .. Array Arguments .. DOUBLE PRECISION CS(*), DWORK(*), C(LDC,*), D(LDD,*), V(LDV,*), $ W(LDW,*), TAU(*) C .. Local Scalars .. LOGICAL LCOLV, LCOLW, LTRC, LTRD, LTRQ INTEGER I DOUBLE PRECISION NU C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARF, DROT, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 LCOLV = LSAME( STOREV, 'C' ) LCOLW = LSAME( STOREW, 'C' ) LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' ) LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' ) LTRQ = LSAME( TRANQ, 'T' ) C C Check the scalar input parameters. C IF ( .NOT.( LTRC.OR.LSAME( TRANC, 'N' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN INFO = -2 ELSE IF ( .NOT.( LTRQ .OR. LSAME( TRANQ, 'N' ) ) ) THEN INFO = -3 ELSE IF ( .NOT.( LCOLV.OR. LSAME( STOREV, 'R' ) ) ) THEN INFO = -4 ELSE IF ( .NOT.( LCOLW.OR. LSAME( STOREW, 'R' ) ) ) THEN INFO = -5 ELSE IF ( M.LT.0 ) THEN INFO = -6 ELSE IF ( N.LT.0 ) THEN INFO = -7 ELSE IF ( K.LT.0 .OR. K.GT.M ) THEN INFO = -8 ELSE IF ( ( LCOLV.AND.LDV.LT.MAX( 1, M ) ) .OR. $ ( .NOT.LCOLV.AND.LDV.LT.MAX( 1, K ) ) ) THEN INFO = -10 ELSE IF ( ( LCOLW.AND.LDW.LT.MAX( 1, M ) ) .OR. $ ( .NOT.LCOLW.AND.LDW.LT.MAX( 1, K ) ) ) THEN INFO = -12 ELSE IF ( ( LTRC.AND.LDC.LT.MAX( 1, N ) ) .OR. $ ( .NOT.LTRC.AND.LDC.LT.MAX( 1, M ) ) ) THEN INFO = -14 ELSE IF ( ( LTRD.AND.LDD.LT.MAX( 1, N ) ) .OR. $ ( .NOT.LTRD.AND.LDD.LT.MAX( 1, M ) ) ) THEN INFO = -16 ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN DWORK(1) = DBLE( MAX( 1, N ) ) INFO = -20 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04QU', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( K, M, N ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C IF ( LTRQ ) THEN DO 10 I = 1, K C C Apply H(I) to C(I:M,:) and D(I:M,:) from the left. C NU = W(I,I) W(I,I) = ONE IF ( LCOLW ) THEN IF ( LTRC ) THEN CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I), $ LDC, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1), $ LDC, DWORK ) END IF IF ( LTRD ) THEN CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I), $ LDD, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1), $ LDD, DWORK ) END IF ELSE IF ( LTRC ) THEN CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, $ C(1,I), LDC, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1), $ LDC, DWORK ) END IF IF ( LTRD ) THEN CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, $ D(1,I), LDD, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1), $ LDD, DWORK ) END IF END IF W(I,I) = NU C C Apply G(i) to C(I,:) and D(I,:) from the left. C IF ( LTRC.AND.LTRD ) THEN CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), CS(2*I) ) ELSE IF ( LTRC ) THEN CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1), $ CS(2*I) ) ELSE IF ( LTRD ) THEN CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1), $ CS(2*I) ) ELSE CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1), $ CS(2*I) ) END IF C C Apply F(I) to C(I:M,:) and D(I:M,:) from the left. C NU = V(I,I) V(I,I) = ONE IF ( LCOLV ) THEN IF ( LTRC ) THEN CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), $ C(1,I), LDC, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), $ C(I,1), LDC, DWORK ) END IF IF ( LTRD ) THEN CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), $ D(1,I), LDD, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), $ D(I,1), LDD, DWORK ) END IF ELSE IF ( LTRC ) THEN CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), $ C(1,I), LDC, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), $ C(I,1), LDC, DWORK ) END IF IF ( LTRD ) THEN CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), $ D(1,I), LDD, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), $ D(I,1), LDD, DWORK ) END IF END IF V(I,I) = NU 10 CONTINUE ELSE DO 20 I = K, 1, -1 C C Apply F(I) to C(I:M,:) and D(I:M,:) from the left. C NU = V(I,I) V(I,I) = ONE IF ( LCOLV ) THEN IF ( LTRC ) THEN CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), $ C(1,I), LDC, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), $ C(I,1), LDC, DWORK ) END IF IF ( LTRD ) THEN CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), $ D(1,I), LDD, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), $ D(I,1), LDD, DWORK ) END IF ELSE IF ( LTRC ) THEN CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), $ C(1,I), LDC, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), $ C(I,1), LDC, DWORK ) END IF IF ( LTRD ) THEN CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), $ D(1,I), LDD, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), $ D(I,1), LDD, DWORK ) END IF END IF V(I,I) = NU C C Apply G(i) to C(I,:) and D(I,:) from the left. C IF ( LTRC.AND.LTRD ) THEN CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), -CS(2*I) ) ELSE IF ( LTRC ) THEN CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1), $ -CS(2*I) ) ELSE IF ( LTRD ) THEN CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1), $ -CS(2*I) ) ELSE CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1), $ -CS(2*I) ) END IF C C Apply H(I) to C(I:M,:) and D(I:M,:) from the left. C NU = W(I,I) W(I,I) = ONE IF ( LCOLW ) THEN IF ( LTRC ) THEN CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I), $ LDC, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1), $ LDC, DWORK ) END IF IF ( LTRD ) THEN CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I), $ LDD, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1), $ LDD, DWORK ) END IF ELSE IF ( LTRC ) THEN CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, $ C(1,I), LDC, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1), $ LDC, DWORK ) END IF IF ( LTRD ) THEN CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, $ D(1,I), LDD, DWORK ) ELSE CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1), $ LDD, DWORK ) END IF END IF W(I,I) = NU 20 CONTINUE END IF C DWORK(1) = DBLE( MAX( 1, N ) ) C *** Last line of MB04QU *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03JD.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03JD.f0000644000175000017500000013404115012430707017353 0ustar00lilgelilge00000000000000 SUBROUTINE MB03JD( COMPQ, N, A, LDA, D, LDD, B, LDB, F, LDF, Q, $ LDQ, NEIG, IWORK, LIWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To move the eigenvalues with strictly negative real parts of an C N-by-N real skew-Hamiltonian/Hamiltonian pencil aS - bH in C structured Schur form, C C ( A D ) ( B F ) C S = ( ), H = ( ), C ( 0 A' ) ( 0 -B' ) C C with A upper triangular and B upper quasi-triangular, to the C leading principal subpencil, while keeping the triangular form. C The notation M' denotes the transpose of the matrix M. C The matrices S and H are transformed by an orthogonal matrix Q C such that C C ( Aout Dout ) C Sout = J Q' J' S Q = ( ), C ( 0 Aout' ) C (1) C ( Bout Fout ) ( 0 I ) C Hout = J Q' J' H Q = ( ), with J = ( ), C ( 0 -Bout' ) ( -I 0 ) C C where Aout is upper triangular and Bout is upper quasi-triangular. C Optionally, if COMPQ = 'I' or COMPQ = 'U', the orthogonal matrix Q C that fulfills (1), is computed. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether or not the orthogonal transformations C should be accumulated in the array Q, as follows: C = 'N': Q is not computed; C = 'I': the array Q is initialized internally to the unit C matrix, and the orthogonal matrix Q is returned; C = 'U': the array Q contains an orthogonal matrix Q0 on C entry, and the matrix Q0*Q is returned, where Q C is the product of the orthogonal transformations C that are applied to the pencil aS - bH to reorder C the eigenvalues. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular matrix A. The elements of the C strictly lower triangular part of this array are not used. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Aout. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C D (input/output) DOUBLE PRECISION array, dimension C (LDD, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the skew-symmetric C matrix D. The diagonal need not be set to zero. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper triangular part of the C matrix Dout. C The strictly lower triangular part of this array is C not referenced, except for the element D(N/2,N/2-1), but C its initial value is preserved. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1, N/2). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper quasi-triangular matrix B. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper quasi-triangular part of C the matrix Bout. C The part below the first subdiagonal of this array is C not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C F (input/output) DOUBLE PRECISION array, dimension C (LDF, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the symmetric matrix C F. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper triangular part of the C matrix Fout. C The strictly lower triangular part of this array is not C referenced, except for the element F(N/2,N/2-1), but its C initial value is preserved. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1, N/2). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) C On entry, if COMPQ = 'U', then the leading N-by-N part of C this array must contain a given matrix Q0, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q0 and the transformation matrix Q C used to transform the matrices S and H. C On exit, if COMPQ = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q. C If COMPQ = 'N' this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'. C C NEIG (output) INTEGER C The number of eigenvalues in aS - bH with strictly C negative real part. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= N+1. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The dimension of the array DWORK. C If COMPQ = 'N', C LDWORK >= MAX(2*N+32,108); C if COMPQ = 'I' or COMPQ = 'U', C LDWORK >= MAX(4*N+32,108). C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: error occured during execution of MB03DD; C = 2: error occured during execution of MB03HD. C C METHOD C C The algorithm reorders the eigenvalues like the following scheme: C C Step 1: Reorder the eigenvalues in the subpencil aA - bB. C I. Reorder the eigenvalues with negative real parts to the C top. C II. Reorder the eigenvalues with positive real parts to the C bottom. C C Step 2: Reorder the remaining eigenvalues with negative real C parts in the pencil aS - bH. C I. Exchange the eigenvalues between the last diagonal block C in aA - bB and the last diagonal block in aS - bH. C II. Move the eigenvalues of the R-th block to the (MM+1)-th C block, where R denotes the number of upper quasi- C triangular blocks in aA - bB and MM denotes the current C number of blocks in aA - bB with eigenvalues with negative C real parts. C C The algorithm uses a sequence of orthogonal transformations as C described on page 33 in [1]. To achieve those transformations the C elementary subroutines MB03DD and MB03HD are called for the C corresponding matrix structures. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 16, 2008. C V. Sima, Dec. 2009 (SLICOT version of the routine DHAUNX). C C REVISIONS C C V. Sima, Aug. 2009; Jan. 2010, Oct. 2010, Nov. 2010. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue reordering, upper (quasi-)triangular matrix, C skew-Hamiltonian/Hamiltonian pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF, TEN PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0, $ TEN = 1.0D+1 ) C C .. Scalar Arguments .. CHARACTER COMPQ INTEGER INFO, LDA, LDB, LDD, LDF, LDQ, LDWORK, LIWORK, $ N, NEIG C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( LDD, * ), $ DWORK( * ), F( LDF, * ), Q( LDQ, * ) C C .. Local Scalars .. LOGICAL LCMPQ, LINIQ, LUPDQ INTEGER DIM1, DIM2, HLP, I, IA, IAUPLE, IB, IB1, IB2, $ IB3, IBUPLE, IBUPRI, IC, ICS, IQ1, IQ2, IQLOLE, $ IQLORI, IQUPLE, IQUPRI, IR, IS, ITMP1, ITMP2, $ ITMP3, IUPD, IWRK1, IWRK2, IWRK3, IWRK4, IWRK5, $ J, K, LDW, M, MM, MP, NCOL, NCOLS, NROW, NROWS, $ OPTDW, R, SDIM, UPDS DOUBLE PRECISION A2, D1, D2, D3, F2, NRMA, NRMB, PREC, Q11, Q12, $ Q21, Q22, TMP, TOL C C .. Local Arrays .. DOUBLE PRECISION PAR( 2 ) C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLANHS, DLANTR EXTERNAL DDOT, DLAMCH, DLANHS, DLANTR, LSAME C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, DLASET, $ DSCAL, MB01LD, MB01RU, MB01RX, MB03DD, MB03HD, $ XERBLA C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD, SIGN C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LCMPQ = LINIQ .OR. LUPDQ IF( LCMPQ ) THEN OPTDW = MAX( 4*N+32, 108 ) ELSE OPTDW = MAX( 2*N+32, 108 ) END IF C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN INFO = -12 ELSE IF( LIWORK.LT.N+1 ) THEN INFO = -15 ELSE IF( LDWORK.LT.OPTDW ) THEN INFO = -17 END IF IF( INFO.NE.0) THEN CALL XERBLA( 'MB03JD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN NEIG = 0 RETURN END IF C C Determine machine constants. C PREC = DLAMCH( 'Precision' ) TOL = MIN( DBLE( N ), TEN )*PREC C PAR( 1 ) = PREC PAR( 2 ) = DLAMCH( 'Safe minimum' ) C C STEP 0: Determine location and size of diagonal blocks. C IWORK(J) and IWORK(IS+J) are used to indicate the C beginning index and the kind of eigenvalues of the C J-th diagonal block of the subpencil aA - bB. For a C 2-by-2 block, it is assumed that both eigenvalues have C real parts with the same sign (true for a structured C Schur form). C I = 1 J = 1 IS = M + 1 C NRMA = DLANTR( 'One', 'Upper', 'Non-diag', M, M, A, LDA, DWORK ) NRMB = DLANHS( 'One', M, B, LDB, DWORK ) C C Partition blocks. C C WHILE( I.LE.M-1 ) DO C 10 CONTINUE IF( I.LE.M-1 ) THEN IWORK( J ) = I IF( ABS( B( I+1, I ) ).LE.TOL*NRMB ) THEN C C 1-by-1 block. C B( I+1, I ) = ZERO IF( ABS( A( I, I ) ).LE.TOL*NRMA .OR. $ ABS( B( I, I ) ).LE.TOL*NRMB ) THEN C C Eigenvalue is infinite, 0, or 0/0. C IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = INT( SIGN( ONE, A( I, I )*B( I, I ) ) ) END IF I = I + 1 ELSE C C 2-by-2 block. C IF( A( I, I ).EQ.ZERO .OR. A( I+1, I+1 ).EQ.ZERO ) THEN C C Eigenvalue is infinite. C IWORK( IS+J ) = 0 ELSE TMP = ( B( I, I ) - ( B( I+1, I ) / A( I+1, I+1 ) )* $ A( I, I+1 ) ) / A( I, I ) + $ B( I+1, I+1 ) / A( I+1, I+1 ) IF( TMP.EQ.ZERO ) THEN IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = INT( SIGN( ONE, TMP ) ) END IF END IF I = I + 2 END IF J = J + 1 GO TO 10 C C END WHILE 10 C END IF C IF( I.EQ.M ) THEN IWORK( J ) = I IF( ABS( A( I, I ) ).LE.TOL*NRMA .OR. $ ABS( B( I, I ) ).LE.TOL*NRMB ) THEN C C Eigenvalue is infinite or zero. C IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = INT( SIGN( ONE, A( I, I )*B( I, I ) ) ) END IF J = J + 1 END IF C R = J - 1 C C Initialize Q if appropriate. C IF( LINIQ ) THEN IUPD = M + 1 UPDS = M CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) ELSE IF( LUPDQ ) THEN IUPD = 1 UPDS = N END IF C IF( M.GT.1 ) THEN C C Save the lower triangle of the submatrix D(M-1:M,M-1:M) and the C elements A(M,M-1), F(M,M-1), which might be overwritten. C D1 = D( M-1, M-1 ) D2 = D( M, M-1 ) D3 = D( M, M ) A2 = A( M, M-1 ) F2 = F( M, M-1 ) END IF C C STEP 1: Reorder the eigenvalues in the subpencil aA - bB. C MM = 0 MP = J C C I. Reorder the eigenvalues with negative real parts to the top. C C Set pointers for the inputs and outputs of MB03DD. C IQ1 = 1 IQ2 = IQ1 + 16 IA = IQ2 + 16 IB = IA + 16 IWRK1 = IB + 16 IWRK2 = IA C K = 1 IB3 = M + 1 IWORK( R+1 ) = IB3 C C WHILE( K.LE.R ) DO C 20 CONTINUE IF( K.LE.R ) THEN IF( IWORK( IS+K ).LT.0 ) THEN DO 30 J = K - 1, MM + 1, -1 C C IB1, IB2, and IB3 are pointers to 3 consecutive blocks. C IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and C B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD. C Also, set the additional zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ DWORK( IA+1 ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, $ DWORK( IB+1 ), SDIM+1 ) CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO, $ DWORK( IB+2 ), SDIM ) C C Perform eigenvalue/matrix block exchange. C Workspace: IWRK1 + 43. C CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ), $ SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM, $ DWORK( IQ2 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF C C Copy the transformed diagonal blocks, if sdim > 2. C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 ICS = IB3 IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) NROW = NROWS NCOL = NCOLS IC = ICS LDW = MAX( 1, NROW ) ELSE TMP = A( IB1+1, IB1 ) A( IB1+1, IB1 ) = ZERO NROW = IB3 - 1 NCOL = M - IB1 + 1 IC = IB1 LDW = NROW END IF C C Update A. C Workspace: IWRK2 + 2*N - 1. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IC ), $ LDA, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IC ), LDA ) IF( SDIM.EQ.2 ) $ A( IB1+1, IB1 ) = TMP C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ D( IB1, ICS ), LDD, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ D( IB1, ICS ), LDD ) CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM, $ D( IB1, IB1 ), LDD, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) C C Update B. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IC ), $ LDB, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IC ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ F( IB1, ICS ), LDF, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, ICS ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK2 + 2*N - 1, if COMPQ = 'I'; C IWRK2 + 4*N - 1, if COMPQ = 'U'. C CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ, $ DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( IUPD, M+IB1 ), LDQ ) END IF C C Update index lists IWORK(1:M) and IWORK(M+2:N+1) if a C 1-by-1 and 2-by-2 block have been swapped. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF C C Update IWORK(M+2:N+1). C HLP = IWORK( IS+J ) IWORK( IS+J ) = IWORK( IS+J+1 ) IWORK( IS+J+1 ) = HLP 30 CONTINUE MM = MM + 1 END IF K = K + 1 GO TO 20 C C END WHILE 20 C END IF C C II. Reorder the eigenvalues with positive real parts to the bottom. C K = R C C WHILE( K.GE.MM+1 ) DO C 40 CONTINUE IF( K.GE.MM + 1 ) THEN IF( IWORK( IS+K ).GT.0 ) THEN DO 50 J = K, MP - 2 IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and C B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD. C Also, set the additional zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ DWORK( IA+1 ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, $ DWORK( IB+1 ), SDIM+1 ) CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO, $ DWORK( IB+2 ), SDIM ) C C Perform eigenvalue/matrix block exchange. C CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ), $ SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM, $ DWORK( IQ2 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF C C Copy the transformed diagonal blocks, if sdim > 2. C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 ICS = IB3 IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) NROW = NROWS NCOL = NCOLS IC = ICS LDW = MAX( 1, NROW ) ELSE TMP = A( IB1+1, IB1 ) A( IB1+1, IB1 ) = ZERO NROW = IB3 - 1 NCOL = M - IB1 + 1 IC = IB1 LDW = NROW END IF C C Update A. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IC ), $ LDA, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IC ), LDA ) IF( SDIM.EQ.2 ) $ A( IB1+1, IB1 ) = TMP C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ D( IB1, ICS ), LDD, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ D( IB1, ICS ), LDD ) CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM, $ D( IB1, IB1 ), LDD, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) C C Update B. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IC ), $ LDB, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IC ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ F( IB1, ICS ), LDF, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, ICS ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ, $ DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( IUPD, M+IB1 ), LDQ ) END IF C C Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block C have been swapped. IWORK(M+2:N+1) is not needed anymore, C so it is not necessary to update it. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF 50 CONTINUE MP = MP - 1 END IF K = K - 1 GO TO 40 C C END WHILE 40 C END IF C C STEP 2: Reorder the remaining eigenvalues with negative real parts. C C Set pointers for the inputs and outputs of MB03HD. C IQUPLE = 1 IAUPLE = IQUPLE + 16 IBUPLE = IAUPLE + 8 IWRK5 = IBUPLE + 8 IWRK3 = IAUPLE IWRK4 = IWRK3 + 2*N ITMP1 = IWRK3 + N ITMP2 = ITMP1 + 4 ITMP3 = ITMP2 + 4 C DO 70 K = R, MP, -1 C C I. Exchange the eigenvalues between two diagonal blocks. C IR = IWORK( R ) DIM1 = IWORK( R+1 ) - IR SDIM = 2*DIM1 C IF( DIM1.EQ.2 ) THEN A( M, IR ) = ZERO C C Build the (small) full skew-symmetric matrix D(M-1:M,M-1:M) C and the (small) symmetric matrix F(M-1:M,M-1:M). C D( IR, IR ) = ZERO D( M, IR ) = -D( IR, M ) D( M, M ) = ZERO F( M, IR ) = F( IR, M ) END IF C C Calculate position of submatrices in DWORK. C IBUPRI = IBUPLE + DIM1*DIM1 IQLOLE = IQUPLE + DIM1 IQUPRI = IQUPLE + DIM1*SDIM IQLORI = IQUPRI + DIM1 C C Generate input matrices for MB03HD built of submatrices of A, C D, B, and F. C IF( DIM1.EQ.2 ) THEN CALL DLACPY( 'Upper', DIM1, DIM1, A( IR, IR ), LDA, $ DWORK( IAUPLE ), DIM1 ) DWORK( IAUPLE+6 ) = D( IR, IR+1 ) CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB, $ DWORK( IBUPLE ), DIM1 ) CALL DLACPY( 'Upper', DIM1, DIM1, F( IR, IR ), LDF, $ DWORK( IBUPRI ), DIM1 ) ELSE DWORK( IBUPLE ) = B( IR, IR ) DWORK( IBUPRI ) = F( IR, IR ) END IF C C Perform eigenvalue exchange. C Workspace: IWRK5 + 23, if SDIM = 4. C CALL MB03HD( SDIM, DWORK( IAUPLE ), DIM1, DWORK( IBUPLE ), $ DIM1, PAR, DWORK( IQUPLE ), SDIM, DWORK( IWRK5 ), $ INFO ) IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C IF( DIM1.EQ.2 ) THEN C C Update A by transformations from the right. C Workspace: IWRK3 + N - 1. C CALL DLACPY( 'Full', M, DIM1, A( 1, IR ), LDA, $ DWORK( IWRK3 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM, $ ZERO, A( 1, IR ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, D( 1, IR ), LDD, DWORK( IQLOLE ), SDIM, $ ONE, A( 1, IR ), LDA ) C C Update D by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM, $ ZERO, DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, D( 1, IR ), LDD, DWORK( IQLORI ), SDIM, $ ONE, DWORK( ITMP1 ), M ) CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, D( 1, IR ), $ LDD ) C C Compute the intermediate product Af'*Q21 and the second C column of Af'*Q22, with Af = A(M-1:M,M-1:M). C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ), $ SDIM, ZERO, DWORK( ITMP1 ), DIM1 ) CALL DGEMV( 'Transpose', DIM1, DIM1, ONE, $ DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI+SDIM ), $ 1, ZERO, DWORK( ITMP2 ), 1 ) C C Update A by transformations from the left. C CALL DLACPY( 'Full', DIM1, DIM1, A( IR, IR ), LDA, $ DWORK( IWRK3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ -ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ), $ DIM1, ZERO, A( IR, IR ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQLORI ), SDIM, DWORK( IWRK3 ), $ DIM1, ONE, A( IR, IR ), LDA ) C C Update D by transformations from the left. C D( IR, M ) = DDOT( DIM1, DWORK( IQLORI ), 1, D( IR, M ), 1 ) $ - DDOT( DIM1, DWORK( IQUPRI ), 1, DWORK( ITMP2 ), $ 1 ) C C Update B by transformations from the right. C CALL DLACPY( 'Full', M, DIM1, B( 1, IR ), LDB, $ DWORK( IWRK3 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM, $ ZERO, B( 1, IR ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, F( 1, IR ), LDF, DWORK( IQLOLE ), SDIM, $ ONE, B( 1, IR ), LDB ) C C Update F by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM, $ ZERO, DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, F( 1, IR ), LDF, DWORK( IQLORI ), SDIM, $ ONE, DWORK( ITMP1 ), M ) CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, F( 1, IR ), $ LDF ) C C Compute intermediate products Bf'*Q21 and Bf'*Q22, with C Bf = B(M-1:M,M-1:M). C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ), $ SDIM, ZERO, DWORK( ITMP1 ), DIM1 ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI ), $ SDIM, ZERO, DWORK( ITMP2 ), DIM1 ) C C Update B by transformations from the left. C CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB, $ DWORK( ITMP3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ), $ DIM1, ZERO, B( IR, IR ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQLORI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, B( IR, IR ), LDB ) C C Update F by transformations from the left. C CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ZERO, $ ONE, DWORK( ITMP1 ), DIM1, DWORK( IQLORI ), $ SDIM, F( IR, IR ), LDF, INFO ) CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ONE, $ ONE, DWORK( ITMP1 ), DIM1, DWORK( IQUPRI ), $ SDIM, DWORK( ITMP2 ), DIM1, INFO ) CALL DLACPY( 'Upper', DIM1, DIM1, DWORK( ITMP1 ), DIM1, $ F( IR, IR ), LDF ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK4 + 2*N - 1. C CALL DLACPY( 'Full', N, DIM1, Q( 1, IR ), LDQ, $ DWORK( IWRK4 ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK4 ), N, $ DWORK( IQUPLE ), SDIM, ZERO, Q( 1, IR ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q( 1, M+IR ), LDQ, $ DWORK( IQLOLE ), SDIM, ONE, Q( 1, IR ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK4 ), N, $ DWORK( IQUPRI ), SDIM, ZERO, DWORK( IWRK3 ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q( 1, M+IR ), LDQ, $ DWORK( IQLORI ), SDIM, ONE, DWORK( IWRK3 ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( IWRK3 ), N, $ Q( 1, M+IR ), LDQ ) END IF ELSE Q11 = DWORK( IQUPLE ) Q21 = DWORK( IQLOLE ) Q12 = DWORK( IQUPRI ) Q22 = DWORK( IQLORI ) C C Update A by transformations from the right. C CALL DCOPY( M-1, A( 1, IR ), 1, DWORK( IWRK3 ), 1 ) CALL DSCAL( M-1, Q11, A( 1, IR ), 1 ) CALL DAXPY( M-1, Q21, D( 1, IR ), 1, A( 1, IR ), 1 ) C C Update D by transformations from the right. C CALL DSCAL( M-1, Q22, D( 1, IR ), 1 ) CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, D( 1, IR ), 1 ) C C Update B by transformations from the right. C CALL DCOPY( M-1, B( 1, IR ), 1, DWORK( IWRK3 ), 1 ) CALL DSCAL( M-1, Q11, B( 1, IR ), 1 ) CALL DAXPY( M-1, Q21, F( 1, IR ), 1, B( 1, IR ), 1 ) C C Update F by transformations from the right. C CALL DSCAL( M-1, Q22, F( 1, IR ), 1 ) CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, F( 1, IR ), 1 ) C C Update B by transformations from the left. C B( M, M ) = -B( M, M ) C IF( LCMPQ ) THEN C C Update Q. C CALL DCOPY( N, Q( 1, IR ), 1, DWORK( IWRK4 ), 1 ) CALL DSCAL( N, Q11, Q( 1, IR ), 1 ) CALL DAXPY( N, Q21, Q( 1, IR+M ), 1, Q( 1, IR ), 1 ) CALL DSCAL( N, Q22, Q( 1, IR+M ), 1 ) CALL DAXPY( N, Q12, DWORK( IWRK4 ), 1, Q( 1, IR+M ), 1 ) END IF C END IF C MM = MM + 1 DO 60 J = R - 1, MM, -1 IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and C B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD. C Also, set the additional zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ DWORK( IA+1 ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, DWORK( IB+1 ), $ SDIM+1 ) CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO, $ DWORK( IB+2 ), SDIM ) C C Perform eigenvalue/matrix block exchange. C CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ), $ SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM, $ DWORK( IQ2 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF C C Copy the transformed diagonal blocks, if sdim > 2. C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 ICS = IB3 IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) NROW = NROWS NCOL = NCOLS IC = ICS LDW = MAX( 1, NROW ) ELSE TMP = A( IB1+1, IB1 ) A( IB1+1, IB1 ) = ZERO NROW = IB3 - 1 NCOL = M - IB1 + 1 IC = IB1 LDW = NROW END IF C C Update A. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IC ), $ LDA, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IC ), LDA ) IF( SDIM.EQ.2 ) $ A( IB1+1, IB1 ) = TMP C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ D( IB1, ICS ), LDD, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ D( IB1, ICS ), LDD ) CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM, $ D( IB1, IB1 ), LDD, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) C C Update B. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IC ), $ LDB, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IC ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ F( IB1, ICS ), LDF, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, ICS ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK2 + 4*N - 1. C CALL DGEMM( 'No Transpose', 'No Transpose', N, SDIM, $ SDIM, ONE, Q( 1, IB1 ), LDQ, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), N ) CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, SDIM, $ SDIM, ONE, Q( 1, M+IB1 ), LDQ, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), N ) CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N, $ Q( 1, M+IB1 ), LDQ ) END IF C C Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block C have been swapped. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 C ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF 60 CONTINUE 70 CONTINUE C IF( M.GT.1 ) THEN C C Restore the lower triangle of the submatrix D(M-1:M,M-1:M) and C the elements A(M,M-1) and F(M,M-1). C D( M-1, M-1 ) = D1 D( M, M-1 ) = D2 D( M, M ) = D3 A( M, M-1 ) = A2 F( M, M-1 ) = F2 END IF C IF( MM.GT.0 ) THEN NEIG = IWORK( MM+1 ) - 1 ELSE NEIG = 0 END IF C RETURN C *** Last line of MB03JD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03MY.f0000644000000000000000000000013015012430707016210 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03MY.f0000644000175000017500000004764615012430707017427 0ustar00lilgelilge00000000000000 SUBROUTINE SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) C C PURPOSE C C To solve the real Lyapunov matrix equation C C op(A)'*X + X*op(A) = scale*C C C where op(A) = A or A' (A**T), A is upper quasi-triangular and C is C symmetric (C = C'). (A' denotes the transpose of the matrix A.) C A is N-by-N, the right hand side C and the solution X are N-by-N, C and scale is an output scale factor, set less than or equal to 1 C to avoid overflow in X. The solution matrix X is overwritten C onto C. C C A must be in Schur canonical form (as returned by LAPACK routines C DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and C 2-by-2 diagonal blocks; each 2-by-2 diagonal block has its C diagonal elements equal and its off-diagonal elements of opposite C sign. C C ARGUMENTS C C Mode Parameters 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) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must contain the C upper quasi-triangular matrix A, in Schur canonical form. C The part of A below the first sub-diagonal is not C referenced. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) C On entry, the leading N-by-N part of this array must C contain the symmetric matrix C. C On exit, if INFO >= 0, the leading N-by-N part of this C array contains the symmetric solution matrix X. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,N). 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 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 A and -A have common or very close eigenvalues; C perturbed values were used to solve the equation C (but the matrix A is unchanged). C C METHOD C C Bartels-Stewart algorithm is used. A set of equivalent linear C algebraic systems of equations of order at most four are formed C and solved using Gaussian elimination with complete pivoting. C C REFERENCES C C [1] 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 NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. C Supersedes Release 2.0 routine SB03AY by Control Systems Research C Group, Kingston Polytechnic, United Kingdom, October 1982. C Based on DTRLYP by P. Petkov, Tech. University of Sofia, September C 1993. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. C C KEYWORDS C C Continuous-time system, Lyapunov equation, matrix algebra, real C Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER TRANA INTEGER INFO, LDA, LDC, N DOUBLE PRECISION SCALE C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ) C .. C .. Local Scalars .. LOGICAL NOTRNA, LUPPER INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, $ MINK1N, MINK2N, MINL1N, MINL2N DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SMIN, $ SMLNUM, XNORM C .. C .. Local Arrays .. DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLANHS EXTERNAL DDOT, DLAMCH, DLANHS, LSAME C .. C .. External Subroutines .. EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, SB03MW, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN C .. C .. Executable Statements .. C C Decode and Test input parameters. C NOTRNA = LSAME( TRANA, 'N' ) LUPPER = .TRUE. C INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. $ .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDC.LT.MAX( 1, N ) ) THEN INFO = -6 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03MY', -INFO ) RETURN END IF C SCALE = ONE C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*DBLE( N*N ) / EPS BIGNUM = ONE / SMLNUM C SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, A, LDA, DUM ) ) C IF( NOTRNA ) THEN C C Solve A'*X + X*A = scale*C. C C The (K,L)th block of X is determined starting from C upper-left corner column by column by C C A(K,K)'*X(K,L) + X(K,L)*A(L,L) = C(K,L) - R(K,L), C C where C K-1 L-1 C R(K,L) = SUM [A(I,K)'*X(I,L)] + SUM [X(K,J)*A(J,L)]. C I=1 J=1 C C Start column loop (index = L). C L1 (L2): column index of the first (last) row of X(K,L). C LNEXT = 1 C DO 60 L = 1, N IF( L.LT.LNEXT ) $ GO TO 60 L1 = L L2 = L IF( L.LT.N ) THEN IF( A( L+1, L ).NE.ZERO ) $ L2 = L2 + 1 LNEXT = L2 + 1 END IF C C Start row loop (index = K). C K1 (K2): row index of the first (last) row of X(K,L). C KNEXT = L C DO 50 K = L, N IF( K.LT.KNEXT ) $ GO TO 50 K1 = K K2 = K IF( K.LT.N ) THEN IF( A( K+1, K ).NE.ZERO ) $ K2 = K2 + 1 KNEXT = K2 + 1 END IF C IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) SCALOC = ONE C A11 = A( K1, K1 ) + A( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 C IF( SCALOC.NE.ONE ) THEN C DO 10 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 10 CONTINUE C SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) IF( K1.NE.L1 ) THEN C( L1, K1 ) = X( 1, 1 ) END IF C ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) C VEC( 2, 1 ) = C( K2, L1 ) - $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) ) C CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -A( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 20 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 20 CONTINUE C SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) C( L1, K1 ) = X( 1, 1 ) C( L1, K2 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) C VEC( 2, 1 ) = C( K1, L2 ) - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) ) C CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( L1, L1 ), $ LDA, ONE, ONE, VEC, 2, -A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 30 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 30 CONTINUE C SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) C( L1, K1 ) = X( 1, 1 ) C( L2, K1 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) ) C VEC( 1, 2 ) = C( K1, L2 ) - $ ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + $ DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) ) C VEC( 2, 1 ) = C( K2, L1 ) - $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) ) C VEC( 2, 2 ) = C( K2, L2 ) - $ ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) + $ DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L2 ), 1 ) ) C IF( K1.EQ.L1 ) THEN CALL SB03MW( .FALSE., LUPPER, A( K1, K1 ), LDA, $ VEC, 2, SCALOC, X, 2, XNORM, IERR ) IF( LUPPER ) THEN X( 2, 1 ) = X( 1, 2 ) ELSE X( 1, 2 ) = X( 2, 1 ) END IF ELSE CALL DLASY2( .TRUE., .FALSE., 1, 2, 2, A( K1, K1 ), $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, $ X, 2, XNORM, IERR ) END IF IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 40 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 40 CONTINUE C SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) IF( K1.NE.L1 ) THEN C( L1, K1 ) = X( 1, 1 ) C( L2, K1 ) = X( 1, 2 ) C( L1, K2 ) = X( 2, 1 ) C( L2, K2 ) = X( 2, 2 ) END IF END IF C 50 CONTINUE C 60 CONTINUE C ELSE C C Solve A*X + X*A' = scale*C. C C The (K,L)th block of X is determined starting from C bottom-right corner column by column by C C A(K,K)*X(K,L) + X(K,L)*A(L,L)' = C(K,L) - R(K,L), C C where C N N C R(K,L) = SUM [A(K,I)*X(I,L)] + SUM [X(K,J)*A(L,J)']. C I=K+1 J=L+1 C C Start column loop (index = L). C L1 (L2): column index of the first (last) row of X(K,L). C LNEXT = N C DO 120 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 120 L1 = L L2 = L IF( L.GT.1 ) THEN IF( A( L, L-1 ).NE.ZERO ) $ L1 = L1 - 1 LNEXT = L1 - 1 END IF MINL1N = MIN( L1+1, N ) MINL2N = MIN( L2+1, N ) C C Start row loop (index = K). C K1 (K2): row index of the first (last) row of X(K,L). C KNEXT = L C DO 110 K = L, 1, -1 IF( K.GT.KNEXT ) $ GO TO 110 K1 = K K2 = K IF( K.GT.1 ) THEN IF( A( K, K-1 ).NE.ZERO ) $ K1 = K1 - 1 KNEXT = K1 - 1 END IF MINK1N = MIN( K1+1, N ) MINK2N = MIN( K2+1, N ) C IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, $ C( MINK1N, L1 ), 1 ) + $ DDOT( N-L1, C( K1, MINL1N ), LDC, $ A( L1, MINL1N ), LDA ) ) SCALOC = ONE C A11 = A( K1, K1 ) + A( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 C IF( SCALOC.NE.ONE ) THEN C DO 70 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 70 CONTINUE C SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) IF( K1.NE.L1 ) THEN C( L1, K1 ) = X( 1, 1 ) END IF C ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, $ C( MINK2N, L1 ), 1 ) + $ DDOT( N-L2, C( K1, MINL2N ), LDC, $ A( L1, MINL2N ), LDA ) ) C VEC( 2, 1 ) = C( K2, L1 ) - $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, $ C( MINK2N, L1 ), 1 ) + $ DDOT( N-L2, C( K2, MINL2N ), LDC, $ A( L1, MINL2N ), LDA ) ) C CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -A( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 80 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 80 CONTINUE C SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) C( L1, K1 ) = X( 1, 1 ) C( L1, K2 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, $ C( MINK1N, L1 ), 1 ) + $ DDOT( N-L2, C( K1, MINL2N ), LDC, $ A( L1, MINL2N ), LDA ) ) C VEC( 2, 1 ) = C( K1, L2 ) - $ ( DDOT( N-K1, A( K1, MINK1N ), LDA, $ C( MINK1N, L2 ), 1 ) + $ DDOT( N-L2, C( K1, MINL2N ), LDC, $ A( L2, MINL2N ), LDA ) ) C CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( L1, L1 ), $ LDA, ONE, ONE, VEC, 2, -A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 90 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 90 CONTINUE C SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) C( L1, K1 ) = X( 1, 1 ) C( L2, K1 ) = X( 2, 1 ) C ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN C VEC( 1, 1 ) = C( K1, L1 ) - $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, $ C( MINK2N, L1 ), 1 ) + $ DDOT( N-L2, C( K1, MINL2N ), LDC, $ A( L1, MINL2N ), LDA ) ) C VEC( 1, 2 ) = C( K1, L2 ) - $ ( DDOT( N-K2, A( K1, MINK2N ), LDA, $ C( MINK2N, L2 ), 1 ) + $ DDOT( N-L2, C( K1, MINL2N ), LDC, $ A( L2, MINL2N ), LDA ) ) C VEC( 2, 1 ) = C( K2, L1 ) - $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, $ C( MINK2N, L1 ), 1 ) + $ DDOT( N-L2, C( K2, MINL2N ), LDC, $ A( L1, MINL2N ), LDA ) ) C VEC( 2, 2 ) = C( K2, L2 ) - $ ( DDOT( N-K2, A( K2, MINK2N ), LDA, $ C( MINK2N, L2 ), 1 ) + $ DDOT( N-L2, C( K2, MINL2N ), LDC, $ A( L2, MINL2N ), LDA ) ) C IF( K1.EQ.L1 ) THEN CALL SB03MW( .TRUE., LUPPER, A( K1, K1 ), LDA, VEC, $ 2, SCALOC, X, 2, XNORM, IERR ) IF( LUPPER ) THEN X( 2, 1 ) = X( 1, 2 ) ELSE X( 1, 2 ) = X( 2, 1 ) END IF ELSE CALL DLASY2( .FALSE., .TRUE., 1, 2, 2, A( K1, K1 ), $ LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC, $ X, 2, XNORM, IERR ) END IF IF( IERR.NE.0 ) $ INFO = 1 C IF( SCALOC.NE.ONE ) THEN C DO 100 J = 1, N CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 100 CONTINUE C SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) IF( K1.NE.L1 ) THEN C( L1, K1 ) = X( 1, 1 ) C( L2, K1 ) = X( 1, 2 ) C( L1, K2 ) = X( 2, 1 ) C( L2, K2 ) = X( 2, 2 ) END IF END IF C 110 CONTINUE C 120 CONTINUE C END IF C RETURN C *** Last line of SB03MY *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01TY.f0000644000000000000000000000013215012430707016220 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01TY.f0000644000175000017500000001010115012430707017405 0ustar00lilgelilge00000000000000 SUBROUTINE TB01TY( MODE, IOFF, JOFF, NROW, NCOL, SIZE, X, LDX, $ BVECT ) C C PURPOSE C C Balances the rows (MODE .EQ. 0) or columns (MODE .NE. 0) of the C (NROW x NCOL) block of the matrix X with offset (IOFF,JOFF), i.e. C with first (top left) element (IOFF + 1,JOFF + 1). Each non- C zero row (column) is balanced in the sense that it is multiplied C by that integer power of the base of the machine floating-point C representation for which the sum of the absolute values of its C entries (i.e. its 1-norm) satisfies C C (SIZE / BASE) .LT. ABSSUM .LE. SIZE C C for SIZE as input. (Note that this form of scaling does not C introduce any rounding errors.) The vector BVECT then contains C the appropriate scale factors in rows (IOFF + 1)...(IOFF + NROW) C (columns (JOFF + 1)...(JOFF + NCOL) ). In particular, if the C I-th row (J-th column) of the block is 'numerically' non-zero C with 1-norm given by BASE**(-EXPT) for some real EXPT, then the C desired scale factor (returned as element IOFF + I (JOFF + J) of C BVECT) is BASE**IEXPT, where IEXPT is the largest integer .LE. C EXPT: this integer is precisely the truncation INT(EXPT) except C for negative non-integer EXPT, in which case this value is too C high by 1 and so must be adjusted accordingly. Finally, note C that the element of BVECT corresponding to a 'numerically' zero C row (column) is simply set equal to 1.0. C C For efficiency, no tests of the input scalar parameters are C performed. C C REVISIONS C C - C C ****************************************************************** C DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER IOFF, JOFF, LDX, MODE, NCOL, NROW DOUBLE PRECISION SIZE C .. Array Arguments .. DOUBLE PRECISION BVECT(*), X(LDX,*) C .. Local Scalars .. DOUBLE PRECISION ABSSUM, DIV, EPS, EXPT, SCALE, TEST INTEGER BASE, I, IEXPT, J C .. External Functions .. DOUBLE PRECISION DASUM, DLAMCH EXTERNAL DASUM, DLAMCH C .. External Subroutines .. EXTERNAL DSCAL C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG C .. Executable Statements .. C BASE = DLAMCH( 'Base' ) EPS = DLAMCH( 'Epsilon' ) C DIV = ONE/LOG( DBLE( BASE ) ) IF ( MODE.NE.0 ) THEN C C Balance one column at a time using its column-sum norm. C DO 10 J = JOFF + 1, JOFF + NCOL ABSSUM = DASUM( NROW, X(IOFF+1,J), 1 )/ABS( SIZE ) TEST = ABSSUM/DBLE( NROW ) IF ( TEST.GT.EPS ) THEN C C Non-zero column: calculate (and apply) correct scale C factor. C EXPT = -DIV*LOG( ABSSUM ) IEXPT = INT( EXPT ) IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) ) $ IEXPT = IEXPT - 1 SCALE = DBLE( BASE )**IEXPT BVECT(J) = SCALE CALL DSCAL( NROW, SCALE, X(IOFF+1,J), 1 ) ELSE C C 'Numerically' zero column: do not rescale. C BVECT(J) = ONE END IF 10 CONTINUE C ELSE C C Balance one row at a time using its row-sum norm. C DO 20 I = IOFF + 1, IOFF + NROW ABSSUM = DASUM( NCOL, X(I,JOFF+1), LDX )/ABS( SIZE ) TEST = ABSSUM/DBLE( NCOL ) IF ( TEST.GT.EPS ) THEN C C Non-zero row: calculate (and apply) correct scale factor. C EXPT = -DIV*LOG( ABSSUM ) IEXPT = INT( EXPT ) IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) ) $ IEXPT = IEXPT - 1 C SCALE = DBLE( BASE )**IEXPT BVECT(I) = SCALE CALL DSCAL( NCOL, SCALE, X(I,JOFF+1), LDX ) ELSE C C 'Numerically' zero row: do not rescale. C BVECT(I) = ONE END IF 20 CONTINUE C END IF C RETURN C *** Last line of TB01TY *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09KD.f0000644000000000000000000000013215012430707016147 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB09KD.f0000644000175000017500000010263515012430707017352 0ustar00lilgelilge00000000000000 SUBROUTINE AB09KD( JOB, DICO, WEIGHT, EQUIL, ORDSEL, N, NV, NW, M, $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, $ NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, $ IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for an original C state-space representation (A,B,C,D) by using the frequency C weighted optimal Hankel-norm approximation method. C The Hankel norm of the weighted error C C V*(G-Gr)*W or conj(V)*(G-Gr)*conj(W) C C is minimized, where G and Gr are the transfer-function matrices C of the original and reduced systems, respectively, and V and W C are the transfer-function matrices of the left and right frequency C weights, specified by their state space realizations (AV,BV,CV,DV) C and (AW,BW,CW,DW), respectively. When minimizing the weighted C error V*(G-Gr)*W, V and W must be antistable transfer-function C matrices. When minimizing conj(V)*(G-Gr)*conj(W), V and W must be C stable transfer-function matrices. C Additionally, V and W must be invertible transfer-function C matrices, with the feedthrough matrices DV and DW invertible. C If the original system is unstable, then the frequency weighted C Hankel-norm approximation is computed only for the C ALPHA-stable part of the system. C C For a transfer-function matrix G, conj(G) denotes the conjugate C of G given by G'(-s) for a continuous-time system or G'(1/z) C for a discrete-time system. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the frequency-weighting problem as follows: C = 'N': solve min||V*(G-Gr)*W||_H; C = 'C': solve min||conj(V)*(G-Gr)*conj(W)||_H. 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 WEIGHT CHARACTER*1 C Specifies the type of frequency weighting, as follows: C = 'N': no weightings are used (V = I, W = I); C = 'L': only left weighting V is used (W = I); C = 'R': only right weighting W is used (V = I); C = 'B': both left and right weightings V and W are used. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e., the order of the matrix A. N >= 0. C C NV (input) INTEGER C The order of the realization of the left frequency C weighting V, i.e., the order of the matrix AV. NV >= 0. C C NW (input) INTEGER C The order of the realization of the right frequency C weighting W, i.e., the order of the matrix AW. NW >= 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of C the resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. For a system with NU ALPHA-unstable C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), C NR is set as follows: if ORDSEL = 'F', NR is equal to C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the C multiplicity of the Hankel singular value HSV(NR-NU+1), C NR is the desired order on entry, and NMIN is the order C of a minimal realization of the ALPHA-stable part of the C given system; NMIN is determined as the number of Hankel C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where C EPS is the machine precision (see LAPACK Library Routine C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the C ALPHA-stable part of the weighted system (computed in C HSV(1)); C if ORDSEL = 'A', NR is the sum of NU and the number of C Hankel singular values greater than C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). C C ALPHA (input) DOUBLE PRECISION C Specifies the ALPHA-stability boundary for the eigenvalues C of the state dynamics matrix A. For a continuous-time C system (DICO = 'C'), ALPHA <= 0 is the boundary value for C the real parts of eigenvalues, while for a discrete-time C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the C boundary value for the moduli of eigenvalues. C The ALPHA-stability domain does not include the boundary. 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, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the C reduced order system in a real Schur form. C The resulting A has a block-diagonal form with two blocks. C For a system with NU ALPHA-unstable eigenvalues and C NS ALPHA-stable eigenvalues (NU+NS = N), the leading C NU-by-NU block contains the unreduced part of A C corresponding to ALPHA-unstable eigenvalues. C The trailing (NR+NS-N)-by-(NR+NS-N) block contains C the reduced part of A corresponding to ALPHA-stable C eigenvalues. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV C part of this array must contain the state matrix AV of a C state space realization of the left frequency weighting V. C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading C NV-by-NV part of this array contains a real Schur form C of the state matrix of a state space realization of the C inverse of V. C AV is not referenced if WEIGHT = 'R' or 'N'. C C LDAV INTEGER C The leading dimension of the array AV. C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; C LDAV >= 1, if WEIGHT = 'R' or 'N'. C C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part C of this array must contain the input matrix BV of a state C space realization of the left frequency weighting V. C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading C NV-by-P part of this array contains the input matrix of a C state space realization of the inverse of V. C BV is not referenced if WEIGHT = 'R' or 'N'. C C LDBV INTEGER C The leading dimension of the array BV. C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; C LDBV >= 1, if WEIGHT = 'R' or 'N'. C C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) C On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part C of this array must contain the output matrix CV of a state C space realization of the left frequency weighting V. C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading C P-by-NV part of this array contains the output matrix of a C state space realization of the inverse of V. C CV is not referenced if WEIGHT = 'R' or 'N'. C C LDCV INTEGER C The leading dimension of the array CV. C LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B'; C LDCV >= 1, if WEIGHT = 'R' or 'N'. C C DV (input/output) DOUBLE PRECISION array, dimension (LDDV,P) C On entry, if WEIGHT = 'L' or 'B', the leading P-by-P part C of this array must contain the feedthrough matrix DV of a C state space realization of the left frequency weighting V. C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading C P-by-P part of this array contains the feedthrough matrix C of a state space realization of the inverse of V. C DV is not referenced if WEIGHT = 'R' or 'N'. C C LDDV INTEGER C The leading dimension of the array DV. C LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B'; C LDDV >= 1, if WEIGHT = 'R' or 'N'. C C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW C part of this array must contain the state matrix AW of C a state space realization of the right frequency C weighting W. C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading C NW-by-NW part of this array contains a real Schur form of C the state matrix of a state space realization of the C inverse of W. C AW is not referenced if WEIGHT = 'L' or 'N'. C C LDAW INTEGER C The leading dimension of the array AW. C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; C LDAW >= 1, if WEIGHT = 'L' or 'N'. C C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part C of this array must contain the input matrix BW of a state C space realization of the right frequency weighting W. C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading C NW-by-M part of this array contains the input matrix of a C state space realization of the inverse of W. C BW is not referenced if WEIGHT = 'L' or 'N'. C C LDBW INTEGER C The leading dimension of the array BW. C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; C LDBW >= 1, if WEIGHT = 'L' or 'N'. C C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part C of this array must contain the output matrix CW of a state C space realization of the right frequency weighting W. C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading C M-by-NW part of this array contains the output matrix of a C state space realization of the inverse of W. C CW is not referenced if WEIGHT = 'L' or 'N'. C C LDCW INTEGER C The leading dimension of the array CW. C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; C LDCW >= 1, if WEIGHT = 'L' or 'N'. C C DW (input/output) DOUBLE PRECISION array, dimension (LDDW,M) C On entry, if WEIGHT = 'R' or 'B', the leading M-by-M part C of this array must contain the feedthrough matrix DW of C a state space realization of the right frequency C weighting W. C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading C M-by-M part of this array contains the feedthrough matrix C of a state space realization of the inverse of W. C DW is not referenced if WEIGHT = 'L' or 'N'. C C LDDW INTEGER C The leading dimension of the array DW. C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; C LDDW >= 1, if WEIGHT = 'L' or 'N'. C C NS (output) INTEGER C The dimension of the ALPHA-stable subsystem. C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, the leading NS elements of this array contain C the Hankel singular values, ordered decreasingly, of the C ALPHA-stable part of the weighted original system. C HSV(1) is the Hankel norm of the ALPHA-stable weighted C subsystem. C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the C Hankel-norm of the ALPHA-stable part of the weighted C original system (computed in HSV(1)). C If TOL1 <= 0 on entry, the used default value is C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of C ALPHA-stable eigenvalues of A and EPS is the machine C precision (see LAPACK Library Routine DLAMCH). C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the ALPHA-stable part of the given system. C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). C This value is used by default if TOL2 <= 0 on entry. C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = MAX(1,M,c), if DICO = 'C', C LIWORK = MAX(1,N,M,c), if DICO = 'D', C where c = 0, if WEIGHT = 'N', C c = 2*P, if WEIGHT = 'L', C c = 2*M, if WEIGHT = 'R', C c = MAX(2*M,2*P), if WEIGHT = 'B'. C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of C the computed minimal realization. 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( LDW1, LDW2, LDW3, LDW4 ), where C LDW1 = 0 if WEIGHT = 'R' or 'N' and C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) C if WEIGHT = 'L' or WEIGHT = 'B', C LDW2 = 0 if WEIGHT = 'L' or 'N' and C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) C if WEIGHT = 'R' or WEIGHT = 'B', with C a = 0, b = 0, if DICO = 'C' or JOB = 'N', C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'; C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + C MAX( 3*M+1, MIN(N,M)+P ). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than NSMIN, the sum of the order of the C ALPHA-unstable part and the order of a minimal C realization of the ALPHA-stable part of the given C system; in this case, the resulting NR is set equal C to NSMIN; C = 2: with ORDSEL = 'F', the selected order NR is less C than the order of the ALPHA-unstable part of the C given system; in this case NR is set equal to the C order of the ALPHA-unstable part. 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 computation of the ordered real Schur form of A C failed; C = 2: the separation of the ALPHA-stable/unstable C diagonal blocks failed because of very close C eigenvalues; C = 3: the reduction of AV or AV-BV*inv(DV)*CV to a C real Schur form failed; C = 4: the reduction of AW or AW-BW*inv(DW)*CW to a C real Schur form failed; C = 5: JOB = 'N' and AV is not antistable, or C JOB = 'C' and AV is not stable; C = 6: JOB = 'N' and AW is not antistable, or C JOB = 'C' and AW is not stable; C = 7: the computation of Hankel singular values failed; C = 8: the computation of stable projection in the C Hankel-norm approximation algorithm failed; C = 9: the order of computed stable projection in the C Hankel-norm approximation algorithm differs C from the order of Hankel-norm approximation; C = 10: DV is singular; C = 11: DW is singular; C = 12: the solution of the Sylvester equation failed C because the zeros of V (if JOB = 'N') or of conj(V) C (if JOB = 'C') are not distinct from the poles C of G1sr (see METHOD); C = 13: the solution of the Sylvester equation failed C because the zeros of W (if JOB = 'N') or of conj(W) C (if JOB = 'C') are not distinct from the poles C of G1sr (see METHOD). C C METHOD C C Let G be the transfer-function matrix of the original C linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t), (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09KD determines C the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t), (2) C C such that the corresponding transfer-function matrix Gr minimizes C the Hankel-norm of the frequency-weighted error C C V*(G-Gr)*W, (3) C or C conj(V)*(G-Gr)*conj(W). (4) C C For minimizing (3), V and W are assumed to be antistable, while C for minimizing (4), V and W are assumed to be stable transfer- C function matrices. C C Note: conj(G) = G'(-s) for a continuous-time system and C conj(G) = G'(1/z) for a discrete-time system. C C The following procedure is used to reduce G (see [1]): C C 1) Decompose additively G as C C G = G1 + G2, C C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and C G2 = (A2,B2,C2,0) has only ALPHA-unstable poles. C C 2) Compute G1s, the stable projection of V*G1*W or C conj(V)*G1*conj(W), using explicit formulas [4]. C C 3) Determine G1sr, the optimal Hankel-norm approximation of G1s C of order r. C C 4) Compute G1r, the stable projection of either inv(V)*G1sr*inv(W) C or conj(inv(V))*G1sr*conj(inv(W)), using explicit formulas [4]. C C 5) Assemble the reduced model Gr as C C Gr = G1r + G2. C C To reduce the weighted ALPHA-stable part G1s at step 3, the C optimal Hankel-norm approximation method of [2], based on the C square-root balancing projection formulas of [3], is employed. C C The optimal weighted approximation error satisfies C C HNORM[V*(G-Gr)*W] = S(r+1), C or C HNORM[conj(V)*(G-Gr)*conj(W)] = S(r+1), C C where S(r+1) is the (r+1)-th Hankel singular value of G1s, the C transfer-function matrix computed at step 2 of the above C procedure, and HNORM(.) denotes the Hankel-norm. C C REFERENCES C C [1] Latham, G.A. and Anderson, B.D.O. C Frequency-weighted optimal Hankel-norm approximation of stable C transfer functions. C Systems & Control Letters, Vol. 5, pp. 229-236, 1985. C C [2] Glover, K. C All optimal Hankel norm approximation of linear C multivariable systems and their L-infinity error bounds. C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. C C [3] Tombs M.S. and Postlethwaite I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C [4] Varga A. C Explicit formulas for an efficient implementation C of the frequency-weighting model reduction approach. C Proc. 1993 European Control Conference, Groningen, NL, C pp. 693-696, 1993. C C NUMERICAL ASPECTS C C The implemented methods rely on an accuracy enhancing square-root C technique. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000. C D. Sima, University of Bucharest, May 2000. C V. Sima, Research Institute for Informatics, Bucharest, May 2000. C Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1, C by A. Varga, 1992. C C REVISIONS C C A. Varga, Australian National University, Canberra, November 2000. C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. C Oct. 2001, March 2005. C C KEYWORDS C C Frequency weighting, model reduction, multivariable system, C state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION C100, ONE, ZERO PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, JOB, ORDSEL, WEIGHT INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, $ NR, NS, NV, NW, P DOUBLE PRECISION ALPHA, TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), $ HSV(*) C .. Local Scalars .. LOGICAL CONJS, DISCR, FIXORD, FRWGHT, LEFTW, RIGHTW INTEGER IA, IB, IERR, IWARNL, KI, KL, KU, KW, LW, NMIN, $ NRA, NU, NU1 DOUBLE PRECISION ALPWRK, MAXRED, RCOND, WRKOPT C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB07ND, AB09CX, AB09KX, TB01ID, TB01KD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 CONJS = LSAME( JOB, 'C' ) DISCR = LSAME( DICO, 'D' ) FIXORD = LSAME( ORDSEL, 'F' ) LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) FRWGHT = LEFTW .OR. RIGHTW C IF ( DISCR .AND. CONJS ) THEN IA = 2*NV IB = 2*NW ELSE IA = 0 IB = 0 END IF LW = 1 IF( LEFTW ) $ LW = MAX( LW, NV*(NV+5), NV*N + MAX( IA, P*N, P*M ) ) IF( RIGHTW ) $ LW = MAX( LW, MAX( NW*(NW+5), NW*N + MAX( IB, M*N, P*M ) ) ) LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 ) LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) C C Check the input scalar arguments. C IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -2 ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN INFO = -3 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -4 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( NV.LT.0 ) THEN INFO = -7 ELSE IF( NW.LT.0 ) THEN INFO = -8 ELSE IF( M.LT.0 ) THEN INFO = -9 ELSE IF( P.LT.0 ) THEN INFO = -10 ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -11 ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN INFO = -12 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -18 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -20 ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN INFO = -22 ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN INFO = -24 ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN INFO = -26 ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN INFO = -28 ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN INFO = -30 ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN INFO = -32 ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN INFO = -34 ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN INFO = -36 ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN INFO = -40 ELSE IF( LDWORK.LT.LW ) THEN INFO = -43 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09KD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 NS = 0 IWORK(1) = 0 DWORK(1) = ONE RETURN END IF C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C Workspace: N. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Correct the value of ALPHA to ensure stability. C ALPWRK = ALPHA IF( DISCR ) THEN IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) ELSE IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) END IF C C Allocate working storage. C KU = 1 KL = KU + N*N KI = KL + N KW = KI + N C C Reduce A to a block-diagonal real Schur form, with the C ALPHA-unstable part in the leading diagonal position, using a C non-orthogonal similarity transformation, A <- inv(T)*A*T, and C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. C C Workspace needed: N*(N+2); C Additional workspace: need 3*N; C prefer larger. C CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) C IF( IERR.NE.0 ) THEN IF( IERR.NE.3 ) THEN INFO = 1 ELSE INFO = 2 END IF RETURN END IF C WRKOPT = DWORK(KW) + DBLE( KW-1 ) C C Compute the stable projection of the weighted ALPHA-stable part. C C Workspace: need MAX( 1, LDW1, LDW2 ), C LDW1 = 0 if WEIGHT = 'R' or 'N' and C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) C if WEIGHT = 'L' or 'B', C LDW2 = 0 if WEIGHT = 'L' or 'N' and C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) C if WEIGHT = 'R' or 'B', C where a = 0, b = 0, if DICO = 'C' or JOB = 'N', C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'; C prefer larger. C NS = N - NU C C Finish if only unstable part is present. C IF( NS.EQ.0 ) THEN NR = NU IWORK(1) = 0 DWORK(1) = WRKOPT RETURN END IF C NU1 = NU + 1 IF( FRWGHT ) THEN CALL AB09KX( JOB, DICO, WEIGHT, NS, NV, NW, M, P, A(NU1,NU1), $ LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, $ DWORK, LDWORK, IWARNL, IERR ) C IF( IERR.NE.0 ) THEN C C Note: Only IERR = 1 or IERR = 2 are possible. C Set INFO to 3 or 4. C INFO = IERR + 2 RETURN END IF C IF( IWARNL.NE.0 ) THEN C C Stability/antistability of V and W are compulsory. C IF( IWARNL.EQ.1 .OR. IWARNL.EQ.3 ) THEN INFO = 5 ELSE INFO = 6 END IF RETURN END IF C DWORK(1) = MAX( WRKOPT, DWORK(1) ) END IF C C Determine a reduced order approximation of the ALPHA-stable part. C C Workspace: need MAX( LDW3, LDW4 ), C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + C MAX( 3*M+1, MIN(N,M)+P ); C prefer larger. C IWARNL = 0 IF( FIXORD ) THEN NRA = MAX( 0, NR - NU ) IF( NRA.EQ.0 ) $ IWARNL = 2 ELSE NRA = 0 END IF CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) C IWARN = MAX( IWARN, IWARNL ) IF( IERR.NE.0 ) THEN C C Set INFO = 7, 8 or 9. C INFO = IERR + 5 RETURN END IF C WRKOPT = MAX( WRKOPT, DWORK(1) ) NMIN = IWORK(1) C C Compute the state space realizations of the inverses of V and W. C C Integer workspace: need c, C Real workspace: need MAX(1,2*c), C where c = 0, if WEIGHT = 'N', C c = 2*P, if WEIGHT = 'L', C c = 2*M, if WEIGHT = 'R', C c = MAX(2*M,2*P), if WEIGHT = 'B'. C IF( LEFTW ) THEN CALL AB07ND( NV, P, AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, $ RCOND, IWORK, DWORK, LDWORK, IERR ) IF( IERR.NE.0 ) THEN INFO = 10 RETURN END IF END IF IF( RIGHTW ) THEN CALL AB07ND( NW, M, AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, $ RCOND, IWORK, DWORK, LDWORK, IERR ) IF( IERR.NE.0 ) THEN INFO = 11 RETURN END IF END IF C WRKOPT = MAX( WRKOPT, DWORK(1) ) C C Compute the stable projection of weighted reduced ALPHA-stable C part. C IF( FRWGHT ) THEN CALL AB09KX( JOB, DICO, WEIGHT, NRA, NV, NW, M, P, A(NU1,NU1), $ LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, $ DWORK, LDWORK, IWARNL, IERR ) C IF( IERR.NE.0 ) THEN IF( IERR.LE.2 ) THEN C C Set INFO to 3 or 4. C INFO = IERR + 2 ELSE C C Set INFO to 12 or 13. C INFO = IERR + 9 END IF RETURN END IF END IF C NR = NRA + NU IWORK(1) = NMIN DWORK(1) = MAX( WRKOPT, DWORK(1) ) C RETURN C *** Last line of AB09KD *** END control-4.1.2/src/slicot/src/PaxHeaders/TF01QD.f0000644000000000000000000000013215012430707016174 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TF01QD.f0000644000175000017500000001612715012430707017377 0ustar00lilgelilge00000000000000 SUBROUTINE TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO ) C C PURPOSE C C To compute N Markov parameters M(1), M(2),..., M(N) from a C multivariable system whose transfer function matrix G(z) is given. C C ARGUMENTS C C Input/Output Parameters C C NC (input) INTEGER C The number of system outputs, i.e. the number of rows in C the transfer function matrix G(z). NC >= 0. C C NB (input) INTEGER C The number of system inputs, i.e. the number of columns in C the transfer function matrix G(z). NB >= 0. C C N (input) INTEGER C The number of Markov parameters M(k) to be computed. C N >= 0. C C IORD (input) INTEGER array, dimension (NC*NB) C This array must contain the order r of the elements of the C transfer function matrix G(z), stored row by row. C For example, the order of the (i,j)-th element of G(z) is C given by IORD((i-1)xNB+j). C C AR (input) DOUBLE PRECISION array, dimension (NA), where C NA = IORD(1) + IORD(2) + ... + IORD(NC*NB). C The leading NA elements of this array must contain the C denominator coefficients AR(1),...,AR(r) in equation (1) C of the (i,j)-th element of the transfer function matrix C G(z), stored row by row, i.e. in the order C (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ..., C (NC,1),(NC,2),...,(NC,NB). The coefficients must be given C in decreasing order of powers of z; the coefficient of the C highest order term is assumed to be equal to 1. C C MA (input) DOUBLE PRECISION array, dimension (NA) C The leading NA elements of this array must contain the C numerator coefficients MA(1),...,MA(r) in equation (1) C of the (i,j)-th element of the transfer function matrix C G(z), stored row by row, i.e. in the order C (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ..., C (NC,1),(NC,2),...,(NC,NB). The coefficients must be given C in decreasing order of powers of z. C C H (output) DOUBLE PRECISION array, dimension (LDH,N*NB) C The leading NC-by-N*NB part of this array contains the C multivariable Markov parameter sequence M(k), where each C parameter M(k) is an NC-by-NB matrix and k = 1,2,...,N. C The Markov parameters are stored such that H(i,(k-1)xNB+j) C contains the (i,j)-th element of M(k) for i = 1,2,...,NC C and j = 1,2,...,NB. C C LDH INTEGER C The leading dimension of array H. LDH >= MAX(1,NC). 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 (i,j)-th element of G(z), defining the particular I/O transfer C between output i and input j, has the following form: C C -1 -2 -r C MA(1)z + MA(2)z + ... + MA(r)z C G (z) = ----------------------------------------. (1) C ij -1 -2 -r C 1 + AR(1)z + AR(2)z + ... + AR(r)z C C The (i,j)-th element of G(z) is defined by its order r, its r C moving average coefficients (= numerator) MA(1),...,MA(r) and its C r autoregressive coefficients (= denominator) AR(1),...,AR(r). The C coefficient of the constant term in the denominator is assumed to C be equal to 1. C C The relationship between the (i,j)-th element of the Markov C parameters M(1),M(2),...,M(N) and the corresponding element of the C transfer function matrix G(z) is given by: C C -1 -2 -k C G (z) = M (0) + M (1)z + M (2)z + ... + M (k)z + ...(2) C ij ij ij ij ij C C Equating (1) and (2), we find that the relationship between the C (i,j)-th element of the Markov parameters M(k) and the ARMA C parameters AR(1),...,AR(r) and MA(1),...,MA(r) of the (i,j)-th C element of the transfer function matrix G(z) is as follows: C C M (1) = MA(1), C ij C k-1 C M (k) = MA(k) - SUM AR(p) x M (k-p) for 1 < k <= r and C ij p=1 ij C r C M (k+r) = - SUM AR(p) x M (k+r-p) for k > 0. C ij p=1 ij C C From these expressions the Markov parameters M(k) are computed C element by element. C C REFERENCES C C [1] Luenberger, D.G. C Introduction to Dynamic Systems: Theory, Models and C Applications. C John Wiley & Sons, New York, 1979. C C NUMERICAL ASPECTS C C The computation of the (i,j)-th element of M(k) requires: C (k-1) multiplications and k additions if k <= r; C r multiplications and r additions if k > r. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TF01ED by S. Van Huffel, Katholieke C Univ. Leuven, Belgium. C C REVISIONS C C - C C KEYWORDS C C Markov parameters, multivariable system, transfer function, C transfer matrix. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INFO, LDH, N, NB, NC C .. Array Arguments .. INTEGER IORD(*) DOUBLE PRECISION AR(*), H(LDH,*), MA(*) C .. Local Scalars .. INTEGER I, J, JJ, JK, K, KI, LDHNB, NL, NORD C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C IF( NC.LT.0 ) THEN INFO = -1 ELSE IF( NB.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN INFO = -8 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TF01QD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( NC, NB, N ).EQ.0 ) $ RETURN C LDHNB = LDH*NB NL = 1 K = 1 C DO 60 I = 1, NC C DO 50 J = 1, NB NORD = IORD(K) H(I,J) = MA(NL) JK = J C DO 20 KI = 1, NORD - 1 JK = JK + NB H(I,JK) = MA(NL+KI) - DDOT( KI, AR(NL), 1, H(I,J), $ -LDHNB ) 20 CONTINUE C DO 40 JJ = J, J + (N - NORD - 1)*NB, NB JK = JK + NB H(I,JK) = -DDOT( NORD, AR(NL), 1, H(I,JJ), -LDHNB ) 40 CONTINUE C NL = NL + NORD K = K + 1 50 CONTINUE C 60 CONTINUE C RETURN C *** Last line of TF01QD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01GD.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01GD.f0000644000175000017500000003747315012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE TG01GD( JOBS, L, N, M, P, A, LDA, E, LDE, B, LDB, $ C, LDC, D, LDD, LR, NR, RANKE, INFRED, TOL, $ IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To find a reduced descriptor representation (Ar-lambda*Er,Br,Cr) C without non-dynamic modes for a descriptor representation C (A-lambda*E,B,C). Optionally, the reduced descriptor system can C be put into a standard form with the leading diagonal block C of Er identity. C C ARGUMENTS C C Mode Parameters C C JOBS CHARACTER*1 C Indicates whether the user wishes to transform the leading C diagonal block of Er to an identity matrix, as follows: C = 'S': make Er with leading diagonal identity; C = 'D': keep Er unreduced or upper triangular. C C Input/Output Parameters C C L (input) INTEGER C The number of rows of the matrices A, E, and B; C also the number of differential equations. L >= 0. C C N (input) INTEGER C The number of columns of the matrices A, E, and C; C also the dimension of descriptor state vector. N >= 0. C C M (input) INTEGER C The number of columns of the matrix B; C also the dimension of the input vector. M >= 0. C C P (input) INTEGER C The number of rows of the matrix C. C also the dimension of the output vector. P >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the state dynamics matrix A. C On exit, if NR < N, the leading LR-by-NR part of this C array contains the reduced order state matrix Ar of a C descriptor realization without non-dynamic modes. C Array A contains the original state dynamics matrix if C INFRED < 0. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,L). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the descriptor matrix E. C On exit, if INFRED >= 0, the leading LR-by-NR part of this C array contains the reduced order descriptor matrix Er of a C descriptor realization without non-dynamic modes. C In this case, only the leading RANKE-by-RANKE submatrix C of Er is nonzero and this submatrix is nonsingular and C upper triangular. Array E contains the original descriptor C matrix if INFRED < 0. If JOBS = 'S', then the leading C RANKE-by-RANKE submatrix results in an identity matrix. C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,L). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, the leading L-by-M part of this array must C contain the input matrix B. C On exit, the leading LR-by-M part of this array contains C the reduced order input matrix Br of a descriptor C realization without non-dynamic modes. Array B contains C the original input matrix if INFRED < 0. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,L). 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 output matrix C. C On exit, the leading P-by-NR part of this array contains C the reduced order output matrix Cr of a descriptor C realization without non-dynamic modes. Array C contains C the original output matrix if INFRED < 0. C C LDC INTEGER C The leading dimension of the 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 original feedthrough matrix D. C On exit, the leading P-by-M part of this array contains C the feedthrough matrix Dr of a reduced descriptor C realization without non-dynamic modes. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1,P). C C LR (output) INTEGER C The number of reduced differential equations. C C NR (output) INTEGER C The dimension of the reduced descriptor state vector. C C RANKE (output) INTEGER C The estimated rank of the matrix E. C C INFRED (output) INTEGER C This parameter contains information on performed reduction C and on structure of resulting system matrices, as follows: C INFRED >= 0 the reduced system is in an SVD-like C coordinate form with Er upper triangular; C INFRED is the achieved order reduction. C INFRED < 0 no reduction achieved and the original C system has been restored. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determinations when C transforming (A-lambda*E). If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C reciprocal condition numbers in rank determinations; a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = L*N*EPS, is used instead, where EPS C is the machine precision (see LAPACK Library routine C DLAMCH). 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) returns the optimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 1, if MIN(L,N) = 0; otherwise, C LDWORK >= MAX( N+P, MIN(L,N)+MAX(3*N-1,M,L) ). C If LDWORK >= 2*L*N+L*M+N*P+ C MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ) then C the original matrices are restored if no order reduction C is possible. This is achieved by saving system matrices C before reduction and restoring them if no order reduction C took place. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C XERBLA. The optimal size does not necessarily include the C space needed for saving the original system matrices. 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 subroutine elliminates the non-dynamics modes in two steps: C C Step 1: Reduce the system to the SVD-like coordinate form C (Q'*A*Z-lambda*Q'*E*Z, Q'*B, C*Z) , where C C ( A11 A12 A13 ) ( E11 0 0 ) ( B1 ) C Q'*A*Z = ( A21 A22 0 ), Q'*E*Z = ( 0 0 0 ), Q'*B = ( B2 ), C ( A31 0 0 ) ( 0 0 0 ) ( B3 ) C C C*Z = ( C1 C2 C3 ), C C where E11 and A22 are upper triangular invertible matrices. C C Step 2: Compute the reduced system as (Ar-lambda*Er,Br,Cr,Dr), C where C ( A11 - A12*inv(A22)*A21, A13 ) ( E11 0 ) C Ar = ( ), Er = ( ), C ( A31 0 ) ( 0 0 ) C C ( B1 - A12*inv(A22)*B2 ) C Br = ( ), Cr = ( C1 - C2*inv(A22)*A21, C3 ), C ( B3 ) C C Dr = D - C2*inv(A22)*B2. C C Step 3: If desired (JOBS = 'S'), reduce the descriptor system to C the standard form C C Ar <- diag(inv(E11),I)*Ar; Br <- diag(inv(E11),I)*Br; C Er = diag(I,0). C C If L = N and LR = NR = RANKE, then if Step 3 is performed, C the resulting system is a standard state space system. C C NUMERICAL ASPECTS C C If L = N, the algorithm requires 0( N**3 ) floating point C operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C May 1999. C C REVISIONS C C July 1999, V. Sima, Research Institute for Informatics, Bucharest. C A. Varga, DLR Oberpfaffenhofen, March 2002. C V. Sima, Dec. 2016, Feb. 2017. C C KEYWORDS C C Minimal realization, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER JOBS INTEGER INFO, INFRED, L, LDA, LDB, LDC, LDD, LDE, $ LDWORK, LR, M, N, NR, P, RANKE DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), E(LDE,*) C .. Local Scalars .. LOGICAL LQUERY, LSPACE, SSTYPE INTEGER K, K1, KWA, KWB, KWC, KWE, KWR, LS, LWRMIN, NS, $ RNKA22, WRKOPT C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, DTRSM, TG01FD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C C Decode JOBS. C SSTYPE = LSAME( JOBS, 'S' ) C INFO = 0 C C Test the input scalar arguments. C IF( .NOT.SSTYPE .AND. .NOT.LSAME( JOBS, 'D' ) ) THEN INFO = -1 ELSE IF( L.LT.0 ) 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, L) ) THEN INFO = -7 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, L ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( TOL.GE.ONE ) THEN INFO = -20 ELSE IF( MIN( L, N ).EQ.0 ) THEN LWRMIN = 1 ELSE LWRMIN = MAX( N + P, MIN( L, N ) + MAX( 3*N - 1, M, L ) ) END IF LQUERY = LDWORK.EQ.-1 C IF( LQUERY ) THEN CALL TG01FD( 'Not Q', 'Not Z', 'Reduce A', L, N, M, P, A, $ LDA, E, LDE, B, LDB, C, LDC, DUM, 1, DUM, 1, $ RANKE, RNKA22, TOL, IWORK, DWORK, -1, INFO ) WRKOPT = MAX( LWRMIN, INT( DWORK(1) ) ) ELSE IF( LDWORK.LT.LWRMIN ) THEN INFO = -23 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01GD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C LR = L NR = N IF( MIN( L, N ).EQ.0 ) THEN DWORK(1) = ONE RANKE = 0 INFRED = -1 RETURN END IF C C Set large workspace option. C LSPACE = LDWORK.GE.( LWRMIN + L*( 2*N + M) + P*N ) .AND. $ .NOT.SSTYPE C IF( LSPACE) THEN C C Determine offsets and save system matrices. C KWA = 1 KWE = KWA + L*N KWB = KWE + L*N KWC = KWB + L*M KWR = KWC + P*N CALL DLACPY( 'Full', L, N, A, LDA, DWORK(KWA), L ) CALL DLACPY( 'Full', L, N, E, LDE, DWORK(KWE), L ) CALL DLACPY( 'Full', L, M, B, LDB, DWORK(KWB), L ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KWC), MAX( 1, P ) ) ELSE KWR = 1 END IF C C Reduce the descriptor system to the SVD-like coordinate form C (At-lambda*Et, Bt, Ct) , where C C ( A11 A12 A13 ) ( E11 0 0 ) ( B1 ) C At = ( A21 A22 0 ), Et = ( 0 0 0 ), Bt = ( B2 ), C ( A31 0 0 ) ( 0 0 0 ) ( B3 ) C C Ct = ( C1 C2 C3 ), C C and E11 and A22 are RANKE-by-RANKE and RNKA22-by-RNKA22 C upper triangular invertible matrices, respectively. C Workspace: needed real MAX( N+P, MIN(L,N)+MAX(3*N-1,M,L) ); C needed integer N. C CALL TG01FD( 'Not Q', 'Not Z', 'Reduce A', L, N, M, P, A, LDA, $ E, LDE, B, LDB, C, LDC, DUM, 1, DUM, 1, RANKE, $ RNKA22, TOL, IWORK, DWORK(KWR), LDWORK-KWR+1, INFO ) C IF( INFO.EQ.0 ) THEN INFRED = RNKA22 IF( RNKA22.GT.0 ) THEN C C Apply residualization formulas. C K = RANKE + 1 K1 = MIN( L, N, K + RNKA22 ) LR = L - RNKA22 NR = N - RNKA22 LS = LR - RANKE NS = NR - RANKE C C Compute A21 <- INV(A22)*A21. C CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non-unit', $ RNKA22, RANKE, ONE, A(K,K), LDA, A(K,1), LDA ) C C Compute B2 <- INV(A22)*B2. C CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non-unit', $ RNKA22, M, ONE, A(K,K), LDA, B(K,1), LDB ) C C Compute the residualized systems matrices. C C Dr = D - C2*INV(A22)*B2. C CALL DGEMM( 'No Transpose', 'No Transpose', P, M, RNKA22, $ -ONE, C(1,K), LDC, B(K,1), LDB, ONE, D, LDD ) C C Br = ( B1 - A12*INV(A22)*B2 ). C ( B3 ) C CALL DGEMM( 'No Transpose', 'No Transpose', RANKE, M, $ RNKA22, -ONE, A(1,K), LDA, B(K,1), LDB, ONE, $ B, LDB ) CALL DLACPY( 'Full', LS, M, B(K1,1), LDB, B(K,1), LDB ) C C Cr = ( C1 - C2*INV(A22)*A21 C3 ). C CALL DGEMM( 'NoTranspose', 'NoTranspose', P, RANKE, RNKA22, $ -ONE, C(1,K), LDC, A(K,1), LDA, ONE, C, LDC ) CALL DLACPY( 'Full', P, NS, C(1,K1), LDC, C(1,K), LDC ) C C Ar = ( A11 - A12*INV(A22)*A21 A13 ). C ( A31 0 ) C CALL DGEMM( 'No Transpose', 'No Transpose', RANKE, RANKE, $ RNKA22, -ONE, A(1,K), LDA, A(K,1), LDA, ONE, A, $ LDA ) C CALL DLACPY( 'Full', LS, NR, A(K1,1), LDA, A(K,1), LDA ) CALL DLACPY( 'Full', RANKE, NS, A(1,K1), LDA, A(1,K), LDA ) ELSE IF( LSPACE ) THEN C C Restore system matrices. C CALL DLACPY( 'Full', L, N, DWORK(KWA), L, A, LDA ) CALL DLACPY( 'Full', L, N, DWORK(KWE), L, E, LDE ) CALL DLACPY( 'Full', L, M, DWORK(KWB), L, B, LDB ) CALL DLACPY( 'Full', P, N, DWORK(KWC), MAX( 1, P ), C, $ LDC ) INFRED = -1 END IF END IF C IF( SSTYPE ) THEN C C Ar <- diag(inv(E11),I)*Ar. C CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non-unit', $ RANKE, NR, ONE, E, LDE, A, LDA ) C C Br <- diag(inv(E11),I)*Br. C CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non-unit', $ RANKE, M, ONE, E, LDE, B, LDB ) C C E11 = I. C CALL DLASET( 'Full', RANKE, RANKE, ZERO, ONE, E, LDE ) END IF DWORK(1) = DWORK(KWR) END IF C RETURN C *** Last line of TG01GD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB08ND.f0000644000000000000000000000013215012430707016151 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB08ND.f0000644000175000017500000004407315012430707017355 0ustar00lilgelilge00000000000000 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 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, Apr. 2011. 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, NINFZ, NN, NU1, NUMU, $ NUMU1, PP, RO, SIGMA, WRKOPT DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, 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) ) ) CALL DTZRZF( II, N+II, AF, LDAF, DWORK, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, II + INT( DWORK(1) ) ) CALL DORMRZ( 'Right', 'Transpose', N, N+II, II, N, AF, LDAF, $ DWORK, AF, LDAF, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, II + INT( DWORK(1) ) ) 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 control-4.1.2/src/slicot/src/PaxHeaders/TB03AY.f0000644000000000000000000000013215012430707016177 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB03AY.f0000644000175000017500000001125115012430707017373 0ustar00lilgelilge00000000000000 SUBROUTINE TB03AY( NR, A, LDA, INDBLK, NBLK, VCOEFF, LDVCO1, $ LDVCO2, PCOEFF, LDPCO1, LDPCO2, INFO ) C C PURPOSE C C To calculate the (PWORK-by-NR) polynomial matrix V(s) one C (PWORK-by-NBLK(L-1)) block V:L-1(s) at a time, in reverse order C (L = INDBLK,...,1). At each stage, the (NBLK(L)-by-NBLK(L)) poly- C nomial matrix W(s) = V2(s) * A2 is formed, where V2(s) is that C part of V(s) already computed and A2 is the subdiagonal (incl.) C part of the L-th column block of A; W(s) is temporarily stored in C the top left part of P(s), as is subsequently the further matrix C Wbar(s) = s * V:L(s) - W(s). Then, except for the final stage C L = 1 (when the next step is to calculate P(s) itself, not here), C the top left part of V:L-1(s) is given by Wbar(s) * inv(R), where C R is the upper triangular part of the L-th superdiagonal block of C A. Finally, note that the coefficient matrices W(.,.,K) can only C be non-zero for K = L + 1,...,INPLUS, with each of these matrices C having only its first NBLK(L-1) rows non-trivial. Similarly, C Wbar(.,.,K) (and so clearly V:L-1(.,.,K) ) can only be non-zero C for K = L,...,INPLUS, with each of these having only its first C NBLK(K-1) rows non-trivial except for K = L, which has NBLK(L) C such rows. C C REVISIONS C C - C C KEYWORDS C C Coprime matrix fraction, elementary polynomial operations, C polynomial matrix, state-space representation, transfer matrix. C C NOTE: In the interests of speed, this routine does not check the C inputs for errors. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INDBLK, INFO, LDA, LDPCO1, LDPCO2, LDVCO1, $ LDVCO2, NR C .. Array Arguments .. INTEGER NBLK(*) DOUBLE PRECISION A(LDA,*), PCOEFF(LDPCO1,LDPCO2,*), $ VCOEFF(LDVCO1,LDVCO2,*) C .. Local Scalars .. INTEGER I, INPLUS, IOFF, J, JOFF, K, KPLUS, L, LSTART, $ LSTOP, LWORK, NCOL, NROW C .. External Subroutines .. EXTERNAL DAXPY, DGEMM, DLACPY, DSCAL, DTRSM C .. Executable Statements .. C INFO = 0 INPLUS = INDBLK + 1 JOFF = NR C C Calculate each column block V:LWORK-1(s) of V(s) in turn. C DO 70 L = 1, INDBLK LWORK = INPLUS - L C C Determine number of columns of V:LWORK(s) & its position in V. C NCOL = NBLK(LWORK) JOFF = JOFF - NCOL C C Find limits for V2(s) * A2 calculation: skips zero rows C in V(s). C LSTART = JOFF + 1 LSTOP = JOFF C C Calculate W(s) and store (temporarily) in top left part C of P(s). C DO 10 K = LWORK + 1, INPLUS NROW = NBLK(K-1) LSTOP = LSTOP + NROW CALL DGEMM( 'No transpose', 'No transpose', NROW, NCOL, $ LSTOP-LSTART+1, ONE, VCOEFF(1,LSTART,K), LDVCO1, $ A(LSTART,JOFF+1), LDA, ZERO, PCOEFF(1,1,K), $ LDPCO1 ) 10 CONTINUE C C Replace W(s) by Wbar(s) = s * V:L(s) - W(s). C NROW = NCOL C DO 30 K = LWORK, INDBLK KPLUS = K + 1 C DO 20 J = 1, NCOL CALL DSCAL( NROW, -ONE, PCOEFF(1,J,K), 1 ) CALL DAXPY( NROW, ONE, VCOEFF(1,JOFF+J,KPLUS), 1, $ PCOEFF(1,J,K), 1 ) 20 CONTINUE C NROW = NBLK(K) 30 CONTINUE C DO 40 J = 1, NCOL CALL DSCAL( NROW, -ONE, PCOEFF(1,J,INPLUS), 1 ) 40 CONTINUE C IF ( LWORK.NE.1 ) THEN C C If not final stage, use the upper triangular R (from A) C to calculate V:L-1(s), finally storing this new block. C IOFF = JOFF - NBLK(LWORK-1) C DO 50 I = 1, NCOL IF ( A(IOFF+I,JOFF+I).EQ.ZERO ) THEN C C Error return. C INFO = I RETURN END IF 50 CONTINUE C NROW = NBLK(LWORK) C DO 60 K = LWORK, INPLUS CALL DLACPY( 'Full', NROW, NCOL, PCOEFF(1,1,K), LDPCO1, $ VCOEFF(1,IOFF+1,K), LDVCO1 ) CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit', $ NROW, NCOL, ONE, A(IOFF+1,JOFF+1), LDA, $ VCOEFF(1,IOFF+1,K), LDVCO1 ) NROW = NBLK(K) 60 CONTINUE C END IF 70 CONTINUE C RETURN C *** Last line of TB03AY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10HD.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10HD.f0000644000175000017500000003065615012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE SB10HD( N, M, NP, NCON, NMEAS, 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 PURPOSE C C To compute the matrices of the H2 optimal n-state controller C C | AK | BK | C K = |----|----| C | CK | DK | C C for the system C C | A | B1 B2 | | A | B | C P = |----|---------| = |---|---| , C | C1 | 0 D12 | | C | D | C | C2 | D21 D22 | C C where B2 has as column size the number of control inputs (NCON) C and C2 has as row size the number of measurements (NMEAS) being C 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) The block D11 of D is zero, C C (A3) D12 is full column rank and D21 is full row rank. 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 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 SB10UD. 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 (max(2*N,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(max(M2 + NP1*NP1 + C max(NP1*N,3*M2+NP1,5*M2), C NP2 + M1*M1 + C max(M1*N,3*NP2+M1,5*NP2), C N*M2,NP2*N,NP2*M2,1), C N*(14*N+12+M2+NP2)+5), C where M1 = M - M2 and NP1 = NP - NP2. 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,Q*(Q+max(N,5)+1),N*(14*N+12+2*Q)+5). 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 D12 had not full column rank in C respect to the tolerance TOL; C = 2: if the matrix D21 had not full row rank in respect C to the tolerance TOL; C = 3: if the singular value decomposition (SVD) algorithm C did not converge (when computing the SVD of one of C the matrices D12 or D21). C = 4: if the X-Riccati equation was not solved C successfully; C = 5: if the Y-Riccati equation was not solved C successfully. C C METHOD C C The routine implements the formulas given in [1], [2]. C C REFERENCES C C [1] Zhou, K., Doyle, J.C., and Glover, K. C Robust and Optimal Control. C Prentice-Hall, Upper Saddle River, NJ, 1996. 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 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, Oct. 1998. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, May 1999, C Sept. 1999, Jan. 2000, Feb. 2000. C C KEYWORDS C C Algebraic Riccati equation, H2 optimal control, optimal regulator, C robust 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 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, $ IWY, LWAMAX, M1, M2, MINWRK, NP1, NP2 DOUBLE PRECISION TOLL C .. C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. C .. External Subroutines .. EXTERNAL DLACPY, SB10UD, SB10VD, SB10WD, 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -11 ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN INFO = -13 ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN INFO = -19 ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN INFO = -21 ELSE C C Compute workspace. C MINWRK = N*M + NP*(N+M) + M2*M2 + NP2*NP2 + $ MAX( MAX( M2 + NP1*NP1 + $ MAX( NP1*N, 3*M2 + NP1, 5*M2 ), $ NP2 + M1*M1 + $ MAX( M1*N, 3*NP2 + M1, 5*NP2 ), $ N*M2, NP2*N, NP2*M2, 1 ), $ N*( 14*N + 12 + M2 + NP2 ) + 5 ) IF( LDWORK.LT.MINWRK ) $ INFO = -26 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10HD', -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 for rank tests. C TOLL = SQRT( DLAMCH( 'Epsilon' ) ) END IF C C Workspace usage. C IWC = N*M + 1 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 H2 optimal controller. C CALL SB10UD( N, M, NP, NCON, NMEAS, 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 IWY = IWRK IWF = IWY + N*N IWH = IWF + M2*N IWRK = IWH + N*NP2 C C Compute the optimal state feedback and output injection matrices. C AK is used to store X. C CALL SB10VD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, $ DWORK( IWC ), NP, DWORK( IWF ), M2, DWORK( IWH ), N, $ AK, LDAK, DWORK( IWY ), N, RCOND( 3 ), IWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = INFO2 + 3 RETURN END IF LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Compute the H2 optimal controller. C CALL SB10WD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), M2, $ DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), $ NP2, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO2 ) C DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10HD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04HD.f0000644000000000000000000000013215012430707016153 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04HD.f0000644000175000017500000030446515012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE MB04HD( COMPQ1, COMPQ2, N, A, LDA, B, LDB, Q1, LDQ1, $ Q2, LDQ2, IWORK, LIWORK, DWORK, LDWORK, BWORK, $ INFO ) C C PURPOSE C C To compute the transformed matrices A and B, using orthogonal C matrices Q1 and Q2 for a real N-by-N regular pencil C C ( A11 0 ) ( 0 B12 ) C aA - bB = a ( ) - b ( ), (1) C ( 0 A22 ) ( B21 0 ) C C where A11, A22 and B12 are upper triangular, B21 is upper C quasi-triangular and the generalized matrix product C -1 -1 C A11 B12 A22 B21 is in periodic Schur form, such that the C matrix Q2' A Q1 is upper triangular, Q2' B Q1 is upper C quasi-triangular and the transformed pencil C a(Q2' A Q1) - b(Q2' B Q1) is in generalized Schur form. The C notation M' denotes the transpose of the matrix M. C C ARGUMENTS C C Mode Parameters C C COMPQ1 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q1, as follows: C = 'N': Q1 is not computed; C = 'I': the array Q1 is initialized internally to the unit C matrix, and the orthogonal matrix Q1 is returned; C = 'U': the array Q1 contains an orthogonal matrix Q01 on C entry, and the matrix Q01*Q1 is returned, where Q1 C is the product of the orthogonal transformations C that are applied on the right to the pencil C aA - bB in (1). C C COMPQ2 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q2, as follows: C = 'N': Q2 is not computed; C = 'I': the array Q2 is initialized internally to the unit C matrix, and the orthogonal matrix Q2 is returned; C = 'U': the array Q2 contains an orthogonal matrix Q02 on C entry, and the matrix Q02*Q2 is returned, where Q2 C is the product of the orthogonal transformations C that are applied on the left to the pencil aA - bB C in (1). C C Input/Output Parameters C C N (input) INTEGER C Order of the pencil aA - bB, N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension (LDA, N) C On entry, the leading N-by-N block diagonal part of this C array must contain the matrix A in (1). The off-diagonal C blocks need not be set to zero. C On exit, the leading N-by-N part of this array contains C the transformed upper triangular matrix. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB, N) C On entry, the leading N-by-N block anti-diagonal part of C this array must contain the matrix B in (1). The diagonal C blocks need not be set to zero. C On exit, the leading N-by-N part of this array contains C the transformed upper quasi-triangular matrix. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N). C C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1, N) C On entry, if COMPQ1 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q01, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q01 and the transformation matrix Q1 C used to transform the matrices A and B. C On exit, if COMPQ1 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q1. C If COMPQ1 = 'N' this array is not referenced. C C LDQ1 INTEGER C The leading dimension of the array Q1. C LDQ1 >= 1, if COMPQ1 = 'N'; C LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'. C C Q2 (input/output) DOUBLE PRECISION array, dimension (LDQ2, N) C On entry, if COMPQ2 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q02, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q02 and the transformation matrix Q2 C used to transform the matrices A and B. C On exit, if COMPQ2 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q2. C If COMPQ2 = 'N' this array is not referenced. C C LDQ2 INTEGER C The leading dimension of the array Q2. C LDQ2 >= 1, if COMPQ2 = 'N'; C LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= MAX( N/2+1, 32 ). C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -16, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= 2*N*N + MAX( N/2 + 168, 272 ). C For good performance LDWORK should be generally larger. C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C BWORK LOGICAL array, dimension (N/2) C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: the periodic QZ algorithm failed to reorder the C eigenvalues (the problem is very ill-conditioned) in C the SLICOT Library routine MB03KD; C = 2: the standard QZ algorithm failed in the LAPACK C routines DGGES or DHGEQZ, called by the SLICOT C routines MB03DD or MB03FD; C = 3: the eigenvalue reordering failed in the LAPACK C routine DTGEX2, called by the SLICOT routine MB03FD; C = 4: the standard QZ algorithm failed to reorder the C eigenvalues in the LAPACK routine DTGSEN, called by C the SLICOT routine MB03DD. C C METHOD C C First, the periodic QZ algorithm (see also [2] and [3]) is applied C -1 -1 C to the formal matrix product A11 B12 A22 B21 to reorder the C eigenvalues, i.e., orthogonal matrices V1, V2, V3 and V4 are C computed such that V2' A11 V1, V2' B12 V3, V4' A22 V3 and C V4' B21 V1 keep the triangular form, but they can be partitioned C into 2-by-2 block forms and the last diagonal blocks correspond to C all nonpositive real eigenvalues of the formal product, and the C first diagonal blocks correspond to the remaining eigenvalues. C C Second, Q1 = diag(V1, V3), Q2 = diag(V2, V4) and C C ( AA11 AA12 0 0 ) C ( ) C ( 0 AA22 0 0 ) C A := Q2' A Q1 =: ( ), C ( 0 0 AA33 AA34 ) C ( ) C ( 0 0 0 AA44 ) C C ( 0 0 BB13 BB14 ) C ( ) C ( 0 0 0 BB24 ) C B := Q2' B Q1 =: ( ), C ( BB31 BB32 0 0 ) C ( ) C ( 0 BB42 0 0 ) C C -1 -1 C are set, such that AA22 BB24 AA44 BB42 has only nonpositive C real eigenvalues. C C Third, the permutation matrix C C ( I 0 0 0 ) C ( ) C ( 0 0 I 0 ) C P = ( ), C ( 0 I 0 0 ) C ( ) C ( 0 0 0 I ) C C where I denotes the identity matrix of appropriate size, is used C to transform aA - bB to block upper triangular form C C ( AA11 0 | AA12 0 ) C ( | ) C ( 0 AA33 | 0 AA34 ) ( AA1 * ) C A := P' A P = (-----------+-----------) = ( ), C ( 0 0 | AA22 0 ) ( 0 AA2 ) C ( | ) C ( 0 0 | 0 AA44 ) C C ( 0 BB13 | 0 BB14 ) C ( | ) C ( BB31 0 | BB32 0 ) ( BB1 * ) C B := P' B P = (-----------+-----------) = ( ). C ( 0 0 | 0 BB24 ) ( 0 BB2 ) C ( | ) C ( 0 0 | BB42 0 ) C C Then, further orthogonal transformations that are provided by C MB03FD and MB03DD are used to triangularize the subpencil C aAA1 - bBB1. C C Finally, the subpencil aAA2 - bBB2 is triangularized by applying a C special permutation matrix. C C See also page 31 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C [2] Bojanczyk, A., Golub, G. H. and Van Dooren, P. C The periodic Schur decomposition: algorithms and applications. C In F.T. Luk (editor), Advanced Signal Processing Algorithms, C Architectures, and Implementations III, Proc. SPIE Conference, C vol. 1770, pp. 31-42, 1992. C C [3] Hench, J. J. and Laub, A. J. C Numerical Solution of the discrete-time periodic Riccati C equation. IEEE Trans. Automat. Control, 39, 1197-1210, 1994. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, December 08, 2008. C V. Sima, Dec. 2009 (SLICOT version of the routine DBTUMT). C C REVISIONS C C V. Sima, Aug. 2009, Feb. 2010, July 2010, Sep.-Nov. 2010, C Jan. 2011, Mar. 2011, July 2011, Aug. 2014, Apr. 2016. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue reordering, matrix pencil, periodic QZ algorithm, C upper (quasi-)triangular matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HUND2 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HUND2 = 2.0D+2 ) C C .. Scalar Arguments .. CHARACTER COMPQ1, COMPQ2 INTEGER INFO, LDA, LDB, LDQ1, LDQ2, LDWORK, LIWORK, N C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), $ Q1( LDQ1, * ), Q2( LDQ2, * ) C C .. Local Scalars .. LOGICAL LCMPQ1, LCMPQ2, LINIQ1, LINIQ2, LQUERY, LUPDQ1, $ LUPDQ2 INTEGER DIM1, DIM2, I, I1, I1LOLE, I1LORI, I1UPLE, $ I1UPRI, I2, I2LOLE, I2LORI, I2UPLE, I2UPRI, I3, $ IA, IA11, IA22, IALOLE, IALORI, IAUPLE, IAUPRI, $ IB, IB1, IB12, IB2, IB21, IBLOLE, IBLORI, $ IBUPLE, IBUPRI, IJ1, IJ2, ITMP, ITMP2, ITMP3, $ IV1, IV2, IV3, IV4, IWRK, J, K, KSCHUR, M, M1, $ M2, M4, MINWRK, MM, MP1, NR, NROW, OPTWRK, R, $ SDIM DOUBLE PRECISION BASE, LGBAS, TMP2, TMP3, ULP C C .. Local Arrays .. LOGICAL BW( 4 ) INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 1 ) C C .. External Functions .. LOGICAL LSAME, SB02OW DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME, SB02OW C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGGES, DLACPY, $ DLASET, DSCAL, MA01BD, MB03BA, MB03DD, MB03FD, $ MB03KD, XERBLA C C .. Intrinsic Functions .. INTRINSIC INT, LOG, MAX, MIN, MOD C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 MM = M*M LINIQ1 = LSAME( COMPQ1, 'I' ) LUPDQ1 = LSAME( COMPQ1, 'U' ) LINIQ2 = LSAME( COMPQ2, 'I' ) LUPDQ2 = LSAME( COMPQ2, 'U' ) LCMPQ1 = LINIQ1 .OR. LUPDQ1 LCMPQ2 = LINIQ2 .OR. LUPDQ2 LQUERY = LDWORK.EQ.-1 MINWRK = 2*N*N + MAX( M + 168, 272 ) C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ1, 'N' ) .OR. LCMPQ1 ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ2, 'N' ) .OR. LCMPQ2 ) ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDQ1.LT.1 .OR. LCMPQ1 .AND. LDQ1.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDQ2.LT.1 .OR. LCMPQ2 .AND. LDQ2.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LIWORK.LT.MAX( M + 1, 32 ) ) THEN INFO = -14 ELSE IF( .NOT. LQUERY .AND. LDWORK.LT.MINWRK ) THEN DWORK( 1 ) = MINWRK INFO = -16 END IF C IF( INFO.NE.0) THEN CALL XERBLA( 'MB04HD', -INFO ) RETURN ELSE C C Compute optimal workspace. C I = MAX( 1, MIN( 4, N ) ) DO 5 J = 1, I BW( I ) = .TRUE. 5 CONTINUE CALL DGGES( 'Vectors', 'Vectors', 'Sorted', SB02OW, I, A, LDA, $ B, LDB, IDUM( 1 ), DWORK, DWORK, DWORK, Q1, I, Q2, $ I, DWORK, -1, BW, INFO ) CALL DGGES( 'Vectors', 'Vectors', 'Not sorted', SB02OW, I, A, $ LDA, B, LDB, IDUM( 1 ), DWORK, DWORK, DWORK, Q1, $ I, Q2, I, DWORK( 2 ), -1, BW, INFO ) C OPTWRK = MAX( 64 + MAX( 12 + INT( DWORK( 1 ) ), 4*N, $ 24 + INT( DWORK( 2 ) ), 28 + 4*I ), $ MINWRK ) IF( LQUERY ) THEN DWORK( 1 ) = OPTWRK RETURN END IF END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK( 1 ) = ONE RETURN END IF C C Computations. Note that MB03KD needs reverse ordering of the C factors in the formal matrix product, compared to MA01BD, MB03BA. C IA11 = 1 IB12 = IA11 + MM IA22 = IB12 + MM IB21 = IA22 + MM IV1 = IB21 + MM IV2 = IV1 + MM IV3 = IV2 + MM IV4 = IV3 + MM MP1 = M + 1 C C Get the machine parameters. C ULP = DLAMCH( 'Precision' ) BASE = DLAMCH( 'Base' ) LGBAS = LOG( BASE ) C C Compute maps to access the factors of the formal matrix product. C K = 4 KSCHUR = 4 IWORK( 2*K+1 ) = -1 IWORK( 2*K+2 ) = 1 IWORK( 2*K+3 ) = -1 IWORK( 2*K+4 ) = 1 CALL MB03BA( K, KSCHUR, IWORK( 2*K+1 ), I, IWORK, IWORK( K+1 ) ) C C Store the factors of the formal matrix product. C DUM( 1 ) = ZERO CALL DCOPY( 4*MM, DUM, 0, DWORK, 1 ) CALL DLACPY( 'Upper', M, M, A, LDA, DWORK, M ) CALL DLACPY( 'Upper', M, M, A( MP1, MP1 ), LDA, DWORK( IA22 ), M ) CALL DLACPY( 'Upper', M, M, B( 1, MP1 ), LDB, DWORK( IB12 ), M ) CALL DLACPY( 'Upper', M, M, B( MP1, 1 ), LDB, DWORK( IB21 ), M ) IF( M.GT.1 ) $ CALL DCOPY( M-1, B( M+2, 1 ), LDB+1, DWORK( IB21+1 ), MP1 ) C C Set BWORK according to the eigenvalues of the formal matrix C product in Schur-triangular form. C Workspace: need 4*M*M + 2. C J = 1 IA = IV1 IB = IA + 1 C C WHILE( J.LE.M ) DO 10 CONTINUE IF( J.LT.M ) THEN IF( DWORK( IB21+J+(J-1)*M ).EQ.ZERO ) THEN CALL MA01BD( BASE, LGBAS, K, IWORK( 2*K+1 ), $ DWORK( (J-1)*M+J ), MM, DWORK( IA ), $ DWORK( IB ), IWORK( 3*K+1 ) ) BWORK( J ) = DWORK( IA ).GT.ZERO .OR. DWORK( IB ).EQ.ZERO J = J + 1 GO TO 10 ELSE BWORK( J ) = .TRUE. BWORK( J+1 ) = .TRUE. J = J + 2 GO TO 10 END IF ELSE IF ( J.EQ.M ) THEN CALL MA01BD( BASE, LGBAS, K, IWORK( 2*K+1 ), DWORK( MM ), MM, $ DWORK( IA ), DWORK( IB ), IWORK( 3*K+1 ) ) BWORK( J ) = DWORK( IA ).GT.ZERO .OR. DWORK( IB ).EQ.ZERO END IF C END WHILE 10 C C Check if BWORK(J) = .TRUE. for all J. C J = 1 C WHILE( J.LE.M and BWORK(J) ) DO 20 CONTINUE IF( J.LE.M .AND. BWORK(J) ) THEN J = J + 1 GO TO 20 END IF C END WHILE 20 C IF( J.NE.MP1 ) THEN C C Apply periodic QZ algorithm for reordering the eigenvalues. C Workspace: need 8*M*M + MAX(42*K + M, 80*K - 48), K = 4, C if there is at least a pair of adjacent blocks C of order 2 involved in reordering, and M > 10. C Otherwise, the MAX term is slightly smaller. C IWRK = 2*IV1 - 1 IB21 = 1 IA22 = IB21 + MM IB12 = IA22 + MM IA11 = IB12 + MM C KSCHUR = 1 IWORK( 2*K+1 ) = 1 IWORK( 2*K+2 ) = -1 IWORK( 2*K+3 ) = 1 IWORK( 2*K+4 ) = -1 C DO 30 I = 1, K IWORK( I ) = M IWORK( K+I ) = 0 IWORK( 3*K+I ) = 1 + ( I - 1 )*MM 30 CONTINUE C CALL DCOPY( MM*K, DUM, 0, DWORK( IB21 ), 1 ) CALL DLACPY( 'Upper', M, M, B( MP1, 1 ), LDB, DWORK( IB21 ), $ M ) CALL DLACPY( 'Upper', M, M, B( 1, MP1 ), LDB, DWORK( IB12 ), $ M ) CALL DLACPY( 'Upper', M, M, A, LDA, DWORK( IA11 ), M ) CALL DLACPY( 'Upper', M, M, A( MP1, MP1 ), LDA, DWORK( IA22 ), $ M ) IF( M.GT.1 ) $ CALL DCOPY( M-1, B( M+2, 1 ), LDB+1, DWORK( IB21+1 ), MP1 ) C CALL MB03KD( 'Initialize', IDUM, 'NotStrong', K, M, KSCHUR, $ IWORK, IWORK( K+1 ), IWORK( 2*K+1 ), BWORK, $ DWORK, IWORK, IWORK( 3*K+1 ), DWORK( IV1 ), $ IWORK, IWORK( 3*K+1 ), M1, HUND2, IWORK( 4*K+1 ), $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) $ RETURN C M2 = M - M1 I1 = M1 + 1 I2 = I1 + M1 I3 = I2 + M2 M4 = 2*M2 C C If Q1 and/or Q2 are user-initialized, update them. C The (2,1) block of A is used as workspace. C IF( LUPDQ1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1, LDQ1, DWORK( IV1 ), M, ZERO, A( MP1, 1 ), $ LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1, LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1( MP1, 1 ), LDQ1, DWORK( IV1 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1( MP1, 1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1( 1, MP1 ), LDQ1, DWORK( IV3 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1( 1, MP1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1( MP1, MP1 ), LDQ1, DWORK( IV3 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1( MP1, MP1 ), $ LDQ1 ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M, Q1( 1, I1 ), LDQ1, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q1( 1, I1 ), LDQ1 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q1( 1, I2 ), LDQ1 ) CALL DLACPY( 'Full', M, M, Q1( MP1, I1 ), LDQ1, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q1( MP1, I1 ), LDQ1 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q1( MP1, I2 ), LDQ1 ) END IF END IF C IF( LUPDQ2 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2, LDQ2, DWORK( IV4 ), M, ZERO, A( MP1, 1 ), $ LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2( MP1, 1 ), LDQ2, DWORK( IV4 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2( MP1, 1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2( 1, MP1 ), LDQ2, DWORK( IV2 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2( 1, MP1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2( MP1, MP1 ), LDQ2, DWORK( IV2 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2( MP1, MP1 ), $ LDQ2 ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M, Q2( 1, I1 ), LDQ2, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q2( 1, I1 ), LDQ2 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q2( 1, I2 ), LDQ2 ) CALL DLACPY( 'Full', M, M, Q2( MP1, I1 ), LDQ2, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q2( MP1, I1 ), LDQ2 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q2( MP1, I2 ), LDQ2 ) END IF END IF C C Make permutations of the corresponding matrices. C IF( M2.GT.0 ) THEN CALL DLASET( 'Full', M, M, ZERO, ZERO, A( MP1, 1 ), LDA ) CALL DLACPY( 'Upper', M1, M1, DWORK( IA11 ), M, A, LDA ) CALL DLASET( 'Full', M1, M1, ZERO, ZERO, A( 1, I1 ), LDA ) CALL DLACPY( 'Upper', M1, M1, DWORK( IA22 ), M, A( I1, I1 ), $ LDA ) CALL DLACPY( 'Full', M1, M2, DWORK( IA11+M*M1 ), M, $ A( 1, I2 ), LDA ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, A( I1, I2 ), LDA ) CALL DLACPY( 'Upper', M2, M2, DWORK( IA11+M*M1+M1 ), M, $ A( I2, I2 ), LDA ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, A( 1, I3 ), LDA ) CALL DLACPY( 'Full', M1, M2, DWORK( IA22+M*M1 ), M, $ A( I1, I3 ), LDA ) CALL DLASET( 'Full', M2, M2, ZERO, ZERO, A( I2, I3 ), LDA ) CALL DLACPY( 'Upper', M2, M2, DWORK( IA22+M*M1+M1 ), M, $ A( I3, I3 ), LDA ) C CALL DLASET( 'Full', M1, M1, ZERO, ZERO, B, LDB ) CALL DLACPY( 'Upper', M1, M1, DWORK( IB21 ), M, B( I1, 1 ), $ LDB ) CALL DCOPY( M1-1, DWORK( IB21+1 ), MP1, B( I1+1, 1 ), $ LDB+1 ) IF( M1.GT.2 ) $ CALL DLASET( 'Lower', M1-2, M1-2, ZERO, ZERO, $ B( I1+2, 1 ), LDB ) CALL DLASET( 'Full', M4, M1, ZERO, ZERO, B( I2, 1 ), LDB ) CALL DLACPY( 'Upper', M1, M1, DWORK( IB12 ), M, B( 1, I1 ), $ LDB ) IF( M1.GT.1 ) $ CALL DLASET( 'Lower', M1-1, M1-1, ZERO, ZERO, B( 2, I1 ), $ LDB ) CALL DLASET( 'Full', N-M1, M1, ZERO, ZERO, B( I1, I1 ), $ LDB ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, B( 1, I2 ), LDB ) CALL DLACPY( 'Full', M1, M2, DWORK( IB21+M*M1 ), M, $ B( I1, I2 ), LDB ) CALL DLASET( 'Full', M2, M2, ZERO, ZERO, B( I2, I2 ), LDB ) CALL DLACPY( 'Upper', M2, M2, DWORK( IB21+M*M1+M1 ), M, $ B( I3, I2 ), LDB ) IF( I3.LT.N ) $ CALL DCOPY( M2-1, DWORK( IB21+M*M1+I1 ), MP1, $ B( I3+1, I2 ), LDB+1 ) IF( M2.GT.2 ) $ CALL DLASET( 'Lower', M2-2, M2-2, ZERO, ZERO, $ B( I3+2, I2 ), LDB ) CALL DLACPY( 'Full', M1, M2, DWORK( IB12+M*M1 ), M, $ B( 1, I3 ), LDB ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, B( I1, I3 ), LDB ) CALL DLACPY( 'Full', M2, M2, DWORK( IB12+M*M1+M1 ), M, $ B( I2, I3 ), LDB ) CALL DLASET( 'Full', M2, M2, ZERO, ZERO, B( I3, I3 ), LDB ) ELSE CALL DLASET( 'Full', M, M, ZERO, ZERO, A( MP1, 1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, A( 1, MP1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B, LDB ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B( MP1, MP1 ), LDB ) END IF C IF( LINIQ1 ) THEN CALL DLACPY( 'Full', M, M1, DWORK( IV1 ), M, Q1, LDQ1 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q1( MP1, 1 ), LDQ1 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q1( 1, I1 ), LDQ1 ) CALL DLACPY( 'Full', M, M1, DWORK( IV3 ), M, Q1( MP1, I1 ), $ LDQ1 ) IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M2, DWORK( IV1+M*M1 ), M, $ Q1( 1, I2 ), LDQ1 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q1( MP1, I2 ), $ LDQ1 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q1( 1, I3 ), $ LDQ1 ) CALL DLACPY( 'Full', M, M2, DWORK( IV3+M*M1 ), M, $ Q1( MP1, I3 ), LDQ1 ) END IF END IF C IF( LINIQ2 ) THEN CALL DLACPY( 'Full', M, M1, DWORK( IV4 ), M, Q2, LDQ2 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q2( MP1, 1 ), LDQ2 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q2( 1, I1 ), LDQ2 ) CALL DLACPY( 'Full', M, M1, DWORK( IV2 ), M, Q2( MP1, I1 ), $ LDQ2 ) IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M2, DWORK( IV4+M*M1 ), M, $ Q2( 1, I2 ), LDQ2 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q2( MP1, I2 ), $ LDQ2 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q2( 1, I3 ), $ LDQ2 ) CALL DLACPY( 'Full', M, M2, DWORK( IV2+M*M1 ), M, $ Q2( MP1, I3 ), LDQ2 ) END IF END IF ELSE M1 = M M2 = 0 I1 = M1 + 1 I2 = I1 + M1 I3 = I2 M4 = 2*M2 CALL DLASET( 'Full', M, M, ZERO, ZERO, A( MP1, 1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, A( 1, MP1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B, LDB ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B( MP1, MP1 ), LDB ) IF( LINIQ1 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 ) IF( LINIQ2 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q2, LDQ2 ) END IF C C Count the number of blocks in BB31. C R = 0 J = 1 C WHILE( J.LE.M1 ) DO 40 CONTINUE IF( J.LT.M1 ) THEN R = R + 1 IWORK( R ) = J IF( B( M1+J+1, J ).EQ.ZERO ) THEN J = J + 1 ELSE J = J + 2 END IF GO TO 40 ELSE IF ( J.EQ.M1 ) THEN R = R + 1 IWORK( R ) = J J = J + 1 END IF C END WHILE 40 IWORK( R+1 ) = J C C Triangularize the upper left subpencil aAA1 - bBB1. C DO 60 I = 1, R C C Calculate position of submatrices in DWORK. C IB1 and IB2 are pointers to 2 consecutive blocks. C IB1 = IWORK( I ) IB2 = IWORK( I+1 ) DIM1 = IB2 - IB1 SDIM = 2*DIM1 C IAUPLE = 1 IALOLE = IAUPLE + DIM1 IAUPRI = DIM1*SDIM + 1 IALORI = IAUPRI + DIM1 IBUPLE = SDIM*SDIM + 1 IBLOLE = IBUPLE + DIM1 IBUPRI = 3*DIM1*SDIM + 1 IBLORI = IBUPRI + DIM1 I1UPLE = 2*SDIM*SDIM + 1 I1LOLE = I1UPLE + DIM1 I1UPRI = 5*DIM1*SDIM + 1 I1LORI = I1UPRI + DIM1 I2UPLE = 3*SDIM*SDIM + 1 I2LOLE = I2UPLE + DIM1 I2UPRI = 7*DIM1*SDIM + 1 I2LORI = I2UPRI + DIM1 C C Generate input matrices for MB03FD, built of submatrices of A C and B. C Workspace: need 32. C IF( DIM1.EQ.1 ) THEN CALL DCOPY( SDIM, A( IB1, IB1 ), ( LDA+1 )*M1, $ DWORK( IAUPLE ), SDIM+1 ) CALL DCOPY( SDIM, B( M1+IB1, IB1 ), ( LDB-1 )*M1, $ DWORK( IBLOLE ), 1 ) ELSE CALL DLACPY( 'Upper', DIM1, DIM1, A( IB1, IB1 ), LDA, $ DWORK( IAUPLE ), SDIM ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ DWORK( IAUPLE+1 ), SDIM ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IAUPRI ), SDIM ) CALL DLACPY( 'Upper', DIM1, DIM1, A( M1+IB1, M1+IB1 ), LDA, $ DWORK( IALORI ), SDIM ) DWORK( IALORI+1 ) = ZERO C CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IBUPLE ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, B( M1+IB1, IB1 ), LDB, $ DWORK( IBLOLE ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, M1+IB1 ), LDB, $ DWORK( IBUPRI ), SDIM ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IBLORI ), SDIM ) END IF C C Perform eigenvalue exchange. C Workspace: need 64 + max( 63, 4*N ). C IWRK = 4*SDIM*SDIM + 1 ITMP = IWRK + M*DIM1 ITMP2 = ITMP + M*DIM1 ITMP3 = ITMP2 + DIM1*DIM1 CALL MB03FD( SDIM, ULP, DWORK( IAUPLE ), SDIM, DWORK( IBUPLE ), $ SDIM, DWORK( I1UPLE ), SDIM, DWORK( I2UPLE ), $ SDIM, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN IF( INFO.LT.3 ) $ INFO = 2 RETURN END IF C NR = IB2 - 1 C IF( DIM1.EQ.2 ) THEN C C Update A. C CALL DLACPY( 'Full', NR, DIM1, A( 1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), $ SDIM, ZERO, A( 1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, A( 1, M1+IB1 ), LDA, $ DWORK( I1LOLE ), SDIM, ONE, A( 1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), $ SDIM, ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, A( 1, M1+IB1 ), LDA, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ A( 1, M1+IB1 ), LDA ) C CALL DLACPY( 'Full', NR, DIM1, A( I1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), $ SDIM, ZERO, A( I1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, A( I1, M1+IB1 ), LDA, $ DWORK( I1LOLE ), SDIM, ONE, A( I1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), $ SDIM, ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, A( I1, M1+IB1 ), LDA, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ A( I1, M1+IB1 ), LDA ) C CALL DLACPY( 'Full', DIM1, DIM1, A( M1+IB1, IB1 ), LDA, $ DWORK( ITMP2 ), DIM1 ) CALL DLACPY( 'Full', DIM1, DIM1, A( IB1, M1+IB1 ), LDA, $ DWORK( ITMP3 ), DIM1 ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ A( M1+IB1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB2+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ A( IB1, IB2 ), LDA, ZERO, A( M1+IB1, IB2 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ A( IB1, IB1 ), LDA, ZERO, DWORK( ITMP ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2LOLE ), SDIM, DWORK( ITMP2 ), $ DIM1, ONE, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ A( IB1, IB1 ), LDA ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2LOLE ), SDIM, $ A( M1+IB1, M1+IB1 ), LDA, ZERO, $ A( IB1, M1+IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2UPLE ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, A( IB1, M1+IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IB1, M1+IB1 ), LDA, ZERO, DWORK( ITMP ), $ DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2UPRI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ A( M1+IB1, M1+IB1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2UPRI ), SDIM, A( IB1, I2 ), $ LDA, ZERO, A( M1+IB1, I2 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2UPLE ), SDIM, A( IB1, I2 ), $ LDA, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ A( IB1, I2 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2LOLE ), SDIM, A( M1+IB1, I3 ), $ LDA, ZERO, A( IB1, I3 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2LORI ), SDIM, A( M1+IB1, I3 ), $ LDA, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ A( M1+IB1, I3 ), LDA ) END IF C C Update B. C CALL DLACPY( 'Full', NR, DIM1, B( 1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), $ SDIM, ZERO, B( 1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, B( 1, M1+IB1 ), LDB, $ DWORK( I1LOLE ), SDIM, ONE, B( 1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), $ SDIM, ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, B( 1, M1+IB1 ), LDB, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ B( 1, M1+IB1 ), LDB ) C CALL DLACPY( 'Full', NR, DIM1, B( I1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), $ SDIM, ZERO, B( I1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, B( I1, M1+IB1 ), LDB, $ DWORK( I1LOLE ), SDIM, ONE, B( I1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), $ SDIM, ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, B( I1, M1+IB1 ), LDB, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ B( I1, M1+IB1 ), LDB ) C CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, IB1 ), LDB, $ DWORK( ITMP2 ), DIM1 ) CALL DLACPY( 'Full', DIM1, DIM1, B( M1+IB1, M1+IB1 ), LDB, $ DWORK( ITMP3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IB1, IB1 ), LDB, ZERO, B( IB1, IB1 ), LDB $ ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2UPLE ), SDIM, DWORK( ITMP2 ), $ DIM1, ONE, B( IB1, IB1 ), LDB ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ B( M1+IB1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IB1, IB1+1 ), LDB, ZERO, DWORK( ITMP ), $ DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ B( M1+IB1, IB1+1 ), LDB ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ B( IB1, M1+IB1 ), LDB, ZERO, $ B( M1+IB1, M1+IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2LORI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, B( M1+IB1, M1+IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ B( IB1, M1+IB1 ), LDB, ZERO, DWORK( ITMP ), $ DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2LOLE ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ B( IB1, M1+IB1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2LOLE ), SDIM, B( M1+IB1, I2 ), $ LDB, ZERO, B( IB1, I2 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2LORI ), SDIM, B( M1+IB1, I2 ), $ LDB, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ B( M1+IB1, I2 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2UPRI ), SDIM, B( IB1, I3 ), $ LDB, ZERO, B( M1+IB1, I3 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2UPLE ), SDIM, B( IB1, I3 ), $ LDB, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ B( IB1, I3 ), LDB ) END IF C ITMP = IWRK + N*DIM1 C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DLACPY( 'Full', N, DIM1, Q1( 1, IB1 ), LDQ1, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPLE ), SDIM, ZERO, Q1( 1, IB1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q1( 1, M1+IB1 ), LDQ1, $ DWORK( I1LOLE ), SDIM, ONE, Q1( 1, IB1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q1( 1, M1+IB1 ), LDQ1, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( ITMP ), N, $ Q1( 1, M1+IB1 ), LDQ1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DLACPY( 'Full', N, DIM1, Q2( 1, IB1 ), LDQ2, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPLE ), SDIM, ZERO, Q2( 1, IB1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q2( 1, M1+IB1 ), LDQ2, $ DWORK( I2LOLE ), SDIM, ONE, Q2( 1, IB1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPRI ), SDIM, ZERO, DWORK( ITMP ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q2( 1, M1+IB1 ), LDQ2, $ DWORK( I2LORI ), SDIM, ONE, DWORK( ITMP ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( ITMP ), N, $ Q2( 1, M1+IB1 ), LDQ2 ) END IF C ELSE C C Update A. C CALL DCOPY( NR, A( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), A( 1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), A( 1, M1+IB1 ), 1, $ A( 1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), A( 1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ A( 1, M1+IB1 ), 1 ) C CALL DCOPY( NR, A( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), A( I1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), A( I1, M1+IB1 ), 1, $ A( I1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), A( I1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ A( I1, M1+IB1 ), 1 ) C TMP2 = A( M1+IB1, IB1 ) TMP3 = A( IB1, M1+IB1 ) IF( M1.GT.IB1 ) THEN CALL DCOPY( M1-IB1, A( IB1, IB1+1 ), LDA, $ A( M1+IB1, IB1+1 ), LDA ) CALL DSCAL( M1-IB1, DWORK( I2UPRI ), A( M1+IB1, IB1+1 ), $ LDA ) END IF A( M1+IB1, IB1 ) = ZERO CALL DSCAL( M1-IB1+1, DWORK( I2UPLE ), A( IB1, IB1 ), LDA ) A( IB1, IB1 ) = A( IB1, IB1 ) + DWORK( I2LOLE )*TMP2 C CALL DCOPY( M1-IB1+1, A( M1+IB1, M1+IB1 ), LDA, $ A( IB1, M1+IB1 ), LDA ) CALL DSCAL( M1-IB1+1, DWORK( I2LOLE ), A( IB1, M1+IB1 ), $ LDA ) A( IB1, M1+IB1 ) = A( IB1, M1+IB1 ) + DWORK( I2UPLE )*TMP3 CALL DSCAL( M1-IB1+1, DWORK( I2LORI ), A( M1+IB1, M1+IB1 ), $ LDA ) A( M1+IB1, M1+IB1 ) = A( M1+IB1, M1+IB1 ) + $ DWORK( I2UPRI )*TMP3 C IF( M2.GT.0 ) THEN CALL DCOPY( M2, A( IB1, I2 ), LDA, A( M1+IB1, I2 ), LDA ) CALL DSCAL( M2, DWORK( I2UPRI ), A( M1+IB1, I2 ), LDA ) CALL DSCAL( M2, DWORK( I2UPLE ), A( IB1, I2 ), LDA ) CALL DCOPY( M2, A( M1+IB1, I3 ), LDA, A( IB1, I3 ), LDA ) CALL DSCAL( M2, DWORK( I2LOLE ), A( IB1, I3 ), LDA ) CALL DSCAL( M2, DWORK( I2LORI ), A( M1+IB1, I3 ), LDA ) END IF C C Update B. C CALL DCOPY( NR, B( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), B( 1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), B( 1, M1+IB1 ), 1, $ B( 1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), B( 1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( 1, M1+IB1 ), 1 ) C CALL DCOPY( NR, B( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), B( I1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), B( I1, M1+IB1 ), 1, $ B( I1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), B( I1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( I1, M1+IB1 ), 1 ) C TMP2 = B( IB1, IB1 ) TMP3 = B( M1+IB1, M1+IB1 ) CALL DCOPY( M1-IB1+1, B( M1+IB1, IB1 ), LDB, B( IB1, IB1 ), $ LDB ) CALL DSCAL( M1-IB1+1, DWORK( I2LOLE ), B( IB1, IB1 ), LDB ) B( IB1, IB1 ) = B( IB1, IB1 ) + DWORK( I2UPLE )*TMP2 B( M1+IB1, IB1 ) = ZERO CALL DSCAL( M1-IB1+1, DWORK( I2LORI ), B( M1+IB1, IB1+1 ), $ LDB ) C CALL DCOPY( M1-IB1+1, B( IB1, M1+IB1 ), LDB, $ B( M1+IB1, M1+IB1 ), LDB ) CALL DSCAL( M1-IB1+1, DWORK( I2UPRI ), B( M1+IB1, M1+IB1 ), $ LDB ) B( M1+IB1, M1+IB1 ) = B( M1+IB1, M1+IB1 ) + $ DWORK( I2LORI )*TMP3 CALL DSCAL( M1-IB1+1, DWORK( I2UPLE ), B( IB1, M1+IB1 ), $ LDB ) B( IB1, M1+IB1 ) = B( IB1, M1+IB1 ) + DWORK( I2LOLE )*TMP3 C IF( M2.GT.0 ) THEN CALL DCOPY( M2, B( M1+IB1, I2 ), LDB, B( IB1, I2 ), LDB ) CALL DSCAL( M2, DWORK( I2LOLE ), B( IB1, I2 ), LDB ) CALL DSCAL( M2, DWORK( I2LORI ), B( M1+IB1, I2 ), LDB ) CALL DCOPY( M2, B( IB1, I3 ), LDB, B( M1+IB1, I3 ), LDB ) CALL DSCAL( M2, DWORK( I2UPRI ), B( M1+IB1, I3 ), LDB ) CALL DSCAL( M2, DWORK( I2UPLE ), B( IB1, I3 ), LDB ) END IF C ITMP = IWRK + N C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DCOPY( N, Q1( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I1UPLE ), Q1( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I1LOLE ), Q1( 1, M1+IB1 ), 1, $ Q1( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I1LORI ), Q1( 1, M1+IB1 ), 1 ) CALL DAXPY( N, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ Q1( 1, M1+IB1 ), 1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DCOPY( N, Q2( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I2UPLE ), Q2( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I2LOLE ), Q2( 1, M1+IB1 ), 1, $ Q2( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I2LORI ), Q2( 1, M1+IB1 ), 1 ) CALL DAXPY( N, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ Q2( 1, M1+IB1 ), 1 ) END IF C END IF C DO 50 J = I - 1, 1, -1 C C Calculate position of submatrices in DWORK. C IJ1 = IWORK( J ) IJ2 = IWORK( J+1 ) DIM1 = IWORK( I+1 ) - IWORK( I ) DIM2 = IJ2 - IJ1 SDIM = DIM1 + DIM2 C IALOLE = IAUPLE + DIM1 IAUPRI = DIM1*SDIM + 1 IALORI = IAUPRI + DIM1 IBUPLE = SDIM*SDIM + 1 IBLOLE = IBUPLE + DIM1 IBUPRI = SDIM*SDIM + DIM1*SDIM + 1 IBLORI = IBUPRI + DIM1 I1UPLE = 2*SDIM*SDIM + 1 I1LOLE = I1UPLE + DIM1 I1UPRI = 2*SDIM*SDIM + DIM1*SDIM + 1 I1LORI = I1UPRI + DIM1 I2UPLE = 3*SDIM*SDIM + 1 I2LOLE = I2UPLE + DIM1 I2UPRI = 3*SDIM*SDIM + DIM1*SDIM + 1 I2LORI = I2UPRI + DIM1 C C Generate input matrices for MB03DD built of submatrices of A C and B. C Workspace: need 32. C IF( DIM1.EQ.2 .AND. DIM2.EQ.2 ) THEN CALL DLACPY( 'Full', DIM1, DIM1, A( IB1, IB1 ), LDA, $ DWORK( IAUPLE ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM1, A( M1+IJ1, IB1 ), LDA, $ DWORK( IALOLE ), SDIM ) CALL DLASET( 'Full', DIM1, DIM2, ZERO, ZERO, $ DWORK( IAUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, A( M1+IJ1, M1+IJ1 ), $ LDA, DWORK( IALORI ), SDIM ) C CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, IB1 ), LDB, $ DWORK( IBUPLE ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM1, B( M1+IJ1, IB1 ), LDB, $ DWORK( IBLOLE ), SDIM ) CALL DLASET( 'Full', DIM1, DIM2, ZERO, ZERO, $ DWORK( IBUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, B( M1+IJ1, M1+IJ1 ), $ LDB, DWORK( IBLORI ), SDIM ) C ELSE IF( DIM1.EQ.1 .AND. DIM2.EQ.2 ) THEN DWORK( IAUPLE ) = A( IB1, IB1 ) CALL DCOPY( DIM2, A( M1+IJ1, IB1 ), 1, DWORK( IALOLE ), $ 1 ) CALL DCOPY( DIM2, DUM, 0, DWORK( IAUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, A( M1+IJ1, M1+IJ1 ), $ LDA, DWORK( IALORI ), SDIM ) C DWORK( IBUPLE ) = B( IB1, IB1 ) CALL DCOPY( DIM2, B( M1+IJ1, IB1 ), 1, DWORK( IBLOLE ), $ 1 ) CALL DCOPY( DIM2, DUM, 0, DWORK( IBUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, B( M1+IJ1, M1+IJ1 ), $ LDB, DWORK( IBLORI ), SDIM ) C ELSE IF( DIM1.EQ.2 .AND. DIM2.EQ.1 ) THEN CALL DLACPY( 'Full', DIM1, DIM1, A( IB1, IB1 ), LDA, $ DWORK( IAUPLE ), SDIM ) CALL DCOPY( DIM1, A( M1+IJ1, IB1 ), LDA, DWORK( IALOLE ), $ SDIM ) CALL DCOPY( DIM1, DUM, 0, DWORK( IAUPRI ), 1 ) DWORK( IALORI ) = A( M1+IJ1, M1+IJ1 ) C CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, IB1 ), LDB, $ DWORK( IBUPLE ), SDIM ) CALL DCOPY( DIM1, B( M1+IJ1, IB1 ), LDB, DWORK( IBLOLE ), $ SDIM ) CALL DCOPY( DIM1, DUM, 0, DWORK( IBUPRI ), 1 ) DWORK( IBLORI ) = B( M1+IJ1, M1+IJ1 ) C ELSE DWORK( IAUPLE ) = A( IB1, IB1 ) DWORK( IALOLE ) = A( M1+IJ1, IB1 ) DWORK( IAUPRI ) = ZERO DWORK( IALORI ) = A( M1+IJ1, M1+IJ1 ) C DWORK( IBUPLE ) = B( IB1, IB1 ) DWORK( IBLOLE ) = B( M1+IJ1, IB1 ) DWORK( IBUPRI ) = ZERO DWORK( IBLORI ) = B( M1+IJ1, M1+IJ1 ) C END IF C C Perform upper triangularization. C Workspace: need 64 + max( 75, 4*N ). C IWRK = 4*SDIM*SDIM + 1 ITMP = IWRK + 2*N CALL MB03DD( 'Lower', DIM1, DIM2, ULP, DWORK( IBUPLE ), $ SDIM, DWORK( IAUPLE ), SDIM, DWORK( I1UPLE ), $ SDIM, DWORK( I2UPLE ), SDIM, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN IF( INFO.LE.4 ) THEN INFO = 2 ELSE INFO = 4 END IF RETURN END IF C NROW = IJ2 - 1 C IF( DIM1.EQ.2 .AND. DIM2.EQ.2 ) THEN C C Update A. C CALL DLACPY( 'Full', NR, DIM1, A( 1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, A( 1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM1, DIM2, ONE, A( 1, M1+IJ1 ), LDA, $ DWORK( I1LOLE ), SDIM, ONE, A( 1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM2, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM2, DIM2, ONE, A( 1, M1+IJ1 ), LDA, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NR ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ A( 1, M1+IJ1 ), LDA ) C CALL DLACPY( 'Full', NROW, DIM1, A( I1, IB1 ), LDA, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, A( I1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM2, ONE, A( I1, M1+IJ1 ), LDA, $ DWORK( I1LOLE ), SDIM, ONE, A( I1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, A( I1, M1+IJ1 ), LDA, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NROW ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ A( I1, M1+IJ1 ), LDA ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, A( IB1, IB1 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, IB1 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ A( M1+IJ1, IB1 ), LDA, ONE, A( IB1, IB1 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, IB1 ), LDA, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, IB1 ), LDA ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, A( IB1, M1+IJ1 ), $ LDA, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, M1+IJ1 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ A( M1+IJ1, M1+IJ1 ), LDA, ONE, $ A( IB1, M1+IJ1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, M1+IJ1 ), LDA, ONE, $ DWORK( ITMP ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, A( IB1, I2 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, I2 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ A( M1+IJ1, I2 ), LDA, ONE, A( IB1, I2 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, I2 ), LDA, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DLACPY( 'Full', NR, DIM1, B( 1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, B( 1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM1, DIM2, ONE, B( 1, M1+IJ1 ), LDB, $ DWORK( I1LOLE ), SDIM, ONE, B( 1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM2, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM2, DIM2, ONE, B( 1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NR ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ B( 1, M1+IJ1 ), LDB ) C CALL DLACPY( 'Full', NROW, DIM1, B( I1, IB1 ), LDB, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, B( I1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM2, ONE, B( I1, M1+IJ1 ), LDB, $ DWORK( I1LOLE ), SDIM, ONE, B( I1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, B( I1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NROW ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ B( I1, M1+IJ1 ), LDB ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, B( IB1, IB1 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, IB1 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IJ1, IB1 ), LDB, ONE, B( IB1, IB1 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, IB1 ), LDB, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, IB1 ), LDB ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, B( IB1, M1+IJ1 ), $ LDB, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, M1+IJ1 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IJ1, M1+IJ1 ), LDB, ONE, $ B( IB1, M1+IJ1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, M1+IJ1 ), LDB, ONE, $ DWORK( ITMP ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, B( IB1, I2 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, I2 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IJ1, I2 ), LDB, ONE, B( IB1, I2 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, I2 ), LDB, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ B( M1+IJ1, I2 ), LDB ) END IF C C Update Q1. C IF( LCMPQ1 ) THEN CALL DLACPY( 'Full', N, DIM1, Q1( 1, IB1 ), LDQ1, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPLE ), SDIM, ZERO, $ Q1( 1, IB1 ), LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM2, ONE, Q1( 1, M1+IJ1 ), LDQ1, $ DWORK( I1LOLE ), SDIM, ONE, Q1( 1, IB1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPRI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q1( 1, M1+IJ1 ), LDQ1, $ DWORK( I1LORI ), SDIM, ONE, $ DWORK( ITMP ), N ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q1( 1, M1+IJ1 ), LDQ1 ) END IF C C Update Q2. C IF( LCMPQ2 ) THEN CALL DLACPY( 'Full', N, DIM1, Q2( 1, IB1 ), LDQ2, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPLE ), SDIM, ZERO, $ Q2( 1, IB1 ), LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM2, ONE, Q2( 1, M1+IJ1 ), LDQ2, $ DWORK( I2LOLE ), SDIM, ONE, Q2( 1, IB1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPRI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q2( 1, M1+IJ1 ), LDQ2, $ DWORK( I2LORI ), SDIM, ONE, $ DWORK( ITMP ), N ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q2( 1, M1+IJ1 ), LDQ2 ) END IF C ELSE IF( DIM1.EQ.1 .AND. DIM2.EQ.2 ) THEN C C Update A. C CALL DCOPY( NR, A( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NR-1, DIM2, ONE, $ A( 1, M1+IJ1 ), LDA, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), A( 1, IB1 ), 1 ) A( NR, IB1 ) = DWORK( I1UPLE )*A( NR, IB1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-1, DIM2, $ DIM2, ONE, A( 1, M1+IJ1 ), LDA, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) DWORK( ITMP+ NR-1 ) = ZERO DWORK( ITMP+2*NR-1 ) = ZERO CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), 1, $ DWORK( ITMP+NR ), 1 ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ A( 1, M1+IJ1 ), LDA ) C CALL DCOPY( NROW, A( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM2, ONE, $ A( I1, M1+IJ1 ), LDA, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), A( I1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, A( I1, M1+IJ1 ), LDA, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+NROW ), 1 ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ A( I1, M1+IJ1 ), LDA ) C CALL DCOPY( M1-IB1+1, A( IB1, IB1 ), LDA, DWORK( IWRK ), $ 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IB1+1, ONE, $ A( M1+IJ1, IB1 ), LDA, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), A( IB1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, IB1 ), LDA, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, IB1 ), LDA ) C CALL DCOPY( M1-IJ1+1, A( IB1, M1+IJ1 ), LDA, $ DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IJ1+1, ONE, $ A( M1+IJ1, M1+IJ1 ), LDA, DWORK( I2LOLE ), $ 1, DWORK( I2UPLE ), A( IB1, M1+IJ1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, M1+IJ1 ), LDA, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, A( IB1, I2 ), LDA, DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M4, ONE, $ A( M1+IJ1, I2 ), LDA, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), A( IB1, I2 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ A( M1+IJ1, I2 ), LDA, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I2UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DCOPY( NR, B( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NR-1, DIM2, ONE, $ B( 1, M1+IJ1 ), LDB, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), B( 1, IB1 ), 1 ) B( NR, IB1 ) = DWORK( I1UPLE )*B( NR, IB1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-1, DIM2, $ DIM2, ONE, B( 1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) DWORK( ITMP+ NR-1 ) = ZERO DWORK( ITMP+2*NR-1 ) = ZERO CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), 1, $ DWORK( ITMP+NR ), 1 ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ B( 1, M1+IJ1 ), LDB ) C CALL DCOPY( NROW, B( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM2, ONE, $ B( I1, M1+IJ1 ), LDB, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), B( I1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, B( I1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+NROW ), 1 ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ B( I1, M1+IJ1 ), LDB ) C CALL DCOPY( M1-IB1+1, B( IB1, IB1 ), LDB, DWORK( IWRK ), $ 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IB1+1, ONE, $ B( M1+IJ1, IB1 ), LDB, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), B( IB1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, IB1 ), LDB, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, IB1 ), LDB ) C CALL DCOPY( M1-IJ1+1, B( IB1, M1+IJ1 ), LDB, $ DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IJ1+1, ONE, $ B( M1+IJ1, M1+IJ1 ), LDB, DWORK( I2LOLE ), $ 1, DWORK( I2UPLE ), B( IB1, M1+IJ1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, M1+IJ1 ), LDB, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, B( IB1, I2 ), LDB, DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M4, ONE, $ B( M1+IJ1, I2 ), LDB, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), B( IB1, I2 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, I2 ), LDB, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I2UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ B( M1+IJ1, I2 ), LDB ) END IF C C Update Q1. C IF( LCMPQ1 ) THEN CALL DCOPY( N, Q1( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', N, DIM2, ONE, $ Q1( 1, M1+IJ1 ), LDQ1, DWORK( I1LOLE ), $ 1, DWORK( I1UPLE ), Q1( 1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q1( 1, M1+IJ1 ), LDQ1, $ DWORK( I1LORI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DAXPY( N, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( N, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+N ), 1 ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q1( 1, M1+IJ1 ), LDQ1 ) END IF C C Update Q2. C IF( LCMPQ2 ) THEN CALL DCOPY( N, Q2( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', N, DIM2, ONE, $ Q2( 1, M1+IJ1 ), LDQ2, DWORK( I2LOLE ), $ 1, DWORK( I2UPLE ), Q2( 1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q2( 1, M1+IJ1 ), LDQ2, $ DWORK( I2LORI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DAXPY( N, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( N, DWORK( I2UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+N ), 1 ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q2( 1, M1+IJ1 ), LDQ2 ) END IF C ELSE IF( DIM1.EQ.2 .AND. DIM2.EQ.1 ) THEN C C Update A. C CALL DLACPY( 'Full', NR, DIM1, A( 1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, A( 1, IB1 ), $ LDA ) CALL DAXPY( NR-1, DWORK( I1LOLE ), A( 1, M1+IJ1 ), 1, $ A( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE+SDIM ), A( 1, M1+IJ1 ), $ 1, A( 1, IB1+1 ), 1 ) A( NR, M1+IJ1 ) = ZERO CALL DGEMV( 'No Transpose', NR, DIM1, ONE, $ DWORK( IWRK ), NR, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), A( 1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', NROW, DIM1, A( I1, IB1 ), LDA, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, A( I1, IB1 ), $ LDA ) CALL DAXPY( NROW, DWORK( I1LOLE ), A( I1, M1+IJ1 ), 1, $ A( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE+SDIM ), A( I1, M1+IJ1 ), $ 1, A( I1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM1, ONE, $ DWORK( IWRK ), NROW, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), A( I1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, A( IB1, IB1 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, IB1 ), $ LDA ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE ), A( M1+IJ1, IB1 ), $ LDA, A( IB1, IB1 ), LDA ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE+SDIM ), $ A( M1+IJ1, IB1 ), LDA, A( IB1+1, IB1 ), $ LDA ) CALL DGEMV( 'Transpose', DIM1, M1-IB1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), A( M1+IJ1, IB1 ), LDA ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, A( IB1, M1+IJ1 ), $ LDA, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, M1+IJ1 ), $ LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE ), $ A( M1+IJ1, M1+IJ1 ), LDA, A( IB1, M1+IJ1 ), $ LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE+SDIM ), $ A( M1+IJ1, M1+IJ1 ), LDA, $ A( IB1+1, M1+IJ1 ), LDA ) CALL DGEMV( 'Transpose', DIM1, M1-IJ1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, A( IB1, I2 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, I2 ), $ LDA ) CALL DAXPY( M4, DWORK( I2LOLE ), A( M1+IJ1, I2 ), $ LDA, A( IB1, I2 ), LDA ) CALL DAXPY( M4, DWORK( I2LOLE+SDIM ), $ A( M1+IJ1, I2 ), LDA, A( IB1+1, I2 ), $ LDA ) CALL DGEMV( 'Transpose', DIM1, M4, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DLACPY( 'Full', NR, DIM1, B( 1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, B( 1, IB1 ), $ LDB ) CALL DAXPY( NR-1, DWORK( I1LOLE ), B( 1, M1+IJ1 ), 1, $ B( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE+SDIM ), B( 1, M1+IJ1 ), $ 1, B( 1, IB1+1 ), 1 ) B( NR, M1+IJ1 ) = ZERO CALL DGEMV( 'No Transpose', NR, DIM1, ONE, $ DWORK( IWRK ), NR, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), B( 1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', NROW, DIM1, B( I1, IB1 ), LDB, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, B( I1, IB1 ), $ LDB ) CALL DAXPY( NROW, DWORK( I1LOLE ), B( I1, M1+IJ1 ), 1, $ B( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE+SDIM ), B( I1, M1+IJ1 ), $ 1, B( I1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM1, ONE, $ DWORK( IWRK ), NROW, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), B( I1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, B( IB1, IB1 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, IB1 ), $ LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE ), B( M1+IJ1, IB1 ), $ LDB, B( IB1, IB1 ), LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE+SDIM ), $ B( M1+IJ1, IB1 ), LDB, B( IB1+1, IB1 ), $ LDB ) CALL DGEMV( 'Transpose', DIM1, M1-IB1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), B( M1+IJ1, IB1 ), LDB ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, B( IB1, M1+IJ1 ), $ LDB, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, M1+IJ1 ), $ LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE ), $ B( M1+IJ1, M1+IJ1 ), LDB, B( IB1, M1+IJ1 ), $ LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE+SDIM ), $ B( M1+IJ1, M1+IJ1 ), LDB, $ B( IB1+1, M1+IJ1 ), LDB ) CALL DGEMV( 'Transpose', DIM1, M1-IJ1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, B( IB1, I2 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, I2 ), $ LDB ) CALL DAXPY( M4, DWORK( I2LOLE ), B( M1+IJ1, I2 ), $ LDB, B( IB1, I2 ), LDB ) CALL DAXPY( M4, DWORK( I2LOLE+SDIM ), $ B( M1+IJ1, I2 ), LDB, B( IB1+1, I2 ), $ LDB ) CALL DGEMV( 'Transpose', DIM1, M4, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), B( M1+IJ1, I2 ), LDB ) END IF C C Update Q1. C IF( LCMPQ1 ) THEN CALL DLACPY( 'Full', N, DIM1, Q1( 1, IB1 ), LDQ1, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPLE ), SDIM, ZERO, $ Q1( 1, IB1 ), LDQ1 ) CALL DAXPY( N, DWORK( I1LOLE ), Q1( 1, M1+IJ1 ), 1, $ Q1( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I1LOLE+SDIM ), Q1( 1, M1+IJ1 ), $ 1, Q1( 1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', N, DIM1, ONE, $ DWORK( IWRK ), N, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), Q1( 1, M1+IJ1 ), 1 ) END IF C C Update Q2. C IF( LCMPQ2 ) THEN CALL DLACPY( 'Full', N, DIM1, Q2( 1, IB1 ), LDQ2, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPLE ), SDIM, ZERO, $ Q2( 1, IB1 ), LDQ2 ) CALL DAXPY( N, DWORK( I2LOLE ), Q2( 1, M1+IJ1 ), 1, $ Q2( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I2LOLE+SDIM ), Q2( 1, M1+IJ1 ), $ 1, Q2( 1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', N, DIM1, ONE, $ DWORK( IWRK ), N, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), Q2( 1, M1+IJ1 ), 1 ) END IF C ELSE C C Update A. C CALL DCOPY( NR, A( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), A( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE ), A( 1, M1+IJ1 ), 1, $ A( 1, IB1 ), 1 ) CALL DSCAL( NR-1, DWORK( I1LORI ), A( 1, M1+IJ1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ A( 1, M1+IJ1 ), 1 ) A( NR, M1+IJ1 ) = DWORK( I1UPRI )*DWORK( IWRK+NR-1 ) C CALL DCOPY( NROW, A( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NROW, DWORK( I1UPLE ), A( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE ), A( I1, M1+IJ1 ), 1, $ A( I1, IB1 ), 1 ) CALL DSCAL( NROW, DWORK( I1LORI ), A( I1, M1+IJ1 ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ A( I1, M1+IJ1 ), 1 ) C CALL DCOPY( M1-IB1+1, A( IB1, IB1 ), LDA, DWORK( IWRK ), $ 1 ) CALL DSCAL( M1-IB1+1, DWORK( I2UPLE ), A( IB1, IB1 ), $ LDA ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE ), A( M1+IJ1, IB1 ), $ LDA, A( IB1, IB1 ), LDA ) CALL DSCAL( M1-IB1+1, DWORK( I2LORI ), A( M1+IJ1, IB1 ), $ LDA ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ A( M1+IJ1, IB1 ), LDA ) C CALL DCOPY( M1-IJ1+1, A( IB1, M1+IJ1 ), LDA, $ DWORK( IWRK ), 1 ) CALL DSCAL( M1-IJ1+1, DWORK( I2UPLE ), A( IB1, M1+IJ1 ), $ LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE ), $ A( M1+IJ1, M1+IJ1 ), LDA, A( IB1, M1+IJ1 ), $ LDA ) CALL DSCAL( M1-IJ1+1, DWORK( I2LORI ), $ A( M1+IJ1, M1+IJ1 ), LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, A( IB1, I2 ), LDA, DWORK( IWRK ), 1 ) CALL DSCAL( M4, DWORK( I2UPLE ), A( IB1, I2 ), LDA ) CALL DAXPY( M4, DWORK( I2LOLE ), A( M1+IJ1, I2 ), LDA, $ A( IB1, I2 ), LDA ) CALL DSCAL( M4, DWORK( I2LORI ), A( M1+IJ1, I2 ), $ LDA ) CALL DAXPY( M4, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DCOPY( NR, B( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), B( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE ), B( 1, M1+IJ1 ), 1, $ B( 1, IB1 ), 1 ) CALL DSCAL( NR-1, DWORK( I1LORI ), B( 1, M1+IJ1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( 1, M1+IJ1 ), 1 ) B( NR, M1+IJ1 ) = DWORK( I1UPRI )*DWORK( IWRK+NR-1 ) C CALL DCOPY( NROW, B( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NROW, DWORK( I1UPLE ), B( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE ), B( I1, M1+IJ1 ), 1, $ B( I1, IB1 ), 1 ) CALL DSCAL( NROW, DWORK( I1LORI ), B( I1, M1+IJ1 ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( I1, M1+IJ1 ), 1 ) C CALL DCOPY( M1-IB1+1, B( IB1, IB1 ), LDB, DWORK( IWRK ), $ 1 ) CALL DSCAL( M1-IB1+1, DWORK( I2UPLE ), B( IB1, IB1 ), $ LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE ), B( M1+IJ1, IB1 ), $ LDB, B( IB1, IB1 ), LDB ) CALL DSCAL( M1-IB1+1, DWORK( I2LORI ), B( M1+IJ1, IB1 ), $ LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ B( M1+IJ1, IB1 ), LDB ) C CALL DCOPY( M1-IJ1+1, B( IB1, M1+IJ1 ), LDB, $ DWORK( IWRK ), 1 ) CALL DSCAL( M1-IJ1+1, DWORK( I2UPLE ), B( IB1, M1+IJ1 ), $ LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE ), $ B( M1+IJ1, M1+IJ1 ), LDB, B( IB1, M1+IJ1 ), $ LDB ) CALL DSCAL( M1-IJ1+1, DWORK( I2LORI ), $ B( M1+IJ1, M1+IJ1 ), LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, B( IB1, I2 ), LDB, DWORK( IWRK ), 1 ) CALL DSCAL( M4, DWORK( I2UPLE ), B( IB1, I2 ), LDB ) CALL DAXPY( M4, DWORK( I2LOLE ), B( M1+IJ1, I2 ), LDB, $ B( IB1, I2 ), LDB ) CALL DSCAL( M4, DWORK( I2LORI ), B( M1+IJ1, I2 ), $ LDB ) CALL DAXPY( M4, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ B( M1+IJ1, I2 ), LDB ) END IF C C Update Q1. C IF( LCMPQ1 ) THEN CALL DCOPY( N, Q1( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I1UPLE ), Q1( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I1LOLE ), Q1( 1, M1+IJ1 ), 1, $ Q1( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I1LORI ), Q1( 1, M1+IJ1 ), 1 ) CALL DAXPY( N, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ Q1( 1, M1+IJ1 ), 1 ) END IF C C Update Q2. C IF( LCMPQ2 ) THEN CALL DCOPY( N, Q2( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I2UPLE ), Q2( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I2LOLE ), Q2( 1, M1+IJ1 ), 1, $ Q2( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I2LORI ), Q2( 1, M1+IJ1 ), 1 ) CALL DAXPY( N, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ Q2( 1, M1+IJ1 ), 1 ) END IF END IF 50 CONTINUE 60 CONTINUE C C Triangularize the lower right subpencil aAA2 - bBB2. C IF( M2.GT.1 ) THEN CALL DLACPY( 'Full', N, M4-2, A( 1, I2+1 ), LDA, DWORK, N ) DO 70 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ A( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ A( 1, 2*( M1+I ) ), 1 ) 70 CONTINUE C CALL DLACPY( 'Full', M4-2, M4, A( I2+1, I2 ), LDA, DWORK, $ M4-2 ) DO 80 I = 1, M2 - 1 CALL DCOPY( M4, DWORK( I ), M4-2, A( 2*( M1+I )+1, I2 ), $ LDA ) CALL DCOPY( M4, DWORK( M2+I-1 ), M4-2, A( 2*( M1+I ), I2 ), $ LDA ) 80 CONTINUE C CALL DLACPY( 'Full', N, M4-2, B( 1, I2+1 ), LDB, DWORK, N ) DO 90 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ B( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ B( 1, 2*( M1+I ) ), 1 ) 90 CONTINUE C CALL DLACPY( 'Full', M4-2, M4, B( I2+1, I2 ), LDB, DWORK, $ M4-2 ) DO 100 I = 1, M2 - 1 CALL DCOPY( M4, DWORK( I ), M4-2, B( 2*( M1+I )+1, I2 ), $ LDB ) CALL DCOPY( M4, DWORK( M2+I-1 ), M4-2, B( 2*( M1+I ), I2 ), $ LDB ) 100 CONTINUE C IF( LCMPQ1 ) THEN CALL DLACPY( 'Full', N, M4-2, Q1( 1, I2+1 ), LDQ1, DWORK, $ N ) DO 110 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ Q1( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ Q1( 1, 2*( M1+I ) ), 1 ) 110 CONTINUE END IF C IF( LCMPQ2 ) THEN CALL DLACPY( 'Full', N, M4-2, Q2( 1, I2+1 ), LDQ2, DWORK, $ N ) DO 120 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ Q2( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ Q2( 1, 2*( M1+I ) ), 1 ) 120 CONTINUE END IF END IF C DWORK( 1 ) = OPTWRK RETURN C *** Last line of MB04HD *** END control-4.1.2/src/slicot/src/PaxHeaders/UD01MD.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/UD01MD.f0000644000175000017500000001016615012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE UD01MD( M, N, L, NOUT, A, LDA, TEXT, INFO ) C C PURPOSE C C To print an M-by-N real matrix A row by row. The elements of A C are output to 7 significant figures. C C ARGUMENTS C C Input/Output Parameters C C M (input) INTEGER C The number of rows of matrix A to be printed. M >= 1. C C N (input) INTEGER C The number of columns of matrix A to be printed. N >= 1. C C L (input) INTEGER C The number of elements of matrix A to be printed per line. C 1 <= L <= 5. C C NOUT (input) INTEGER C The output channel to which the results are sent. C NOUT >= 0. 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 to be printed. C C LDA INTEGER C The leading dimension of array A. LDA >= M. C C TEXT (input) CHARACTER*72. C Title caption of the matrix to be printed (up to a C maximum of 72 characters). For example, TEXT = 'Matrix 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 The routine first prints the contents of TEXT as a title, followed C by the elements of the matrix A such that C C (i) if N <= L, the leading M-by-N part is printed; C (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of C consecutive columns of A are printed one after another C followed by one M-by-p block containing the last p columns C of A. C C Row numbers are printed on the left of each row and a column C number appears on top of each column. C The routine uses 2 + (k + 1)*(m + 1) lines and 8 + 15*c positions C per line where c is the actual number of columns, (i.e. c = L C or c = p). C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1997. C Supersedes Release 2.0 routine UD01AD by H. Willemsen, Eindhoven C University of Technology, Holland. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INFO, L, LDA, M, N, NOUT CHARACTER*(*) TEXT C .. Array Arguments .. DOUBLE PRECISION A(LDA,*) C .. Local Scalars .. INTEGER I, J, J1, J2, JJ, LENTXT, LTEXT, N1 C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC LEN, MIN C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C IF( M.LT.1 ) THEN INFO = -1 ELSE IF( N.LT.1 ) THEN INFO = -2 ELSE IF( L.LT.1 .OR. L.GT.5 ) THEN INFO = -3 ELSE IF( NOUT.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.M ) THEN INFO = -6 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'UD01MD', -INFO ) RETURN END IF C LENTXT = LEN( TEXT ) C DO 20 LTEXT = MIN( 72, LENTXT ), 2, -1 IF ( TEXT(LTEXT:LTEXT).NE.' ' ) GO TO 40 20 CONTINUE C 40 CONTINUE WRITE ( NOUT, FMT=99996 ) TEXT(1:LTEXT), M, N N1 = ( N-1 )/L J1 = 1 J2 = L C DO 80 J = 1, N1 WRITE ( NOUT, FMT=99999 ) ( JJ, JJ=J1, J2 ) C DO 60 I = 1, M WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, J2 ) 60 CONTINUE C WRITE ( NOUT, FMT=99998 ) J1 = J1 + L J2 = J2 + L 80 CONTINUE C WRITE ( NOUT, FMT=99999 ) ( J, J=J1, N ) C DO 100 I = 1, M WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, N ) 100 CONTINUE C WRITE ( NOUT, FMT=99998 ) C RETURN C 99999 FORMAT (8X,5(5X,I5,5X) ) 99998 FORMAT (' ' ) 99997 FORMAT (1X,I5,2X,5D15.7 ) 99996 FORMAT (1X,A,' (',I5,'X',I5,')',/ ) C *** Last line of UD01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01RW.f0000644000000000000000000000013215012430707016205 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01RW.f0000644000175000017500000001547615012430707017416 0ustar00lilgelilge00000000000000 SUBROUTINE MB01RW( UPLO, TRANS, M, N, A, LDA, Z, LDZ, DWORK, $ INFO ) 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 control-4.1.2/src/slicot/src/PaxHeaders/MA02CZ.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02CZ.f0000644000175000017500000000541015012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE MA02CZ( N, KL, KU, A, LDA ) C C PURPOSE C C To compute the pertranspose of a central band of a square matrix. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the square matrix A. N >= 0. C C KL (input) INTEGER C The number of subdiagonals of A to be pertransposed. C 0 <= KL <= N-1. C C KU (input) INTEGER C The number of superdiagonals of A to be pertransposed. C 0 <= KU <= N-1. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain a square matrix whose central band formed from C the KL subdiagonals, the main diagonal and the KU C superdiagonals will be pertransposed. C On exit, the leading N-by-N part of this array contains C the matrix A with its central band (the KL subdiagonals, C the main diagonal and the KU superdiagonals) pertransposed C (that is the elements of each antidiagonal appear in C reversed order). This is equivalent to forming P*B'*P, C where B is the matrix formed from the central band of A C and P is a permutation matrix with ones down the secondary C diagonal. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, March 1998. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C - C C ****************************************************************** C C .. Scalar Arguments .. INTEGER KL, KU, LDA, N C .. Array Arguments .. COMPLEX*16 A(LDA,*) C .. Local Scalars .. INTEGER I, I1, LDA1 C .. External Subroutines .. EXTERNAL ZSWAP C .. Intrinsic Functions .. INTRINSIC MIN C .. Executable Statements .. C C Quick return if possible. C IF( N.LE.1 ) $ RETURN C LDA1 = LDA + 1 C C Pertranspose the KL subdiagonals. C DO 10 I = 1, MIN( KL, N-2 ) I1 = (N-I) / 2 IF( I1.GT.0 ) $ CALL ZSWAP( I1, A(I+1,1), LDA1, A(N-I1+1,N-I1+1-I), -LDA1 ) 10 CONTINUE C C Pertranspose the KU superdiagonals. C DO 20 I = 1, MIN( KU, N-2 ) I1 = (N-I) / 2 IF( I1.GT.0 ) $ CALL ZSWAP( I1, A(1,I+1), LDA1, A(N-I1+1-I,N-I1+1), -LDA1 ) 20 CONTINUE C C Pertranspose the diagonal. C I1 = N / 2 IF( I1.GT.0 ) $ CALL ZSWAP( I1, A(1,1), LDA1, A(N-I1+1,N-I1+1), -LDA1 ) C RETURN C *** Last line of MA02CZ *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04NX.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04NX.f0000644000175000017500000002451215012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE SB04NX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) C C PURPOSE C C To solve a system of equations in Hessenberg form with two C consecutive offdiagonals and two right-hand sides. C C ARGUMENTS C C Mode Parameters C C RC CHARACTER*1 C Indicates processing by columns or rows, as follows: C = 'R': Row transformations are applied; C = 'C': Column transformations are applied. C C UL CHARACTER*1 C Indicates whether AB is upper or lower Hessenberg matrix, C as follows: C = 'U': AB is upper Hessenberg; C = 'L': AB is lower Hessenberg. C C Input/Output Parameters C C M (input) INTEGER C The order of the matrix A. M >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,M) C The leading M-by-M part of this array must contain a C matrix A in Hessenberg form. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C LAMBD1, (input) DOUBLE PRECISION C LAMBD2, These variables must contain the 2-by-2 block to be added C LAMBD3, to the diagonal blocks of A. C LAMBD4 C C D (input/output) DOUBLE PRECISION array, dimension (2*M) C On entry, this array must contain the two right-hand C side vectors of the Hessenberg system, stored row-wise. C On exit, if INFO = 0, this array contains the two solution C vectors of the Hessenberg system, stored row-wise. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used to test for near singularity of C the triangular factor R of the Hessenberg matrix. A matrix C whose estimated condition number is less than 1/TOL is C considered to be nonsingular. C C Workspace C C IWORK INTEGER array, dimension (2*M) C C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) C The leading 2*M-by-2*M part of this array is used for C computing the triangular factor of the QR decomposition C of the Hessenberg matrix. The remaining 6*M elements are C used as workspace for the computation of the reciprocal C condition estimate. C C LDDWOR INTEGER C The leading dimension of array DWORK. C LDDWOR >= MAX(1,2*M). C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if the Hessenberg matrix is (numerically) singular. C That is, its estimated reciprocal condition number C is less than or equal to TOL. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB04BX by M. Vanbegin, and C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. C C REVISIONS C C - C C Note that RC, UL, M and LDA must be such that the value of the C LOGICAL variable OK in the following statement is true. C C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) C .AND. C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) C .AND. C ( M.GE.0 ) C .AND. C ( LDA.GE.MAX( 1, M ) ) C .AND. C ( LDDWOR.GE.MAX( 1, 2*M ) ) 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 .. CHARACTER RC, UL INTEGER INFO, LDA, LDDWOR, M DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) C .. Local Scalars .. CHARACTER TRANS INTEGER J, J1, J2, M2, MJ, ML DOUBLE PRECISION C, R, RCOND, S C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLARTG, DLASET, DROT, DTRCON, DTRSV C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. Executable Statements .. C INFO = 0 C C For speed, no tests on the input scalar arguments are made. C Quick return if possible. C IF ( M.EQ.0 ) $ RETURN C M2 = M*2 IF ( LSAME( UL, 'U' ) ) THEN C DO 20 J = 1, M J2 = J*2 ML = MIN( M, J + 1 ) CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), $ LDDWOR ) CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 DWORK(J2,J2-1) = LAMBD3 DWORK(J2-1,J2) = LAMBD2 DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 20 CONTINUE C IF ( LSAME( RC, 'R' ) ) THEN TRANS = 'N' C C A is an upper Hessenberg matrix, row transformations. C DO 40 J = 1, M2 - 1 MJ = M2 - J IF ( J.LT.M2-1 ) THEN IF ( DWORK(J+2,J).NE.ZERO ) THEN CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) DWORK(J+1,J) = R DWORK(J+2,J) = ZERO CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, $ DWORK(J+2,J+1), LDDWOR, C, S ) CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) END IF END IF IF ( DWORK(J+1,J).NE.ZERO ) THEN CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) DWORK(J,J) = R DWORK(J+1,J) = ZERO CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), $ LDDWOR, C, S ) CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) END IF 40 CONTINUE C ELSE TRANS = 'T' C C A is an upper Hessenberg matrix, column transformations. C DO 60 J = 1, M2 - 1 MJ = M2 - J IF ( J.LT.M2-1 ) THEN IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, $ S, R ) DWORK(MJ+1,MJ) = R DWORK(MJ+1,MJ-1) = ZERO CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, $ S ) CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) END IF END IF IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, $ R ) DWORK(MJ+1,MJ+1) = R DWORK(MJ+1,MJ) = ZERO CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, $ S ) CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) END IF 60 CONTINUE C END IF ELSE C DO 80 J = 1, M J2 = J*2 J1 = MAX( J - 1, 1 ) ML = MIN( M - J + 2, M ) CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), $ LDDWOR ) CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 DWORK(J2,J2-1) = LAMBD3 DWORK(J2-1,J2) = LAMBD2 DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 80 CONTINUE C IF ( LSAME( RC, 'R' ) ) THEN TRANS = 'N' C C A is a lower Hessenberg matrix, row transformations. C DO 100 J = 1, M2 - 1 MJ = M2 - J IF ( J.LT.M2-1 ) THEN IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, $ S, R ) DWORK(MJ,MJ+1) = R DWORK(MJ-1,MJ+1) = ZERO CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), $ LDDWOR, C, S ) CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) END IF END IF IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, $ R ) DWORK(MJ+1,MJ+1) = R DWORK(MJ,MJ+1) = ZERO CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), $ LDDWOR, C, S) CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) END IF 100 CONTINUE C ELSE TRANS = 'T' C C A is a lower Hessenberg matrix, column transformations. C DO 120 J = 1, M2 - 1 MJ = M2 - J IF ( J.LT.M2-1 ) THEN IF ( DWORK(J,J+2).NE.ZERO ) THEN CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) DWORK(J,J+1) = R DWORK(J,J+2) = ZERO CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), $ 1, C, S ) CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) END IF END IF IF ( DWORK(J,J+1).NE.ZERO ) THEN CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) DWORK(J,J) = R DWORK(J,J+1) = ZERO CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, $ S ) CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) END IF 120 CONTINUE C END IF END IF C CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, $ DWORK(1,M2+1), IWORK, INFO ) IF ( RCOND.LE.TOL ) THEN INFO = 1 ELSE CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) END IF C RETURN C *** Last line of SB04NX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04AD.f0000644000000000000000000000013215012430707016144 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04AD.f0000644000175000017500000016246215012430707017353 0ustar00lilgelilge00000000000000 SUBROUTINE MB04AD( JOB, COMPQ1, COMPQ2, COMPU1, COMPU2, N, Z, LDZ, $ H, LDH, Q1, LDQ1, Q2, LDQ2, U11, LDU11, U12, $ LDU12, U21, LDU21, U22, LDU22, T, LDT, ALPHAR, $ ALPHAI, BETA, IWORK, LIWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute the eigenvalues of a real N-by-N skew-Hamiltonian/ C Hamiltonian pencil aS - bH with C C ( 0 I ) C S = T Z = J Z' J' Z, where J = ( ), (1) C ( -I 0 ) C C via generalized symplectic URV decomposition. That is, orthogonal C matrices Q1 and Q2 and orthogonal symplectic matrices U1 and U2 C are computed such that C C ( T11 T12 ) C Q1' T U1 = Q1' J Z' J' U1 = ( ) = Tout, C ( 0 T22 ) C C ( Z11 Z12 ) C U2' Z Q2 = ( ) = Zout, (2) C ( 0 Z22 ) C C ( H11 H12 ) C Q1' H Q2 = ( ) = Hout, C ( 0 H22 ) C C where T11, T22', Z11, Z22', H11 are upper triangular and H22' is C upper quasi-triangular. The notation M' denotes the transpose of C the matrix M. C Optionally, if COMPQ1 = 'I' or COMPQ1 = 'U', the orthogonal C transformation matrix Q1 will be computed. C Optionally, if COMPQ2 = 'I' or COMPQ2 = 'U', the orthogonal C transformation matrix Q2 will be computed. C Optionally, if COMPU1 = 'I' or COMPU1 = 'U', the orthogonal C symplectic transformation matrix C C ( U11 U12 ) C U1 = ( ) C ( -U12 U11 ) C C will be computed. C Optionally, if COMPU2 = 'I' or COMPU2 = 'U', the orthogonal C symplectic transformation matrix C C ( U21 U22 ) C U2 = ( ) C ( -U22 U21 ) C C will be computed. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; Z, T, and H will not C necessarily be put into the forms in (2); H22' is C upper Hessenberg; C = 'T': put Z, T, and H into the forms in (2), and return C the eigenvalues in ALPHAR, ALPHAI and BETA. C C COMPQ1 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q1, as follows: C = 'N': Q1 is not computed; C = 'I': the array Q1 is initialized internally to the unit C matrix, and the orthogonal matrix Q1 is returned; C = 'U': the array Q1 contains an orthogonal matrix Q01 on C entry, and the product Q01*Q1 is returned, where Q1 C is the product of the orthogonal transformations C that are applied to the pencil aT*Z - bH on the C left to reduce T, Z, and H to the forms in (2), C for COMPQ1 = 'I'. C C COMPQ2 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q2, as follows: C = 'N': Q2 is not computed; C = 'I': the array Q2 is initialized internally to the unit C matrix, and the orthogonal matrix Q2 is returned; C = 'U': the array Q2 contains an orthogonal matrix Q02 on C entry, and the product Q02*Q2 is returned, where Q2 C is the product of the orthogonal transformations C that are applied to the pencil aT*Z - bH on the C right to reduce T, Z, and H to the forms in (2), C for COMPQ2 = 'I'. C C COMPU1 CHARACTER*1 C Specifies whether to compute the orthogonal symplectic C transformation matrix U1, as follows: C = 'N': U1 is not computed; C = 'I': the arrays U11 and U12 are initialized internally C to the unit and zero matrices, respectively, and C the corresponding submatrices of the orthogonal C symplectic matrix U1 are returned; C = 'U': the arrays U11 and U12 contain the corresponding C submatrices of an orthogonal symplectic matrix U01 C on entry, and the updated submatrices U11 and U12 C of the matrix product U01*U1 are returned, where U1 C is the product of the orthogonal symplectic C transformations that are applied to the pencil C aT*Z - bH to reduce T, Z, and H to the forms in C (2), for COMPU1 = 'I'. C C COMPU2 CHARACTER*1 C Specifies whether to compute the orthogonal symplectic C transformation matrix U2, as follows: C = 'N': U2 is not computed; C = 'I': the arrays U21 and U22 are initialized internally C to the unit and zero matrices, respectively, and C the corresponding submatrices of the orthogonal C symplectic matrix U2 are returned; C = 'U': the arrays U21 and U22 contain the corresponding C submatrices of an orthogonal symplectic matrix U02 C on entry, and the updated submatrices U21 and U22 C of the matrix product U02*U2 are returned, where U2 C is the product of the orthogonal symplectic C transformations that are applied to the pencil C aT*Z - bH to reduce T, Z, and H to the forms in C (2), for COMPU2 = 'I'. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) C On entry, the leading N-by-N part of this array must C contain the matrix Z. C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the matrix Zout; otherwise, it contains the C matrix Z obtained just before the application of the C periodic QZ algorithm. C The elements of the (2,1) block, i.e., in the rows N/2+1 C to N and in the columns 1 to N/2 are not set to zero, but C are unchanged on exit. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1, N). C C H (input/output) DOUBLE PRECISION array, dimension (LDH, N) C On entry, the leading N-by-N part of this array must C contain the Hamiltonian matrix H (H22 = -H11', H12 = H12', C H21 = H21'). C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the matrix Hout; otherwise, it contains the C matrix H obtained just before the application of the C periodic QZ algorithm. C C LDH INTEGER C The leading dimension of the array H. LDH >= MAX(1, N). C C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1, N) C On entry, if COMPQ1 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q01, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q01 and the transformation matrix Q1 C used to transform the matrices Z, T and H. C On exit, if COMPQ1 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q1. C If COMPQ1 = 'N', this array is not referenced. C C LDQ1 INTEGER C The leading dimension of the array Q1. C LDQ1 >= 1, if COMPQ1 = 'N'; C LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'. C C Q2 (input/output) DOUBLE PRECISION array, dimension (LDQ2, N) C On entry, if COMPQ2 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q02, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q02 and the transformation matrix Q2 C used to transform the matrices Z, T and H. C On exit, if COMPQ2 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q2. C If COMPQ2 = 'N', this array is not referenced. C C LDQ2 INTEGER C The leading dimension of the array Q2. C LDQ2 >= 1, if COMPQ2 = 'N'; C LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'. C C U11 (input/output) DOUBLE PRECISION array, dimension C (LDU11, N/2) C On entry, if COMPU1 = 'U', then the leading N/2-by-N/2 C part of this array must contain the upper left block of a C given matrix U01, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper left block U11 of C the product of the input matrix U01 and the transformation C matrix U1 used to transform the matrices Z, T, and H. C On exit, if COMPU1 = 'I', then the leading N/2-by-N/2 part C of this array contains the upper left block U11 of the C orthogonal symplectic transformation matrix U1. C If COMPU1 = 'N' this array is not referenced. C C LDU11 INTEGER C The leading dimension of the array U11. C LDU11 >= 1, if COMPU1 = 'N'; C LDU11 >= MAX(1, N/2), if COMPU1 = 'I' or COMPU1 = 'U'. C C U12 (input/output) DOUBLE PRECISION array, dimension C (LDU12, N/2) C On entry, if COMPU1 = 'U', then the leading N/2-by-N/2 C part of this array must contain the upper right block of a C given matrix U01, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper right block U12 C of the product of the input matrix U01 and the C transformation matrix U1 used to transform the matrices C Z, T, and H. C On exit, if COMPU1 = 'I', then the leading N/2-by-N/2 part C of this array contains the upper right block U12 of the C orthogonal symplectic transformation matrix U1. C If COMPU1 = 'N' this array is not referenced. C C LDU12 INTEGER C The leading dimension of the array U12. C LDU12 >= 1, if COMPU1 = 'N'; C LDU12 >= MAX(1, N/2), if COMPU1 = 'I' or COMPU1 = 'U'. C C U21 (input/output) DOUBLE PRECISION array, dimension C (LDU21, N/2) C On entry, if COMPU2 = 'U', then the leading N/2-by-N/2 C part of this array must contain the upper left block of a C given matrix U02, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper left block U21 of C the product of the input matrix U02 and the transformation C matrix U2 used to transform the matrices Z, T, and H. C On exit, if COMPU2 = 'I', then the leading N/2-by-N/2 part C of this array contains the upper left block U21 of the C orthogonal symplectic transformation matrix U2. C If COMPU2 = 'N' this array is not referenced. C C LDU21 INTEGER C The leading dimension of the array U21. C LDU21 >= 1, if COMPU2 = 'N'; C LDU21 >= MAX(1, N/2), if COMPU2 = 'I' or COMPU2 = 'U'. C C U22 (input/output) DOUBLE PRECISION array, dimension C (LDU22, N/2) C On entry, if COMPU2 = 'U', then the leading N/2-by-N/2 C part of this array must contain the upper right block of a C given matrix U02, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper right block U22 C of the product of the input matrix U02 and the C transformation matrix U2 used to transform the matrices C Z, T, and H. C On exit, if COMPU2 = 'I', then the leading N/2-by-N/2 part C of this array contains the upper right block U22 of the C orthogonal symplectic transformation matrix U2. C If COMPU2 = 'N' this array is not referenced. C C LDU22 INTEGER C The leading dimension of the array U22. C LDU22 >= 1, if COMPU2 = 'N'; C LDU22 >= MAX(1, N/2), if COMPU2 = 'I' or COMPU2 = 'U'. C C T (output) DOUBLE PRECISION array, dimension (LDT, N) C If JOB = 'T', the leading N-by-N part of this array C contains the matrix Tout; otherwise, it contains the C matrix T obtained just before the application of the C periodic QZ algorithm. C C LDT INTEGER C The leading dimension of the array T. LDT >= MAX(1, N). C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta defining the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C Due to the skew-Hamiltonian/Hamiltonian structure of the C pencil, for every eigenvalue lambda, -lambda is also an C eigenvalue, and thus it has only to be saved once in C ALPHAR, ALPHAI and BETA. C Specifically, only eigenvalues with imaginary parts C greater than or equal to zero are stored; their conjugate C eigenvalues are not stored. If imaginary parts are zero C (i.e., for real eigenvalues), only positive eigenvalues C are stored. The remaining eigenvalues have opposite signs. C As a consequence, pairs of complex eigenvalues, stored in C consecutive locations, are not complex conjugate. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = 3, IWORK(1) contains the number of C (pairs of) possibly inaccurate eigenvalues, q <= N/2, and C IWORK(2), ..., IWORK(q+1) indicate their indices. C Specifically, a positive value is an index of a real or C purely imaginary eigenvalue, corresponding to a 1-by-1 C block, while the absolute value of a negative entry in C IWORK is an index to the first eigenvalue in a pair of C consecutively stored eigenvalues, corresponding to a C 2-by-2 block. A 2-by-2 block may have two complex, two C real, two purely imaginary, or one real and one purely C imaginary eigenvalue. C For i = q+2, ..., 2*q+1, IWORK(i) contains a pointer to C the starting location in DWORK of the i-th quadruple of C 1-by-1 blocks, if IWORK(i-q) > 0, or 2-by-2 blocks, C if IWORK(i-q) < 0, defining unreliable eigenvalues. C IWORK(2*q+2) contains the number of the 1-by-1 blocks, and C IWORK(2*q+3) contains the number of the 2-by-2 blocks, C corresponding to unreliable eigenvalues. IWORK(2*q+4) C contains the total number t of the 2-by-2 blocks. C If INFO = 0, then q = 0, therefore IWORK(1) = 0. C C LIWORK INTEGER C The dimension of the array IWORK. LIWORK >= N+18. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or INFO = 3, DWORK(1) returns the C optimal LDWORK, and DWORK(2), ..., DWORK(7) contain the C Frobenius norms of the factors of the formal matrix C product used by the algorithm. In addition, DWORK(8), ..., C DWORK(7+6*s) contain the s sextuple values corresponding C to the 1-by-1 blocks. Their eigenvalues are real or purely C imaginary. Such an eigenvalue is obtained from C -i*sqrt((a1/a2/a3)*(a4/a5/a6)), but always taking a C positive sign, where a1, ..., a6 are the corresponding C sextuple values. C Moreover, DWORK(8+6*s), ..., DWORK(7+6*s+24*t) contain the C t groups of sextuple 2-by-2 matrices corresponding to the C 2-by-2 blocks. Their eigenvalue pairs are either complex, C or placed on the real and imaginary axes. Such an C eigenvalue pair is obtained as -1i*sqrt(ev), but taking C positive imaginary parts, where ev are the eigenvalues of C the product A1*inv(A2)*inv(A3)*A4*inv(A5)*inv(A6), where C A1, ..., A6 define the corresponding 2-by-2 matrix C sextuple. C On exit, if INFO = -31, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C If JOB = 'E' and COMPQ1 = 'N' and COMPQ2 = 'N' and C COMPU1 = 'N' and COMPU2 = 'N', then C LDWORK >= 3/2*N**2 + MAX(6*N,54); C else, LDWORK >= 3*N**2 + MAX(6*N,54). C For good performance LDWORK should generally be larger. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C XERBLA. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: the periodic QZ algorithm was not able to reveal C information about the eigenvalues from the 2-by-2 C blocks in the SLICOT Library routine MB03BD; C = 2: the periodic QZ algorithm did not converge in the C SLICOT Library routine MB03BD; C = 3: some eigenvalues might be inaccurate, and details can C be found in IWORK and DWORK. This is a warning. C C METHOD C C The algorithm uses Givens rotations and Householder reflections to C annihilate elements in T, Z, and H such that T11, T22', Z11, Z22', C and H11 are upper triangular and H22' is upper Hessenberg. Finally C the periodic QZ algorithm is applied to transform H22' to upper C quasi-triangular form while T11, T22', Z11, Z22', and H11 stay in C upper triangular form. C See also page 17 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, December 03, 2008. C V. Sima, Dec. 2009 (SLICOT version of the routine DGEURV). C C REVISIONS C C V. Sima, Feb. 2010, Nov. 2010, Aug. 2011, Nov. 2011, July 2012, C Oct. 2012, July 2013, Aug. 2014, Mar. 2020, Apr. 2020, May 2020. C M. Voigt, Jan. 2012. C C KEYWORDS C C generalized symplectic URV decomposition, periodic QZ algorithm, C upper (quasi-)triangular matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, SEVEN PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, $ SEVEN = 7.0D+0 ) C C .. Scalar Arguments .. CHARACTER COMPQ1, COMPQ2, COMPU1, COMPU2, JOB INTEGER INFO, LDH, LDQ1, LDQ2, LDT, LDU11, LDU12, $ LDU21, LDU22, LDWORK, LDZ, LIWORK, N C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), $ DWORK( * ), H( LDH, * ), Q1( LDQ1, * ), $ Q2( LDQ2, * ), T( LDT, * ), U11( LDU11, * ), $ U12( LDU12, * ), U21( LDU21, * ), $ U22( LDU22, * ), Z( LDZ, * ) C C .. Local Scalars .. LOGICAL LCMPQ1, LCMPQ2, LCMPU1, LCMPU2, LINIQ1, LINIQ2, $ LINIU1, LINIU2, LQUERY, LTRI, LUPDQ1, LUPDQ2, $ LUPDU1, LUPDU2, UNREL CHARACTER*16 CMPQ, CMPSC INTEGER EMAX, EMIN, I, I11, I22, I2X2, IMAT, IQ, ITAU, $ IW, IWARN, IWRK, J, K, L, M, MINDW, MM, NBETA0, $ NINF, OPTDW, P DOUBLE PRECISION BASE, CO, SI, TEMP, TMP1, TMP2 COMPLEX*16 EIG C C .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 6 ) C C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLANTR, DLAPY2 EXTERNAL DLAMCH, DLAPY2, IDAMAX, LSAME C C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEQRF, DGERQF, DLACPY, DLARTG, $ DLASET, DORMQR, DORMRQ, DROT, DSCAL, DSWAP, $ MA02AD, MB03BD, XERBLA C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MOD, SQRT C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 MM = M*M C LTRI = LSAME( JOB, 'T' ) LINIQ1 = LSAME( COMPQ1, 'I' ) LUPDQ1 = LSAME( COMPQ1, 'U' ) LINIQ2 = LSAME( COMPQ2, 'I' ) LUPDQ2 = LSAME( COMPQ2, 'U' ) LINIU1 = LSAME( COMPU1, 'I' ) LUPDU1 = LSAME( COMPU1, 'U' ) LINIU2 = LSAME( COMPU2, 'I' ) LUPDU2 = LSAME( COMPU2, 'U' ) LCMPQ1 = LINIQ1 .OR. LUPDQ1 LCMPQ2 = LINIQ2 .OR. LUPDQ2 LCMPU1 = LINIU1 .OR. LUPDU1 LCMPU2 = LINIU2 .OR. LUPDU2 IF( N.EQ.0 ) THEN MINDW = 7 ELSE IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 .OR. LCMPU1 .OR. LCMPU2 ) $ THEN MINDW = 12*MM + MAX( 6*N, 54 ) ELSE MINDW = 6*MM + MAX( 6*N, 54 ) END IF LQUERY = LDWORK.EQ.-1 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ1, 'N' ) .OR. LCMPQ1 ) ) THEN INFO = -2 ELSE IF( .NOT.( LSAME( COMPQ2, 'N' ) .OR. LCMPQ2 ) ) THEN INFO = -3 ELSE IF( .NOT.( LSAME( COMPU1, 'N' ) .OR. LCMPU1 ) ) THEN INFO = -4 ELSE IF( .NOT.( LSAME( COMPU2, 'N' ) .OR. LCMPU2 ) ) THEN INFO = -5 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -6 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDQ1.LT.1 .OR. ( LCMPQ1 .AND. LDQ1.LT.N ) ) THEN INFO = -12 ELSE IF( LDQ2.LT.1 .OR. ( LCMPQ2 .AND. LDQ2.LT.N ) ) THEN INFO = -14 ELSE IF( LDU11.LT.1 .OR. ( LCMPU1 .AND. LDU11.LT.M ) ) THEN INFO = -16 ELSE IF( LDU12.LT.1 .OR. ( LCMPU1 .AND. LDU12.LT.M ) ) THEN INFO = -18 ELSE IF( LDU21.LT.1 .OR. ( LCMPU2 .AND. LDU21.LT.M ) ) THEN INFO = -20 ELSE IF( LDU22.LT.1 .OR. ( LCMPU2 .AND. LDU22.LT.M ) ) THEN INFO = -22 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -24 ELSE IF( LIWORK.LT.N+18 ) THEN INFO = -29 ELSE IF( .NOT.LQUERY .AND. LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -31 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04AD', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN C C Compute optimal workspace. C IF( LQUERY ) THEN CALL DORMQR( 'Left', 'Transpose', N, N, M, T, LDT, DWORK, T, $ LDT, DWORK, -1, INFO ) CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z, LDZ, DWORK, $ H, LDH, DUM, -1, INFO ) I = INT( DUM( 1 ) ) OPTDW = MAX( INT( DWORK( 1 ) ), I ) CALL DGERQF( M, M, DWORK, M, DWORK, DWORK, -1, INFO ) CALL DORMRQ( 'Left', 'No Transpose', M, N, M, DWORK, M, $ DWORK, H, LDH, DUM, -1, INFO ) OPTDW = M + MAX( OPTDW, MM + MAX( INT( DWORK( 1 ) ), $ INT( DUM( 1 ) ) ) ) IF( LCMPQ1 ) $ OPTDW = MAX( OPTDW, M + MM + I ) CALL DGEQRF( N, M, DWORK, N, DWORK, DWORK, -1, INFO ) CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N, $ DWORK, H, LDH, DUM, -1, INFO ) OPTDW = MAX( OPTDW, M + M*N + MAX( INT( DWORK( 1 ) ), $ INT( DUM( 1 ) ) ) ) IF( LCMPQ2 ) THEN CALL DORMQR( 'Left', 'No Transpose', N, N, M, DWORK, N, $ DWORK, Q2, LDQ2, DWORK, -1, INFO ) OPTDW = MAX( OPTDW, M + M*N + INT( DWORK( 1 ) ) ) END IF DWORK( 1 ) = MAX( OPTDW, MINDW ) RETURN END IF END IF C C Quick return if possible. C DUM( 1 ) = ZERO C IF( N.EQ.0 ) THEN IWORK( 1 ) = 0 DWORK( 1 ) = SEVEN CALL DCOPY( 6, DUM, 0, DWORK( 2 ), 1 ) RETURN END IF C C Determine machine constants. C BASE = DLAMCH( 'Base' ) EMIN = INT( DLAMCH( 'Minimum Exponent' ) ) EMAX = INT( DLAMCH( 'Largest Exponent' ) ) C C Find half of the number of infinite eigenvalues if Z is diagonal. C Otherwise, find a lower bound of this number. C NINF = 0 IF( N.EQ.1 ) THEN IF( Z( 1, 1 ).EQ.ZERO ) $ NINF = 1 ELSE IF( DLANTR( 'Max', 'Lower', 'No-diag', N-1, N-1, Z( 2, 1 ), $ LDZ, DWORK ).EQ.ZERO .AND. $ DLANTR( 'Max', 'Upper', 'No-diag', N-1, N-1, Z( 1, 2 ), $ LDZ, DWORK ).EQ.ZERO ) THEN DO 10 J = 1, M IF( Z( J, J ).EQ.ZERO .OR. Z( J+M, J+M ).EQ.ZERO ) $ NINF = NINF + 1 10 CONTINUE ELSE DO 20 J = 1, M I = IDAMAX( N, Z( 1, J ), 1 ) K = IDAMAX( N, Z( 1, M+J ), 1 ) L = IDAMAX( N, Z( J, 1 ), LDZ ) P = IDAMAX( N, Z( M+J, 1 ), LDZ ) IF( Z( I, J ).EQ.ZERO .OR. Z( K, M+J ).EQ.ZERO .OR. $ Z( J, L ).EQ.ZERO .OR. Z( M+J, P ).EQ.ZERO ) $ NINF = NINF + 1 20 CONTINUE END IF END IF C C Initializations. C C Set T = J Z' J'. C CALL MA02AD( 'Full', M, M, Z( M+1, M+1 ), LDZ, T, LDT ) CALL MA02AD( 'Full', M, M, Z( 1, M+1 ), LDZ, T( 1, M+1 ), LDT ) C DO 30 I = 1, M CALL DSCAL( M, -ONE, T( 1, M+I ), 1 ) 30 CONTINUE C CALL MA02AD( 'Full', M, M, Z( M+1, 1 ), LDZ, T( M+1, 1 ), LDT ) C DO 40 I = 1, M CALL DSCAL( M, -ONE, T( M+1, I ), 1 ) 40 CONTINUE C CALL MA02AD( 'Full', M, M, Z, LDZ, T( M+1, M+1 ), LDT ) C IF( LINIQ1 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 ) C IF( LINIQ2 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q2, LDQ2 ) C IF( LINIU1 ) THEN CALL DLASET( 'Full', M, M, ZERO, ONE, U11, LDU11 ) CALL DLASET( 'Full', M, M, ZERO, ZERO, U12, LDU12 ) END IF C IF( LINIU2 ) THEN CALL DLASET( 'Full', M, M, ZERO, ONE, U21, LDU21 ) CALL DLASET( 'Full', M, M, ZERO, ZERO, U22, LDU22 ) END IF C C STEP 1: Block triangularize T and 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 ITAU = 1 IWRK = ITAU + M C C ( T11 ) C Perform a QR decomposition, ( ) = Q1*R1. C ( T21 ) C C Workspace: need IWRK + M - 1; C prefer IWRK + M*NB - 1. C CALL DGEQRF( N, M, T, LDT, DWORK( ITAU ), DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) C C ( T12 ) C Update ( ). C ( T22 ) C C Workspace: need IWRK + M - 1; C prefer IWRK + M*NB - 1. C CALL DORMQR( 'Left', 'Transpose', N, M, M, T, LDT, DWORK( ITAU ), $ T( 1, M+1 ), LDT, DWORK( IWRK ), LDWORK-IWRK+1, INFO $ ) C C Update H. C C Workspace: need IWRK + N - 1; C prefer IWRK + N*NB - 1. C CALL DORMQR( 'Left', 'Transpose', N, N, M, T, LDT, DWORK( ITAU ), $ H, LDH, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DORMQR( 'Right', 'No Transpose', N, N, M, T, LDT, $ DWORK( ITAU ), Q1, LDQ1, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) END IF C C Set the strictly lower triangular part of [ T11; T21 ] to zero. C CALL DLASET( 'Lower', N-1, M, ZERO, ZERO, T( 2, 1 ), LDT ) C C Perform an RQ decomposition, T22 = R2*Q2. C C Workspace: need IWRK + M - 1; C prefer IWRK + M*NB - 1. C ITAU = MM + 1 IWRK = ITAU + M CALL MA02AD( 'Full', M, M, T( M+1, M+1 ), LDT, DWORK, M ) CALL DGERQF( M, M, DWORK, M, DWORK( ITAU ), DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) CALL MA02AD( 'Upper', M, M, DWORK, M, T( M+1, M+1 ), LDT ) C C Set the strictly upper triangular part of T22 to zero. C IF( M.GT.1 ) $ CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, T( M+1, M+2 ), LDT $ ) C C Update H. C C Workspace: need IWRK + N - 1; C prefer IWRK + N*NB - 1. C CALL DORMRQ( 'Left', 'No Transpose', M, N, M, DWORK, M, $ DWORK( ITAU ), H( M+1, 1 ), LDH, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DORMRQ( 'Right', 'Transpose', N, M, M, DWORK, M, $ DWORK( ITAU ), Q1( 1, M+1 ), LDQ1, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) END IF C C Perform a QR decomposition, ( Z21 Z22 )' = Q3*R3. C C Workspace: need IWRK + M - 1; C prefer IWRK + M*NB - 1. C ITAU = M*N + 1 IWRK = ITAU + M CALL MA02AD( 'Full', M, N, Z( M+1, 1 ), LDZ, DWORK, N ) CALL DGEQRF( N, M, DWORK, N, DWORK( ITAU ), DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Update ( Z11 Z12 ). C CALL DORMQR( 'Right', 'No Transpose', M, N, M, DWORK, N, $ DWORK( ITAU ), Z, LDZ, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) CALL MA02AD( 'Upper', M, M, DWORK, N, Z( M+1, M+1 ), LDZ ) C C Set the strictly upper triangular part of Z22 to zero. C IF( M.GT.1 ) $ CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, Z( M+1, M+2 ), LDZ $ ) C C Update H. C CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N, $ DWORK( ITAU ), H, LDH, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C DO 50 I = 1, M CALL DSWAP( N, H( 1, I ), 1, H( 1, M+I ), 1 ) 50 CONTINUE C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N, $ DWORK( ITAU ), Q2, LDQ2, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C DO 60 I = 1, M CALL DSWAP( N, Q2( 1, I ), 1, Q2( 1, M+I ), 1 ) 60 CONTINUE END IF C C Perform an RQ decomposition Z12 = R4*Q4. C ITAU = 1 IWRK = ITAU + M CALL DGERQF( M, M, Z( 1, M+1 ), LDZ, DWORK( ITAU ), DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) C C Update H. C CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z( 1, M+1 ), LDZ, $ DWORK( ITAU ), H, LDH, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z( 1, M+1 ), LDZ, $ DWORK( ITAU ), Q2, LDQ2, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) END IF C C Exchange Z11 and Z12 and set the strictly lower triangular part C of Z11 to zero. C DO 70 I = 1, M - 1 CALL DSWAP( M, Z( 1, I ), 1, Z( 1, M+I ), 1 ) CALL DCOPY( M-I, DUM, 0, Z( I+1, I ), 1 ) 70 CONTINUE C CALL DSWAP( M, Z( 1, M ), 1, Z( 1, N ), 1 ) C C STEP 2: Eliminations in H. C DO 120 K = 1, M C C I. Annihilate H(m+k:n-1,k). C DO 80 J = K, M-1 C C Determine a Givens rotation to annihilate H(m+j,k) from the C left. C CALL DLARTG( H( M+J+1, K ), H( M+J, K ), CO, SI, TMP1 ) C C Update H. C H( M+J+1, K ) = TMP1 H( M+J, K ) = ZERO CALL DROT( N-K, H( M+J+1, K+1 ), LDH, H( M+J, K+1 ), LDH, $ CO, SI ) C C Update T. C CALL DROT( J+1, T( M+J+1, M+1 ), LDT, T( M+J, M+1 ), LDT, $ CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M+J+1 ), 1, Q1( 1, M+J ), 1, CO, SI $ ) END IF C C Determine a Givens rotation to annihilate T(m+j,m+j+1) from C the right. C CALL DLARTG( T( M+J, M+J ), T( M+J, M+J+1 ), CO, SI, TMP1 ) C C Update T. C CALL DROT( M, T( 1, M+J ), 1, T( 1, M+J+1 ), 1, CO , SI ) T( M+J, M+J ) = TMP1 T( M+J, M+J+1 ) = ZERO CALL DROT( M-J, T( M+J+1, M+J ), 1, T( M+J+1, M+J+1 ), 1, $ CO, SI ) CALL DROT( J+1, T( 1, J ), 1, T( 1, J+1 ), 1, CO, SI ) C IF( LCMPU1 ) THEN C C Update U11 and U12. C CALL DROT( M, U11( 1, J ), 1, U11( 1, J+1 ), 1, CO, SI ) CALL DROT( M, U12( 1, J ), 1, U12( 1, J+1 ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate T(j+1,j) from the C left. C CALL DLARTG( T( J, J ), T( J+1, J ), CO, SI, TMP1 ) C C Update T. C T( J, J ) = TMP1 T( J+1, J ) = ZERO CALL DROT( N-J, T( J, J+1 ), LDT, T( J+1, J+1 ), LDT, CO, SI $ ) C C Update H. C CALL DROT( N-K+1, H( J, K ), LDH, H( J+1, K ), LDH, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, J ), 1, Q1( 1, J+1 ), 1, CO, SI ) END IF 80 CONTINUE C C II. Annihilate H(n,k). C C Determine a Givens rotation to annihilate H(n,k) form the left. C CALL DLARTG( H( M, K ), H( N, K ), CO, SI, TMP1 ) C C Update H. C H( M, K ) = TMP1 H( N, K ) = ZERO CALL DROT( N-K, H( M, K+1 ), LDH, H( N, K+1 ), LDH, CO, SI ) C C Update T. C CALL DROT( M, T( M, M+1 ), LDT, T( N, M+1 ), LDT, CO, SI ) TMP1 = -SI*T( M, M ) T( M, M ) = CO*T( M, M ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate T(n,m) from the C right. C CALL DLARTG( T( N, N ), TMP1, CO, SI, TMP2 ) C C Update T. C CALL DROT( M, T( 1, N ), 1, T( 1, M ), 1, CO, SI ) T( N, N ) = TMP2 C IF( LCMPU1 ) THEN C C Update U11 and U12. C CALL DROT( M, U12( 1, M ), 1, U11( 1, M ), 1, CO, SI ) END IF C C III. Annihilate H(k+1:m,k). C DO 90 J = M, K+1, -1 C C Determine a Givens rotation to annihilate H(j,k) from the C left. C CALL DLARTG( H( J-1, K ), H( J, K ), CO, SI, TMP1 ) C C Update H. C H( J-1, K ) = TMP1 H( J, K ) = ZERO CALL DROT( N-K, H( J-1, K+1 ), LDH, H( J, K+1 ), LDH, CO, SI $ ) C C Update T. C CALL DROT( N-J+2, T( J-1, J-1 ), LDT, T( J, J-1 ), LDT, CO, $ SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, J-1 ), 1, Q1( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate T(j,j-1) from the C right. C CALL DLARTG( T( J, J ), T( J, J-1 ), CO, SI, TMP1 ) C C Update T. C CALL DROT( M, T( 1, M+J ), 1, T( 1, M+J-1 ), 1, CO, SI ) CALL DROT( M-J+2, T( M+J-1, M+J ), 1, T( M+J-1, M+J-1 ), 1, $ CO, SI ) T( J, J ) = TMP1 T( J, J-1 ) = ZERO CALL DROT( J-1, T( 1, J ), 1, T( 1, J-1 ), 1, CO, SI ) C IF( LCMPU1 ) THEN C C Update U11 and U12. C CALL DROT( M, U11( 1, J ), 1, U11( 1, J-1 ), 1, CO, SI ) CALL DROT( M, U12( 1, J ), 1, U12( 1, J-1 ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate T(m+j-1,m-j) from C the left. C CALL DLARTG( T( M+J, M+J ), T( M+J-1, M+J ), CO, SI, TMP1 ) C C Update T. C T( M+J, M+J ) = TMP1 T( M+J-1, M+J ) = ZERO CALL DROT( J-1, T( M+J, M+1 ), LDT, T( M+J-1, M+1 ), LDT, $ CO, SI ) C C Update H. C CALL DROT( N-K+1, H( M+J, K ), LDH, H( M+J-1, K ), LDH, CO, $ SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M+J ), 1, Q1( 1, M+J-1 ), 1, CO, SI $ ) END IF 90 CONTINUE C C IV. Annihilate H(m+k,k+1:m-1). C DO 100 J = K+1, M-1 C C Determine a Givens rotation to annihilate H(m+k,j) from the C right. C CALL DLARTG( H( M+K, J+1 ), H( M+K, J ), CO, SI, TMP1 ) C C Update H. C CALL DROT( M, H( 1, J+1 ), 1, H( 1, J ), 1, CO, SI ) H( M+K, J+1 ) = TMP1 H( M+K, J ) = ZERO CALL DROT( M-K, H( M+K+1, J+1 ), 1, H( M+K+1, J ), 1, CO, SI $ ) C C Update Z. C CALL DROT( J+1, Z( 1, J+1 ), 1, Z( 1, J ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, J+1 ), 1, Q2( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(j+1,j) from the C left. C CALL DLARTG( Z( J, J ), Z( J+1, J ), CO, SI, TMP1 ) C C Update Z. C Z( J, J ) = TMP1 Z( J+1, J ) = ZERO CALL DROT( N-J, Z( J, J+1 ), LDZ, Z( J+1, J+1 ), LDZ, CO, SI $ ) CALL DROT( J+1, Z( M+J, M+1 ), LDZ, Z( M+J+1, M+1 ), LDZ, $ CO, SI ) C IF( LCMPU2 ) THEN C C Update U21 and U22. C CALL DROT( M, U21( 1, J ), 1, U21( 1, J+1 ), 1, CO, SI ) CALL DROT( M, U22( 1, J ), 1, U22( 1, J+1 ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(m+j,m+j+1) from C the right. C CALL DLARTG( Z( M+J, M+J ), Z( M+J, M+J+1 ), CO, SI, TMP1 ) C C Update Z. C Z( M+J, M+J ) = TMP1 Z( M+J, M+J+1 ) = ZERO CALL DROT( M, Z( 1, M+J ), 1, Z( 1, M+J+1 ), 1, CO, SI ) CALL DROT( M-J, Z( M+J+1, M+J ), 1, Z( M+J+1, M+J+1 ), 1, $ CO, SI ) C C Update H. C CALL DROT( M, H( 1, M+J ), 1, H( 1, M+J+1 ), 1, CO, SI ) CALL DROT( M-K+1, H( M+K, M+J ), 1, H( M+K, M+J+1 ), 1, CO, $ SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, M+J ), 1, Q2( 1, M+J+1 ), 1, CO, SI $ ) END IF 100 CONTINUE C C V. Annihilate H(m+k,m). C IF( K.LT.M ) THEN C C Determine a Givens rotation to annihilate H(m+k,m) from the C right. C CALL DLARTG( H( M+K, N ), H( M+K, M ), CO, SI, TMP1 ) C C Update H. C H( M+K, N ) = TMP1 H( M+K, M ) = ZERO CALL DROT( M, H( 1, N ), 1, H( 1, M ), 1, CO, SI ) CALL DROT( M-K, H( M+K+1, N ), 1, H( M+K+1, M ), 1, CO, SI ) C C Update Z. C CALL DROT( M, Z( 1, N ), 1, Z( 1, M ), 1, CO, SI ) TMP1 = -SI*Z( N, N ) Z( N, N ) = CO*Z( N, N ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, N ), 1, Q2( 1, M ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(n,m) from the C left. C CALL DLARTG( Z( M, M ), TMP1, CO, SI, TMP2 ) C C Update Z. C CALL DROT( M, Z( M, M+1 ), LDZ, Z( N, M+1 ), LDZ, CO, SI ) Z( M, M ) = TMP2 C IF( LCMPU2 ) THEN C C Update U2. C CALL DROT( M, U21( 1, M ), 1, U22( 1, M ), 1, CO, SI ) END IF ELSE C C Determine a Givens rotation to annihilate H(n,m) from the C left. C CALL DLARTG( H( M, M ), H( N, M ), CO, SI, TMP1 ) C C Update H. C H( M, M ) = TMP1 H( N, M ) = ZERO CALL DROT( M, H( M, M+1 ), LDH, H( N, M+1 ), LDH, CO, SI ) C C Update T. C CALL DROT( M, T( M, M+1 ), LDT, T( N, M+1 ), LDT, CO, SI ) T( M, M ) = CO*T( M, M ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate T( N, M ) from the C right. C CALL DLARTG( T( N, N ), -SI*T( M, M ), CO, SI, TMP2 ) C C Update T. C CALL DROT( M, T( 1, N ), 1, T( 1, M ), 1, CO, SI ) T( N, N ) = TMP2 C IF( LCMPU1 ) THEN C C Update U1. C CALL DROT( M, U12( 1, M ), 1, U11( 1, M ), 1, CO, SI ) END IF END IF C C VI. Annihilate H(m+k,m+k+2:n). C DO 110 J = M, K+2, -1 C C Determine a Givens rotation to annihilate H(m+k,m+j) from C the right. C CALL DLARTG( H( M+K, M+J-1 ), H( M+K, M+J ), CO, SI, TMP1 ) C C Update H. C CALL DROT( M, H( 1, M+J-1 ), 1, H( 1, M+J ), 1, CO, SI ) H( M+K, M+J-1 ) = TMP1 H( M+K, M+J ) = ZERO CALL DROT( M-K, H( M+K+1, M+J-1 ), 1, H( M+K+1, M+J ), 1, $ CO, SI ) C C Update Z. C CALL DROT( M, Z( 1, M+J-1 ), 1, Z( 1, M+J ), 1, CO, SI ) CALL DROT( M-J+2, Z( M+J-1, M+J-1 ), 1, Z( M+J-1, M+J ), 1, $ CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, M+J-1 ), 1, Q2( 1, M+J ), 1, CO, SI $ ) END IF C C Determine a Givens rotation to annihilate Z(m+j-1,m+j) from C the left. C CALL DLARTG( Z( M+J, M+J ), Z( M+J-1, M+J ), CO, SI, TMP1 ) C C Update Z. C Z( M+J, M+J ) = TMP1 Z( M+J-1, M+J ) = ZERO CALL DROT( J-1, Z( M+J, M+1 ), LDZ, Z( M+J-1, M+1 ), LDZ, $ CO, SI ) CALL DROT( N-J+2, Z( J, J-1 ), LDZ, Z( J-1, J-1 ), LDZ, CO, $ SI ) C IF( LCMPU2 ) THEN C C Update U2. C CALL DROT( M, U21( 1, J ), 1, U21( 1, J-1 ), 1, CO, SI ) CALL DROT( M, U22( 1, J ), 1, U22( 1, J-1 ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(j,j-1) from the C right. C CALL DLARTG( Z( J, J ), Z( J, J-1 ), CO, SI, TMP1 ) C C Update Z. C Z( J, J ) = TMP1 Z( J, J-1 ) = ZERO CALL DROT( J-1, Z( 1, J ), 1, Z( 1, J-1 ), 1, CO, SI ) C C Update H. C CALL DROT( M, H( 1, J ), 1, H( 1, J-1 ), 1, CO, SI ) CALL DROT( M-K+1, H( M+K, J ), 1, H( M+K, J-1 ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, J ), 1, Q2( 1, J-1 ), 1, CO, SI ) END IF 110 CONTINUE C 120 CONTINUE C C Now T, Z, H are in block forms (1) and H22' is upper Hessenberg. C C STEP 3: Apply periodic QZ algorithm to the generalized matrix C C -1 -1 -1 -1 C product H22 T22 T11 H11 Z11 Z22 to transform H22' C to upper quasi-triangular form while T11, T22', Z11, Z22', C and H11 stay in upper triangular form. C C Determine the mode of computations. C IQ = 1 IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 .OR. LCMPU1 .OR. LCMPU2 ) THEN CMPQ = 'Initialize' IMAT = 6*MM + 1 IWRK = 12*MM + 1 ELSE CMPQ = 'No Computation' IMAT = 1 IWRK = 6*MM + 1 END IF C IF( LTRI ) THEN CMPSC = 'Schur Form' ELSE CMPSC = 'Eigenvalues Only' END IF C C Save matrices in structure that is required by MB03BD. C CALL MA02AD( 'Lower', M, M, H( M+1, M+1 ), LDH, DWORK( IMAT ), M ) CALL DCOPY( M-1, H( M+1, M+2 ), LDH+1, DWORK( IMAT+1 ), M+1 ) CALL DLASET( 'Lower', M-2, M-2, ZERO, ZERO, DWORK( IMAT+2 ), M ) CALL MA02AD( 'Lower', M, M, T( M+1, M+1 ), LDT, DWORK( IMAT+MM ), $ M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+MM+1 ), $ M ) CALL DLACPY( 'Upper', M, M, T, LDT, DWORK( IMAT+2*MM ), M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+2*MM+1 ), $ M ) CALL DLACPY( 'Upper', M, M, H, LDH, DWORK( IMAT+3*MM ), M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+3*MM+1 ), $ M ) CALL DLACPY( 'Upper', M, M, Z, LDZ, DWORK( IMAT+4*MM ), M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+4*MM+1 ), $ M ) CALL MA02AD( 'Lower', M, M, Z( M+1, M+1 ), LDZ, $ DWORK( IMAT+5*MM ), M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, DWORK( IMAT+5*MM+1 ), $ M ) C IWORK( 1 ) = 1 IWORK( 2 ) = -1 IWORK( 3 ) = -1 IWORK( 4 ) = 1 IWORK( 5 ) = -1 IWORK( 6 ) = -1 C C Apply periodic QZ algorithm. C Workspace: need IWRK + MAX( N, 48 ) + 5. C Integer workspace: need N + 18. C CALL MB03BD( CMPSC, 'Careful', CMPQ, IDUM, 6, M, 1, 1, M, IWORK, $ DWORK( IMAT ), M, M, DWORK( IQ ), M, M, ALPHAR, $ ALPHAI, BETA, IWORK( 7 ), IWORK( M+7 ), $ LIWORK-( M+6 ), DWORK( IWRK ), LDWORK-IWRK+1, IWARN, $ INFO ) IF( IWARN.GT.0 .AND. IWARN.LT.M ) THEN INFO = 1 RETURN ELSE IF( IWARN.EQ.M+1 ) THEN INFO = 3 ELSE IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF NBETA0 = 0 I11 = 0 I22 = 0 I2X2 = 0 C C Compute the "non-negative" eigenvalues of the pencil aTZ - bH. C These are the eigenvalues with positive real parts or with C non-negative imaginary parts, when real parts are zero. C Also, count the number of 2-by-2 diagonal blocks, I2X2, and the C number of 1-by-1 and 2-by-2 blocks with unreliable eigenvalues, C I11 and I22, respectively. C I = 1 C WHILE( I.LE.M ) DO 130 CONTINUE IF( I.LE.M ) THEN IF( NINF.GT.0 ) THEN IF( BETA( I ).EQ.ZERO ) $ NBETA0 = NBETA0 + 1 END IF IF( IWORK( I+6 ).GE.2*EMIN .AND. IWORK( I+6 ).LE.2*EMAX ) THEN C C B = SQRT(BASE**IWORK(i+6)) is between underflow and overflow C threshold, BETA(i) is divided by B. C BETA( I ) = BETA( I )/BASE**( HALF*IWORK( I+6 ) ) IF( BETA( I ).NE.ZERO ) THEN IF( IWORK( M+I+7 ).LT.0 ) THEN I22 = I22 + 1 ELSE IF( IWORK( M+I+7 ).GT.0 ) THEN I11 = I11 + 1 END IF EIG = SQRT( DCMPLX( ALPHAR( I ), ALPHAI( I ) ) ) ALPHAR( I ) = DIMAG( EIG ) ALPHAI( I ) = DBLE( EIG ) IF( ALPHAR( I ).LT.ZERO ) $ ALPHAR( I ) = -ALPHAR( I ) IF( ALPHAI( I ).LT.ZERO ) $ ALPHAI( I ) = -ALPHAI( I ) IF( ALPHAR( I ).NE.ZERO .AND. ALPHAI( I ).NE.ZERO ) THEN ALPHAR( I+1 ) = -ALPHAR( I ) ALPHAI( I+1 ) = ALPHAI( I ) BETA( I+1 ) = BETA( I ) I2X2 = I2X2 + 1 I = I + 1 END IF END IF ELSE IF( IWORK( I+6 ).LT.2*EMIN ) THEN C C Set to zero the numerator part of the eigenvalue. C ALPHAR( I ) = ZERO ALPHAI( I ) = ZERO I11 = I11 + 1 ELSE C C Set an infinite eigenvalue. C IF( NINF.GT.0 ) $ NBETA0 = NBETA0 + 1 BETA( I ) = ZERO I11 = I11 + 1 END IF I = I + 1 GO TO 130 END IF C END WHILE 130 C IWORK( 1 ) = I11 + I22 C C Set to infinity the largest eigenvalues, if necessary. C L = 0 IF( NINF.GT.0 ) THEN DO 150 J = 1, NINF - NBETA0 TMP1 = ZERO TMP2 = ONE P = 1 DO 140 I = 1, M IF( BETA( I ).GT.ZERO ) THEN TEMP = DLAPY2( ALPHAR( I ), ALPHAI( I ) ) IF( TEMP.GT.TMP1 .AND. TMP2.GE.BETA( I ) ) THEN TMP1 = TEMP TMP2 = BETA( I ) P = I END IF END IF 140 CONTINUE L = L + 1 BETA( P ) = ZERO 150 CONTINUE C IF( L.EQ.IWORK( 1 ) ) THEN C C All unreliable eigenvalues found have been set to infinity. C INFO = 0 I11 = 0 I22 = 0 IWORK( 1 ) = 0 END IF END IF C C Save the norms of the factors. C CALL DCOPY( 6, DWORK( IWRK+1 ), 1, DUM, 1 ) C C Save the sextuples of the 1-by-1 and 2-by-2 diagonal blocks. C All 1-by-1 diagonal blocks come first. C Save also information about blocks with possible loss of accuracy. C C Workspace: IWRK+w-1, where w = 6 if M = 1, or w = 6*N, otherwise. C K = IWRK IW = IWORK( 1 ) I = 1 J = 1 L = 6*( M - 2*I2X2 ) + K C C WHILE( I.LE.N ) DO UNREL = .FALSE. 160 CONTINUE IF( I.LE.M ) THEN IF( J.LE.IW ) $ UNREL = I.EQ.ABS( IWORK( M+I+7 ) ) IF( ALPHAR( I ).NE.ZERO .AND. BETA( I ).NE.ZERO .AND. $ ALPHAI( I ).NE.ZERO ) THEN IF( UNREL ) THEN J = J + 1 IWORK( J ) = IWORK( M+I+7 ) IWORK( IW+J ) = L - IWRK + 1 UNREL = .FALSE. END IF CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1) ), M, $ DWORK( L ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+MM ), M, $ DWORK( L+4 ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+2*MM ), $ M, DWORK( L+8 ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+3*MM ), $ M, DWORK( L+12 ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+4*MM ), $ M, DWORK( L+16 ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+5*MM ), $ M, DWORK( L+20 ), 2 ) L = L + 24 I = I + 2 ELSE IF ( UNREL ) THEN J = J + 1 IWORK( J ) = I IWORK( IW+J ) = K - IWRK + 1 UNREL = .FALSE. END IF CALL DCOPY( 6, DWORK( IMAT+(M+1)*(I-1) ), MM, DWORK( K ), $ 1 ) K = K + 6 I = I + 1 END IF GO TO 160 END IF C END WHILE 160 C IWORK( 2*IW+2 ) = I11 IWORK( 2*IW+3 ) = I22 IWORK( 2*IW+4 ) = I2X2 C IF( LTRI ) THEN C C Update H. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+3*MM ), M, H, LDH ) CALL MA02AD( 'Full', M, M, DWORK( IMAT ), M, H( M+1, M+1 ), $ LDH ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ+3*MM ), M, H( 1, M+1 ), LDH, ZERO, $ DWORK( IMAT ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IMAT ), M, DWORK, M, ZERO, H( 1, M+1 ), $ LDH ) C C Update T. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+2*MM ), M, T, LDT ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ+3*MM ), M, T( 1, M+1 ), LDT, ZERO, $ DWORK( IMAT ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IMAT ), M, DWORK( IQ+2*MM ), M, ZERO, $ T( 1, M+1 ), LDT ) CALL MA02AD( 'Upper', M, M, DWORK( IMAT+MM ), M, T( M+1, M+1 ), $ LDT ) C C Update Z. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+4*MM ), M, Z, LDZ ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ+5*MM ), M, Z( 1, M+1 ), LDZ, ZERO, $ DWORK( IMAT ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IMAT ), M, DWORK, M, ZERO, Z( 1, M+1 ), $ LDZ ) CALL MA02AD( 'Upper', M, M, DWORK( IMAT+5*MM ), M, $ Z( M+1, M+1 ), LDZ ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q1, LDQ1, DWORK( IQ+3*MM ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1, LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q1( 1, M+1 ), LDQ1, DWORK( IQ+MM ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1( 1, M+1 ), $ LDQ1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q2, LDQ2, DWORK( IQ+4*MM ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q2( 1, M+1 ), LDQ2, DWORK, M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2( 1, M+1 ), $ LDQ2 ) END IF C IF( LCMPU1 ) THEN C C Update U11 and U12. C CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U11, LDU11, DWORK( IQ+2*MM ), M, ZERO, $ DWORK( IMAT ), M ) CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U11, LDU11 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U12, LDU12, DWORK( IQ+2*MM ), M, ZERO, $ DWORK( IMAT ), M ) CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U12, LDU12 ) END IF C IF( LCMPU2 ) THEN C C Update U21 and U22. C CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U21, LDU21, DWORK( IQ+5*MM ), M, ZERO, $ DWORK( IMAT ), M ) CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U21, LDU21 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U22, LDU22, DWORK( IQ+5*MM ), M, ZERO, $ DWORK( IMAT ), M ) CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, U22, LDU22 ) END IF END IF C C Move the norms, and the sextuples of 1-by-1 and 2-by-2 blocks C in front. C K = 6*( M - 2*I2X2 ) + 24*I2X2 CALL DCOPY( K, DWORK( IWRK ), 1, DWORK( 8 ), 1 ) CALL DCOPY( 6, DUM, 1, DWORK( 2 ), 1 ) C DWORK( 1 ) = OPTDW RETURN C *** Last line of MB04AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01UW.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01UW.f0000644000175000017500000002710215012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE MB01UW( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute one of the matrix products C C A : = alpha*op( H ) * A, or A : = alpha*A * op( H ), C C where alpha is a scalar, A is an m-by-n matrix, H is an upper C 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': A := alpha*op( H ) * A; C = 'R': A := 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 matrix A. M >= 0. C C N (input) INTEGER C The number of columns of the matrix A. 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/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading M-by-N part of this array must C contain the matrix A. C On exit, the leading M-by-N part of this array contains C the computed product. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, alpha <> 0, and LDWORK >= M*N > 0, C DWORK contains a copy of the matrix A, having the leading C dimension M. C This array is not referenced when alpha = 0. C C LDWORK The length of the array DWORK. C LDWORK >= 0, if alpha = 0 or MIN(M,N) = 0; C LDWORK >= M-1, if SIDE = 'L'; C LDWORK >= N-1, if SIDE = 'R'. C For maximal efficiency LDWORK should be at least M*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 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. If the workspace can C accomodate a copy of A, a fast BLAS 3 DTRMM operation is used in C the first step. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, January 1999. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. 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, LDH, LDWORK, M, N DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), H(LDH,*) C .. Local Scalars .. LOGICAL LSIDE, LTRANS INTEGER I, J, JW C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DLACPY, DLASCL, DLASET, DSCAL, DSWAP, $ DTRMM, DTRMV, 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( LDWORK.LT.0 .OR. $ ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 .AND. $ ( ( LSIDE .AND. LDWORK.LT.M-1 ) .OR. $ ( .NOT.LSIDE .AND. LDWORK.LT.N-1 ) ) ) ) THEN INFO = -11 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01UW', -INFO ) RETURN END IF C C Quick return, if possible. C IF ( MIN( M, N ).EQ.0 ) THEN RETURN ELSE IF ( LSIDE ) THEN IF ( M.EQ.1 ) THEN CALL DSCAL( N, ALPHA*H(1,1), A, LDA ) RETURN END IF ELSE IF ( N.EQ.1 ) THEN CALL DSCAL( M, ALPHA*H(1,1), A, 1 ) RETURN END IF END IF C IF( ALPHA.EQ.ZERO ) THEN C C Set A to zero and return. C CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) RETURN END IF C IF( LDWORK.GE.M*N ) THEN C C Enough workspace for a fast BLAS 3 calculation. C Save A in the workspace and compute one of the matrix products C A : = alpha*op( triu( H ) ) * A, or C A : = alpha*A * op( triu( H ) ), C involving the upper triangle of H. C CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M ) CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H, $ LDH, A, LDA ) 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 JW = 1 DO 20 J = 1, N JW = JW + 1 DO 10 I = 1, M - 1 A( I, J ) = A( I, J ) + $ ALPHA*H( I+1, 1 )*DWORK( JW ) JW = JW + 1 10 CONTINUE 20 CONTINUE ELSE JW = 0 DO 40 J = 1, N JW = JW + 1 DO 30 I = 2, M A( I, J ) = A( I, J ) + $ ALPHA*H( I, 1 )*DWORK( JW ) JW = JW + 1 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 JW = 1 DO 50 J = 1, N - 1 IF ( H( J+1, J ).NE.ZERO ) $ CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1, $ A( 1, J+1 ), 1 ) JW = JW + M 50 CONTINUE ELSE JW = M + 1 DO 60 J = 1, N - 1 IF ( H( J+1, J ).NE.ZERO ) $ CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1, $ A( 1, J ), 1 ) JW = JW + M 60 CONTINUE END IF END IF C ELSE C C Use a BLAS 2 calculation. 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 80 J = 1, N C C Compute the contribution of the subdiagonal of H to C the j-th column of the product. C DO 70 I = 1, M - 1 DWORK( I ) = H( I+1, 1 )*A( I+1, J ) 70 CONTINUE C C Multiply the upper triangle of H by the j-th column C of A, and add to the above result. C CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH, $ A( 1, J ), 1 ) CALL DAXPY( M-1, ONE, DWORK, 1, A( 1, J ), 1 ) 80 CONTINUE C ELSE DO 100 J = 1, N C C Compute the contribution of the subdiagonal of H to C the j-th column of the product. C DO 90 I = 1, M - 1 DWORK( I ) = H( I+1, 1 )*A( I, J ) 90 CONTINUE C C Multiply the upper triangle of H by the j-th column C of A, and add to the above result. C CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH, $ A( 1, J ), 1 ) CALL DAXPY( M-1, ONE, DWORK, 1, A( 2, J ), 1 ) 100 CONTINUE END IF IF( M.GT.2 ) $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) C ELSE C C Below, row-wise calculations are used for A. C IF( N.GT.2 ) $ CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) IF( LTRANS ) THEN DO 120 I = 1, M C C Compute the contribution of the subdiagonal of H to C the i-th row of the product. C DO 110 J = 1, N - 1 DWORK( J ) = A( I, J )*H( J+1, 1 ) 110 CONTINUE C C Multiply the i-th row of A by the upper triangle of H, C and add to the above result. C CALL DTRMV( 'Upper', 'NoTranspose', 'Non-unit', N, H, $ LDH, A( I, 1 ), LDA ) CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 2 ), LDA ) 120 CONTINUE C ELSE DO 140 I = 1, M C C Compute the contribution of the subdiagonal of H to C the i-th row of the product. C DO 130 J = 1, N - 1 DWORK( J ) = A( I, J+1 )*H( J+1, 1 ) 130 CONTINUE C C Multiply the i-th row of A by the upper triangle of H, C and add to the above result. C CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', N, H, $ LDH, A( I, 1 ), LDA ) CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 1 ), LDA ) 140 CONTINUE END IF IF( N.GT.2 ) $ CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) C END IF C C Scale the result by alpha. C IF ( ALPHA.NE.ONE ) $ CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA, $ INFO ) END IF RETURN C *** Last line of MB01UW *** END control-4.1.2/src/slicot/src/PaxHeaders/AB8NXZ.f0000644000000000000000000000013215012430707016247 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB8NXZ.f0000644000175000017500000003644515012430707017457 0ustar00lilgelilge00000000000000 SUBROUTINE AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD, $ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, $ DWORK, ZWORK, LZWORK, INFO ) 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) COMPLEX*16 array, dimension (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 (2*MAX(M,P)) C C ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal value C of LZWORK. C C LZWORK INTEGER C The length of the array ZWORK. C LZWORK >= 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 LZWORK should be larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK 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 V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008 with suggestions from P. Gahinet, C The MathWorks. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009, C Apr. 2011. C C KEYWORDS C C Generalized eigenvalue problem, Kronecker indices, multivariable C system, unitary transformation, structural invariant. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) DOUBLE PRECISION DZERO PARAMETER ( DZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDABCD, LZWORK, M, MU, N, NINFZ, NKROL, $ NU, P, RO, SIGMA DOUBLE PRECISION SVLMAX, TOL C .. Array Arguments .. INTEGER INFZ(*), IWORK(*), KRONL(*) COMPLEX*16 ABCD(LDABCD,*), ZWORK(*) DOUBLE PRECISION DWORK(*) C .. Local Scalars .. LOGICAL LQUERY INTEGER I1, IK, IROW, ITAU, IZ, JWORK, MM1, MNTAU, MNU, $ MPM, NP, RANK, RO1, TAU, WRKOPT COMPLEX*16 TC C .. Local Arrays .. DOUBLE PRECISION SVAL(3) C .. External Subroutines .. EXTERNAL MB3OYZ, MB3PYZ, XERBLA, ZLAPMT, ZLARFG, ZLASET, $ ZLATZM, ZUNMQR, ZUNMRQ C .. Intrinsic Functions .. INTRINSIC DCONJG, INT, MAX, MIN C .. Executable Statements .. C NP = N + P MPM = MIN( P, M ) INFO = 0 LQUERY = ( LZWORK.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.DZERO ) 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 CALL ZUNMQR( 'Left', 'Conjugate', P, N, MPM, ABCD, $ LDABCD, ZWORK, ABCD, LDABCD, ZWORK, -1, $ INFO ) WRKOPT = MAX( JWORK, MPM + INT( ZWORK(1) ) ) ELSE WRKOPT = JWORK END IF CALL ZUNMRQ( 'Right', 'ConjTranspose', NP, N, MIN( P, N ), $ ABCD, LDABCD, ZWORK, ABCD, LDABCD, ZWORK, -1, $ INFO ) WRKOPT = MAX( WRKOPT, MIN( P, N ) + INT( ZWORK(1) ) ) CALL ZUNMRQ( 'Left', 'NoTranspose', N, M+N, MIN( P, N ), $ ABCD, LDABCD, ZWORK, ABCD, LDABCD, ZWORK, -1, $ INFO ) WRKOPT = MAX( WRKOPT, MIN( P, N ) + INT( ZWORK(1) ) ) ELSE IF( LZWORK.LT.JWORK ) THEN INFO = -19 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB8NXZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN ZWORK(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 "xWorkspace:", where x is C I, D, or C, describe the minimal amount of integer, real and C complex workspace needed at that point in the code, respectively, C 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 CWorkspace: need M+N-1. C DO 40 I1 = 1, SIGMA CALL ZLARFG( RO+1, ABCD(IROW,I1), ABCD(IROW+1,I1), 1, $ TC ) CALL ZLATZM( 'L', RO+1, MNU-I1, ABCD(IROW+1,I1), 1, $ DCONJG( TC ), ABCD(IROW,I1+1), $ ABCD(IROW+1,I1+1), LDABCD, ZWORK ) IROW = IROW + 1 40 CONTINUE CALL ZLASET( '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 IWorkspace: need M; C RWorkspace: need 2*M; C CWorkspace: 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 MB3OYZ( RO1, M-SIGMA, ABCD(IROW,I1), LDABCD, TOL, $ SVLMAX, RANK, SVAL, IWORK, ZWORK(ITAU), DWORK, $ ZWORK(JWORK), INFO ) WRKOPT = MAX( WRKOPT, JWORK + 3*M - 2 ) C C Apply the column permutations to matrices B and part of D. C CALL ZLAPMT( .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 CWorkspace: need min(RO1,M) + NU; C prefer min(RO1,M) + NU*NB. C CALL ZUNMQR( 'Left', 'Conjugate', RO1, NU, RANK, $ ABCD(IROW,I1), LDABCD, ZWORK(ITAU), $ ABCD(IROW,MM1), LDABCD, ZWORK(JWORK), $ LZWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) IF ( RO1.GT.1 ) $ CALL ZLASET( '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 IWorkspace: need TAU; C RWorkspace: need 2*TAU; C CWorkspace: need min(TAU,NU) + 3*TAU - 1. C CALL MB3PYZ( TAU, NU, ABCD(I1,MM1), LDABCD, TOL, SVLMAX, RANK, $ SVAL, IWORK, ZWORK(ITAU), DWORK, ZWORK(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 CWorkspace: need min(TAU,NU) + NU + SIGMA; SIGMA <= P; C prefer min(TAU,NU) + (NU + SIGMA)*NB. C CALL ZUNMRQ( 'Right', 'ConjTranspose', I1-1, NU, RANK, $ ABCD(IROW,MM1), LDABCD, ZWORK(MNTAU-RANK+1), $ ABCD(1,MM1), LDABCD, ZWORK(JWORK), $ LZWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) C C Apply Q to the first NU rows and M + NU columns of [ B A ] C from the left. C CWorkspace: need min(TAU,NU) + M + NU; C prefer min(TAU,NU) + (M + NU)*NB. C CALL ZUNMRQ( 'Left', 'NoTranspose', NU, MNU, RANK, $ ABCD(IROW,MM1), LDABCD, ZWORK(MNTAU-RANK+1), $ ABCD, LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, $ INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) C CALL ZLASET( 'Full', RANK, NU-RANK, ZERO, ZERO, $ ABCD(IROW,MM1), LDABCD ) IF ( RANK.GT.1 ) $ CALL ZLASET( '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 ZWORK(1) = WRKOPT RETURN C *** Last line of AB8NXZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01XY.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01XY.f0000644000175000017500000001155315012430707017416 0ustar00lilgelilge00000000000000 SUBROUTINE MB01XY( UPLO, N, A, LDA, INFO ) C C PURPOSE C C To compute the matrix product U' * U or L * L', where U and L are C upper and lower triangular matrices, respectively, stored in the C corresponding upper or lower triangular part of the array A. C C If UPLO = 'U' then the upper triangle of the result is stored, C overwriting the matrix U in A. C If UPLO = 'L' then the lower triangle of the result is stored, C overwriting the matrix L in A. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies which triangle (U or L) is given in the array A, C as follows: C = 'U': the upper triangular part U is given; C = 'L': the lower triangular part L is given. C C Input/Output Parameters C C N (input) INTEGER C The order of the triangular matrices U or L. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,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 matrix U. C On entry, if UPLO = 'L', the leading N-by-N lower C triangular part of this array must contain the lower C triangular matrix L. C On exit, if UPLO = 'U', the leading N-by-N upper C triangular part of this array contains the upper C triangular part of the product U' * U. The strictly lower C triangular part is not referenced. C On exit, if UPLO = 'L', the leading N-by-N lower C triangular part of this array contains the lower C triangular part of the product L * L'. The strictly upper C triangular part is not referenced. C C LDA INTEGER C The leading dimension of array A. LDA >= max(1,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 METHOD C C The matrix product U' * U or L * L' is computed using BLAS 2 and C BLAS 1 operations (an unblocked algorithm). C C FURTHER COMMENTS C C This routine is a counterpart of LAPACK Library routine DLAUU2, C which computes the matrix product U * U' or L' * L. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) C .. C .. Local Scalars .. LOGICAL UPPER INTEGER I DOUBLE PRECISION AII C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL DDOT, LSAME C .. C .. External Subroutines .. EXTERNAL DGEMV, DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01XY', -INFO ) RETURN END IF C C Quick return, if possible. C IF( N.EQ.0 ) $ RETURN C IF( UPPER ) THEN C C Compute the product U' * U. C A( N, N ) = DDOT( N, A( 1, N ), 1, A( 1, N ), 1 ) C DO 10 I = N-1, 2, -1 AII = A( I, I ) A( I, I ) = DDOT( I, A( 1, I ), 1, A( 1, I ), 1 ) CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), LDA, $ A( 1, I ), 1, AII, A( I, I+1 ), LDA ) 10 CONTINUE C IF( N.GT.1 ) THEN AII = A( 1, 1 ) CALL DSCAL( N, AII, A( 1, 1 ), LDA ) END IF C ELSE C C Compute the product L * L'. C A( N, N ) = DDOT( N, A( N, 1 ), LDA, A( N, 1 ), LDA ) C DO 20 I = N-1, 2, -1 AII = A( I, I ) A( I, I ) = DDOT( I, A( I, 1 ), LDA, A( I, 1 ), LDA ) CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A( I+1, 1 ), $ LDA, A( I, 1 ), LDA, AII, A( I+1, I ), 1 ) 20 CONTINUE C IF( N.GT.1 ) THEN AII = A( 1, 1 ) CALL DSCAL( N, AII, A( 1, 1 ), 1 ) END IF END IF C RETURN C C *** Last line of MB01XY *** END control-4.1.2/src/slicot/src/PaxHeaders/DG01OD.f0000644000000000000000000000013215012430707016153 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/DG01OD.f0000644000175000017500000002141215012430707017347 0ustar00lilgelilge00000000000000 SUBROUTINE DG01OD( SCR, WGHT, N, A, W, INFO ) C C PURPOSE C C To compute the (scrambled) discrete Hartley transform of C a real signal. C C ARGUMENTS C C Mode Parameters C C SCR CHARACTER*1 C Indicates whether the signal is scrambled on input or C on output as follows: C = 'N': the signal is not scrambled at all; C = 'I': the input signal is bit-reversed; C = 'O': the output transform is bit-reversed. C C WGHT CHARACTER*1 C Indicates whether the precomputed weights are available C or not, as follows: C = 'A': available; C = 'N': not available. C Note that if N > 1 and WGHT = 'N' on entry, then WGHT is C set to 'A' on exit. C C Input/Output Parameters C C N (input) INTEGER C Number of real samples. N must be a power of 2. C N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (N) C On entry with SCR = 'N' or SCR = 'O', this array must C contain the input signal. C On entry with SCR = 'I', this array must contain the C bit-reversed input signal. C On exit with SCR = 'N' or SCR = 'I', this array contains C the Hartley transform of the input signal. C On exit with SCR = 'O', this array contains the C bit-reversed Hartley transform. C C W (input/output) DOUBLE PRECISION array, C dimension (N - LOG2(N)) C On entry with WGHT = 'A', this array must contain the long C weight vector computed by a previous call of this routine C with the same value of N. If WGHT = 'N', the contents of C this array on entry is ignored. C On exit, this array contains the long weight vector. 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 This routine uses a Hartley butterfly algorithm as described C in [1]. C C REFERENCES C C [1] Van Loan, Charles. C Computational frameworks for the fast Fourier transform. C SIAM, 1992. C C NUMERICAL ASPECTS C C The algorithm is backward stable and requires O(N log(N)) C floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, April 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. C C KEYWORDS C C Digital signal processing, fast Hartley transform, real signals. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO, FOUR PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, FOUR = 4.0D0 ) C .. Scalar Arguments .. CHARACTER SCR, WGHT INTEGER INFO, N C .. Array Arguments .. DOUBLE PRECISION A(*), W(*) C .. Local Scalars .. INTEGER I, J, L, LEN, M, P1, P2, Q1, Q2, R1, R2, S1, S2, $ WPOS LOGICAL LFWD, LSCR, LWGHT DOUBLE PRECISION CF, SF, T1, T2, TH C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC ATAN, COS, DBLE, MOD, SIN C .. Executable Statements .. C INFO = 0 LFWD = LSAME( SCR, 'N' ) .OR. LSAME( SCR, 'I' ) LSCR = LSAME( SCR, 'I' ) .OR. LSAME( SCR, 'O' ) LWGHT = LSAME( WGHT, 'A' ) C C Test the input scalar arguments. C IF( .NOT.( LFWD .OR. LSCR ) ) THEN INFO = -1 ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN INFO = -2 ELSE M = 0 J = 0 IF( N.GE.1 ) THEN J = N C WHILE ( MOD( J, 2 ).EQ.0 ) DO 10 CONTINUE IF ( MOD( J, 2 ).EQ.0 ) THEN J = J/2 M = M + 1 GO TO 10 END IF C END WHILE 10 IF ( J.NE.1 ) INFO = -3 ELSE IF ( N.LT.0 ) THEN INFO = -3 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'DG01OD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.LE.1 ) $ RETURN C IF ( .NOT. LWGHT ) THEN C C Compute the long weight vector via subvector scaling. C R1 = 1 LEN = 1 TH = FOUR*ATAN( ONE ) / DBLE( N ) C DO 30 L = 1, M - 2 LEN = 2*LEN TH = TWO*TH CF = COS(TH) SF = SIN(TH) W(R1) = CF W(R1+1) = SF R1 = R1 + 2 C DO 20 I = 1, LEN - 2, 2 W(R1) = CF*W(I) - SF*W(I+1) W(R1+1) = SF*W(I) + CF*W(I+1) R1 = R1 + 2 20 CONTINUE C 30 CONTINUE C P1 = 3 Q1 = R1 - 2 C DO 50 L = M - 2, 1, -1 C DO 40 I = P1, Q1, 4 W(R1) = W(I) W(R1+1) = W(I+1) R1 = R1 + 2 40 CONTINUE C P1 = Q1 + 4 Q1 = R1 - 2 50 CONTINUE C WGHT = 'A' C END IF C IF ( LFWD .AND. .NOT.LSCR ) THEN C C Inplace shuffling of data. C J = 1 C DO 70 I = 1, N IF ( J.GT.I ) THEN T1 = A(I) A(I) = A(J) A(J) = T1 END IF L = N/2 C REPEAT 60 IF ( J.GT.L ) THEN J = J - L L = L/2 IF ( L.GE.2 ) GO TO 60 END IF C UNTIL ( L.LT.2 ) J = J + L 70 CONTINUE C END IF C IF ( LFWD ) THEN C C Compute Hartley transform with butterfly operators. C DO 110 J = 2, N, 2 T1 = A(J) A(J) = A(J-1) - T1 A(J-1) = A(J-1) + T1 110 CONTINUE C LEN = 1 WPOS = N - 2*M + 1 C DO 140 L = 1, M - 1 LEN = 2*LEN P2 = 1 Q2 = LEN + 1 R2 = LEN / 2 + 1 S2 = R2 + Q2 - 1 C DO 130 I = 0, N/( 2*LEN ) - 1 T1 = A(Q2) A(Q2) = A(P2) - T1 A(P2) = A(P2) + T1 T1 = A(S2) A(S2) = A(R2) - T1 A(R2) = A(R2) + T1 C P1 = P2 + 1 Q1 = P1 + LEN R1 = Q1 - 2 S1 = R1 + LEN C DO 120 J = WPOS, WPOS + LEN - 3, 2 CF = W(J) SF = W(J+1) T1 = CF*A(Q1) + SF*A(S1) T2 = -CF*A(S1) + SF*A(Q1) A(Q1) = A(P1) - T1 A(P1) = A(P1) + T1 A(S1) = A(R1) - T2 A(R1) = A(R1) + T2 P1 = P1 + 1 Q1 = Q1 + 1 R1 = R1 - 1 S1 = S1 - 1 120 CONTINUE C P2 = P2 + 2*LEN Q2 = Q2 + 2*LEN R2 = R2 + 2*LEN S2 = S2 + 2*LEN 130 CONTINUE C WPOS = WPOS - 2*LEN + 2 140 CONTINUE C ELSE C C Compute Hartley transform with transposed butterfly operators. C WPOS = 1 LEN = N C DO 230 L = M - 1, 1, -1 LEN = LEN / 2 P2 = 1 Q2 = LEN + 1 R2 = LEN / 2 + 1 S2 = R2 + Q2 - 1 C DO 220 I = 0, N/( 2*LEN ) - 1 T1 = A(Q2) A(Q2) = A(P2) - T1 A(P2) = A(P2) + T1 T1 = A(S2) A(S2) = A(R2) - T1 A(R2) = A(R2) + T1 C P1 = P2 + 1 Q1 = P1 + LEN R1 = Q1 - 2 S1 = R1 + LEN C DO 210 J = WPOS, WPOS + LEN - 3, 2 CF = W(J) SF = W(J+1) T1 = A(P1) - A(Q1) T2 = A(R1) - A(S1) A(P1) = A(P1) + A(Q1) A(R1) = A(R1) + A(S1) A(Q1) = CF*T1 + SF*T2 A(S1) = -CF*T2 + SF*T1 P1 = P1 + 1 Q1 = Q1 + 1 R1 = R1 - 1 S1 = S1 - 1 210 CONTINUE C P2 = P2 + 2*LEN Q2 = Q2 + 2*LEN R2 = R2 + 2*LEN S2 = S2 + 2*LEN 220 CONTINUE C WPOS = WPOS + LEN - 2 230 CONTINUE C DO 240 J = 2, N, 2 T1 = A(J) A(J) = A(J-1) - T1 A(J-1) = A(J-1) + T1 240 CONTINUE C END IF RETURN C *** Last line of DG01OD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04AZ.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04AZ.f0000644000175000017500000011360415012430707017373 0ustar00lilgelilge00000000000000 SUBROUTINE MB04AZ( JOB, COMPQ, COMPU, N, Z, LDZ, B, LDB, FG, $ LDFG, D, LDD, C, LDC, Q, LDQ, U, LDU, ALPHAR, $ ALPHAI, BETA, IWORK, LIWORK, DWORK, LDWORK, $ ZWORK, LZWORK, BWORK, INFO ) C PURPOSE C C To compute the eigenvalues of a complex N-by-N skew-Hamiltonian/ C Hamiltonian pencil aS - bH, with C C H T ( B F ) ( Z11 Z12 ) C S = J Z J Z and H = ( H ), Z =: ( ). (1) C ( G -B ) ( Z21 Z22 ) C C The structured Schur form of the embedded real skew-Hamiltonian/ C H T C skew-Hamiltonian pencil, aB_S - bB_T, with B_S = J B_Z J B_Z, C C ( Re(Z11) -Im(Z11) | Re(Z12) -Im(Z12) ) C ( | ) C ( Im(Z11) Re(Z11) | Im(Z12) Re(Z12) ) C ( | ) C B_Z = (---------------------+---------------------) , C ( | ) C ( Re(Z21) -Im(Z21) | Re(Z22) -Im(Z22) ) C ( | ) C ( Im(Z21) Re(Z21) | Im(Z22) Re(Z22) ) C (2) C ( -Im(B) -Re(B) | -Im(F) -Re(F) ) C ( | ) C ( Re(B) -Im(B) | Re(F) -Im(F) ) C ( | ) C B_T = (-----------------+-----------------) , T = i*H, C ( | T T ) C ( -Im(G) -Re(G) | -Im(B ) Re(B ) ) C ( | T T ) C ( Re(G) -Im(G) | -Re(B ) -Im(B ) ) C C is determined and used to compute the eigenvalues. Optionally, C if JOB = 'T', the pencil aB_S - bB_H is transformed by a unitary C matrix Q and a unitary symplectic matrix U to the structured Schur C H T C form aB_Sout - bB_Hout, with B_Sout = J B_Zout J B_Zout, C C ( BA BD ) ( BB BF ) C B_Zout = ( ) and B_Hout = ( H ), (3) C ( 0 BC ) ( 0 -BB ) C C where BA and BB are upper triangular, BC is lower triangular, C and BF is Hermitian. B_H above is defined as B_H = -i*B_T. C The embedding doubles the multiplicities of the eigenvalues of C the pencil aS - bH. C Optionally, if COMPQ = 'C', the unitary matrix Q is computed. C Optionally, if COMPU = 'C', the unitary symplectic matrix U is C computed. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; S and H will not C necessarily be transformed as in (3). C = 'T': put S and H into the forms in (3) and return the C eigenvalues in ALPHAR, ALPHAI and BETA. C C COMPQ CHARACTER*1 C Specifies whether to compute the unitary transformation C matrix Q, as follows: C = 'N': do not compute the unitary matrix Q; C = 'C': the array Q is initialized internally to the unit C matrix, and the unitary matrix Q is returned. C C COMPU CHARACTER*1 C Specifies whether to compute the unitary symplectic C transformation matrix U, as follows: C = 'N': do not compute the unitary symplectic matrix U; C = 'C': the array U is initialized internally to the unit C matrix, and the unitary symplectic matrix U is C returned. C C Input/Output Parameters C C N (input) INTEGER C Order of the pencil aS - bH. N >= 0, even. C C Z (input/output) COMPLEX*16 array, dimension (LDZ, N) C On entry, the leading N-by-N part of this array must C contain the non-trivial factor Z in the factorization C H T C S = J Z J Z of the skew-Hamiltonian matrix S. C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the upper triangular matrix BA in (3) C (see also METHOD). The strictly lower triangular part is C not zeroed. The submatrix in the rows N/2+1 to N and the C first N/2 columns is unchanged, except possibly for the C entry (N/2+1,N/2), which might be set to zero. C If JOB = 'E', this array is unchanged on exit. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1, N). C C B (input/output) COMPLEX*16 array, dimension (LDB, K), where C K = N, if JOB = 'T', and K = M, if JOB = 'E'. C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the upper triangular matrix BB in (3) C (see also METHOD). C The strictly lower triangular part is not zeroed. C If JOB = 'E', this array is unchanged on exit. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1, M), if JOB = 'E'; C LDB >= MAX(1, N), if JOB = 'T'. C C FG (input/output) COMPLEX*16 array, dimension (LDFG, P), C where P = MAX(M+1,N), if JOB = 'T', and C P = M+1, if JOB = 'E'. C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C Hermitian matrix G, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C Hermitian matrix F. Accidental nonzero imaginary parts on C the main diagonals of F and G do not perturb the results. C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the Hermitian matrix BF in (3) (see also C METHOD). The strictly lower triangular part of the input C matrix is preserved. The diagonal elements might have tiny C imaginary parts, since they have not been annihilated. C If JOB = 'E', this array is unchanged on exit. C C LDFG INTEGER C The leading dimension of the array FG. C LDFG >= MAX(1, M), if JOB = 'E'; C LDFG >= MAX(1, N), if JOB = 'T'. C C D (output) COMPLEX*16 array, dimension (LDD, N) C If JOB = 'T', the leading N-by-N part of this array C contains the matrix BD in (3) (see also METHOD). C If JOB = 'E', this array is not referenced. C C LDD INTEGER C The leading dimension of the array D. C LDD >= 1, if JOB = 'E'; C LDD >= MAX(1, N), if JOB = 'T'. C C C (output) COMPLEX*16 array, dimension (LDC, N) C If JOB = 'T', the leading N-by-N part of this array C contains the lower triangular matrix BC in (3) (see also C METHOD). The part over the first superdiagonal is not set. C If JOB = 'E', this array is not referenced. C C LDC INTEGER C The leading dimension of the array C. C LDC >= 1, if JOB = 'E'; C LDC >= MAX(1, N), if JOB = 'T'. C C Q (output) COMPLEX*16 array, dimension (LDQ, 2*N) C On exit, if COMPQ = 'C' and JOB = 'T', then the leading C 2*N-by-2*N part of this array contains the unitary C transformation matrix Q. C If COMPQ = 'C' and JOB = 'E', this array contains the C orthogonal transformation which reduced B_Z and B_T C in the first step of the algorithm (see METHOD). C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, 2*N), if COMPQ = 'C'. C C U (output) COMPLEX*16 array, dimension (LDU, 2*N) C On exit, if COMPU = 'C' and JOB = 'T', then the leading C N-by-2*N part of this array contains the leading N-by-2*N C part of the unitary symplectic transformation matrix U. C If COMPU = 'C' and JOB = 'E', this array contains the C first N rows of the transformation U which reduced B_Z C and B_T in the first step of the algorithm (see METHOD). C If COMPU = 'N', this array is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= 1, if COMPU = 'N'; C LDU >= MAX(1, N), if COMPU = 'C'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = 3, IWORK(1) contains the number of C (pairs of) possibly inaccurate eigenvalues, q <= N/2, and C IWORK(2), ..., IWORK(q+1) indicate their indices. C Specifically, a positive value is an index of a real or C purely imaginary eigenvalue, corresponding to a 1-by-1 C block, while the absolute value of a negative entry in C IWORK is an index to the first eigenvalue in a pair of C consecutively stored eigenvalues, corresponding to a C 2-by-2 block. A 2-by-2 block may have two complex, two C real, two purely imaginary, or one real and one purely C imaginary eigenvalue. The blocks are those in B_T and B_S. C For i = q+2, ..., 2*q+1, IWORK(i) contains a pointer to C the starting location in DWORK of the i-th triplet of C 1-by-1 blocks, if IWORK(i-q) > 0, or 2-by-2 blocks, C if IWORK(i-q) < 0, defining unreliable eigenvalues. C IWORK(2*q+2) contains the number of the 1-by-1 blocks, and C IWORK(2*q+3) contains the number of the 2-by-2 blocks, C corresponding to unreliable eigenvalues. IWORK(2*q+4) C contains the total number t of the 2-by-2 blocks. C If INFO = 0, then q = 0, therefore IWORK(1) = 0. C C LIWORK INTEGER C The dimension of the array IWORK. LIWORK >= 2*N+9. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or INFO = 3, DWORK(1) returns the C optimal LDWORK, and DWORK(2), ..., DWORK(4) contain the C Frobenius norms of the factors of the formal matrix C product used by the algorithm. In addition, DWORK(5), ..., C DWORK(4+3*s) contain the s triplet values corresponding C to the 1-by-1 blocks. Their eigenvalues are real or purely C imaginary. Such an eigenvalue is obtained as -a1/a2/a3*i, C where a1, ..., a3 are the corresponding triplet values, C and i is the purely imaginary unit. C Moreover, DWORK(5+3*s), ..., DWORK(4+3*s+12*t) contain the C t groups of triplet 2-by-2 matrices corresponding to the C 2-by-2 blocks. Their eigenvalue pairs are either complex, C or placed on the real and imaginary axes. Such an C eigenvalue pair is given by imag( ev ) - real( ev )*i, C where ev is the spectrum of the matrix product C A1*inv(A2)*inv(A3), and A1, ..., A3 define the C corresponding 2-by-2 matrix triplet. C On exit, if INFO = -25, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= c*N**2 + N + MAX(6*N, 27), where C c = 18, if COMPU = 'C'; C c = 16, if COMPQ = 'C' and COMPU = 'N'; C c = 13, if COMPQ = 'N' and COMPU = 'N'. C For good performance LDWORK should be generally 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 ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal LZWORK. C On exit, if INFO = -27, ZWORK(1) returns the minimum C value of LZWORK. C C LZWORK INTEGER C The dimension of the array ZWORK. C LZWORK >= 8*N + 28, if JOB = 'T' and COMPQ = 'C'; C LZWORK >= 6*N + 28, if JOB = 'T' and COMPQ = 'N'; C LZWORK >= 1, if JOB = 'E'. C For good performance LZWORK should be generally larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK C is issued by XERBLA. C C BWORK LOGICAL array, dimension (LBWORK) C LBWORK >= 0, if JOB = 'E'; C LBWORK >= N, if JOB = 'T'. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: the algorithm was not able to reveal information C about the eigenvalues from the 2-by-2 blocks in the C SLICOT Library routine MB03BD (called by MB04ED); C = 2: periodic QZ iteration failed in the SLICOT Library C routines MB03BD or MB03BZ when trying to C triangularize the 2-by-2 blocks; C = 3: some eigenvalues might be inaccurate. This is a C warning. C C METHOD C C First T = i*H is set. Then, the embeddings, B_Z and B_T, of the C matrices S and T, are determined and, subsequently, the SLICOT C Library routine MB04ED is applied to compute the structured Schur C form, i.e., the factorizations C C ~ T ( BZ11 BZ12 ) C B_Z = U B_Z Q = ( ) and C ( 0 BZ22 ) C C ~ T T ( T11 T12 ) C B_T = J Q J B_T Q = ( T ), C ( 0 T11 ) C C where Q is real orthogonal, U is real orthogonal symplectic, BZ11, C BZ22' are upper triangular and T11 is upper quasi-triangular. C If JOB = 'T', the 2-by-2 blocks are triangularized using the C periodic QZ algorithm. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C complex floating point operations. C C FURTHER COMMENTS C C This routine does not perform any scaling of the matrices. Scaling C might sometimes be useful, and it should be done externally. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, April 30, 2009. C V. Sima, Aug. 2009 (SLICOT version of the routine ZHAFDF). C C REVISIONS C V. Sima, Jan. 2011, Mar. 2011, Aug. 2011, Nov. 2011, July 2012, C July 2013, May 2020. C C KEYWORDS C C Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian C pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, FOUR PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, FOUR = 4.0D+0 ) COMPLEX*16 CZERO, CONE, CIMAG PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ), $ CIMAG = ( 0.0D+0, 1.0D+0 ) ) C C .. Scalar Arguments .. CHARACTER COMPQ, COMPU, JOB INTEGER INFO, LDB, LDC, LDD, LDFG, LDQ, LDU, LDWORK, $ LDZ, LIWORK, LZWORK, N C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), DWORK( * ) COMPLEX*16 B( LDB, * ), C( LDC, * ), D( LDD, * ), $ FG( LDFG, * ), Q( LDQ, * ), U( LDU, * ), $ Z( LDZ, * ), ZWORK( * ) C C .. Local Scalars .. LOGICAL LCMPQ, LCMPU, LQUERY, LTRI CHARACTER*10 CMPQ, CMPU INTEGER I, I1, IB, IEV, IFG, IQ, IQ2, IQB, IS, IU, IUB, $ IW, IW1, IWRK, IZ11, IZ22, J, J1, J2, J3, JM1, $ JP2, K, M, MINDB, MINDW, MINZW, N2, NB, NC, $ NJ1, NN, OPTDW, OPTZW DOUBLE PRECISION EPS, NRMB COMPLEX*16 TMP C C .. Local Arrays .. INTEGER DWORKZ( 2 ), IWORKZ( 5 ) C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C C .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DSCAL, MB03BZ, MB04ED, XERBLA, $ ZGEMM, ZGEQRF, ZLACPY, ZSCAL C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, $ MIN, MOD C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 NN = N*N N2 = 2*N C LTRI = LSAME( JOB, 'T' ) LCMPQ = LSAME( COMPQ, 'C' ) LCMPU = LSAME( COMPU, 'C' ) C IF( LTRI ) THEN K = MAX( 1, N ) ELSE K = MAX( 1, M ) END IF IF( N.EQ.0 ) THEN MINDW = 4 MINZW = 1 ELSE IF( LTRI ) THEN IF( LCMPQ ) THEN MINZW = 4*N2 + 28 ELSE MINZW = 3*N2 + 28 END IF ELSE MINZW = 1 END IF IF( LCMPU ) THEN I = 12 J = 18 ELSE I = 10 IF( LCMPQ ) THEN J = 16 ELSE J = 13 END IF END IF MINDB = I*NN + N MINDW = J*NN + N + MAX( 3*N2, 27 ) END IF LQUERY = LDWORK.EQ.-1 .OR. LZWORK.EQ.-1 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -2 ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -4 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.K ) THEN INFO = -8 ELSE IF( LDFG.LT.K ) THEN INFO = -10 ELSE IF( LDD.LT.1 .OR. ( LTRI .AND. LDD.LT.N ) ) THEN INFO = -12 ELSE IF( LDC.LT.1 .OR. ( LTRI .AND. LDC.LT.N ) ) THEN INFO = -14 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N2 ) ) THEN INFO = -16 ELSE IF( LDU.LT.1 .OR. ( LCMPU .AND. LDU.LT.N ) ) THEN INFO = -18 ELSE IF( LIWORK.LT.N2+9 ) THEN INFO = -23 ELSE IF( .NOT. LQUERY ) THEN IF( LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -25 ELSE IF( LZWORK.LT.MINZW ) THEN ZWORK( 1 ) = MINZW INFO = -27 END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04AZ', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN C C Compute optimal workspace. C IF( LTRI ) THEN CALL ZGEQRF( N, N, Z, LDZ, ZWORK, ZWORK, -1, INFO ) I = INT( ZWORK( 1 ) ) NB = MAX( I/N, 2 ) END IF C IF( LCMPQ ) THEN CMPQ = 'Initialize' ELSE CMPQ = COMPQ END IF IF( LCMPU ) THEN CMPU = 'Initialize' ELSE CMPU = COMPU END IF C IF( LQUERY ) THEN CALL MB04ED( JOB, CMPQ, CMPU, N2, DWORK, N2, DWORK, N, $ DWORK, N, DWORK, N2, DWORK, N, DWORK, N, $ ALPHAI, ALPHAR, BETA, IWORK, LIWORK, DWORK, $ -1, INFO ) OPTDW = MAX( MINDW, MINDB + INT( DWORK( 1 ) ) ) C IF( LTRI ) THEN OPTZW = MAX( MINZW, I ) ELSE OPTZW = MINZW END IF DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW RETURN ELSE OPTZW = MINZW END IF END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IWORK( 1 ) = 0 DWORK( 1 ) = FOUR DWORK( 2 ) = ZERO DWORK( 3 ) = ZERO DWORK( 4 ) = ZERO ZWORK( 1 ) = CONE RETURN END IF C C Determine machine constants. C EPS = DLAMCH( 'Precision' ) C C Set up the embeddings of the matrices Z and H. C Real workspace: need w1, where C w1 = 12*N**2+N, if COMPU = 'C'; C w1 = 10*N**2+N, if COMPU = 'N'. C IQ = 1 IF( LCMPU ) THEN IU = IQ + N2*N2 IZ11 = IU + N2*N ELSE IU = 1 IZ11 = IQ + N2*N2 END IF IB = IZ11 + N2*N2 IFG = IB + NN IWRK = IFG + NN + N C C Build the embedding of Z. C IW = IZ11 IS = IW + N2*M DO 50 J = 1, N IW1 = IW DO 10 I = 1, M DWORK( IW ) = DBLE( Z( I, J ) ) IW = IW + 1 10 CONTINUE C DO 20 I = 1, M DWORK( IW ) = DIMAG( Z( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 20 CONTINUE CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IW1 = IW IS = IS + M C DO 30 I = M + 1, N DWORK( IW ) = DBLE( Z( I, J ) ) IW = IW + 1 30 CONTINUE C DO 40 I = M + 1, N DWORK( IW ) = DIMAG( Z( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 40 CONTINUE C CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IW1 = IW IS = IS + M IF( MOD( J, M ).EQ.0 ) THEN IW = IW + N2*M IS = IS + N2*M END IF 50 CONTINUE C C Build the embedding of B. C IW = IB IS = IW + N*M DO 80 J = 1, M IW1 = IW DO 60 I = 1, M DWORK( IW ) = -DIMAG( B( I, J ) ) IW = IW + 1 60 CONTINUE C DO 70 I = 1, M DWORK( IW ) = DBLE( B( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 70 CONTINUE CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IS = IS + M 80 CONTINUE C C Build the embeddings of F and G. C IW = IFG DO 110 J = 1, M + 1 DO 90 I = 1, M DWORK( IW ) = -DIMAG( FG( I, J ) ) IW = IW + 1 90 CONTINUE C IW = IW + J - 1 IS = IW DO 100 I = J, M DWORK( IW ) = DBLE( FG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 100 CONTINUE 110 CONTINUE C IW1 = IW I1 = IW DO 130 J = 2, M + 1 IS = I1 I1 = I1 + 1 DO 120 I = 1, J - 1 DWORK( IW ) = -DBLE( FG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 120 CONTINUE IW = IW + N - J + 1 130 CONTINUE CALL DLACPY( 'Full', M, M+1, DWORK( IFG ), N, DWORK( IW1-M ), N ) C C Apply MB04ED to transform the extended pencil to real C skew-Hamiltonian/skew-Hamiltonian Schur form. C C Real workspace: need w1 + w2, where C w2 = 6*N**2+MAX(6*N, 27), C if COMPQ = 'C' or COMPU = 'C'; C w2 = 3*N**2+MAX(6*N, 27), C if COMPQ = 'N' and COMPU = 'N'; C prefer larger. C Integer workspace: need 2*N+9. C CALL MB04ED( JOB, CMPQ, CMPU, N2, DWORK( IZ11 ), N2, DWORK( IB ), $ N, DWORK( IFG ), N, DWORK( IQ ), N2, DWORK( IU ), N, $ DWORK( IU+NN ), N, ALPHAI, ALPHAR, BETA, IWORK, $ LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 .AND. INFO.LT.3 ) $ RETURN OPTDW = MAX( MINDW, MINDB + INT( DWORK( IWRK ) ) ) C C Scale the eigenvalues. C CALL DSCAL( N, -ONE, ALPHAI, 1 ) C C Convert the transformation matrices to complex datatype. C IF( LCMPQ ) THEN IW = IQ DO 150 J = 1, N2 DO 140 I = 1, N2 Q( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 140 CONTINUE 150 CONTINUE END IF C IF( LCMPU ) THEN IW = IU DO 170 J = 1, N2 DO 160 I = 1, N U( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 160 CONTINUE 170 CONTINUE END IF C C Return if only the eigenvalues are desired. C IF( .NOT.LTRI ) THEN ZWORK( 1 ) = OPTZW DWORK( 1 ) = OPTDW IW1 = IWORK( 1 ) IW = IWORK( 2*IW1+4 ) K = 3*( N - 2*IW + 1 ) + 12*IW CALL DCOPY( K, DWORK( IWRK+1 ), 1, DWORK( 2 ), 1 ) RETURN END IF C C Convert the other results to complex datatype. C IW = IZ11 DO 190 J = 1, N DO 180 I = 1, J Z( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 180 CONTINUE IW = IW + N2 - J 190 CONTINUE C IW = IZ11 + N2*N DO 220 J = 1, N DO 200 I = 1, N D( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 200 CONTINUE IW = IW + J - 1 C DO 210 I = J, N C( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 210 CONTINUE 220 CONTINUE C IW = IB DO 240 J = 1, N DO 230 I = 1, MIN( J + 1, N ) B( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 230 CONTINUE IW = IW + N - J - 1 240 CONTINUE C IW = IFG + N DO 260 J = 1, N DO 250 I = 1, J - 1 FG( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 250 CONTINUE FG( J, J ) = CZERO IW = IW + N - J + 1 260 CONTINUE C C Triangularize the 2-by-2 diagonal blocks in B using the complex C version of the periodic QZ algorithm. C C Set up pointers on the inputs and outputs of MB03BZ. C A block algorithm is used for updating the matrices for large N. C IS = IWRK IQ2 = 1 IQ = IQ2 + 4 IU = IQ + 4 IB = IU + 4 IZ11 = IB + 4 IZ22 = IZ11 + 4 IEV = IZ22 + 4 IQB = IEV + 4 IUB = IQB + 4*M IWRK = IUB + 4*M C C Set the signatures of the input matrices of MB03BZ. C IWORKZ( 1 ) = 1 IWORKZ( 2 ) = -1 IWORKZ( 3 ) = -1 C J = 1 J1 = 1 J2 = MIN( N, NB ) C WHILE( J.LT.N ) DO 270 CONTINUE IF( J.LT.N ) THEN NRMB = ABS( B( J, J ) ) + ABS( B( J+1, J+1 ) ) IF( ABS( B( J+1, J ) ).GT.NRMB*EPS ) THEN C C Triangularization step. Row transformations are blocked. C Complex workspace: need 8*N + 28, if COMPQ = 'C'; C 6*N + 28, if COMPQ = 'N'. C Real workspace: need 2. C Integer workspace: need 5. C NC = MAX( J2-J-1, 0 ) J3 = MIN( J2-J1+1, J-1 ) JM1 = MAX( J-1, 1 ) JP2 = MIN( J+2, N ) NJ1 = MAX( N-J-1, 1 ) CALL ZLACPY( 'Full', 2, 2, B( J, J ), LDB, ZWORK( IB ), 2 ) CALL ZLACPY( 'Upper', 2, 2, Z( J, J ), LDZ, ZWORK( IZ11 ), $ 2 ) ZWORK( IZ11+1 ) = CZERO ZWORK( IZ22 ) = DCONJG( C( J, J ) ) ZWORK( IZ22+1 ) = CZERO ZWORK( IZ22+2 ) = DCONJG( C( J+1, J ) ) ZWORK( IZ22+3 ) = DCONJG( C( J+1, J+1 ) ) C CALL MB03BZ( 'Schur form', 'Initialize', 3, 2, 1, 2, IWORKZ, $ ZWORK( IB ), 2, 2, ZWORK( IQ2 ), 2, 2, $ ZWORK( IEV ), ZWORK( IEV+2 ), IWORKZ( 4 ), $ DWORKZ, 2, ZWORK( IWRK ), LZWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Update a panel of Z. C CALL ZGEMM( 'No Transpose', 'No Transpose', J-1, 2, 2, $ CONE, Z( 1, J ), LDZ, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), JM1 ) CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, Z( 1, J ), $ LDZ ) CALL ZLACPY( 'Upper', 2, 2, ZWORK( IZ11 ), 2, Z( J, J ), $ LDZ ) Z( J+1, J ) = CZERO CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, NC, $ 2, CONE, ZWORK( IU ), 2, Z( J, JP2 ), LDZ, $ CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, Z( J, JP2 ), $ LDZ ) C C Update the columns J and J+1 of D. C The transformations on rows are made outside this loop. C CALL ZGEMM( 'No Transpose', 'No Transpose', N, 2, 2, CONE, $ D( 1, J ), LDD, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), N ) CALL ZLACPY( 'Full', N, 2, ZWORK( IWRK ), N, D( 1, J ), $ LDD ) C C Similarly, update C. C C( J, J ) = DCONJG( ZWORK( IZ22 ) ) C( J+1, J ) = DCONJG( ZWORK( IZ22+2 ) ) C( J, J+1 ) = CZERO C( J+1, J+1 ) = DCONJG( ZWORK( IZ22+3 ) ) CALL ZGEMM( 'No Transpose', 'No Transpose', N-J-1, 2, 2, $ CONE, C( JP2, J ), LDC, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), NJ1 ) CALL ZLACPY( 'Full', N-J-1, 2, ZWORK( IWRK ), NJ1, $ C( JP2, J ), LDC ) C C Update a panel of B. C CALL ZGEMM( 'No Transpose', 'No Transpose', J-1, 2, 2, $ CONE, B( 1, J ), LDB, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), JM1 ) CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, B( 1, J ), $ LDB ) CALL ZLACPY( 'Upper', 2, 2, ZWORK( IB ), 2, B( J, J ), $ LDB ) B( J+1, J ) = CZERO CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, NC, $ 2, CONE, ZWORK( IQ2 ), 2, B( J, JP2 ), LDB, $ CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, B( J, JP2 ), $ LDB ) C C Update a panel of F. C TMP = FG( J+1, J ) FG( J+1, J ) = -FG( J, J+1 ) CALL ZGEMM( 'No Transpose', 'No Transpose', J+1, 2, 2, $ CONE, FG( 1, J ), LDFG, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), J+1 ) CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, FG( 1, J ), $ LDFG ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ J2-J+1, 2, CONE, ZWORK( IQ2 ), 2, FG( J, J ), $ LDFG, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2, $ FG( J, J ), LDFG ) FG( J+1, J ) = TMP C IF( LCMPQ ) THEN C C Update Q. C CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, $ CONE, Q( 1, J ), LDQ, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, $ Q( 1, J ), LDQ ) CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, $ CONE, Q( 1, N+J ), LDQ, ZWORK( IQ2 ), 2, $ CZERO, ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, $ Q( 1, N+J ), LDQ ) END IF C IF( LCMPU ) THEN C C Update U. C CALL ZGEMM( 'No Transpose', 'No Transpose', N, 2, 2, $ CONE, U( 1, J ), LDU, ZWORK( IU ), 2, CZERO, $ ZWORK( IWRK ), N ) CALL ZLACPY( 'Full', N, 2, ZWORK( IWRK ), N, U( 1, J ), $ LDU ) CALL ZGEMM( 'No Transpose', 'No Transpose', N, 2, 2, $ CONE, U( 1, N+J ), LDU, ZWORK( IU ), 2, $ CZERO, ZWORK( IWRK ), N ) CALL ZLACPY( 'Full', N, 2, ZWORK( IWRK ), N, U( 1, N+J ), $ LDU ) END IF C C Save the needed transformations. C BWORK( J ) = .TRUE. J = J + 2 CALL ZLACPY( 'Full', 2, 2, ZWORK( IQ2 ), 2, ZWORK( IQB ), $ 2 ) CALL ZLACPY( 'Full', 2, 2, ZWORK( IU ), 2, ZWORK( IUB ), 2 ) IQB = IQB + 4 IUB = IUB + 4 ELSE BWORK( J ) = .FALSE. B( J+1, J ) = CZERO J = J + 1 END IF C IF( J.GE.J2 .AND. J.LE.N ) THEN IQB = IEV + 4 IUB = IQB + 4*M C C Start to update the next panel of Z, B, and F for previous C transformations on rows. C I = 1 J1 = J2 + 1 J2 = MIN( N, J1 + NB - 1 ) NC = J2 - J1 + 1 C WHILE( I.LT.J-1 ) DO 280 CONTINUE IF( I.LT.J-1 ) THEN IF( BWORK( I ) ) THEN CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IUB ), 2, Z( I, J1 ), $ LDZ, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ Z( I, J1 ), LDZ ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, B( I, J1 ), $ LDB, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ B( I, J1 ), LDB ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, $ FG( I, J1 ), LDFG, CZERO, ZWORK( IWRK ), $ 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ FG( I, J1 ), LDFG ) IQB = IQB + 4 IUB = IUB + 4 C I = I + 2 ELSE I = I + 1 END IF GO TO 280 END IF C END WHILE 280 END IF GO TO 270 END IF C END WHILE 270 C J1 = 1 J2 = MIN( N, NB ) C WHILE( MAX( J1, J2 ).LE.N ) DO 290 CONTINUE IF( MAX( J1, J2 ).LE.N ) THEN IQB = IEV + 4 IUB = IQB + 4*M C C Update the panel of columns J1 to J2 of D and C for the C transformations on rows. C I = 1 NC = J2 - J1 + 1 C WHILE( I.LT.N ) DO 300 CONTINUE IF( I.LT.N ) THEN IF( BWORK( I ) ) THEN CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IUB ), 2, D( I, J1 ), $ LDD, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, D( I, J1 ), $ LDD ) C IF( I.GT.J1 ) THEN J3 = MIN( NC, I - J1 ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ J3, 2, CONE, ZWORK( IUB ), 2, C( I, J1 ), $ LDC, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, J3, ZWORK( IWRK ), 2, $ C( I, J1 ), LDC ) END IF C IQB = IQB + 4 IUB = IUB + 4 C I = I + 2 ELSE I = I + 1 END IF GO TO 300 END IF C END WHILE 300 J1 = J2 + 1 J2 = MIN( N, J1 + NB - 1 ) GO TO 290 C END WHILE 290 END IF C C Scale B and F by -i. C DO 310 I = 1, N CALL ZSCAL( I, -CIMAG, B( 1, I ), 1 ) 310 CONTINUE C DO 320 I = 1, N CALL ZSCAL( I, -CIMAG, FG( 1, I ), 1 ) 320 CONTINUE C ZWORK( 1 ) = OPTZW DWORK( 1 ) = OPTDW IW1 = IWORK( 1 ) IW = IWORK( 2*IW1+4 ) K = 3*( N - 2*IW + 1 ) + 12*IW CALL DCOPY( K, DWORK( IS+1 ), 1, DWORK( 2 ), 1 ) C RETURN C *** Last line of MB04AZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03XP.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03XP.f0000644000175000017500000005326315012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE MB03XP( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, $ Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To compute the periodic Schur decomposition and the eigenvalues of C a product of matrices, H = A*B, with A upper Hessenberg and B C upper triangular without evaluating any part of the product. C Specifically, the matrices Q and Z are computed, so that C C Q' * A * Z = S, Z' * B * Q = T C C where S is in real Schur form, and T is upper triangular. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Indicates whether the user wishes to compute the full C Schur form or the eigenvalues only, as follows: C = 'E': Compute the eigenvalues only; C = 'S': compute the factors S and T of the full C Schur form. C C COMPQ CHARACTER*1 C Indicates whether or not the user wishes to accumulate C the matrix Q as follows: C = 'N': The matrix Q is not required; C = 'I': Q is initialized to the unit matrix and the C orthogonal transformation matrix Q is returned; C = 'V': Q must contain an orthogonal matrix U on entry, C and the product U*Q is returned. C C COMPZ CHARACTER*1 C Indicates whether or not the user wishes to accumulate C the matrix Z as follows: C = 'N': The matrix Z is not required; C = 'I': Z is initialized to the unit matrix and the C orthogonal transformation matrix Z is returned; C = 'V': Z must contain an orthogonal matrix U on entry, C and the product U*Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and B. N >= 0. C C ILO (input) INTEGER C IHI (input) INTEGER C It is assumed that the matrices A and B are already upper C triangular in rows and columns 1:ILO-1 and IHI+1:N. C The routine works primarily with the submatrices in rows C and columns ILO to IHI, but applies the transformations to C all the rows and columns of the matrices A and B, if C JOB = 'S'. C 1 <= ILO <= max(1,N+1); min(ILO,N) <= IHI <= N. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading N-by-N part of this array A must C contain the upper Hessenberg matrix A. C On exit, if JOB = 'S', the leading N-by-N part of this C array is upper quasi-triangular with any 2-by-2 diagonal C blocks corresponding to a pair of complex conjugated C eigenvalues. C If JOB = 'E', the diagonal elements and 2-by-2 diagonal C blocks of A will be correct, but the remaining parts of A C are unspecified on exit. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) C On entry, the leading N-by-N part of this array B must C contain the upper triangular matrix B. C On exit, if JOB = 'S', the leading N-by-N part of this C array contains the transformed upper triangular matrix. C 2-by-2 blocks in B corresponding to 2-by-2 blocks in A C will be reduced to positive diagonal form. (I.e., if C A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) C and B(j+1,j+1) will be positive.) C If JOB = 'E', the elements corresponding to diagonal C elements and 2-by-2 diagonal blocks in A will be correct, C but the remaining parts of B are unspecified on exit. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, if COMPQ = 'V', then the leading N-by-N part of C this array must contain a matrix Q which is assumed to be C equal to the unit matrix except for the submatrix C Q(ILO:IHI,ILO:IHI). C If COMPQ = 'I', Q need not be set on entry. C On exit, if COMPQ = 'V' or COMPQ = 'I' the leading N-by-N C part of this array contains the transformation matrix C which produced the Schur form. C If COMPQ = 'N', Q is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= 1. C If COMPQ <> 'N', LDQ >= MAX(1,N). C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C On entry, if COMPZ = 'V', then the leading N-by-N part of C this array must contain a matrix Z which is assumed to be C equal to the unit matrix except for the submatrix C Z(ILO:IHI,ILO:IHI). C If COMPZ = 'I', Z need not be set on entry. C On exit, if COMPZ = 'V' or COMPZ = 'I' the leading N-by-N C part of this array contains the transformation matrix C which produced the Schur form. C If COMPZ = 'N', Z is not referenced. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= 1. C If COMPZ <> 'N', LDZ >= MAX(1,N). 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 The i-th (1 <= i <= N) computed eigenvalue is given by C BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two C eigenvalues are computed as a complex conjugate pair, C they are stored in consecutive elements of ALPHAR, ALPHAI C and BETA. If JOB = 'S', the eigenvalues are stored in the C same order as on the diagonales of the Schur forms of A C and B. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -19, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,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 > 0: if INFO = i, then MB03XP failed to compute the Schur C form in a total of 30*(IHI-ILO+1) iterations; C elements 1:ilo-1 and i+1:n of ALPHAR, ALPHAI and C BETA contain successfully computed eigenvalues. C C METHOD C C The implemented algorithm is a multi-shift version of the periodic C QR algorithm described in [1,3] with some minor modifications C proposed in [2]. C C REFERENCES C C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. C The periodic Schur decomposition: Algorithms and applications. C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, C 1992. C C [2] Kressner, D. C An efficient and reliable implementation of the periodic QZ C algorithm. Proc. of the IFAC Workshop on Periodic Control C Systems, pp. 187-192, 2001. C C [3] Van Loan, C. C Generalized Singular Values with Algorithms and Applications. C Ph. D. Thesis, University of Michigan, 1973. C C NUMERICAL ASPECTS C C The algorithm requires O(N**3) floating point operations and is C backward stable. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHGPQR). C V. Sima, Oct. 2011, April 2015. C C KEYWORDS C C Eigenvalue, eigenvalue decomposition, Hessenberg form, orthogonal C transformation, (periodic) Schur form C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) INTEGER NSMAX, LDAS, LDBS PARAMETER ( NSMAX = 15, LDAS = NSMAX, LDBS = NSMAX ) C .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOB INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDWORK, LDZ, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), $ BETA(*), DWORK(*), Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. LOGICAL INITQ, INITZ, WANTQ, WANTT, WANTZ INTEGER DUM, I, I1, I2, IERR, ITEMP, ITN, ITS, J, K, $ KK, L, MAXB, NH, NR, NS, NV, PV2, PV3 DOUBLE PRECISION OVFL, SMLNUM, TAUV, TAUW, TEMP, TST, ULP, UNFL C .. Local Arrays .. INTEGER ISEED(4) DOUBLE PRECISION AS(LDAS,LDAS), BS(LDBS,LDBS), V(3*NSMAX+6) C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, UE01MD DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS, IDAMAX, LSAME, UE01MD C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLABAD, DLACPY, DLARFG, $ DLARFX, DLARNV, DLASET, DSCAL, DTRMV, MB03YA, $ MB03YD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN C C .. Executable Statements .. C C Decode the scalar input parameters. C WANTT = LSAME( JOB, 'S' ) INITQ = LSAME( COMPQ, 'I' ) WANTQ = INITQ.OR.LSAME( COMPQ, 'V' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = INITZ.OR.LSAME( COMPZ, 'V' ) C C Check the scalar input parameters. C INFO = 0 IF ( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN INFO = -1 ELSE IF ( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -2 ELSE IF ( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN INFO = -3 ELSE IF ( N.LT.0 ) THEN INFO = -4 ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N+1 ) ) THEN INFO = -5 ELSE IF ( IHI.LT.MIN( ILO,N ).OR.IHI.GT.N ) 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 ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN INFO = -12 ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN INFO = -14 ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN DWORK(1) = DBLE( MAX( 1, N ) ) INFO = -19 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03XP', -INFO ) RETURN END IF C C Initialize Q and Z, if necessary. C IF ( INITQ ) $ CALL DLASET( 'All', N, N, ZERO, ONE, Q, LDQ ) IF ( INITZ ) $ CALL DLASET( 'All', N, N, ZERO, ONE, Z, LDZ ) C C Store isolated eigenvalues and standardize B. C C FOR I = [1:ILO-1, IHI+1:N] I = 1 10 CONTINUE IF ( I.EQ.ILO ) THEN I = IHI + 1 END IF IF ( I.LE.N ) THEN IF ( B(I,I).LT.ZERO ) THEN IF ( .NOT.WANTT ) THEN B(I,I) = -B(I,I) A(I,I) = -A(I,I) END IF END IF ALPHAR(I) = A(I,I) ALPHAI(I) = ZERO BETA(I) = B(I,I) I = I + 1 C END FOR GO TO 10 END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. ILO.EQ.IHI+1 ) THEN DWORK(1) = ONE RETURN END IF C C Set rows and coloms ILO to IHI of B (A) to zero below the first C (sub)diagonal. C DO 60 J = ILO, IHI - 2 DO 50 I = J + 2, N A(I,J) = ZERO 50 CONTINUE 60 CONTINUE DO 80 J = ILO, IHI - 1 DO 70 I = J + 1, N B(I,J) = ZERO 70 CONTINUE 80 CONTINUE NH = IHI - ILO + 1 C C Suboptimal choice of the number of shifts. C IF ( WANTQ ) THEN NS = UE01MD( 4, 'MB03XP', JOB // COMPQ, N, ILO, IHI ) MAXB = UE01MD( 8, 'MB03XP', JOB // COMPQ, N, ILO, IHI ) ELSE NS = UE01MD( 4, 'MB03XP', JOB // COMPZ, N, ILO, IHI ) MAXB = UE01MD( 8, 'MB03XP', JOB // COMPZ, N, ILO, IHI ) END IF C IF ( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN C C Standard double-shift product QR. C CALL MB03YD( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILO, IHI, A, $ LDA, B, LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, $ DWORK, LDWORK, INFO ) RETURN END IF MAXB = MAX( 3, MAXB ) NS = MIN( NS, MAXB, NSMAX ) C C Set machine-dependent constants for the stopping criterion. C If max(norm(A),norm(B)) <= sqrt(OVFL), then overflow should not C occur. C UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( DBLE( NH ) / ULP ) C C I1 and I2 are the indices of the first rows and last columns of C A and B to which transformations must be applied. C IF ( WANTT ) THEN I1 = 1 I2 = N END IF ISEED(1) = 1 ISEED(2) = 0 ISEED(3) = 0 ISEED(4) = 1 C C ITN is the maximal number of QR iterations. C ITN = 30*NH DUM = 0 C C Main loop. Eigenvalues I+1:IHI have converged. Either L = ILO C or A(L,L-1) is negligible. C I = IHI 90 CONTINUE L = ILO IF ( I.LT.ILO ) $ GO TO 210 C DO 190 ITS = 0, ITN DUM = DUM + (IHI-ILO)*(IHI-ILO) C C Look for deflations in A. C DO 100 K = I, L + 1, -1 TST = ABS( A(K-1,K-1) ) + ABS( A(K,K) ) IF ( TST.EQ.ZERO ) $ TST = DLANHS( '1', I-L+1, A(L,L), LDA, DWORK ) IF ( ABS( A(K,K-1) ).LE.MAX( ULP*TST, SMLNUM ) ) $ GO TO 110 100 CONTINUE 110 CONTINUE C C Look for deflation in B if problem size is greater than 1. C IF ( I-K.GE.1 ) THEN DO 120 KK = I, K, -1 IF ( KK.EQ.I ) THEN TST = ABS( B(KK-1,KK) ) ELSE IF ( KK.EQ.K ) THEN TST = ABS( B(KK,KK+1) ) ELSE TST = ABS( B(KK-1,KK) ) + ABS( B(KK,KK+1) ) END IF IF ( TST.EQ.ZERO ) $ TST = DLANHS( '1', I-K+1, B(K,K), LDB, DWORK ) IF ( ABS( B(KK,KK) ).LE.MAX( ULP*TST, SMLNUM ) ) $ GO TO 130 120 CONTINUE ELSE KK = K-1 END IF 130 CONTINUE IF ( KK.GE.K ) THEN C C B has an element close to zero at position (KK,KK). C B(KK,KK) = ZERO CALL MB03YA( WANTT, WANTQ, WANTZ, N, K, I, ILO, IHI, KK, $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) K = KK+1 END IF L = K IF( L.GT.ILO ) THEN C C A(L,L-1) is negligible. C A(L,L-1) = ZERO END IF C C Exit from loop if a submatrix of order <= MAXB has split off. C IF ( L.GE.I-MAXB+1 ) $ GO TO 200 C C The active submatrices are now in rows and columns L:I. C IF ( .NOT.WANTT ) THEN I1 = L I2 = I END IF IF ( ITS.EQ.10.OR.ITS.EQ.20 ) THEN C C Exceptional shift. The first column of the shift polynomial C is a pseudo-random vector. C CALL DLARNV( 3, ISEED, NS+1, V ) ELSE C C Use eigenvalues of trailing submatrix as shifts. C CALL DLACPY( 'Full', NS, NS, A(I-NS+1,I-NS+1), LDA, AS, $ LDAS ) CALL DLACPY( 'Full', NS, NS, B(I-NS+1,I-NS+1), LDB, BS, $ LDBS ) CALL MB03YD( .FALSE., .FALSE., .FALSE., NS, 1, NS, 1, NS, $ AS, LDAS, BS, LDBS, Q, LDQ, Z, LDZ, $ ALPHAR(I-NS+1), ALPHAI(I-NS+1), BETA(I-NS+1), $ DWORK, LDWORK, IERR ) END IF C C Compute the nonzero elements of the first column of C (A*B-w(1)) (A*B-w(2)) .. (A*B-w(ns)). C V(1) = ONE NV = 1 C WHILE NV <= NS 140 CONTINUE IF ( NV.LE.NS ) THEN IF ( NV.EQ.NS .OR. AS(NV+1,NV).EQ.ZERO ) THEN C C Real shift. C V(NV+1) = ZERO PV2 = NV+2 CALL DCOPY( NV, V, 1, V(PV2), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', $ NV, B(L,L), LDB, V(PV2), 1 ) CALL DSCAL( NV, BS(NV,NV), V, 1 ) ITEMP = IDAMAX( 2*NV+1, V, 1 ) TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) CALL DSCAL( 2*NV+1, TEMP, V, 1 ) CALL DGEMV( 'No transpose', NV+1, NV, ONE, A(L,L), LDA, $ V(PV2), 1, -AS(NV,NV), V, 1 ) NV = NV + 1 ELSE C C Double shift using a product formulation of the shift C polynomial [2]. C V(NV+1) = ZERO V(NV+2) = ZERO PV2 = NV+3 PV3 = 2*NV+5 CALL DCOPY( NV+2, V, 1, V(PV2), 1 ) CALL DCOPY( NV+1, V, 1, V(PV3), 1 ) CALL DSCAL( NV, BS(NV+1,NV+1), V(PV2), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', $ NV, B(L,L), LDB, V(PV3), 1 ) ITEMP = IDAMAX( 2*NV+3, V(PV2), 1 ) TEMP = ONE / MAX( ABS( V(PV2+ITEMP-1) ), SMLNUM ) CALL DSCAL( 2*NV+3, TEMP, V(PV2), 1 ) C CALL DCOPY( NV, V(PV2), 1, V, 1 ) CALL DGEMV( 'No transpose', NV+1, NV, -ONE, A(L,L), LDA, $ V(PV3), 1, AS(NV+1,NV+1), V(PV2), 1 ) CALL DSCAL( NV, AS(NV,NV+1), V, 1 ) ITEMP = IDAMAX( 2*NV+3, V, 1 ) TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) CALL DSCAL( 2*NV+3, TEMP, V, 1 ) C CALL DSCAL( NV, -AS(NV+1,NV), V, 1 ) CALL DAXPY( NV+1, AS(NV,NV), V(PV2), 1, V, 1) ITEMP = IDAMAX( 2*NV+3, V, 1 ) TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) CALL DSCAL( 2*NV+3, TEMP, V, 1 ) C CALL DSCAL( NV+1, BS(NV,NV), V, 1 ) CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', $ NV+1, B(L,L), LDB, V(PV2), 1 ) ITEMP = IDAMAX( 2*NV+3, V, 1 ) TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) CALL DSCAL( 2*NV+3, TEMP, V, 1 ) C CALL DGEMV( 'No transpose', NV+2, NV+1, -ONE, A(L,L), $ LDA, V(PV2), 1, ONE, V, 1 ) NV = NV + 2 END IF ITEMP = IDAMAX( NV, V, 1 ) TEMP = ABS( V(ITEMP) ) IF ( TEMP.EQ.ZERO ) THEN V(1) = ONE DO 150 K = 2, NV V(K) = ZERO 150 CONTINUE ELSE TEMP = MAX( TEMP, SMLNUM ) CALL DSCAL( NV, ONE/TEMP, V, 1 ) END IF GO TO 140 C END WHILE END IF C C Multi-shift product QR step. C PV2 = NS+2 DO 180 K = L,I-1 NR = MIN( NS+1,I-K+1 ) IF ( K.GT.L ) $ CALL DCOPY( NR, A(K,K-1), 1, V, 1 ) CALL DLARFG( NR, V(1), V(2), 1, TAUV ) IF ( K.GT.L ) THEN A(K,K-1) = V(1) DO 160 KK = K+1,I A(KK,K-1) = ZERO 160 CONTINUE END IF C C Apply reflector V from the right to B in rows C I1:min(K+NS,I). C V(1) = ONE CALL DLARFX( 'Right', MIN(K+NS,I)-I1+1, NR, V, TAUV, $ B(I1,K), LDB, DWORK ) C C Annihilate the introduced nonzeros in the K-th column. C CALL DCOPY( NR, B(K,K), 1, V(PV2), 1 ) CALL DLARFG( NR, V(PV2), V(PV2+1), 1, TAUW ) B(K,K) = V(PV2) DO 170 KK = K+1,I B(KK,K) = ZERO 170 CONTINUE V(PV2) = ONE C C Apply reflector W from the left to transform the rows of the C matrix B in columns K+1:I2. C CALL DLARFX( 'Left', NR, I2-K, V(PV2), TAUW, B(K,K+1), LDB, $ DWORK ) C C Apply reflector V from the left to transform the rows of the C matrix A in columns K:I2. C CALL DLARFX( 'Left', NR, I2-K+1, V, TAUV, A(K,K), LDA, $ DWORK ) C C Apply reflector W from the right to transform the columns of C the matrix A in rows I1:min(K+NS,I). C CALL DLARFX( 'Right', MIN(K+NS+1,I)-I1+1, NR, V(PV2), TAUW, $ A(I1,K), LDA, DWORK ) C C Accumulate transformations in the matrices Q and Z. C IF ( WANTQ ) $ CALL DLARFX( 'Right', NH, NR, V, TAUV, Q(ILO,K), LDQ, $ DWORK ) IF ( WANTZ ) $ CALL DLARFX( 'Right', NH, NR, V(PV2), TAUW, Z(ILO,K), $ LDZ, DWORK ) 180 CONTINUE 190 CONTINUE C C Failure to converge. C INFO = I RETURN 200 CONTINUE C C Submatrix of order <= MAXB has split off. Use double-shift C periodic QR algorithm. C CALL MB03YD( WANTT, WANTQ, WANTZ, N, L, I, ILO, IHI, A, LDA, B, $ LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, $ LDWORK, INFO ) IF ( INFO.GT.0 ) $ RETURN ITN = ITN - ITS I = L - 1 GO TO 90 C 210 CONTINUE DWORK(1) = DBLE( MAX( 1,N ) ) RETURN C *** Last line of MB03XP *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03BU.f0000644000000000000000000000013215012430707016200 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SG03BU.f0000644000175000017500000006076015012430707017405 0ustar00lilgelilge00000000000000 SUBROUTINE SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, $ INFO ) C C PURPOSE C C To compute the Cholesky factor U of the matrix X, X = U**T * U or C X = U * U**T, which is the solution of the generalized d-stable C discrete-time Lyapunov equation C C T T 2 T C A * X * A - E * X * E = - SCALE * B * B, (1) C C or the transposed equation C C T T 2 T C A * X * A - E * X * E = - SCALE * B * B , (2) C C respectively, where A, E, B, and U are real N-by-N matrices. The C Cholesky factor U of the solution is computed without first C finding X. The pencil A - lambda * E must be in generalized Schur C form ( A upper quasitriangular, E upper triangular ). Moreover, it C must be d-stable, i.e., the moduli of its eigenvalues must be less C than one. B must be an upper triangular matrix with non-negative C entries on its main diagonal. C C The resulting matrix U is upper triangular. The entries on its C main diagonal are non-negative. SCALE is an output scale factor C set to avoid overflow in U. C C ARGUMENTS C C Mode Parameters C C TRANS CHARACTER*1 C Specifies whether equation (1) or equation (2) is to be C solved: 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 matrices. 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. The elements C below the upper Hessenberg part are not referenced. 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 triangular matrix E. The elements below C the main diagonal are not referenced. C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the matrix B. C On exit, the leading N-by-N upper triangular part of this C array contains the solution matrix U. The elements below C the main diagonal are not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,N). C C SCALE (output) DOUBLE PRECISION C The scale factor set to avoid overflow in U. C 0 < SCALE <= 1. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (6*N-6) 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 generalized Sylvester equation to be solved in C step II (see METHOD) is (nearly) singular to working C precision; perturbed values were used to solve the C equation (but the matrices A and E are unchanged); C = 2: the generalized Schur form of the pencil C A - lambda * E contains a 2-by-2 main diagonal block C whose eigenvalues are not a pair of complex C conjugate numbers; C = 3: the pencil A - lambda * E is not d-stable, i.e., C there are eigenvalues outside the open unit circle; C = 4: the LAPACK routine DSYEVX utilized to factorize M3 C failed to converge. This error is unlikely to occur. C C METHOD C C The method [2] used by the routine is an extension of Hammarling's C algorithm [1] to generalized Lyapunov equations. C C We present the method for solving equation (1). Equation (2) can C be treated in a similar fashion. For simplicity, assume SCALE = 1. C C The matrix A is an upper quasitriangular matrix, i.e., it is a C block triangular matrix with square blocks on the main diagonal C and the block order at most 2. We use the following partitioning C for the matrices A, E, B and the solution matrix U C C ( A11 A12 ) ( E11 E12 ) C A = ( ), E = ( ), C ( 0 A22 ) ( 0 E22 ) C C ( B11 B12 ) ( U11 U12 ) C B = ( ), U = ( ). (3) C ( 0 B22 ) ( 0 U22 ) C C The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or C 2-by-2. C C We compute U11, U12**T, and U22 in three steps. C C Step I: C C From (1) and (3) we get the 1-by-1 or 2-by-2 equation C C T T T T C A11 * U11 * U11 * A11 - E11 * U11 * U11 * E11 C C T C = - B11 * B11. C C For brevity, details are omitted here. The technique for C computing U11 is similar to those applied to standard Lyapunov C equations in Hammarling's algorithm ([1], section 6). C C Furthermore, the auxiliary matrices M1 and M2 defined as C follows C C -1 -1 C M1 = U11 * A11 * E11 * U11 , C C -1 -1 C M2 = B11 * E11 * U11 , C C are computed in a numerically reliable way. C C Step II: C C We solve for U12**T the generalized Sylvester equation C C T T T T C A22 * U12 * M1 - E22 * U12 C C T T T T T C = - B12 * M2 + E12 * U11 - A12 * U11 * M1. C C Step III: C C One can show that C C T T T T C A22 * U22 * U22 * A22 - E22 * U22 * U22 * E22 = C C T T C - B22 * B22 - y * y (4) C C holds, where y is defined as follows C C T T T T C w = A12 * U11 + A22 * U12 , C C T C y = ( B12 w ) * M3EV, C C where M3EV is a matrix which fulfils C C ( I-M2*M2**T -M2*M1**T ) T C M3 = ( ) = M3EV * M3EV . C ( -M1*M2**T I-M1*M1**T ) C C M3 is positive semidefinite and its rank is equal to the size C of U11. Therefore, a matrix M3EV can be found by solving the C symmetric eigenvalue problem for M3 such that y consists of C either 1 or 2 rows. C C If B22_tilde is the square triangular matrix arising from the C QR-factorization C C ( B22_tilde ) ( B22 ) C Q * ( ) = ( ), C ( 0 ) ( y**T ) C C then C C T T T C - B22 * B22 - y * y = - B22_tilde * B22_tilde. C C Replacing the right hand side in (4) by the term C - B22_tilde**T * B22_tilde leads to a generalized Lyapunov C equation of lower dimension compared to (1). C C The solution U of the equation (1) can be obtained by recursive C application of the steps I to III. C C REFERENCES C C [1] Hammarling, S.J. C Numerical solution of the stable, non-negative definite C Lyapunov equation. C IMA J. Num. Anal., 2, pp. 303-323, 1982. 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 The routine requires 2*N**3 flops. Note that we count a single C floating point arithmetic operation as one flop. C C FURTHER COMMENTS C C The Lyapunov equation may be very ill-conditioned. In particular, C if the pencil A - lambda * E has a pair of almost reciprocal C eigenvalues, then the Lyapunov equation will be ill-conditioned. C Perturbed values were used to solve the equation. C A condition estimate can be obtained from the routine SG03AD. C When setting the error indicator INFO, the routine does not test C for near instability in the equation but only for exact C instability. C C CONTRIBUTOR C C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. C C REVISIONS C C Sep. 1998, Dec. 2021 (V. Sima). C C KEYWORDS C C Lyapunov equation C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION HALF, MONE, ONE, TWO, ZERO PARAMETER ( HALF = 0.5D+0, MONE = -1.0D0, ONE = 1.0D+0, $ TWO = 2.0D+0, ZERO = 0.0D+0 ) C .. Scalar Arguments .. CHARACTER TRANS DOUBLE PRECISION SCALE INTEGER INFO, LDA, LDB, LDE, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*) C .. Local Scalars .. DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, R, S, SCALE1, SMLNUM, T, $ UFLT, X INTEGER I, INFO1, J, KB, KH, KL, KL1, L, LDWS, M, UIIPT, $ WPT, YPT LOGICAL NOTRNS C .. Local Arrays .. DOUBLE PRECISION M1(2,2), M2(2,2), M3(4,4), M3C(4,4), M3EW(4), $ RW(32), TM(2,2), UI(2,2) INTEGER IW(24) C .. External Functions .. DOUBLE PRECISION DLAMCH LOGICAL LSAME EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, DLACPY, DLARTG, $ DLASCL, DLASET, DROT, DSCAL, DSYEVX, DSYRK, $ SG03BW, SG03BX, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT 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 ( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE INFO = 0 END IF IF ( INFO.NE.0 ) THEN CALL XERBLA( 'SG03BU', -INFO ) RETURN END IF C SCALE = ONE C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) UFLT = DLAMCH( 'S' ) SMLNUM = UFLT/EPS BIGNUM = ONE/SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) C C Set workspace pointers and leading dimension of matrices in the C workspace. C UIIPT = 1 WPT = 2*N-1 YPT = 4*N-3 LDWS = N-1 C IF ( NOTRNS ) THEN C C Solve equation (1). C C Main Loop. Compute block row U(KL:KH,KL:N). KB denotes the C number of rows in this block row. C KH = 0 C WHILE ( KH.LT.N ) DO 20 CONTINUE IF ( KH.LT.N ) THEN KL = KH + 1 IF ( KL.EQ.N ) THEN KH = N KB = 1 ELSE IF ( A(KL+1,KL).EQ.ZERO ) THEN KH = KL KB = 1 ELSE KH = KL + 1 KB = 2 END IF END IF C C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary C matrices M1 and M2. (For the moment the result C U(KL:KH,KL:KH) is stored in UI). C IF ( KB.EQ.1 ) THEN DELTA1 = E(KL,KL) T = ABS( A(KL,KL) ) X = MAX( DELTA1, T ) DELTA1 = DELTA1/X T = T/X IF ( DELTA1.LE.T ) THEN INFO = 3 RETURN END IF DELTA1 = SQRT( ONE - T )*SQRT( ONE + T )*X T = B(KL,KL)*SMLNUM IF ( T.GT.DELTA1 ) THEN SCALE1 = DELTA1/T SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) END IF C UI(1,1) = B(KL,KL)/DELTA1 M1(1,1) = A(KL,KL)/E(KL,KL) M2(1,1) = DELTA1/E(KL,KL) C ELSE C C If a pair of complex conjugate eigenvalues occurs, apply C (complex) Hammarling algorithm for the 2-by-2 problem. C CALL SG03BX( 'D', 'N', A(KL,KL), LDA, E(KL,KL), LDE, $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, $ INFO ) IF ( INFO.NE.0 ) $ RETURN IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) END IF END IF C IF ( KH.LT.N ) THEN C C STEP II: Compute U(KL:KH,KH+1:N) by solving a generalized C Sylvester equation. (For the moment the result C U(KL:KH,KH+1:N) is stored in the workspace.) C C Form right hand side of the Sylvester equation. C CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, B(KL,KH+1), $ LDB, M2, 2, ZERO, DWORK(UIIPT), LDWS ) CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, E(KL,KH+1), $ LDE, UI, 2, ONE, DWORK(UIIPT), LDWS ) CALL DGEMM( 'T', 'N', KB, KB, KB, ONE, UI, 2, M1, 2, $ ZERO, TM, 2 ) CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, A(KL,KH+1), $ LDA, TM, 2, ONE, DWORK(UIIPT), LDWS ) C C Solve generalized Sylvester equation. C CALL DLASET( 'A', KB, KB, ZERO, MONE, TM, 2 ) CALL SG03BW( 'N', N-KH, KB, A(KH+1,KH+1), LDA, M1, 2, $ E(KH+1,KH+1), LDE, TM, 2, DWORK(UIIPT), $ LDWS, SCALE1, INFO ) IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) CALL DSCAL( 4, SCALE1, UI, 1 ) END IF C C STEP III: Form the right hand side matrix C B(KH+1:N,KH+1:N) of the (smaller) Lyapunov C equation to be solved during the next pass of C the main loop. C C Compute auxiliary matrices M3 and Y. The factorization C M3 = M3C * M3C**T is found by solving the symmetric C eigenvalue problem. C CALL DLASET( 'U', 2*KB, 2*KB, ZERO, ONE, M3, 4 ) CALL DSYRK( 'U', 'N', KB, KB, MONE, M2, 2, ONE, M3, 4 ) CALL DGEMM( 'N', 'T', KB, KB, KB, MONE, M2, 2, M1, 2, $ ZERO, M3(1,KB+1), 4 ) CALL DSYRK( 'U', 'N', KB, KB, MONE, M1, 2, ONE, $ M3(KB+1,KB+1), 4 ) CALL DSYEVX( 'V', 'V', 'U', 2*KB, M3, 4, HALF, TWO, 1, 4, $ TWO*UFLT, M, M3EW, M3C, 4, RW, 32, IW(5), $ IW, INFO1 ) IF ( INFO1.NE.0 ) THEN INFO = 4 RETURN END IF CALL DGEMM( 'T', 'N', N-KH, KB, KB, ONE, B(KL,KH+1), LDB, $ M3C, 4, ZERO, DWORK(YPT), LDWS ) CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, A(KL,KH+1), LDA, $ UI, 2, ZERO, DWORK(WPT), LDWS ) DO 40 I = 1, N-KH CALL DGEMV( 'T', MIN( I+1, N-KH ), KB, ONE, $ DWORK(UIIPT), LDWS, A(KH+1,KH+I), 1, ONE, $ DWORK(WPT+I-1), LDWS ) 40 CONTINUE CALL DGEMM( 'N', 'N', N-KH, KB, KB, ONE, DWORK(WPT), $ LDWS, M3C(KB+1,1), 4, ONE, DWORK(YPT), LDWS ) C C Overwrite B(KH+1:N,KH+1:N) with the triangular matrix C from the QR-factorization of the (N-KH+KB)-by-(N-KH) C matrix C C ( B(KH+1:N,KH+1:N) ) C ( ) C ( Y**T ) . C L = YPT - 1 DO 80 J = 1, KB DO 60 I = 1, N-KH X = B(KH+I,KH+I) T = DWORK(L+I) CALL DLARTG( X, T, C, S, R ) B(KH+I,KH+I) = R IF ( I.LT.N-KH ) $ CALL DROT( N-KH-I, B(KH+I,KH+I+1), LDB, $ DWORK(L+I+1), 1, C, S ) 60 CONTINUE L = L + LDWS 80 CONTINUE C C Make main diagonal elements of B(KH+1:N,KH+1:N) positive. C DO 100 I = KH+1, N IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( N-I+1, MONE, B(I,I), LDB ) 100 CONTINUE C C Overwrite right hand side with the part of the solution C computed in step II. C CALL DCOPY( N-KH, DWORK(UIIPT), 1, B(KL,KH+1), LDB ) IF ( KH.GT.KL ) $ CALL DCOPY( N-KH, DWORK(UIIPT+LDWS), 1, B(KH,KH+1), $ LDB ) END IF C C Overwrite right hand side with the part of the solution C computed in step I. C CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) C GOTO 20 END IF C END WHILE 20 C ELSE C C Solve equation (2). C C Main Loop. Compute block column U(1:KH,KL:KH). KB denotes the C number of columns in this block column. C KL = N + 1 C WHILE ( KL.GT.1 ) DO 120 CONTINUE IF ( KL.GT.1 ) THEN KH = KL - 1 IF ( KH.EQ.1 ) THEN KL = 1 KB = 1 ELSE IF ( A(KH,KH-1).EQ.ZERO ) THEN KL = KH KB = 1 ELSE KL = KH - 1 KB = 2 END IF END IF KL1 = KL - 1 C C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary C matrices M1 and M2. (For the moment the result C U(KL:KH,KL:KH) is stored in UI). C IF ( KB.EQ.1 ) THEN DELTA1 = E(KL,KL) T = ABS( A(KL,KL) ) X = MAX( DELTA1, T ) DELTA1 = DELTA1/X T = T/X IF ( DELTA1.LE.T ) THEN INFO = 3 RETURN END IF DELTA1 = SQRT( ONE - T )*SQRT( ONE + T )*X T = B(KL,KL)*SMLNUM IF ( T.GT.DELTA1 ) THEN SCALE1 = DELTA1/T SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) END IF C UI(1,1) = B(KL,KL)/DELTA1 M1(1,1) = A(KL,KL)/E(KL,KL) M2(1,1) = DELTA1/E(KL,KL) C ELSE C C If a pair of complex conjugate eigenvalues occurs, apply C (complex) Hammarling algorithm for the 2-by-2 problem. C CALL SG03BX( 'D', 'T', A(KL,KL), LDA, E(KL,KL), LDE, $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, $ INFO ) IF ( INFO.NE.0 ) $ RETURN IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) END IF END IF C IF ( KL.GT.1 ) THEN C C STEP II: Compute U(1:KL-1,KL:KH) by solving a generalized C Sylvester equation. (For the moment the result C U(1:KL-1,KL:KH) is stored in the workspace.) C C Form right hand side of the Sylvester equation. C CALL DGEMM( 'N', 'T', KL1, KB, KB, MONE, B(1,KL), LDB, $ M2, 2, ZERO, DWORK(UIIPT), LDWS ) CALL DGEMM( 'N', 'N', KL1, KB, KB, ONE, E(1,KL), LDE, UI, $ 2, ONE, DWORK(UIIPT), LDWS ) CALL DGEMM( 'N', 'T', KB, KB, KB, ONE, UI, 2, M1, 2, $ ZERO, TM, 2 ) CALL DGEMM( 'N', 'N', KL1, KB, KB, MONE, A(1,KL), LDA, $ TM, 2, ONE, DWORK(UIIPT), LDWS ) C C Solve generalized Sylvester equation. C CALL DLASET( 'A', KB, KB, ZERO, MONE, TM, 2 ) CALL SG03BW( 'T', KL1, KB, A, LDA, M1, 2, E, LDE, TM, 2, $ DWORK(UIIPT), LDWS, SCALE1, INFO ) IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) CALL DSCAL( 4, SCALE1, UI, 1 ) END IF C C STEP III: Form the right hand side matrix C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov C equation to be solved during the next pass of C the main loop. C C Compute auxiliary matrices M3 and Y. The factorization C M3 = M3C * M3C**T is found by solving the symmetric C eigenvalue problem. C CALL DLASET( 'U', 2*KB, 2*KB, ZERO, ONE, M3, 4 ) CALL DSYRK( 'U', 'T', KB, KB, MONE, M2, 2, ONE, M3, 4 ) CALL DGEMM( 'T', 'N', KB, KB, KB, MONE, M2, 2, M1, 2, $ ZERO, M3(1,KB+1), 4 ) CALL DSYRK( 'U', 'T', KB, KB, MONE, M1, 2, ONE, $ M3(KB+1,KB+1), 4 ) CALL DSYEVX( 'V', 'V', 'U', 2*KB, M3, 4, HALF, TWO, 1, 4, $ TWO*UFLT, M, M3EW, M3C, 4, RW, 32, IW(5), $ IW, INFO1 ) IF ( INFO1.NE.0 ) THEN INFO = 4 RETURN END IF CALL DGEMM( 'N', 'N', KL1, KB, KB, ONE, B(1,KL), LDB, $ M3C, 4, ZERO, DWORK(YPT), LDWS ) CALL DGEMM( 'N', 'N', KL1, KB, KB, ONE, A(1,KL), LDA, UI, $ 2, ZERO, DWORK(WPT), LDWS ) DO 140 I = 1, KL1 CALL DGEMV( 'T', MIN( KL-I+1, KL1 ), KB, ONE, $ DWORK(MAX( UIIPT, UIIPT+I-2 )), LDWS, $ A(I,MAX( I-1, 1 )), LDA, ONE, $ DWORK(WPT+I-1), LDWS ) 140 CONTINUE CALL DGEMM( 'N', 'N', KL1, KB, KB, ONE, DWORK(WPT), LDWS, $ M3C(KB+1,1), 4, ONE, DWORK(YPT), LDWS ) C C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix C from the RQ-factorization of the (KL-1)-by-KH matrix C C ( ) C ( B(1:KL-1,1:KL-1) Y ) C ( ). C L = YPT - 1 DO 180 J = 1, KB DO 160 I = KL1, 1, -1 X = B(I,I) T = DWORK(L+I) CALL DLARTG( X, T, C, S, R ) B(I,I) = R IF ( I.GT.1 ) $ CALL DROT( I-1, B(1,I), 1, DWORK(L+1), 1, C, S ) 160 CONTINUE L = L + LDWS 180 CONTINUE C C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. C DO 200 I = 1, KL1 IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( I, MONE, B(1,I), 1 ) 200 CONTINUE C C Overwrite right hand side with the part of the solution C computed in step II. C CALL DLACPY( 'A', KL1, KB, DWORK(UIIPT), LDWS, B(1,KL), $ LDB ) C END IF C C Overwrite right hand side with the part of the solution C computed in step I. C CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) C GOTO 120 END IF C END WHILE 120 C END IF C RETURN C *** Last line of SG03BU *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10RD.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10RD.f0000644000175000017500000005617115012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, $ C, LDC, D, LDD, F, LDF, H, LDH, TU, LDTU, TY, $ LDTY, X, LDX, Y, LDY, AK, LDAK, BK, LDBK, CK, $ LDCK, DK, LDDK, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the matrices of an H-infinity (sub)optimal controller C C | AK | BK | C K = |----|----|, C | CK | DK | C C from the state feedback matrix F and output injection matrix H as C determined by the SLICOT Library routine SB10QD. 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 F (input) DOUBLE PRECISION array, dimension (LDF,N) C The leading M-by-N part of this array must contain the C state feedback matrix F. C C LDF INTEGER C The leading dimension of the array F. LDF >= max(1,M). C C H (input) DOUBLE PRECISION array, dimension (LDH,NP) C The leading N-by-NP part of this array must contain the C output injection matrix H. C C LDH INTEGER C The leading dimension of the array H. LDH >= max(1,N). C C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) C The leading M2-by-M2 part of this array must contain the C control transformation matrix TU, as obtained by the C SLICOT Library routine SB10PD. C C LDTU INTEGER C The leading dimension of the array TU. LDTU >= max(1,M2). C C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) C The leading NP2-by-NP2 part of this array must contain the C measurement transformation matrix TY, as obtained by the C SLICOT Library routine SB10PD. C C LDTY INTEGER C The leading dimension of the array TY. C LDTY >= max(1,NP2). C C X (input) DOUBLE PRECISION array, dimension (LDX,N) C The leading N-by-N part of this array must contain the C matrix X, solution of the X-Riccati equation, as obtained C by the SLICOT Library routine SB10QD. C C LDX INTEGER C The leading dimension of the array X. LDX >= max(1,N). C C Y (input) DOUBLE PRECISION array, dimension (LDY,N) C The leading N-by-N part of this array must contain the C matrix Y, solution of the Y-Riccati equation, as obtained C by the SLICOT Library routine SB10QD. C C LDY INTEGER C The leading dimension of the array Y. LDY >= max(1,N). 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 Workspace C C IWORK INTEGER array, dimension (LIWORK), where C LIWORK = max(2*(max(NP,M)-M2-NP2,M2,N),NP2) 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(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 where 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 max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, 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 controller is not admissible (too small value C of gamma); C = 2: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is zero. C C METHOD C C The routine implements the Glover's and Doyle's formulas [1],[2]. 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 NUMERICAL ASPECTS C C The accuracy of the result depends on the condition numbers of the C input and output transformations. 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, Oct. 2001. 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, LDF, LDH, LDTU, LDTY, LDWORK, LDX, LDY, $ M, N, NCON, NMEAS, NP DOUBLE PRECISION GAMMA 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( * ), $ F( LDF, * ), H( LDH, * ), TU( LDTU, * ), $ TY( LDTY, * ), X( LDX, * ), Y( LDY, * ) C .. C .. Local Scalars .. INTEGER I, ID11, ID12, ID21, IJ, INFO2, IW1, IW2, IW3, $ IW4, IWB, IWC, IWRK, J, LWAMAX, M1, M2, MINWRK, $ ND1, ND2, NP1, NP2 DOUBLE PRECISION ANORM, EPS, RCOND C .. C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE, DLANSY EXTERNAL DLAMCH, DLANGE, DLANSY C .. C .. External Subroutines .. EXTERNAL DGECON, DGEMM, DGETRF, DGETRI, DGETRS, DLACPY, $ DLASET, DPOTRF, DSYCON, DSYRK, DSYTRF, DSYTRS, $ DTRMM, MA02AD, MB01RX, 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.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( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN INFO = -20 ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN INFO = -22 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -24 ELSE IF( LDY.LT.MAX( 1, N ) ) THEN INFO = -26 ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN INFO = -28 ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN INFO = -30 ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN INFO = -32 ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN INFO = -34 ELSE C C Compute workspace. C ND1 = NP1 - M2 ND2 = M1 - NP2 MINWRK = 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 ) ) ) ) ) ) IF( LDWORK.LT.MINWRK ) $ INFO = -37 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10RD', -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 DWORK( 1 ) = ONE RETURN END IF C C Get the machine precision. C EPS = DLAMCH( 'Epsilon' ) C C Workspace usage. C ID11 = 1 ID21 = ID11 + M2*NP2 ID12 = ID21 + NP2*NP2 IW1 = ID12 + M2*M2 IW2 = IW1 + ND1*ND1 IW3 = IW2 + ND1*NP2 IWRK = IW2 C C Set D11HAT := -D1122 . C IJ = ID11 DO 20 J = 1, NP2 DO 10 I = 1, M2 DWORK( IJ ) = -D( ND1+I, ND2+J ) IJ = IJ + 1 10 CONTINUE 20 CONTINUE C C Set D21HAT := Inp2 . C CALL DLASET( 'Upper', NP2, NP2, ZERO, ONE, DWORK( ID21 ), NP2 ) C C Set D12HAT := Im2 . C CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( ID12 ), M2 ) C C Compute D11HAT, D21HAT, D12HAT . C LWAMAX = 0 IF( ND1.GT.0 ) THEN IF( ND2.EQ.0 ) THEN C C Compute D21HAT'*D21HAT = Inp2 - D1112'*D1112/gamma^2 . C CALL DSYRK( 'U', 'T', NP2, ND1, -ONE/GAMMA**2, D, LDD, ONE, $ DWORK( ID21 ), NP2 ) ELSE C C Compute gdum = gamma^2*Ind1 - D1111*D1111' . C CALL DLASET( 'U', ND1, ND1, ZERO, GAMMA**2, DWORK( IW1 ), $ ND1 ) CALL DSYRK( 'U', 'N', ND1, ND2, -ONE, D, LDD, ONE, $ DWORK( IW1 ), ND1 ) ANORM = DLANSY( 'I', 'U', ND1, DWORK( IW1 ), ND1, $ DWORK( IWRK ) ) CALL DSYTRF( 'U', ND1, DWORK( IW1 ), ND1, IWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 CALL DSYCON( 'U', ND1, DWORK( IW1 ), ND1, IWORK, ANORM, $ RCOND, DWORK( IWRK ), IWORK( ND1+1 ), INFO2 ) C C Return if the matrix is singular to working precision. C IF( RCOND.LT.EPS ) THEN INFO = 1 RETURN END IF C C Compute inv(gdum)*D1112 . C CALL DLACPY( 'Full', ND1, NP2, D( 1, ND2+1 ), LDD, $ DWORK( IW2 ), ND1 ) CALL DSYTRS( 'U', ND1, NP2, DWORK( IW1 ), ND1, IWORK, $ DWORK( IW2 ), ND1, INFO2 ) C C Compute D11HAT = -D1121*D1111'*inv(gdum)*D1112 - D1122 . C CALL DGEMM( 'T', 'N', ND2, NP2, ND1, ONE, D, LDD, $ DWORK( IW2 ), ND1, ZERO, DWORK( IW3 ), ND2 ) CALL DGEMM( 'N', 'N', M2, NP2, ND2, -ONE, D( ND1+1, 1 ), $ LDD, DWORK( IW3 ), ND2, ONE, DWORK( ID11 ), M2 ) C C Compute D21HAT'*D21HAT = Inp2 - D1112'*inv(gdum)*D1112 . C CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, ND1, ONE, $ -ONE, DWORK( ID21 ), NP2, D( 1, ND2+1 ), LDD, $ DWORK( IW2 ), ND1, INFO2 ) C IW2 = IW1 + ND2*ND2 IWRK = IW2 C C Compute gdum = gamma^2*Ind2 - D1111'*D1111 . C CALL DLASET( 'L', ND2, ND2, ZERO, GAMMA**2, DWORK( IW1 ), $ ND2 ) CALL DSYRK( 'L', 'T', ND2, ND1, -ONE, D, LDD, ONE, $ DWORK( IW1 ), ND2 ) ANORM = DLANSY( 'I', 'L', ND2, DWORK( IW1 ), ND2, $ DWORK( IWRK ) ) CALL DSYTRF( 'L', ND2, DWORK( IW1 ), ND2, IWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) CALL DSYCON( 'L', ND2, DWORK( IW1 ), ND2, IWORK, ANORM, $ RCOND, DWORK( IWRK ), IWORK( ND2+1 ), INFO2 ) C C Return if the matrix is singular to working precision. C IF( RCOND.LT.EPS ) THEN INFO = 1 RETURN END IF C C Compute inv(gdum)*D1121' . C CALL MA02AD( 'Full', M2, ND2, D( ND1+1, 1 ), LDD, $ DWORK( IW2 ), ND2 ) CALL DSYTRS( 'L', ND2, M2, DWORK( IW1 ), ND2, IWORK, $ DWORK( IW2 ), ND2, INFO2 ) C C Compute D12HAT*D12HAT' = Im2 - D1121*inv(gdum)*D1121' . C CALL MB01RX( 'Left', 'Lower', 'NoTranspose', M2, ND2, ONE, $ -ONE, DWORK( ID12 ), M2, D( ND1+1, 1 ), LDD, $ DWORK( IW2 ), ND2, INFO2 ) END IF ELSE IF( ND2.GT.0 ) THEN C C Compute D12HAT*D12HAT' = Im2 - D1121*D1121'/gamma^2 . C CALL DSYRK( 'L', 'N', M2, ND2, -ONE/GAMMA**2, D, LDD, ONE, $ DWORK( ID12 ), M2 ) END IF END IF C C Compute D21HAT using Cholesky decomposition. C CALL DPOTRF( 'U', NP2, DWORK( ID21 ), NP2, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF C C Compute D12HAT using Cholesky decomposition. C CALL DPOTRF( 'L', M2, DWORK( ID12 ), M2, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF C _ C Compute Z = In - Y*X/gamma^2 and its LU factorization in AK . C IWRK = IW1 CALL DLASET( 'Full', N, N, ZERO, ONE, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, N, -ONE/GAMMA**2, Y, LDY, X, LDX, $ ONE, AK, LDAK ) ANORM = DLANGE( '1', N, N, AK, LDAK, DWORK( IWRK ) ) CALL DGETRF( N, N, AK, LDAK, IWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF CALL DGECON( '1', N, AK, LDAK, ANORM, RCOND, DWORK( IWRK ), $ IWORK( N+1 ), INFO ) C C Return if the matrix is singular to working precision. C IF( RCOND.LT.EPS ) THEN INFO = 1 RETURN END IF C IWB = IW1 IWC = IWB + N*NP2 IW1 = IWC + ( M2 + NP2 )*N IW2 = IW1 + N*M2 C C Compute C2' + F12' in BK . C DO 40 J = 1, N DO 30 I = 1, NP2 BK( J, I ) = C( NP1 + I, J ) + F( ND2 + I, J ) 30 CONTINUE 40 CONTINUE C _ C Compute the transpose of (C2 + F12)*Z , with Z = inv(Z) . C CALL DGETRS( 'Transpose', N, NP2, AK, LDAK, IWORK, BK, LDBK, $ INFO2 ) C C Compute the transpose of F2*Z . C CALL MA02AD( 'Full', M2, N, F( M1+1, 1 ), LDF, DWORK( IW1 ), N ) CALL DGETRS( 'Transpose', N, M2, AK, LDAK, IWORK, DWORK( IW1 ), N, $ INFO2 ) C C Compute the transpose of C1HAT = F2*Z - D11HAT*(C2 + F12)*Z . C CALL DGEMM( 'N', 'T', N, M2, NP2, -ONE, BK, LDBK, DWORK( ID11 ), $ M2, ONE, DWORK( IW1 ), N ) C C Compute CHAT . C CALL DGEMM( 'N', 'T', M2, N, M2, ONE, TU, LDTU, DWORK( IW1 ), N, $ ZERO, DWORK( IWC ), M2+NP2 ) CALL MA02AD( 'Full', N, NP2, BK, LDBK, DWORK( IWC+M2 ), M2+NP2 ) CALL DTRMM( 'L', 'U', 'N', 'N', NP2, N, -ONE, DWORK( ID21 ), NP2, $ DWORK( IWC+M2 ), M2+NP2 ) C C Compute B2 + H12 . C IJ = IW2 DO 60 J = 1, M2 DO 50 I = 1, N DWORK( IJ ) = B( I, M1 + J ) + H( I, ND1 + J ) IJ = IJ + 1 50 CONTINUE 60 CONTINUE C C Compute A + HC in AK . C CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, NP, ONE, H, LDH, C, LDC, ONE, AK, $ LDAK ) C C Compute AHAT = A + HC + (B2 + H12)*C1HAT in AK . C CALL DGEMM( 'N', 'T', N, N, M2, ONE, DWORK( IW2 ), N, $ DWORK( IW1 ), N, ONE, AK, LDAK ) C C Compute B1HAT = -H2 + (B2 + H12)*D11HAT in BK . C CALL DLACPY( 'Full', N, NP2, H( 1, NP1+1 ), LDH, BK, LDBK ) CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, DWORK( IW2 ), N, $ DWORK( ID11 ), M2, -ONE, BK, LDBK ) C C Compute the first block of BHAT, BHAT1 . C CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO, $ DWORK( IWB ), N ) C C Compute Tu*D11HAT . C CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DWORK( ID11 ), $ M2, ZERO, DWORK( IW1 ), M2 ) C C Compute Tu*D11HAT*Ty in DK . C CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK( IW1 ), M2, TY, $ LDTY, ZERO, DK, LDDK ) C C Compute P = Im2 + Tu*D11HAT*Ty*D22 and its condition. C IW2 = IW1 + M2*NP2 IWRK = IW2 + M2*M2 CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) CALL DGEMM( 'N', 'N', M2, M2, NP2, ONE, DK, LDDK, $ D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 ) ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 2 RETURN END IF CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND, $ DWORK( IWRK ), IWORK( M2+1 ), INFO2 ) C C Return if the matrix is singular to working precision. C IF( RCOND.LT.EPS ) THEN INFO = 2 RETURN END IF C C Find the controller matrix CK, CK = inv(P)*CHAT(1:M2,:) . C CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) CALL DGETRS( 'NoTranspose', M2, N, DWORK( IW2 ), M2, IWORK, CK, $ LDCK, INFO2 ) C C Find the controller matrices AK, BK, and DK, exploiting the C special structure of the relations. C C Compute Q = Inp2 + D22*Tu*D11HAT*Ty and its LU factorization. C IW3 = IW2 + NP2*NP2 IW4 = IW3 + NP2*M2 IWRK = IW4 + NP2*NP2 CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 ) CALL DGEMM( 'N', 'N', NP2, NP2, M2, ONE, D( NP1+1, M1+1 ), LDD, $ DK, LDDK, ONE, DWORK( IW2 ), NP2 ) CALL DGETRF( NP2, NP2, DWORK( IW2 ), NP2, IWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 2 RETURN END IF C C Compute A1 = inv(Q)*D22 and inv(Q) . C CALL DLACPY( 'Full', NP2, M2, D( NP1+1, M1+1 ), LDD, DWORK( IW3 ), $ NP2 ) CALL DGETRS( 'NoTranspose', NP2, M2, DWORK( IW2 ), NP2, IWORK, $ DWORK( IW3 ), NP2, INFO2 ) CALL DGETRI( NP2, DWORK( IW2 ), NP2, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO2 ) LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Compute A2 = ( inv(Ty) - inv(Q)*inv(Ty) - C A1*Tu*D11HAT )*inv(D21HAT) . C CALL DLACPY( 'Full', NP2, NP2, TY, LDTY, DWORK( IW4 ), NP2 ) CALL DGETRF( NP2, NP2, DWORK( IW4 ), NP2, IWORK, INFO2 ) CALL DGETRI( NP2, DWORK( IW4 ), NP2, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO2 ) C CALL DLACPY( 'Full', NP2, NP2, DWORK( IW4 ), NP2, DWORK( IWRK ), $ NP2 ) CALL DGEMM( 'N', 'N', NP2, NP2, NP2, -ONE, DWORK( IW2), NP2, $ DWORK( IWRK ), NP2, ONE, DWORK( IW4 ), NP2 ) CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, DWORK( IW3), NP2, $ DWORK( IW1 ), M2, ONE, DWORK( IW4 ), NP2 ) CALL DTRMM( 'R', 'U', 'N', 'N', NP2, NP2, ONE, DWORK( ID21 ), NP2, $ DWORK( IW4 ), NP2 ) C C Compute [ A1 A2 ]*CHAT . C CALL DGEMM( 'N', 'N', NP2, N, M2+NP2, ONE, DWORK( IW3 ), NP2, $ DWORK( IWC ), M2+NP2, ZERO, DWORK( IWRK ), NP2 ) C C Compute AK := AHAT - BHAT1*[ A1 A2 ]*CHAT . C CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, DWORK( IWB ), N, $ DWORK( IWRK ), NP2, ONE, AK, LDAK ) C C Compute BK := BHAT1*inv(Q) . C CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, DWORK( IWB ), N, $ DWORK( IW2 ), NP2, ZERO, BK, LDBK ) C C Compute DK := Tu*D11HAT*Ty*inv(Q) . C CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DK, LDDK, DWORK( IW2 ), $ NP2, ZERO, DWORK( IW3 ), M2 ) CALL DLACPY( 'Full', M2, NP2, DWORK( IW3 ), M2, DK, LDDK ) C DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10RD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03BZ.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03BZ.f0000644000175000017500000012071215012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE MB03BZ( JOB, COMPQ, K, N, ILO, IHI, S, A, LDA1, LDA2, $ Q, LDQ1, LDQ2, ALPHA, BETA, SCAL, DWORK, $ LDWORK, ZWORK, LZWORK, INFO ) C C PURPOSE C C To find the eigenvalues of the complex generalized matrix product C C S(1) S(2) S(K) C A(:,:,1) * A(:,:,2) * ... * A(:,:,K) , S(1) = 1, C C where A(:,:,1) is upper Hessenberg and A(:,:,i) is upper C triangular, i = 2, ..., K, using a single-shift version of the C periodic QZ method. In addition, A may be reduced to periodic C Schur form by unitary transformations: all factors A(:,:,i) become C upper triangular. C C If COMPQ = 'V' or COMPQ = 'I', then the unitary factors are C computed and stored in the array Q so that for S(I) = 1, C C H C Q(:,:,I)(in) A(:,:,I)(in) Q(:,:,MOD(I,K)+1)(in) C H (1) C = Q(:,:,I)(out) A(:,:,I)(out) Q(:,:,MOD(I,K)+1)(out), C C and for S(I) = -1, C C H C Q(:,:,MOD(I,K)+1)(in) A(:,:,I)(in) Q(:,:,I)(in) C H (2) C = Q(:,:,MOD(I,K)+1)(out) A(:,:,I)(out) Q(:,:,I)(out). C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; A will not C necessarily be put into periodic Schur form; C = 'S': put A into periodic Schur form, and return the C eigenvalues in ALPHA, BETA, and SCAL. C C COMPQ CHARACTER*1 C Specifies whether or not the unitary transformations C should be accumulated in the array Q, as follows: C = 'N': do not modify Q; C = 'V': modify the array Q by the unitary transformations C that are applied to the matrices in the array A to C reduce them to periodic Schur form; C = 'I': like COMPQ = 'V', except that each matrix in the C array Q will be first initialized to the identity C matrix. C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of each factor in the array A. N >= 0. C C ILO (input) INTEGER C IHI (input) INTEGER C It is assumed that each factor in A is already upper C triangular in rows and columns 1:ILO-1 and IHI+1:N. C 1 <= ILO <= IHI <= N, if N > 0; C ILO = 1 and IHI = 0, if N = 0. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures of the factors. Each entry in S must be either C 1 or -1. By definition, S(1) must be set to 1. C C A (input/output) COMPLEX*16 array, dimension (LDA1,LDA2,K) C On entry, the leading N-by-N-by-K part of this array C must contain the factors in upper Hessenberg-triangular C form, that is, A(:,:,1) is upper Hessenberg and the other C factors are upper triangular. C On exit, if JOB = 'S' and INFO = 0, the leading C N-by-N-by-K part of this array contains the factors of C A in periodic Schur form. All factors are reduced to C upper triangular form and, moreover, A(:,:,2), ..., C A(:,:,K) are normalized so that their diagonals contain C nonnegative real numbers. C On exit, if JOB = 'E', then the leading N-by-N-by-K part C of this array contains meaningless elements. C C LDA1 INTEGER C The first leading dimension of the array A. C LDA1 >= MAX(1,N). C C LDA2 INTEGER C The second leading dimension of the array A. C LDA2 >= MAX(1,N). C C Q (input/output) COMPLEX*16 array, dimension (LDQ1,LDQ2,K) C On entry, if COMPQ = 'V', the leading N-by-N-by-K part C of this array must contain the initial unitary factors C as described in (1) and (2). C On exit, if COMPQ = 'V' or COMPQ = 'I', the leading C N-by-N-by-K part of this array contains the modified C unitary factors as described in (1) and (2). C This array is not referenced if COMPQ = 'N'. C C LDQ1 INTEGER C The first leading dimension of the array Q. LDQ1 >= 1, C and, if COMPQ <> 'N', LDQ1 >= MAX(1,N). C C LDQ2 INTEGER C The second leading dimension of the array Q. LDQ2 >= 1, C and, if COMPQ <> 'N', LDQ2 >= MAX(1,N). C C ALPHA (output) COMPLEX*16 array, dimension (N) C On exit, if INFO = 0, the leading N elements of this C array contain the scaled eigenvalues of the matrix C product A. The i-th eigenvalue of A is given by C C ALPHA(I) / BETA(I) * BASE**(SCAL(I)), C C where ABS(ALPHA(I)) = 0.0 or 1.0 <= ABS(ALPHA(I)) < BASE, C and BASE is the machine base (normally 2.0). C C BETA (output) COMPLEX*16 array, dimension (N) C On exit, if INFO = 0, the leading N elements of this C array contain indicators for infinite eigenvalues. That C is, if BETA(I) = 0.0, then the i-th eigenvalue is C infinite. Otherwise BETA(I) is set to 1.0. C C SCAL (output) INTEGER array, dimension (N) C On exit, if INFO = 0, the leading N elements of this C array contain the scaling parameters for the eigenvalues C of A. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the minimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,N). C C ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the minimal value C of LZWORK. C C LZWORK INTEGER C The length of the array ZWORK. LZWORK >= MAX(1,N). C C Error Indicator C C INFO INTEGER C = 0 : succesful exit; C < 0 : if INFO = -i, the i-th argument had an illegal C value; C = 1,..,N : the periodic QZ iteration did not converge. C A is not in periodic Schur form, but C ALPHA(I), BETA(I), and SCAL(I), for C I = INFO+1,...,N should be correct. C C METHOD C C A slightly modified version of the periodic QZ algorithm is C used. For more details, see [2]. C C REFERENCES C C [1] Bojanczyk, A., Golub, G. H. and Van Dooren, P. C The periodic Schur decomposition: algorithms and applications. C In F.T. Luk (editor), Advanced Signal Processing Algorithms, C Architectures, and Implementations III, Proc. SPIE Conference, C vol. 1770, pp. 31-42, 1992. C C [2] Kressner, D. C An efficient and reliable implementation of the periodic QZ C algorithm. IFAC Workshop on Periodic Control Systems (PSYCO C 2001), Como (Italy), August 27-28 2001. Periodic Control C Systems 2001 (IFAC Proceedings Volumes), Pergamon. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C 3 C The algorithm requires 0(K N ) floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, Dec. 2002. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Aug. 2009, SLICOT Library version of the routine ZPGEQZ. C V. Sima, Nov. 2011, July 2012. C C KEYWORDS C C Eigenvalues, periodic QZ algorithm, periodic Schur form, unitary C equivalence transformations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CONE, CZERO PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), $ CZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. CHARACTER COMPQ, JOB INTEGER IHI, ILO, INFO, K, LDA1, LDA2, LDQ1, LDQ2, $ LDWORK, LZWORK, N C .. Array Arguments .. INTEGER S(*), SCAL(*) DOUBLE PRECISION DWORK(*) COMPLEX*16 A(LDA1, LDA2, *), ALPHA(*), BETA(*), $ Q(LDQ1, LDQ2, *), ZWORK(*) C .. Local Scalars .. LOGICAL LINIQ, LSCHR, SOK, WANTQ INTEGER IFIRST, IFRSTM, IITER, ILAST, ILASTM, IN, J, J1, $ JDEF, JITER, JLO, L, LDEF, LN, MAXIT, NTRA, $ ZITER DOUBLE PRECISION ABST, BASE, CS, SAFMAX, SAFMIN, SMLNUM, TOL, ULP COMPLEX*16 SN, TEMP C .. Local Arrays .. INTEGER ISEED(4) COMPLEX*16 RND(4) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANHS, ZLANTR EXTERNAL DLAMCH, LSAME, ZLANHS, ZLANTR C .. External Subroutines .. EXTERNAL DLABAD, MA01BZ, XERBLA, ZLARNV, ZLARTG, ZLASET, $ ZROT, ZSCAL C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, INT, LOG, MAX, MIN, $ MOD C C .. Executable Statements .. C C Decode the scalar input parameters. C LSCHR = LSAME( JOB, 'S' ) LINIQ = LSAME( COMPQ, 'I' ) WANTQ = LSAME( COMPQ, 'V' ) .OR. LINIQ C C Check the scalar input parameters. C INFO = 0 IF ( .NOT. ( LSCHR .OR. LSAME( JOB, 'E' ) ) ) THEN INFO = -1 ELSE IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN INFO = -2 ELSE IF ( K.LT.0 ) THEN INFO = -3 ELSE IF ( N.LT.0 ) THEN INFO = -4 ELSE IF ( ILO.LT.1 ) THEN INFO = -5 ELSE IF ( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -6 ELSE SOK = S(1).EQ.1 DO 10 L = 2, K SOK = SOK .AND. ( S(L).EQ.1 .OR. S(L).EQ.-1 ) 10 CONTINUE IF ( .NOT.SOK ) THEN INFO = -7 ELSE IF ( LDA1.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF ( LDA2.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF ( LDQ1.LT.1 .OR. ( WANTQ .AND. LDQ1.LT.N ) ) THEN INFO = -12 ELSE IF ( LDQ2.LT.1 .OR. ( WANTQ .AND. LDQ2.LT.N ) ) THEN INFO = -13 ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE IF ( LZWORK.LT.MAX( 1, N ) ) THEN INFO = -20 END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03BZ', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = ONE ZWORK(1) = CONE RETURN END IF C C Initialize Q. C IF ( LINIQ ) THEN DO 20 L = 1, K CALL ZLASET( 'Full', N, N, CZERO, CONE, Q(1,1,L), LDQ1 ) 20 CONTINUE END IF C C Machine Constants. C IN = IHI + 1 - ILO SAFMIN = DLAMCH( 'SafeMinimum' ) SAFMAX = ONE / SAFMIN ULP = DLAMCH( 'Precision' ) CALL DLABAD( SAFMIN, SAFMAX ) SMLNUM = SAFMIN*( IN / ULP ) BASE = DLAMCH( 'Base' ) IF ( K.GE.INT( LOG( DLAMCH( 'Underflow' ) ) / LOG( ULP ) ) ) THEN C C Start Iteration with a controlled zero shift. C ZITER = -1 ELSE ZITER = 0 END IF C C Set Eigenvalues IHI+1:N. C DO 30 J = IHI + 1, N CALL MA01BZ( BASE, K, S, A(J,J,1), LDA1*LDA2, ALPHA(J), $ BETA(J), SCAL(J) ) 30 CONTINUE C C If IHI < ILO, skip QZ steps. C IF ( IHI.LT.ILO ) $ GO TO 460 C C MAIN PERIODIC QZ ITERATION LOOP. C C Initialize dynamic indices. C C Eigenvalues ILAST+1:N have been found. C Column operations modify rows IFRSTM:whatever. C Row operations modify columns whatever:ILASTM. C C If only eigenvalues are being computed, then C IFRSTM is the row of the last splitting row above row ILAST; C this is always at least ILO. C IITER counts iterations since the last eigenvalue was found, C to tell when to use an observed zero or random shift. C MAXIT is the maximum number of QZ sweeps allowed. C ILAST = IHI IF ( LSCHR ) THEN IFRSTM = 1 ILASTM = N ELSE IFRSTM = ILO ILASTM = IHI END IF IITER = 0 ISEED(1) = 1 ISEED(2) = 0 ISEED(3) = 0 ISEED(4) = 1 MAXIT = 30 * IN C DO 450 JITER = 1, MAXIT C C Special Case: ILAST = ILO. C IF ( ILAST.EQ.ILO ) $ GO TO 390 C C ************************************************************** C * CHECK FOR DEFLATION * C ************************************************************** C C Test 1: Deflation in the Hessenberg matrix. C JLO = ILO DO 40 J = ILAST, ILO + 1, -1 TOL = ABS( A(J-1,J-1,1) ) + ABS( A(J,J,1) ) IF ( TOL.EQ.ZERO ) $ TOL = ZLANHS( '1', J-ILO+1, A(ILO,ILO,1), LDA1, DWORK ) TOL = MAX( ULP*TOL, SMLNUM ) IF ( ABS( A(J,J-1,1) ).LE.TOL ) THEN A(J,J-1,1) = CZERO JLO = J IF ( J.EQ.ILAST ) $ GO TO 390 GO TO 50 END IF 40 CONTINUE C 50 CONTINUE C C Test 2: Deflation in the triangular matrices with index 1. C DO 70 LDEF = 2, K IF ( S(LDEF).EQ.1 ) THEN DO 60 J = ILAST, JLO, -1 IF ( J.EQ.ILAST ) THEN TOL = ABS( A(J-1,J,LDEF) ) ELSE IF ( J.EQ.JLO ) THEN TOL = ABS( A(J,J+1,LDEF) ) ELSE TOL = ABS( A(J-1,J,LDEF) ) + ABS( A(J,J+1,LDEF) ) END IF IF ( TOL.EQ.ZERO ) $ TOL = ZLANTR( '1', 'Upper', 'Non-unit', J-JLO+1, $ J-JLO+1, A(JLO,JLO,LDEF), LDA1, $ DWORK ) TOL = MAX( ULP*TOL, SMLNUM ) IF ( ABS( A(J,J,LDEF) ).LE.TOL ) THEN A(J,J,LDEF) = CZERO GO TO 170 END IF 60 CONTINUE END IF 70 CONTINUE C C Test 3: Deflation in the triangular matrices with index -1. C DO 90 LDEF = 2, K IF ( S(LDEF).EQ.-1 ) THEN DO 80 J = ILAST, JLO, -1 IF ( J.EQ.ILAST ) THEN TOL = ABS( A(J-1,J,LDEF) ) ELSE IF ( J.EQ.JLO ) THEN TOL = ABS( A(J,J+1,LDEF) ) ELSE TOL = ABS( A(J-1,J,LDEF) ) + ABS( A(J,J+1,LDEF) ) END IF IF ( TOL.EQ.ZERO ) $ TOL = ZLANTR( '1', 'Upper', 'Non-unit', J-JLO+1, $ J-JLO+1, A(JLO,JLO,LDEF), LDA1, $ DWORK ) TOL = MAX( ULP*TOL, SMLNUM ) IF ( ABS( A(J,J,LDEF) ).LE.TOL ) THEN A(J,J,LDEF) = CZERO GO TO 320 END IF 80 CONTINUE END IF 90 CONTINUE C C Test 4: Controlled zero shift. C IF ( ZITER.GE.7 .OR. ZITER.LT.0 ) THEN C C Make Hessenberg matrix upper triangular. C DO 100 J = JLO, ILAST - 1 TEMP = A(J,J,1) CALL ZLARTG( TEMP, A(J+1,J,1), CS, SN, A(J,J,1) ) A(J+1,J,1) = CZERO CALL ZROT( ILASTM-J, A(J,J+1,1), LDA1, $ A(J+1,J+1,1), LDA1, CS, SN ) DWORK(J) = CS ZWORK(J) = SN 100 CONTINUE IF ( WANTQ ) THEN DO 110 J = JLO, ILAST - 1 CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, DWORK(J), $ DCONJG( ZWORK(J) ) ) 110 CONTINUE END IF C C Propagate Transformations back to A_1. C DO 150 L = K, 2, -1 IF ( S(L).EQ.1 ) THEN DO 120 J = JLO, ILAST - 1 SN = ZWORK(J) IF ( SN.NE.CZERO ) THEN CS = DWORK(J) CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1, $ A(IFRSTM,J+1,L), 1, CS, $ DCONJG( SN ) ) C C Check for deflation. C TOL = ABS( A(J,J,L) ) + ABS( A(J+1,J+1,L) ) IF ( TOL.EQ.ZERO ) $ TOL = ZLANHS( '1', J-JLO+2, A(JLO,JLO,L), $ LDA1, DWORK ) TOL = MAX( ULP*TOL, SMLNUM ) IF ( ABS( A(J+1,J,L) ).LE.TOL ) THEN CS = ONE SN = CZERO A(J+1,J,L) = CZERO ELSE C TEMP = A(J,J,L) CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, $ A(J,J,L) ) A(J+1,J,L) = CZERO CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1, $ A(J+1,J+1,L), LDA1, CS, SN ) END IF DWORK(J) = CS ZWORK(J) = SN END IF 120 CONTINUE ELSE DO 130 J = JLO, ILAST - 1 SN = ZWORK(J) IF ( SN.NE.CZERO ) THEN CS = DWORK(J) CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1, $ A(J+1,J,L), LDA1, CS, SN ) C C Check for deflation. C TOL = ABS( A(J,J,L) ) + ABS( A(J+1,J+1,L) ) IF ( TOL.EQ.ZERO ) $ TOL = ZLANHS( '1', J-JLO+2, A(JLO,JLO,L), $ LDA1, DWORK ) TOL = MAX( ULP*TOL, SMLNUM ) IF ( ABS( A(J+1,J,L) ).LE.TOL ) THEN CS = ONE SN = CZERO A(J+1,J,L) = CZERO ELSE C TEMP = A(J+1,J+1,L) CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, $ A(J+1,J+1,L) ) A(J+1,J,L) = CZERO CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1, $ A(IFRSTM,J,L), 1, CS, SN ) END IF DWORK(J) = CS ZWORK(J) = -SN END IF 130 CONTINUE END IF C IF ( WANTQ ) THEN DO 140 J = JLO, ILAST - 1 CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, DWORK(J), $ DCONJG( ZWORK(J) ) ) 140 CONTINUE END IF 150 CONTINUE C C Apply the transformations to the right hand side of the C Hessenberg factor. C ZITER = 0 DO 160 J = JLO, ILAST - 1 CS = DWORK(J) SN = ZWORK(J) CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,1), 1, $ A(IFRSTM,J+1,1), 1, CS, DCONJG( SN ) ) IF ( SN.EQ.CZERO ) $ ZITER = 1 160 CONTINUE C C No QZ iteration. C GO TO 440 END IF C C ************************************************************** C * HANDLE DEFLATIONS * C ************************************************************** C C Case I: Deflation occurs in the Hessenberg matrix. The QZ C iteration is only applied to the JLO:ILAST part. C IFIRST = JLO C C Go to the periodic QZ steps. C GO TO 400 C C Case II: Deflation occurs in a triangular matrix with index 1. C C Do an unshifted periodic QZ step. C 170 CONTINUE JDEF = J DO 180 J = JLO, JDEF - 1 TEMP = A(J,J,1) CALL ZLARTG( TEMP, A(J+1,J,1), CS, SN, A(J,J,1) ) A(J+1,J,1) = CZERO CALL ZROT( ILASTM-J, A(J,J+1,1), LDA1, A(J+1,J+1,1), LDA1, $ CS, SN ) DWORK(J) = CS ZWORK(J) = SN 180 CONTINUE IF ( WANTQ ) THEN DO 190 J = JLO, JDEF - 1 CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, DWORK(J), $ DCONJG( ZWORK(J) ) ) 190 CONTINUE END IF C C Propagate the transformations through the triangular matrices. C Due to the zero element on the diagonal of the LDEF-th factor, C the number of transformations drops by one. C DO 230 L = K, 2, -1 IF ( L.LT.LDEF ) THEN NTRA = JDEF - 2 ELSE NTRA = JDEF - 1 END IF IF ( S(L).EQ.1 ) THEN DO 200 J = JLO, NTRA CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1, $ A(IFRSTM,J+1,L), 1, DWORK(J), $ DCONJG( ZWORK(J) ) ) TEMP = A(J,J,L) CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J,J,L) ) A(J+1,J,L) = CZERO CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1, $ A(J+1,J+1,L), LDA1, CS, SN ) DWORK(J) = CS ZWORK(J) = SN 200 CONTINUE ELSE DO 210 J = JLO, NTRA CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1, A(J+1,J,L), $ LDA1, DWORK(J), ZWORK(J) ) TEMP = A(J+1,J+1,L) CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J+1,J+1,L) ) A(J+1,J,L) = CZERO CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1, $ A(IFRSTM,J,L), 1, CS, SN ) DWORK(J) = CS ZWORK(J) = -SN 210 CONTINUE END IF IF ( WANTQ ) THEN DO 220 J = JLO, NTRA CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, DWORK(J), $ DCONJG( ZWORK(J) ) ) 220 CONTINUE END IF 230 CONTINUE C C Apply the transformations to the right hand side of the C Hessenberg factor. C DO 240 J = JLO, JDEF - 2 CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,1), 1, A(IFRSTM,J+1,1), $ 1, DWORK(J), DCONJG( ZWORK(J) ) ) 240 CONTINUE C C Do an unshifted periodic QZ step. C DO 250 J = ILAST, JDEF + 1, -1 TEMP = A(J,J,1) CALL ZLARTG( TEMP, A(J,J-1,1), CS, SN, A(J,J,1) ) A(J,J-1,1) = CZERO CALL ZROT( J-IFRSTM, A(IFRSTM,J,1), 1, $ A(IFRSTM,J-1,1), 1, CS, SN ) DWORK(J) = CS ZWORK(J) = -SN 250 CONTINUE IF ( WANTQ ) THEN DO 260 J = ILAST, JDEF + 1, -1 CALL ZROT( N, Q(1,J-1,2), 1, Q(1,J,2), $ 1, DWORK(J), DCONJG( ZWORK(J) ) ) 260 CONTINUE END IF C C Propagate the transformations through the triangular matrices. C DO 300 L = 2, K IF ( L.GT.LDEF ) THEN NTRA = JDEF + 2 ELSE NTRA = JDEF + 1 END IF IF ( S(L).EQ.-1 ) THEN DO 270 J = ILAST, NTRA, -1 CS = DWORK(J) SN = ZWORK(J) CALL ZROT( J+1-IFRSTM, A(IFRSTM,J-1,L), 1, $ A(IFRSTM,J,L), 1, CS, DCONJG( SN ) ) TEMP = A(J-1,J-1,L) CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN, A(J-1,J-1,L) ) A(J,J-1,L) = CZERO CALL ZROT( ILASTM-J+1, A(J-1,J,L), LDA1, A(J,J,L), $ LDA1, CS, SN ) DWORK(J) = CS ZWORK(J) = SN 270 CONTINUE ELSE DO 280 J = ILAST, NTRA, -1 CALL ZROT( ILASTM-J+2, A(J-1,J-1,L), LDA1, $ A(J,J-1,L), LDA1, DWORK(J), ZWORK(J) ) TEMP = A(J,J,L) CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN, A(J,J,L) ) A(J,J-1,L) = CZERO CALL ZROT( J-IFRSTM, A(IFRSTM,J,L), 1, $ A(IFRSTM,J-1,L), 1, CS, SN ) DWORK(J) = CS ZWORK(J) = -SN 280 CONTINUE END IF IF ( WANTQ ) THEN IF ( L.EQ.K ) THEN LN = 1 ELSE LN = L + 1 END IF DO 290 J = ILAST, NTRA, -1 CALL ZROT( N, Q(1,J-1,LN), 1, Q(1,J,LN), 1, DWORK(J), $ DCONJG( ZWORK(J) ) ) 290 CONTINUE END IF 300 CONTINUE C C Apply the transformations to the left hand side of the C Hessenberg factor. C DO 310 J = ILAST, JDEF + 2, -1 CALL ZROT( ILASTM-J+2, A(J-1,J-1,1), LDA1, A(J,J-1,1), $ LDA1, DWORK(J), ZWORK(J) ) 310 CONTINUE C C No QZ iteration. C GO TO 440 C C Case III: Deflation occurs in a triangular matrix with C index -1. C 320 CONTINUE JDEF = J IF ( JDEF.GT.( ( ILAST - JLO + 1 )/2 ) ) THEN C C Chase the zero downwards to the last position. C DO 340 J1 = JDEF, ILAST - 1 J = J1 TEMP = A(J,J+1,LDEF) CALL ZLARTG( TEMP, A(J+1,J+1,LDEF), CS, SN, $ A(J,J+1,LDEF) ) A(J+1,J+1,LDEF) = CZERO CALL ZROT( ILASTM-J-1, A(J,J+2,LDEF), LDA1, $ A(J+1,J+2,LDEF), LDA1, CS, SN ) IF ( LDEF.EQ.K ) THEN LN = 1 ELSE LN = LDEF + 1 END IF IF ( WANTQ ) THEN CALL ZROT( N, Q(1,J,LN), 1, Q(1,J+1,LN), 1, CS, $ DCONJG( SN ) ) END IF DO 330 L = 1, K - 1 IF ( LN.EQ.1 ) THEN CALL ZROT( ILASTM-J+2, A(J,J-1,LN), LDA1, $ A(J+1,J-1,LN), LDA1, CS, SN ) TEMP = A(J+1,J,LN) CALL ZLARTG( TEMP, A(J+1,J-1,LN), CS, SN, $ A(J+1,J,LN) ) A(J+1,J-1,LN) = CZERO CALL ZROT( J-IFRSTM+1, A(IFRSTM,J,LN), 1, $ A(IFRSTM,J-1,LN), 1, CS, SN ) SN = -SN J = J - 1 ELSE IF ( S(LN).EQ.1 ) THEN CALL ZROT( ILASTM-J+1, A(J,J,LN), LDA1, $ A(J+1,J,LN), LDA1, CS, SN ) TEMP = A(J+1,J+1,LN) CALL ZLARTG( TEMP, A(J+1,J,LN), CS, SN, $ A(J+1,J+1,LN) ) A(J+1,J,LN) = CZERO CALL ZROT( J-IFRSTM+1, A(IFRSTM,J+1,LN), 1, $ A(IFRSTM,J,LN), 1, CS, SN ) SN = -SN ELSE CALL ZROT( J-IFRSTM+2, A(IFRSTM,J,LN), 1, $ A(IFRSTM,J+1,LN), 1, CS, DCONJG( SN ) ) TEMP = A(J,J,LN) CALL ZLARTG( TEMP, A(J+1,J,LN), CS, SN, A(J,J,LN) ) A(J+1,J,LN) = CZERO CALL ZROT( ILASTM-J, A(J,J+1,LN), LDA1, $ A(J+1,J+1,LN), LDA1, CS, SN ) END IF LN = LN + 1 IF ( LN.GT.K ) $ LN = 1 IF ( WANTQ ) THEN CALL ZROT( N, Q(1,J,LN), 1, Q(1,J+1,LN), 1, CS, $ DCONJG( SN ) ) END IF 330 CONTINUE CALL ZROT( J-IFRSTM+1, A(IFRSTM,J,LDEF), 1, $ A(IFRSTM,J+1,LDEF), 1, CS, DCONJG( SN ) ) 340 CONTINUE C C Deflate the last element in the Hessenberg matrix. C J = ILAST TEMP = A(J,J,1) CALL ZLARTG( TEMP, A(J,J-1,1), CS, SN, A(J,J,1) ) A(J,J-1,1) = CZERO CALL ZROT( J-IFRSTM, A(IFRSTM,J,1), 1, $ A(IFRSTM,J-1,1), 1, CS, SN ) SN = -SN IF ( WANTQ ) THEN CALL ZROT( N, Q(1,J-1,2), 1, Q(1,J,2), 1, CS, $ DCONJG( SN ) ) END IF DO 350 L = 2, LDEF - 1 IF ( S(L).EQ.-1 ) THEN CALL ZROT( J+1-IFRSTM, A(IFRSTM,J-1,L), 1, $ A(IFRSTM,J,L), 1, CS, DCONJG( SN ) ) TEMP = A(J-1,J-1,L) CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN, $ A(J-1,J-1,L) ) A(J,J-1,L) = CZERO CALL ZROT( ILASTM-J+1, A(J-1,J,L), LDA1, $ A(J,J,L), LDA1, CS, SN ) ELSE CALL ZROT( ILASTM-J+2, A(J-1,J-1,L), LDA1, $ A(J,J-1,L), LDA1, CS, SN ) TEMP = A(J,J,L) CALL ZLARTG( TEMP, A(J,J-1,L), CS, SN, $ A(J,J,L) ) A(J,J-1,L) = CZERO CALL ZROT( J-IFRSTM, A(IFRSTM,J,L), 1, $ A(IFRSTM,J-1,L), 1, CS, SN ) SN = -SN END IF IF ( WANTQ ) THEN IF ( L.EQ.K ) THEN LN = 1 ELSE LN = L + 1 END IF CALL ZROT( N, Q(1,J-1,LN), 1, Q(1,J,LN), 1, CS, $ DCONJG( SN ) ) END IF 350 CONTINUE CALL ZROT( J+1-IFRSTM, A(IFRSTM,J-1,LDEF), 1, $ A(IFRSTM,J,LDEF), 1, CS, DCONJG( SN ) ) ELSE C C Chase the zero upwards to the first position. C DO 370 J1 = JDEF, JLO + 1, -1 J = J1 TEMP = A(J-1,J,LDEF) CALL ZLARTG( TEMP, A(J-1,J-1,LDEF), CS, SN, $ A(J-1,J,LDEF) ) A(J-1,J-1,LDEF) = CZERO CALL ZROT( J-IFRSTM-1, A(IFRSTM,J,LDEF), 1, $ A(IFRSTM,J-1,LDEF), 1, CS, SN ) SN = -SN IF ( WANTQ ) THEN CALL ZROT( N, Q(1,J-1,LDEF), 1, Q(1,J,LDEF), 1, CS, $ DCONJG( SN ) ) END IF LN = LDEF - 1 DO 360 L = 1, K - 1 IF ( LN.EQ.1 ) THEN CALL ZROT( J-IFRSTM+2, A(IFRSTM,J-1,LN), 1, $ A(IFRSTM,J,LN), 1, CS, DCONJG( SN ) ) TEMP = A(J,J-1,LN) CALL ZLARTG( TEMP, A(J+1,J-1,LN), CS, SN, $ A(J,J-1,LN) ) A(J+1,J-1,LN) = CZERO CALL ZROT( ILASTM-J+1, A(J,J,LN), LDA1, $ A(J+1,J,LN), LDA1, CS, SN ) J = J + 1 ELSE IF ( S(LN).EQ.-1 ) THEN CALL ZROT( ILASTM-J+2, A(J-1,J-1,LN), LDA1, $ A(J,J-1,LN), LDA1, CS, SN ) TEMP = A(J,J,LN) CALL ZLARTG( TEMP, A(J,J-1,LN), CS, SN, $ A(J,J,LN) ) A(J,J-1,LN) = CZERO CALL ZROT( J-IFRSTM, A(IFRSTM,J,LN), 1, $ A(IFRSTM,J-1,LN), 1, CS, SN ) SN = -SN ELSE CALL ZROT( J-IFRSTM+1, A(IFRSTM,J-1,LN), 1, $ A(IFRSTM,J,LN), 1, CS, DCONJG( SN ) ) TEMP = A(J-1,J-1,LN) CALL ZLARTG( TEMP, A(J,J-1,LN), CS, SN, $ A(J-1,J-1,LN) ) A(J,J-1,LN) = CZERO CALL ZROT( ILASTM-J+1, A(J-1,J,LN), LDA1, $ A(J,J,LN), LDA1, CS, SN ) END IF IF ( WANTQ ) THEN CALL ZROT( N, Q(1,J-1,LN), 1, Q(1,J,LN), 1, CS, $ DCONJG( SN ) ) END IF LN = LN - 1 IF ( LN.LE.0 ) $ LN = K 360 CONTINUE CALL ZROT( ILASTM-J+1, A(J-1,J,LDEF), LDA1, A(J,J,LDEF), $ LDA1, CS, SN ) 370 CONTINUE C C Deflate the first element in the Hessenberg matrix. C J = JLO TEMP = A(J,J,1) CALL ZLARTG( TEMP, A(J+1,J,1), CS, SN, A(J,J,1) ) A(J+1,J,1) = CZERO CALL ZROT( ILASTM-J, A(J,J+1,1), LDA1, A(J+1,J+1,1), $ LDA1, CS, SN ) IF ( WANTQ ) THEN CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, CS, $ DCONJG( SN ) ) END IF DO 380 L = K, LDEF + 1, -1 IF ( S(L).EQ.1 ) THEN CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1, $ A(IFRSTM,J+1,L), 1, CS, DCONJG( SN ) ) TEMP = A(J,J,L) CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J,J,L) ) A(J+1,J,L) = CZERO CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1, $ A(J+1,J+1,L), LDA1, CS, SN ) ELSE CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1, $ A(J+1,J,L), LDA1, CS, SN ) TEMP = A(J+1,J+1,L) CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, $ A(J+1,J+1,L) ) A(J+1,J,L) = CZERO CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1, $ A(IFRSTM,J,L), 1, CS, SN ) SN = -SN END IF IF ( WANTQ ) THEN CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, CS, $ DCONJG( SN ) ) END IF 380 CONTINUE CALL ZROT( ILASTM-J, A(J,J+1,LDEF), LDA1, A(J+1,J+1,LDEF), $ LDA1, CS, SN ) END IF C C No QZ iteration. C GO TO 440 C C Special case: A 1x1 block splits off at the bottom. C 390 CONTINUE CALL MA01BZ( BASE, K, S, A(ILAST,ILAST,1), LDA1*LDA2, $ ALPHA(ILAST), BETA(ILAST), SCAL(ILAST) ) C C Go to next block - exit if finished. C ILAST = ILAST - 1 IF ( ILAST.LT.ILO ) $ GO TO 460 C C Reset iteration counters. C IITER = 0 IF ( ZITER.NE.-1 ) $ ZITER = 0 IF ( .NOT.LSCHR ) THEN ILASTM = ILAST IF ( IFRSTM.GT.ILAST ) $ IFRSTM = ILO END IF C C No QZ iteration. C GO TO 440 C C ************************************************************** C * PERIODIC QZ STEP * C ************************************************************** C C It is assumed that IFIRST < ILAST. C 400 CONTINUE C IITER = IITER + 1 ZITER = ZITER + 1 IF( .NOT.LSCHR ) $ IFRSTM = IFIRST C C Complex single shift. C IF ( MOD( IITER, 10 ).EQ.0 ) THEN C C Exceptional shift. C CALL ZLARNV( 2, ISEED, 2, RND ) CALL ZLARTG( RND(1), RND(2), CS, SN, TEMP ) ELSE CALL ZLARTG( CONE, CONE, CS, SN, TEMP ) DO 410 L = K, 2, -1 IF ( S(L).EQ.1 ) THEN CALL ZLARTG( A(IFIRST,IFIRST,L)*CS, $ A(ILAST,ILAST,L)*DCONJG( SN ), $ CS, SN, TEMP ) ELSE CALL ZLARTG( A(ILAST,ILAST,L)*CS, $ -A(IFIRST,IFIRST,L)*DCONJG( SN ), $ CS, SN, TEMP ) SN = -SN END IF 410 CONTINUE CALL ZLARTG( A(IFIRST,IFIRST,1)*CS $ -A(ILAST,ILAST,1)*DCONJG( SN ), $ A(IFIRST+1,IFIRST,1)*CS, CS, SN, TEMP ) END IF C C Do the sweeps. C DO 430 J1 = IFIRST - 1, ILAST - 2 J = J1 + 1 C C Create a bulge if J1 = IFIRST - 1, otherwise chase the C bulge. C IF ( J1.GE.IFIRST ) THEN TEMP = A(J,J-1,1) CALL ZLARTG( TEMP, A(J+1,J-1,1), CS, SN, A(J,J-1,1) ) A(J+1,J-1,1) = CZERO END IF CALL ZROT( ILASTM-J+1, A(J,J,1), LDA1, A(J+1,J,1), LDA1, $ CS, SN ) IF ( WANTQ ) THEN CALL ZROT( N, Q(1,J,1), 1, Q(1,J+1,1), 1, CS, $ DCONJG( SN ) ) END IF C C Propagate rotation through AK, ..., A2 to A1. C DO 420 L = K, 2, -1 IF ( S(L).EQ.1 ) THEN CALL ZROT( J+2-IFRSTM, A(IFRSTM,J,L), 1, $ A(IFRSTM,J+1,L), 1, CS, DCONJG( SN ) ) TEMP = A(J,J,L) CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J,J,L) ) A(J+1,J,L) = CZERO CALL ZROT( ILASTM-J, A(J,J+1,L), LDA1, $ A(J+1,J+1,L), LDA1, CS, SN ) ELSE CALL ZROT( ILASTM-J+1, A(J,J,L), LDA1, A(J+1,J,L), $ LDA1, CS, SN ) TEMP = A(J+1,J+1,L) CALL ZLARTG( TEMP, A(J+1,J,L), CS, SN, A(J+1,J+1,L) ) A(J+1,J,L) = CZERO CALL ZROT( J+1-IFRSTM, A(IFRSTM,J+1,L), 1, $ A(IFRSTM,J,L), 1, CS, SN ) SN = -SN END IF IF ( WANTQ ) THEN CALL ZROT( N, Q(1,J,L), 1, Q(1,J+1,L), 1, CS, $ DCONJG( SN ) ) END IF 420 CONTINUE CALL ZROT( MIN( J+2, ILASTM )-IFRSTM+1, A(IFRSTM,J,1), 1, $ A(IFRSTM,J+1,1), 1, CS, DCONJG( SN ) ) 430 CONTINUE C C End of iteration loop. C 440 CONTINUE 450 CONTINUE C C Drop through = non-convergence. C INFO = ILAST GO TO 540 C C Successful completion of all QZ steps. C 460 CONTINUE C C Set eigenvalues 1:ILO-1. C DO 470 J = 1, ILO - 1 CALL MA01BZ( BASE, K, S, A(J,J,1), LDA1*LDA2, ALPHA(J), $ BETA(J), SCAL(J) ) 470 CONTINUE IF ( LSCHR ) THEN C C Scale A(2,:,:), ..., A(K,:,:). C DO 530 L = K, 2, -1 IF ( S(L).EQ.1 ) THEN DO 480 J = 1, N ABST = ABS( A(J,J,L) ) IF ( ABST.GT.SAFMIN ) THEN TEMP = DCONJG( A(J,J,L) / ABST ) A(J,J,L ) = ABST IF ( J.LT.N ) $ CALL ZSCAL( N-J, TEMP, A(J,J+1,L), LDA1 ) ELSE TEMP = CONE END IF ZWORK(J) = TEMP 480 CONTINUE ELSE DO 490 J = 1, N ABST = ABS( A(J,J,L) ) IF ( ABST.GT.SAFMIN ) THEN TEMP = DCONJG( A(J,J,L) / ABST ) A(J,J,L ) = ABST CALL ZSCAL( J-1, TEMP, A(1,J,L), 1 ) ELSE TEMP = CONE END IF ZWORK(J) = DCONJG( TEMP ) 490 CONTINUE END IF IF ( WANTQ ) THEN DO 500 J = 1, N CALL ZSCAL( N, DCONJG( ZWORK(J) ), Q(1,J,L), 1 ) 500 CONTINUE END IF IF ( S(L-1).EQ.1 ) THEN DO 510 J = 1, N CALL ZSCAL( J, DCONJG( ZWORK(J) ), A(1,J,L-1), 1 ) 510 CONTINUE ELSE DO 520 J = 1, N CALL ZSCAL( N-J+1, ZWORK(J), A(J,J,L-1), LDA1 ) 520 CONTINUE END IF 530 CONTINUE END IF C 540 CONTINUE C DWORK(1) = DBLE( N ) ZWORK(1) = DCMPLX( N, 0 ) RETURN C *** Last line of MB03BZ *** END control-4.1.2/src/slicot/src/PaxHeaders/AB07ND.f0000644000000000000000000000013215012430707016150 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB07ND.f0000644000175000017500000002337215012430707017353 0ustar00lilgelilge00000000000000 SUBROUTINE AB07ND( N, M, A, LDA, B, LDB, C, LDC, D, LDD, RCOND, $ IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the inverse (Ai,Bi,Ci,Di) of a given system (A,B,C,D). C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the state matrix A. N >= 0. C C M (input) INTEGER C The number of system inputs and outputs. 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 state matrix A of the original system. C On exit, the leading N-by-N part of this array contains C the state matrix Ai of the inverse system. C C LDA INTEGER C The leading dimension of the 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 matrix B of the original system. C On exit, the leading N-by-M part of this array contains C the input matrix Bi of the inverse system. C C LDB INTEGER C The leading dimension of the 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 output matrix C of the original system. C On exit, the leading M-by-N part of this array contains C the output matrix Ci of the inverse system. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,M). C C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) C On entry, the leading M-by-M part of this array must C contain the feedthrough matrix D of the original system. C On exit, the leading M-by-M part of this array contains C the feedthrough matrix Di of the inverse system. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1,M). C C RCOND (output) DOUBLE PRECISION C The estimated reciprocal condition number of the C feedthrough matrix D of the original system. C C Workspace C C IWORK INTEGER array, dimension (2*M) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or M+1, DWORK(1) returns the optimal C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,4*M). C For good 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 = i: the matrix D is exactly singular; the (i,i) diagonal C element is zero, i <= M; RCOND was set to zero; C = M+1: the matrix D is numerically singular, i.e., RCOND C is less than the relative machine precision, EPS C (see LAPACK Library routine DLAMCH). The C calculations have been completed, but the results C could be very inaccurate. C C METHOD C C The matrices of the inverse system are computed with the formulas: C -1 -1 -1 -1 C Ai = A - B*D *C, Bi = -B*D , Ci = D *C, Di = D . C C NUMERICAL ASPECTS C C The accuracy depends mainly on the condition number of the matrix C D to be inverted. The estimated reciprocal condition number is C returned in RCOND. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000. C D. Sima, University of Bucharest, April 2000. C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. C Based on the routine SYSINV, A. Varga, 1992. C C REVISIONS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2011. C C KEYWORDS C C Inverse system, state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION RCOND INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*) INTEGER IWORK(*) C .. Local Scalars .. DOUBLE PRECISION DNORM INTEGER BL, CHUNK, I, IERR, J, MAXWRK, MINWRK LOGICAL BLAS3, BLOCK, LQUERY C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE C .. External Subroutines .. EXTERNAL DCOPY, DGECON, DGEMM, DGEMV, DGETRF, DGETRI, $ DLACPY, 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, N ) ) THEN INFO = -6 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE LQUERY = LDWORK.EQ.-1 MINWRK = MAX( 1, 4*M ) CALL DGETRI( M, D, LDD, IWORK, DWORK, -1, IERR ) MAXWRK = MAX( MINWRK, INT( DWORK(1) ), N*M ) IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -14 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB07ND', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = MAXWRK RETURN END IF C C Quick return if possible. C IF ( M.EQ.0 ) THEN RCOND = ONE DWORK(1) = ONE RETURN END IF C C Factorize D. C CALL DGETRF( M, M, D, LDD, IWORK, INFO ) IF ( INFO.NE.0 ) THEN RCOND = ZERO RETURN END IF C C Compute the reciprocal condition number of the matrix D. C Workspace: need 4*M. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 DNORM = DLANGE( '1-norm', M, M, D, LDD, DWORK ) CALL DGECON( '1-norm', M, D, LDD, DNORM, RCOND, DWORK, IWORK(M+1), $ IERR ) IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) $ INFO = M + 1 C -1 C Compute Di = D . C Workspace: need M; C prefer M*NB. C CALL DGETRI( M, D, LDD, IWORK, DWORK, LDWORK, IERR ) IF ( N.GT.0 ) THEN CHUNK = LDWORK / M BLAS3 = CHUNK.GE.N .AND. M.GT.1 BLOCK = MIN( CHUNK, M ).GT.1 C -1 C Compute Bi = -B*D . C IF ( BLAS3 ) THEN C C Enough workspace for a fast BLAS 3 algorithm. C CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, M, -ONE, $ DWORK, N, D, LDD, ZERO, B, LDB ) C ELSE IF( BLOCK ) THEN C C Use as many rows of B as possible. C DO 10 I = 1, N, CHUNK BL = MIN( N-I+1, CHUNK ) CALL DLACPY( 'Full', BL, M, B(I,1), LDB, DWORK, BL ) CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, -ONE, $ DWORK, BL, D, LDD, ZERO, B(I,1), LDB ) 10 CONTINUE C ELSE C C Use a BLAS 2 algorithm. C DO 20 I = 1, N CALL DCOPY( M, B(I,1), LDB, DWORK, 1 ) CALL DGEMV( 'Transpose', M, M, -ONE, D, LDD, DWORK, 1, $ ZERO, B(I,1), LDB ) 20 CONTINUE C END IF C C Compute Ai = A + Bi*C. C CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, LDB, $ C, LDC, ONE, A, LDA ) C -1 C Compute C <-- D *C. C IF ( BLAS3 ) THEN C C Enough workspace for a fast BLAS 3 algorithm. C CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE, $ D, LDD, DWORK, M, ZERO, C, LDC ) C ELSE IF( BLOCK ) THEN C C Use as many columns of C as possible. C DO 30 J = 1, N, CHUNK BL = MIN( N-J+1, CHUNK ) CALL DLACPY( 'Full', M, BL, C(1,J), LDC, DWORK, M ) CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE, $ D, LDD, DWORK, M, ZERO, C(1,J), LDC ) 30 CONTINUE C ELSE C C Use a BLAS 2 algorithm. C DO 40 J = 1, N CALL DCOPY( M, C(1,J), 1, DWORK, 1 ) CALL DGEMV( 'NoTranspose', M, M, ONE, D, LDD, DWORK, 1, $ ZERO, C(1,J), 1 ) 40 CONTINUE C END IF END IF C C Return optimal workspace in DWORK(1). C DWORK(1) = MAXWRK RETURN C C *** Last line of AB07ND *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03OY.f0000644000000000000000000000013215012430707016214 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03OY.f0000644000175000017500000005570215012430707017421 0ustar00lilgelilge00000000000000 SUBROUTINE SB03OY( DISCR, LTRANS, ISGN, S, LDS, R, LDR, A, LDA, $ SCALE, INFO ) C C PURPOSE C C To solve for the Cholesky factor U of X, C C op(U)'*op(U) = X, C C where U is a two-by-two upper triangular matrix, either the C continuous-time two-by-two Lyapunov equation C 2 C op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R), C C when DISCR = .FALSE., or the discrete-time two-by-two Lyapunov C equation C 2 C op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R), C C when DISCR = .TRUE., where op(K) = K or K' (i.e., the transpose of C the matrix K), S is a two-by-two matrix with complex conjugate C eigenvalues, R is a two-by-two upper triangular matrix, C ISGN = -1 or 1, and scale is an output scale factor, set less C than or equal to 1 to avoid overflow in X. The routine also C computes two matrices, B and A, so that C 2 C B*U = U*S and A*U = scale *R, if LTRANS = .FALSE., or C 2 C U*B = S*U and U*A = scale *R, if LTRANS = .TRUE., C which are used by the general Lyapunov solver. C In the continuous-time case ISGN*S must be stable, so that its C eigenvalues must have strictly negative real parts. C In the discrete-time case S must be convergent if ISGN = 1, that C is, its eigenvalues must have moduli less than unity, or S must C be completely divergent if ISGN = -1, that is, its eigenvalues C must have moduli greater than unity. C C ARGUMENTS C C Mode Parameters C C DISCR LOGICAL C Specifies the equation to be solved: 2 C = .FALSE.: op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R); C 2 C = .TRUE. : op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R). C C LTRANS LOGICAL C Specifies the form of op(K) to be used, as follows: C = .FALSE.: op(K) = K (No transpose); C = .TRUE. : op(K) = K**T (Transpose). C C ISGN INTEGER C Specifies the sign of the equation as described before. C ISGN may only be 1 or -1. C C Input/Output Parameters C C S (input/output) DOUBLE PRECISION array, dimension (LDS,2) C On entry, S must contain a 2-by-2 matrix. C On exit, S contains a 2-by-2 matrix B such that B*U = U*S, C if LTRANS = .FALSE., or U*B = S*U, if LTRANS = .TRUE.. C Notice that if U is nonsingular then C B = U*S*inv( U ), if LTRANS = .FALSE. C B = inv( U )*S*U, if LTRANS = .TRUE.. C C LDS INTEGER C The leading dimension of array S. LDS >= 2. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,2) C On entry, R must contain a 2-by-2 upper triangular matrix. C The element R( 2, 1 ) is not referenced. C On exit, R contains U, the 2-by-2 upper triangular C Cholesky factor of the solution X, X = op(U)'*op(U). C C LDR INTEGER C The leading dimension of array R. LDR >= 2. C C A (output) DOUBLE PRECISION array, dimension (LDA,2) C A contains a 2-by-2 upper triangular matrix A satisfying C A*U/scale = scale*R, if LTRANS = .FALSE., or C U*A/scale = scale*R, if LTRANS = .TRUE.. C Notice that if U is nonsingular then C A = scale*scale*R*inv( U ), if LTRANS = .FALSE. C A = scale*scale*inv( U )*R, if LTRANS = .TRUE.. C C LDA INTEGER C The leading dimension of array A. LDA >= 2. 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 Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if the Lyapunov equation is (nearly) singular C (warning indicator); C if DISCR = .FALSE., this means that while the C matrix S has computed eigenvalues with negative real C parts, it is only just stable in the sense that C small perturbations in S can make one or more of the C eigenvalues have a non-negative real part; C if DISCR = .TRUE., this means that while the C matrix S has computed eigenvalues inside the unit C circle, it is nevertheless only just convergent, in C the sense that small perturbations in S can make one C or more of the eigenvalues lie outside the unit C circle; C perturbed values were used to solve the equation C (but the matrix S is unchanged); C = 2: if DISCR = .FALSE., and ISGN*S is not stable or C if DISCR = .TRUE., ISGN = 1 and S is not convergent C or if DISCR = .TRUE., ISGN = -1 and S is not C completely divergent; C = 4: if S has real eigenvalues. C C NOTE: In the interests of speed, this routine does not check all C inputs for errors. C C METHOD C C The LAPACK scheme for solving 2-by-2 Sylvester equations is C adapted for 2-by-2 Lyapunov equations, but directly computing the C Cholesky factor of the solution. C C REFERENCES C C [1] 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 C The algorithm is backward stable. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB03CY by Sven Hammarling, C NAG Ltd., United Kingdom, November 1986. C Partly based on SB03CY and PLYAP2 by A. Varga, University of C Bochum, May 1992. C C REVISIONS C C V. Sima, Dec. 1997, April 1998, Aug. 2012, Jan. - Feb. 2022. C D. Kressner, ETH Zurich, May 2011. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ***************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, FOUR PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ FOUR = 4.0D0 ) C .. Scalar Arguments .. LOGICAL DISCR, LTRANS INTEGER INFO, ISGN, LDA, LDR, LDS DOUBLE PRECISION SCALE C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), R(LDR,*), S(LDS,*) C .. Local Scalars .. DOUBLE PRECISION ABSB, ABSG, ABST, ALPHA, BIGNUM, E1, E2, EPS, $ ETA, P1, P3, P3I, P3R, S11, S12, S21, S22, $ SCALOC, SGN, SMIN, SMLNUM, SNP, SNQ, SNT, TEMPI, $ TEMPR, V1, V3 C .. Local Arrays .. DOUBLE PRECISION CSP(2), CSQ(2), CST(2), DELTA(2), DP(2), DT(2), $ G(2), GAMMA(2), P2(2), T(2), TEMP(2), V2(2), $ X11(2), X12(2), X21(2), X22(2), Y(2) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2, DLAPY3 EXTERNAL DLAMCH, DLAPY2, DLAPY3 C .. External Subroutines .. EXTERNAL DLABAD, DLANV2, SB03OV C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT C .. Executable Statements .. C C The comments in this routine refer to notation and equation C numbers in sections 6 and 10 of [1]. C C Find the eigenvalue lambda = E1 - i*E2 of s11. C INFO = 0 SGN = ISGN S11 = S(1,1) S12 = S(1,2) S21 = S(2,1) S22 = S(2,2) C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*FOUR / EPS BIGNUM = ONE / SMLNUM C SMIN = SMLNUM SCALE = ONE C CALL DLANV2( S11, S12, S21, S22, TEMPR, TEMPI, E1, E2, CSP, CSQ ) IF ( TEMPI.EQ.ZERO ) THEN INFO = 4 RETURN END IF ABSB = DLAPY2( E1, E2 ) IF ( DISCR ) THEN IF ( SGN*( ABSB - ONE ).GE.ZERO ) THEN INFO = 2 RETURN END IF ELSE IF ( SGN*E1.GE.ZERO ) THEN INFO = 2 RETURN END IF END IF C C Compute the cos and sine that define Qhat. The sine is real. C TEMP(1) = S(1,1) - E1 TEMP(2) = E2 IF ( LTRANS ) TEMP(2) = -E2 CALL SB03OV( TEMP, S(2,1), SMLNUM, CSQ, SNQ ) C C beta in (6.9) is given by beta = E1 + i*E2, compute t. C TEMP(1) = CSQ(1)*S(1,2) - SNQ*S(1,1) TEMP(2) = CSQ(2)*S(1,2) TEMPR = CSQ(1)*S(2,2) - SNQ*S(2,1) TEMPI = CSQ(2)*S(2,2) T(1) = CSQ(1)*TEMP(1) - CSQ(2)*TEMP(2) + SNQ*TEMPR T(2) = CSQ(1)*TEMP(2) + CSQ(2)*TEMP(1) + SNQ*TEMPI C IF ( LTRANS ) THEN C ( -- ) C Case op(M) = M'. Note that the modified R is ( p3 p2 ). C ( 0 p1 ) C C Compute the cos and sine that define Phat. C TEMP(1) = CSQ(1)*R(2,2) - SNQ*R(1,2) TEMP(2) = -CSQ(2)*R(2,2) CALL SB03OV( TEMP, -SNQ*R(1,1), SMLNUM, CSP, SNP ) C C Compute p1, p2 and p3 of the relation corresponding to (6.11). C P1 = TEMP(1) TEMP(1) = CSQ(1)*R(1,2) + SNQ*R(2,2) TEMP(2) = -CSQ(2)*R(1,2) TEMPR = CSQ(1)*R(1,1) TEMPI = -CSQ(2)*R(1,1) P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR P2(2) = -CSP(1)*TEMP(2) - CSP(2)*TEMP(1) - SNP*TEMPI P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) P3I = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*TEMP(2) ELSE C C Case op(M) = M. C C Compute the cos and sine that define Phat. C TEMP(1) = CSQ(1)*R(1,1) + SNQ*R(1,2) TEMP(2) = CSQ(2)*R(1,1) CALL SB03OV( TEMP, SNQ*R(2,2), SMLNUM, CSP, SNP ) C C Compute p1, p2 and p3 of (6.11). C P1 = TEMP(1) TEMP(1) = CSQ(1)*R(1,2) - SNQ*R(1,1) TEMP(2) = CSQ(2)*R(1,2) TEMPR = CSQ(1)*R(2,2) TEMPI = CSQ(2)*R(2,2) P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR P2(2) = CSP(1)*TEMP(2) + CSP(2)*TEMP(1) + SNP*TEMPI P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) P3I = CSP(2)*TEMPR - CSP(1)*TEMPI + SNP*TEMP(2) END IF C C Make p3 real by multiplying by conjg ( p3 )/abs( p3 ) to give C C p3 := abs( p3 ). C IF ( P3I.EQ.ZERO ) THEN P3 = ABS( P3R ) DP(1) = SIGN( ONE, P3R ) DP(2) = ZERO ELSE P3 = DLAPY2( P3R, P3I ) DP(1) = P3R/P3 DP(2) = -P3I/P3 END IF C C Now compute the quantities v1, v2, v3 and y in (6.13) - (6.15), C or (10.23) - (10.25). Care is taken to avoid overflows. C IF ( DISCR ) THEN ALPHA = SQRT( ABS( ONE - ABSB )*( ONE + ABSB ) ) ELSE ALPHA = SQRT( ABS( TWO*E1 ) ) END IF C SCALOC = ONE IF( ALPHA.LT.SMIN ) THEN ALPHA = SMIN INFO = 1 END IF ABST = ABS( P1 ) IF( ALPHA.LT.ONE .AND. ABST.GT.ONE ) THEN IF( ABST.GT.BIGNUM*ALPHA ) $ SCALOC = ONE / ABST END IF IF( SCALOC.NE.ONE ) THEN P1 = SCALOC*P1 P2(1) = SCALOC*P2(1) P2(2) = SCALOC*P2(2) P3 = SCALOC*P3 SCALE = SCALOC*SCALE END IF V1 = P1/ALPHA C IF ( DISCR ) THEN G(1) = ( ONE - E1 )*( ONE + E1 ) + E2**2 G(2) = -TWO*E1*E2 ABSG = DLAPY2( G(1), G(2) ) SCALOC = ONE IF( ABSG.LT.SMIN ) THEN ABSG = SMIN INFO = 1 END IF TEMP(1) = SGN*ALPHA*P2(1) + V1*( E1*T(1) - E2*T(2) ) TEMP(2) = SGN*ALPHA*P2(2) + V1*( E1*T(2) + E2*T(1) ) ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN IF( ABST.GT.BIGNUM*ABSG ) $ SCALOC = ONE / ABST END IF IF( SCALOC.NE.ONE ) THEN V1 = SCALOC*V1 TEMP(1) = SCALOC*TEMP(1) TEMP(2) = SCALOC*TEMP(2) P1 = SCALOC*P1 P2(1) = SCALOC*P2(1) P2(2) = SCALOC*P2(2) P3 = SCALOC*P3 SCALE = SCALOC*SCALE END IF TEMP(1) = TEMP(1)/ABSG TEMP(2) = TEMP(2)/ABSG C SCALOC = ONE V2(1) = G(1)*TEMP(1) + G(2)*TEMP(2) V2(2) = G(1)*TEMP(2) - G(2)*TEMP(1) ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN IF( ABST.GT.BIGNUM*ABSG ) $ SCALOC = ONE / ABST END IF IF( SCALOC.NE.ONE ) THEN V1 = SCALOC*V1 V2(1) = SCALOC*V2(1) V2(2) = SCALOC*V2(2) P1 = SCALOC*P1 P2(1) = SCALOC*P2(1) P2(2) = SCALOC*P2(2) P3 = SCALOC*P3 SCALE = SCALOC*SCALE END IF V2(1) = V2(1)/ABSG V2(2) = V2(2)/ABSG C SCALOC = ONE TEMP(1) = P1*T(1) - TWO*E2*P2(2) TEMP(2) = P1*T(2) + TWO*E2*P2(1) ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN IF( ABST.GT.BIGNUM*ABSG ) $ SCALOC = ONE / ABST END IF IF( SCALOC.NE.ONE ) THEN TEMP(1) = SCALOC*TEMP(1) TEMP(2) = SCALOC*TEMP(2) V1 = SCALOC*V1 V2(1) = SCALOC*V2(1) V2(2) = SCALOC*V2(2) P3 = SCALOC*P3 SCALE = SCALOC*SCALE END IF TEMP(1) = TEMP(1)/ABSG TEMP(2) = TEMP(2)/ABSG C SCALOC = ONE Y(1) = -( G(1)*TEMP(1) + G(2)*TEMP(2) ) Y(2) = -( G(1)*TEMP(2) - G(2)*TEMP(1) ) ABST = MAX( ABS( Y(1) ), ABS( Y(2) ) ) IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN IF( ABST.GT.BIGNUM*ABSG ) $ SCALOC = ONE / ABST END IF IF( SCALOC.NE.ONE ) THEN Y(1) = SCALOC*Y(1) Y(2) = SCALOC*Y(2) V1 = SCALOC*V1 V2(1) = SCALOC*V2(1) V2(2) = SCALOC*V2(2) P3 = SCALOC*P3 SCALE = SCALOC*SCALE END IF Y(1) = Y(1)/ABSG Y(2) = Y(2)/ABSG ELSE C SCALOC = ONE IF( ABSB.LT.SMIN ) THEN ABSB = SMIN INFO = 1 END IF TEMP(1) = SGN*ALPHA*P2(1) + V1*T(1) TEMP(2) = SGN*ALPHA*P2(2) + V1*T(2) ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN IF( ABST.GT.BIGNUM*ABSB ) $ SCALOC = ONE / ABST END IF IF( SCALOC.NE.ONE ) THEN V1 = SCALOC*V1 TEMP(1) = SCALOC*TEMP(1) TEMP(2) = SCALOC*TEMP(2) P2(1) = SCALOC*P2(1) P2(2) = SCALOC*P2(2) P3 = SCALOC*P3 SCALE = SCALOC*SCALE END IF TEMP(1) = TEMP(1)/( TWO*ABSB ) TEMP(2) = TEMP(2)/( TWO*ABSB ) SCALOC = ONE V2(1) = -( E1*TEMP(1) + E2*TEMP(2) ) V2(2) = -( E1*TEMP(2) - E2*TEMP(1) ) ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN IF( ABST.GT.BIGNUM*ABSB ) $ SCALOC = ONE / ABST END IF IF( SCALOC.NE.ONE ) THEN V1 = SCALOC*V1 V2(1) = SCALOC*V2(1) V2(2) = SCALOC*V2(2) P2(1) = SCALOC*P2(1) P2(2) = SCALOC*P2(2) P3 = SCALOC*P3 SCALE = SCALOC*SCALE END IF V2(1) = V2(1)/ABSB V2(2) = V2(2)/ABSB Y(1) = P2(1) - ALPHA*V2(1) Y(2) = P2(2) - ALPHA*V2(2) END IF C SCALOC = ONE V3 = DLAPY3( P3, Y(1), Y(2) ) IF( ALPHA.LT.ONE .AND. V3.GT.ONE ) THEN IF( V3.GT.BIGNUM*ALPHA ) $ SCALOC = ONE / V3 END IF IF( SCALOC.NE.ONE ) THEN V1 = SCALOC*V1 V2(1) = SCALOC*V2(1) V2(2) = SCALOC*V2(2) V3 = SCALOC*V3 P3 = SCALOC*P3 SCALE = SCALOC*SCALE END IF V3 = V3/ALPHA C IF ( LTRANS ) THEN C C Case op(M) = M'. C C Form X = conjg( Qhat' )*v11. C X11(1) = CSQ(1)*V3 X11(2) = CSQ(2)*V3 X21(1) = SNQ*V3 X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) - SNQ*V1 X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) X22(1) = CSQ(1)*V1 + SNQ*V2(1) X22(2) = -CSQ(2)*V1 - SNQ*V2(2) C C Obtain u11 from the RQ-factorization of X. The conjugate of C X22 should be taken. C X22(2) = -X22(2) CALL SB03OV( X22, X21(1), SMLNUM, CST, SNT ) R(2,2) = X22(1) R(1,2) = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) TEMPR = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) TEMPI = CST(1)*X11(2) - CST(2)*X11(1) - SNT*X12(2) IF ( TEMPI.EQ.ZERO ) THEN R(1,1) = ABS( TEMPR ) DT(1) = SIGN( ONE, TEMPR ) DT(2) = ZERO ELSE R(1,1) = DLAPY2( TEMPR, TEMPI ) DT(1) = TEMPR/R(1,1) DT(2) = -TEMPI/R(1,1) END IF ELSE C C Case op(M) = M. C C Now form X = v11*conjg( Qhat' ). C X11(1) = CSQ(1)*V1 - SNQ*V2(1) X11(2) = -CSQ(2)*V1 + SNQ*V2(2) X21(1) = -SNQ*V3 X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) + SNQ*V1 X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) X22(1) = CSQ(1)*V3 X22(2) = CSQ(2)*V3 C C Obtain u11 from the QR-factorization of X. C CALL SB03OV( X11, X21(1), SMLNUM, CST, SNT ) R(1,1) = X11(1) R(1,2) = CST(1)*X12(1) + CST(2)*X12(2) + SNT*X22(1) TEMPR = CST(1)*X22(1) - CST(2)*X22(2) - SNT*X12(1) TEMPI = CST(1)*X22(2) + CST(2)*X22(1) - SNT*X12(2) IF ( TEMPI.EQ.ZERO ) THEN R(2,2) = ABS( TEMPR ) DT(1) = SIGN( ONE, TEMPR ) DT(2) = ZERO ELSE R(2,2) = DLAPY2( TEMPR, TEMPI ) DT(1) = TEMPR/R(2,2) DT(2) = -TEMPI/R(2,2) END IF END IF C C The computations below are not needed when B and A are not C useful. Compute delta, eta and gamma as in (6.21) or (10.26). C IF ( ( ABS( Y(1) ).LT.SMLNUM ).AND.( ABS( Y(2) ).LE.SMLNUM ) ) $ THEN DELTA(1) = ZERO DELTA(2) = ZERO GAMMA(1) = ZERO GAMMA(2) = ZERO ETA = ALPHA ELSE DELTA(1) = Y(1)/V3 DELTA(2) = Y(2)/V3 GAMMA(1) = -ALPHA*DELTA(1) GAMMA(2) = -ALPHA*DELTA(2) ETA = P3/V3 IF ( DISCR ) THEN TEMPR = E1*DELTA(1) - E2*DELTA(2) DELTA(2) = E1*DELTA(2) + E2*DELTA(1) DELTA(1) = TEMPR END IF END IF C IF ( LTRANS ) THEN C C Case op(M) = M'. C C Find X = conjg( That' )*( inv( v11 )*s11hat*v11 ). C ( Defer the scaling.) C X11(1) = CST(1)*E1 + CST(2)*E2 X11(2) = -CST(1)*E2 + CST(2)*E1 X21(1) = SNT*E1 X21(2) = -SNT*E2 X12(1) = SGN*( CST(1)*GAMMA(1) + CST(2)*GAMMA(2) ) - SNT*E1 X12(2) = SGN*( -CST(1)*GAMMA(2) + CST(2)*GAMMA(1) ) - SNT*E2 X22(1) = CST(1)*E1 + CST(2)*E2 + SGN*SNT*GAMMA(1) X22(2) = CST(1)*E2 - CST(2)*E1 - SGN*SNT*GAMMA(2) C C Now find B = X*That. ( Include the scaling here.) C S(1,1) = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) TEMPR = CST(1)*X21(1) + CST(2)*X21(2) - SNT*X22(1) TEMPI = CST(1)*X21(2) - CST(2)*X21(1) - SNT*X22(2) S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI TEMPR = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) TEMPI = CST(1)*X12(2) + CST(2)*X12(1) + SNT*X11(2) S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI S(2,2) = CST(1)*X22(1) - CST(2)*X22(2) + SNT*X21(1) C C Form X = ( inv( v11 )*p11 )*conjg( Phat' ). C TEMPR = DP(1)*ETA TEMPI = -DP(2)*ETA X11(1) = CSP(1)*TEMPR - CSP(2)*TEMPI + SNP*DELTA(1) X11(2) = CSP(1)*TEMPI + CSP(2)*TEMPR - SNP*DELTA(2) X21(1) = SNP*ALPHA X12(1) = -SNP*TEMPR + CSP(1)*DELTA(1) - CSP(2)*DELTA(2) X12(2) = -SNP*TEMPI - CSP(1)*DELTA(2) - CSP(2)*DELTA(1) X22(1) = CSP(1)*ALPHA X22(2) = -CSP(2)*ALPHA C C Finally form A = conjg( That' )*X. C TEMPR = CST(1)*X11(1) - CST(2)*X11(2) - SNT*X21(1) TEMPI = CST(1)*X22(2) + CST(2)*X22(1) A(1,1) = DT(1)*TEMPR + DT(2)*TEMPI TEMPR = CST(1)*X12(1) - CST(2)*X12(2) - SNT*X22(1) TEMPI = CST(1)*X12(2) + CST(2)*X12(1) - SNT*X22(1) A(1,2) = DT(1)*TEMPR + DT(2)*TEMPI A(2,1) = ZERO A(2,2) = CST(1)*X22(1) + CST(2)*X22(2) + SNT*X12(1) ELSE C C Case op(M) = M. C C Find X = That*( v11*s11hat*inv( v11 ) ). ( Defer the scaling.) C X11(1) = CST(1)*E1 + CST(2)*E2 X11(2) = CST(1)*E2 - CST(2)*E1 X21(1) = -SNT*E1 X21(2) = -SNT*E2 X12(1) = SGN*( CST(1)*GAMMA(1) - CST(2)*GAMMA(2) ) + SNT*E1 X12(2) = SGN*( -CST(1)*GAMMA(2) - CST(2)*GAMMA(1) ) - SNT*E2 X22(1) = CST(1)*E1 + CST(2)*E2 - SGN*SNT*GAMMA(1) X22(2) = -CST(1)*E2 + CST(2)*E1 + SGN*SNT*GAMMA(2) C C Now find B = X*conjg( That' ). ( Include the scaling here.) C S(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) TEMPR = CST(1)*X21(1) - CST(2)*X21(2) + SNT*X22(1) TEMPI = CST(1)*X21(2) + CST(2)*X21(1) + SNT*X22(2) S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI TEMPR = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) TEMPI = CST(1)*X12(2) - CST(2)*X12(1) - SNT*X11(2) S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI S(2,2) = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) C C Form X = Phat*( p11*inv( v11 ) ). C TEMPR = DP(1)*ETA TEMPI = -DP(2)*ETA X11(1) = CSP(1)*ALPHA X11(2) = CSP(2)*ALPHA X21(1) = SNP*ALPHA X12(1) = CSP(1)*DELTA(1) + CSP(2)*DELTA(2) - SNP*TEMPR X12(2) = -CSP(1)*DELTA(2) + CSP(2)*DELTA(1) - SNP*TEMPI X22(1) = CSP(1)*TEMPR + CSP(2)*TEMPI + SNP*DELTA(1) X22(2) = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*DELTA(2) C C Finally form A = X*conjg( That' ). C A(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) A(2,1) = ZERO A(1,2) = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) TEMPR = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) TEMPI = CST(1)*X22(2) - CST(2)*X22(1) A(2,2) = DT(1)*TEMPR + DT(2)*TEMPI END IF C IF( SCALE.NE.ONE ) THEN A(1,1) = SCALE*A(1,1) A(1,2) = SCALE*A(1,2) A(2,2) = SCALE*A(2,2) END IF C RETURN C *** Last line of SB03OY *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03AD.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SG03AD.f0000644000175000017500000006014415012430707017357 0ustar00lilgelilge00000000000000 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 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 If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 = 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 (or DGGES) 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 V. Sima, Sep. 1998, Dec. 1998, July 2011, Oct. 2017, May 2020. 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, MINGG, MINWRK, OPTWRK LOGICAL ISDISC, ISFACT, ISTRAN, ISUPPR, LQUERY, WANTBH, $ WANTSP, WANTX C .. Local Arrays .. LOGICAL BWORK(1) INTEGER ISAVE( 3 ) C .. External Functions .. DOUBLE PRECISION DLAMCH, DNRM2 LOGICAL DELCTG, LSAME EXTERNAL DELCTG, DLAMCH, DNRM2, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEGS, DGGES, DLACN2, 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' ) LQUERY = LDWORK.EQ.-1 C C Check the scalar input parameters. C INFO = 0 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 C C Compute minimal and optimal 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 MINGG = MAX( MINWRK, 8*N + 16 ) IF( LQUERY ) THEN IF ( ISFACT ) THEN OPTWRK = MINGG ELSE CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, $ N, A, LDA, E, LDE, I, ALPHAR, ALPHAI, BETA, $ Q, LDQ, Z, LDZ, DWORK, -1, BWORK, INFO1 ) OPTWRK = MAX( MINGG, INT( DWORK(1) ), N*N ) END IF ELSE IF ( MINWRK .GT. LDWORK ) THEN INFO = -25 END IF END IF C IF ( INFO .NE. 0 ) THEN CALL XERBLA( 'SG03AD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = OPTWRK 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 IF ( LDWORK .LT. MINGG ) THEN C C Use DGEGS for backward compatibilty with LDWORK value. 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 ) ELSE C C Use DGGES. The workspace is increased to avoid an error C return, while it should not really be larger than above. C ( Workspace: >= MAX(1,8*N+16) ) C CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N, $ A, LDA, E, LDE, I, ALPHAR, ALPHAI, BETA, Q, LDQ, $ Z, LDZ, DWORK, LDWORK, BWORK, INFO1 ) END IF IF ( INFO1 .NE. 0 ) THEN INFO = 2 RETURN END IF OPTWRK = INT( DWORK(1) ) ELSE OPTWRK = 0 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 DLACN2( N*N, DWORK(N*N+1), DWORK, IWORK, EST, KASE, ISAVE $ ) 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 control-4.1.2/src/slicot/src/PaxHeaders/MB04XY.f0000644000000000000000000000013215012430707016220 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04XY.f0000644000175000017500000001777115012430707017431 0ustar00lilgelilge00000000000000 SUBROUTINE MB04XY( JOBU, JOBV, M, N, X, LDX, TAUP, TAUQ, U, $ LDU, V, LDV, INUL, INFO ) C C PURPOSE C C To apply the Householder transformations Pj stored in factored C form into the columns of the array X, to the desired columns of C the matrix U by premultiplication, and/or the Householder C transformations Qj stored in factored form into the rows of the C array X, to the desired columns of the matrix V by C premultiplication. The Householder transformations Pj and Qj C are stored as produced by LAPACK Library routine DGEBRD. C C ARGUMENTS C C Mode Parameters C C JOBU CHARACTER*1 C Specifies whether to transform the columns in U as C follows: C = 'N': Do not transform the columns in U; C = 'A': Transform the columns in U (U has M columns); C = 'S': Transform the columns in U (U has min(M,N) C columns). C C JOBV CHARACTER*1 C Specifies whether to transform the columns in V as C follows: C = 'N': Do not transform the columns in V; C = 'A': Transform the columns in V (V has N columns); C = 'S': Transform the columns in V (V has min(M,N) C columns). C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrix X. M >= 0. C C N (input) INTEGER C The number of columns of the matrix X. N >= 0. C C X (input) DOUBLE PRECISION array, dimension (LDX,N) C The leading M-by-N part contains in the columns of its C lower triangle the Householder transformations Pj, and C in the rows of its upper triangle the Householder C transformations Qj in factored form. C X is modified by the routine but restored on exit. C C LDX INTEGER C The leading dimension of the array X. LDX >= MAX(1,M). C C TAUP (input) DOUBLE PRECISION array, dimension (MIN(M,N)) C The scalar factors of the Householder transformations Pj. C C TAUQ (input) DOUBLE PRECISION array, dimension (MIN(M,N)) C The scalar factors of the Householder transformations Qj. C C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) C On entry, U contains the M-by-M (if JOBU = 'A') or C M-by-min(M,N) (if JOBU = 'S') matrix U. C On exit, the Householder transformations Pj have been C applied to each column i of U corresponding to a parameter C INUL(i) = .TRUE. C NOTE that U is not referenced if JOBU = 'N'. C C LDU INTEGER C The leading dimension of the array U. C LDU >= MAX(1,M), if JOBU = 'A' or JOBU = 'S'; C LDU >= 1, if JOBU = 'N'. C C V (input/output) DOUBLE PRECISION array, dimension (LDV,*) C On entry, V contains the N-by-N (if JOBV = 'A') or C N-by-min(M,N) (if JOBV = 'S') matrix V. C On exit, the Householder transformations Qj have been C applied to each column i of V corresponding to a parameter C INUL(i) = .TRUE. C NOTE that V is not referenced if JOBV = 'N'. C C LDV INTEGER C The leading dimension of the array V. C LDV >= MAX(1,M), if JOBV = 'A' or JOBV = 'S'; C LDV >= 1, if JOBV = 'N'. C C INUL (input) LOGICAL array, dimension (MAX(M,N)) C INUL(i) = .TRUE. if the i-th column of U and/or V is to be C transformed, and INUL(i) = .FALSE., otherwise. C (1 <= i <= MAX(M,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 METHOD C C The Householder transformations Pj or Qj are applied to the C columns of U or V indexed by I for which INUL(I) = .TRUE.. 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, June 1997. C Supersedes Release 2.0 routine MB04PZ by S. Van Huffel, Katholieke C University Leuven, Belgium. C C REVISIONS C C - C C KEYWORDS C C Bidiagonalization, orthogonal transformation, singular subspace, C singular value decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBU, JOBV INTEGER INFO, LDU, LDV, LDX, M, N C .. Array Arguments .. LOGICAL INUL(*) DOUBLE PRECISION TAUP(*), TAUQ(*), U(LDU,*), V(LDV,*), $ X(LDX,*) C .. Local Scalars .. LOGICAL LJOBUA, LJOBUS, LJOBVA, LJOBVS, WANTU, WANTV INTEGER I, IM, IOFF, L, NCOL, P DOUBLE PRECISION FIRST C .. Local Arrays .. DOUBLE PRECISION DWORK(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARF, XERBLA C .. Intrinsic Functions .. INTRINSIC MIN, MAX C .. Executable Statements .. C INFO = 0 LJOBUA = LSAME( JOBU, 'A' ) LJOBUS = LSAME( JOBU, 'S' ) LJOBVA = LSAME( JOBV, 'A' ) LJOBVS = LSAME( JOBV, 'S' ) WANTU = LJOBUA.OR.LJOBUS WANTV = LJOBVA.OR.LJOBVS C C Test the input scalar arguments. C IF( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDX.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( ( WANTU.AND.LDU.LT.MAX( 1, M ) ) .OR. $ ( .NOT.WANTU.AND.LDU.LT.1 ) ) THEN INFO = -10 ELSE IF( ( WANTV.AND.LDV.LT.MAX( 1, N ) ) .OR. $ ( .NOT.WANTV.AND.LDV.LT.1 ) ) THEN INFO = -12 END IF C IF ( INFO.NE.0 ) THEN C C Error return C CALL XERBLA( 'MB04XY', -INFO ) RETURN END IF C C Quick return if possible. C P = MIN( M, N ) IF ( P.EQ.0 ) $ RETURN C IF ( M.LT.N ) THEN IOFF = 1 ELSE IOFF = 0 END IF C C Apply the Householder transformations Pj onto the desired C columns of U. C IM = MIN( M-1, N ) IF ( WANTU .AND. ( IM.GT.0 ) ) THEN IF ( LJOBUA ) THEN NCOL = M ELSE NCOL = P END IF C DO 40 I = 1, NCOL IF ( INUL(I) ) THEN C DO 20 L = IM, 1, -1 IF ( TAUP(L).NE.ZERO ) THEN FIRST = X(L+IOFF,L) X(L+IOFF,L) = ONE CALL DLARF( 'Left', M-L+1-IOFF, 1, X(L+IOFF,L), 1, $ TAUP(L), U(L+IOFF,I), LDU, DWORK ) X(L+IOFF,L) = FIRST END IF 20 CONTINUE C END IF 40 CONTINUE C END IF C C Apply the Householder transformations Qj onto the desired columns C of V. C IM = MIN( N-1, M ) IF ( WANTV .AND. ( IM.GT.0 ) ) THEN IF ( LJOBVA ) THEN NCOL = N ELSE NCOL = P END IF C DO 80 I = 1, NCOL IF ( INUL(I) ) THEN C DO 60 L = IM, 1, -1 IF ( TAUQ(L).NE.ZERO ) THEN FIRST = X(L,L+1-IOFF) X(L,L+1-IOFF) = ONE CALL DLARF( 'Left', N-L+IOFF, 1, X(L,L+1-IOFF), $ LDX, TAUQ(L), V(L+1-IOFF,I), LDV, $ DWORK ) X(L,L+1-IOFF) = FIRST END IF 60 CONTINUE C END IF 80 CONTINUE C END IF C RETURN C *** Last line of MB04XY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01TD.f0000644000000000000000000000013215012430707016164 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01TD.f0000644000175000017500000001043315012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE MB01TD( N, A, LDA, B, LDB, DWORK, INFO ) C C PURPOSE C C To compute the matrix product A * B, where A and B are upper C quasi-triangular matrices (that is, block upper triangular with C 1-by-1 or 2-by-2 diagonal blocks) with the same structure. C The result is returned in the array B. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and B. N >= 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 upper quasi-triangular matrix A. The elements below the C subdiagonal are not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) C On entry, the leading N-by-N part of this array must C contain the upper quasi-triangular matrix B, with the same C structure as matrix A. C On exit, the leading N-by-N part of this array contains C the computed product A * B, with the same structure as C on entry. C The elements below the subdiagonal are not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (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 = 1: if the matrices A and B have not the same structure, C and/or A and B are not upper quasi-triangular. C C METHOD C C The matrix product A * B is computed column by column, using C BLAS 2 and BLAS 1 operations. C C FURTHER COMMENTS C C This routine can be used, for instance, for computing powers of C a real Schur form matrix. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. C C REVISIONS C C V. Sima, Feb. 2000. 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 .. INTEGER INFO, LDA, LDB, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*) C .. Local Scalars .. INTEGER I, J, JMIN, JMNM C .. External Subroutines .. EXTERNAL DAXPY, DTRMV, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -5 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01TD', -INFO ) RETURN END IF C C Quick return, if possible. C IF ( N.EQ.0 ) THEN RETURN ELSE IF ( N.EQ.1 ) THEN B(1,1) = A(1,1)*B(1,1) RETURN END IF C C Test the upper quasi-triangular structure of A and B for identity. C DO 10 I = 1, N - 1 IF ( A(I+1,I).EQ.ZERO ) THEN IF ( B(I+1,I).NE.ZERO ) THEN INFO = 1 RETURN END IF ELSE IF ( I.LT.N-1 ) THEN IF ( A(I+2,I+1).NE.ZERO ) THEN INFO = 1 RETURN END IF END IF 10 CONTINUE C DO 30 J = 1, N JMIN = MIN( J+1, N ) JMNM = MIN( JMIN, N-1 ) C C Compute the contribution of the subdiagonal of A to the C j-th column of the product. C DO 20 I = 1, JMNM DWORK(I) = A(I+1,I)*B(I,J) 20 CONTINUE C C Multiply the upper triangle of A by the j-th column of B, C and add to the above result. C CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', JMIN, A, LDA, $ B(1,J), 1 ) CALL DAXPY( JMNM, ONE, DWORK, 1, B(2,J), 1 ) 30 CONTINUE C RETURN C *** Last line of MB01TD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB04BW.f0000644000000000000000000000013215012430707016177 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB04BW.f0000644000175000017500000002055215012430707017377 0ustar00lilgelilge00000000000000 SUBROUTINE TB04BW( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN, $ GD, D, LDD, INFO ) C C PURPOSE C C To compute the sum of an P-by-M rational matrix G and a real C P-by-M matrix D. C C ARGUMENTS C C Mode Parameters C C ORDER CHARACTER*1 C Specifies the order in which the polynomial coefficients C of the rational matrix are stored, as follows: C = 'I': Increasing order of powers of the indeterminate; C = 'D': Decreasing order of powers of the indeterminate. C C Input/Output Parameters C C P (input) INTEGER C The number of the system outputs. P >= 0. C C M (input) INTEGER C The number of the system inputs. M >= 0. C C MD (input) INTEGER C The maximum degree of the polynomials in G, plus 1, i.e., C MD = MAX(IGN(I,J),IGD(I,J)) + 1. C I,J C C IGN (input/output) INTEGER array, dimension (LDIGN,M) C On entry, the leading P-by-M part of this array must C contain the degrees of the numerator polynomials in G: C the (i,j) element of IGN must contain the degree of the C numerator polynomial of the polynomial ratio G(i,j). C On exit, the leading P-by-M part of this array contains C the degrees of the numerator polynomials in G + D. C C LDIGN INTEGER C The leading dimension of array IGN. LDIGN >= max(1,P). C C IGD (input) INTEGER array, dimension (LDIGD,M) C The leading P-by-M part of this array must contain the C degrees of the denominator polynomials in G (and G + D): C the (i,j) element of IGD contains the degree of the C denominator polynomial of the polynomial ratio G(i,j). C C LDIGD INTEGER C The leading dimension of array IGD. LDIGD >= max(1,P). C C GN (input/output) DOUBLE PRECISION array, dimension (P*M*MD) C On entry, this array must contain the coefficients of the C numerator polynomials, Num(i,j), of the rational matrix G. C The polynomials are stored in a column-wise order, i.e., C Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2), C ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M); C MD memory locations are reserved for each polynomial, C hence, the (i,j) polynomial is stored starting from the C location ((j-1)*P+i-1)*MD+1. The coefficients appear in C increasing or decreasing order of the powers of the C indeterminate, according to ORDER. C On exit, this array contains the coefficients of the C numerator polynomials of the rational matrix G + D, C stored similarly. C C GD (input) DOUBLE PRECISION array, dimension (P*M*MD) C This array must contain the coefficients of the C denominator polynomials, Den(i,j), of the rational C matrix G. The polynomials are stored as for the C numerator polynomials. C C D (input) DOUBLE PRECISION array, dimension (LDD,M) C The leading P-by-M part of this array must contain the C matrix D. C C LDD INTEGER C The leading dimension of array D. LDD >= max(1,P). 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 (i,j) entry of the real matrix D is added to the (i,j) entry C of the matrix G, g(i,j), which is a ratio of two polynomials, C for i = 1 : P, and for j = 1 : M. If g(i,j) = 0, it is assumed C that its denominator is 1. C C NUMERICAL ASPECTS C C The algorithm is numerically stable. C C FURTHER COMMENTS C C Often, the rational matrix G is found from a state-space C representation (A,B,C), and D corresponds to the direct C feedthrough matrix of the system. The sum G + D gives the C transfer function matrix of the system (A,B,C,D). C For maximum efficiency of index calculations, GN and GD are C implemented as one-dimensional arrays. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, May 2002. C Based on the BIMASC Library routine TMCADD by A. Varga. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. C C KEYWORDS C C State-space representation, transfer function. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER ORDER INTEGER INFO, LDD, LDIGD, LDIGN, M, MD, P C .. Array Arguments .. DOUBLE PRECISION D(LDD,*), GD(*), GN(*) INTEGER IGD(LDIGD,*), IGN(LDIGN,*) C .. Local Scalars .. LOGICAL ASCEND INTEGER I, II, J, K, KK, KM, ND, NN DOUBLE PRECISION DIJ C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the input scalar parameters. C INFO = 0 ASCEND = LSAME( ORDER, 'I' ) IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN INFO = -1 ELSE IF( P.LT.0 ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( MD.LT.1 ) THEN INFO = -4 ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN INFO = -6 ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN INFO = -8 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -12 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB04BW', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( P, M ).EQ.0 ) $ RETURN C K = 1 C IF ( ASCEND ) THEN C C Polynomial coefficients are stored in increasing order. C DO 30 J = 1, M C DO 20 I = 1, P DIJ = D(I,J) IF ( DIJ.NE.ZERO ) THEN NN = IGN(I,J) ND = IGD(I,J) IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN IF ( GN(K).EQ.ZERO ) THEN GN(K) = DIJ ELSE GN(K) = GN(K) + DIJ*GD(K) ENDIF ELSE KM = MIN( NN, ND ) + 1 CALL DAXPY( KM, DIJ, GD(K), 1, GN(K), 1 ) IF ( NN.LT.ND ) THEN C DO 10 II = K + KM, K + ND GN(II) = DIJ*GD(II) 10 CONTINUE C IGN(I,J) = ND ENDIF ENDIF ENDIF K = K + MD 20 CONTINUE C 30 CONTINUE C ELSE C C Polynomial coefficients are stored in decreasing order. C DO 60 J = 1, M C DO 50 I = 1, P DIJ = D(I,J) IF ( DIJ.NE.ZERO ) THEN NN = IGN(I,J) ND = IGD(I,J) IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN IF ( GN(K).EQ.ZERO ) THEN GN(K) = DIJ ELSE GN(K) = GN(K) + DIJ*GD(K) ENDIF ELSE KM = MIN( NN, ND ) + 1 IF ( NN.LT.ND ) THEN KK = K + ND - NN C DO 35 II = K + NN, K, -1 GN(II+ND-NN) = GN(II) 35 CONTINUE C DO 40 II = K, KK - 1 GN(II) = DIJ*GD(II) 40 CONTINUE C IGN(I,J) = ND CALL DAXPY( KM, DIJ, GD(KK), 1, GN(KK), 1 ) ELSE KK = K + NN - ND CALL DAXPY( KM, DIJ, GD(K), 1, GN(KK), 1 ) ENDIF ENDIF ENDIF K = K + MD 50 CONTINUE C 60 CONTINUE C ENDIF C RETURN C *** Last line of TB04BW *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03FD.f0000644000000000000000000000013215012430707016150 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03FD.f0000644000175000017500000002377315012430707017360 0ustar00lilgelilge00000000000000 SUBROUTINE MB03FD( N, PREC, A, LDA, B, LDB, Q1, LDQ1, Q2, LDQ2, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute orthogonal matrices Q1 and Q2 for a real 2-by-2 or C 4-by-4 regular pencil C C ( A11 0 ) ( 0 B12 ) C aA - bB = a ( ) - b ( ), (1) C ( 0 A22 ) ( B21 0 ) C C such that Q2' A Q1 is upper triangular, Q2' B Q1 is upper quasi- C triangular, and the eigenvalues with negative real parts (if there C are any) are allocated on the top. The notation M' denotes the C transpose of the matrix M. The submatrices A11, A22, and B12 are C upper triangular. If B21 is 2-by-2, then all the other blocks are C -1 -1 C nonsingular and the product A11 B12 A22 B21 has a pair of C complex conjugate eigenvalues. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the input pencil, N = 2 or N = 4. C C PREC (input) DOUBLE PRECISION C The machine precision, (relative machine precision)*base. C See the LAPACK Library routine DLAMCH. 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 of the pencil aA - bB. C If N = 2, the diagonal elements only are referenced. C On exit, if N = 4, the leading N-by-N part of this array C contains the transformed upper triangular matrix of the C generalized real Schur form of the pencil aA - bB. C If N = 2, this array is unchanged on exit. C C LDA INTEGER C The leading dimension of the array A. LDA >= N. C C B (input/output) DOUBLE PRECISION array, dimension (LDB, N) C On entry, the leading N-by-N part of this array must C contain the matrix B of the pencil aA - bB. C If N = 2, the anti-diagonal elements only are referenced. C On exit, if N = 4, the leading N-by-N part of this array C contains the transformed real Schur matrix of the C generalized real Schur form of the pencil aA - bB. C If N = 2, this array is unchanged on exit. C C LDB INTEGER C The leading dimension of the array B. LDB >= N. C C Q1 (output) DOUBLE PRECISION array, dimension (LDQ1, N) C The leading N-by-N part of this array contains the first C orthogonal transformation matrix. C C LDQ1 INTEGER C The leading dimension of the array Q1. LDQ1 >= N. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N) C The leading N-by-N part of this array contains the second C orthogonal transformation matrix. C C LDQ2 INTEGER C The leading dimension of the array Q2. LDQ2 >= N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C If N = 2, then DWORK is not referenced. C C LDWORK INTEGER C The dimension of the array DWORK. C If N = 4, then LDWORK >= 63. For good performance LDWORK C should be generally larger. C If N = 2, then LDWORK >= 0. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: the QZ iteration failed in the LAPACK routine DGGES; C = 2: another error occured during execution of DGGES. C C METHOD C C The algorithm uses orthogonal transformations as described on page C 29 in [2]. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical computation of deflating subspaces of skew- C Hamiltonian/Hamiltonian pencils. C SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002. C C [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 16, 2008. C C REVISIONS C C V. Sima, Aug. 2009 (SLICOT version of the routine MB03FD). C V. Sima, Oct. 2009, Nov. 2009, Oct. 2010, Nov. 2010, Mar. 2016, C Mai 2016. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue exchange, matrix pencil, upper (quasi-)triangular C matrix. 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, LDB, LDQ1, LDQ2, LDWORK, N DOUBLE PRECISION PREC C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), $ Q1( LDQ1, * ), Q2( LDQ2, * ) C C .. Local Scalars .. INTEGER IDUM, IERR, IHI, ILO DOUBLE PRECISION A11, A22, B12, B21, CO, SAFMIN, SCALA, SCALB, $ SI, TMP C C .. Local Arrays .. LOGICAL BWORK( 4 ) DOUBLE PRECISION AS( 4, 4 ), BS( 4, 4 ), C( 4 ), R( 4 ) C C .. External Functions .. LOGICAL SB02OW DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, SB02OW C C .. External Subroutines .. EXTERNAL DGGBAK, DGGES, DLACPY, DLARTG, MB04DL C C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C C Computations. C IF( N.EQ.4 ) THEN C C Save A and B, since DGGES might not converge. C CALL DLACPY( 'Full', N, N, A, LDA, AS, 4 ) CALL DLACPY( 'Full', N, N, B, LDB, BS, 4 ) CALL DGGES( 'Vector Computation', 'Vector Computation', $ 'Sorted', SB02OW, N, B, LDB, A, LDA, IDUM, DWORK, $ DWORK( N+1 ), DWORK( 2*N+1 ), Q2, LDQ2, Q1, LDQ1, $ DWORK( 3*N+1 ), LDWORK-3*N, BWORK, INFO ) IF( INFO.NE.0 ) THEN C C Retry after balancing. C CALL DLACPY( 'Full', N, N, AS, 4, A, LDA ) CALL DLACPY( 'Full', N, N, BS, 4, B, LDB ) CALL MB04DL( 'Both', N, ZERO, B, LDB, A, LDA, ILO, IHI, C, $ R, DWORK, IDUM, IERR ) CALL DGGES( 'Vector Computation', 'Vector Computation', $ 'Sorted', SB02OW, N, B, LDB, A, LDA, IDUM, $ DWORK, DWORK( N+1 ), DWORK( 2*N+1 ), Q2, LDQ2, $ Q1, LDQ1, DWORK( 3*N+1 ), LDWORK-3*N, BWORK, $ IERR ) C C If DGGES fails again, error return based on previous call. C IF( IERR.NE.0 ) THEN IF( INFO.GE.1 .AND. INFO.LE.4 ) THEN INFO = 1 ELSE INFO = 2 END IF RETURN END IF CALL DGGBAK( 'Both', 'Right', N, ILO, IHI, C, R, N, Q1, $ LDQ1, INFO ) CALL DGGBAK( 'Both', 'Left', N, ILO, IHI, C, R, N, Q2, $ LDQ2, INFO ) END IF ELSE INFO = 0 C C Set Q1, and Q2 to I_2, or permuted I_2, if there are 0, purely C imaginary, or infinite eigenvalues. C A11 = ABS( A( 1, 1 ) ) A22 = ABS( A( 2, 2 ) ) B21 = ABS( B( 2, 1 ) ) B12 = ABS( B( 1, 2 ) ) C SAFMIN = DLAMCH( 'Safe minimum' ) SCALA = ONE / MAX( A11, A22, SAFMIN ) SCALB = ONE / MAX( B12, B21, SAFMIN ) C A11 = SCALA*A11 A22 = SCALA*A22 B21 = SCALB*B21 B12 = SCALB*B12 IF( A11.LE.PREC ) THEN Q1( 1, 1 ) = ONE Q1( 2, 1 ) = ZERO Q1( 1, 2 ) = ZERO Q1( 2, 2 ) = ONE Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO ELSE IF( A22.LE.PREC ) THEN Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ONE Q2( 2, 1 ) = ZERO Q2( 1, 2 ) = ZERO Q2( 2, 2 ) = ONE ELSE IF( B21.LE.PREC ) THEN Q1( 1, 1 ) = ONE Q1( 2, 1 ) = ZERO Q1( 1, 2 ) = ZERO Q1( 2, 2 ) = ONE Q2( 1, 1 ) = ONE Q2( 2, 1 ) = ZERO Q2( 1, 2 ) = ZERO Q2( 2, 2 ) = ONE ELSE IF( B12.LE.PREC ) THEN Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO ELSE IF( SIGN( ONE, A( 1, 1 ) )*SIGN( ONE, A( 2, 2 ) )* $ SIGN( ONE, B( 2, 1 ) )*SIGN( ONE, B( 1, 2 ) ).GT.ZERO $ ) THEN C C The pencil has two real eigenvalues. C CALL DLARTG( SIGN( ONE, A( 1, 1 )*A( 2, 2 ) )* $ SQRT( A22*B12 ), SQRT( A11*B21 ), CO, SI, $ TMP ) Q1( 1, 1 ) = CO Q1( 2, 1 ) = -SI Q1( 1, 2 ) = SI Q1( 2, 2 ) = CO CALL DLARTG( SQRT( A11*B12 ), SQRT( A22*B21 ), CO, SI, $ TMP ) Q2( 1, 1 ) = CO Q2( 2, 1 ) = -SI Q2( 1, 2 ) = SI Q2( 2, 2 ) = CO ELSE Q1( 1, 1 ) = ONE Q1( 2, 1 ) = ZERO Q1( 1, 2 ) = ZERO Q1( 2, 2 ) = ONE Q2( 1, 1 ) = ONE Q2( 2, 1 ) = ZERO Q2( 1, 2 ) = ZERO Q2( 2, 2 ) = ONE END IF END IF END IF C RETURN C *** Last line of MB03FD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03AH.f0000644000000000000000000000013215012430707016147 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03AH.f0000644000175000017500000002201015012430707017336 0ustar00lilgelilge00000000000000 SUBROUTINE MB03AH( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, C1, $ S1, C2, S2 ) C C PURPOSE C C To compute two Givens rotations (C1,S1) and (C2,S2) such that the C orthogonal matrix C C [ Q 0 ] [ C1 S1 0 ] [ 1 0 0 ] C Z = [ ], Q := [ -S1 C1 0 ] * [ 0 C2 S2 ], C [ 0 I ] [ 0 0 1 ] [ 0 -S2 C2 ] C C makes the first column of the real Wilkinson double shift C polynomial of the product of matrices in periodic upper Hessenberg C form, stored in the array A, parallel to the first unit vector. C Only the rotation defined by C1 and S1 is used for the real C Wilkinson single shift polynomial (see SLICOT Library routines C MB03BE or MB03BF). All factors whose exponents differ from that of C the Hessenberg factor are assumed nonsingular. The trailing 2-by-2 C submatrix and the five nonzero elements in the first two columns C of the matrix product are evaluated when a double shift is used. C C ARGUMENTS C C Mode Parameters C C SHFT CHARACTER*1 C Specifies the number of shifts employed by the shift C polynomial, as follows: C = 'D': two shifts (assumes N > 2); C = 'S': one real shift. C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of the factors. N >= 2. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C AMAP(K) is the pointer to the Hessenberg matrix. C Before calling this routine, AMAP returned by SLICOT C Library routine MB03BA should be modified as follows: C J = AMAP(1), AMAP(I) = AMAP(I+1), I = 1:K-1, AMAP(K) = J. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input) DOUBLE PRECISION array, dimension (LDA1,LDA2,K) C The leading N-by-N-by-K part of this array must contain C the product (implicitly represented by its K factors) C in periodic upper Hessenberg form. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= N. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= N. C C C1 (output) DOUBLE PRECISION C S1 (output) DOUBLE PRECISION C On exit, C1 and S1 contain the parameters for the first C Givens rotation. C C C2 (output) DOUBLE PRECISION C S2 (output) DOUBLE PRECISION C On exit, if SHFT = 'D' and N > 2, C2 and S2 contain the C parameters for the second Givens rotation. Otherwise, C C2 = 1, S2 = 0. C C METHOD C C The necessary elements of the real Wilkinson double/single shift C polynomial are computed, and suitable Givens rotations are found. C For numerical reasons, this routine should be called when C convergence difficulties are encountered. For a double shift, if C there are two real eigenvalues of the trailing 2-by-2 part of the C product, both shifts are chosen equal to the eigenvalue with C minimum modulus. The trailing element of the product is used as a C single shift. If SINV is negative, the shift(s) correspond to the C reciprocals of the eigenvalues of the product, as required by the C SLICOT Library routine MB03BD. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Aug. 2019, Dec. 2020. C C REVISIONS C C V. Sima, Sep. 2019, Dec. 2019, Jan. 2020, Feb. 2020, Mar. 2020. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO, ZERO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER SHFT INTEGER K, LDA1, LDA2, N, SINV DOUBLE PRECISION C1, C2, S1, S2 C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*) C .. Local Scalars .. LOGICAL SGLE INTEGER I, IC, IND, J, M, MM DOUBLE PRECISION E1, E2, P1, P2, P3, PR, SCL, SM, T C .. Local Arrays .. INTEGER IP(3), JP(3) DOUBLE PRECISION DWORK(9), WI(2), WR(2), Y(9), Z(2,2) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGESC2, DGETC2, DLACPY, DLANV2, DLARTG, $ DLASET, DTRMV C .. Intrinsic Functions .. INTRINSIC ABS, MIN C C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked for errors. C C Evaluate the needed part of the matrix product. C SGLE = LSAME( SHFT, 'S' ) .OR. N.EQ.2 C M = MIN( N, 3 ) MM = M*M C CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK, M ) C DO 30 J = K - 1, 1, -1 I = AMAP(J) IF ( S(I).EQ.SINV ) THEN C DO 10 IC = 1, MM, M CALL DTRMV( 'Upper', 'NoTran', 'NonUnit', M, A(1,1,I), $ LDA1, DWORK(IC), 1 ) 10 CONTINUE C ELSE C C Complete pivoting is used for triangular factors whose C exponents differ from SINV. It is assumed that no overflow C could appear when solving linear systems, hence SCL = 1. C CALL DLACPY( 'Upper', M, M, A(1,1,I), LDA1, Y, M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, Y(2), M ) CALL DGETC2( M, Y, M, IP, JP, IND ) C DO 20 IC = 1, MM, M CALL DGESC2( M, Y, M, DWORK(IC), IP, JP, SCL ) 20 CONTINUE C END IF 30 CONTINUE C C Compute successively in Y(1:3) the nonzero elements of the first C two columns of the product, and save the results. C I = AMAP(K) CALL DCOPY( 2, A(1,1,I), 1, Y, 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NonUnit', 2, DWORK, M, Y, 1 ) E1 = Y(1) E2 = Y(2) C IF ( SGLE ) THEN P1 = ONE C C Compute the (N,N) element of the product and the rotations. C This element is used as shift. C DO 40 J = 1, K I = AMAP(J) IF ( S(I).EQ.SINV ) THEN P1 = P1*A(N,N,I) ELSE P1 = P1/A(N,N,I) END IF 40 CONTINUE C CALL DLARTG( E1 - P1, E2, C1, S1, E1 ) C2 = ONE S2 = ZERO C ELSE C CALL DCOPY( M, A(1,2,I), 1, Y, 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NonUnit', M, DWORK, M, Y, 1) P1 = Y(1) P2 = Y(2) P3 = Y(3) C C Compute the bottom 2-by-2 part using complete pivoting. C CALL DLASET( 'Full', 2, 2, ZERO, ONE, Z, 2 ) C M = N - 1 C DO 50 J = K - 1, 1, -1 I = AMAP(J) IF ( S(I).EQ.SINV ) THEN Z(1,1) = A(M,M,I)*Z(1,1) Z(1,2) = A(M,M,I)*Z(1,2) + A(M,N,I)*Z(2,2) Z(2,2) = A(N,N,I)*Z(2,2) ELSE Y(1) = A(M,M,I) Y(2) = ZERO CALL DCOPY( 2, A(M,N,I), 1, Y(3), 1 ) CALL DGETC2( 2, Y, 2, IP, JP, IND ) CALL DGESC2( 2, Y, 2, Z, IP, JP, SCL ) CALL DGESC2( 2, Y, 2, Z(1,2), IP, JP, SCL ) END IF 50 CONTINUE C I = AMAP(K) T = Z(1,1)*A(M,M,I) + Z(1,2)*A(N,M,I) Z(1,2) = Z(1,1)*A(M,N,I) + Z(1,2)*A(N,N,I) Z(1,1) = T Z(2,1) = Z(2,2)*A(N,M,I) Z(2,2) = Z(2,2)*A(N,N,I) C C Compute the eigenvalues of the bottom 2-by-2 part. C If there are two real eigenvalues, both shifts are chosen equal C to the eigenvalue with minimum modulus. Only the sum and C product of the shifts are needed. C CALL DLANV2( Z(1,1), Z(1,2), Z(2,1), Z(2,2), WR(1), WI(1), $ WR(2), WI(2), C1, S1 ) IF ( WI(1).EQ.ZERO ) THEN IF ( ABS( WR(1) ).LT.ABS( WR(2) ) ) THEN T = WR(1) ELSE T = WR(2) END IF SM = TWO*T PR = T**2 ELSE SM = TWO*WR(1) PR = WR(1)**2 + WI(1)**2 END IF C C Compute a multiple of the first column of the real Wilkinson C double shift polynomial, having only three nonzero elements. C P1 = P1 + ( ( E1 - SM )*E1 + PR )/E2 P2 = P2 + E1 - SM C C Compute the rotations to annihilate P2 and P3. C CALL DLARTG( P2, P3, C2, S2, E1 ) CALL DLARTG( P1, E1, C1, S1, E2 ) END IF C RETURN C *** Last line of MB03AH *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10DD.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10DD.f0000644000175000017500000010366215012430707017356 0ustar00lilgelilge00000000000000 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 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 control-4.1.2/src/slicot/src/PaxHeaders/SB10ED.f0000644000000000000000000000013215012430707016153 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10ED.f0000644000175000017500000003773215012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE SB10ED( N, M, NP, NCON, NMEAS, 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 PURPOSE C C To compute the matrices of the H2 optimal n-state 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 | 0 D12 | | C | D | C | C2 | D21 D22 | C C where B2 has as column size the number of control inputs (NCON) C and C2 has as row size the number of measurements (NMEAS) being C 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 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 A (input/worksp.) 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 This array is modified internally, but it is restored on C exit. 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 (7) C RCOND contains estimates the reciprocal condition C numbers of the matrices which are to be inverted and the C reciprocal condition numbers of the Riccati equations C which have to be solved during the computation of the C controller. (See the description of the algorithm in [2].) C RCOND(1) contains the reciprocal condition number of the C control transformation matrix TU; C RCOND(2) contains the reciprocal condition number of the C measurement transformation matrix TY; C RCOND(3) contains the reciprocal condition number of the C matrix Im2 + B2'*X2*B2; C RCOND(4) contains the reciprocal condition number of the C matrix Ip2 + C2*Y2*C2'; C RCOND(5) contains the reciprocal condition number of the C X-Riccati equation; C RCOND(6) contains the reciprocal condition number of the C Y-Riccati equation; C RCOND(7) contains the reciprocal condition number of the C matrix Im2 + DKHAT*D22 . C C Tolerances C C TOL DOUBLE PRECISION C Tolerance used for controlling the accuracy of the C transformations applied for diagonalizing D12 and D21, C and for checking the nonsingularity of the matrices to be C inverted. 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 (max(2*M2,2*N,N*N,NP2)) 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+max(1,14*N*N+6*N+max(14*N+23,16*N),M2*(N+M2+ C max(3,M1)),NP2*(N+NP2+3)), C LW6 = max(N*M2,N*NP2,M2*NP2,M2*M2+4*M2), C with M1 = M - M2 and NP1 = NP - NP2. 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+max(1,14*N*N+6*N+max(14*N+23,16*N), C Q*(N+Q+max(Q,3)))). 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 in respect to the tolerance EPS; C j*Theta C = 2: if the matrix | A-e *I B1 | had not full C | C2 D21 | C row 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-I B2 |, |A-I B1 |, D12 or D21). C |C1 D12| |C2 D21| C = 6: if the X-Riccati equation was not solved C successfully; C = 7: if the matrix Im2 + B2'*X2*B2 is not positive C definite, or it is numerically singular (with C respect to the tolerance TOL); C = 8: if the Y-Riccati equation was not solved C successfully; C = 9: if the matrix Ip2 + C2*Y2*C2' is not positive C definite, or it is numerically singular (with C respect to the tolerance TOL); C =10: if the matrix Im2 + DKHAT*D22 is singular, or its C estimated condition number is larger than or equal C to 1/TOL. C C METHOD C C The routine implements the formulas given in [1]. C C REFERENCES C C [1] Zhou, K., Doyle, J.C., and Glover, K. C Robust and Optimal Control. C Prentice-Hall, Upper Saddle River, NJ, 1996. 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 The accuracy of the result depends on the condition numbers of the C matrices which are to be inverted and on the condition numbers of C the matrix Riccati equations which are to be solved in the C computation of the controller. (The corresponding reciprocal C condition numbers are given in the output array RCOND.) C C CONTRIBUTORS C C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 1999. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, May 1999, C Sept. 1999, Feb. 2000, Nov. 2005. C C KEYWORDS C C Algebraic Riccati equation, H2 optimal control, optimal regulator, C robust 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 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( * ) LOGICAL BWORK( * ) C .. C .. Local Scalars .. INTEGER I, INFO2, IWC, IWD, IWRK, IWTU, IWTY, IWX, IWY, $ LW1, LW2, LW3, LW4, LW5, LW6, LWAMAX, M1, M2, $ M2L, MINWRK, NL, NLP, NP1, NP2, NPL DOUBLE PRECISION TOLL C .. C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. C .. External Subroutines .. EXTERNAL DLACPY, SB10PD, SB10SD, SB10TD, 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 NL = MAX( 1, N ) NPL = MAX( 1, NP ) M2L = MAX( 1, M2 ) NLP = MAX( 1, NP2 ) 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( LDA.LT.NL ) THEN INFO = -7 ELSE IF( LDB.LT.NL ) THEN INFO = -9 ELSE IF( LDC.LT.NPL ) THEN INFO = -11 ELSE IF( LDD.LT.NPL ) THEN INFO = -13 ELSE IF( LDAK.LT.NL ) THEN INFO = -15 ELSE IF( LDBK.LT.NL ) THEN INFO = -17 ELSE IF( LDCK.LT.M2L ) THEN INFO = -19 ELSE IF( LDDK.LT.M2L ) THEN INFO = -21 ELSE C C Compute workspace. C 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 + MAX( 1, 14*N*N + $ 6*N + MAX( 14*N + 23, 16*N ), $ M2*( N + M2 + MAX( 3, M1 ) ), $ NP2*( N + NP2 + 3 ) ) LW6 = MAX( N*M2, N*NP2, M2*NP2, M2*M2 + 4*M2 ) MINWRK = N*M + NP*( N + M ) + M2*M2 + NP2*NP2 + $ MAX( 1, LW1, LW2, LW3, LW4, LW5, LW6 ) IF( LDWORK.LT.MINWRK ) $ INFO = -26 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10ED', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 .AND. MAX( M2, 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 DWORK( 1 ) = ONE RETURN END IF C TOLL = TOL IF( TOLL.LE.ZERO ) THEN C C Set the default value of the tolerance for rank tests. C TOLL = SQRT( DLAMCH( 'Epsilon' ) ) END IF C C Workspace usage. C IWC = N*M + 1 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, NL ) CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NPL ) CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NPL ) C C Transform the system so that D12 and D21 satisfy the formulas C in the computation of the H2 optimal controller. C Since SLICOT Library routine SB10PD performs the tests C corresponding to the continuous-time counterparts of the C assumptions (A3) and (A4), for the frequency w = 0, the C next SB10PD routine call uses A - I. C DO 10 I = 1, N A(I,I) = A(I,I) - ONE 10 CONTINUE C CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, NL, $ DWORK( IWC ), NPL, DWORK( IWD ), NPL, DWORK( IWTU ), $ M2L, DWORK( IWTY ), NLP, RCOND, TOLL, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO2 ) C DO 20 I = 1, N A(I,I) = A(I,I) + ONE 20 CONTINUE C IF( INFO2.GT.0 ) THEN INFO = INFO2 RETURN END IF LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 C IWX = IWRK IWY = IWX + N*N IWRK = IWY + N*N C C Compute the optimal H2 controller for the normalized system. C CALL SB10SD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, NL, $ DWORK( IWC ), NPL, DWORK( IWD ), NPL, AK, LDAK, BK, $ LDBK, CK, LDCK, DK, LDDK, DWORK( IWX ), NL, $ DWORK( IWY ), NL, RCOND( 3 ), TOLL, 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 IWRK = IWX C C Compute the H2 optimal controller for the original system. C CALL SB10TD( N, M, NP, NCON, NMEAS, DWORK( IWD ), NPL, $ DWORK( IWTU ), M2L, DWORK( IWTY ), NLP, AK, LDAK, BK, $ LDBK, CK, LDCK, DK, LDDK, RCOND( 7 ), TOLL, IWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 10 RETURN END IF C DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10ED *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04PY.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04PY.f0000644000175000017500000004323115012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE MB04PY( SIDE, M, N, V, TAU, C, LDC, DWORK ) C C PURPOSE C C To apply a real elementary reflector H to a real m-by-n matrix C C, from either the left or the right. H is 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 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 Mode Parameters C C SIDE CHARACTER*1 C Indicates whether the elementary reflector should be C applied from the left or from the right, as follows: C = 'L': Compute H * C; C = 'R': Compute C * H. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrix C. M >= 0. C C N (input) INTEGER C The number of columns of the matrix C. N >= 0. C C V (input) DOUBLE PRECISION array, dimension C (M-1), if SIDE = 'L', or C (N-1), if SIDE = 'R'. C The vector v in the representation of H. C C TAU (input) DOUBLE PRECISION C The scalar factor of the elementary reflector H. 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 matrix C. C On exit, the leading M-by-N part of this array contains C the matrix H * C, if SIDE = 'L', or C * H, if SIDE = 'R'. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,M). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (N), if SIDE = 'L', or C (M), if SIDE = 'R'. 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 its special C structure into account. The multiplications by the first component C of u (which is 1) are avoided, to increase the efficiency. C C NUMERICAL ASPECTS C C The algorithm is backward stable. C C CONTRIBUTORS C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. C This is a modification of LAPACK Library routine DLARFX. * 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.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER SIDE INTEGER LDC, M, N DOUBLE PRECISION TAU C .. C .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), DWORK( * ), V( * ) C .. C .. Local Scalars .. INTEGER J DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V2, V3, V4, V5, V6, V7, V8, V9 C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DGER C .. C .. Executable Statements .. C IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN C C Form H * C, where H has order m. C GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 ) M C C Code for general M. C C w := C'*u. C CALL DCOPY( N, C, LDC, DWORK, 1 ) CALL DGEMV( 'Transpose', M-1, N, ONE, C( 2, 1 ), LDC, V, 1, $ ONE, DWORK, 1 ) C C C := C - tau * u * w'. C CALL DAXPY( N, -TAU, DWORK, 1, C, LDC ) CALL DGER( M-1, N, -TAU, V, 1, DWORK, 1, C( 2, 1 ), LDC ) GO TO 410 10 CONTINUE C C Special code for 1 x 1 Householder. C T1 = ONE - TAU DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE C C Special code for 2 x 2 Householder. C V1 = V( 1 ) T1 = TAU*V1 DO 40 J = 1, N SUM = C( 1, J ) + V1*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*TAU C( 2, J ) = C( 2, J ) - SUM*T1 40 CONTINUE GO TO 410 50 CONTINUE C C Special code for 3 x 3 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 60 J = 1, N SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*TAU C( 2, J ) = C( 2, J ) - SUM*T1 C( 3, J ) = C( 3, J ) - SUM*T2 60 CONTINUE GO TO 410 70 CONTINUE C C Special code for 4 x 4 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 80 J = 1, N SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + $ V3*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*TAU C( 2, J ) = C( 2, J ) - SUM*T1 C( 3, J ) = C( 3, J ) - SUM*T2 C( 4, J ) = C( 4, J ) - SUM*T3 80 CONTINUE GO TO 410 90 CONTINUE C C Special code for 5 x 5 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 100 J = 1, N SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + $ V3*C( 4, J ) + V4*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*TAU C( 2, J ) = C( 2, J ) - SUM*T1 C( 3, J ) = C( 3, J ) - SUM*T2 C( 4, J ) = C( 4, J ) - SUM*T3 C( 5, J ) = C( 5, J ) - SUM*T4 100 CONTINUE GO TO 410 110 CONTINUE C C Special code for 6 x 6 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 120 J = 1, N SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*TAU C( 2, J ) = C( 2, J ) - SUM*T1 C( 3, J ) = C( 3, J ) - SUM*T2 C( 4, J ) = C( 4, J ) - SUM*T3 C( 5, J ) = C( 5, J ) - SUM*T4 C( 6, J ) = C( 6, J ) - SUM*T5 120 CONTINUE GO TO 410 130 CONTINUE C C Special code for 7 x 7 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 140 J = 1, N SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + $ V6*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*TAU C( 2, J ) = C( 2, J ) - SUM*T1 C( 3, J ) = C( 3, J ) - SUM*T2 C( 4, J ) = C( 4, J ) - SUM*T3 C( 5, J ) = C( 5, J ) - SUM*T4 C( 6, J ) = C( 6, J ) - SUM*T5 C( 7, J ) = C( 7, J ) - SUM*T6 140 CONTINUE GO TO 410 150 CONTINUE C C Special code for 8 x 8 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 160 J = 1, N SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + $ V6*C( 7, J ) + V7*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*TAU C( 2, J ) = C( 2, J ) - SUM*T1 C( 3, J ) = C( 3, J ) - SUM*T2 C( 4, J ) = C( 4, J ) - SUM*T3 C( 5, J ) = C( 5, J ) - SUM*T4 C( 6, J ) = C( 6, J ) - SUM*T5 C( 7, J ) = C( 7, J ) - SUM*T6 C( 8, J ) = C( 8, J ) - SUM*T7 160 CONTINUE GO TO 410 170 CONTINUE C C Special code for 9 x 9 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 180 J = 1, N SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + $ V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*TAU C( 2, J ) = C( 2, J ) - SUM*T1 C( 3, J ) = C( 3, J ) - SUM*T2 C( 4, J ) = C( 4, J ) - SUM*T3 C( 5, J ) = C( 5, J ) - SUM*T4 C( 6, J ) = C( 6, J ) - SUM*T5 C( 7, J ) = C( 7, J ) - SUM*T6 C( 8, J ) = C( 8, J ) - SUM*T7 C( 9, J ) = C( 9, J ) - SUM*T8 180 CONTINUE GO TO 410 190 CONTINUE C C Special code for 10 x 10 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 200 J = 1, N SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + $ V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J ) + $ V9*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*TAU C( 2, J ) = C( 2, J ) - SUM*T1 C( 3, J ) = C( 3, J ) - SUM*T2 C( 4, J ) = C( 4, J ) - SUM*T3 C( 5, J ) = C( 5, J ) - SUM*T4 C( 6, J ) = C( 6, J ) - SUM*T5 C( 7, J ) = C( 7, J ) - SUM*T6 C( 8, J ) = C( 8, J ) - SUM*T7 C( 9, J ) = C( 9, J ) - SUM*T8 C( 10, J ) = C( 10, J ) - SUM*T9 200 CONTINUE GO TO 410 ELSE C C Form C * H, where H has order n. C GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 ) N C C Code for general N. C C w := C * u. C CALL DCOPY( M, C, 1, DWORK, 1 ) CALL DGEMV( 'No transpose', M, N-1, ONE, C( 1, 2 ), LDC, V, 1, $ ONE, DWORK, 1 ) C C C := C - tau * w * u'. C CALL DAXPY( M, -TAU, DWORK, 1, C, 1 ) CALL DGER( M, N-1, -TAU, DWORK, 1, V, 1, C( 1, 2 ), LDC ) GO TO 410 210 CONTINUE C C Special code for 1 x 1 Householder. C T1 = ONE - TAU DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE C C Special code for 2 x 2 Householder. C V1 = V( 1 ) T1 = TAU*V1 DO 240 J = 1, M SUM = C( J, 1 ) + V1*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*TAU C( J, 2 ) = C( J, 2 ) - SUM*T1 240 CONTINUE GO TO 410 250 CONTINUE C C Special code for 3 x 3 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 260 J = 1, M SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*TAU C( J, 2 ) = C( J, 2 ) - SUM*T1 C( J, 3 ) = C( J, 3 ) - SUM*T2 260 CONTINUE GO TO 410 270 CONTINUE C C Special code for 4 x 4 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 280 J = 1, M SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + $ V3*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*TAU C( J, 2 ) = C( J, 2 ) - SUM*T1 C( J, 3 ) = C( J, 3 ) - SUM*T2 C( J, 4 ) = C( J, 4 ) - SUM*T3 280 CONTINUE GO TO 410 290 CONTINUE C C Special code for 5 x 5 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 300 J = 1, M SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + $ V3*C( J, 4 ) + V4*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*TAU C( J, 2 ) = C( J, 2 ) - SUM*T1 C( J, 3 ) = C( J, 3 ) - SUM*T2 C( J, 4 ) = C( J, 4 ) - SUM*T3 C( J, 5 ) = C( J, 5 ) - SUM*T4 300 CONTINUE GO TO 410 310 CONTINUE C C Special code for 6 x 6 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 320 J = 1, M SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*TAU C( J, 2 ) = C( J, 2 ) - SUM*T1 C( J, 3 ) = C( J, 3 ) - SUM*T2 C( J, 4 ) = C( J, 4 ) - SUM*T3 C( J, 5 ) = C( J, 5 ) - SUM*T4 C( J, 6 ) = C( J, 6 ) - SUM*T5 320 CONTINUE GO TO 410 330 CONTINUE C C Special code for 7 x 7 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 340 J = 1, M SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + $ V6*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*TAU C( J, 2 ) = C( J, 2 ) - SUM*T1 C( J, 3 ) = C( J, 3 ) - SUM*T2 C( J, 4 ) = C( J, 4 ) - SUM*T3 C( J, 5 ) = C( J, 5 ) - SUM*T4 C( J, 6 ) = C( J, 6 ) - SUM*T5 C( J, 7 ) = C( J, 7 ) - SUM*T6 340 CONTINUE GO TO 410 350 CONTINUE C C Special code for 8 x 8 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 360 J = 1, M SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + $ V6*C( J, 7 ) + V7*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*TAU C( J, 2 ) = C( J, 2 ) - SUM*T1 C( J, 3 ) = C( J, 3 ) - SUM*T2 C( J, 4 ) = C( J, 4 ) - SUM*T3 C( J, 5 ) = C( J, 5 ) - SUM*T4 C( J, 6 ) = C( J, 6 ) - SUM*T5 C( J, 7 ) = C( J, 7 ) - SUM*T6 C( J, 8 ) = C( J, 8 ) - SUM*T7 360 CONTINUE GO TO 410 370 CONTINUE C C Special code for 9 x 9 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 380 J = 1, M SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + $ V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*TAU C( J, 2 ) = C( J, 2 ) - SUM*T1 C( J, 3 ) = C( J, 3 ) - SUM*T2 C( J, 4 ) = C( J, 4 ) - SUM*T3 C( J, 5 ) = C( J, 5 ) - SUM*T4 C( J, 6 ) = C( J, 6 ) - SUM*T5 C( J, 7 ) = C( J, 7 ) - SUM*T6 C( J, 8 ) = C( J, 8 ) - SUM*T7 C( J, 9 ) = C( J, 9 ) - SUM*T8 380 CONTINUE GO TO 410 390 CONTINUE C C Special code for 10 x 10 Householder. C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 400 J = 1, M SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + $ V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 ) + $ V9*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*TAU C( J, 2 ) = C( J, 2 ) - SUM*T1 C( J, 3 ) = C( J, 3 ) - SUM*T2 C( J, 4 ) = C( J, 4 ) - SUM*T3 C( J, 5 ) = C( J, 5 ) - SUM*T4 C( J, 6 ) = C( J, 6 ) - SUM*T5 C( J, 7 ) = C( J, 7 ) - SUM*T6 C( J, 8 ) = C( J, 8 ) - SUM*T7 C( J, 9 ) = C( J, 9 ) - SUM*T8 C( J, 10 ) = C( J, 10 ) - SUM*T9 400 CONTINUE GO TO 410 END IF 410 CONTINUE RETURN C C *** Last line of MB04PY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01KD.f0000644000000000000000000000013215012430707016153 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01KD.f0000644000175000017500000002457615012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE MB01KD( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, $ C, LDC, INFO ) C C PURPOSE C C To perform one of the skew-symmetric rank 2k operations C C C := alpha*A*B' - alpha*B*A' + beta*C, C C or C C C := alpha*A'*B - alpha*B'*A + beta*C, C C where alpha and beta are scalars, C is a real N-by-N skew- C symmetric matrix and A, B are N-by-K matrices in the first case C and K-by-N matrices in the second case. C C This is a modified version of the vanilla implemented BLAS C routine DSYR2K written by Jack Dongarra, Iain Duff, C Jeremy Du Croz and Sven Hammarling. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies whether the upper or lower triangular part of C the array C is to be referenced, as follows: C = 'U': only the strictly upper triangular part of C is to C be referenced; C = 'L': only the striclty lower triangular part of C is to C be referenced. C C TRANS CHARACTER*1 C Specifies the operation to be performed, as follows: C = 'N': C := alpha*A*B' - alpha*B*A' + beta*C; C = 'T' or 'C': C := alpha*A'*B - alpha*B'*A + beta*C. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix C. N >= 0. C C K (input) INTEGER C If TRANS = 'N' the number of columns of A and B; and if C TRANS = 'T' or TRANS = 'C' the number of rows of A and B. C K >= 0. C C ALPHA (input) DOUBLE PRECISION C The scalar alpha. If alpha is zero, or N <= 1, or K = 0, C A and B are not referenced. C C A (input) DOUBLE PRECISION array, dimension (LDA,KA), C where KA is K when TRANS = 'N', and is N otherwise. C On entry with TRANS = 'N', the leading N-by-K part of C of this array must contain the matrix A. C On entry with TRANS = 'T' or TRANS = 'C', the leading C K-by-N part of this array must contain the matrix A. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,N), if TRANS = 'N'; C LDA >= MAX(1,K), if TRANS = 'T' or TRANS = 'C'. C C B (input) DOUBLE PRECISION array, dimension (LDB,KB), C where KB is K when TRANS = 'N', and is N otherwise. C On entry with TRANS = 'N', the leading N-by-K part of C of this array must contain the matrix B. C On entry with TRANS = 'T' or TRANS = 'C', the leading C K-by-N part of this array must contain the matrix B. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N), if TRANS = 'N'; C LDB >= MAX(1,K), if TRANS = 'T' or TRANS = 'C'. C C BETA (input) DOUBLE PRECISION C The scalar beta. If beta is zero C need not be set before C entry. C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) C On entry with UPLO = 'U', the leading N-by-N part of this C array must contain the strictly upper triangular part of C the matrix C. The lower triangular part of this array is C not referenced. C On entry with UPLO = 'L', the leading N-by-N part of this C array must contain the strictly lower triangular part of C the matrix C. The upper triangular part of this array is C not referenced. C On exit with UPLO = 'U', the leading N-by-N part of this C array contains the strictly upper triangular part of the C updated matrix C. C On exit with UPLO = 'L', the leading N-by-N part of this C array contains the strictly lower triangular part of the C updated matrix C. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,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 NUMERICAL ASPECTS C C Though being almost identical with the vanilla implementation C of the BLAS routine DSYR2K the performance of this routine could C be significantly lower in the case of vendor supplied, highly C optimized BLAS. C C CONTRIBUTORS C C D. Kressner (Technical Univ. Berlin, Germany) and C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. C C REVISIONS C C V. Sima, Jan. 2010 (SLICOT version of the HAPACK routine DSKR2K). C C KEYWORDS C C Elementary matrix operations, C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER UPLO, TRANS INTEGER INFO, K, LDA, LDB, LDC, N DOUBLE PRECISION ALPHA, BETA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) C .. Local Scalars .. LOGICAL LUP, LTRAN INTEGER I, J, L DOUBLE PRECISION TEMP1, TEMP2 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 LUP = LSAME( UPLO, 'U' ) LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) C C Check the scalar input parameters. C IF ( .NOT.( LUP .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( LTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN INFO = -2 ELSE IF ( N.LT.0 ) THEN INFO = -3 ELSE IF ( K.LT.0 ) THEN INFO = -4 ELSE IF ( ( .NOT.LTRAN .AND. LDA.LT.N ) .OR. LDA.LT.1 .OR. $ ( LTRAN .AND. LDA.LT.K ) ) THEN INFO = -7 ELSE IF ( ( .NOT.LTRAN .AND. LDB.LT.N ) .OR. LDB.LT.1 .OR. $ ( LTRAN .AND. LDB.LT.K ) ) THEN INFO = -9 ELSE IF ( LDC.LT.MAX( 1, N ) ) THEN INFO = -12 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB01KD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( ( N.LE.1 ) .OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN C C Special case ALPHA = 0. C IF ( ALPHA.EQ.ZERO ) THEN IF ( LUP ) THEN IF ( BETA.EQ.ZERO ) THEN DO 20 J = 2, N DO 10 I = 1, J-1 C(I,J) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40 J = 2, N DO 30 I = 1, J-1 C(I,J) = BETA * C(I,J) 30 CONTINUE 40 CONTINUE END IF ELSE IF( BETA.EQ.ZERO ) THEN DO 60 J = 1, N-1 DO 50 I = J+1, N C(I,J) = ZERO 50 CONTINUE 60 CONTINUE ELSE DO 80 J = 1, N-1 DO 70 I = J+1, N C(I,J) = BETA * C(I,J) 70 CONTINUE 80 CONTINUE END IF END IF RETURN END IF C C Normal case. C IF ( .NOT.LTRAN ) THEN C C Update C := alpha*A*B' - alpha*B*A' + beta*C. C IF ( LUP ) THEN DO 130 J = 2, N IF ( BETA.EQ.ZERO ) THEN DO 90 I = 1, J-1 C(I,J) = ZERO 90 CONTINUE ELSE IF ( BETA.NE.ONE ) THEN DO 100 I = 1, J-1 C(I,J) = BETA * C(I,J) 100 CONTINUE END IF DO 120 L = 1, K IF ( ( A(J,L).NE.ZERO ) .OR. $ ( B(J,L).NE.ZERO ) ) THEN TEMP1 = ALPHA * B(J,L) TEMP2 = ALPHA * A(J,L) DO 110 I = 1, J-1 C(I,J) = C(I,J) + A(I,L)*TEMP1 - B(I,L)*TEMP2 110 CONTINUE END IF 120 CONTINUE 130 CONTINUE ELSE DO 180 J = 1, N-1 IF ( BETA.EQ.ZERO ) THEN DO 140 I = J+1, N C(I,J) = ZERO 140 CONTINUE ELSE IF ( BETA.NE.ONE ) THEN DO 150 I = J+1, N C(I,J) = BETA * C(I,J) 150 CONTINUE END IF DO 170 L = 1, K IF ( ( A(J,L).NE.ZERO ) .OR. $ ( B(J,L).NE.ZERO ) ) THEN TEMP1 = ALPHA * B(J,L) TEMP2 = ALPHA * A(J,L) DO 160 I = J+1, N C(I,J) = C(I,J) + A(I,L)*TEMP1 - B(I,L)*TEMP2 160 CONTINUE END IF 170 CONTINUE 180 CONTINUE END IF ELSE C C Update C := alpha*A'*B - alpha*B'*A + beta*C. C IF ( LUP ) THEN DO 210 J = 2, N DO 200 I = 1, J-1 TEMP1 = ZERO TEMP2 = ZERO DO 190 L = 1, K TEMP1 = TEMP1 + A(L,I)*B(L,J) TEMP2 = TEMP2 + B(L,I)*A(L,J) 190 CONTINUE IF ( BETA.EQ.ZERO ) THEN C(I,J) = ALPHA*TEMP1 - ALPHA*TEMP2 ELSE C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 - ALPHA*TEMP2 END IF 200 CONTINUE 210 CONTINUE ELSE DO 240 J = 1, N-1 DO 230 I = J+1, N TEMP1 = ZERO TEMP2 = ZERO DO 220, L = 1, K TEMP1 = TEMP1 + A(L,I)*B(L,J) TEMP2 = TEMP2 + B(L,I)*A(L,J) 220 CONTINUE IF ( BETA.EQ.ZERO ) THEN C(I,J) = ALPHA*TEMP1 - ALPHA*TEMP2 ELSE C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 - ALPHA*TEMP2 END IF 230 CONTINUE 240 CONTINUE END IF END IF RETURN C *** Last line of MB01KD *** END control-4.1.2/src/slicot/src/PaxHeaders/BB01AD.f0000644000000000000000000000013215012430707016126 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/BB01AD.f0000644000175000017500000014106215012430707017326 0ustar00lilgelilge00000000000000 SUBROUTINE BB01AD(DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, 1 A, LDA, B, LDB, C, LDC, G, LDG, Q, LDQ, X, LDX, 2 DWORK, LDWORK, INFO) C C PURPOSE C C To generate the benchmark examples for the numerical solution of C continuous-time algebraic Riccati equations (CAREs) of the form C C 0 = Q + A'X + XA - XGX C C corresponding to the Hamiltonian matrix C C ( A G ) C H = ( T ). C ( Q -A ) C C A,G,Q,X are real N-by-N matrices, Q and G are symmetric and may C be given in factored form C C -1 T T C (I) G = B R B , (II) Q = C W C . C C Here, C is P-by-N, W P-by-P, B N-by-M, and R M-by-M, where W C and R are symmetric. In linear-quadratic optimal control problems, C usually W is positive semidefinite and R positive definite. The C factorized form can be used if the CARE is solved using the C deflating subspaces of the extended Hamiltonian pencil C C ( A 0 B ) ( I 0 0 ) C ( T ) ( ) C H - s K = ( Q A 0 ) - s ( 0 -I 0 ) , C ( T ) ( ) C ( 0 B R ) ( 0 0 0 ) C C where I and 0 denote the identity and zero matrix, respectively, C of appropriate dimensions. C C NOTE: the formulation of the CARE and the related matrix (pencils) C used here does not include CAREs as they arise in robust C control (H_infinity optimization). C C ARGUMENTS C C Mode Parameters C C DEF CHARACTER C This parameter specifies if the default parameters are C to be used or not. C = 'N' or 'n' : The parameters given in the input vectors C xPAR (x = 'D', 'I', 'B', 'CH') are used. C = 'D' or 'd' : The default parameters for the example C are used. C This parameter is not meaningful if NR(1) = 1. C C Input/Output Parameters C C NR (input) INTEGER array, dimension (2) C This array determines the example for which CAREX returns C data. NR(1) is the group of examples. C NR(1) = 1 : parameter-free problems of fixed size. C NR(1) = 2 : parameter-dependent problems of fixed size. C NR(1) = 3 : parameter-free problems of scalable size. C NR(1) = 4 : parameter-dependent problems of scalable size. C NR(2) is the number of the example in group NR(1). C Let NEXi be the number of examples in group i. Currently, C NEX1 = 6, NEX2 = 9, NEX3 = 2, NEX4 = 4. C 1 <= NR(1) <= 4; C 1 <= NR(2) <= NEXi , where i = NR(1). C C DPAR (input/output) DOUBLE PRECISION array, dimension (7) C Double precision parameter vector. For explanation of the C parameters see [1]. C DPAR(1) : defines the parameters C 'delta' for NR(1) = 3, C 'q' for NR(1).NR(2) = 4.1, C 'a' for NR(1).NR(2) = 4.2, and C 'mu' for NR(1).NR(2) = 4.3. C DPAR(2) : defines parameters C 'r' for NR(1).NR(2) = 4.1, C 'b' for NR(1).NR(2) = 4.2, and C 'delta' for NR(1).NR(2) = 4.3. C DPAR(3) : defines parameters C 'c' for NR(1).NR(2) = 4.2 and C 'kappa' for NR(1).NR(2) = 4.3. C DPAR(j), j=4,5,6,7: These arguments are only used to C generate Example 4.2 and define in C consecutive order the intervals C ['beta_1', 'beta_2'], C ['gamma_1', 'gamma_2']. C NOTE that if DEF = 'D' or 'd', the values of DPAR entries C on input are ignored and, on output, they are overwritten C with the default parameters. C C IPAR (input/output) INTEGER array, dimension (4) C On input, IPAR(1) determines the actual state dimension, C i.e., the order of the matrix A as follows, where C NO = NR(1).NR(2). C NR(1) = 1 or 2.1-2.8: IPAR(1) is ignored. C NO = 2.9 : IPAR(1) = 1 generates the CARE for C optimal state feedback (default); C IPAR(1) = 2 generates the Kalman C filter CARE. C NO = 3.1 : IPAR(1) is the number of vehicles C (parameter 'l' in the description C in [1]). C NO = 3.2, 4.1 or 4.2: IPAR(1) is the order of the matrix C A. C NO = 4.3 or 4.4 : IPAR(1) determines the dimension of C the second-order system, i.e., the C order of the stiffness matrix for C Examples 4.3 and 4.4 (parameter 'l' C in the description in [1]). C C The order of the output matrix A is N = 2*IPAR(1) for C Example 4.3 and N = 2*IPAR(1)-1 for Examples 3.1 and 4.4. C NOTE that IPAR(1) is overwritten for Examples 1.1-2.8. For C the other examples, IPAR(1) is overwritten if the default C parameters are to be used. C On output, IPAR(1) contains the order of the matrix A. C C On input, IPAR(2) is the number of colums in the matrix B C in (I) (in control problems, the number of inputs of the C system). Currently, IPAR(2) is fixed or determined by C IPAR(1) for all examples and thus is not referenced on C input. C On output, IPAR(2) is the number of columns of the C matrix B from (I). C NOTE that currently IPAR(2) is overwritten and that C rank(G) <= IPAR(2). C C On input, IPAR(3) is the number of rows in the matrix C C in (II) (in control problems, the number of outputs of the C system). Currently, IPAR(3) is fixed or determined by C IPAR(1) for all examples and thus is not referenced on C input. C On output, IPAR(3) contains the number of rows of the C matrix C in (II). C NOTE that currently IPAR(3) is overwritten and that C rank(Q) <= IPAR(3). C C On input, if NR(1) = NR(2) = 4, and other data file than C that used by default is desired, then IPAR(4) is the C length of the character string in CHPAR specifying the C file name. C C BPAR (input) BOOLEAN array, dimension (6) C This array defines the form of the output of the examples C and the storage mode of the matrices G and Q. C BPAR(1) = .TRUE. : G is returned. C BPAR(1) = .FALSE. : G is returned in factored form, i.e., C B and R from (I) are returned. C BPAR(2) = .TRUE. : The matrix returned in array G (i.e., C G if BPAR(1) = .TRUE. and R if C BPAR(1) = .FALSE.) is stored as full C matrix. C BPAR(2) = .FALSE. : The matrix returned in array G is C provided in packed storage mode. C BPAR(3) = .TRUE. : If BPAR(2) = .FALSE., the matrix C returned in array G is stored in upper C packed mode, i.e., the upper triangle C of a symmetric n-by-n matrix is stored C by columns, e.g., the matrix entry C G(i,j) is stored in the array entry C G(i+j*(j-1)/2) for i <= j. C Otherwise, this entry is ignored. C BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix C returned in array G is stored in lower C packed mode, i.e., the lower triangle C of a symmetric n-by-n matrix is stored C by columns, e.g., the matrix entry C G(i,j) is stored in the array entry C G(i+(2*n-j)*(j-1)/2) for j <= i. C Otherwise, this entry is ignored. C BPAR(4) = .TRUE. : Q is returned. C BPAR(4) = .FALSE. : Q is returned in factored form, i.e., C C and W from (II) are returned. C BPAR(5) = .TRUE. : The matrix returned in array Q (i.e., C Q if BPAR(4) = .TRUE. and W if C BPAR(4) = .FALSE.) is stored as full C matrix. C BPAR(5) = .FALSE. : The matrix returned in array Q is C provided in packed storage mode. C BPAR(6) = .TRUE. : If BPAR(5) = .FALSE., the matrix C returned in array Q is stored in upper C packed mode (see above). C Otherwise, this entry is ignored. C BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix C returned in array Q is stored in lower C packed mode (see above). C Otherwise, this entry is ignored. C NOTE that there are no default values for BPAR. If all C entries are declared to be .TRUE., then matrices G and Q C are returned in conventional storage mode, i.e., as C N-by-N arrays where the array element Z(I,J) contains the C matrix entry Z_{i,j}. C C CHPAR (input/output) CHARACTER*255 C On input, this is the name of a data file supplied by the C user. C In the current version, only Example 4.4 allows a C user-defined data file. This file must contain C consecutively DOUBLE PRECISION vectors mu, delta, gamma, C and kappa. The length of these vectors is determined by C the input value for IPAR(1). C If on entry, IPAR(1) = L, then mu and delta must each C contain L DOUBLE PRECISION values, and gamma and kappa C must each contain L-1 DOUBLE PRECISION values. C On output, this string contains short information about C the chosen example. C C VEC (output) LOGICAL array, dimension (9) C Flag vector which displays the availability of the output C data: C VEC(j), j=1,2,3, refer to N, M, and P, respectively, and C are always .TRUE. C VEC(4) refers to A and is always .TRUE. C VEC(5) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors B C and R from (I) are returned. C VEC(6) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors C C and W from (II) are returned. C VEC(7) refers to G and is always .TRUE. C VEC(8) refers to Q and is always .TRUE. C VEC(9) refers to X and is .TRUE. if the exact solution C matrix is available. C NOTE that VEC(i) = .FALSE. for i = 1 to 9 if on exit C INFO .NE. 0. C C N (output) INTEGER C The order of the matrices A, X, G if BPAR(1) = .TRUE., and C Q if BPAR(4) = .TRUE. C C M (output) INTEGER C The number of columns in the matrix B (or the dimension of C the control input space of the underlying dynamical C system). C C P (output) INTEGER C The number of rows in the matrix C (or the dimension of C the output space of the underlying dynamical system). C C A (output) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array contains the C coefficient matrix A of the CARE. C C LDA INTEGER C The leading dimension of array A. LDA >= N. C C B (output) DOUBLE PRECISION array, dimension (LDB,M) C If (BPAR(1) = .FALSE.), then the leading N-by-M part of C this array contains the matrix B of the factored form (I) C of G. Otherwise, B is used as workspace. C C LDB INTEGER C The leading dimension of array B. LDB >= N. C C C (output) DOUBLE PRECISION array, dimension (LDC,N) C If (BPAR(4) = .FALSE.), then the leading P-by-N part of C this array contains the matrix C of the factored form (II) C of Q. Otherwise, C is used as workspace. C C LDC INTEGER C The leading dimension of array C. C LDC >= P, where P is the number of rows of the matrix C, C i.e., the output value of IPAR(3). (For all examples, C P <= N, where N equals the output value of the argument C IPAR(1), i.e., LDC >= LDA is always safe.) C C G (output) DOUBLE PRECISION array, dimension (NG) C If (BPAR(2) = .TRUE.) then NG = LDG*N. C If (BPAR(2) = .FALSE.) then NG = N*(N+1)/2. C If (BPAR(1) = .TRUE.), then array G contains the C coefficient matrix G of the CARE. C If (BPAR(1) = .FALSE.), then array G contains the 'control C weighting matrix' R of G's factored form as in (I). (For C all examples, M <= N.) The symmetric matrix contained in C array G is stored according to BPAR(2) and BPAR(3). C C LDG INTEGER C If conventional storage mode is used for G, i.e., C BPAR(2) = .TRUE., then G is stored like a 2-dimensional C array with leading dimension LDG. If packed symmetric C storage mode is used, then LDG is not referenced. C LDG >= N if BPAR(2) = .TRUE.. C C Q (output) DOUBLE PRECISION array, dimension (NQ) C If (BPAR(5) = .TRUE.) then NQ = LDQ*N. C If (BPAR(5) = .FALSE.) then NQ = N*(N+1)/2. C If (BPAR(4) = .TRUE.), then array Q contains the C coefficient matrix Q of the CARE. C If (BPAR(4) = .FALSE.), then array Q contains the 'output C weighting matrix' W of Q's factored form as in (II). C The symmetric matrix contained in array Q is stored C according to BPAR(5) and BPAR(6). C C LDQ INTEGER C If conventional storage mode is used for Q, i.e., C BPAR(5) = .TRUE., then Q is stored like a 2-dimensional C array with leading dimension LDQ. If packed symmetric C storage mode is used, then LDQ is not referenced. C LDQ >= N if BPAR(5) = .TRUE.. C C X (output) DOUBLE PRECISION array, dimension (LDX,IPAR(1)) C If an exact solution is available (NR = 1.1, 1.2, 2.1, C 2.3-2.6, 3.2), then the leading N-by-N part of this array C contains the solution matrix X in conventional storage C mode. Otherwise, X is not referenced. C C LDX INTEGER C The leading dimension of array X. LDX >= 1, and C LDX >= N if NR = 1.1, 1.2, 2.1, 2.3-2.6, 3.2. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= N*MAX(4,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 : data file could not be opened or had wrong format; C = 2 : division by zero; C = 3 : G can not be computed as in (I) due to a singular R C matrix. C C REFERENCES C C [1] Abels, J. and Benner, P. C CAREX - A Collection of Benchmark Examples for Continuous-Time C Algebraic Riccati Equations (Version 2.0). C SLICOT Working Note 1999-14, November 1999. Available from C http://www.win.tue.nl/niconet/NIC2/reports.html. C C This is an updated and extended version of C C [2] Benner, P., Laub, A.J., and Mehrmann, V. C A Collection of Benchmark Examples for the Numerical Solution C of Algebraic Riccati Equations I: Continuous-Time Case. C Technical Report SPC 95_22, Fak. f. Mathematik, C TU Chemnitz-Zwickau (Germany), October 1995. C C NUMERICAL ASPECTS C C If the original data as taken from the literature is given via C matrices G and Q, but factored forms are requested as output, then C these factors are obtained from Cholesky or LDL' decompositions of C G and Q, i.e., the output data will be corrupted by roundoff C errors. C C FURTHER COMMENTS C C Some benchmark examples read data from the data files provided C with the collection. C C CONTRIBUTOR C C Peter Benner (Universitaet Bremen), November 15, 1999. C C For questions concerning the collection or for the submission of C test examples, please send e-mail to benner@math.uni-bremen.de. C C REVISIONS C C V. Sima, 1999, December 23, May 2016. C C KEYWORDS C C Algebraic Riccati equation, Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. C . # of examples available , # of examples with fixed size. . INTEGER NEX1, NEX2, NEX3, NEX4, NMAX PARAMETER ( NMAX = 9, NEX1 = 6, NEX2 = 9, NEX3 = 2, 1 NEX4 = 4 ) DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 1 THREE = 3.0D0, FOUR = 4.0D0, 2 PI = .3141592653589793D1 ) C C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDG, LDQ, LDWORK, LDX, M, N, $ P CHARACTER DEF C C .. Array Arguments .. INTEGER IPAR(4), NR(2) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*), 1 G(*), Q(*), X(LDX,*) CHARACTER CHPAR*(*) LOGICAL BPAR(6), VEC(9) C C .. Local Scalars .. INTEGER GDIMM, I, IOS, ISYMM, J, K, L, MSYMM, NSYMM, POS, 1 PSYMM, QDIMM DOUBLE PRECISION APPIND, B1, B2, C1, C2, SUM, TEMP, TTEMP C C ..Local Arrays .. INTEGER MDEF(2,NMAX), NDEF(4,NMAX), NEX(4), PDEF(2,NMAX) DOUBLE PRECISION PARDEF(4,NMAX) CHARACTER IDENT*4 CHARACTER*255 NOTES(4,NMAX) C C .. External Functions .. C . BLAS . DOUBLE PRECISION DDOT EXTERNAL DDOT C . LAPACK . LOGICAL LSAME DOUBLE PRECISION DLAPY2 EXTERNAL LSAME, DLAPY2 C C .. External Subroutines .. C . BLAS . EXTERNAL DCOPY, DGEMV, DSCAL, DSPMV, DSPR, DSYMM, DSYRK C . LAPACK . EXTERNAL DLASET, DPPTRF, DPPTRI, DPTTRF, DPTTRS, XERBLA C . SLICOT . EXTERNAL MA02DD, MA02ED C C .. Intrinsic Functions .. INTRINSIC COS, DBLE, MAX, MIN, MOD, SQRT C C .. Data Statements .. C . default values for dimensions . DATA (NEX(I), I = 1, 4) /NEX1, NEX2, NEX3, NEX4/ DATA (NDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 30/ DATA (NDEF(2,I), I = 1, NEX2) /2, 2, 2, 2, 2, 3, 4, 4, 55/ DATA (NDEF(3,I), I = 1, NEX3) /20, 64/ DATA (NDEF(4,I), I = 1, NEX4) /21, 100, 30, 211/ DATA (MDEF(1,I), I = 1, NEX1) /1, 1, 2, 2, 3, 3/ DATA (MDEF(2,I), I = 1, NEX2) /1, 2, 1, 2, 1, 3, 1, 1, 2/ DATA (PDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 5/ DATA (PDEF(2,I), I = 1, NEX2) /1, 1, 2, 2, 2, 3, 2, 1, 10/ C . default values for parameters . DATA (PARDEF(1,I), I = 1, NEX1) /ZERO, ZERO, ZERO, ZERO, ZERO, 1 ZERO/ DATA (PARDEF(2,I), I = 1, NEX2) /.1D-5, .1D-7, .1D7, .1D-6, ZERO, 1 .1D7, .1D-5, .1D-5, .1D1/ DATA (PARDEF(3,I), I = 1, NEX3) /ZERO, ZERO/ DATA (PARDEF(4,I), I = 1, NEX4) /ONE, .1D-1, FOUR, ZERO/ C . comments on examples . DATA (NOTES(1,I), I = 1, NEX1) / 1'Laub 1979, Ex.1', 'Laub 1979, Ex.2: uncontrollable-unobservable d 2ata', 'Beale/Shafai 1989: model of L-1011 aircraft', 'Bhattacharyy 3a et al. 1983: binary distillation column', 'Patnaik et al. 1980: 4tubular ammonia reactor', 'Davison/Gesing 1978: J-100 jet engine'/ DATA (NOTES(2,I), I = 1, NEX2) / 1'Arnold/Laub 1984, Ex.1: (A,B) unstabilizable as EPS -> 0', 'Arnol 2d/Laub 1984, Ex.3: control weighting matrix singular as EPS -> 0', 3'Kenney/Laub/Wette 1989, Ex.2: ARE ill conditioned for EPS -> oo', 4'Bai/Qian 1994: ill-conditioned Hamiltonian for EPS -> 0', 'Laub 1 5992: H-infinity problem, eigenvalues +/- EPS +/- i', 'Petkov et a 6l. 1987: increasingly badly scaled Hamiltonian as EPS -> oo', 'Cho 7w/Kokotovic 1976: magnetic tape control system', 'Arnold/Laub 1984 8, Ex.2: poor sep. of closed-loop spectrum as EPS -> 0', 'IFAC Benc 9hmark Problem #90-06: LQG design for modified Boing B-767 at flutt 1er condition'/ DATA (NOTES(3,I), I = 1, NEX3) / 1'Laub 1979, Ex.4: string of high speed vehicles', 'Laub 1979, Ex.5 2: circulant matrices'/ DATA (NOTES(4,I), I = 1, NEX4) / 1'Laub 1979, Ex.6: ill-conditioned Riccati equation', 'Rosen/Wang 1 2992: lq control of 1-dimensional heat flow','Hench et al. 1995: co 3upled springs, dashpots and masses','Lang/Penzl 1994: rotating axl 4e' / C C .. Executable Statements .. C INFO = 0 DO 5 I = 1, 9 VEC(I) = .FALSE. 5 CONTINUE C IF ((NR(1) .NE. 1) .AND. (.NOT. (LSAME(DEF,'N') 1 .OR. LSAME(DEF,'D')))) THEN INFO = -1 ELSE IF ((NR(1) .LT. 1) .OR. (NR(2) .LT. 1) .OR. 1 (NR(1) .GT. 4) .OR. (NR(2) .GT. NEX(NR(1)))) THEN INFO = -2 ELSE IF (NR(1) .GT. 2) THEN IF (.NOT. LSAME(DEF,'N')) IPAR(1) = NDEF(NR(1),NR(2)) IF (NR(1) .EQ. 3) THEN IF (NR(2) .EQ. 1) THEN IPAR(2) = IPAR(1) IPAR(3) = IPAR(1) - 1 IPAR(1) = 2*IPAR(1) - 1 ELSE IF (NR(2) .EQ. 2) THEN IPAR(2) = IPAR(1) IPAR(3) = IPAR(1) ELSE IPAR(2) = 1 IPAR(3) = 1 END IF ELSE IF (NR(1) .EQ. 4) THEN IF (NR(2) .EQ. 3) THEN L = IPAR(1) IPAR(2) = 2 IPAR(3) = 2*L IPAR(1) = 2*L ELSE IF (NR(2) .EQ. 4) THEN L = IPAR(1) IPAR(2) = L IPAR(3) = L IPAR(1) = 2*L-1 ELSE IPAR(2) = 1 IPAR(3) = 1 END IF END IF ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 9) .AND. 1 (IPAR(1) . EQ. 2)) THEN IPAR(1) = NDEF(NR(1),NR(2)) IPAR(2) = MDEF(NR(1),NR(2)) IPAR(3) = 3 ELSE IPAR(1) = NDEF(NR(1),NR(2)) IPAR(2) = MDEF(NR(1),NR(2)) IPAR(3) = PDEF(NR(1),NR(2)) END IF IF (INFO .NE. 0) GOTO 7 C IF (IPAR(1) .LT. 1) THEN INFO = -4 ELSE IF (IPAR(1) .GT. LDA) THEN INFO = -12 ELSE IF (IPAR(1) .GT. LDB) THEN INFO = -14 ELSE IF (IPAR(3) .GT. LDC) THEN INFO = -16 ELSE IF (BPAR(2) .AND. (IPAR(1).GT. LDG)) THEN INFO = -18 ELSE IF (BPAR(5) .AND. (IPAR(1).GT. LDQ)) THEN INFO = -20 ELSE IF (LDX.LT.1) THEN INFO = -22 ELSE IF ((NR(1) .EQ. 1) .AND. $ ((NR(2) .EQ. 1) .OR. (NR(2) .EQ.2))) THEN IF (IPAR(1) .GT. LDX) INFO = -22 ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 1)) THEN IF (IPAR(1) .GT. LDX) INFO = -22 ELSE IF ((NR(1) .EQ. 2) .AND. ((NR(2) .GE. 3) .AND. 1 (NR(2) .LE. 6))) THEN IF (IPAR(1) .GT. LDX) INFO = -22 ELSE IF ((NR(1) .EQ. 3) .AND. (NR(2) .EQ. 2)) THEN IF (IPAR(1) .GT. LDX) INFO = -22 ELSE IF (LDWORK .LT. N*(MAX(4,N))) THEN INFO = -24 END IF C 7 CONTINUE IF (INFO .NE. 0) THEN CALL XERBLA( 'BB01AD', -INFO ) RETURN END IF C NSYMM = (IPAR(1)*(IPAR(1)+1))/2 MSYMM = (IPAR(2)*(IPAR(2)+1))/2 PSYMM = (IPAR(3)*(IPAR(3)+1))/2 IF (.NOT. LSAME(DEF,'N')) DPAR(1) = PARDEF(NR(1),NR(2)) C CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, A, LDA) CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, B, LDB) CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ZERO, C, LDC) CALL DLASET('L', MSYMM, 1, ZERO, ZERO, G, 1) CALL DLASET('L', PSYMM, 1, ZERO, ZERO, Q, 1) C IF (NR(1) .EQ. 1) THEN IF (NR(2) .EQ. 1) THEN A(1,2) = ONE B(2,1) = ONE Q(1) = ONE Q(3) = TWO IDENT = '0101' CALL DLASET('A', IPAR(1), IPAR(1), ONE, TWO, X, LDX) C ELSE IF (NR(2) .EQ. 2) THEN A(1,1) = FOUR A(2,1) = -.45D1 A(1,2) = THREE A(2,2) = -.35D1 CALL DLASET('A', IPAR(1), IPAR(2), -ONE, ONE, B, LDB) Q(1) = 9.0D0 Q(2) = 6.0D0 Q(3) = FOUR IDENT = '0101' TEMP = ONE + SQRT(TWO) CALL DLASET('A', IPAR(1), IPAR(1), 6.0D0*TEMP, FOUR*TEMP, X, 1 LDX) X(1,1) = 9.0D0*TEMP C ELSE IF ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6)) THEN WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', 1 NR(2) , '.dat' IF ((NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4)) THEN IDENT = '0101' ELSE IF (NR(2) .EQ. 5) THEN IDENT = '0111' ELSE IF (NR(2) .EQ. 6) THEN IDENT = '0011' END IF OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) IF (IOS .NE. 0) THEN INFO = 1 ELSE DO 10 I = 1, IPAR(1) READ (1, FMT = *, IOSTAT = IOS) 1 (A(I,J), J = 1, IPAR(1)) IF (IOS .NE. 0) INFO = 1 10 CONTINUE DO 20 I = 1, IPAR(1) READ (1, FMT = *, IOSTAT = IOS) 1 (B(I,J), J = 1, IPAR(2)) IF (IOS .NE. 0) INFO = 1 20 CONTINUE IF (NR(2) .LE. 4) THEN DO 30 I = 1, IPAR(1) POS = (I-1)*IPAR(1) READ (1, FMT = *, IOSTAT = IOS) (DWORK(POS+J), 1 J = 1,IPAR(1)) 30 CONTINUE IF (IOS .NE. 0) THEN INFO = 1 ELSE CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) END IF ELSE IF (NR(2) .EQ. 6) THEN DO 35 I = 1, IPAR(3) READ (1, FMT = *, IOSTAT = IOS) 1 (C(I,J), J = 1, IPAR(1)) IF (IOS .NE. 0) INFO = 1 35 CONTINUE END IF CLOSE(1) END IF END IF C ELSE IF (NR(1) .EQ. 2) THEN IF (NR(2) .EQ. 1) THEN A(1,1) = ONE A(2,2) = -TWO B(1,1) = DPAR(1) CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) IDENT = '0011' IF (DPAR(1) .NE. ZERO) THEN TEMP = DLAPY2(ONE, DPAR(1)) X(1,1) = (ONE + TEMP)/DPAR(1)/DPAR(1) X(2,1) = ONE/(TWO + TEMP) X(1,2) = X(2,1) TTEMP = DPAR(1)*X(1,2) TEMP = (ONE - TTEMP) * (ONE + TTEMP) X(2,2) = TEMP / FOUR ELSE INFO = 2 END IF C ELSE IF (NR(2) .EQ. 2) THEN A(1,1) = -.1D0 A(2,2) = -.2D-1 B(1,1) = .1D0 B(2,1) = .1D-2 B(2,2) = .1D-1 CALL DLASET('L', MSYMM, 1, ONE, ONE, G, MSYMM) G(1) = G(1) + DPAR(1) C(1,1) = .1D2 C(1,2) = .1D3 IDENT = '0010' C ELSE IF (NR(2) .EQ. 3) THEN A(1,2) = DPAR(1) B(2,1) = ONE IDENT = '0111' IF (DPAR(1) .NE. ZERO) THEN TEMP = SQRT(ONE + TWO*DPAR(1)) CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, X, LDX) X(1,1) = X(1,1)/DPAR(1) ELSE INFO = 2 END IF C ELSE IF (NR(2) .EQ. 4) THEN TEMP = DPAR(1) + ONE CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, A, LDA) Q(1) = DPAR(1)**2 Q(3) = Q(1) IDENT = '1101' X(1,1) = TWO*TEMP + SQRT(TWO)*(SQRT(TEMP**2 + ONE) + DPAR(1)) X(1,1) = X(1,1)/TWO X(2,2) = X(1,1) TTEMP = X(1,1) - TEMP IF (TTEMP .NE. ZERO) THEN X(2,1) = X(1,1) / TTEMP X(1,2) = X(2,1) ELSE INFO = 2 END IF C ELSE IF (NR(2) .EQ. 5) THEN A(1,1) = THREE - DPAR(1) A(2,1) = FOUR A(1,2) = ONE A(2,2) = TWO - DPAR(1) CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB) Q(1) = FOUR*DPAR(1) - 11.0D0 Q(2) = TWO*DPAR(1) - 5.0D0 Q(3) = TWO*DPAR(1) - TWO IDENT = '0101' CALL DLASET('A', IPAR(1), IPAR(1), ONE, ONE, X, LDX) X(1,1) = TWO C ELSE IF (NR(2) .EQ. 6) THEN IF (DPAR(1) .NE. ZERO) THEN A(1,1) = DPAR(1) A(2,2) = DPAR(1)*TWO A(3,3) = DPAR(1)*THREE C .. set C = V .. TEMP = TWO/THREE CALL DLASET('A', IPAR(3), IPAR(1), -TEMP, ONE - TEMP, 1 C, LDC) CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, A, LDA, 1 ZERO, DWORK, IPAR(1)) CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, 1 IPAR(1), ZERO, A, LDA) C .. G = R ! .. G(1) = DPAR(1) G(4) = DPAR(1) G(6) = DPAR(1) Q(1) = ONE/DPAR(1) Q(4) = ONE Q(6) = DPAR(1) IDENT = '1000' CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, X, LDX) TEMP = DPAR(1)**2 X(1,1) = TEMP + SQRT(TEMP**2 + ONE) X(2,2) = TEMP*TWO + SQRT(FOUR*TEMP**2 + DPAR(1)) X(3,3) = TEMP*THREE + DPAR(1)*SQRT(9.0D0*TEMP + ONE) CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, X, LDX, 1 ZERO, DWORK, IPAR(1)) CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, 1 IPAR(1), ZERO, X, LDX) ELSE INFO = 2 END IF C ELSE IF (NR(2) .EQ. 7) THEN IF (DPAR(1) .NE. ZERO) THEN A(1,2) = .400D0 A(2,3) = .345D0 A(3,2) = -.524D0/DPAR(1) A(3,3) = -.465D0/DPAR(1) A(3,4) = .262D0/DPAR(1) A(4,4) = -ONE/DPAR(1) B(4,1) = ONE/DPAR(1) C(1,1) = ONE C(2,3) = ONE IDENT = '0011' ELSE INFO = 2 END IF C ELSE IF (NR(2) .EQ. 8) THEN A(1,1) = -DPAR(1) A(2,1) = -ONE A(1,2) = ONE A(2,2) = -DPAR(1) A(3,3) = DPAR(1) A(4,3) = -ONE A(3,4) = ONE A(4,4) = DPAR(1) CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB) CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) IDENT = '0011' C ELSE IF (NR(2) .EQ. 9) THEN IF (IPAR(3) .EQ. 10) THEN C .. read LQR CARE ... WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', 1 NR(2), '1.dat' OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12)) IF (IOS .NE. 0) THEN INFO = 1 ELSE DO 36 I = 1, 27, 2 READ (1, FMT = *, IOSTAT = IOS) 1 ((A(I+J,I+K), K = 0, 1), J = 0, 1) IF (IOS .NE. 0) INFO = 1 36 CONTINUE DO 37 I = 30, 44, 2 READ (1, FMT = *, IOSTAT = IOS) 1 ((A(I+J,I+K), K = 0, 1), J = 0, 1) IF (IOS .NE. 0) INFO = 1 37 CONTINUE DO 38 I = 1, IPAR(1) READ (1, FMT = *, IOSTAT = IOS) 1 (A(I,J), J = 46, IPAR(1)) IF (IOS .NE. 0) INFO = 1 38 CONTINUE A(29,29) = -.5301D1 B(48,1) = .8D06 B(51,2) = .8D06 G(1) = .3647D03 G(3) = .1459D02 DO 39 I = 1,6 READ (1, FMT = *, IOSTAT = IOS) 1 (C(I,J), J = 1,45) IF (IOS .NE. 0) INFO = 1 39 CONTINUE C(7,47) = ONE C(8,46) = ONE C(9,50) = ONE C(10,49) = ONE Q(11) = .376D-13 Q(20) = .120D-12 Q(41) = .245D-11 END IF ELSE C .. read Kalman filter CARE .. WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', 1 NR(2), '2.dat' OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12)) IF (IOS .NE. 0) THEN INFO = 1 ELSE DO 40 I = 1, 27, 2 READ (1, FMT = *, IOSTAT = IOS) 1 ((A(I+K,I+J), K = 0, 1), J = 0, 1) IF (IOS .NE. 0) INFO = 1 40 CONTINUE DO 41 I = 30, 44, 2 READ (1, FMT = *, IOSTAT = IOS) 1 ((A(I+K,I+J), K = 0, 1), J = 0, 1) IF (IOS .NE. 0) INFO = 1 41 CONTINUE DO 42 I = 1, IPAR(1) READ (1, FMT = *, IOSTAT = IOS) 1 (A(J,I), J = 46, IPAR(1)) IF (IOS .NE. 0) INFO = 1 42 CONTINUE A(29,29) = -.5301D1 DO 43 J = 1, IPAR(2) READ (1, FMT = *, IOSTAT = IOS) 1 (B(I,J), I = 1, IPAR(1)) IF (IOS .NE. 0) INFO = 1 43 CONTINUE G(1) = .685D-5 G(3) = .373D3 C(1,52) = .3713 C(1,53) = .1245D1 C(2,48) = .8D6 C(2,54) = ONE C(3,51) = .8D6 C(3,55) = ONE Q(1) = .28224D5 Q(4) = .2742D-4 Q(6) = .6854D-3 END IF END IF CLOSE(1) IDENT = '0000' END IF C ELSE IF (NR(1) .EQ. 3) THEN IF (NR(2) .EQ. 1) THEN DO 45 I = 1, IPAR(1) IF (MOD(I,2) .EQ. 1) THEN A(I,I) = -ONE B(I,(I+1)/2) = ONE ELSE A(I,I-1) = ONE A(I,I+1) = -ONE C(I/2,I) = ONE END IF 45 CONTINUE ISYMM = 1 DO 50 I = IPAR(3), 1, -1 Q(ISYMM) = 10.0D0 ISYMM = ISYMM + I 50 CONTINUE IDENT = '0001' C ELSE IF (NR(2) .EQ. 2) THEN DO 60 I = 1, IPAR(1) A(I,I) = -TWO IF (I .LT. IPAR(1)) THEN A(I,I+1) = ONE A(I+1,I) = ONE END IF 60 CONTINUE A(1,IPAR(1)) = ONE A(IPAR(1),1) = ONE IDENT = '1111' TEMP = TWO * PI / DBLE(IPAR(1)) DO 70 I = 1, IPAR(1) DWORK(I) = COS(TEMP*DBLE(I-1)) DWORK(IPAR(1)+I) = -TWO + TWO*DWORK(I) + 1 SQRT(5.0D0 + FOUR*DWORK(I)*(DWORK(I) - TWO)) 70 CONTINUE DO 90 J = 1, IPAR(1) DO 80 I = 1, IPAR(1) DWORK(2*IPAR(1)+I) = COS(TEMP*DBLE(I-1)*DBLE(J-1)) 80 CONTINUE X(J,1) = DDOT(IPAR(1), DWORK(IPAR(1)+1), 1, 1 DWORK(2*IPAR(1)+1), 1)/DBLE(IPAR(1)) 90 CONTINUE C .. set up circulant solution matrix .. DO 100 I = 2, IPAR(1) CALL DCOPY(IPAR(1)-I+1, X(1,1), 1, X(I,I), 1) CALL DCOPY(I-1, X(IPAR(1)-I+2,1), 1, X(1,I), 1) 100 CONTINUE END IF C ELSE IF (NR(1) .EQ. 4) THEN IF (NR(2) .EQ. 1) THEN C .. set up remaining parameter .. IF (.NOT. LSAME(DEF,'N')) THEN DPAR(1) = ONE DPAR(2) = ONE END IF CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(1,2), LDA) B(IPAR(1),1) = ONE C(1,1) = ONE Q(1) = DPAR(1) G(1) = DPAR(2) IDENT = '0000' C ELSE IF (NR(2) .EQ. 2) THEN C .. set up remaining parameters .. APPIND = DBLE(IPAR(1) + 1) IF (.NOT. LSAME(DEF,'N')) THEN DPAR(1) = PARDEF(NR(1), NR(2)) DPAR(2) = ONE DPAR(3) = ONE DPAR(4) = .2D0 DPAR(5) = .3D0 DPAR(6) = .2D0 DPAR(7) = .3D0 END IF C .. set up stiffness matrix .. TEMP = -DPAR(1)*APPIND CALL DLASET('A', IPAR(1), IPAR(1), ZERO, TWO*TEMP, A, LDA) DO 110 I = 1, IPAR(1) - 1 A(I+1,I) = -TEMP A(I,I+1) = -TEMP 110 CONTINUE C .. set up Gramian, stored by diagonals .. TEMP = ONE/(6.0D0*APPIND) CALL DLASET('L', IPAR(1), 1, FOUR*TEMP, FOUR*TEMP, DWORK, 1 IPAR(1)) CALL DLASET('L', IPAR(1)-1, 1, TEMP, TEMP, DWORK(IPAR(1)+1), 1 IPAR(1)) CALL DPTTRF(IPAR(1), DWORK(1), DWORK(IPAR(1)+1), INFO) C .. A = (inverse of Gramian) * (stiffness matrix) .. CALL DPTTRS(IPAR(1), IPAR(1), DWORK(1), DWORK(IPAR(1)+1), 1 A, LDA, INFO) C .. compute B, C .. DO 120 I = 1, IPAR(1) B1 = MAX(DBLE(I-1)/APPIND, DPAR(4)) B2 = MIN(DBLE(I+1)/APPIND, DPAR(5)) C1 = MAX(DBLE(I-1)/APPIND, DPAR(6)) C2 = MIN(DBLE(I+1)/APPIND, DPAR(7)) IF (B1 .GE. B2) THEN B(I,1) = ZERO ELSE B(I,1) = B2 - B1 TEMP = MIN(B2, DBLE(I)/APPIND) IF (B1 .LT. TEMP) THEN B(I,1) = B(I,1) + APPIND*(TEMP**2 - B1**2)/TWO B(I,1) = B(I,1) + DBLE(I)*(B1 - TEMP) END IF TEMP = MAX(B1, DBLE(I)/APPIND) IF (TEMP .LT. B2) THEN B(I,1) = B(I,1) - APPIND*(B2**2 - TEMP**2)/TWO B(I,1) = B(I,1) - DBLE(I)*(TEMP - B2) END IF END IF IF (C1 .GE. C2) THEN C(1,I) = ZERO ELSE C(1,I) = C2 - C1 TEMP = MIN(C2, DBLE(I)/APPIND) IF (C1 .LT. TEMP) THEN C(1,I) = C(1,I) + APPIND*(TEMP**2 - C1**2)/TWO C(1,I) = C(1,I) + DBLE(I)*(C1 - TEMP) END IF TEMP = MAX(C1, DBLE(I)/APPIND) IF (TEMP .LT. C2) THEN C(1,I) = C(1,I) - APPIND*(C2**2 - TEMP**2)/TWO C(1,I) = C(1,I) - DBLE(I)*(TEMP - C2) END IF END IF 120 CONTINUE CALL DSCAL(IPAR(1), DPAR(2), B(1,1), 1) CALL DSCAL(IPAR(1), DPAR(3), C(1,1), LDC) CALL DPTTRS(IPAR(1), 1, DWORK(1), DWORK(IPAR(1)+1), B, LDB, 1 INFO) IDENT = '0011' C ELSE IF (NR(2) .EQ. 3) THEN C .. set up remaining parameters .. IF (.NOT. LSAME(DEF,'N')) THEN DPAR(1) = PARDEF(NR(1),NR(2)) DPAR(2) = FOUR DPAR(3) = ONE END IF IF (DPAR(1) . NE. 0) THEN CALL DLASET('A', L, L, ZERO, ONE, A(1,L+1), LDA) TEMP = DPAR(3) / DPAR(1) A(L+1,1) = -TEMP A(L+1,2) = TEMP A(IPAR(1),L-1) = TEMP A(IPAR(1),L) = -TEMP TTEMP = TWO*TEMP DO 130 I = 2, L-1 A(L+I,I) = -TTEMP A(L+I,I+1) = TEMP A(L+I,I-1) = TEMP 130 CONTINUE CALL DLASET('A', L, L, ZERO, -DPAR(2)/DPAR(1), A(L+1,L+1), 1 LDA) B(L+1,1) = ONE / DPAR(1) B(IPAR(1),IPAR(2)) = -ONE / DPAR(1) IDENT = '0111' ELSE INFO = 2 END IF C ELSE IF (NR(2) .EQ. 4) THEN IF (.NOT. LSAME(DEF,'N')) THEN WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') 1 'BB01', NR(1), '0', NR(2), '.dat' I = 11 ELSE I = IPAR(4) END IF OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:I)) IF (IOS .NE. 0) THEN INFO = 1 ELSE READ (1, FMT = *, IOSTAT = IOS) (DWORK(I), I = 1, 4*L-2) IF (IOS .NE. 0) INFO = 1 END IF CLOSE(1) IF (INFO .EQ. 0) THEN CALL DLASET('A', L-1, L-1, ZERO, ONE, A(L+1,2), LDA) POS = 2*L + 1 A(1,2) = - DWORK(POS) / DWORK(1) DO 140 I = 2, L TEMP = DWORK(POS) / DWORK(I-1) TTEMP = DWORK(POS) / DWORK(I) IF (I .GT. 2) A(I-1,I) = TEMP A(I,I) = -(TEMP + TTEMP) IF (I .LT. L) A(I+1,I) = TTEMP POS = POS + 1 140 CONTINUE POS = L TEMP = DWORK(POS+1) / DWORK(1) A(1,1) = -TEMP DO 160 I = 2, L TTEMP = TEMP TEMP = DWORK(POS+I) / DWORK(I) SUM = TTEMP - TEMP A(I,1) = -SUM A(I,I) = A(I,I) - TEMP DO 150 J = 2, I-2 A(I,J) = SUM 150 CONTINUE IF (I .GT. 2) A(I,I-1) = A(I,I-1) + SUM 160 CONTINUE POS = 3*L A(1,L+1) = -DWORK(3*L)/DWORK(1) DO 170 I = 2, L TEMP = DWORK(POS) / DWORK(I-1) TTEMP = DWORK(POS) / DWORK(I) IF (I .GT. 2) A(I-1,L+I-1) = TEMP A(I,L+I-1) = -(TEMP + TTEMP) IF (I .LT. L) A(I+1,L+I-1) = TTEMP POS = POS + 1 170 CONTINUE B(1,1) = ONE/DWORK(1) DO 180 I = 1, L TEMP = ONE/DWORK(I) IF (I .GT. 1) B(I,I) = -TEMP IF (I .LT. L) B(I+1,I) = TEMP 180 CONTINUE C(1,1) = ONE Q(1) = ONE POS = 2*L - 1 ISYMM = L + 1 DO 190 I = 2, L TEMP = DWORK(POS+I) TTEMP = DWORK(POS+L+I-1) C(I,I) = TEMP C(I,L+I-1) = TTEMP Q(ISYMM) = ONE / (TEMP*TEMP + TTEMP*TTEMP) ISYMM = ISYMM + L - I + 1 190 CONTINUE IDENT = '0001' END IF END IF END IF C IF (INFO .NE. 0) GOTO 2001 C .. set up data in required format .. C IF (BPAR(1)) THEN C .. G is to be returned in product form .. GDIMM = IPAR(1) IF (IDENT(4:4) .EQ. '0') THEN C .. invert R using Cholesky factorization, store in G .. CALL DPPTRF('L', IPAR(2), G, INFO) IF (INFO .EQ. 0) THEN CALL DPPTRI('L', IPAR(2), G, INFO) IF (IDENT(1:1) .EQ. '0') THEN C .. B is not identity matrix .. DO 200 I = 1, IPAR(1) CALL DSPMV('L', IPAR(2), ONE, G, B(I,1), LDB, ZERO, 1 DWORK((I-1)*IPAR(1)+1), 1) 200 CONTINUE CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), 1 B(1,1), LDB, ZERO, G, 1) ISYMM = IPAR(1) + 1 DO 210 I = 2, IPAR(1) CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), 1 B(I,1), LDB, ZERO, B(1,1), LDB) CALL DCOPY(IPAR(1) - I + 1, B(1,I), LDB, G(ISYMM), 1) ISYMM = ISYMM + (IPAR(1) - I + 1) 210 CONTINUE END IF ELSE IF (INFO .GT. 0) THEN INFO = 3 GOTO 2001 END IF END IF ELSE C .. R = identity .. IF (IDENT(1:1) .EQ. '0') THEN C .. B is not identity matrix .. IF (IPAR(2) .EQ. 1) THEN CALL DLASET('L', NSYMM, 1, ZERO, ZERO, G, 1) CALL DSPR('L', IPAR(1), ONE, B, 1, G) ELSE CALL DSYRK('L', 'N', IPAR(1), IPAR(2), ONE, 1 B, LDB, ZERO, DWORK, IPAR(1)) CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), G) END IF ELSE C .. B = R = identity .. ISYMM = 1 DO 220 I = IPAR(1), 1, -1 G(ISYMM) = ONE ISYMM = ISYMM + I 220 CONTINUE END IF END IF ELSE GDIMM = IPAR(2) IF (IDENT(1:1) .EQ. '1') 1 CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ONE, B, LDB) IF (IDENT(4:4) .EQ. '1') THEN ISYMM = 1 DO 230 I = IPAR(2), 1, -1 G(ISYMM) = ONE ISYMM = ISYMM + I 230 CONTINUE END IF END IF C IF (BPAR(4)) THEN C .. Q is to be returned in product form .. QDIMM = IPAR(1) IF (IDENT(3:3) .EQ. '0') THEN IF (IDENT(2:2) .EQ. '0') THEN C .. C is not identity matrix .. DO 240 I = 1, IPAR(1) CALL DSPMV('L', IPAR(3), ONE, Q, C(1,I), 1, ZERO, 1 DWORK((I-1)*IPAR(1)+1), 1) 240 CONTINUE C .. use Q(1:IPAR(1)) as workspace and compute the first column C of Q in the end .. ISYMM = IPAR(1) + 1 DO 250 I = 2, IPAR(1) CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), 1 C(1,I), 1, ZERO, Q(1), 1) CALL DCOPY(IPAR(1) - I + 1, Q(I), 1, Q(ISYMM), 1) ISYMM = ISYMM + (IPAR(1) - I + 1) 250 CONTINUE CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), 1 C(1,1), 1, ZERO, Q, 1) END IF ELSE C .. Q = identity .. IF (IDENT(2:2) .EQ. '0') THEN C .. C is not identity matrix .. IF (IPAR(3) .EQ. 1) THEN CALL DLASET('L', NSYMM, 1, ZERO, ZERO, Q, 1) CALL DSPR('L', IPAR(1), ONE, C, LDC, Q) ELSE CALL DSYRK('L', 'T', IPAR(1), IPAR(3), ONE, C, LDC, 1 ZERO, DWORK, IPAR(1)) CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) END IF ELSE C .. C = Q = identity .. ISYMM = 1 DO 260 I = IPAR(1), 1, -1 Q(ISYMM) = ONE ISYMM = ISYMM + I 260 CONTINUE END IF END IF ELSE QDIMM = IPAR(3) IF (IDENT(2:2) .EQ. '1') 1 CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ONE, C, LDC) IF (IDENT(3:3) .EQ. '1') THEN ISYMM = 1 DO 270 I = IPAR(3), 1, -1 Q(ISYMM) = ONE ISYMM = ISYMM + I 270 CONTINUE END IF END IF C C .. unpack symmetric matrices if desired .. IF (BPAR(2)) THEN ISYMM = (GDIMM * (GDIMM + 1)) / 2 CALL DCOPY(ISYMM, G, 1, DWORK, 1) CALL MA02DD('Unpack', 'Lower', GDIMM, G, LDG, DWORK) CALL MA02ED('Lower', GDIMM, G, LDG) ELSE IF (BPAR(3)) THEN CALL MA02DD('Unpack', 'Lower', GDIMM, DWORK, GDIMM, G) CALL MA02ED('Lower', GDIMM, DWORK, GDIMM) CALL MA02DD('Pack', 'Upper', GDIMM, DWORK, GDIMM, G) END IF IF (BPAR(5)) THEN ISYMM = (QDIMM * (QDIMM + 1)) / 2 CALL DCOPY(ISYMM, Q, 1, DWORK, 1) CALL MA02DD('Unpack', 'Lower', QDIMM, Q, LDQ, DWORK) CALL MA02ED('Lower', QDIMM, Q, LDQ) ELSE IF (BPAR(6)) THEN CALL MA02DD('Unpack', 'Lower', QDIMM, DWORK, QDIMM, Q) CALL MA02ED('Lower', QDIMM, DWORK, QDIMM) CALL MA02DD('Pack', 'Upper', QDIMM, DWORK, QDIMM, Q) END IF C C ...set VEC... VEC(1) = .TRUE. VEC(2) = .TRUE. VEC(3) = .TRUE. VEC(4) = .TRUE. VEC(5) = .NOT. BPAR(1) VEC(6) = .NOT. BPAR(4) VEC(7) = .TRUE. VEC(8) = .TRUE. IF (NR(1) .EQ. 1) THEN IF ((NR(2) .EQ. 1) .OR. (NR(2) .EQ. 2)) VEC(9) = .TRUE. ELSE IF (NR(1) .EQ. 2) THEN IF ((NR(2) .EQ. 1) .OR. ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6))) 1 VEC(9) = .TRUE. ELSE IF (NR(1) .EQ. 3) THEN IF (NR(2) .EQ. 2) VEC(9) = .TRUE. END IF CHPAR = NOTES(NR(1),NR(2)) N = IPAR(1) M = IPAR(2) P = IPAR(3) 2001 CONTINUE RETURN C *** Last line of BB01AD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02OD.f0000644000000000000000000000013015012430707016164 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB02OD.f0000644000175000017500000007677115012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE SB02OD( DICO, JOBB, FACT, UPLO, JOBL, SORT, N, M, P, A, $ LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, RCOND, X, $ LDX, ALFAR, ALFAI, BETA, S, LDS, T, LDT, U, $ LDU, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) C C PURPOSE C C To solve for X either the continuous-time algebraic Riccati C equation C -1 C Q + A'X + XA - (L+XB)R (L+XB)' = 0 (1) C C or the discrete-time algebraic Riccati equation C -1 C X = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q (2) C C where A, B, Q, R, and L are N-by-N, N-by-M, N-by-N, M-by-M and C N-by-M matrices, respectively, such that Q = C'C, R = D'D and C L = C'D; X is an N-by-N symmetric matrix. C The routine also returns the computed values of the closed-loop C spectrum of the system, i.e., the stable eigenvalues lambda(1), C ..., lambda(N) of the corresponding Hamiltonian or symplectic C pencil, in the continuous-time case or discrete-time case, C respectively. C -1 C Optionally, matrix G = BR B' may be given instead of B and R. C Other options include the case with Q and/or R given in a C factored form, Q = C'C, R = D'D, and with L a zero matrix. C C The routine uses the method of deflating subspaces, based on C reordering the eigenvalues in a generalized Schur matrix pair. C A standard eigenproblem is solved in the continuous-time case C if G is given. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of Riccati equation to be solved as C follows: C = 'C': Equation (1), continuous-time case; C = 'D': Equation (2), discrete-time case. C C JOBB CHARACTER*1 C Specifies whether or not the matrix G is given, instead C of the matrices B and R, as follows: C = 'B': B and R are given; C = 'G': G is given. C C FACT CHARACTER*1 C Specifies whether or not the matrices Q and/or R (if C JOBB = 'B') are factored, as follows: C = 'N': Not factored, Q and R are given; C = 'C': C is given, and Q = C'C; C = 'D': D is given, and R = D'D; C = 'B': Both factors C and D are given, Q = C'C, R = D'D. C C UPLO CHARACTER*1 C If JOBB = 'G', or FACT = 'N', specifies which triangle of C the matrices G and Q (if FACT = 'N'), or Q and R (if C JOBB = 'B'), is stored, as follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. C C JOBL CHARACTER*1 C Specifies whether or not the matrix L is zero, as follows: C = 'Z': L is zero; C = 'N': L is nonzero. C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. C SLICOT Library routine SB02MT should be called just before C SB02OD, for obtaining the results when JOBB = 'G' and C JOBL = 'N'. C C SORT CHARACTER*1 C Specifies which eigenvalues should be obtained in the top C of the generalized Schur form, as follows: C = 'S': Stable eigenvalues come first; C = 'U': Unstable eigenvalues come first. C C Input/Output Parameters C C N (input) INTEGER C The actual state dimension, i.e. the order of the matrices C A, Q, and X, and the number of rows of the matrices B C and L. N >= 0. C C M (input) INTEGER C The number of system inputs. If JOBB = 'B', M is the C order of the matrix R, and the number of columns of the C matrix B. M >= 0. C M is not used if JOBB = 'G'. C C P (input) INTEGER C The number of system outputs. If FACT = 'C' or 'D' or 'B', C P is the number of rows of the matrices C and/or D. C P >= 0. C Otherwise, P is not used. 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 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,*) C If JOBB = 'B', the leading N-by-M part of this array must C contain the input matrix B of the system. C If JOBB = 'G', 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 upper triangular part or C lower triangular part, respectively, of the matrix C -1 C G = BR B'. The strictly lower triangular part (if C UPLO = 'U') or strictly upper triangular part (if C UPLO = 'L') is not referenced. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) C If FACT = 'N' or 'D', the leading N-by-N upper triangular C part (if UPLO = 'U') or lower triangular part (if UPLO = C 'L') of this array must contain the upper triangular part C or lower triangular part, respectively, of the symmetric C state weighting matrix Q. The strictly lower triangular C part (if UPLO = 'U') or strictly upper triangular part (if C UPLO = 'L') is not referenced. C If JOBB = 'B', the triangular part of this array defined C by UPLO is modified internally, but is restored on exit. C If FACT = 'C' or 'B', the leading P-by-N part of this C array must contain the output matrix C of the system. C If JOBB = 'B', this part is modified internally, but is C restored on exit. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= MAX(1,N) if FACT = 'N' or 'D', C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. C C R (input) DOUBLE PRECISION array, dimension (LDR,M) C If FACT = 'N' or 'C', the leading M-by-M upper triangular C part (if UPLO = 'U') or lower triangular part (if UPLO = C 'L') of this array must contain the upper triangular part C or lower triangular part, respectively, of the symmetric C input weighting matrix R. The strictly lower triangular C part (if UPLO = 'U') or strictly upper triangular part (if C UPLO = 'L') is not referenced. C The triangular part of this array defined by UPLO is C modified internally, but is restored on exit. C If FACT = 'D' or 'B', the leading P-by-M part of this C array must contain the direct transmission matrix D of the C system. This part is modified internally, but is restored C on exit. C If JOBB = 'G', this array is not referenced. C C LDR INTEGER C The leading dimension of array R. C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; C LDR >= 1 if JOBB = 'G'. C C L (input) DOUBLE PRECISION array, dimension (LDL,M) C If JOBL = 'N' (and JOBB = 'B'), the leading N-by-M part of C this array must contain the cross weighting matrix L. C This part is modified internally, but is restored on exit. C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. C C LDL INTEGER C The leading dimension of array L. C LDL >= MAX(1,N) if JOBL = 'N' and JOBB = 'B'; C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. C C RCOND (output) DOUBLE PRECISION C An estimate of the reciprocal of the condition number (in C the 1-norm) of the N-th order system of algebraic C equations from which the solution matrix X is obtained. C C X (output) DOUBLE PRECISION array, dimension (LDX,N) C The leading N-by-N part of this array contains the C solution matrix X of the problem. C C LDX INTEGER C The leading dimension of array X. LDX >= MAX(1,N). C C ALFAR (output) DOUBLE PRECISION array, dimension (2*N) C ALFAI (output) DOUBLE PRECISION array, dimension (2*N) C BETA (output) DOUBLE PRECISION array, dimension (2*N) C The generalized eigenvalues of the 2N-by-2N matrix pair, C ordered as specified by SORT (if INFO = 0). For instance, C if SORT = 'S', the leading N elements of these arrays C contain the closed-loop spectrum of the system matrix C A - BF, where F is the optimal feedback matrix computed C based on the solution matrix X. Specifically, C lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for C k = 1,2,...,N. C If DICO = 'C' and JOBB = 'G', the elements of BETA are C set to 1. C C S (output) DOUBLE PRECISION array, dimension (LDS,*) C The leading 2N-by-2N part of this array contains the C ordered real Schur form S of the first matrix in the C reduced matrix pencil associated to the optimal problem, C or of the corresponding Hamiltonian matrix, if DICO = 'C' C and JOBB = 'G'. That is, C C (S S ) C ( 11 12) C S = ( ), C (0 S ) C ( 22) C C where S , S and S are N-by-N matrices. C 11 12 22 C Array S must have 2*N+M columns if JOBB = 'B', and 2*N C columns, otherwise. C C LDS INTEGER C The leading dimension of array S. C LDS >= MAX(1,2*N+M) if JOBB = 'B', C LDS >= MAX(1,2*N) if JOBB = 'G'. C C T (output) DOUBLE PRECISION array, dimension (LDT,2*N) C If DICO = 'D' or JOBB = 'B', the leading 2N-by-2N part of C this array contains the ordered upper triangular form T of C the second matrix in the reduced matrix pencil associated C to the optimal problem. That is, C C (T T ) C ( 11 12) C T = ( ), C (0 T ) C ( 22) C C where T , T and T are N-by-N matrices. C 11 12 22 C If DICO = 'C' and JOBB = 'G' this array is not referenced. C C LDT INTEGER C The leading dimension of array T. C LDT >= MAX(1,2*N+M) if JOBB = 'B', C LDT >= MAX(1,2*N) if JOBB = 'G' and DICO = 'D', C LDT >= 1 if JOBB = 'G' and DICO = 'C'. C C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) C The leading 2N-by-2N part of this array contains the right C transformation matrix U which reduces the 2N-by-2N matrix C pencil to the ordered generalized real Schur form (S,T), C or the Hamiltonian matrix to the ordered real Schur C form S, if DICO = 'C' and JOBB = 'G'. That is, C C (U U ) C ( 11 12) C U = ( ), C (U U ) C ( 21 22) C C where U , U , U and U are N-by-N matrices. C 11 12 21 22 C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,2*N). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used to test for near singularity of C the original matrix pencil, specifically of the triangular C factor obtained during the reduction process. If the user C sets TOL > 0, then the given value of TOL is used as a C lower bound for the reciprocal condition number of that C matrix; a matrix whose estimated condition number is less C than 1/TOL is considered to be nonsingular. If the user C sets TOL <= 0, then a default tolerance, defined by C TOLDEF = EPS, is used instead, where EPS is the machine C precision (see LAPACK Library routine DLAMCH). C This parameter is not referenced if JOBB = 'G'. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK >= MAX(1,M,2*N) if JOBB = 'B', C LIWORK >= MAX(1,2*N) if JOBB = 'G'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK. If JOBB = 'B' and N > 0, DWORK(2) returns the C reciprocal of the condition number of the M-by-M lower C triangular matrix obtained after compressing the matrix C pencil of order 2N+M to obtain a pencil of order 2N. C If INFO = 0 or INFO = 6, DWORK(3) returns the scaling C factor used internally, which should multiply the C submatrix Y2 to recover X from the first N columns of U C (see METHOD). C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(3,6*N), if JOBB = 'G', C DICO = 'C'; C LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G', C DICO = 'D'; C LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. C For optimum performance LDWORK should be larger. 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 computed extended matrix pencil is singular, C possibly due to rounding errors; C = 2: if the QZ (or QR) algorithm failed; C = 3: if reordering of the (generalized) eigenvalues C failed; C = 4: if after reordering, roundoff changed values of C some complex eigenvalues so that leading eigenvalues C in the (generalized) Schur form no longer satisfy C the stability condition; this could also be caused C due to scaling; C = 5: if the computed dimension of the solution does not C equal N; C = 6: if a singular matrix was encountered during the C computation of the solution matrix X. C C METHOD C C The routine uses a variant of the method of deflating subspaces C proposed by van Dooren [1]. See also [2], [3]. C It is assumed that (A,B) is stabilizable and (C,A) is detectable. C Under these assumptions the algebraic Riccati equation is known to C have a unique non-negative definite solution. C The first step in the method of deflating subspaces is to form the C extended Hamiltonian matrices, dimension 2N + M given by C C discrete-time continuous-time C C |A 0 B| |I 0 0| |A 0 B| |I 0 0| C |Q -I L| - z |0 -A' 0|, |Q A' L| - s |0 -I 0|. C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| C C Next, these pencils are compressed to a form (see [1]) C C lambda x A - B . C f f C C This generalized eigenvalue problem is then solved using the QZ C algorithm and the stable deflating subspace Ys is determined. C If [Y1'|Y2']' is a basis for Ys, then the required solution is C -1 C X = Y2 x Y1 . C A standard eigenvalue problem is solved using the QR algorithm in C the continuous-time case when G is given (DICO = 'C', JOBB = 'G'). C C REFERENCES C C [1] Van Dooren, P. C A Generalized Eigenvalue Approach for Solving Riccati C Equations. C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. C C [2] Mehrmann, V. C The Autonomous Linear Quadratic Control Problem. Theory and C Numerical Solution. C Lect. Notes in Control and Information Sciences, vol. 163, C Springer-Verlag, Berlin, 1991. C C [3] Sima, V. C Algorithms for Linear-Quadratic Optimization. C Pure and Applied Mathematics: A Series of Monographs and C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. C C NUMERICAL ASPECTS C C This routine is particularly suited for systems where the matrix R C is ill-conditioned. Internal scaling is used. C C FURTHER COMMENTS C C To obtain a stabilizing solution of the algebraic Riccati C equations set SORT = 'S'. C C The routine can also compute the anti-stabilizing solutions of C the algebraic Riccati equations, by specifying SORT = 'U'. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. C Supersedes Release 2.0 routine SB02CD by T.G.J. Beelen, Philips, C Eindhoven, Holland. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, June 2002, C December 2002, January 2005. C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, discrete-time system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, THREE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, $ THREE = 3.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, FACT, JOBB, JOBL, SORT, UPLO INTEGER INFO, LDA, LDB, LDL, LDQ, LDR, LDS, LDT, LDU, $ LDWORK, LDX, M, N, P DOUBLE PRECISION RCOND, TOL C .. Array Arguments .. LOGICAL BWORK(*) INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), ALFAI(*), ALFAR(*), B(LDB,*), BETA(*), $ DWORK(*), L(LDL,*), Q(LDQ,*), R(LDR,*), $ S(LDS,*), T(LDT,*), U(LDU,*), X(LDX,*) C .. Local Scalars .. CHARACTER QTYPE, RTYPE LOGICAL DISCR, LFACB, LFACN, LFACQ, LFACR, LJOBB, LJOBL, $ LJOBLN, LSCAL, LSCL, LSORT, LUPLO INTEGER I, INFO1, J, LDW, MP, NDIM, NN, NNM, NP, NP1, $ WRKOPT DOUBLE PRECISION QSCAL, RCONDL, RNORM, RSCAL, SCALE, UNORM C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME, SB02MR, SB02MV, SB02OU, SB02OV, SB02OW DOUBLE PRECISION DLAMCH, DLANGE, DLANSY EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MV, $ SB02OU, SB02OV, SB02OW C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGECON, DGEES, DGETRF, DGETRS, $ DGGES, DLACPY, DLASCL, DLASET, DSCAL, DSWAP, $ SB02OY, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 DISCR = LSAME( DICO, 'D' ) LJOBB = LSAME( JOBB, 'B' ) LFACN = LSAME( FACT, 'N' ) LFACQ = LSAME( FACT, 'C' ) LFACR = LSAME( FACT, 'D' ) LFACB = LSAME( FACT, 'B' ) LUPLO = LSAME( UPLO, 'U' ) LSORT = LSAME( SORT, 'S' ) C NN = 2*N IF ( LJOBB ) THEN LJOBL = LSAME( JOBL, 'Z' ) LJOBLN = LSAME( JOBL, 'N' ) NNM = NN + M LDW = MAX( NNM, 3*M ) ELSE NNM = NN LDW = 1 END IF NP1 = N + 1 C C Test the input scalar arguments. C IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN INFO = -2 ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB $ .AND. .NOT.LFACN ) THEN INFO = -3 ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) $ INFO = -4 END IF IF( INFO.EQ.0 .AND. LJOBB ) THEN IF( .NOT.LJOBL .AND. .NOT.LJOBLN ) $ INFO = -5 END IF IF( INFO.EQ.0 ) THEN IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN INFO = -6 ELSE IF( N.LT.0 ) THEN INFO = -7 ELSE IF( LJOBB ) THEN IF( M.LT.0 ) $ INFO = -8 END IF END IF IF( INFO.EQ.0 .AND. .NOT.LFACN ) THEN IF( P.LT.0 ) $ INFO = -9 END IF IF( INFO.EQ.0 ) THEN IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN INFO = -15 ELSE IF( LDR.LT.1 ) THEN INFO = -17 ELSE IF( LDL.LT.1 ) THEN INFO = -19 ELSE IF( LJOBB ) THEN IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.M .OR. $ ( LFACR.OR.LFACB ) .AND. LDR.LT.P ) THEN INFO = -17 ELSE IF( LJOBLN .AND. LDL.LT.N ) THEN INFO = -19 END IF END IF END IF IF( INFO.EQ.0 ) THEN IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -22 ELSE IF( LDS.LT.MAX( 1, NNM ) ) THEN INFO = -27 ELSE IF( LDT.LT.1 ) THEN INFO = -29 ELSE IF( LDU.LT.MAX( 1, NN ) ) THEN INFO = -31 ELSE IF( LDWORK.LT.MAX( 3, 6*N ) ) THEN INFO = -35 ELSE IF( DISCR .OR. LJOBB ) THEN IF( LDT.LT.NNM ) THEN INFO = -29 ELSE IF( LDWORK.LT.MAX( 14*N + 23, 16*N, LDW ) ) THEN INFO = -35 END IF END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB02OD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN RCOND = ONE DWORK(1) = THREE DWORK(3) = ONE RETURN END IF C C Always scale the matrix pencil. C LSCAL = .TRUE. C C Start computations. 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 IF ( LSCAL .AND. LJOBB ) THEN C C Scale the matrices Q, R, and L so that C norm(Q) + norm(R) + norm(L) = 1, C using the 1-norm. If Q and/or R are factored, the norms of C the factors are used. C Workspace: need max(N,M), if FACT = 'N'; C N, if FACT = 'D'; C M, if FACT = 'C'. C IF ( LFACN .OR. LFACR ) THEN SCALE = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) QTYPE = UPLO NP = N ELSE SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) QTYPE = 'G' NP = P END IF C IF ( LFACN .OR. LFACQ ) THEN RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) RTYPE = UPLO MP = M ELSE RNORM = DLANGE( '1-norm', P, M, R, LDR, DWORK ) RTYPE = 'G' MP = P END IF SCALE = SCALE + RNORM C IF ( LJOBLN ) $ SCALE = SCALE + DLANGE( '1-norm', N, M, L, LDL, DWORK ) IF ( SCALE.EQ.ZERO ) $ SCALE = ONE C IF ( LFACN .OR. LFACR ) THEN QSCAL = SCALE ELSE QSCAL = SQRT( SCALE ) END IF C IF ( LFACN .OR. LFACQ ) THEN RSCAL = SCALE ELSE RSCAL = SQRT( SCALE ) END IF C CALL DLASCL( QTYPE, 0, 0, QSCAL, ONE, NP, N, Q, LDQ, INFO1 ) CALL DLASCL( RTYPE, 0, 0, RSCAL, ONE, MP, M, R, LDR, INFO1 ) IF ( LJOBLN ) $ CALL DLASCL( 'G', 0, 0, SCALE, ONE, N, M, L, LDL, INFO1 ) END IF C C Construct the extended matrix pair. C C Workspace: need 1, if JOBB = 'G', C max(1,2*N+M,3*M), if JOBB = 'B'; C prefer larger. C CALL SB02OY( 'Optimal control', DICO, JOBB, FACT, UPLO, JOBL, $ 'Identity E', N, M, P, A, LDA, B, LDB, Q, LDQ, R, $ LDR, L, LDL, U, 1, S, LDS, T, LDT, TOL, IWORK, DWORK, $ LDWORK, INFO ) C IF ( LSCAL .AND. LJOBB ) THEN C C Undo scaling of the data arrays. C CALL DLASCL( QTYPE, 0, 0, ONE, QSCAL, NP, N, Q, LDQ, INFO1 ) CALL DLASCL( RTYPE, 0, 0, ONE, RSCAL, MP, M, R, LDR, INFO1 ) IF ( LJOBLN ) $ CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, M, L, LDL, INFO1 ) END IF C IF ( INFO.NE.0 ) $ RETURN WRKOPT = DWORK(1) IF ( LJOBB ) RCONDL = DWORK(2) C IF ( LSCAL .AND. .NOT.LJOBB ) THEN C C This part of the code is used when G is given (JOBB = 'G'). C A standard eigenproblem is solved in the continuous-time case. C Scale the Hamiltonian matrix S, if DICO = 'C', or the C symplectic pencil (S,T), if DICO = 'D', using the square roots C of the norms of the matrices Q and G. C Workspace: need N. C IF ( LFACN .OR. LFACR ) THEN SCALE = SQRT( DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) ) ELSE SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) END IF RNORM = SQRT( DLANSY( '1-norm', UPLO, N, B, LDB, DWORK ) ) C LSCL = MIN( SCALE, RNORM ).GT.ZERO .AND. SCALE.NE.RNORM C IF( LSCL ) THEN IF( DISCR ) THEN CALL DLASCL( 'G', 0, 0, SCALE, RNORM, N, N, S(NP1,1), $ LDS, INFO1 ) CALL DLASCL( 'G', 0, 0, RNORM, SCALE, N, N, T(1,NP1), $ LDT, INFO1 ) ELSE CALL DLASCL( 'G', 0, 0, SCALE, -RNORM, N, N, S(NP1,1), $ LDS, INFO1 ) CALL DLASCL( 'G', 0, 0, RNORM, SCALE, N, N, S(1,NP1), $ LDS, INFO1 ) CALL DLASCL( 'G', 0, 0, ONE, -ONE, N, N, S(NP1,NP1), $ LDS, INFO1 ) END IF ELSE IF( .NOT.DISCR ) THEN CALL DLASCL( 'G', 0, 0, ONE, -ONE, N, NN, S(NP1,1), LDS, $ INFO1 ) END IF END IF ELSE LSCL = .FALSE. END IF C C Workspace: need max(7*(2*N+1)+16,16*N), C if JOBB = 'B' or DICO = 'D'; C 6*N, if JOBB = 'G' and DICO = 'C'; C prefer larger. C IF ( DISCR ) THEN IF ( LSORT ) THEN C C The natural tendency of the QZ algorithm to get the largest C eigenvalues in the leading part of the matrix pair is C exploited, by computing the unstable eigenvalues of the C permuted matrix pair. C CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, T, $ LDT, S, LDS, NDIM, ALFAR, ALFAI, BETA, U, LDU, $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) CALL DSWAP( N, ALFAR(NP1), 1, ALFAR, 1 ) CALL DSWAP( N, ALFAI(NP1), 1, ALFAI, 1 ) CALL DSWAP( N, BETA (NP1), 1, BETA, 1 ) ELSE CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, S, $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) END IF ELSE IF ( LJOBB ) THEN IF ( LSORT ) THEN CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OW, NN, $ S, LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, $ LDU, U, LDU, DWORK, LDWORK, BWORK, INFO1 ) ELSE CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OU, NN, $ S, LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, $ LDU, U, LDU, DWORK, LDWORK, BWORK, INFO1 ) END IF ELSE IF ( LSORT ) THEN CALL DGEES( 'Vectors', 'Sort', SB02MV, NN, S, LDS, NDIM, $ ALFAR, ALFAI, U, LDU, DWORK, LDWORK, BWORK, $ INFO1 ) ELSE CALL DGEES( 'Vectors', 'Sort', SB02MR, NN, S, LDS, NDIM, $ ALFAR, ALFAI, U, LDU, DWORK, LDWORK, BWORK, $ INFO1 ) END IF DUM(1) = ONE CALL DCOPY( NN, DUM, 0, BETA, 1 ) END IF END IF IF ( INFO1.GT.0 .AND. INFO1.LE.NN+1 ) THEN INFO = 2 ELSE IF ( INFO1.EQ.NN+2 ) THEN INFO = 4 ELSE IF ( INFO1.EQ.NN+3 ) THEN INFO = 3 ELSE IF ( NDIM.NE.N ) THEN INFO = 5 END IF IF ( INFO.NE.0 ) $ RETURN WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Select submatrices U1 and U2 out of the array U which define the C solution X = U2 x inv(U1). C Since X = X' we may obtain X as the solution of the system of C linear equations U1' x X = U2', where C U1 = U(1:n, 1:n), C U2 = U(n+1:2n, 1:n). C Use the (2,1) block of S as a workspace for factoring U1. C DO 20 J = 1, N CALL DCOPY( N, U(NP1,J), 1, X(J,1), LDX ) 20 CONTINUE C CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) C C Check if U1 is singular. C UNORM = DLANGE( '1-norm', N, N, S(NP1,1), LDS, DWORK ) C C Solve the system U1' x X = U2'. C CALL DGETRF( N, N, S(NP1,1), LDS, IWORK, INFO1 ) IF ( INFO1.NE.0 ) THEN INFO = 6 DWORK(3) = ONE IF ( LSCAL ) THEN IF ( LJOBB ) THEN DWORK(3) = SCALE ELSE IF ( LSCL ) THEN DWORK(3) = SCALE / RNORM END IF END IF RETURN ELSE C C Estimate the reciprocal condition of U1. C Workspace: need 3*N. C CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCOND, DWORK, $ IWORK(NP1), INFO ) C IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN C C Nearly singular matrix. Set INFO for error return. C INFO = 6 RETURN END IF WRKOPT = MAX( WRKOPT, 3*N ) CALL DGETRS( 'Transpose', N, N, S(NP1,1), LDS, IWORK, X, LDX, $ INFO1 ) C C Set S(2,1) to zero. C CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) C IF ( LSCAL ) THEN C C Prepare to undo scaling for the solution X. C IF ( .NOT.LJOBB ) THEN IF ( LSCL ) THEN SCALE = SCALE / RNORM ELSE SCALE = ONE END IF END IF DWORK(3) = SCALE SCALE = HALF*SCALE ELSE DWORK(3) = ONE SCALE = HALF END IF C C Make sure the solution matrix X is symmetric. C DO 40 I = 1, N CALL DAXPY( N-I+1, ONE, X(I,I), LDX, X(I,I), 1 ) CALL DSCAL( N-I+1, SCALE, X(I,I), 1 ) CALL DCOPY( N-I+1, X(I,I), 1, X(I,I), LDX ) 40 CONTINUE END IF C DWORK(1) = WRKOPT IF ( LJOBB ) DWORK(2) = RCONDL C RETURN C *** Last line of SB02OD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB08MZ.f0000644000000000000000000000013215012430707016176 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB08MZ.f0000644000175000017500000002257515012430707017405 0ustar00lilgelilge00000000000000 SUBROUTINE AB08MZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ RANK, TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) C C PURPOSE C C To compute the normal rank of the transfer-function matrix of a C state-space model (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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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 RANK (output) INTEGER C The normal rank of the transfer-function matrix. 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 (2*N+MAX(M,P)+1) C C DWORK DOUBLE PRECISION array, dimension (2*MAX(M,P)) C C ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal value C of LZWORK. C C LZWORK INTEGER C The length of the array ZWORK. C LZWORK >= (N+P)*(N+M) + MAX(MIN(P,M) + MAX(3*M-1,N), 1, C MIN(P,N) + MAX(3*P-1,N+P,N+M)) C For optimum performance LZWORK should be larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK 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 reduces the (N+P)-by-(M+N) compound matrix (B A) C (D C) C C to one with the same invariant zeros and with D of full row rank. C The normal rank of the transfer-function matrix is the rank of D. 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 CONTRIBUTOR C C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Dec. 2008. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, C Apr. 2009. C C KEYWORDS C C Multivariable system, unitary transformation, C structural invariant. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL INTEGER INFO, LDA, LDB, LDC, LDD, LZWORK, M, N, P, RANK DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) COMPLEX*16 A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), ZWORK(*) DOUBLE PRECISION DWORK(*) C .. Local Scalars .. LOGICAL LEQUIL, LQUERY INTEGER I, KW, MU, NINFZ, NKROL, NM, NP, NU, RO, $ SIGMA, WRKOPT DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL DLAMCH, LSAME, ZLANGE C .. External Subroutines .. EXTERNAL AB8NXZ, TB01IZ, XERBLA, ZLACPY C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C NP = N + P NM = N + M INFO = 0 LEQUIL = LSAME( EQUIL, 'S' ) LQUERY = ( LZWORK.EQ.-1 ) WRKOPT = NP*NM 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 KW = WRKOPT + MAX( MIN( P, M ) + MAX( 3*M-1, N ), 1, $ MIN( P, N ) + MAX( 3*P-1, NP, NM ) ) IF( LQUERY ) THEN SVLMAX = ZERO NINFZ = 0 CALL AB8NXZ( N, M, P, P, 0, SVLMAX, ZWORK, MAX( 1, NP ), $ NINFZ, IWORK, IWORK, MU, NU, NKROL, TOL, IWORK, $ DWORK, ZWORK, -1, INFO ) WRKOPT = MAX( KW, WRKOPT + INT( ZWORK(1) ) ) ELSE IF( LZWORK.LT.KW ) THEN INFO = -17 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB08MZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN ZWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF ( MIN( M, P ).EQ.0 ) THEN RANK = 0 ZWORK(1) = ONE RETURN END IF C DO 10 I = 1, 2*N+1 IWORK(I) = 0 10 CONTINUE C C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C as well as the preferred amount for good performance.) C C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). C ( D C ) C Complex workspace: need (N+P)*(N+M). C CALL ZLACPY( 'Full', N, M, B, LDB, ZWORK, NP ) CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(N+1), NP ) CALL ZLACPY( 'Full', N, N, A, LDA, ZWORK(NP*M+1), NP ) CALL ZLACPY( 'Full', P, N, C, LDC, ZWORK(NP*M+N+1), NP ) C C If required, balance the compound matrix (default MAXRED). C Real Workspace: need N. C KW = WRKOPT + 1 IF ( LEQUIL ) THEN MAXRED = ZERO CALL TB01IZ( 'A', N, M, P, MAXRED, ZWORK(NP*M+1), NP, ZWORK, $ NP, ZWORK(NP*M+N+1), NP, DWORK, INFO ) END IF C C If required, set tolerance. C THRESH = SQRT( DBLE( NP*NM ) )*DLAMCH( 'Precision' ) TOLER = TOL IF ( TOLER.LT.THRESH ) TOLER = THRESH SVLMAX = ZLANGE( 'Frobenius', NP, NM, ZWORK, NP, DWORK ) C C Reduce this system to one with the same invariant zeros and with C D full row rank MU (the normal rank of the original system). C Real workspace: need 2*MAX(M,P); C Complex workspace: need (N+P)*(N+M) + C 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 Integer workspace: 2*N+MAX(M,P)+1. C RO = P SIGMA = 0 NINFZ = 0 CALL AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ZWORK, NP, NINFZ, IWORK, $ IWORK(N+1), MU, NU, NKROL, TOLER, IWORK(2*N+2), $ DWORK, ZWORK(KW), LZWORK-KW+1, INFO ) RANK = MU C ZWORK(1) = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) RETURN C *** Last line of AB08MZ *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04MR.f0000644000000000000000000000013215012430707016204 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04MR.f0000644000175000017500000001226215012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE SB04MR( M, D, IPR, INFO ) 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 control-4.1.2/src/slicot/src/PaxHeaders/SB08HD.f0000644000000000000000000000013215012430707016165 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB08HD.f0000644000175000017500000002053315012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE SB08HD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, CR, $ LDCR, DR, LDDR, IWORK, DWORK, INFO ) C C PURPOSE C C To construct the state-space representation for the system C G = (A,B,C,D) from the factors Q = (AQR,BQR,CQ,DQ) and C R = (AQR,BQR,CR,DR) of its right coprime factorization C -1 C G = Q * R , C C where G, Q and R are the corresponding transfer-function matrices. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. Also the number of rows of the C matrix B and the number of columns of the matrices C and C CR. N represents the order of the systems Q and R. C N >= 0. C C M (input) INTEGER C The dimension of input vector. Also the number of columns C of the matrices B, D and DR and the number of rows of the C matrices CR and DR. M >= 0. C C P (input) INTEGER C The dimension of output vector. Also the number of rows C of the matrices C and D. 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 AQR of the systems C Q and R. C On exit, the leading N-by-N part of this array contains C the state dynamics matrix of the system G. 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 BQR of the systems Q and R. C On exit, the leading N-by-M part of this array contains C the input/state matrix of the system G. 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 CQ of the system Q. C On exit, the leading P-by-N part of this array contains C the state/output matrix of the system G. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C 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 DQ of the system Q. C On exit, the leading P-by-M part of this array contains C the input/output matrix of the system G. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C CR (input) DOUBLE PRECISION array, dimension (LDCR,N) C The leading M-by-N part of this array must contain the C state/output matrix CR of the system R. C C LDCR INTEGER C The leading dimension of array CR. LDCR >= MAX(1,M). C C DR (input/output) DOUBLE PRECISION array, dimension (LDDR,M) C On entry, the leading M-by-M part of this array must C contain the input/output matrix DR of the system R. C On exit, the leading M-by-M part of this array contains C the LU factorization of the matrix DR, as computed by C LAPACK Library routine DGETRF. C C LDDR INTEGER C The leading dimension of array DR. LDDR >= MAX(1,M). C C Workspace C C IWORK INTEGER array, dimension (M) C C DWORK DOUBLE PRECISION array, dimension (MAX(1,4*M)) C On exit, DWORK(1) contains an estimate of the reciprocal C condition number of the matrix DR. 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 DR is singular; C = 2: the matrix DR is numerically singular (warning); C the calculations continued. C C METHOD C C The subroutine computes the matrices of the state-space C representation G = (A,B,C,D) by using the formulas: C C -1 -1 C A = AQR - BQR * DR * CR, B = BQR * DR , C -1 -1 C C = CQ - DQ * DR * CR, D = DQ * DR . C C REFERENCES C C [1] Varga A. C Coprime factors model reduction method based on C square-root balancing-free techniques. C System Analysis, Modelling and Simulation, C vol. 11, pp. 303-311, 1993. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C July 1998. C Based on the RASP routine RCFI. C V. Sima, Research Institute for Informatics, Bucharest, Nov. 1998, C full BLAS 3 version. C C REVISIONS C C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. C Mar. 2000, V. Sima, Research Institute for Informatics, Bucharest. C C KEYWORDS C C Coprime factorization, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDCR, LDD, LDDR, M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), CR(LDCR,*), $ D(LDD,*), DR(LDDR,*), DWORK(*) INTEGER IWORK(*) C .. Local Scalars DOUBLE PRECISION DRNORM, RCOND C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE C .. External Subroutines .. EXTERNAL DGECON, DGEMM, DGETRF, DTRSM, MA02GD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C INFO = 0 C C Check the scalar input parameters. 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -9 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -11 ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN INFO = -13 ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN INFO = -15 END IF IF( INFO.NE.0 )THEN C C Error return. C CALL XERBLA( 'SB08HD', -INFO ) RETURN END IF C C Quick return if possible. C IF( M.EQ.0 )THEN DWORK(1) = ONE RETURN END IF C C Factor the matrix DR. First, compute the 1-norm. C DRNORM = DLANGE( '1-norm', M, M, DR, LDDR, DWORK ) CALL DGETRF( M, M, DR, LDDR, IWORK, INFO ) IF( INFO.NE.0 ) THEN INFO = 1 DWORK(1) = ZERO RETURN END IF C -1 C Compute B = BQR * DR , using the factorization P*DR = L*U. C CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, M, ONE, $ DR, LDDR, B, LDB ) CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', N, M, ONE, $ DR, LDDR, B, LDB ) CALL MA02GD( N, B, LDB, 1, M, IWORK, -1 ) C -1 C Compute A = AQR - BQR * DR * CR. C CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, -ONE, B, LDB, $ CR, LDCR, ONE, A, LDA ) C -1 C Compute D = DQ * DR . C CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', P, M, ONE, $ DR, LDDR, D, LDD ) CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', P, M, ONE, $ DR, LDDR, D, LDD ) CALL MA02GD( P, D, LDD, 1, M, IWORK, -1 ) C -1 C Compute C = CQ - DQ * DR * CR. C CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, -ONE, D, LDD, $ CR, LDCR, ONE, C, LDC ) C C Estimate the reciprocal condition number of DR. C Workspace 4*M. C CALL DGECON( '1-norm', M, DR, LDDR, DRNORM, RCOND, DWORK, IWORK, $ INFO ) IF( RCOND.LE.DLAMCH( 'Epsilon' ) ) $ INFO = 2 C DWORK(1) = RCOND C RETURN C *** Last line of SB08HD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03VW.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03VW.f0000644000175000017500000006175015012430707017420 0ustar00lilgelilge00000000000000 SUBROUTINE MB03VW( COMPQ, QIND, TRIU, N, K, H, ILO, IHI, S, A, $ LDA1, LDA2, Q, LDQ1, LDQ2, IWORK, LIWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To reduce the generalized matrix product C C S(1) S(2) S(K) C A(:,:,1) * A(:,:,2) * ... * A(:,:,K) C C to upper Hessenberg-triangular form, where A is N-by-N-by-K and S C is the signature array with values 1 or -1. The H-th matrix of A C is reduced to upper Hessenberg form while the other matrices are C triangularized. Unblocked version. C C If COMPQ = 'U' or COMPZ = 'I', then the orthogonal factors are C computed and stored in the array Q so that for S(I) = 1, C T C Q(:,:,I)(in) A(:,:,I)(in) Q(:,:,MOD(I,K)+1)(in) C T (1) C = Q(:,:,I)(out) A(:,:,I)(out) Q(:,:,MOD(I,K)+1)(out) , C C and for S(I) = -1, C T C Q(:,:,MOD(I,K)+1)(in) A(:,:,I)(in) Q(:,:,I)(in) C T (2) C = Q(:,:,MOD(I,K)+1)(out) A(:,:,I)(out) Q(:,:,I)(out) . C C A partial generation of the orthogonal factors can be realized via C the array QIND. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether or not the orthogonal transformations C should be accumulated in the array Q, as follows: C = 'N': do not modify Q; C = 'U': modify (update) the array Q by the orthogonal C transformations that are applied to the matrices in C the array A to reduce them to periodic Hessenberg- C triangular form; C = 'I': like COMPQ = 'U', except that each matrix in the C array Q will be first initialized to the identity C matrix; C = 'P': use the parameters as encoded in QIND. C C QIND INTEGER array, dimension (K) C If COMPQ = 'P', then this array describes the generation C of the orthogonal factors as follows: C If QIND(I) > 0, then the array Q(:,:,QIND(I)) is C modified by the transformations corresponding to the C i-th orthogonal factor in (1) and (2). C If QIND(I) < 0, then the array Q(:,:,-QIND(I)) is C initialized to the identity and modified by the C transformations corresponding to the i-th orthogonal C factor in (1) and (2). C If QIND(I) = 0, then the transformations corresponding C to the i-th orthogonal factor in (1), (2) are not applied. C C TRIU CHARACTER*1 C Indicates how many matrices are reduced to upper C triangular form in the first stage of the algorithm, C as follows C = 'N': only matrices with negative signature; C = 'A': all possible N - 1 matrices. C The first choice minimizes the computational costs of the C algorithm, whereas the second is more cache efficient and C therefore faster on modern architectures. C C Input/Output Parameters C C N (input) INTEGER C The order of each factor in the array A. N >= 0. C C K (input) INTEGER C The number of factors. K >= 0. C C H (input/output) INTEGER C On entry, if H is in the interval [1,K] then the H-th C factor of A will be transformed to upper Hessenberg form. C Otherwise the most efficient H is chosen. C On exit, H indicates the factor of A which is in upper C Hessenberg form. C C ILO (input) INTEGER C IHI (input) INTEGER C It is assumed that each factor in A is already upper C triangular in rows and columns 1:ILO-1 and IHI+1:N. C 1 <= ILO <= IHI <= N, if N > 0; C ILO = 1 and IHI = 0, if N = 0. C If ILO = IHI, all factors are upper triangular. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures of the factors. Each entry in S must be either C 1 or -1. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA1,LDA2,K) C On entry, the leading N-by-N-by-K part of this array must C contain the factors of the general product to be reduced. C On exit, A(:,:,H) is overwritten by an upper Hessenberg C matrix and each A(:,:,I), for I not equal to H, is C overwritten by an upper triangular matrix. C C LDA1 INTEGER C The first leading dimension of the array A. C LDA1 >= MAX(1,N). C C LDA2 INTEGER C The second leading dimension of the array A. C LDA2 >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension C (LDQ1,LDQ2,K) C On entry, if COMPQ = 'U', the leading N-by-N-by-K part C of this array must contain the initial orthogonal factors C as described in (1) and (2). C On entry, if COMPQ = 'P', only parts of the leading C N-by-N-by-K part of this array must contain some C orthogonal factors as described by the parameters QIND. C If COMPQ = 'I', this array should not be set on entry. C On exit, if COMPQ = 'U' or COMPQ = 'I', the leading C N-by-N-by-K part of this array contains the modified C orthogonal factors as described in (1) and (2). C On exit, if COMPQ = 'P', only parts of the leading C N-by-N-by-K part contain some modified orthogonal factors C as described by the parameters QIND. C This array is not referenced if COMPQ = 'N'. C C LDQ1 INTEGER C The first leading dimension of the array Q. LDQ1 >= 1, C and, if COMPQ <> 'N', LDQ1 >= MAX(1,N). C C LDQ2 INTEGER C The second leading dimension of the array Q. LDQ2 >= 1, C and, if COMPQ <> 'N', LDQ2 >= MAX(1,N). C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = -17, IWORK(1) returns the needed C value of LIWORK. C C LIWORK INTEGER C The length of the array IWORK. LIWORK >= MAX(1,3*K). C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK. C On exit, if INFO = -19, DWORK(1) returns the minimum C value of LIWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 1, if MIN(N,K) = 0, or N = 1 or ILO = IHI; C LDWORK >= M+MAX(IHI,N-ILO+1)), otherwise, where C M = IHI-ILO+1. C For optimum performance LDWORK should be larger. C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message 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 CONTRIBUTOR C C V. Sima, Feb. 2022. C Based on an unfinished version of the routine PGGHRD, developed by C D. Kressner, Technical Univ. Chemnitz, Germany, June 1998. C C REVISIONS C C V. Sima, Mar. 2022. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER COMPQ, TRIU INTEGER H, IHI, ILO, INFO, K, LDA1, LDA2, LDQ1, LDQ2, $ LDWORK, LIWORK, N C .. Array Arguments .. INTEGER IWORK(*), QIND(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*), DWORK(LDWORK), Q(LDQ1,LDQ2,*) C .. Local Scalars .. LOGICAL ALLTRI, LCMPQ, LINDQ, LINIQ, LPARQ, LQUERY INTEGER AIND, AINDP, I, I2, I3, IER, INDQ, IWRK, J, L, $ LT, M, MAPA, MAPQ, MAXSET, MINWRK, OPTWRK, POS, $ SMULT, UPIDX, WMAX DOUBLE PRECISION ALPHA, TAU, TEMP C .. Local Arrays .. DOUBLE PRECISION DUM(3) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEQRF, DGERQF, DLACPY, DLARF, DLARFG, $ DLARTG, DLASET, DORGQR, DORMQR, DORMRQ, DROT, $ MB03BA, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN C C .. Executable Statements .. C INFO = 0 LINIQ = LSAME( COMPQ, 'I' ) LCMPQ = LSAME( COMPQ, 'U' ) .OR. LINIQ LPARQ = LSAME( COMPQ, 'P' ) ALLTRI = LSAME( TRIU, 'A' ) LQUERY = LDWORK.EQ.-1 C C Test the input scalar arguments. C IF ( .NOT.LCMPQ .AND. .NOT.LPARQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) $ THEN INFO = -1 ELSE IF ( .NOT.ALLTRI .AND. .NOT.LSAME( TRIU, 'N') ) THEN INFO = -3 ELSE IF ( N.LT.0 ) THEN INFO = -4 ELSE IF ( K.LT.0 ) THEN INFO = -5 ELSE IF ( ILO.LT.1 ) THEN INFO = -7 ELSE IF ( IHI.GT.N .OR. ( N.GT.0 .AND. IHI.LT.ILO ) .OR. $ IHI.LT.0 ) THEN INFO = -8 ELSE IF ( LDA1.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF ( LDA2.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF ( LDQ1.LT.1 .OR. ( ( LCMPQ .OR. LPARQ ) $ .AND. LDQ1.LT.N ) ) THEN INFO = -14 ELSE IF ( LDQ2.LT.1 .OR. ( ( LCMPQ .OR. LPARQ ) $ .AND. LDQ2.LT.N ) ) THEN INFO = -15 ELSE IF ( LIWORK.LT.MAX( 1, 3*K ) ) THEN INFO = -17 IWORK(1) = MAX( 1, 3*K ) ELSE IF ( MIN( N, K ).EQ.0 .OR. N.EQ.1 .OR. ILO.EQ.IHI ) THEN MINWRK = 1 ELSE M = IHI - ILO + 1 MINWRK = M + MAX( IHI, N - ILO + 1 ) END IF OPTWRK = MINWRK IF ( .NOT.LQUERY .AND. LDWORK.LT.MINWRK ) THEN INFO = -19 DWORK(1) = MINWRK ELSE IF ( N.GT.2 ) THEN CALL DGEQRF( M, M, A, LDA1, DUM, DUM(1), -1, IER ) CALL DGERQF( M, M, A, LDA1, DUM, DUM(2), -1, IER ) OPTWRK = MAX( INT( DUM(1) ), INT( DUM(2) ) ) IF ( IHI.LT.N ) THEN CALL DORMQR( 'Left', 'Trans', M, N-IHI, M, A, LDA1, DUM, $ A, LDA1, DUM, -1, IER ) OPTWRK = MAX( OPTWRK, INT( DUM(1) ) ) END IF CALL DORMQR( 'Right', 'NoTran', IHI, M, M, A, LDA1, DUM, A, $ LDA1, DUM, -1, IER ) CALL DORMQR( 'Left', 'Trans', M, N-ILO+1, M, A, LDA1, DUM, $ A, LDA1, DUM(2), -1, IER ) OPTWRK = MAX( OPTWRK, INT( DUM(1) ), INT( DUM(2) ) ) CALL DORMRQ( 'Right', 'Trans', IHI, M, M, A, LDA1, DUM, A, $ LDA1, DUM, -1, IER ) CALL DORMRQ( 'Left', 'NoTran', M, N-ILO+1, M, A, LDA1, DUM, $ A, LDA1, DUM(2), -1, IER ) OPTWRK = MAX( OPTWRK, INT( DUM(1) ), INT( DUM(2) ) ) IF ( LINIQ ) THEN CALL DORGQR( M, M, M, Q, LDQ1, DUM, DUM, -1, IER ) OPTWRK = MAX( OPTWRK, INT( DUM(1) ) ) END IF OPTWRK = MAX( MINWRK, M + OPTWRK ) END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB03VW', -INFO ) RETURN ELSE IF ( LQUERY ) THEN DWORK(1) = OPTWRK RETURN 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 NB refers to the optimal block size for the immediately C following subroutine.) C C Set H, if not in the proper interval. C IF ( K.EQ.0 ) THEN H = 0 ELSE IF ( H.LT.1 .OR. H.GT.K ) THEN H = 1 END IF C C Quick return if possible. C IF ( MIN( N, K ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Initialize Q, if needed. C DO 10 I = 1, K J = 0 IF ( LINIQ ) THEN J = I ELSE IF ( LPARQ ) THEN J = -QIND(I) END IF IF ( J.GT.0 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q(1,1,J), LDQ1 ) 10 CONTINUE C C If all factors are already upper triangular, return. C IF ( ILO.EQ.IHI ) THEN DWORK(1) = ONE RETURN END IF C C Compute maps for accessing A and Q. C MAPA = K MAPQ = 2*K CALL MB03BA( K, H, S, SMULT, IWORK(MAPA+1), IWORK(MAPQ+1) ) C C Compute a certain subset of the set ( i : s(i) = smult ). C DO 20 I = 1, K AIND = IWORK(MAPA+I) IF ( S(AIND).NE.SMULT ) THEN IWORK(AIND) = 0 ELSE IF ( ALLTRI .AND. AIND.NE.H ) THEN IWORK(AIND) = 0 ELSE IWORK(AIND) = 1 END IF 20 CONTINUE C C Find the maximal element in this set. C MAXSET = 0 C DO 30 I = K, 1, -1 AIND = IWORK(MAPA+I) IF ( MAXSET.EQ.0 .AND. IWORK(AIND).EQ.1 ) $ MAXSET = I 30 CONTINUE C C Transform all matrices which are not in the set to upper C triangular form. C I2 = MIN( N, ILO+1 ) I3 = MIN( N, IHI+1 ) IWRK = M + 1 WMAX = LDWORK - M LINDQ = .FALSE. C DO 40 I = K, 1, -1 AIND = IWORK(MAPA+I) C IF ( IWORK(AIND).EQ.0 ) THEN INDQ = IWORK(MAPQ+I) IF ( LPARQ ) THEN INDQ = ABS( QIND(INDQ) ) LINDQ = INDQ.GT.0 END IF AINDP = IWORK(MAPA+I-1) C IF ( S(AIND).EQ.SMULT ) THEN C C Do a QR Decomposition of A_AIND. C C Workspace: need 2*M, M = IHI - ILO + 1; C prefer M + M*NB. C CALL DGEQRF( M, M, A(ILO,ILO,AIND), LDA1, DWORK, $ DWORK(IWRK), WMAX, IER ) C C Update the rows ILO:IHI in columns IHI+1:N of A_AIND. C C Workspace: need M + N-IHI; C prefer M + (N-IHI)*NB. C IF ( IHI.LT.N ) $ CALL DORMQR( 'Left', 'Trans', M, N-IHI, M, $ A(ILO,ILO,AIND), LDA1, DWORK, $ A(ILO,IHI+1,AIND), LDA1, DWORK(IWRK), $ WMAX, IER ) C C Update A_AINDP. C C Workspace: need M + MAX( IHI, N-ILO+1 ); C prefer M + MAX( IHI, N-ILO+1 )*NB. C IF ( S(AINDP).EQ.SMULT ) THEN CALL DORMQR( 'Right', 'NoTran', IHI, M, M, $ A(ILO,ILO,AIND), LDA1, DWORK, $ A(1,ILO,AINDP), LDA1, DWORK(IWRK), WMAX, $ IER ) ELSE CALL DORMQR( 'Left', 'Trans', M, N-ILO+1, M, $ A(ILO,ILO,AIND), LDA1, DWORK, $ A(ILO,ILO,AINDP), LDA1, DWORK(IWRK), $ WMAX, IER ) END IF C C Update the transformation matrix. C IF ( LINIQ ) THEN C C Workspace: need 2*M; C prefer M + M*NB. C CALL DLASET( 'Full', N, ILO-1, ZERO, ONE, Q(1,1,INDQ), $ LDQ1 ) CALL DLASET( 'Full', ILO-1, N-ILO+1, ZERO, ZERO, $ Q(1,ILO,INDQ), LDQ1 ) CALL DLACPY( 'Lower', M-1, M-1, A(I2,ILO,AIND), LDA1, $ Q(I2,ILO,INDQ), LDQ1 ) CALL DORGQR( M, M, M, Q(ILO,ILO,INDQ), LDQ1, DWORK, $ DWORK(IWRK), WMAX, IER ) CALL DLASET( 'Full', N-IHI, IHI, ZERO, ZERO, $ Q(I3,ILO,INDQ), LDQ1 ) CALL DLASET( 'Full', IHI, N-IHI, ZERO, ZERO, $ Q(1,I3,INDQ), LDQ1 ) CALL DLASET( 'Full', N-IHI, N-IHI, ZERO, ONE, $ Q(I3,I3,INDQ), LDQ1 ) ELSE IF ( LCMPQ .OR. LINDQ ) THEN C C Workspace: need M + IHI; C prefer M + IHI*NB. C CALL DORMQR( 'Right', 'NoTran', IHI, M, M, $ A(ILO,ILO,AIND), LDA1, DWORK, $ Q(1,ILO,INDQ), LDQ1, DWORK(IWRK), WMAX, $ IER ) END IF C ELSE C C Do an RQ Decomposition of A_AIND. C C Workspace: need 2*M; C prefer M + M*NB. C CALL DGERQF( M, M, A(ILO,ILO,AIND), LDA1, DWORK, $ DWORK(IWRK), WMAX, IER ) C C Update the rows 1:ILO-1 in columns ILO:IHI of A_AIND. C C Workspace: need M + ILO - 1; C prefer M + (ILO - 1)*NB. C IF ( ILO.GT.1 ) $ CALL DORMRQ( 'Right', 'Trans', ILO-1, M, M, $ A(ILO,ILO,AIND), LDA1, DWORK, $ A(1,ILO,AIND), LDA1, DWORK(IWRK), WMAX, $ IER ) C C Update A_AINDP. C C Workspace: need M + MAX( IHI, N-ILO+1 ); C prefer M + MAX( IHI, N-ILO+1 )*NB. C IF ( S(AINDP).EQ.SMULT ) THEN CALL DORMRQ( 'Right', 'Trans', IHI, M, M, $ A(ILO,ILO,AIND), LDA1, DWORK, $ A(1,ILO,AINDP), LDA1, DWORK(IWRK), WMAX, $ IER ) ELSE CALL DORMRQ( 'Left', 'NoTran', M, N-ILO+1, M, $ A(ILO,ILO,AIND), LDA1, DWORK, $ A(ILO,ILO,AINDP), LDA1, DWORK(IWRK), $ WMAX, IER ) END IF C C Update the transformation matrix. C C Workspace: need M + IHI; C prefer M + IHI*NB. C IF ( LCMPQ .OR. LINDQ ) $ CALL DORMRQ( 'Right', 'Trans', IHI, M, M, $ A(ILO,ILO,AIND), LDA1, DWORK, $ Q(1,ILO,INDQ), LDQ1, DWORK(IWRK), WMAX, $ IER ) END IF C CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, A(I2,ILO,AIND), $ LDA1 ) END IF C 40 CONTINUE C C Reduce A_1 to upper Hessenberg form and the other matrices of the C set to upper triangular form. C DUM(1) = ZERO LINDQ = .FALSE. C DO 120 J = ILO, IHI - 1 C C UPIDX denotes the last remaining nonzero element in the C j-th column. C UPIDX = J C DO 110 LT = K + MAXSET, MAXSET + 1, -1 L = LT IF ( L.GT.K ) $ L = L - K IF ( L.EQ.1 ) $ UPIDX = J + 1 C IF ( UPIDX.LT.N ) THEN AIND = IWORK(MAPA+L) INDQ = IWORK(MAPQ+L) IF ( LPARQ ) THEN INDQ = ABS( QIND(INDQ) ) LINDQ = INDQ.GT.0 END IF IF ( L.LE.1 ) THEN AINDP = IWORK(MAPA+K) ELSE AINDP = IWORK(MAPA+L-1) END IF C IF ( IWORK(AIND).EQ.1 .AND. IWORK(AINDP).EQ.1 ) THEN C C Case 1: AIND and AINDP are in the set. C Annihilate A(UPIDX+1:ihi,j,AIND) with Householder. C CALL DLARFG( IHI-UPIDX+1, A(UPIDX,J,AIND), $ A(UPIDX+1,J,AIND), 1, TAU ) ALPHA = A(UPIDX,J,AIND) A(UPIDX,J,AIND) = ONE C C Update the affected matrices. C C Workspace: need MAX( N - ILO, IHI ), if COMPQ = 'N'; C Workspace: need N, if COMPQ <> 'N'. C CALL DLARF( 'Left', IHI-UPIDX+1, N-J, A(UPIDX,J,AIND), $ 1, TAU, A(UPIDX,J+1,AIND), LDA1, DWORK ) CALL DLARF( 'Right', IHI, N-UPIDX+1, A(UPIDX,J,AIND), $ 1, TAU, A(1,UPIDX,AINDP), LDA1, DWORK ) IF ( LCMPQ .OR. LINDQ ) $ CALL DLARF( 'Right', N, N-UPIDX+1, A(UPIDX,J,AIND), $ 1, TAU, Q(1,UPIDX,INDQ), LDQ1, DWORK ) A(UPIDX,J,AIND) = ALPHA CALL DCOPY( IHI-UPIDX, DUM, 0, A(UPIDX+1,J,AIND), 1 ) C ELSE IF ( IWORK(AIND).EQ.1 ) THEN POS = 1 C C Case 2: AIND is in the set, but AINDP is not. C Annihilate A(UPIDX+1:n,j,AIND) with Givens rotations. C C Workspace: need 2*(M - 1). C DO 50 I = IHI, UPIDX + 1, -1 TEMP = A(I-1,J,AIND) CALL DLARTG( TEMP, A(I,J,AIND), DWORK(POS), $ DWORK(POS+1), A(I-1,J,AIND) ) A(I,J,AIND) = ZERO CALL DROT( N-J, A(I-1,J+1,AIND), LDA1, $ A(I,J+1,AIND), LDA1, DWORK(POS), $ DWORK(POS+1) ) POS = POS + 2 50 CONTINUE C C Update the corresponding transformation matrix. C IF ( LCMPQ .OR. LINDQ ) THEN POS = 1 C DO 60 I = IHI, UPIDX + 1, -1 CALL DROT( N, Q(1,I-1,INDQ), 1, Q(1,I,INDQ), 1, $ DWORK(POS), DWORK(POS+1) ) POS = POS + 2 60 CONTINUE C END IF C ELSE C C Case 3: Neither AIND nor AINDP are in the set. C Propagate rotations over upper triangular matrices. C C Workspace: need 2*(M - 1). C POS = 1 IF ( S(AIND).EQ.SMULT ) THEN C DO 70 I = IHI, UPIDX + 1, -1 CALL DROT( I, A(1,I-1,AIND), 1, A(1,I,AIND), 1, $ DWORK(POS), DWORK(POS+1) ) TEMP = A(I-1,I-1,AIND) CALL DLARTG( TEMP, A(I,I-1,AIND), DWORK(POS), $ DWORK(POS+1), A(I-1,I-1,AIND) ) A(I,I-1,AIND) = ZERO CALL DROT( N-I+1, A(I-1,I,AIND), LDA1, $ A(I,I,AIND), LDA1, DWORK(POS), $ DWORK(POS+1) ) POS = POS + 2 70 CONTINUE C ELSE C DO 80 I = IHI, UPIDX + 1, -1 CALL DROT( N-I+2, A(I-1,I-1,AIND), LDA1, $ A(I,I-1,AIND), LDA1, DWORK(POS), $ DWORK(POS+1) ) TEMP = A(I,I,AIND) C C Use a transposed rotation to get a unified C treatment when applying the transformations. C CALL DLARTG( TEMP, -A(I,I-1,AIND), DWORK(POS), $ DWORK(POS+1), A(I,I,AIND) ) A(I,I-1,AIND) = ZERO CALL DROT( I-1, A(1,I-1,AIND), 1, A(1,I,AIND), $ 1, DWORK(POS), DWORK(POS+1) ) POS = POS + 2 80 CONTINUE C END IF C C Update the corresponding transformation matrix. C IF ( LCMPQ .OR. LINDQ ) THEN POS = 1 C DO 90 I = IHI, UPIDX + 1, -1 CALL DROT( N, Q(1,I-1,INDQ), 1, Q(1,I,INDQ), 1, $ DWORK(POS), DWORK(POS+1) ) POS = POS + 2 90 CONTINUE C END IF C C If AINDP is in the set, then apply all rotations on C this matrix. C IF ( IWORK(AINDP).EQ.1 ) THEN POS = 1 C DO 100 I = IHI, UPIDX + 1, -1 CALL DROT( IHI, A(1,I-1,AINDP), 1, A(1,I,AINDP), $ 1, DWORK(POS), DWORK(POS+1) ) POS = POS + 2 100 CONTINUE C END IF C END IF C END IF C 110 CONTINUE C 120 CONTINUE C DWORK(1) = OPTWRK RETURN C *** Last line of MB03VW *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04ZD.f0000644000000000000000000000013215012430707016175 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04ZD.f0000644000175000017500000004156415012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO $ ) C C PURPOSE C C To transform a Hamiltonian matrix C C ( A G ) C H = ( T ) (1) C ( Q -A ) C C into a square-reduced Hamiltonian matrix C C ( A' G' ) C H' = ( T ) (2) C ( Q' -A' ) C T C by an orthogonal symplectic similarity transformation H' = U H U, C where C ( U1 U2 ) C U = ( ). (3) C ( -U2 U1 ) C T C The square-reduced Hamiltonian matrix satisfies Q'A' - A' Q' = 0, C and C C 2 T 2 ( A'' G'' ) C H' := (U H U) = ( T ). C ( 0 A'' ) C C In addition, A'' is upper Hessenberg and G'' is skew symmetric. C The square roots of the eigenvalues of A'' = A'*A' + G'*Q' are the C eigenvalues of H. C C ARGUMENTS C C Mode Parameters C C COMPU CHARACTER*1 C Indicates whether the orthogonal symplectic similarity C transformation matrix U in (3) is returned or C accumulated into an orthogonal symplectic matrix, or if C the transformation matrix is not required, as follows: C = 'N': U is not required; C = 'I' or 'F': on entry, U need not be set; C on exit, U contains the orthogonal C symplectic matrix U from (3); C = 'V' or 'A': the orthogonal symplectic similarity C transformations are accumulated into U; C on input, U must contain an orthogonal C symplectic matrix S; C on exit, U contains S*U with U from (3). C See the description of U below for details. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, G, and Q. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On input, the leading N-by-N part of this array must C contain the upper left block A of the Hamiltonian matrix H C in (1). C On output, the leading N-by-N part of this array contains C the upper left block A' of the square-reduced Hamiltonian C matrix H' in (2). C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input/output) DOUBLE PRECISION array, dimension C (LDQG,N+1) C On input, the leading N-by-N lower triangular part of this C array must contain the lower triangle of the lower left C symmetric block Q of the Hamiltonian matrix H in (1), and C the N-by-N upper triangular part of the submatrix in the C columns 2 to N+1 of this array must contain the upper C triangle of the upper right symmetric block G of H in (1). C So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j) C and G(i,j) = G(j,i) is stored in QG(j,i+1). C On output, the leading N-by-N lower triangular part of C this array contains the lower triangle of the lower left C symmetric block Q', and the N-by-N upper triangular part C of the submatrix in the columns 2 to N+1 of this array C contains the upper triangle of the upper right symmetric C block G' of the square-reduced Hamiltonian matrix H' C in (2). C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C U (input/output) DOUBLE PRECISION array, dimension (LDU,2*N) C If COMPU = 'N', then this array is not referenced. C If COMPU = 'I' or 'F', then the input contents of this C array are not specified. On output, the leading C N-by-(2*N) part of this array contains the first N rows C of the orthogonal symplectic matrix U in (3). C If COMPU = 'V' or 'A', then, on input, the leading C N-by-(2*N) part of this array must contain the first N C rows of an orthogonal symplectic matrix S. On output, the C leading N-by-(2*N) part of this array contains the first N C rows of the product S*U where U is the orthogonal C symplectic matrix from (3). C The storage scheme implied by (3) is used for orthogonal C symplectic matrices, i.e., only the first N rows are C stored, as they contain all relevant information. C C LDU INTEGER C The leading dimension of the array U. C LDU >= MAX(1,N), if COMPU <> 'N'; C LDU >= 1, if COMPU = 'N'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (2*N) C C Error Indicator C C INFO INTEGER C = 0: successful exit; C < 0: if INFO = -i, then the i-th argument had an illegal C value. C C METHOD C C The Hamiltonian matrix H is transformed into a square-reduced C Hamiltonian matrix H' using the implicit version of Van Loan's C method as proposed in [1,2,3]. C C REFERENCES C C [1] Van Loan, C. F. C A Symplectic Method for Approximating All the Eigenvalues of C a Hamiltonian Matrix. C Linear Algebra and its Applications, 61, pp. 233-251, 1984. C C [2] Byers, R. C Hamiltonian and Symplectic Algorithms for the Algebraic C Riccati Equation. C Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983. C C [3] Benner, P., Byers, R., and Barth, E. C Fortran 77 Subroutines for Computing the Eigenvalues of C Hamiltonian Matrices. I: The Square-Reduced Method. C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. C C NUMERICAL ASPECTS C C This algorithm requires approximately 20*N**3 flops for C transforming H into square-reduced form. If the transformations C are required, this adds another 8*N**3 flops. The method is C strongly backward stable in the sense that if H' and U are the C computed square-reduced Hamiltonian and computed orthogonal C symplectic similarity transformation, then there is an orthogonal C symplectic matrix T and a Hamiltonian matrix M such that C C H T = T M C C || T - U || <= c1 * eps C C || H' - M || <= c2 * eps * || H || C C where c1, c2 are modest constants depending on the dimension N and C eps is the machine precision. C C Eigenvalues computed by explicitly forming the upper Hessenberg C matrix A'' = A'A' + G'Q', with A', G', and Q' as in (2), and C applying the Hessenberg QR iteration to A'' are exactly C eigenvalues of a perturbed Hamiltonian matrix H + E, where C C || E || <= c3 * sqrt(eps) * || H ||, C C and c3 is a modest constant depending on the dimension N and eps C is the machine precision. Moreover, if the norm of H and an C eigenvalue lambda are of roughly the same magnitude, the computed C eigenvalue is essentially as accurate as the computed eigenvalue C from traditional methods. See [1] or [2]. C C CONTRIBUTOR C C P. Benner, Universitaet Bremen, Germany, C R. Byers, University of Kansas, Lawrence, USA, and C E. Barth, Kalamazoo College, Kalamazoo, USA, C Aug. 1998, routine DHASRD. C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Oct. 1998, SLICOT Library version. C C REVISIONS C C May 2001, A. Varga, German Aeropsce Center, DLR Oberpfaffenhofen. C May 2009, V. Sima, Research Institute for Informatics, Bucharest. C C KEYWORDS C C Orthogonal transformation, (square-reduced) Hamiltonian matrix, C symplectic similarity transformation. C C ****************************************************************** C C .. Parameters .. C DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C C .. Scalar Arguments .. INTEGER INFO, LDA, LDQG, LDU, N CHARACTER COMPU C .. C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), U(LDU,*) C .. C .. Local Scalars .. DOUBLE PRECISION COSINE, SINE, TAU, TEMP, X, Y INTEGER J LOGICAL ACCUM, FORGET, FORM C .. C .. Local Arrays .. DOUBLE PRECISION DUMMY(1), T(2,2) C .. C .. External Functions .. DOUBLE PRECISION DDOT LOGICAL LSAME EXTERNAL DDOT, LSAME C .. C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLARFG, DLARFX, DLARTG, $ DROT, DSYMV, DSYR2, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C INFO = 0 ACCUM = LSAME( COMPU, 'A' ) .OR. LSAME( COMPU, 'V' ) FORM = LSAME( COMPU, 'F' ) .OR. LSAME( COMPU, 'I' ) FORGET = LSAME( COMPU, 'N' ) C IF ( .NOT.ACCUM .AND. .NOT.FORM .AND. .NOT.FORGET ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDQG.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDU.LT.1 .OR. ( .NOT.FORGET .AND. LDU.LT.MAX( 1, N ) ) ) $ THEN INFO = -8 END IF C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04ZD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C C Transform to square-reduced form. C DO 10 J = 1, N - 1 C T C DWORK <- (Q*A - A *Q)(J+1:N,J). C CALL DCOPY( J-1, QG(J,1), LDQG, DWORK(N+1), 1 ) CALL DCOPY( N-J+1, QG(J,J), 1, DWORK(N+J), 1 ) CALL DGEMV( 'Transpose', N, N-J, -ONE, A(1,J+1), LDA, $ DWORK(N+1), 1, ZERO, DWORK(J+1), 1 ) CALL DGEMV( 'NoTranspose', N-J, J, ONE, QG(J+1,1), LDQG, $ A(1,J), 1, ONE, DWORK(J+1), 1 ) CALL DSYMV( 'Lower', N-J, ONE, QG(J+1,J+1), LDQG, A(J+1,J), 1, $ ONE, DWORK(J+1), 1 ) C C Symplectic reflection to zero (H*H)((N+J+2):2N,J). C CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU ) Y = DWORK(J+1) DWORK(J+1) = ONE C CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA, $ DWORK(N+1) ) CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA, $ DWORK(N+1) ) C CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG, $ DWORK(N+1) ) CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1), $ 1, ZERO, DWORK(N+J+1), 1 ) CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, $ QG(J+1,J+1), LDQG ) C CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG, $ DWORK(N+1) ) CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1), $ 1, ZERO, DWORK(N+J+1), 1 ) CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, $ QG(J+1,J+2), LDQG ) C IF ( FORM ) THEN C C Save reflection. C CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,J), 1 ) U(J+1,J) = TAU C ELSE IF ( ACCUM ) THEN C C Accumulate reflection. C CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1), $ LDU, DWORK(N+1) ) CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1), $ LDU, DWORK(N+1) ) END IF C C (X,Y) := ((J+1,J),(N+J+1,J)) component of H*H. C X = DDOT( J, QG(1,J+2), 1, QG(J,1), LDQG ) + $ DDOT( N-J, QG(J+1,J+2), LDQG, QG(J+1,J), 1 ) + $ DDOT( N, A(J+1,1), LDA, A(1,J), 1 ) C C Symplectic rotation to zero (H*H)(N+J+1,J). C CALL DLARTG( X, Y, COSINE, SINE, TEMP ) C CALL DROT( J, A(J+1,1), LDA, QG(J+1,1), LDQG, COSINE, SINE ) CALL DROT( J, A(1,J+1), 1, QG(1,J+2), 1, COSINE, SINE ) IF( J.LT.N-1 ) THEN CALL DROT( N-J-1, A(J+1,J+2), LDA, QG(J+2,J+1), 1, $ COSINE, SINE ) CALL DROT( N-J-1, A(J+2,J+1), 1, QG(J+1,J+3), LDQG, $ COSINE, SINE ) END IF C T(1,1) = A(J+1,J+1) T(1,2) = QG(J+1,J+2) T(2,1) = QG(J+1,J+1) T(2,2) = -T(1,1) CALL DROT( 2, T(1,1), 1, T(1,2), 1, COSINE, SINE ) CALL DROT( 2, T(1,1), 2, T(2,1), 2, COSINE, SINE ) A(J+1,J+1) = T(1,1) QG(J+1,J+2) = T(1,2) QG(J+1,J+1) = T(2,1) C IF ( FORM ) THEN C C Save rotation. C U(J,J) = COSINE U(J,N+J) = SINE C ELSE IF ( ACCUM ) THEN C C Accumulate rotation. C CALL DROT( N, U(1,J+1), 1, U(1,N+J+1), 1, COSINE, SINE ) END IF C C DWORK := (A*A + G*Q)(J+1:N,J). C CALL DGEMV( 'NoTranspose', N-J, N, ONE, A(J+1,1), LDA, A(1,J), $ 1, ZERO, DWORK(J+1), 1 ) CALL DGEMV( 'Transpose', J, N-J, ONE, QG(1,J+2), LDQG, QG(J,1), $ LDQG, ONE, DWORK(J+1), 1 ) CALL DSYMV( 'Upper', N-J, ONE, QG(J+1,J+2), LDQG, QG(J+1,J), 1, $ ONE, DWORK(J+1), 1 ) C C Symplectic reflection to zero (H*H)(J+2:N,J). C CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU ) DWORK(J+1) = ONE C CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA, $ DWORK(N+1) ) CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA, $ DWORK(N+1) ) C CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG, $ DWORK(N+1) ) CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1), $ 1, ZERO, DWORK(N+J+1), 1 ) CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, $ QG(J+1,J+1), LDQG ) C CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG, $ DWORK(N+1) ) CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1), $ 1, ZERO, DWORK(N+J+1), 1 ) CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, $ QG(J+1,J+2), LDQG ) C IF ( FORM ) THEN C C Save reflection. C CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,N+J), 1 ) U(J+1,N+J) = TAU C ELSE IF ( ACCUM ) THEN C C Accumulate reflection. C CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1), $ LDU, DWORK(N+1) ) CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1), $ LDU, DWORK(N+1) ) END IF C 10 CONTINUE C IF ( FORM ) THEN DUMMY(1) = ZERO C C Form S by accumulating transformations. C DO 20 J = N - 1, 1, -1 C C Initialize (J+1)st column of S. C CALL DCOPY( N, DUMMY, 0, U(1,J+1), 1 ) U(J+1,J+1) = ONE CALL DCOPY( N, DUMMY, 0, U(1,N+J+1), 1 ) C C Second reflection. C TAU = U(J+1,N+J) U(J+1,N+J) = ONE CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU, $ U(J+1,J+1), LDU, DWORK(N+1) ) CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU, $ U(J+1,N+J+1), LDU, DWORK(N+1) ) C C Rotation. C CALL DROT( N-J, U(J+1,J+1), LDU, U(J+1,N+J+1), LDU, $ U(J,J), U(J,N+J) ) C C First reflection. C TAU = U(J+1,J) U(J+1,J) = ONE CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU, U(J+1,J+1), $ LDU, DWORK(N+1) ) CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU, $ U(J+1,N+J+1), LDU, DWORK(N+1) ) 20 CONTINUE C C The first column is the first column of identity. C CALL DCOPY( N, DUMMY, 0, U, 1 ) U(1,1) = ONE CALL DCOPY( N, DUMMY, 0, U(1,N+1), 1 ) END IF C RETURN C *** Last line of MB04ZD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01YD.f0000644000000000000000000000013215012430707016200 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01YD.f0000644000175000017500000001073015012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE TB01YD( N, M, P, A, LDA, B, LDB, C, LDC, INFO ) C C PURPOSE C C To apply a special similarity transformation to a system given as C a triple (A,B,C), C C A <-- P * A * P, B <-- P * B, C <-- C * P, C C where P is a matrix with 1 on the secondary diagonal, and with 0 C in the other entries. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A, the number of rows of matrix B C and the number of columns of matrix C. C N represents the dimension of the state vector. N >= 0. C C M (input) INTEGER. C The number of columns of matrix B. C M represents the dimension of input vector. M >= 0. C C P (input) INTEGER. C The number of rows of matrix C. 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 system state matrix A. C On exit, the leading N-by-N part of this array contains C the transformed matrix P*A*P. C C LDA INTEGER C The leading dimension of the 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 system input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed matrix P*B. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N) if M > 0. C LDB >= 1 if M = 0. 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 system output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*P. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). 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 rows and/or columns of the matrices of the triplet (A,B,C) C are swapped in a special way. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. C C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. C C KEYWORDS C C Matrix algebra, matrix operations, similarity transformation. C C ********************************************************************* C C .. C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, M, N, P C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) C .. C .. Local Scalars .. INTEGER J, NBY2 C .. C .. External Subroutines .. EXTERNAL DSWAP, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX, MOD C .. C .. Executable Statements .. C C Test the scalar input arguments. C INFO = 0 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -9 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01YD', -INFO ) RETURN END IF C IF( N.LE.1 ) $ RETURN C C Transform the matrix A. C NBY2 = N/2 C DO 10 J = 1, NBY2 CALL DSWAP( N, A( 1, J ), -1, A( 1, N-J+1 ), 1 ) 10 CONTINUE C IF( MOD( N, 2 ).NE.0 .AND. N.GT.2 ) $ CALL DSWAP( NBY2, A( NBY2+2, NBY2+1 ), -1, A( 1, NBY2+1 ), 1 ) C IF( M.GT.0 ) THEN C C Transform the matrix B. C DO 20 J = 1, NBY2 CALL DSWAP( M, B( J, 1 ), LDB, B( N-J+1, 1 ), LDB ) 20 CONTINUE C END IF C IF( P.GT.0 ) THEN C C Transform the matrix C. C DO 30 J = 1, NBY2 CALL DSWAP( P, C( 1, J ), 1, C( 1, N-J+1 ), 1 ) 30 CONTINUE C END IF C RETURN C *** Last line of TB01YD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03BF.f0000644000000000000000000000013215012430707016146 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03BF.f0000644000175000017500000001014215012430707017340 0ustar00lilgelilge00000000000000 SUBROUTINE MB03BF( K, AMAP, S, SINV, A, LDA1, LDA2, ULP ) C C PURPOSE C C To apply at most 20 iterations of a real single shifted C periodic QZ algorithm to the 2-by-2 product of matrices stored C in the array A. The Hessenberg matrix is the last one of the C formal matrix product. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA1,LDA2,K) C On entry, the leading 2-by-2-by-K part of this array must C contain a 2-by-2 product (implicitly represented by its K C factors) in upper Hessenberg form. The Hessenberg matrix C is the last one of the formal matrix product. C On exit, the leading 2-by-2-by-K part of this array C contains the product after at most 20 iterations of a real C shifted periodic QZ algorithm. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= 2. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= 2. C C ULP INTEGER C The machine relation precision. C C METHOD C C Twenty iterations of a real single shifted periodic QZ algorithm C are applied to the 2-by-2 matrix product A. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Dec. 2018. C C REVISIONS C C - C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER K, LDA1, LDA2, SINV DOUBLE PRECISION ULP C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*) C .. Local Scalars .. INTEGER I, L, AI DOUBLE PRECISION CS, CT, SN, ST, TEMP C .. External Subroutines .. EXTERNAL DLARTG, DROT, MB03AF C .. Intrinsic Functions .. INTRINSIC ABS, MAX C C .. Executable Statements .. C DO 20 I = 1, 20 CALL MB03AF( 'Single', K, 2, AMAP, S, SINV, A, LDA1, LDA2, $ CS, SN, CT, ST ) AI = AMAP(K) CALL DROT( 2, A(1,1,AI), 1, A(1,2,AI), 1, CS, SN ) C DO 10 L = 1, K - 1 AI = AMAP(L) IF ( S(AI).EQ.SINV ) THEN CALL DROT( 2, A(1,1,AI), LDA1, A(2,1,AI), LDA1, CS, SN ) TEMP = A(2,2,AI) CALL DLARTG( TEMP, -A(2,1,AI), CS, SN, A(2,2,AI) ) A(2,1,AI) = ZERO TEMP = CS*A(1,1,AI) + SN*A(1,2,AI) A(1,2,AI) = CS*A(1,2,AI) - SN*A(1,1,AI) A(1,1,AI) = TEMP ELSE CALL DROT( 2, A(1,1,AI), 1, A(1,2,AI), 1, CS, SN ) TEMP = A(1,1,AI) CALL DLARTG( TEMP, A(2,1,AI), CS, SN, A(1,1,AI) ) A(2,1,AI) = ZERO TEMP = CS*A(1,2,AI) + SN*A(2,2,AI) A(2,2,AI) = CS*A(2,2,AI) - SN*A(1,2,AI) A(1,2,AI) = TEMP END IF 10 CONTINUE C AI = AMAP(K) CALL DROT( 2, A(1,1,AI), LDA1, A(2,1,AI), LDA1, CS, SN ) C IF ( ABS( A(2,1,AI) ).LT.ULP*( MAX( ABS( A(1,1,AI) ), $ ABS( A(1,2,AI) ), $ ABS( A(2,2,AI) ) ) ) ) $ GO TO 30 20 CONTINUE C 30 CONTINUE C RETURN C *** Last line of MB03BF *** END control-4.1.2/src/slicot/src/PaxHeaders/SB09MD.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB09MD.f0000644000175000017500000001651015012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE SB09MD( N, NC, NB, H1, LDH1, H2, LDH2, SS, LDSS, SE, $ LDSE, PRE, LDPRE, TOL, INFO ) C C PURPOSE C C To compare two multivariable sequences M1(k) and M2(k) for C k = 1,2,...,N, and evaluate their closeness. Each of the C parameters M1(k) and M2(k) is an NC by NB matrix. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The number of parameters. N >= 0. C C NC (input) INTEGER C The number of rows in M1(k) and M2(k). NC >= 0. C C NB (input) INTEGER C The number of columns in M1(k) and M2(k). NB >= 0. C C H1 (input) DOUBLE PRECISION array, dimension (LDH1,N*NB) C The leading NC-by-N*NB part of this array must contain C the multivariable sequence M1(k), where k = 1,2,...,N. C Each parameter M1(k) is an NC-by-NB matrix, whose C (i,j)-th element must be stored in H1(i,(k-1)*NB+j) for C i = 1,2,...,NC and j = 1,2,...,NB. C C LDH1 INTEGER C The leading dimension of array H1. LDH1 >= MAX(1,NC). C C H2 (input) DOUBLE PRECISION array, dimension (LDH2,N*NB) C The leading NC-by-N*NB part of this array must contain C the multivariable sequence M2(k), where k = 1,2,...,N. C Each parameter M2(k) is an NC-by-NB matrix, whose C (i,j)-th element must be stored in H2(i,(k-1)*NB+j) for C i = 1,2,...,NC and j = 1,2,...,NB. C C LDH2 INTEGER C The leading dimension of array H2. LDH2 >= MAX(1,NC). C C SS (output) DOUBLE PRECISION array, dimension (LDSS,NB) C The leading NC-by-NB part of this array contains the C matrix SS. C C LDSS INTEGER C The leading dimension of array SS. LDSS >= MAX(1,NC). C C SE (output) DOUBLE PRECISION array, dimension (LDSE,NB) C The leading NC-by-NB part of this array contains the C quadratic error matrix SE. C C LDSE INTEGER C The leading dimension of array SE. LDSE >= MAX(1,NC). C C PRE (output) DOUBLE PRECISION array, dimension (LDPRE,NB) C The leading NC-by-NB part of this array contains the C percentage relative error matrix PRE. C C LDPRE INTEGER C The leading dimension of array PRE. LDPRE >= MAX(1,NC). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in the computation of the error C matrices SE and PRE. If the user sets TOL to be less than C EPS then the tolerance is taken as EPS, where EPS is the C machine precision (see LAPACK Library routine DLAMCH). 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 (i,j)-th element of the matrix SS is defined by: C N 2 C SS = SUM M1 (k) . (1) C ij k=1 ij C C The (i,j)-th element of the quadratic error matrix SE is defined C by: C N 2 C SE = SUM (M1 (k) - M2 (k)) . (2) C ij k=1 ij ij C C The (i,j)-th element of the percentage relative error matrix PRE C is defined by: C C PRE = 100 x SQRT( SE / SS ). (3) C ij ij ij C C The following precautions are taken by the routine to guard C against underflow and overflow: C C (i) if ABS( M1 (k) ) > 1/TOL or ABS( M1 (k) - M2 (k) ) > 1/TOL, C ij ij ij C C then SE and SS are set to 1/TOL and PRE is set to 1; and C ij ij ij C C (ii) if ABS( SS ) <= TOL, then PRE is set to 100. C ij ij C C NUMERICAL ASPECTS C C The algorithm requires approximately C 2xNBxNCx(N+1) multiplications/divisions, C 4xNBxNCxN additions/subtractions and C NBxNC square roots. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB09AD by S. Van Huffel, Katholieke C University Leuven, Belgium. C C REVISIONS C C - C C KEYWORDS C C Closeness multivariable sequences, elementary matrix operations, C real signals, system response. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HUNDRD PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HUNDRD = 100.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDH1, LDH2, LDPRE, LDSE, LDSS, N, NB, NC DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION H1(LDH1,*), H2(LDH2,*), PRE(LDPRE,*), $ SE(LDSE,*), SS(LDSS,*) C .. Local Scalars .. LOGICAL NOFLOW INTEGER I, J, K DOUBLE PRECISION EPSO, SSE, SSS, TOLER, VAR, VARE C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NC.LT.0 ) THEN INFO = -2 ELSE IF( NB.LT.0 ) THEN INFO = -3 ELSE IF( LDH1.LT.MAX( 1, NC ) ) THEN INFO = -5 ELSE IF( LDH2.LT.MAX( 1, NC ) ) THEN INFO = -7 ELSE IF( LDSS.LT.MAX( 1, NC ) ) THEN INFO = -9 ELSE IF( LDSE.LT.MAX( 1, NC ) ) THEN INFO = -11 ELSE IF( LDPRE.LT.MAX( 1, NC ) ) THEN INFO = -13 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB09MD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. NC.EQ.0 .OR. NB.EQ.0 ) $ RETURN C TOLER = MAX( TOL, DLAMCH( 'Epsilon' ) ) EPSO = ONE/TOLER C DO 60 J = 1, NB C DO 40 I = 1, NC SSE = ZERO SSS = ZERO NOFLOW = .TRUE. K = 0 C C WHILE ( ( NOFLOW .AND. ( K .LT. N*NB ) ) DO 20 IF ( ( NOFLOW ) .AND. ( K.LT.N*NB ) ) THEN VAR = H1(I,K+J) VARE = H2(I,K+J) - VAR IF ( ABS( VAR ).GT.EPSO .OR. ABS( VARE ).GT.EPSO ) $ THEN SE(I,J) = EPSO SS(I,J) = EPSO PRE(I,J) = ONE NOFLOW = .FALSE. ELSE IF ( ABS( VARE ).GT.TOLER ) SSE = SSE + VARE*VARE IF ( ABS( VAR ).GT.TOLER ) SSS = SSS + VAR*VAR K = K + NB END IF GO TO 20 END IF C END WHILE 20 C IF ( NOFLOW ) THEN SE(I,J) = SSE SS(I,J) = SSS PRE(I,J) = HUNDRD IF ( SSS.GT.TOLER ) PRE(I,J) = SQRT( SSE/SSS )*HUNDRD END IF 40 CONTINUE C 60 CONTINUE C RETURN C *** Last line of SB09MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04KD.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04KD.f0000644000175000017500000001550015012430707017353 0ustar00lilgelilge00000000000000 SUBROUTINE MB04KD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, $ TAU, DWORK ) C C PURPOSE C C To calculate a QR factorization of the first block column and C apply the orthogonal transformations (from the left) also to the C second block column of a structured matrix, as follows C _ C [ R 0 ] [ R C ] C Q' * [ ] = [ ] C [ A B ] [ 0 D ] 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 This computation is useful, for instance, in combined measurement C and time update of one iteration of the Kalman filter (square C root information filter). 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 columns of the matrices B, C and D. M >= 0. C C P (input) INTEGER C The number of rows of the matrices A, B and D. 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,N) C On entry, if UPLO = 'F', the leading P-by-N part of this C array must contain the matrix A. If UPLO = 'U', the C leading MIN(P,N)-by-N part of this array must contain the C upper trapezoidal (upper triangular if P >= N) matrix A, C and the elements below the diagonal are not referenced. C On exit, the leading P-by-N part (upper trapezoidal or C triangular, if UPLO = 'U') of this array contains the C trailing components (the vectors v, see Method) of the C elementary reflectors used in the factorization. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,P). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, the leading P-by-M part of this array must C contain the matrix B. C On exit, the leading P-by-M part of this array contains C the computed matrix D. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,P). C C C (output) DOUBLE PRECISION array, dimension (LDC,M) C The leading N-by-M part of this array contains the C computed matrix C. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,N). 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 (N) 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 an min(i,P)-vector, if C i C UPLO = 'U'. The components of v are stored in the i-th column C i C of A, and tau is stored in TAU(i). C i C C NUMERICAL ASPECTS C C The algorithm is backward stable. C C CONTRIBUTORS C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C C REVISIONS C C - C C KEYWORDS C C Elementary reflector, QR 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 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL C .. Intrinsic Functions .. INTRINSIC MIN C .. Executable Statements .. C IF( MIN( N, P ).EQ.0 ) $ RETURN C LUPLO = LSAME( UPLO, 'U' ) IM = P C DO 10 I = 1, N C C Annihilate the I-th column of A and apply the transformations C to the entire block matrix, exploiting its structure. C IF( LUPLO ) IM = MIN( I, P ) CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) IF( TAU(I).NE.ZERO ) THEN C C [ R(I,I+1:N) 0 ] C [ w C(I,:) ] := [ 1 v' ] * [ ] C [ A(1:IM,I+1:N) B(1:IM,:) ] C IF( I.LT.N ) THEN CALL DCOPY( N-I, R(I,I+1), LDR, DWORK, 1 ) CALL DGEMV( 'Transpose', IM, N-I, ONE, A(1,I+1), LDA, $ A(1,I), 1, ONE, DWORK, 1 ) END IF CALL DGEMV( 'Transpose', IM, M, ONE, B, LDB, A(1,I), 1, $ ZERO, C(I,1), LDC ) C C [ R(I,I+1:N) C(I,:) ] [ R(I,I+1:N) 0 ] C [ ] := [ ] C [ A(1:IM,I+1:N) D(1:IM,:) ] [ A(1:IM,I+1:N) B(1:IM,:) ] C C [ 1 ] C - tau * [ ] * [ w C(I,:) ] C [ v ] C IF( I.LT.N ) THEN CALL DAXPY( N-I, -TAU(I), DWORK, 1, R(I,I+1), LDR ) CALL DGER( IM, N-I, -TAU(I), A(1,I), 1, DWORK, 1, $ A(1,I+1), LDA ) END IF CALL DSCAL( M, -TAU(I), C(I,1), LDC ) CALL DGER( IM, M, ONE, A(1,I), 1, C(I,1), LDC, B, LDB ) END IF 10 CONTINUE C RETURN C *** Last line of MB04KD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02XD.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02XD.f0000644000175000017500000003332615012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE MB02XD( FORM, STOR, UPLO, F, M, N, NRHS, IPAR, LIPAR, $ DPAR, LDPAR, A, LDA, B, LDB, ATA, LDATA, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To solve a set of systems of linear equations, A'*A*X = B, or, C in the implicit form, f(A)*X = B, with A'*A or f(A) positive C definite, using symmetric Gaussian elimination. C C ARGUMENTS C C Mode Parameters C C FORM CHARACTER*1 C Specifies the form in which the matrix A is provided, as C follows: C = 'S' : standard form, the matrix A is given; C = 'F' : the implicit, function form f(A) is provided. C If FORM = 'F', then the routine F is called to compute the C matrix A'*A. C C STOR CHARACTER*1 C Specifies the storage scheme for the symmetric C matrix A'*A, as follows: C = 'F' : full storage is used; C = 'P' : packed storage is used. C C UPLO CHARACTER*1 C Specifies which part of the matrix A'*A is stored, as C follows: C = 'U' : the upper triagular part is stored; C = 'L' : the lower triagular part is stored. C C Function Parameters C C F EXTERNAL C If FORM = 'F', then F is a subroutine which calculates the C value of f(A) = A'*A, for given A. C If FORM = 'S', then F is not called. C C F must have the following interface: C C SUBROUTINE F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, C $ LDA, ATA, LDATA, DWORK, LDWORK, INFO ) C C where C C STOR (input) CHARACTER*1 C Specifies the storage scheme for the symmetric C matrix A'*A, as follows: C = 'F' : full storage is used; C = 'P' : packed storage is used. C C UPLO (input) CHARACTER*1 C Specifies which part of the matrix A'*A is stored, C as follows: C = 'U' : the upper triagular part is stored; C = 'L' : the lower triagular part is stored. C C N (input) INTEGER C The order of the matrix A'*A. N >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of C the matrix A. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 0. C C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) C The real parameters needed for solving the C problem. C C LDPAR (input) INTEGER C The length of the array DPAR. LDPAR >= 0. C C A (input) DOUBLE PRECISION array, dimension C (LDA, NC), where NC is the number of columns. C The leading NR-by-NC part of this array must C contain the (compressed) representation of the C matrix A, where NR is the number of rows of A C (function of IPAR entries). C C LDA (input) INTEGER C The leading dimension of the array A. C LDA >= MAX(1,NR). C C ATA (output) DOUBLE PRECISION array, C dimension (LDATA,N), if STOR = 'F', C dimension (N*(N+1)/2), if STOR = 'P'. C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 C (if STOR = 'P') part of this array contains the C upper or lower triangle of the matrix A'*A, C depending on UPLO = 'U', or UPLO = 'L', C respectively, stored either as a two-dimensional, C or one-dimensional array, depending on STOR. C C LDATA (input) INTEGER C The leading dimension of the array ATA. C LDATA >= MAX(1,N), if STOR = 'F'. C LDATA >= 1, if STOR = 'P'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C The workspace array for subroutine F. C C LDWORK (input) INTEGER C The size of the array DWORK (as large as needed C in the subroutine F). C C INFO INTEGER C Error indicator, set to a negative value if an C input scalar argument is erroneous, and to C positive values for other possible errors in the C subroutine F. The LAPACK Library routine XERBLA C should be used in conjunction with negative INFO. C INFO must be zero if the subroutine finished C successfully. C C Parameters marked with "(input)" must not be changed. 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 order of the matrix A'*A, the number of columns of the C matrix A, and the number of rows of the matrix X. N >= 0. C C NRHS (input) INTEGER C The number of columns of the matrices B and X. NRHS >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C If FORM = 'F', the integer parameters describing the C structure of the matrix A. C This parameter is ignored if FORM = 'S'. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 0. C C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) C If FORM = 'F', the real parameters needed for solving C the problem. C This parameter is ignored if FORM = 'S'. C C LDPAR (input) INTEGER C The length of the array DPAR. LDPAR >= 0. C C A (input) DOUBLE PRECISION array, C dimension (LDA, N), if FORM = 'S', C dimension (LDA, NC), if FORM = 'F', where NC is C the number of columns. C If FORM = 'S', the leading M-by-N part of this array C must contain the matrix A. C If FORM = 'F', the leading NR-by-NC part of this array C must contain an appropriate representation of matrix A, C where NR is the number of rows. C If FORM = 'F', this array is not referenced by this C routine itself, except in the call to the routine F. C C LDA INTEGER C The leading dimension of array A. C LDA >= MAX(1,M), if FORM = 'S'; C LDA >= MAX(1,NR), if FORM = 'F'. C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, NRHS) C On entry, the leading N-by-NRHS part of this array must C contain the right hand side matrix B. C On exit, if INFO = 0 and M (or NR) is nonzero, the leading C N-by-NRHS part of this array contains the solution X of C the set of systems of linear equations A'*A*X = B or C f(A)*X = B. If M (or NR) is zero, then B is unchanged. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C ATA (output) DOUBLE PRECISION array, C dimension (LDATA,N), if STOR = 'F', C dimension (N*(N+1)/2), if STOR = 'P'. C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if C STOR = 'P') part of this array contains the upper or lower C triangular Cholesky factor of the matrix A'*A, depending C on UPLO = 'U', or UPLO = 'L', respectively, stored either C as a two-dimensional, or one-dimensional array, depending C on STOR. C C LDATA INTEGER C The leading dimension of the array ATA. C LDATA >= MAX(1,N), if STOR = 'F'. C LDATA >= 1, if STOR = 'P'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. 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, then the (i,i) element of the C triangular factor of the matrix A'*A is exactly C zero (the matrix A'*A is exactly singular); C if INFO = j > n, then F returned with INFO = j-n. C C METHOD C C The matrix A'*A is built either directly (if FORM = 'S'), or C implicitly, by calling the routine F. Then, A'*A is Cholesky C factored and its factor is used to solve the set of systems of C linear equations, A'*A*X = B. C C REFERENCES C C [1] Golub, G.H. and van Loan, C.F. C Matrix Computations. Third Edition. C M. D. Johns Hopkins University Press, Baltimore, 1996. C C [2] Anderson, E., Bai, Z., Bischof, C., Blackford, Demmel, J., C Dongarra, J., Du Croz, J., Greenbaum, A., Hammarling, S., C McKenney, A., Sorensen, D. C LAPACK Users' Guide: Third Edition, SIAM, Philadelphia, 1999. C C NUMERICAL ASPECTS C C For speed, this routine does not check for near singularity of the C matrix A'*A. If the matrix A is nearly rank deficient, then the C computed X could be inaccurate. Estimates of the reciprocal C condition numbers of the matrices A and A'*A can be obtained C using LAPACK routines DGECON and DPOCON (DPPCON), respectively. C C The approximate number of floating point operations is C (M+3)*N**2/2 + N**3/6 + NRHS*N**2, if FORM = 'S', C f + N**3/6 + NRHS*N**2, if FORM = 'F', C where M is the number of rows of A, and f is the number of C floating point operations required by the subroutine F. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. C C REVISIONS C C V. Sima, Mar. 2002. C C KEYWORDS C C Linear system of equations, matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER FORM, STOR, UPLO INTEGER INFO, LDA, LDATA, LDB, LDPAR, LDWORK, LIPAR, M, $ N, NRHS C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), ATA(*), B(LDB,*), DPAR(*), DWORK(*) INTEGER IPAR(*) C .. Local Scalars .. INTEGER IERR, J, J1 LOGICAL FULL, MAT, UPPER C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEMV, DPOTRF, DPOTRS, DPPTRF, DPPTRS, DSYRK, F, $ XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Decode the scalar input parameters. C MAT = LSAME( FORM, 'S' ) FULL = LSAME( STOR, 'F' ) UPPER = LSAME( UPLO, 'U' ) C C Check the scalar input parameters. C INFO = 0 IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN INFO = -1 ELSEIF ( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN INFO = -2 ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -3 ELSEIF ( M.LT.0 ) THEN INFO = -5 ELSEIF ( N.LT.0 ) THEN INFO = -6 ELSEIF ( NRHS.LT.0 ) THEN INFO = -7 ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN INFO = -9 ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN INFO = -11 ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.M ) ) THEN INFO = -13 ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN INFO = -15 ELSEIF ( LDATA.LT.1 .OR. ( FULL .AND. LDATA.LT.N ) ) THEN INFO = -17 ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02XD', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( N.EQ.0 .OR. ( MAT .AND. M.EQ.0 ) ) $ RETURN C C Build a triangle of the matrix A'*A. C IF ( MAT ) THEN C C Matrix A is given in the usual form. C IF ( FULL ) THEN CALL DSYRK( UPLO, 'Transpose', N, M, ONE, A, LDA, ZERO, $ ATA, LDATA ) ELSEIF ( UPPER ) THEN J1 = 1 C DO 10 J = 1, N CALL DGEMV( 'Transpose', M, J, ONE, A, LDA, A(1,J), 1, $ ZERO, ATA(J1), 1 ) J1 = J1 + J 10 CONTINUE C ELSE J1 = 1 C DO 20 J = 1, N CALL DGEMV( 'Transpose', M, N-J+1, ONE, A(1,J), LDA, $ A(1,J), 1, ZERO, ATA(J1), 1 ) J1 = J1 + N - J + 1 20 CONTINUE C ENDIF C ELSE C C Implicit form, A'*A = f(A). C CALL F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, ATA, $ LDATA, DWORK, LDWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = N + IERR RETURN ENDIF C ENDIF C C Factor the matrix A'*A. C IF ( FULL ) THEN CALL DPOTRF( UPLO, N, ATA, LDATA, IERR ) ELSE CALL DPPTRF( UPLO, N, ATA, IERR ) ENDIF C IF ( IERR.NE.0 ) THEN INFO = IERR RETURN ENDIF C C Solve the set of linear systems. C IF ( FULL ) THEN CALL DPOTRS( UPLO, N, NRHS, ATA, LDATA, B, LDB, IERR ) ELSE CALL DPPTRS( UPLO, N, NRHS, ATA, B, LDB, IERR ) ENDIF C C *** Last line of MB02XD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03YD.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03YD.f0000644000175000017500000004300615012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE MB03YD( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILOQ, IHIQ, $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, $ BETA, DWORK, LDWORK, INFO ) C C PURPOSE C C To deal with small subtasks of the product eigenvalue problem. C C MB03YD is an auxiliary routine called by SLICOT Library routine C MB03XP. C C ARGUMENTS C C Mode Parameters C C WANTT LOGICAL C Indicates whether the user wishes to compute the full C Schur form or the eigenvalues only, as follows: C = .TRUE. : Compute the full Schur form; C = .FALSE.: compute the eigenvalues only. C C WANTQ LOGICAL C Indicates whether or not the user wishes to accumulate C the matrix Q as follows: C = .TRUE. : The matrix Q is updated; C = .FALSE.: the matrix Q is not required. C C WANTZ LOGICAL C Indicates whether or not the user wishes to accumulate C the matrix Z as follows: C = .TRUE. : The matrix Z is updated; C = .FALSE.: the matrix Z is not required. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and B. N >= 0. C C ILO (input) INTEGER C IHI (input) INTEGER C It is assumed that the matrices A and B are already C (quasi) upper triangular in rows and columns 1:ILO-1 and C IHI+1:N. The routine works primarily with the submatrices C in rows and columns ILO to IHI, but applies the C transformations to all the rows and columns of the C matrices A and B, if WANTT = .TRUE.. C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. C C ILOQ (input) INTEGER C IHIQ (input) INTEGER C Specify the rows of Q and Z to which transformations C must be applied if WANTQ = .TRUE. and WANTZ = .TRUE., C respectively. C 1 <= ILOQ <= ILO; IHI <= IHIQ <= 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 Hessenberg matrix A. C On exit, if WANTT = .TRUE., the leading N-by-N part of C this array is upper quasi-triangular in rows and columns C ILO:IHI. C If WANTT = .FALSE., the diagonal elements and 2-by-2 C diagonal blocks of A will be correct, but the remaining C parts of A are unspecified on exit. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) C On entry, the leading N-by-N part of this array must C contain the upper triangular matrix B. C On exit, if WANTT = .TRUE., the leading N-by-N part of C this array contains the transformed upper triangular C matrix. 2-by-2 blocks in B corresponding to 2-by-2 blocks C in A will be reduced to positive diagonal form. (I.e., if C A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) C and B(j+1,j+1) will be positive.) C If WANTT = .FALSE., the elements corresponding to diagonal C elements and 2-by-2 diagonal blocks in A will be correct, C but the remaining parts of B are unspecified on exit. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, if WANTQ = .TRUE., then the leading N-by-N part C of this array must contain the current matrix Q of C transformations accumulated by MB03XP. C On exit, if WANTQ = .TRUE., then the leading N-by-N part C of this array contains the matrix Q updated in the C submatrix Q(ILOQ:IHIQ,ILO:IHI). C If WANTQ = .FALSE., Q is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= 1. C If WANTQ = .TRUE., LDQ >= MAX(1,N). C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C On entry, if WANTZ = .TRUE., then the leading N-by-N part C of this array must contain the current matrix Z of C transformations accumulated by MB03XP. C On exit, if WANTZ = .TRUE., then the leading N-by-N part C of this array contains the matrix Z updated in the C submatrix Z(ILOQ:IHIQ,ILO:IHI). C If WANTZ = .FALSE., Z is not referenced. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= 1. C If WANTZ = .TRUE., LDZ >= MAX(1,N). 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 The i-th (ILO <= i <= IHI) computed eigenvalue is given C by BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two C eigenvalues are computed as a complex conjugate pair, C they are stored in consecutive elements of ALPHAR, ALPHAI C and BETA. If WANTT = .TRUE., the eigenvalues are stored in C the same order as on the diagonals of the Schur forms of C A and B. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = -19, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,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 > 0: if INFO = i, then MB03YD failed to compute the Schur C form in a total of 30*(IHI-ILO+1) iterations; C elements i+1:n of ALPHAR, ALPHAI and BETA contain C successfully computed eigenvalues. C C METHOD C C The implemented algorithm is a double-shift version of the C periodic QR algorithm described in [1,3] with some minor C modifications [2]. The eigenvalues are computed via an implicit C complex single shift algorithm. C C REFERENCES C C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. C The periodic Schur decomposition: Algorithms and applications. C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, C 1992. C C [2] Kressner, D. C An efficient and reliable implementation of the periodic QZ C algorithm. Proc. of the IFAC Workshop on Periodic Control C Systems, pp. 187-192, 2001. C C [3] Van Loan, C. C Generalized Singular Values with Algorithms and Applications. C Ph. D. Thesis, University of Michigan, 1973. C C NUMERICAL ASPECTS C C The algorithm requires O(N**3) floating point operations and is C backward stable. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPQR). C C KEYWORDS C C Eigenvalue, eigenvalue decomposition, Hessenberg form, orthogonal C transformation, (periodic) Schur form C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. Scalar Arguments .. LOGICAL WANTQ, WANTT, WANTZ INTEGER IHI, IHIQ, ILO, ILOQ, INFO, LDA, LDB, LDQ, $ LDWORK, LDZ, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), $ BETA(*), DWORK(*), Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. INTEGER I, I1, I2, ITN, ITS, K, KK, L, NH, NQ, NR DOUBLE PRECISION ALPHA, BETAX, CS1, CS2, CS3, DELTA, GAMMA, $ OVFL, SMLNUM, SN1, SN2, SN3, TAUV, TAUW, $ TEMP, TST, ULP, UNFL C .. Local Arrays .. INTEGER ISEED(4) DOUBLE PRECISION V(3), W(3) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS C .. External Subroutines .. EXTERNAL DCOPY, DLABAD, DLARFG, DLARFX, DLARNV, DLARTG, $ DROT, MB03YA, MB03YT, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 NH = IHI - ILO + 1 NQ = IHIQ - ILOQ + 1 IF ( N.LT.0 ) THEN INFO = -4 ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF ( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -6 ELSE IF ( ILOQ.LT.1 .OR. ILOQ.GT.ILO ) THEN INFO = -7 ELSE IF ( IHIQ.LT.IHI .OR. IHIQ.GT.N ) THEN INFO = -8 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN INFO = -14 ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN INFO = -16 ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN DWORK(1) = DBLE( MAX( 1, N ) ) INFO = -21 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03YD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C C Set machine-dependent constants for the stopping criterion. C UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( NH / ULP ) C C I1 and I2 are the indices of the first rows and last columns of C A and B to which transformations must be applied. C I1 = 1 I2 = N ISEED(1) = 1 ISEED(2) = 0 ISEED(3) = 0 ISEED(4) = 1 C C ITN is the maximal number of QR iterations. C ITN = 30*NH C C Main loop. Eigenvalues I+1:IHI have converged. Either L = ILO C or A(L,L-1) is negligible. C I = IHI 10 CONTINUE L = ILO IF ( I.LT.ILO ) $ GO TO 120 C C Perform periodic QR iteration on rows and columns ILO to I of A C and B until a submatrix of order 1 or 2 splits off at the bottom. C DO 70 ITS = 0, ITN C C Look for deflations in A. C DO 20 K = I, L + 1, -1 TST = ABS( A(K-1,K-1) ) + ABS( A(K,K) ) IF ( TST.EQ.ZERO ) $ TST = DLANHS( '1', I-L+1, A(L,L), LDA, DWORK ) IF ( ABS( A(K,K-1) ).LE.MAX( ULP*TST, SMLNUM ) ) $ GO TO 30 20 CONTINUE 30 CONTINUE C C Look for deflation in B if problem size is greater than 1. C IF ( I-K.GE.1 ) THEN DO 40 KK = I, K, -1 IF ( KK.EQ.I ) THEN TST = ABS( B(KK-1,KK) ) ELSE IF ( KK.EQ.K ) THEN TST = ABS( B(KK,KK+1) ) ELSE TST = ABS( B(KK-1,KK) ) + ABS( B(KK,KK+1) ) END IF IF ( TST.EQ.ZERO ) $ TST = DLANHS( '1', I-K+1, B(K,K), LDB, DWORK ) IF ( ABS( B(KK,KK) ).LE.MAX( ULP*TST, SMLNUM ) ) $ GO TO 50 40 CONTINUE ELSE KK = K-1 END IF 50 CONTINUE IF ( KK.GE.K ) THEN C C B has an element close to zero at position (KK,KK). C B(KK,KK) = ZERO CALL MB03YA( WANTT, WANTQ, WANTZ, N, K, I, ILOQ, IHIQ, KK, $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) K = KK+1 END IF L = K IF( L.GT.ILO ) THEN C C A(L,L-1) is negligible. C A(L,L-1) = ZERO END IF C C Exit from loop if a submatrix of order 1 or 2 has split off. C IF ( L.GE.I-1 ) $ GO TO 80 C C The active submatrices are now in rows and columns L:I. C IF ( .NOT.WANTT ) THEN I1 = L I2 = I END IF IF ( ITS.EQ.10.OR.ITS.EQ.20 ) THEN C C Exceptional shift. The first column of the shift polynomial C is a pseudo-random vector. C CALL DLARNV( 3, ISEED, 3, V ) ELSE C C The implicit double shift is constructed via a partial C product QR factorization [2]. C CALL DLARTG( B(L,L), B(I,I), CS2, SN2, TEMP ) CALL DLARTG( TEMP, B(I-1,I), CS1, SN1, ALPHA ) C ALPHA = A(L,L)*CS2 - A(I,I)*SN2 BETAX = CS1*( CS2*A(L+1,L) ) GAMMA = CS1*( SN2*A(I-1,I) ) + SN1*A(I-1,I-1) ALPHA = ALPHA*CS1 - A(I,I-1)*SN1 CALL DLARTG( ALPHA, BETAX, CS1, SN1, TEMP ) C CALL DLARTG( TEMP, GAMMA, CS2, SN2, ALPHA ) ALPHA = CS2 GAMMA = ( A(I-1,I-1)*CS1 )*CS2 + A(I,I-1)*SN2 DELTA = ( A(I-1,I-1)*SN1 )*CS2 CALL DLARTG( GAMMA, DELTA, CS3, SN3, TEMP ) CALL DLARTG( ALPHA, TEMP, CS2, SN2, ALPHA ) C ALPHA = ( B(L,L)*CS1 + B(L,L+1)*SN1 )*CS2 BETAX = ( B(L+1,L+1)*SN1 )*CS2 GAMMA = B(I-1,I-1)*SN2 CALL DLARTG( ALPHA, BETAX, CS1, SN1, TEMP ) CALL DLARTG( TEMP, GAMMA, CS2, SN2, ALPHA ) C ALPHA = CS1*A(L,L) + SN1*A(L,L+1) BETAX = CS1*A(L+1,L) + SN1*A(L+1,L+1) GAMMA = SN1*A(L+2,L+1) C V(1) = CS2*ALPHA - SN2*CS3 V(2) = CS2*BETAX - SN2*SN3 V(3) = GAMMA*CS2 END IF C C Double-shift QR step C DO 60 K = L, I-1 C NR = MIN( 3,I-K+1 ) IF ( K.GT.L ) $ CALL DCOPY( NR, A(K,K-1), 1, V, 1 ) CALL DLARFG( NR, V(1), V(2), 1, TAUV ) IF ( K.GT.L ) THEN A(K,K-1) = V(1) A(K+1,K-1) = ZERO IF ( K.LT.I-1 ) $ A(K+2,K-1) = ZERO END IF C C Apply reflector V from the right to B in rows I1:min(K+2,I). C V(1) = ONE CALL DLARFX( 'Right', MIN(K+2,I)-I1+1, NR, V, TAUV, B(I1,K), $ LDB, DWORK ) C C Annihilate the introduced nonzeros in the K-th column. C CALL DCOPY( NR, B(K,K), 1, W, 1 ) CALL DLARFG( NR, W(1), W(2), 1, TAUW ) B(K,K) = W(1) B(K+1,K) = ZERO IF ( K.LT.I-1 ) $ B(K+2,K) = ZERO C C Apply reflector W from the left to transform the rows of the C matrix B in columns K+1:I2. C W(1) = ONE CALL DLARFX( 'Left', NR, I2-K, W, TAUW, B(K,K+1), LDB, $ DWORK ) C C Apply reflector V from the left to transform the rows of the C matrix A in columns K:I2. C CALL DLARFX( 'Left', NR, I2-K+1, V, TAUV, A(K,K), LDA, $ DWORK ) C C Apply reflector W from the right to transform the columns of C the matrix A in rows I1:min(K+3,I). C CALL DLARFX( 'Right', MIN(K+3,I)-I1+1, NR, W, TAUW, A(I1,K), $ LDA, DWORK ) C C Accumulate transformations in the matrices Q and Z. C IF ( WANTQ ) $ CALL DLARFX( 'Right', NQ, NR, V, TAUV, Q(ILOQ,K), LDQ, $ DWORK ) IF ( WANTZ ) $ CALL DLARFX( 'Right', NQ, NR, W, TAUW, Z(ILOQ,K), LDZ, $ DWORK ) 60 CONTINUE 70 CONTINUE C C Failure to converge. C INFO = I RETURN C 80 CONTINUE C C Compute 1-by-1 or 2-by-2 subproblem. C IF ( L.EQ.I ) THEN C C Standardize B, set ALPHAR, ALPHAI and BETA. C IF ( B(I,I).LT.ZERO ) THEN IF ( WANTT ) THEN DO 90 K = I1, I B(K,I) = -B(K,I) 90 CONTINUE DO 100 K = I, I2 A(I,K) = -A(I,K) 100 CONTINUE ELSE B(I,I) = -B(I,I) A(I,I) = -A(I,I) END IF IF ( WANTQ ) THEN DO 110 K = ILOQ, IHIQ Q(K,I) = -Q(K,I) 110 CONTINUE END IF END IF ALPHAR(I) = A(I,I) ALPHAI(I) = ZERO BETA(I) = B(I,I) ELSE IF( L.EQ.I-1 ) THEN C C A double block has converged. C Compute eigenvalues and standardize double block. C CALL MB03YT( A(I-1,I-1), LDA, B(I-1,I-1), LDB, ALPHAR(I-1), $ ALPHAI(I-1), BETA(I-1), CS1, SN1, CS2, SN2 ) C C Apply transformation to rest of A and B. C IF ( I2.GT.I ) $ CALL DROT( I2-I, A(I-1,I+1), LDA, A(I,I+1), LDA, CS1, SN1 ) CALL DROT( I-I1-1, A(I1,I-1), 1, A(I1,I), 1, CS2, SN2 ) IF ( I2.GT.I ) $ CALL DROT( I2-I, B(I-1,I+1), LDB, B(I,I+1), LDB, CS2, SN2 ) CALL DROT( I-I1-1, B(I1,I-1), 1, B(I1,I), 1, CS1, SN1 ) C C Apply transformation to rest of Q and Z if desired. C IF ( WANTQ ) $ CALL DROT( NQ, Q(ILOQ,I-1), 1, Q(ILOQ,I), 1, CS1, SN1 ) IF ( WANTZ ) $ CALL DROT( NQ, Z(ILOQ,I-1), 1, Z(ILOQ,I), 1, CS2, SN2 ) END IF C C Decrement number of remaining iterations, and return to start of C the main loop with new value of I. C ITN = ITN - ITS I = L - 1 GO TO 10 C 120 CONTINUE DWORK(1) = DBLE( MAX( 1, N ) ) RETURN C *** Last line of MB03YD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01HU.f0000644000000000000000000000013215012430707016205 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01HU.f0000644000175000017500000007220715012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE TG01HU( COMPQ, COMPZ, L, N, M1, M2, P, N1, LBE, A, LDA, $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, $ NRBLCK, RTAU, TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C Given the descriptor system (A-lambda*E,B,C) with the system C matrices A, E and B of the form C C ( A1 X1 ) ( E1 Y1 ) ( B1 B2 ) C A = ( ) , E = ( ) , B = ( ) , C ( 0 X2 ) ( 0 Y2 ) ( 0 0 ) C C where C - B is an L-by-(M1+M2) matrix, C with B1 an N1-by-M1 submatrix, B2 an N1-by-M2 submatrix, C - A is an L-by-N matrix, with A1 an N1-by-N1 submatrix, C - E is an L-by-N matrix, with E1 an N1-by-N1 submatrix C with LBE nonzero sub-diagonals, C this routine reduces the pair (A1-lambda*E1,[B1 B2]) to the form C C Qc'*[B1 B2 A1-lambda*E1 ]*diag(I,Zc) = C C ( Bc1 Bc2 Ac-lambda*Ec * ) C ( ) , C ( 0 0 0 Anc-lambda*Enc ) C C where: C 1) the pencil ( Bc1 Bc2 Ac-lambda*Ec ) has full row rank NR for C all finite lambda and is in a staircase form with C C [ A11 A12 . . . A1,p-2 A1,p-1 A1p ] C [ A21 A22 . . . A2,p-2 A2,p-1 A2p ] C [ A31 A32 . . . A3,p-2 A3,p-1 A3p ] C [ 0 A42 . . . A4,p-2 A4,p-1 A4p ] C Ac = [ . . . . . . . . ], (1) C [ . . . . . . . ] C [ . . . . . . ] C [ 0 0 . . . Ap,p-2 Ap,p-1 App ] C C C [ A1,-1 A1,0 ] C [ 0 A2,0 ] C [ 0 0 ] ( E11 E12 ... E1p ) C [ 0 0 ] ( 0 E22 ... E2p ) C [Bc1 Bc2] = [ . . ], Ec = ( . . . . ), C [ . . ] ( . . . . ) C [ . . ] ( 0 0 ... Epp ) C [ 0 0 ] C C where the block Ai,i-2 is an rtau(i)-by-rtau(i-2) full row C rank matrix (with rtau(-1) = M1, rtau(0) = M2) and Ei,i is an C rtau(i)-by-rtau(i) upper triangular matrix. C C 2) the pencil Anc-lambda*Enc is regular of order N1-NR with Enc C upper triangular; this pencil contains the uncontrollable C finite eigenvalues of the pencil (A1-lambda*E1). C C The transformations are applied to the whole matrices A, E, B C and C. The left and/or right orthogonal transformations Qc and Zc, C performed to reduce the pencil, can be optionally accumulated in C the matrices Q and Z, respectively. C C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has no C uncontrollable finite eigenvalues and has the same transfer- C function matrix as the original system (A-lambda*E,B,C). C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C = 'N': do not compute Q; C = 'I': Q is initialized to the unit matrix, and the C orthogonal matrix Q is returned; C = 'U': Q must contain an orthogonal matrix Q1 on entry, C and the product Q1*Q is returned. C C COMPZ CHARACTER*1 C = 'N': do not compute Z; C = 'I': Z is initialized to the unit matrix, and the C orthogonal matrix Z is returned; C = 'U': Z must contain an orthogonal matrix Z1 on entry, C and the product Z1*Z is returned. C C Input/Output Parameters C C L (input) INTEGER C The number of descriptor state equations; also the number C of rows of the matrices A, E and B. L >= 0. C C N (input) INTEGER C The dimension of the descriptor state vector; also the C number of columns of the matrices A, E and C. N >= 0. C C M1 (input) INTEGER C The number of system inputs in U1, or of columns of B1. C M1 >= 0. C C M2 (input) INTEGER C The number of system inputs in U2, or of columns of B2. C M2 >= 0. C C P (input) INTEGER C The dimension of descriptor system output; also the C number of rows of the matrix C. P >= 0. C C N1 (input) INTEGER C The order of the subsystem (A1-lambda*E1,B1,C1) to be C reduced. MIN(L,N) >= N1 >= 0. C C LBE (input) INTEGER C The number of nonzero sub-diagonals of the submatrix E1. C MAX(0,N1-1) >= LBE >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the L-by-N state matrix A in the partitioned form C C ( A1 X1 ) C A = ( ) , C ( 0 X2 ) C C where A1 is N1-by-N1. C On exit, the leading L-by-N part of this array contains C the transformed state matrix, C C ( Ac * * ) C Qc'*A*diag(Zc,I) = ( 0 Anc * ) , C ( 0 0 * ) C C where Ac is NR-by-NR and Anc is (N1-NR)-by-(N1-NR). C The matrix ( Bc Ac ) is in the controllability staircase C form (1). C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,L). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the L-by-N descriptor matrix E in the partitioned C form C ( E1 Y1 ) C E = ( ) , C ( 0 Y2 ) C C where E1 is an N1-by-N1 matrix with LBE nonzero C sub-diagonals. C On exit, the leading L-by-N part of this array contains C the transformed descriptor matrix C C ( Ec * * ) C Qc'*E*diag(Zc,I) = ( 0 Enc * ) , C ( 0 0 * ) C C where Ec is NR-by-NR and Enc is (N1-NR)-by-(N1-NR). C Both Ec and Enc are upper triangular and Enc is C nonsingular. C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,L). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) C with M = M1 + M2. C On entry, the leading L-by-M part of this array must C contain the L-by-M input matrix B in the partitioned form C C ( Bi ) C B = ( ) , C ( 0 ) C C where Bi is N1-by-M. C On exit, the leading L-by-M part of this array contains C the transformed input matrix C C ( Bc ) C Qc'*B = ( ) , C ( 0 ) C C where Bc is NR-by-M. C The matrix ( Bc Ac ) is in the controllability staircase C form (1). C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,L). 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Zc. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) C If COMPQ = 'N': Q is not referenced. C If COMPQ = 'I': on entry, Q need not be set; C on exit, the leading L-by-L part of this C array contains the orthogonal matrix Qc, C where Qc' is the product of the C transformations applied to A, E, and B on C the left. C If COMPQ = 'U': on entry, the leading L-by-L part of this C array must contain an orthogonal matrix Q; C on exit, the leading L-by-L part of this C array contains the orthogonal matrix C Q*Qc. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1,L), if COMPQ = 'I' or 'U'. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C If COMPZ = 'N': Z is not referenced. C If COMPZ = 'I': on entry, Z need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Zc, C i.e., the product of the transformations C applied to A, E, and C on the right. C If COMPZ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix Z; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Z*Zc. C C LDZ INTEGER C The leading dimension of the array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= MAX(1,N), if COMPZ = 'I' or 'U'. C C NR (output) INTEGER C The order of the reduced matrices Ac and Ec, and the C number of rows of the reduced matrix Bc; also the order of C the controllable part of the pair (B, A-lambda*E). C C NRBLCK (output) INTEGER C The number p, of full row rank blocks Ai,i-2 in the C staircase form of the pencil (Bc1 Bc2 Ac-lambda*Ec). C C RTAU (output) INTEGER array, dimension (2*N1) C The leading NRBLCK elements of this array contain the C orders of the diagonal blocks of Ac. NRBLCK is always C an even number, and the NRBLCK/2 odd and even components C of RTAU have decreasing values, respectively. C Note that some elements of RTAU can be zero. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determinations when C transforming (A-lambda*E, B). If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C reciprocal condition numbers in rank determinations; a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = L*N*EPS, is used instead, where C EPS is the machine precision (see LAPACK Library routine C DLAMCH). TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (M) 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 >= 1, if MIN(N1,M) = 0; otherwise, C LDWORK >= MAX(N1+MAX(L,N,M),2*M), if LBE > 0 and N1 > 2; C LDWORK >= MAX(1,L,N,2*M), if LBE = 0 or N1 <= 2. 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 implemented algorithm [1] represents a specialization of the C controllability staircase algorithm of [2] to the special structure C of the input matrix B = [B1,B2]. C C REFERENCES C C [1] Varga, A. C Reliable algorithms for computing minimal dynamic covers for C descriptor systems. C Proc. of MTNS'04, Leuven, Belgium, 2004. C C [2] Varga, A. C Computation of Irreducible Generalized State-Space C Realizations. C Kybernetika, vol. 26, pp. 89-106, 1990. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N*N1**2 ) floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C April 2003. Based on the SLICOT routine TG01HX. C C REVISIONS C C A. Varga, Dec. 2006. C V. Sima, Dec. 2016, Mar. 2019. C C KEYWORDS C C Controllability, minimal realization, orthogonal canonical form, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. INTEGER IMAX, IMIN PARAMETER ( IMAX = 1, IMIN = 2 ) DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER COMPQ, COMPZ INTEGER INFO, L, LBE, LDA, LDB, LDC, LDE, LDQ, LDWORK, $ LDZ, M1, M2, N, N1, NR, NRBLCK, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK( * ), RTAU( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), $ Z( LDZ, * ) C .. Local Scalars .. LOGICAL B1RED, ILQ, ILZ, LQUERY, ONECOL, WITHC INTEGER I, IC, ICOL, ICOMPQ, ICOMPZ, IROW, ISMAX, $ ISMIN, J, JB2, K, M, MCRT, MCRT1, MCRT2, $ MINWRK, MN, NB, NF, NR1, NX, RANK, WRKOPT DOUBLE PRECISION C1, C2, CO, RCOND, S1, S2, SI, SMAX, SMAXPR, $ SMIN, SMINPR, SVLMAX, SVMA, SVMR, T, TOLZ, TT C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, ILAENV DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLANGE, DLAPY2, DNRM2, IDAMAX, ILAENV, $ LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEQRF, DLACPY, DLAIC1, DLARF, DLARFG, $ DLARTG, DLASET, DORMQR, DROT, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT C C .. Executable Statements .. C C Decode COMPQ. C IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'U' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF C C Decode COMPZ. C IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'U' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF C C Test the input scalar parameters. C INFO = 0 IF( ICOMPQ.LE.0 ) THEN INFO = -1 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -2 ELSE IF( L.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M1.LT.0 ) THEN INFO = -5 ELSE IF( M2.LT.0 ) THEN INFO = -6 ELSE IF( P.LT.0 ) THEN INFO = -7 ELSE IF( N1.LT.0 .OR. N1.GT.MIN( L, N ) ) THEN INFO = -8 ELSE IF( LBE.LT.0 .OR. LBE.GT.MAX( 0, N1-1 ) ) THEN INFO = -9 ELSE IF( LDA.LT.MAX( 1, L ) ) THEN INFO = -11 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -13 ELSE IF( LDB.LT.MAX( 1, L ) ) THEN INFO = -15 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -17 ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN INFO = -19 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -21 ELSE IF( TOL.GE.ONE ) THEN INFO = -25 ELSE M = M1 + M2 IF( MIN( N1, M ).EQ.0 ) THEN MINWRK = 1 ELSE IF( LBE.GT.0 .AND. N1.GT.2 ) THEN MINWRK = MAX( N1 + MAX( L, N, M ), 2*M ) ELSE MINWRK = MAX( 1, L, N, 2*M ) END IF C LQUERY = LDWORK.EQ.-1 IF( LQUERY ) THEN IF( LBE.GT.0 .AND. N1.GT.2 ) THEN CALL DGEQRF( N1, N1, E, LDE, DWORK, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, N1 + INT( DWORK(1) ) ) CALL DORMQR( 'Left', 'Transpose', N1, N, N1, E, LDE, $ DWORK, A, LDA, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(1) ) ) CALL DORMQR( 'Left', 'Transpose', N1, M, N1, E, LDE, $ DWORK, B, LDB, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(1) ) ) IF( ILQ ) THEN CALL DORMQR( 'Right', 'NoTranspose', L, N1, N1, E, $ LDE, DWORK, Q, LDQ, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(1) ) ) END IF ELSE WRKOPT = MINWRK END IF ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -28 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01HU', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Initialize Q and Z if necessary. C IF( ICOMPQ.EQ.3 ) $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) C C Initialize output variables. C NR = 0 NRBLCK = 0 C C Quick return if possible. C IF( MIN( N1, M ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C TOLZ = DLAMCH( 'Precision' ) WITHC = P.GT.0 SVLMAX = DLANGE( 'F', L, M, B, LDB, DWORK ) RCOND = TOL IF ( RCOND.LE.ZERO ) THEN C C Use the default tolerance in controllability determination. C RCOND = DBLE( L*N )*TOLZ END IF TOLZ = SQRT( TOLZ ) C IF ( SVLMAX.LT.RCOND ) $ SVLMAX = ONE SVMR = SVLMAX*RCOND SVMA = MAX( ONE, DLANGE( 'F', L, N, A, LDA, DWORK ) )*RCOND IF( SVMA.GT.SVMR*TOLZ ) $ SVMA = DLAPY2( SVMR, SVMA ) NX = ILAENV( 3, 'DGEQRF', ' ', N1, N1, -1, -1 ) NB = LDWORK/N1 C C Reduce E to upper triangular form if necessary. C IF( LBE.GT.NX/2 .AND. MIN( NB, N1 ).GE.NX ) THEN C C If E1 is a rather full matrix of enough size, use its C QR decomposition and apply it to A, B, and Q (if needed). C Workspace: need 2*N1; C prefer N1 + N1*NB. C CALL DGEQRF( N1, N1, E, LDE, DWORK, DWORK(N1+1), LDWORK-N1, $ INFO ) WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(N1+1) ) ) C C Workspace: need N1 + N; C prefer N1 + N*NB. C CALL DORMQR( 'Left', 'Transpose', N1, N, N1, E, LDE, DWORK, A, $ LDA, DWORK(N1+1), LDWORK-N1, INFO ) WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(N1+1) ) ) C C Workspace: need N1 + M; C prefer N1 + M*NB. C CALL DORMQR( 'Left', 'Transpose', N1, M, N1, E, LDE, DWORK, B, $ LDB, DWORK(N1+1), LDWORK-N1, INFO ) WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(N1+1) ) ) IF( ILQ ) THEN C C Workspace: need N1 + L; C prefer N1 + L*NB. C CALL DORMQR( 'Right', 'NoTranspose', L, N1, N1, E, LDE, $ DWORK, Q, LDQ, DWORK(N1+1), LDWORK-N1, INFO ) WRKOPT = MAX( WRKOPT, N1 + INT( DWORK(N1+1) ) ) END IF CALL DLASET( 'Lower', N1-1, N1-1, ZERO, ZERO, E(2,1), LDE ) ELSE IF( LBE.GT.0 .AND. N1.GT.1 ) THEN DO 10 I = 1, N1 - 1 C C Generate elementary reflector H(i) to annihilate C E(i+1:i+lbe,i). C K = MIN( LBE, N1-I ) + 1 CALL DLARFG( K, E(I,I), E(I+1,I), 1, TT ) T = E(I,I) E(I,I) = ONE C C Apply H(i) to E(i:n1,i+1:n) from the left. C CALL DLARF( 'Left', K, N-I, E(I,I), 1, TT, $ E(I,I+1), LDE, DWORK ) C C Apply H(i) to A(i:n1,1:n) from the left. C CALL DLARF( 'Left', K, N, E(I,I), 1, TT, $ A(I,1), LDA, DWORK ) C C Apply H(i) to B(i:n1,1:m) from the left. C CALL DLARF( 'Left', K, M, E(I,I), 1, TT, $ B(I,1), LDB, DWORK ) IF( ILQ ) THEN C C Apply H(i) to Q(1:l,i:n1) from the right. C CALL DLARF( 'Right', L, K, E(I,I), 1, TT, $ Q(1,I), LDQ, DWORK ) END IF E(I,I) = T 10 CONTINUE CALL DLASET( 'Lower', N1-1, N1-1, ZERO, ZERO, E(2,1), LDE ) END IF C MCRT1 = M1 MCRT2 = M2 MCRT = MCRT1 B1RED = .TRUE. ISMIN = 1 ISMAX = ISMIN + M C IC = 0 NF = N1 JB2 = M C 20 CONTINUE IF( NF.EQ.0 .AND. B1RED ) $ GO TO 120 NRBLCK = NRBLCK + 1 RANK = 0 C IF( NF.GT.0 ) THEN C C IROW will point to the current pivot line in B, C ICOL+1 will point to the first active columns of A. C ICOL = IC IROW = NR NR1 = NR + 1 IF( NRBLCK.EQ.2 ) THEN CALL DLACPY( 'Full', NF, M2, B(NR1,M1+1), LDB, $ B(NR1,1), LDB ) JB2 = MCRT ELSEIF( NRBLCK.GT.2 ) THEN CALL DLACPY( 'Full', NF, MCRT, A(NR1,IC+1), LDA, $ B(NR1,1), LDB ) ICOL = IC + MCRT SVMR = SVMA JB2 = MCRT ENDIF ONECOL = MCRT.EQ.1 C C Perform QR-decomposition with column pivoting on the current B C while keeping E upper triangular. C The current B is at first iteration B1, at second iteration B2 C and for subsequent iterations the NF-by-MCRT matrix delimited C by rows NR + 1 to N1 and columns IC + 1 to IC + MCRT of A. C The rank of current B is computed in RANK. C IF( ONECOL ) THEN MN = 1 ELSE MN = MIN( NF, MCRT ) C C Compute column norms. C DO 30 J = 1, MCRT DWORK(J) = DNRM2( NF, B(NR1,J), 1 ) DWORK(M+J) = DWORK(J) IWORK(J) = J 30 CONTINUE END IF C 40 CONTINUE IF( RANK.LT.MN ) THEN J = RANK + 1 IROW = IROW + 1 C C Pivot if necessary. C IF( J.NE.MCRT ) THEN K = ( J - 1 ) + IDAMAX( MCRT-J+1, DWORK(J), 1 ) IF( K.NE.J ) THEN CALL DSWAP( NF, B(NR1,J), 1, B(NR1,K), 1 ) I = IWORK(K) IWORK(K) = IWORK(J) IWORK(J) = I DWORK(K) = DWORK(J) DWORK(M+K) = DWORK(M+J) END IF END IF C C Zero elements below the current diagonal element of B. C DO 50 I = N1-1, IROW, -1 C C Rotate rows I and I+1 to zero B(I+1,J). C T = B(I,J) CALL DLARTG( T, B(I+1,J), CO, SI, B(I,J) ) B(I+1,J) = ZERO CALL DROT( N-I+1, E(I,I), LDE, E(I+1,I), LDE, CO, SI ) IF( J.LT.JB2 ) $ CALL DROT( JB2-J, B(I,J+1), LDB, B(I+1,J+1), LDB, CO, $ SI ) CALL DROT( N-ICOL, A(I,ICOL+1), LDA, A(I+1,ICOL+1), LDA, $ CO, SI ) IF( ILQ ) $ CALL DROT( L, Q(1,I), 1, Q(1,I+1), 1, CO, SI ) C C Rotate columns I, I+1 to zero E(I+1,I). C T = E(I+1,I+1) CALL DLARTG( T, E(I+1,I), CO, SI, E(I+1,I+1) ) E(I+1,I) = ZERO CALL DROT( I, E(1,I+1), 1, E(1,I), 1, CO, SI ) CALL DROT( N1, A(1,I+1), 1, A(1,I), 1, CO, SI ) IF( ILZ ) $ CALL DROT( N, Z(1,I+1), 1, Z(1,I), 1, CO, SI ) IF( WITHC ) $ CALL DROT( P, C(1,I+1), 1, C(1,I), 1, CO, SI ) 50 CONTINUE C IF( RANK.EQ.0 ) THEN C C Initialize; exit if matrix is zero (RANK = 0). C Short pass if the current B has one column. C SMAX = ABS( B(NR1,1) ) IF ( SMAX.LE.SVMR ) THEN GO TO 80 ELSE IF ( ONECOL ) THEN RANK = RANK + 1 GO TO 80 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, B(NR1,J), $ B(IROW,J), SMINPR, S1, C1 ) CALL DLAIC1( IMAX, RANK, DWORK(ISMAX), SMAX, B(NR1,J), $ B(IROW,J), SMAXPR, S2, C2 ) END IF C C Check the rank; finish the loop if rank loss occurs. C IF( SVMR.LE.SMAXPR ) THEN IF( SMAXPR*RCOND.LT.SMINPR ) THEN C C Finish the loop if last row. C IF( IROW.EQ.N1 ) THEN RANK = RANK + 1 GO TO 80 END IF C C Update partial column norms. C DO 60 I = J + 1, MCRT IF( DWORK(I).NE.ZERO ) THEN T = ABS( B(IROW,I) )/DWORK(I) T = MAX( ( ONE + T )*( ONE - T ), ZERO) TT = T*( DWORK(I)/DWORK(M+I) )**2 IF( TT.GT.TOLZ ) THEN DWORK(I) = DWORK(I)*SQRT( T ) ELSE DWORK(I) = DNRM2( NF-J, B(IROW+1,I), 1 ) DWORK(M+I) = DWORK(I) END IF END IF 60 CONTINUE C DO 70 I = 1, RANK DWORK(ISMIN+I-1) = S1*DWORK(ISMIN+I-1) DWORK(ISMAX+I-1) = S2*DWORK(ISMAX+I-1) 70 CONTINUE C DWORK(ISMIN+RANK) = C1 DWORK(ISMAX+RANK) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 GO TO 40 END IF END IF END IF END IF C 80 CONTINUE C IF( RANK.GT.0 ) THEN RTAU(NRBLCK) = RANK C C Back permute interchanged columns. C IF( .NOT.ONECOL ) THEN DO 100 J = 1, MCRT IF( IWORK(J).GT.0 ) THEN K = IWORK(J) IWORK(J) = -K 90 CONTINUE IF( K.NE.J ) THEN CALL DSWAP( RANK, B(NR1,J), 1, B(NR1,K), 1 ) IWORK(K) = -IWORK(K) K = -IWORK(K) GO TO 90 END IF END IF 100 CONTINUE END IF END IF IF( NRBLCK.EQ.2 ) THEN DO 110 J = M2, 1, -1 CALL DCOPY( NF, B(NR1,J), 1, B(NR1,M1+J), 1 ) 110 CONTINUE ELSEIF( NRBLCK.GT.2 ) THEN CALL DLACPY( 'Full', NF, MCRT, B(NR1,1), LDB, A(NR1,IC+1), $ LDA ) END IF IF( RANK.GT.0 ) THEN NR = NR + RANK NF = NF - RANK IF( NRBLCK.GT.2 ) $ IC = IC + MCRT IF( B1RED ) THEN MCRT1 = RANK MCRT = MCRT2 ELSE MCRT2 = RANK MCRT = MCRT1 END IF B1RED = .NOT.B1RED GO TO 20 ELSE IF( B1RED ) THEN IF( MCRT2.GT.0 ) THEN B1RED = .NOT.B1RED RTAU(NRBLCK) = 0 IF( NRBLCK.GT.2 ) $ IC = IC + MCRT MCRT1 = 0 MCRT = MCRT2 GO TO 20 END IF NRBLCK = NRBLCK - 1 ELSE IF( MCRT1.GT.0 ) THEN B1RED = .NOT.B1RED RTAU(NRBLCK) = 0 IF( NRBLCK.GT.2 ) $ IC = IC + MCRT MCRT2 = 0 MCRT = MCRT1 GO TO 20 END IF NRBLCK = NRBLCK - 2 END IF END IF C 120 CONTINUE C IF( NRBLCK.GT.0 ) THEN C RANK = RTAU(1) IF( RANK.LT.N1 ) $ CALL DLASET( 'Full', N1-RANK, M1, ZERO, ZERO, B(RANK+1,1), $ LDB ) RANK = RANK + RTAU(2) IF( RANK.LT.N1 ) $ CALL DLASET( 'Full', N1-RANK, M2, ZERO, ZERO, $ B(RANK+1,M1+1), LDB ) END IF C DWORK(1) = WRKOPT RETURN C *** Last line of TG01HU *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03BC.f0000644000000000000000000000013215012430707016143 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03BC.f0000644000175000017500000002751515012430707017351 0ustar00lilgelilge00000000000000 SUBROUTINE MB03BC( K, AMAP, S, SINV, A, LDA1, LDA2, MACPAR, CV, $ SV, DWORK ) C C PURPOSE C C To compute the product singular value decomposition of the K-1 C triangular factors corresponding to a 2-by-2 product of K C factors in upper Hessenberg-triangular form. C For a general product of 2-by-2 triangular matrices C C S(2) S(3) S(K) C A = A(:,:,2) A(:,:,3) ... A(:,:,K), C C Givens rotations are computed so that C S(i) C [ CV(i-1) SV(i-1) ] [ A(1,1,i)(in) A(1,2,i)(in) ] C [ -SV(i-1) CV(i-1) ] [ 0 A(2,2,i)(in) ] C S(i) C [ A(1,1,i)(out) A(1,2,i)(out) ] [ CV(i) SV(i) ] C = [ 0 A(2,2,i)(out) ] [ -SV(i) CV(i) ] C C stays upper triangular and C C [ CV(1) SV(1) ] [ CV(K) -SV(K) ] C [ -SV(1) CV(1) ] * A * [ SV(K) CV(K) ] C C is diagonal. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA1,LDA2,K) C On entry, the leading 2-by-2-by-K part of this array must C contain a 2-by-2 product (implicitly represented by its K C factors) in upper Hessenberg-triangular form. C On exit, the leading 2-by-2-by-K part of this array C contains modified triangular factors such that their C product is diagonal. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= 2. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= 2. C C MACPAR (input) DOUBLE PRECISION array, dimension (5) C Machine parameters: C MACPAR(1) overflow threshold, DLAMCH( 'O' ); C MACPAR(2) underflow threshold, DLAMCH( 'U' ); C MACPAR(3) safe minimum, DLAMCH( 'S' ); C MACPAR(4) relative machine precision, DLAMCH( 'E' ); C MACPAR(5) base of the machine, DLAMCH( 'B' ). C C CV (output) DOUBLE PRECISION array, dimension (K) C On exit, the first K elements of this array contain the C cosines of the Givens rotations. C C SV (output) DOUBLE PRECISION array, dimension (K) C On exit, the first K elements of this array contain the C sines of the Givens rotations. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (3*(K-1)) C C METHOD C C The product singular value decomposition of the K-1 C triangular factors are computed as described in [1]. C C REFERENCES C C [1] Bojanczyk, A. and Van Dooren, P. C On propagating orthogonal transformations in a product of 2x2 C triangular matrices. C In Reichel, Ruttan and Varga: 'Numerical Linear Algebra', C pp. 1-9, 1993. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLAPST. C V. Sima, Nov. 2010, Aug. 2011. C C KEYWORDS C C Eigenvalues, orthogonal transformation, singular values, C singular value decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0, $ TWO = 2.0D0 ) C .. Scalar Arguments .. INTEGER K, LDA1, LDA2, SINV C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*), CV(*), DWORK(*), MACPAR(*), $ SV(*) C .. Local Scalars .. INTEGER AI, I, PW, SCL DOUBLE PRECISION A11, A12, A22, B11, B12, B22, BASE, CC, CL, CR, $ EPS, MX, MX2, RMAX, RMIN, RMNS, RMXS, S11, S22, $ SC, SFMN, SL, SR, SSMAX, SSMIN, T11, T12, T22, $ TEMP, TWOS C .. External Subroutines .. EXTERNAL DLARTG, DLASV2 C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C C .. Executable Statements .. C RMAX = MACPAR(1) RMXS = SQRT( RMAX ) RMIN = MACPAR(2) RMNS = SQRT( RMIN ) SFMN = MACPAR(3) EPS = MACPAR(4) BASE = MACPAR(5) TWOS = SQRT( TWO ) C C Compute the product of the 2-by-2 triangular matrices. C PW = 1 T11 = ONE T12 = ZERO T22 = ONE C DO 60 I = 2, K AI = AMAP(I) A11 = A(1,1,AI) A12 = A(1,2,AI) A22 = A(2,2,AI) IF ( S(AI).NE.SINV ) THEN TEMP = A11 A11 = A22 A22 = TEMP A12 = -A12 END IF C C A and T are scaled so that the elements of the resulting C product do not overflow. C MX = ABS( A11 ) / RMXS MX2 = ABS( T11 ) / RMXS 10 CONTINUE IF ( MX*MX2.GE.ONE ) THEN IF ( MX.GE.ONE ) THEN MX = MX / BASE A11 = A11 / BASE A22 = A22 / BASE A12 = A12 / BASE END IF IF ( MX2.GE.ONE ) THEN MX2 = MX2 / BASE T11 = T11 / BASE T22 = T22 / BASE T12 = T12 / BASE END IF GOTO 10 END IF C MX = ABS( A22 ) / RMXS MX2 = ABS( T22 ) / RMXS 20 CONTINUE IF ( MX*MX2.GE.ONE ) THEN IF ( MX.GE.ONE ) THEN MX = MX / BASE A11 = A11 / BASE A22 = A22 / BASE A12 = A12 / BASE END IF IF ( MX2.GE.ONE ) THEN MX2 = MX2 / BASE T11 = T11 / BASE T22 = T22 / BASE T12 = T12 / BASE END IF GOTO 20 END IF C MX = ABS( A12 ) / RMXS MX2 = ABS( T11 ) / RMXS 30 CONTINUE IF ( MX*MX2.GE.HALF ) THEN IF ( MX.GE.HALF ) THEN MX = MX / BASE A11 = A11 / BASE A22 = A22 / BASE A12 = A12 / BASE END IF IF ( MX2.GE.HALF ) THEN MX2 = MX2 / BASE T11 = T11 / BASE T22 = T22 / BASE T12 = T12 / BASE END IF GOTO 30 END IF C MX = ABS( A22 ) / RMXS MX2 = ABS( T12 ) / RMXS 40 CONTINUE IF ( MX*MX2.GE.HALF ) THEN IF ( MX.GE.HALF ) THEN MX = MX / BASE A11 = A11 / BASE A22 = A22 / BASE A12 = A12 / BASE END IF IF ( MX2.GE.HALF ) THEN MX2 = MX2 / BASE T11 = T11 / BASE T22 = T22 / BASE T12 = T12 / BASE END IF GOTO 40 END IF C C Avoid underflow if possible. C MX = MAX( ABS( A11 ), ABS( A22 ), ABS( A12 ) ) MX2 = MAX( ABS( T11 ), ABS( T22 ), ABS( T12 ) ) IF ( MX.NE.ZERO .AND. MX2.NE.ZERO ) THEN 50 CONTINUE IF ( ( MX.LE.( ONE/RMNS ) .AND. MX2.LE.RMNS ) .OR. $ ( MX.LE.RMNS .AND. MX2.LE.( ONE/RMNS ) ) ) $ THEN IF ( MX.LE.MX2 ) THEN MX = MX * BASE A11 = A11 * BASE A22 = A22 * BASE A12 = A12 * BASE ELSE MX2 = MX2 * BASE T11 = T11 * BASE T22 = T22 * BASE T12 = T12 * BASE END IF GOTO 50 END IF END IF T12 = T11 * A12 + T12 * A22 T11 = T11 * A11 T22 = T22 * A22 IF ( I.LT.K ) THEN DWORK(PW) = T11 DWORK(PW+1) = T12 DWORK(PW+2) = T22 PW = PW + 3 END IF 60 CONTINUE C C Compute the SVD of this product avoiding unnecessary C overflow/underflow in the singular values. C TEMP = MAX( ABS( T11 / TWO ) + ABS( T12 / TWO ), $ ABS( T22 / TWO ) ) IF ( TEMP.GT.( RMAX/( TWO * TWOS ) ) ) THEN TEMP = TEMP / BASE T11 = T11 / BASE T12 = T12 / BASE T22 = T22 / BASE END IF 70 CONTINUE IF ( TEMP.LT.( RMAX/( TWO * BASE * TWOS ) ) .AND. $ T11.NE.ZERO .AND. T22.NE.ZERO ) THEN SCL = 0 IF ( ABS( T22 ).LE.TWOS * RMIN ) THEN SCL = 1 ELSE IF ( EPS * ABS( T12 ).GT.ABS( T22 ) ) THEN IF ( SQRT( ABS( T11 ) ) * SQRT( ABS( T22 ) ).LE. $ ( SQRT( TWOS ) * RMNS ) * SQRT( ABS( T12 ) ) ) $ SCL = 1 ELSE IF ( ABS( T11 ).LE.TWOS * RMIN * $ ( ONE + ABS( T12 / T22 ) ) ) $ SCL = 1 END IF IF ( SCL.EQ.1 ) THEN TEMP = TEMP * BASE T11 = T11 * BASE T12 = T12 * BASE T22 = T22 * BASE GOTO 70 END IF END IF C CALL DLASV2( T11, T12, T22, SSMIN, SSMAX, SR, CR, SL, CL ) C C Now, the last transformation is propagated to the front as C described in [1]. C S11 = T11 S22 = T22 C CV(K) = CR SV(K) = SR C DO 80 I = K, 2, -1 AI = AMAP(I) IF ( S(AI).EQ.SINV ) THEN A11 = A(1,1,AI) A12 = A(1,2,AI) A22 = A(2,2,AI) ELSE A11 = A(2,2,AI) A12 = -A(1,2,AI) A22 = A(1,1,AI) END IF IF ( I.GT.2 ) THEN PW = PW - 3 T11 = DWORK(PW) T12 = DWORK(PW+1) T22 = DWORK(PW+2) IF ( ABS( SR * CL * S22 ).LT.ABS( SL * CR * S11 ) ) THEN B11 = T22 B22 = T11 B12 = -T12 CC = CL SC = SL ELSE B11 = A11 B12 = A12 B22 = A22 CC = CR SC = SR END IF MX = MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ) ) IF ( MX.GT.RMAX / TWO ) THEN B11 = B11 / TWO B22 = B22 / TWO B12 = B12 / TWO END IF CALL DLARTG( B11 * CC + B12 * SC, SC * B22, CC, SC, TEMP ) ELSE CC = CL SC = SL END IF IF ( ABS( SC ).LT.SFMN * ABS( A22 ) ) THEN A(1,1,AI) = SC * SR * A22 + CC * ( CR * A11 + SR * A12 ) ELSE A(1,1,AI) = ( A22 / SC ) * SR END IF IF ( ABS( SR ).LT.SFMN * ABS( A11 ) ) THEN A(2,2,AI) = SC * SR * A11 + CR * ( CC * A22 - SC * A12 ) ELSE A(2,2,AI) = ( A11 / SR ) * SC END IF A(1,2,AI) = ( A12 * CR - A11 * SR ) * CC + A22 * CR * SC IF ( S(AI).NE.SINV ) THEN TEMP = A(1,1,AI) A(1,1,AI) = A(2,2,AI) A(2,2,AI) = TEMP A(1,2,AI) = -A(1,2,AI) END IF CR = CC SR = SC CV(I-1) = CR SV(I-1) = SR S11 = T11 S22 = T22 80 CONTINUE C CV(1) = CL SV(1) = SL C RETURN C *** Last line of MB03BC *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03OS.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03OS.f0000644000175000017500000004622715012430707017415 0ustar00lilgelilge00000000000000 SUBROUTINE SB03OS( DISCR, LTRANS, N, S, LDS, R, LDR, SCALE, DWORK, $ ZWORK, INFO ) C C PURPOSE C H C To solve for X = op(U) *op(U) either the stable non-negative C definite continuous-time Lyapunov equation C H 2 H C op(S) *X + X*op(S) = -scale *op(R) *op(R), (1) C C or the convergent non-negative definite discrete-time Lyapunov C equation C H 2 H C op(S) *X*op(S) - X = -scale *op(R) *op(R), (2) C C where op(K) = K or K**H (i.e., the conjugate transpose of the C matrix K), S and R are complex N-by-N upper triangular matrices, C and scale is an output scale factor, set less than or equal to 1 C to avoid overflow in X. The diagonal elements of the matrix R must C be real non-negative. C C In the case of equation (1) the matrix S must be stable (that is, C all the eigenvalues of S must have negative real parts), and for C equation (2) the matrix S must be convergent (that is, all the C eigenvalues of S must lie inside the unit circle). C C ARGUMENTS C C Mode Parameters C C DISCR LOGICAL C Specifies the type of Lyapunov equation to be solved as C follows: C = .TRUE. : Equation (2), discrete-time case; C = .FALSE.: Equation (1), continuous-time case. C C LTRANS LOGICAL C Specifies the form of op(K) to be used, as follows: C = .FALSE.: op(K) = K (No transpose); C = .TRUE. : op(K) = K**H (Conjugate transpose). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices S and R. N >= 0. C C S (input) COMPLEX*16 array of dimension (LDS,N) C The leading N-by-N upper triangular part of this array C must contain the upper triangular matrix. C The elements below the upper triangular part of the array C S are not referenced. C C LDS INTEGER C The leading dimension of array S. LDS >= MAX(1,N). C C R (input/output) COMPLEX*16 array of 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, with C real non-negative entries on its main diagonal. C On exit, the leading N-by-N upper triangular part of this C array contains the upper triangular matrix U, with real C non-negative entries on its main diagonal. C The strictly lower triangle of R is not referenced. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). 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 Workspace C C DWORK DOUBLE PRECISION array, dimension (N-1) C C ZWORK COMPLEX*16 array, dimension (2*N-2) 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 = 3: if the matrix S is not stable (that is, one or more C of the eigenvalues of S has a non-negative real C part), if DISCR = .FALSE., or not convergent (that C is, one or more of the eigenvalues of S lies outside C the unit circle), if DISCR = .TRUE.. C C METHOD C C The method used by the routine is based on a variant of the C Bartels and Stewart backward substitution method [1], that finds C the Cholesky factor op(U) directly without first finding X and C without the need to form the normal matrix op(R)'*op(R) [2]. C C The continuous-time Lyapunov equation in the canonical form C H H H 2 H C op(S) *op(U) *op(U) + op(U) *op(U)*op(S) = -scale *op(R) *op(R), C C or the discrete-time Lyapunov equation in the canonical form C H H H 2 H C op(S) *op(U) *op(U)*op(S) - op(U) *op(U) = -scale *op(R) *op(R), C C where U and R are upper triangular, is solved for U. C C REFERENCES C C [1] Bartels, R.H. and Stewart, G.W. C Solution of the matrix equation A'X + XB = C. C Comm. A.C.M., 15, pp. 820-826, 1972. C C [2] 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 The Lyapunov equation may be very ill-conditioned. In particular C if S is only just stable (or convergent) then the Lyapunov C equation will be ill-conditioned. "Large" elements in U relative C to those of S and R, or a "small" value for scale, is a symptom C of ill-conditioning. A condition estimate can be computed using C SLICOT Library routine SB03MD. C C CONTRIBUTOR C C V. Sima, March 2022. C C REVISIONS C C V. Sima, April 2022. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION SCALE INTEGER INFO, LDR, LDS, N LOGICAL DISCR, LTRANS C .. Array Arguments .. COMPLEX*16 R(LDR,*), S(LDS,*), ZWORK(*) DOUBLE PRECISION DWORK(*) C .. Local Scalars .. COMPLEX*16 ALPHA, SN, TMP, X, Z DOUBLE PRECISION ABSSKK, BIGNUM, C, DR, EPS, SCALOC, SMLNUM, $ SQTWO, TEMP INTEGER I, J, K, K1, KOUNT, KP1, KSZ LOGICAL SLV C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. External Subroutines .. EXTERNAL DLABAD, XERBLA, ZAXPY, ZCOPY, ZDSCAL, ZLACGV, $ ZLARTG, ZLASCL, ZLATRS, ZROT, ZSCAL, ZSWAP, $ ZTRMV C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, MAX, SQRT C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C IF ( N.LT.0 ) THEN INFO = -3 ELSE IF ( LDS.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF ( LDR.LT.MAX( 1, N ) ) THEN INFO = -7 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB03OS', -INFO ) RETURN END IF C SCALE = ONE C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*DBLE( N*N ) / EPS BIGNUM = ONE / SMLNUM C SQTWO = SQRT( TWO ) C C Start the solution. Most of the comments refer to notation and C equations in sections 5 and 10 of the second reference above. C IF ( .NOT.LTRANS ) THEN C C Case op(M) = M. C KOUNT = 1 C 10 CONTINUE C WHILE( KOUNT.LE.N )LOOP IF ( KOUNT.LE.N ) THEN K = KOUNT KP1 = K + 1 KOUNT = KP1 C C Make sure S is stable or convergent and find u11 in C equation (5.13) or (10.15). C IF ( DISCR ) THEN ABSSKK = ABS( S(K,K) ) IF ( ABSSKK.GE.ONE ) THEN INFO = 3 RETURN END IF TEMP = SQRT( ONE - ABSSKK )*SQRT( ONE + ABSSKK ) ELSE TEMP = DBLE( S(K,K) ) IF ( TEMP.GE.ZERO ) THEN INFO = 3 RETURN END IF TEMP = SQTWO*SQRT( -TEMP ) END IF C SCALOC = ONE DR = DBLE( R(K,K) ) IF ( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN IF ( DR.GT.BIGNUM*TEMP ) $ SCALOC = ONE / DR END IF ALPHA = TEMP R(K,K) = R(K,K) / ALPHA IF ( SCALOC.NE.ONE ) THEN SCALE = SCALE*SCALOC CALL ZLASCL( 'Upper', 0, 0, ONE, SCALOC, N, N, R, LDR, $ INFO ) END IF C C If we are not at the end of S then set up and solve C equation (5.14) or (10.16). ksz is the order of the C remainder of S. C IF ( KOUNT.LE.N ) THEN KSZ = N - K K1 = KSZ + 1 C C Form the right-hand side in ZWORK( 1 ),..., ZWORK( n-k ). C Z = DCONJG( S(K,K) ) CALL ZCOPY( KSZ, R(K,KP1), LDR, ZWORK, 1 ) CALL ZSCAL( KSZ, -ALPHA, ZWORK, 1 ) IF ( DISCR ) THEN CALL ZAXPY( KSZ, -Z*R(K,K), S(K,KP1), LDS, ZWORK, 1 ) ELSE CALL ZAXPY( KSZ, -R(K,K), S(K,KP1), LDS, ZWORK, 1 ) END IF CALL ZLACGV( KSZ, ZWORK, 1 ) C C Form the coefficient matrix. C SLV = .TRUE. IF ( DISCR ) THEN IF ( Z.EQ.CZERO ) THEN SLV = .FALSE. CALL ZSCAL( KSZ, -CONE, ZWORK, 1 ) ELSE I = 0 C DO 20 J = KP1, N I = I + 1 CALL ZSCAL( I, Z, S(KP1,J), 1 ) S(J,J) = S(J,J) - CONE 20 CONTINUE C END IF ELSE C DO 30 J = KP1, N S(J,J) = S(J,J) + Z 30 CONTINUE C END IF C IF ( SLV ) THEN C C Solve the system, with scaling to prevent overflow. C CALL ZLATRS( 'Upper', 'CTran', 'NoDiag', 'NoNorm', $ KSZ, S(KP1,KP1), LDS, ZWORK, SCALOC, $ DWORK, INFO ) IF ( SCALOC.NE.ONE ) THEN SCALE = SCALE*SCALOC CALL ZLASCL( 'Upper', 0, 0, ONE, SCALOC, N, N, R, $ LDR, INFO ) END IF END IF C C Restore the upper triangle or diagonal of the trailing S. C Then, copy the solution into the next ( n - k ) elements C of ZWORK, and swap it with the corresponding part of the C row of R. C IF ( DISCR ) THEN IF ( Z.NE.CZERO ) THEN Z = CONE / Z I = 0 C DO 40 J = KP1, N S(J,J) = S(J,J) + CONE I = I + 1 CALL ZSCAL( I, Z, S(KP1,J), 1 ) 40 CONTINUE C END IF CALL ZCOPY( KSZ, ZWORK, 1, ZWORK(K1), 1 ) CALL ZLACGV( KSZ, ZWORK, 1 ) ELSE C DO 50 J = KP1, N S(J,J) = S(J,J) - Z 50 CONTINUE C CALL ZLACGV( KSZ, ZWORK, 1 ) CALL ZCOPY( KSZ, ZWORK, 1, ZWORK(K1), 1 ) END IF C CALL ZSWAP( KSZ, ZWORK, 1, R(K,KP1), LDR ) C C Now form the matrix Rhat of equation (5.15) or C (10.17), first computing y in ZWORK, and then C updating R1. C IF ( DISCR ) THEN C C First form -lambda( 1 )*r and then add in C alpha*u11*s. C CALL ZSCAL( KSZ, -S(K,K), ZWORK, 1 ) CALL ZAXPY( KSZ, ALPHA*R(K,K), S(K,KP1), LDS, ZWORK, $ 1 ) CALL ZLACGV( KSZ, ZWORK, 1 ) C C Now form S1'*u in ZWORK(K1), where S1 is upper C triangular, and then add alpha*S1'*u to ZWORK. C CALL ZTRMV( 'Upper', 'CTrans', 'NoUnit', KSZ, $ S(KP1,KP1), LDS, ZWORK(K1), 1 ) CALL ZAXPY( KSZ, ALPHA, ZWORK(K1), 1, ZWORK, 1 ) CALL ZLACGV( KSZ, ZWORK, 1 ) ELSE CALL ZAXPY( KSZ, -ALPHA, ZWORK(K1), 1, ZWORK, 1 ) END IF C C Overwrite R(K+1:N,K+1:N) with the triangular matrix C from the QR-factorization of the (N-K+1)-by-(N-K) C matrix C C ( R(KP1:N,KP1:N) ) C ( ) . C ( Y**H ) C DO 60 I = 1, KSZ X = R(K+I,K+I) Z = ZWORK(I) CALL ZLARTG( X, Z, C, SN, TMP ) R(K+I,K+I) = TMP IF ( I.LT.KSZ ) $ CALL ZROT( KSZ-I, R(K+I,K+I+1), LDR, ZWORK(I+1), 1, $ C, SN ) 60 CONTINUE C C Make main diagonal elements of R(K+1:N,K+1:N) positive. C DO 70 I = KP1, N IF ( DBLE( R(I,I) ).LT.ZERO ) $ CALL ZDSCAL( N-I+1, -ONE, R(I,I), LDR ) 70 CONTINUE C END IF GO TO 10 END IF C END WHILE 10 C ELSE C C Case op(M) = M'. C KOUNT = N C 80 CONTINUE C WHILE( KOUNT.GE.1 )LOOP IF ( KOUNT.GE.1 ) THEN K = KOUNT KOUNT = KOUNT - 1 C C Make sure S is stable or convergent and find u11 in C equation corresponding to (5.13) or (10.15). C IF ( DISCR ) THEN ABSSKK = ABS( S(K,K) ) IF ( ABSSKK.GE.ONE ) THEN INFO = 3 RETURN END IF TEMP = SQRT( ONE - ABSSKK )*SQRT( ONE + ABSSKK ) ELSE TEMP = DBLE( S(K,K) ) IF ( TEMP.GE.ZERO ) THEN INFO = 3 RETURN END IF TEMP = SQTWO*SQRT( -TEMP ) END IF C SCALOC = ONE DR = DBLE( R(K,K) ) IF ( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN IF ( DR.GT.BIGNUM*TEMP ) $ SCALOC = ONE / DR END IF ALPHA = TEMP R(K,K) = R(K,K) / ALPHA IF ( SCALOC.NE.ONE ) THEN SCALE = SCALE*SCALOC CALL ZLASCL( 'Upper', 0, 0, ONE, SCALOC, N, N, R, LDR, $ INFO ) END IF C C If we are not at the front of S then set up and solve C equation corresponding to (5.14) or (10.16). ksz is C the order of the remainder leading part of S. C IF ( KOUNT.GT.0 ) THEN KSZ = K - 1 K1 = KSZ C C Form the right-hand side in ZWORK( 1 ),..., C ZWORK( k - 1 ). C Z = DCONJG( S(K,K) ) CALL ZCOPY( KSZ, R(1,K), 1, ZWORK, 1 ) CALL ZSCAL( KSZ, -ALPHA, ZWORK, 1 ) IF ( DISCR ) THEN CALL ZAXPY( KSZ, -Z*R(K,K), S(1,K), 1, ZWORK, 1 ) ELSE CALL ZAXPY( KSZ, -R(K,K), S(1,K), 1, ZWORK, 1 ) END IF C C Form the coefficient matrix. C SLV = .TRUE. IF ( DISCR ) THEN IF ( Z.EQ.CZERO ) THEN SLV = .FALSE. CALL ZSCAL( KSZ, -CONE, ZWORK, 1 ) ELSE C DO 90 J = 1, K1 CALL ZSCAL( J, Z, S(1,J), 1 ) S(J,J) = S(J,J) - CONE 90 CONTINUE C END IF ELSE C DO 100 J = 1, K1 S(J,J) = S(J,J) + Z 100 CONTINUE C END IF C IF ( SLV ) THEN C C Solve the system, with scaling to prevent overflow. C CALL ZLATRS( 'Upper', 'NoTran', 'NoDiag', 'NoNorm', $ KSZ, S, LDS, ZWORK, SCALOC, DWORK, INFO ) IF ( SCALOC.NE.ONE ) THEN SCALE = SCALE*SCALOC CALL ZLASCL( 'Upper', 0, 0, ONE, SCALOC, N, N, R, $ LDR, INFO ) END IF END IF C C Restore the upper triangle or diagonal of the leading S. C Then, copy the solution into the next ( k - 1 ) elements C of ZWORK, and swap it with the corresponding part of the C row of R. C IF ( DISCR ) THEN IF ( Z.NE.CZERO ) THEN Z = CONE / Z C DO 110 J = 1, K1 S(J,J) = S(J,J) + CONE CALL ZSCAL( J, Z, S(1,J), 1 ) 110 CONTINUE C END IF ELSE C DO 120 J = 1, K1 S(J,J) = S(J,J) - Z 120 CONTINUE C END IF C CALL ZCOPY( KSZ, ZWORK, 1, ZWORK(K), 1 ) CALL ZSWAP( KSZ, ZWORK, 1, R(1,K), 1 ) C C Now form the matrix Rhat of equation corresponding C to (5.15) or (10.17), first computing y in ZWORK, C and then updating R1. C IF ( DISCR ) THEN C C First form -lambda( 1 )*r and then add in C alpha*u11*s. C CALL ZSCAL( KSZ, -S(K,K), ZWORK, 1 ) CALL ZAXPY( KSZ, ALPHA*R(K,K), S(1,K), 1, ZWORK, 1 ) C C Now form alpha*S1*u in ZWORK(K), where S1 is upper C triangular. C CALL ZTRMV( 'Upper', 'NoTran', 'NoUnit', KSZ, S, LDS, $ ZWORK(K), 1 ) CALL ZAXPY( KSZ, ALPHA, ZWORK(K), 1, ZWORK, 1 ) ELSE CALL ZAXPY( KSZ, -ALPHA, ZWORK(K), 1, ZWORK, 1 ) END IF C C Overwrite R(1:K-1,1:K-1) with the triangular matrix C from the RQ-factorization of the (K-1)-by-K matrix C C ( ) C ( R(1:K-1,1:K-1) Y ) . C ( ) C DO 130 I = KSZ, 1, -1 X = R(I,I) Z = DCONJG( ZWORK(I) ) CALL ZLARTG( X, Z, C, SN, TMP ) R(I,I) = TMP IF ( I.GT.1 ) $ CALL ZROT( I-1, R(1,I), 1, ZWORK, 1, C, $ DCONJG( SN ) ) 130 CONTINUE C C Make main diagonal elements of R(1:K-1,1:K-1) positive. C DO 140 I = 1, KSZ IF ( DBLE( R(I,I) ).LT.ZERO ) $ CALL ZDSCAL( I, -ONE, R(1,I), 1 ) 140 CONTINUE END IF GO TO 80 END IF C END WHILE 80 C END IF RETURN C *** Last line of SB03OS *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04NV.f0000644000000000000000000000013215012430707016211 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04NV.f0000644000175000017500000001166015012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE SB04NV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) C C PURPOSE C C To construct the right-hand sides D for a system of equations in C Hessenberg form solved via SB04NX (case with 2 right-hand sides). C C ARGUMENTS C C Mode Parameters C C ABSCHR CHARACTER*1 C Indicates whether AB contains A or B, as follows: C = 'A': AB contains A; C = 'B': AB contains B. C C UL CHARACTER*1 C Indicates whether AB is upper or lower Hessenberg matrix, C as follows: C = 'U': AB is upper Hessenberg; C = 'L': AB is lower Hessenberg. 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 C (input) DOUBLE PRECISION array, dimension (LDC,M) C The leading N-by-M part of this array must contain both C the not yet modified part of the coefficient matrix C of C the Sylvester equation AX + XB = C, and both the currently C computed part of the solution of the Sylvester equation. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,N). C C INDX (input) INTEGER C The position of the first column/row of C to be used in C the construction of the right-hand side D. C C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) C The leading N-by-N or M-by-M part of this array must C contain either A or B of the Sylvester equation C AX + XB = C. C C LDAB INTEGER C The leading dimension of array AB. C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on C ABSCHR = 'A' or ABSCHR = 'B', respectively). C C D (output) DOUBLE PRECISION array, dimension (*) C The leading 2*N or 2*M part of this array (depending on C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the C right-hand side stored as a matrix with two rows. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB04BV by M. Vanbegin, and C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. C C REVISIONS C C - C C KEYWORDS C C Hessenberg form, orthogonal transformation, real Schur form, C Sylvester equation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER ABSCHR, UL INTEGER INDX, LDAB, LDC, M, N C .. Array Arguments .. DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMV C .. Executable Statements .. C C For speed, no tests on the input scalar arguments are made. C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 ) $ RETURN C IF ( LSAME( ABSCHR, 'B' ) ) THEN C C Construct the 2 columns of the right-hand side. C CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) IF ( LSAME( UL, 'U' ) ) THEN IF ( INDX.GT.1 ) THEN CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, $ ONE, D(1), 2 ) CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX+1), $ 1, ONE, D(2), 2 ) END IF ELSE IF ( INDX.LT.M-1 ) THEN CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, $ AB(INDX+2,INDX), 1, ONE, D(1), 2 ) CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, $ AB(INDX+2,INDX+1), 1, ONE, D(2), 2 ) END IF END IF ELSE C C Construct the 2 rows of the right-hand side. C CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) IF ( LSAME( UL, 'U' ) ) THEN IF ( INDX.LT.N-1 ) THEN CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, $ AB(INDX,INDX+2), LDAB, ONE, D(1), 2 ) CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, $ AB(INDX+1,INDX+2), LDAB, ONE, D(2), 2 ) END IF ELSE IF ( INDX.GT.1 ) THEN CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), $ LDAB, ONE, D(1), 2 ) CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX+1,1), $ LDAB, ONE, D(2), 2 ) END IF END IF END IF C RETURN C *** Last line of SB04NV *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02BD.f0000644000000000000000000000013215012430707016142 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02BD.f0000644000175000017500000000546715012430707017352 0ustar00lilgelilge00000000000000 SUBROUTINE MA02BD( SIDE, M, N, A, LDA ) C C PURPOSE C C To reverse the order of rows and/or columns of a given matrix A C by pre-multiplying and/or post-multiplying it, respectively, with C a permutation matrix P, where P is a square matrix of appropriate C order, with ones down the secondary diagonal. C C ARGUMENTS C C Mode Parameters C C SIDE CHARACTER*1 C Specifies the operation to be performed, as follows: C = 'L': the order of rows of A is to be reversed by C pre-multiplying A with P; C = 'R': the order of columns of A is to be reversed by C post-multiplying A with P; C = 'B': both the order of rows and the order of columns C of A is to be reversed by pre-multiplying and C post-multiplying A with P. 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 (LDA,N) C On entry, the leading M-by-N part of this array must C contain the given matrix whose rows and/or columns are to C be permuted. C On exit, the leading M-by-N part of this array contains C the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or C P*A*P if SIDE = 'B'. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, March 1998. C Based on the RASP routine PAP. C C REVISIONS C C - C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER SIDE INTEGER LDA, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*) C .. Local Scalars .. LOGICAL BSIDES INTEGER I, J, K, M2, N2 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DSWAP C .. Executable Statements .. C BSIDES = LSAME( SIDE, 'B' ) C IF( ( LSAME( SIDE, 'L' ) .OR. BSIDES ) .AND. M.GT.1 ) THEN C C Compute P*A. C M2 = M/2 K = M - M2 + 1 DO 10 J = 1, N CALL DSWAP( M2, A(1,J), -1, A(K,J), 1 ) 10 CONTINUE END IF IF( ( LSAME( SIDE, 'R' ) .OR. BSIDES ) .AND. N.GT.1 ) THEN C C Compute A*P. C N2 = N/2 K = N - N2 + 1 DO 20 I = 1, M CALL DSWAP( N2, A(I,1), -LDA, A(I,K), LDA ) 20 CONTINUE END IF C RETURN C *** Last line of MA02BD *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03BR.f0000644000000000000000000000013215012430707016175 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SG03BR.f0000644000175000017500000001236515012430707017400 0ustar00lilgelilge00000000000000 SUBROUTINE SG03BR( XR, XI, YR, YI, C, SR, SI, ZR, ZI ) C C PURPOSE C C To compute the parameters for the complex Givens rotation C C ( C SR+SI*I ) ( XR+XI*I ) ( ZR+ZI*I ) C ( ) * ( ) = ( ) C ( -SR+SI*I C ) ( YR+YI*I ) ( 0 ) C C where C, SR, SI, XR, XI, YR, YI, ZR, ZI are real numbers, I is the C imaginary unit, I = SQRT(-1), and C**2 + |SR+SI*I|**2 = 1. C C ARGUMENTS C C Input/Output Parameters C C XR, XI, (input) DOUBLE PRECISION C YR, YI (input) DOUBLE PRECISION C The given real scalars XR, XI, YR, YI. C C C, (output) DOUBLE PRECISION C SR, SI, (output) DOUBLE PRECISION C ZR, ZI (output) DOUBLE PRECISION C The computed real scalars C, SR, SI, ZR, ZI defining the C complex Givens rotation and Z = ZR+ZI*I. C C NUMERICAL ASPECTS C C The subroutine avoids unnecessary overflow. C C FURTHER COMMENTS C C In the interest of speed, this routine does not check the input C for errors. C C CONTRIBUTOR C C V. Sima, Dec. 2021. C This is an adaptation for real data of the LAPACK routine ZLARTG. C C REVISIONS C C V. Sima, Jan. 2022. 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 .. DOUBLE PRECISION C, SI, SR, XI, XR, YI, YR, ZI, ZR C .. Local Scalars .. INTEGER COUNT, I DOUBLE PRECISION D, DI, DR, EPS, SAFMIN, SAFMN2, SAFMX2, SCALE, $ TI, TR, X2, X2S, XIS, XRS, Y2, Y2S, YIS, YRS C .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 C .. Intrinsic Functions .. DOUBLE PRECISION ABS, INT, LOG, MAX, SQRT C C Do not check input parameters for errors. C SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 C SCALE = MAX( ABS( XR ), ABS( XI ), ABS( YR ), ABS( YI ) ) C XRS = XR XIS = XI YRS = YR YIS = YI COUNT = 0 C IF( SCALE.GE.SAFMX2 ) THEN C 10 CONTINUE COUNT = COUNT + 1 XRS = XRS*SAFMN2 XIS = XIS*SAFMN2 YRS = YRS*SAFMN2 YIS = YIS*SAFMN2 SCALE = SCALE*SAFMN2 IF( SCALE.GE.SAFMX2 ) $ GO TO 10 C ELSE IF( SCALE.LE.SAFMN2 ) THEN C IF( YR.EQ.ZERO .AND. YI.EQ.ZERO ) THEN C = ONE SR = ZERO SI = ZERO ZR = XR ZI = XI RETURN END IF C 20 CONTINUE COUNT = COUNT - 1 XRS = XRS*SAFMX2 XIS = XIS*SAFMX2 YRS = YRS*SAFMX2 YIS = YIS*SAFMX2 SCALE = SCALE*SAFMX2 IF( SCALE.LE.SAFMN2 ) $ GO TO 20 C END IF C X2 = XRS**2 + XIS**2 Y2 = YRS**2 + YIS**2 C IF( X2.LE.MAX( Y2, ONE )*SAFMIN ) THEN C C This is a rare case: XR + I*XI is very small. C IF( XR.EQ.ZERO .AND. XI.EQ.ZERO ) THEN C = ZERO ZR = DLAPY2( YR, YI ) ZI = ZERO C C Do complex/real division explicitly with two real divisions. C D = DLAPY2( YRS, YIS ) SR = YRS / D SI = -YIS / D RETURN END IF C X2S = DLAPY2( XRS, XIS ) C C Y2 and Y2S are accurate. C Y2 is at least SAFMIN, and Y2S is at least SAFMN2. C Y2S = SQRT( Y2 ) C = X2S / Y2S C C Make sure abs(XR+iXI) = 1. C Do complex/real division explicitly with two real divisions. C IF( MAX( ABS( XR ), ABS( XI ) ).GT.ONE ) THEN D = DLAPY2( XR, XI ) TR = XR / D TI = XI / D ELSE DR = SAFMX2*XR DI = SAFMX2*XI D = DLAPY2( DR, DI ) TR = DR / D TI = DI / D END IF C SR = TR*( YRS / Y2S ) + TI*( YIS / Y2S ) SI = TI*( YRS / Y2S ) - TR*( YIS / Y2S ) ZR = C*XR + SR*YR - SI*YI ZI = C*XI + SI*YR + SR*YI C ELSE C C This is the most common case. C Neither X2 nor X2/Y2 are less than SAFMIN. C X2S cannot overflow, and it is accurate. C X2S = SQRT( ONE + Y2 / X2 ) C C Do the X2S*XS multiply with two real multiplies. C ZR = X2S*XRS ZI = X2S*XIS C = ONE / X2S D = X2 + Y2 C C Do complex/real division explicitly with two real divisions. C SR = ZR / D SI = ZI / D DR = SR*YRS + SI*YIS SI = SI*YRS - SR*YIS SR = DR C IF( COUNT.NE.0 ) THEN IF( COUNT.GT.0 ) THEN C DO 30 I = 1, COUNT ZR = ZR*SAFMX2 ZI = ZI*SAFMX2 30 CONTINUE C ELSE C DO 40 I = 1, -COUNT ZR = ZR*SAFMN2 ZI = ZI*SAFMN2 40 CONTINUE C END IF END IF C END IF C RETURN C C *** Last line of SG03BR *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02TD.f0000644000000000000000000000013215012430707016165 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02TD.f0000644000175000017500000001364715012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCOND, IWORK, $ DWORK, INFO ) C C PURPOSE C C To estimate the reciprocal of the condition number of an upper C Hessenberg matrix H, in either the 1-norm or the infinity-norm, C using the LU factorization computed by MB02SD. C C ARGUMENTS C C Mode Parameters C C NORM CHARACTER*1 C Specifies whether the 1-norm condition number or the C infinity-norm condition number is required: C = '1' or 'O': 1-norm; C = 'I': Infinity-norm. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix H. N >= 0. C C HNORM (input) DOUBLE PRECISION C If NORM = '1' or 'O', the 1-norm of the original matrix H. C If NORM = 'I', the infinity-norm of the original matrix H. C C H (input) DOUBLE PRECISION array, dimension (LDH,N) C The factors L and U from the factorization H = P*L*U C as computed by MB02SD. C C LDH INTEGER C The leading dimension of the array H. LDH >= max(1,N). C C IPIV (input) INTEGER array, dimension (N) C The pivot indices; for 1 <= i <= N, row i of the matrix C was interchanged with row IPIV(i). C C RCOND (output) DOUBLE PRECISION C The reciprocal of the condition number of the matrix H, C computed as RCOND = 1/(norm(H) * norm(inv(H))). C C Workspace C C IWORK INTEGER array, dimension (N) C C DWORK DOUBLE PRECISION array, dimension (3*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 METHOD C C An estimate is obtained for norm(inv(H)), and the reciprocal of C the condition number is computed as C RCOND = 1 / ( norm(H) * norm(inv(H)) ). C C REFERENCES C C - C C NUMERICAL ASPECTS C 2 C The algorithm requires 0( N ) operations. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. C C REVISIONS C C V. Sima, May 2020. C C KEYWORDS C C Hessenberg form, matrix algebra. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. Scalar Arguments .. CHARACTER NORM INTEGER INFO, LDH, N DOUBLE PRECISION HNORM, RCOND C .. C .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION DWORK( * ), H( LDH, * ) C .. Local Scalars .. LOGICAL ONENRM CHARACTER NORMIN INTEGER IX, J, JP, KASE, KASE1 DOUBLE PRECISION HINVNM, SCALE, SMLNUM, T C .. Local Arrays .. INTEGER ISAVE( 3 ) C .. C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, IDAMAX, LSAME C .. C .. External Subroutines .. EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( HNORM.LT.ZERO ) THEN INFO = -3 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02TD', -INFO ) RETURN END IF C C Quick return if possible. C RCOND = ZERO IF( N.EQ.0 ) THEN RCOND = ONE RETURN ELSE IF( HNORM.EQ.ZERO ) THEN RETURN END IF C SMLNUM = DLAMCH( 'Safe minimum' ) C C Estimate the norm of inv(H). C HINVNM = ZERO NORMIN = 'N' IF( ONENRM ) THEN KASE1 = 1 ELSE KASE1 = 2 END IF KASE = 0 10 CONTINUE CALL DLACN2( N, DWORK( N+1 ), DWORK, IWORK, HINVNM, KASE, ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.KASE1 ) THEN C C Multiply by inv(L). C DO 20 J = 1, N - 1 JP = IPIV( J ) T = DWORK( JP ) IF( JP.NE.J ) THEN DWORK( JP ) = DWORK( J ) DWORK( J ) = T END IF DWORK( J+1 ) = DWORK( J+1 ) - T * H( J+1, J ) 20 CONTINUE C C Multiply by inv(U). C CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, $ H, LDH, DWORK, SCALE, DWORK( 2*N+1 ), INFO ) ELSE C C Multiply by inv(U'). C CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, H, $ LDH, DWORK, SCALE, DWORK( 2*N+1 ), INFO ) C C Multiply by inv(L'). C DO 30 J = N - 1, 1, -1 DWORK( J ) = DWORK( J ) - H( J+1, J ) * DWORK( J+1 ) JP = IPIV( J ) IF( JP.NE.J ) THEN T = DWORK( JP ) DWORK( JP ) = DWORK( J ) DWORK( J ) = T END IF 30 CONTINUE END IF C C Divide X by 1/SCALE if doing so will not cause overflow. C NORMIN = 'Y' IF( SCALE.NE.ONE ) THEN IX = IDAMAX( N, DWORK, 1 ) IF( SCALE.LT.ABS( DWORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO $ ) GO TO 40 CALL DRSCL( N, SCALE, DWORK, 1 ) END IF GO TO 10 END IF C C Compute the estimate of the reciprocal condition number. C IF( HINVNM.NE.ZERO ) $ RCOND = ( ONE / HINVNM ) / HNORM C 40 CONTINUE RETURN C *** Last line of MB02TD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03AE.f0000644000000000000000000000013215012430707016144 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03AE.f0000644000175000017500000002214615012430707017345 0ustar00lilgelilge00000000000000 SUBROUTINE MB03AE( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, C1, $ S1, C2, S2 ) C C PURPOSE C C To compute two Givens rotations (C1,S1) and (C2,S2) such that the C orthogonal matrix C C [ Q 0 ] [ C1 S1 0 ] [ 1 0 0 ] C Z = [ ], Q := [ -S1 C1 0 ] * [ 0 C2 S2 ], C [ 0 I ] [ 0 0 1 ] [ 0 -S2 C2 ] C C makes the first column of the real Wilkinson double shift C polynomial of the product of matrices in periodic upper Hessenberg C form, stored in the array A, parallel to the first unit vector. C Only the rotation defined by C1 and S1 is used for the real C Wilkinson single shift polynomial (see SLICOT Library routines C MB03BE or MB03BF). All factors whose exponents differ from that of C the Hessenberg factor are assumed nonsingular. The trailing 2-by-2 C submatrix and the five nonzero elements in the first two columns C of the matrix product are evaluated when a double shift is used. C C ARGUMENTS C C Mode Parameters C C SHFT CHARACTER*1 C Specifies the number of shifts employed by the shift C polynomial, as follows: C = 'D': two shifts (assumes N > 2); C = 'S': one real shift. C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of the factors. N >= 2. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C AMAP(1) is the pointer to the Hessenberg matrix. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input) DOUBLE PRECISION array, dimension (LDA1,LDA2,K) C The leading N-by-N-by-K part of this array must contain C the product (implicitly represented by its K factors) C in periodic upper Hessenberg form. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= N. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= N. C C C1 (output) DOUBLE PRECISION C S1 (output) DOUBLE PRECISION C On exit, C1 and S1 contain the parameters for the first C Givens rotation. C C C2 (output) DOUBLE PRECISION C S2 (output) DOUBLE PRECISION C On exit, if SHFT = 'D' and N > 2, C2 and S2 contain the C parameters for the second Givens rotation. Otherwise, C C2 = 1, S2 = 0. C C METHOD C C The necessary elements of the real Wilkinson double/single shift C polynomial are computed, and suitable Givens rotations are found. C For numerical reasons, this routine should be called when C convergence difficulties are encountered. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Aug. 2019. C C REVISIONS C C V. Sima, Sep. 2019, Dec. 2019. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO, ZERO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER SHFT INTEGER K, LDA1, LDA2, N, SINV DOUBLE PRECISION C1, C2, S1, S2 C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*) C .. Local Scalars .. LOGICAL SGLE INTEGER I, IC, IND, J, L, M, MM DOUBLE PRECISION E1, E2, P1, P2, P3, PR, SCL, SM, T C .. Local Arrays .. INTEGER IP(3), JP(3) DOUBLE PRECISION DWORK(9), WI(2), WR(2), Y(9), Z(2,2) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL DDOT, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGESC2, DGETC2, DLACPY, DLANV2, DLARTG, $ DLASET, DTRMV C .. Intrinsic Functions .. INTRINSIC ABS, MIN C C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked for errors. C C Evaluate the needed part of the matrix product. C SGLE = LSAME( SHFT, 'S' ) .OR. N.EQ.2 C M = MIN( N, 3 ) MM = M*M L = N - M + 1 T = ONE C CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK, M ) C IF ( SGLE ) THEN C C Compute the two nonzero elements, E1 and E2, of the first C column of the product, as well as the bottom M-by-M part of the C product of triangular factors. Complete pivoting is used for C triangular factors whose exponents differ from SINV. C It is assumed that no overflow could appear when solving linear C systems, hence SCL = 1. C DO 30 J = K, 2, -1 I = AMAP(J) IF ( S(I).EQ.SINV ) THEN T = T*A(1,1,I) C DO 10 IC = 1, MM, M CALL DTRMV( 'Upper', 'NoTran', 'NonUnit', M, A(L,L,I), $ LDA1, DWORK(IC), 1 ) 10 CONTINUE C ELSE T = T/A(1,1,I) C CALL DLACPY( 'Upper', M, M, A(L,L,I), LDA1, Y, M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, Y(2), M ) CALL DGETC2( M, Y, M, IP, JP, IND ) C DO 20 IC = 1, MM, M CALL DGESC2( M, Y, M, DWORK(IC), IP, JP, SCL ) 20 CONTINUE C END IF 30 CONTINUE C I = AMAP(1) E1 = A(1,1,I)*T E2 = A(2,1,I)*T C C Compute the (N,N) element of the product and the rotations. C P1 = DDOT( 2, A(N,N-1,I), LDA1, DWORK(M+1), 1 ) CALL DLARTG( E1 - P1, E2, C1, S1, E1 ) C2 = ONE S2 = ZERO C ELSE C C Compute the nonzero elements of the first two columns and the C bottom M-by-M part of the product of triangular factors. C CALL DLASET( 'Full', 2, 2, ZERO, ONE, Z, 2 ) C DO 60 J = K, 2, -1 I = AMAP(J) IF ( S(I).EQ.SINV ) THEN Z(1,1) = A(1,1,I)*Z(1,1) Z(1,2) = A(1,1,I)*Z(1,2) + A(1,2,I)*Z(2,2) Z(2,2) = A(2,2,I)*Z(2,2) C DO 40 IC = 1, MM, M CALL DTRMV( 'Upper', 'NoTran', 'NonUnit', M, A(L,L,I), $ LDA1, DWORK(IC), 1 ) 40 CONTINUE C ELSE C Y(1) = A(1,1,I) Y(2) = ZERO CALL DCOPY( 2, A(1,2,I), 1, Y(3), 1 ) CALL DGETC2( 2, Y, 2, IP, JP, IND ) CALL DGESC2( 2, Y, 2, Z, IP, JP, SCL ) CALL DGESC2( 2, Y, 2, Z(1,2), IP, JP, SCL ) C CALL DLACPY( 'Upper', M, M, A(L,L,I), LDA1, Y, M ) CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, Y(2), M ) CALL DGETC2( M, Y, M, IP, JP, IND ) C DO 50 IC = 1, MM, M CALL DGESC2( M, Y, M, DWORK(IC), IP, JP, SCL ) 50 CONTINUE C END IF 60 CONTINUE C C Save the nonzero elements of the first column of the product. C I = AMAP(1) E1 = A(1,1,I)*Z(1,1) E2 = A(2,1,I)*Z(1,1) C C Save the nonzero elements of the second column of the product. C P1 = A(1,1,I)*Z(1,2) + A(1,2,I)*Z(2,2) P2 = A(2,1,I)*Z(1,2) + A(2,2,I)*Z(2,2) P3 = A(3,2,I)*Z(2,2) C C Compute the bottom 2-by-2 part of the product. C L = N - 1 C Z(1,1) = DDOT( 2, A(L,L-1,I), LDA1, DWORK(M+1), 1 ) Z(2,1) = A(N,L,I)*DWORK(M+2) Z(1,2) = DDOT( M, A(L,L-1,I), LDA1, DWORK(MM-M+1), 1 ) Z(2,2) = DDOT( 2, A(N,L,I), LDA1, DWORK(MM-1), 1 ) C C Compute the eigenvalues of the bottom 2-by-2 part. C If there are two real eigenvalues, both shifts are chosen equal C to the eigenvalue with minimum modulus. Only the sum and C product of the shifts are needed. C CALL DLANV2( Z(1,1), Z(1,2), Z(2,1), Z(2,2), WR(1), WI(1), $ WR(2), WI(2), C1, S1 ) IF ( WI(1).EQ.ZERO ) THEN IF ( ABS( WR(1) ).LT.ABS( WR(2) ) ) THEN T = WR(1) ELSE T = WR(2) END IF SM = TWO*T PR = T**2 ELSE SM = TWO*WR(1) PR = WR(1)**2 + WI(1)**2 END IF C C Compute a multiple of the first column of the real Wilkinson C double shift polynomial, having only three nonzero elements. C P1 = P1 + ( ( E1 - SM )*E1 + PR )/E2 P2 = P2 + E1 - SM C C Compute the rotations to annihilate P2 and P3. C CALL DLARTG( P2, P3, C2, S2, E1 ) CALL DLARTG( P1, E1, C1, S1, E2 ) END IF C RETURN C *** Last line of MB03AE *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03JP.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03JP.f0000644000175000017500000020636615012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE MB03JP( COMPQ, N, A, LDA, D, LDD, B, LDB, F, LDF, Q, $ LDQ, NEIG, IWORK, LIWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To move the eigenvalues with strictly negative real parts of an C N-by-N real skew-Hamiltonian/Hamiltonian pencil aS - bH in C structured Schur form, C C ( A D ) ( B F ) C S = ( ), H = ( ), C ( 0 A' ) ( 0 -B' ) C C with A upper triangular and B upper quasi-triangular, to the C leading principal subpencil, while keeping the triangular form. C The notation M' denotes the transpose of the matrix M. C The matrices S and H are transformed by an orthogonal matrix Q C such that C C ( Aout Dout ) C Sout = J Q' J' S Q = ( ), C ( 0 Aout' ) C (1) C ( Bout Fout ) ( 0 I ) C Hout = J Q' J' H Q = ( ), with J = ( ), C ( 0 -Bout' ) ( -I 0 ) C C where Aout is upper triangular and Bout is upper quasi-triangular. C Optionally, if COMPQ = 'I' or COMPQ = 'U', the orthogonal matrix Q C that fulfills (1), is computed. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether or not the orthogonal transformations C should be accumulated in the array Q, as follows: C = 'N': Q is not computed; C = 'I': the array Q is initialized internally to the unit C matrix, and the orthogonal matrix Q is returned; C = 'U': the array Q contains an orthogonal matrix Q0 on C entry, and the matrix Q0*Q is returned, where Q C is the product of the orthogonal transformations C that are applied to the pencil aS - bH to reorder C the eigenvalues. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular matrix A. The elements of the C strictly lower triangular part of this array are not used. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Aout. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C D (input/output) DOUBLE PRECISION array, dimension C (LDD, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the skew-symmetric C matrix D. The diagonal need not be set to zero. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper triangular part of the C matrix Dout. C The strictly lower triangular part of this array is C not referenced, except for the element D(N/2,N/2-1), but C its initial value is preserved. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1, N/2). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper quasi-triangular matrix B. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper quasi-triangular part of C the matrix Bout. C The part below the first subdiagonal of this array is C not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C F (input/output) DOUBLE PRECISION array, dimension C (LDF, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the symmetric matrix C F. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper triangular part of the C matrix Fout. C The strictly lower triangular part of this array is not C referenced, except for the element F(N/2,N/2-1), but its C initial value is preserved. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1, N/2). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) C On entry, if COMPQ = 'U', then the leading N-by-N part of C this array must contain a given matrix Q0, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q0 and the transformation matrix Q C used to transform the matrices S and H. C On exit, if COMPQ = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q. C If COMPQ = 'N' this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'. C C NEIG (output) INTEGER C The number of eigenvalues in aS - bH with strictly C negative real part. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= 3*N-3. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The dimension of the array DWORK. C If COMPQ = 'N', C LDWORK >= MAX(2*N+32,108)+5*N/2; C if COMPQ = 'I' or COMPQ = 'U', C LDWORK >= MAX(4*N+32,108)+5*N/2. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: error occured during execution of MB03DD; C = 2: error occured during execution of MB03HD. C C METHOD C C The algorithm reorders the eigenvalues like the following scheme: C C Step 1: Reorder the eigenvalues in the subpencil aA - bB. C I. Reorder the eigenvalues with negative real parts to the C top. C II. Reorder the eigenvalues with positive real parts to the C bottom. C C Step 2: Reorder the remaining eigenvalues with negative real C parts in the pencil aS - bH. C I. Exchange the eigenvalues between the last diagonal block C in aA - bB and the last diagonal block in aS - bH. C II. Move the eigenvalues of the R-th block to the (MM+1)-th C block, where R denotes the number of upper quasi- C triangular blocks in aA - bB and MM denotes the current C number of blocks in aA - bB with eigenvalues with negative C real parts. C C The algorithm uses a sequence of orthogonal transformations as C described on page 33 in [1]. To achieve those transformations the C elementary subroutines MB03DD and MB03HD are called for the C corresponding matrix structures. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C FURTHER COMMENTS C C For large values of N, the routine applies the transformations on C panels of columns. The user may specify in INFO the desired number C of columns. If on entry INFO <= 0, then the routine estimates a C suitable value of this number. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2010. C M. Voigt, Max Planck Institute for Dynamics of Complex Technical C Systems, Magdeburg, Jan. 2012. C C REVISIONS C C V. Sima, Nov. 2010, July 2013, Aug. 2014, June 2015. C M. Voigt, July 2013. C C KEYWORDS C C Eigenvalue reordering, upper (quasi-)triangular matrix, C skew-Hamiltonian/Hamiltonian pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF, TEN PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0, $ TEN = 1.0D+1 ) C C .. Scalar Arguments .. CHARACTER COMPQ INTEGER INFO, LDA, LDB, LDD, LDF, LDQ, LDWORK, LIWORK, $ N, NEIG C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( LDD, * ), $ DWORK( * ), F( LDF, * ), Q( LDQ, * ) C C .. Local Scalars .. LOGICAL LCMPQ, LINIQ, LUPDQ INTEGER BLKUP, DIM1, DIM2, HLP, I, IA, IAUPLE, IB, IB1, $ IB2, IB3, IBUPLE, IBUPRI, IC, ICOL, ICOLS, ICS, $ IQ1, IQ2, IQLOLE, IQLORI, IQUPLE, IQUPRI, IR, $ IS, ITMP1, ITMP2, ITMP3, IUPD, IWRK1, IWRK2, $ IWRK3, IWRK4, IWRK5, J, JE, JS, K, LDW, M, M1, $ MM, MP, NB, NC, NCOL, NP2, NROWS, OPTDW, R, $ SDIM, UPDS DOUBLE PRECISION A2, D1, D2, D3, F2, NRMA, NRMB, PREC, Q11, Q12, $ Q21, Q22, TMP, TOL C C .. Local Arrays .. DOUBLE PRECISION PAR( 2 ) C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLANHS, DLANTR EXTERNAL DDOT, DLAMCH, DLANHS, DLANTR, LSAME C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGEQRF, DLACPY, $ DLASET, DSCAL, MB01LD, MB01RU, MB01RX, MB03DD, $ MB03HD, XERBLA C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD, SIGN C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 M1 = MAX( 1, M ) NB = INFO IF( NB.GT.0 ) $ NB = MAX( NB, 2 ) C LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LCMPQ = LINIQ .OR. LUPDQ IF( LCMPQ ) THEN OPTDW = MAX( 4*N+32, 108 ) + 5*M ELSE OPTDW = MAX( 2*N+32, 108 ) + 5*M END IF C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -2 ELSE IF( LDA.LT.M1 ) THEN INFO = -4 ELSE IF( LDD.LT.M1 ) THEN INFO = -6 ELSE IF( LDB.LT.M1 ) THEN INFO = -8 ELSE IF( LDF.LT.M1 ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN INFO = -12 ELSE IF( LIWORK.LT.3*N-3 ) THEN INFO = -15 ELSE IF( LDWORK.LT.OPTDW ) THEN INFO = -17 END IF IF( INFO.NE.0) THEN CALL XERBLA( 'MB03JP', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN NEIG = 0 RETURN END IF C C A block algorithm is used for large M. C IF( NB.LE.0 ) THEN CALL DGEQRF( M, M, A, LDA, DWORK, DWORK, -1, INFO ) NB = MIN( MAX( INT( DWORK( 1 ) )/M1, 2 ), M ) END IF C C Determine machine constants. C PREC = DLAMCH( 'Precision' ) TOL = MIN( DBLE( N ), TEN )*PREC C PAR( 1 ) = PREC PAR( 2 ) = DLAMCH( 'Safe minimum' ) C C STEP 0: Determine location and size of diagonal blocks. C IWORK(J) and IWORK(IS+J) are used to indicate the C beginning index and the kind of eigenvalues of the C J-th diagonal block of the subpencil aA - bB. For a C 2-by-2 block, it is assumed that both eigenvalues have C real parts with the same sign (true for a structured C Schur form). C I = 1 J = 1 IS = M + 1 C NRMA = DLANTR( 'One', 'Upper', 'Non-diag', M, M, A, LDA, DWORK ) NRMB = DLANHS( 'One', M, B, LDB, DWORK ) C C Partition blocks. C C WHILE( I.LE.M-1 ) DO C 10 CONTINUE IF( I.LE.M-1 ) THEN IWORK( J ) = I IF( ABS( B( I+1, I ) ).LE.TOL*NRMB ) THEN C C 1-by-1 block. C B( I+1, I ) = ZERO IF( ABS( A( I, I ) ).LE.TOL*NRMA .OR. $ ABS( B( I, I ) ).LE.TOL*NRMB ) THEN C C Eigenvalue is infinite, 0, or 0/0. C IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = INT( SIGN( ONE, A( I, I )*B( I, I ) ) ) END IF I = I + 1 ELSE C C 2-by-2 block. C IF( A( I, I ).EQ.ZERO .OR. A( I+1, I+1 ).EQ.ZERO ) THEN C C Eigenvalue is infinite. C IWORK( IS+J ) = 0 ELSE TMP = ( B( I, I ) - ( B( I+1, I ) / A( I+1, I+1 ) )* $ A( I, I+1 ) ) / A( I, I ) + $ B( I+1, I+1 ) / A( I+1, I+1 ) IF( TMP.EQ.ZERO ) THEN IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = INT( SIGN( ONE, TMP ) ) END IF END IF I = I + 2 END IF J = J + 1 GO TO 10 C C END WHILE 10 C END IF C IF( I.EQ.M ) THEN IWORK( J ) = I IF( ABS( A( I, I ) ).LE.TOL*NRMA .OR. $ ABS( B( I, I ) ).LE.TOL*NRMB ) THEN C C Eigenvalue is infinite or zero. C IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = INT( SIGN( ONE, A( I, I )*B( I, I ) ) ) END IF J = J + 1 END IF C R = J - 1 C C Initialize Q if appropriate. C IF( LINIQ ) THEN IUPD = M + 1 UPDS = M CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) ELSE IF( LUPDQ ) THEN IUPD = 1 UPDS = N END IF C IF( M.GT.1 ) THEN C C Save the lower triangle of the submatrix D(M-1:M,M-1:M) and the C elements A(M,M-1), F(M,M-1), which might be overwritten. C D1 = D( M-1, M-1 ) D2 = D( M, M-1 ) D3 = D( M, M ) A2 = A( M, M-1 ) F2 = F( M, M-1 ) END IF C C STEP 1: Reorder the eigenvalues in the subpencil aA - bB. C MM = 0 MP = J C C I. Reorder the eigenvalues with negative real parts to the top. C C Set pointers for the inputs and outputs of MB03DD. C IQ1 = 1 IQ2 = IQ1 + 16 IA = IQ2 + 16 IB = IA + 16 IWRK1 = IB + 16 IWRK2 = IA C K = 1 NP2 = N + 2 IB3 = M + 1 IWORK( R+1 ) = IB3 C C WHILE( K.LE.R ) DO C 20 CONTINUE IF( K.LE.R ) THEN IF( IWORK( IS+K ).LT.0 ) THEN ICOL = NP2 IF ( LCMPQ ) THEN IWORK( ICOL ) = MAX( 109, IWRK2 + 4*N ) ELSE IWORK( ICOL ) = MAX( 109, IWRK2 + 2*N ) END IF DO 30 J = K - 1, MM + 1, -1 C C IB1, IB2, and IB3 are pointers to 3 consecutive blocks. C IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and C B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD. C Also, set the additional zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ DWORK( IA+1 ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, $ DWORK( IB+1 ), SDIM+1 ) CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO, $ DWORK( IB+2 ), SDIM ) C C Perform eigenvalue/matrix block exchange. C Workspace: IWRK1 + 43 = 108. C CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ), $ SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM, $ DWORK( IQ2 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF C C Store data for blocked computations. C Workspace: MAX( 108, a*N+32 ) + 5*M, where C a = 2, if COMPQ = 'N'; C a = 4, if COMPQ <> 'N'. IWORK( ICOL+1 ) = IB1 IWORK( ICOL+2 ) = IB2 IWORK( ICOL+3 ) = IB3 IWORK( ICOL+4 ) = IWORK( ICOL ) + SDIM*SDIM CALL DLACPY( 'Full', SDIM, SDIM, DWORK( IQ2 ), SDIM, $ DWORK( IWORK( ICOL ) ), SDIM ) ICOL = ICOL + 4 C C Copy the transformed diagonal blocks, if sdim > 2. C NROWS = IB1 - 1 ICS = IB3 IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) ELSE CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ A( IB1, IB1 ), LDA, ZERO, DWORK( IA ), $ SDIM ) CALL DGEMM( 'No Transpose', 'No Transpose', SDIM, $ SDIM, SDIM, ONE, DWORK( IA ), SDIM, $ DWORK( IQ1 ), SDIM, ZERO, A( IB1, IB1 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ B( IB1, IB1 ), LDB, ZERO, DWORK( IB ), $ SDIM ) CALL DGEMM( 'No Transpose', 'No Transpose', SDIM, $ SDIM, SDIM, ONE, DWORK( IB ), SDIM, $ DWORK( IQ1 ), SDIM, ZERO, B( IB1, IB1 ), $ LDB ) END IF C IC = ICS LDW = MAX( 1, NROWS ) C C Update A. C Workspace: IWRK2 + 2*N - 1. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ A( 1, IB1 ), LDA ) C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ D( 1, IB1 ), LDD ) CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM, $ D( IB1, IB1 ), LDD, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) C C Update B. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK2 + 2*N - 1, if COMPQ = 'I'; C IWRK2 + 4*N - 1, if COMPQ = 'U'. C CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ, $ DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( IUPD, M+IB1 ), LDQ ) END IF C C Update index lists IWORK(1:M) and IWORK(M+2:N+1) if a C 1-by-1 and 2-by-2 block have been swapped. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF C C Update IWORK(M+2:N+1). C HLP = IWORK( IS+J ) IWORK( IS+J ) = IWORK( IS+J+1 ) IWORK( IS+J+1 ) = HLP 30 CONTINUE C C Panel Updates C C Update A. C ICOLS = NP2 JE = K - 1 C C WHILE( JE.GT.2 ) DO 40 CONTINUE IF( JE.GE.MM+1 ) THEN NCOL = 0 NC = 0 ICOL = ICOLS BLKUP = 0 JS = IWORK( ICOL+3 ) DO 50 J = JE, MM + 1, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, A( IWORK( ICOL+1 ), JS ), LDA, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IWORK( ICOL+1 ), JS ), LDA ) ICOL = ICOL + 4 NC = NC + DIM1 IF( NC.LE.NB ) THEN NCOL = NCOL+DIM1 JS = IWORK( ICOLS+3 ) - NCOL BLKUP = BLKUP+1 END IF 50 CONTINUE JE = JE - BLKUP ICOLS = ICOLS + 4*BLKUP GO TO 40 END IF C END WHILE 40 C DO 70 JS = IWORK( N+5 ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 60 J = K - 1, MM + 1, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, A( IWORK( ICOL+1 ), JS ), LDA, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IWORK( ICOL+1 ), JS ), LDA ) ICOL = ICOL + 4 60 CONTINUE 70 CONTINUE C C Update D. C ICOLS = NP2 JE = K - 1 C C WHILE( JE.GT.2 ) DO 80 CONTINUE IF( JE.GE.MM+1 ) THEN NCOL = 0 NC = 0 ICOL = ICOLS BLKUP = 0 JS = IWORK( ICOL+3 ) DO 90 J = JE, MM + 1, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, D( IWORK( ICOL+1 ), JS ), LDD, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ D( IWORK( ICOL+1 ), JS ), LDD ) ICOL = ICOL + 4 NC = NC + DIM1 IF( NC.LE.NB ) THEN NCOL = NCOL+DIM1 JS = IWORK( ICOLS+3 ) - NCOL BLKUP = BLKUP+1 END IF 90 CONTINUE JE = JE - BLKUP ICOLS = ICOLS + 4*BLKUP GO TO 80 END IF C END WHILE 80 C DO 110 JS = IWORK( N+5 ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 100 J = K - 1, MM + 1, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, D( IWORK( ICOL+1 ), JS ), LDD, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ D( IWORK( ICOL+1 ), JS ), LDD ) ICOL = ICOL + 4 100 CONTINUE 110 CONTINUE C C Update B. C ICOLS = NP2 JE = K - 1 C C WHILE( JE.GT.2 ) DO 120 CONTINUE IF( JE.GE.MM+1 ) THEN NCOL = 0 NC = 0 ICOL = ICOLS BLKUP = 0 JS = IWORK( ICOL+3 ) DO 130 J = JE, MM + 1, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, B( IWORK( ICOL+1 ), JS ), LDB, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IWORK( ICOL+1 ), JS ), LDB ) ICOL = ICOL + 4 NC = NC + DIM1 IF( NC.LE.NB ) THEN NCOL = NCOL+DIM1 JS = IWORK( ICOLS+3 ) - NCOL BLKUP = BLKUP+1 END IF 130 CONTINUE JE = JE - BLKUP ICOLS = ICOLS + 4*BLKUP GO TO 120 END IF C END WHILE 120 C DO 150 JS = IWORK( N+5 ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 140 J = K - 1, MM + 1, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, B( IWORK( ICOL+1 ), JS ), LDB, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IWORK( ICOL+1 ), JS ), LDB ) ICOL = ICOL + 4 140 CONTINUE 150 CONTINUE C C Update F. C ICOLS = NP2 JE = K - 1 C C WHILE( JE.GT.2 ) DO 160 CONTINUE IF( JE.GE.MM+1 ) THEN NCOL = 0 NC = 0 ICOL = ICOLS BLKUP = 0 JS = IWORK( ICOL+3 ) DO 170 J = JE, MM + 1, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, F( IWORK( ICOL+1 ), JS ), LDF, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ F( IWORK( ICOL+1 ), JS ), LDF ) ICOL = ICOL + 4 NC = NC + DIM1 IF( NC.LE.NB ) THEN NCOL = NCOL+DIM1 JS = IWORK( ICOLS+3 ) - NCOL BLKUP = BLKUP+1 END IF 170 CONTINUE JE = JE - BLKUP ICOLS = ICOLS + 4*BLKUP GO TO 160 END IF C END WHILE 160 C DO 190 JS = IWORK( N+5 ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 180 J = K - 1, MM + 1, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, F( IWORK( ICOL+1 ), JS ), LDF, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ F( IWORK( ICOL+1 ), JS ), LDF ) ICOL = ICOL + 4 180 CONTINUE 190 CONTINUE C MM = MM + 1 END IF K = K + 1 GO TO 20 C C END WHILE 20 C END IF C C II. Reorder the eigenvalues with positive real parts to the bottom. C K = R C C WHILE( K.GE.MM+1 ) DO C 200 CONTINUE IF( K.GE.MM + 1 ) THEN IF( IWORK( IS+K ).GT.0 ) THEN ICOL = NP2 IF ( LCMPQ ) THEN IWORK( ICOL ) = MAX( 109, IWRK2 + 4*N ) ELSE IWORK( ICOL ) = MAX( 109, IWRK2 + 2*N ) END IF NC = IWORK( MP ) DO 210 J = K, MP - 2 IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and C B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD. C Also, set the additional zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ DWORK( IA+1 ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, $ DWORK( IB+1 ), SDIM+1 ) CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO, $ DWORK( IB+2 ), SDIM ) C C Perform eigenvalue/matrix block exchange. C CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ), $ SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM, $ DWORK( IQ2 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF C C Store data for blocked computations. C IWORK( ICOL+1 ) = IB1 IWORK( ICOL+2 ) = IB2 IWORK( ICOL+3 ) = IB3 IWORK( ICOL+4 ) = IWORK( ICOL ) + SDIM*SDIM CALL DLACPY( 'Full', SDIM, SDIM, DWORK( IQ2 ), SDIM, $ DWORK( IWORK( ICOL ) ), SDIM ) ICOL = ICOL + 4 C C Copy the transformed diagonal blocks, if sdim > 2. C NROWS = IB1 - 1 ICS = IB3 IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) ELSE CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ A( IB1, IB1 ), LDA, ZERO, DWORK( IA ), $ SDIM ) CALL DGEMM( 'No Transpose', 'No Transpose', SDIM, $ SDIM, SDIM, ONE, DWORK( IA ), SDIM, $ DWORK( IQ1 ), SDIM, ZERO, A( IB1, IB1 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ B( IB1, IB1 ), LDB, ZERO, DWORK( IB ), $ SDIM ) CALL DGEMM( 'No Transpose', 'No Transpose', SDIM, $ SDIM, SDIM, ONE, DWORK( IB ), SDIM, $ DWORK( IQ1 ), SDIM, ZERO, B( IB1, IB1 ), $ LDB ) END IF C IC = ICS LDW = MAX( 1, NROWS ) C C Update A. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NC-IB3, $ SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IC ), $ LDA, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NC-IB3, DWORK( IWRK2 ), $ SDIM, A( IB1, IC ), LDA ) C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NC-IB3, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ D( IB1, ICS ), LDD, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NC-IB3, DWORK( IWRK2 ), $ SDIM, D( IB1, ICS ), LDD ) CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM, $ D( IB1, IB1 ), LDD, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) C C Update B. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NC-IB3, $ SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IC ), $ LDB, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NC-IB3, DWORK( IWRK2 ), $ SDIM, B( IB1, IC ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NC-IB3, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ F( IB1, ICS ), LDF, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NC-IB3, DWORK( IWRK2 ), $ SDIM, F( IB1, ICS ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ, $ DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( IUPD, M+IB1 ), LDQ ) END IF C C Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block C have been swapped. IWORK(M+2:N+1) is not needed anymore, C so it is not necessary to update it. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF 210 CONTINUE C C Panel Updates. C C Update A. C DO 230 JS = IWORK( MP ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 220 J = K, MP - 2 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, A( IWORK( ICOL+1 ), JS ), LDA, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IWORK( ICOL+1 ), JS ), LDA ) ICOL = ICOL + 4 220 CONTINUE 230 CONTINUE C C Update D. C DO 250 JS = IWORK( MP ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 240 J = K, MP - 2 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, D( IWORK( ICOL+1 ), JS ), LDD, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ D( IWORK( ICOL+1 ), JS ), LDD ) ICOL = ICOL + 4 240 CONTINUE 250 CONTINUE C C Update B. C DO 270 JS = IWORK( MP ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 260 J = K, MP - 2 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, B( IWORK( ICOL+1 ), JS ), LDB, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IWORK( ICOL+1 ), JS ), LDB ) ICOL = ICOL + 4 260 CONTINUE 270 CONTINUE C C Update F. C DO 290 JS = IWORK( MP ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 280 J = K, MP - 2 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), $ SDIM, F( IWORK( ICOL+1 ), JS ), LDF, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ F( IWORK( ICOL+1 ), JS ), LDF ) ICOL = ICOL + 4 280 CONTINUE 290 CONTINUE C MP = MP - 1 END IF K = K - 1 GO TO 200 C C END WHILE 200 C END IF C C STEP 2: Reorder the remaining eigenvalues with negative real parts. C C Set pointers for the inputs and outputs of MB03HD. C IQUPLE = 1 IAUPLE = IQUPLE + 16 IBUPLE = IAUPLE + 8 IWRK5 = IBUPLE + 8 IWRK3 = IAUPLE IWRK4 = IWRK3 + 2*N ITMP1 = IWRK3 + N ITMP2 = ITMP1 + 4 ITMP3 = ITMP2 + 4 C DO 470 K = R, MP, -1 C C I. Exchange the eigenvalues between two diagonal blocks. C IR = IWORK( R ) DIM1 = IWORK( R+1 ) - IR SDIM = 2*DIM1 C IF( DIM1.EQ.2 ) THEN A( M, IR ) = ZERO C C Build the (small) full skew-symmetric matrix D(M-1:M,M-1:M) C and the (small) symmetric matrix F(M-1:M,M-1:M). C D( IR, IR ) = ZERO D( M, IR ) = -D( IR, M ) D( M, M ) = ZERO F( M, IR ) = F( IR, M ) END IF C C Calculate position of submatrices in DWORK. C IBUPRI = IBUPLE + DIM1*DIM1 IQLOLE = IQUPLE + DIM1 IQUPRI = IQUPLE + DIM1*SDIM IQLORI = IQUPRI + DIM1 C C Generate input matrices for MB03HD built of submatrices of A, C D, B, and F. C IF( DIM1.EQ.2 ) THEN CALL DLACPY( 'Upper', DIM1, DIM1, A( IR, IR ), LDA, $ DWORK( IAUPLE ), DIM1 ) DWORK( IAUPLE+6 ) = D( IR, IR+1 ) CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB, $ DWORK( IBUPLE ), DIM1 ) CALL DLACPY( 'Upper', DIM1, DIM1, F( IR, IR ), LDF, $ DWORK( IBUPRI ), DIM1 ) ELSE DWORK( IBUPLE ) = B( IR, IR ) DWORK( IBUPRI ) = F( IR, IR ) END IF C C Perform eigenvalue exchange. C Workspace: IWRK5 + 23, if SDIM = 4. C CALL MB03HD( SDIM, DWORK( IAUPLE ), DIM1, DWORK( IBUPLE ), $ DIM1, PAR, DWORK( IQUPLE ), SDIM, DWORK( IWRK5 ), $ INFO ) IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C IF( DIM1.EQ.2 ) THEN C C Update A by transformations from the right. C Workspace: IWRK3 + N - 1. C CALL DLACPY( 'Full', M, DIM1, A( 1, IR ), LDA, $ DWORK( IWRK3 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM, $ ZERO, A( 1, IR ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, D( 1, IR ), LDD, DWORK( IQLOLE ), SDIM, $ ONE, A( 1, IR ), LDA ) C C Update D by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM, $ ZERO, DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, D( 1, IR ), LDD, DWORK( IQLORI ), SDIM, $ ONE, DWORK( ITMP1 ), M ) CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, D( 1, IR ), $ LDD ) C C Compute the intermediate product Af'*Q21 and the second C column of Af'*Q22, with Af = A(M-1:M,M-1:M). C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ), $ SDIM, ZERO, DWORK( ITMP1 ), DIM1 ) CALL DGEMV( 'Transpose', DIM1, DIM1, ONE, $ DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI+SDIM ), $ 1, ZERO, DWORK( ITMP2 ), 1 ) C C Update A by transformations from the left. C CALL DLACPY( 'Full', DIM1, DIM1, A( IR, IR ), LDA, $ DWORK( IWRK3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ -ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ), $ DIM1, ZERO, A( IR, IR ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQLORI ), SDIM, DWORK( IWRK3 ), $ DIM1, ONE, A( IR, IR ), LDA ) C C Update D by transformations from the left. C D( IR, M ) = DDOT( DIM1, DWORK( IQLORI ), 1, D( IR, M ), 1 ) $ - DDOT( DIM1, DWORK( IQUPRI ), 1, DWORK( ITMP2 ), $ 1 ) C C Update B by transformations from the right. C CALL DLACPY( 'Full', M, DIM1, B( 1, IR ), LDB, $ DWORK( IWRK3 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM, $ ZERO, B( 1, IR ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, F( 1, IR ), LDF, DWORK( IQLOLE ), SDIM, $ ONE, B( 1, IR ), LDB ) C C Update F by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM, $ ZERO, DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, F( 1, IR ), LDF, DWORK( IQLORI ), SDIM, $ ONE, DWORK( ITMP1 ), M ) CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, F( 1, IR ), $ LDF ) C C Compute intermediate products Bf'*Q21 and Bf'*Q22, with C Bf = B(M-1:M,M-1:M). C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ), $ SDIM, ZERO, DWORK( ITMP1 ), DIM1 ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI ), $ SDIM, ZERO, DWORK( ITMP2 ), DIM1 ) C C Update B by transformations from the left. C CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB, $ DWORK( ITMP3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ), $ DIM1, ZERO, B( IR, IR ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQLORI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, B( IR, IR ), LDB ) C C Update F by transformations from the left. C CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ZERO, $ ONE, DWORK( ITMP1 ), DIM1, DWORK( IQLORI ), $ SDIM, F( IR, IR ), LDF, INFO ) CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ONE, $ ONE, DWORK( ITMP1 ), DIM1, DWORK( IQUPRI ), $ SDIM, DWORK( ITMP2 ), DIM1, INFO ) CALL DLACPY( 'Upper', DIM1, DIM1, DWORK( ITMP1 ), DIM1, $ F( IR, IR ), LDF ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK4 + 2*N - 1. C CALL DLACPY( 'Full', N, DIM1, Q( 1, IR ), LDQ, $ DWORK( IWRK4 ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK4 ), N, $ DWORK( IQUPLE ), SDIM, ZERO, Q( 1, IR ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q( 1, M+IR ), LDQ, $ DWORK( IQLOLE ), SDIM, ONE, Q( 1, IR ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK4 ), N, $ DWORK( IQUPRI ), SDIM, ZERO, DWORK( IWRK3 ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q( 1, M+IR ), LDQ, $ DWORK( IQLORI ), SDIM, ONE, DWORK( IWRK3 ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( IWRK3 ), N, $ Q( 1, M+IR ), LDQ ) END IF ELSE Q11 = DWORK( IQUPLE ) Q21 = DWORK( IQLOLE ) Q12 = DWORK( IQUPRI ) Q22 = DWORK( IQLORI ) C C Update A by transformations from the right. C CALL DCOPY( M-1, A( 1, IR ), 1, DWORK( IWRK3 ), 1 ) CALL DSCAL( M-1, Q11, A( 1, IR ), 1 ) CALL DAXPY( M-1, Q21, D( 1, IR ), 1, A( 1, IR ), 1 ) C C Update D by transformations from the right. C CALL DSCAL( M-1, Q22, D( 1, IR ), 1 ) CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, D( 1, IR ), 1 ) C C Update B by transformations from the right. C CALL DCOPY( M-1, B( 1, IR ), 1, DWORK( IWRK3 ), 1 ) CALL DSCAL( M-1, Q11, B( 1, IR ), 1 ) CALL DAXPY( M-1, Q21, F( 1, IR ), 1, B( 1, IR ), 1 ) C C Update F by transformations from the right. C CALL DSCAL( M-1, Q22, F( 1, IR ), 1 ) CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, F( 1, IR ), 1 ) C C Update B by transformations from the left. C B( M, M ) = -B( M, M ) C IF( LCMPQ ) THEN C C Update Q. C CALL DCOPY( N, Q( 1, IR ), 1, DWORK( IWRK4 ), 1 ) CALL DSCAL( N, Q11, Q( 1, IR ), 1 ) CALL DAXPY( N, Q21, Q( 1, IR+M ), 1, Q( 1, IR ), 1 ) CALL DSCAL( N, Q22, Q( 1, IR+M ), 1 ) CALL DAXPY( N, Q12, DWORK( IWRK4 ), 1, Q( 1, IR+M ), 1 ) END IF C END IF C MM = MM + 1 C ICOL = NP2 IF ( LCMPQ ) THEN IWORK( ICOL ) = MAX( 109, IWRK2 + 4*N ) ELSE IWORK( ICOL ) = MAX( 109, IWRK2 + 2*N ) END IF DO 300 J = R - 1, MM, -1 IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and C B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD. C Also, set the additional zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ DWORK( IA+1 ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, DWORK( IB+1 ), $ SDIM+1 ) CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO, $ DWORK( IB+2 ), SDIM ) C C Perform eigenvalue/matrix block exchange. C CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ), $ SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM, $ DWORK( IQ2 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF C C Store data for blocked computations. C IWORK( ICOL+1 ) = IB1 IWORK( ICOL+2 ) = IB2 IWORK( ICOL+3 ) = IB3 IWORK( ICOL+4 ) = IWORK( ICOL ) + SDIM*SDIM CALL DLACPY( 'Full', SDIM, SDIM, DWORK( IQ2 ), SDIM, $ DWORK( IWORK( ICOL ) ), SDIM ) ICOL = ICOL + 4 C C Copy the transformed diagonal blocks, if sdim > 2. C NROWS = IB1 - 1 ICS = IB3 IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) ELSE CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM, $ SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IB1 ), $ LDA, ZERO, DWORK( IA ), SDIM ) CALL DGEMM( 'No Transpose', 'No Transpose', SDIM, SDIM, $ SDIM, ONE, DWORK( IA ), SDIM, DWORK( IQ1 ), $ SDIM, ZERO, A( IB1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, SDIM, $ SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IB1 ), $ LDB, ZERO, DWORK( IB ), SDIM ) CALL DGEMM( 'No Transpose', 'No Transpose', SDIM, SDIM, $ SDIM, ONE, DWORK( IB ), SDIM, DWORK( IQ1 ), $ SDIM, ZERO, B( IB1, IB1 ), LDB ) END IF IC = ICS LDW = MAX( 1, NROWS ) C C Update A. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ A( 1, IB1 ), LDA ) C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ D( 1, IB1 ), LDD ) CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM, $ D( IB1, IB1 ), LDD, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) C C Update B. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK2 + 4*N - 1. C CALL DGEMM( 'No Transpose', 'No Transpose', N, SDIM, $ SDIM, ONE, Q( 1, IB1 ), LDQ, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), N ) CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, SDIM, $ SDIM, ONE, Q( 1, M+IB1 ), LDQ, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), N ) CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N, $ Q( 1, M+IB1 ), LDQ ) END IF C C Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block C have been swapped. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 C ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF 300 CONTINUE C C Panel Updates C C Update A. C ICOLS = NP2 JE = R - 1 C C WHILE( JE.GT.2 ) DO 310 CONTINUE IF( JE.GE.MM ) THEN NCOL = 0 NC = 0 ICOL = ICOLS BLKUP = 0 JS = IWORK( ICOL+3 ) DO 320 J = JE, MM, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM, $ A( IWORK( ICOL+1 ), JS ), LDA, ZERO, $ DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IWORK( ICOL+1 ), JS ), LDA ) ICOL = ICOL + 4 NC = NC + DIM1 IF( NC.LE.NB ) THEN NCOL = NCOL+DIM1 JS = IWORK( ICOLS+3 ) - NCOL BLKUP = BLKUP+1 END IF 320 CONTINUE JE = JE - BLKUP ICOLS = ICOLS + 4*BLKUP GO TO 310 END IF C END WHILE 310 C DO 340 JS = IWORK( N+5 ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 330 J = R - 1, MM, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM, $ A( IWORK( ICOL+1 ), JS ), LDA, ZERO, $ DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IWORK( ICOL+1 ), JS ), LDA ) ICOL = ICOL + 4 330 CONTINUE 340 CONTINUE C C Update D. C ICOLS = NP2 JE = R - 1 C C WHILE( JE.GT.2 ) DO 350 CONTINUE IF( JE.GE.MM ) THEN NCOL = 0 NC = 0 ICOL = ICOLS BLKUP = 0 JS = IWORK( ICOL+3 ) DO 360 J = JE, MM, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM, $ D( IWORK( ICOL+1 ), JS ), LDD, ZERO, $ DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ D( IWORK( ICOL+1 ), JS ), LDD ) ICOL = ICOL + 4 NC = NC + DIM1 IF( NC.LE.NB ) THEN NCOL = NCOL+DIM1 JS = IWORK( ICOLS+3 ) - NCOL BLKUP = BLKUP+1 END IF 360 CONTINUE JE = JE - BLKUP ICOLS = ICOLS + 4*BLKUP GO TO 350 END IF C END WHILE 350 C DO 380 JS = IWORK( N+5 ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 370 J = R - 1, MM, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM, $ D( IWORK( ICOL+1 ), JS ), LDD, ZERO, $ DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ D( IWORK( ICOL+1 ), JS ), LDD ) ICOL = ICOL + 4 370 CONTINUE 380 CONTINUE C C Update B. C ICOLS = NP2 JE = R - 1 C C WHILE( JE.GT.2 ) DO 390 CONTINUE IF( JE.GE.MM ) THEN NCOL = 0 NC = 0 ICOL = ICOLS BLKUP = 0 JS = IWORK( ICOL+3 ) DO 400 J = JE, MM, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM, $ B( IWORK( ICOL+1 ), JS ), LDB, ZERO, $ DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IWORK( ICOL+1 ), JS ), LDB ) ICOL = ICOL + 4 NC = NC + DIM1 IF( NC.LE.NB ) THEN NCOL = NCOL+DIM1 JS = IWORK( ICOLS+3 ) - NCOL BLKUP = BLKUP+1 END IF 400 CONTINUE JE = JE - BLKUP ICOLS = ICOLS + 4*BLKUP GO TO 390 END IF C END WHILE 390 C DO 420 JS = IWORK( N+5 ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 410 J = R - 1, MM, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM, $ B( IWORK( ICOL+1 ), JS ), LDB, ZERO, $ DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IWORK( ICOL+1 ), JS ), LDB ) ICOL = ICOL + 4 410 CONTINUE 420 CONTINUE C C Update F. C ICOLS = NP2 JE = R - 1 C C WHILE( JE.GT.2 ) DO 430 CONTINUE IF( JE.GE.MM ) THEN NCOL = 0 NC = 0 ICOL = ICOLS BLKUP = 0 JS = IWORK( ICOL+3 ) DO 440 J = JE, MM, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM, $ F( IWORK( ICOL+1 ), JS ), LDF, ZERO, $ DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ F( IWORK( ICOL+1 ), JS ), LDF ) ICOL = ICOL + 4 NC = NC + DIM1 IF( NC.LE.NB ) THEN NCOL = NCOL+DIM1 JS = IWORK( ICOLS+3 ) - NCOL BLKUP = BLKUP+1 END IF 440 CONTINUE JE = JE - BLKUP ICOLS = ICOLS + 4*BLKUP GO TO 430 END IF C END WHILE 430 C DO 460 JS = IWORK( N+5 ), M, NB JE = MIN( M, JS+NB-1 ) NCOL = JE - JS + 1 ICOL = NP2 DO 450 J = R - 1, MM, -1 DIM1 = IWORK( ICOL+2 ) - IWORK( ICOL+1 ) DIM2 = IWORK( ICOL+3 ) - IWORK( ICOL+2 ) SDIM = DIM1 + DIM2 CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IWORK( ICOL ) ), SDIM, $ F( IWORK( ICOL+1 ), JS ), LDF, ZERO, $ DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ F( IWORK( ICOL+1 ), JS ), LDF ) ICOL = ICOL + 4 450 CONTINUE 460 CONTINUE C 470 CONTINUE C IF( M.GT.1 ) THEN C C Restore the lower triangle of the submatrix D(M-1:M,M-1:M) and C the elements A(M,M-1) and F(M,M-1). C D( M-1, M-1 ) = D1 D( M, M-1 ) = D2 D( M, M ) = D3 A( M, M-1 ) = A2 F( M, M-1 ) = F2 END IF C IF( MM.GT.0 ) THEN NEIG = IWORK( MM+1 ) - 1 ELSE NEIG = 0 END IF C RETURN C *** Last line of MB03JP *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01OD.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01OD.f0000644000175000017500000003147515012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE MB01OD( UPLO, TRANS, N, ALPHA, BETA, R, LDR, H, LDH, $ X, LDX, E, LDE, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the matrix formula C C R := alpha*R + beta*( op( H )*X*op( E )' + op( E )*X*op( H )' ), C C where alpha and beta are scalars, R and X are symmetric matrices, C H is an upper Hessenberg matrix, E is an upper triangular matrix, C and op( M ) is one of C C op( M ) = M or op( M ) = M'. 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( M ) to be used in the matrix C multiplication as follows: C = 'N': op( M ) = M; C = 'T': op( M ) = M'; C = 'C': op( M ) = M'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices R, H, E, and X. 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 H and X are not C referenced. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) C On entry with 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 R. C On entry with 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 R. C In both cases, the other strictly triangular part is not C referenced. C On exit, the leading N-by-N 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 the computed matrix R. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C H (input) DOUBLE PRECISION array, dimension (LDH,N) C On entry, the leading N-by-N upper Hessenberg part of this C array must contain the upper Hessenberg matrix H. C If TRANS = 'N', the entries 3, 4,..., N of the first C column are modified internally, but are restored on exit. C The remaining part of this array is not referenced. C C LDH INTEGER C The leading dimension of array H. LDH >= MAX(1,N). 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 E (input) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the upper triangular matrix E. C The remaining part of this array is not referenced. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C This array is not referenced when beta = 0, or N = 0. C C LDWORK The length of the array DWORK. C LDWORK >= N*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 = U + L, with U and L upper and C lower triangular matrices, defined by C C U = triu( X ) - (1/2)*diag( X ), C L = tril( X ) - (1/2)*diag( X ), C C where triu, tril, and diag denote the upper triangular part, lower C triangular part, and diagonal part of X, respectively. Then, C if UPLO = 'U', C C H*X*E' + E*X*H' = (H*U)*E' + E*(H*U)' + H*(E*U)' + (E*U)*H', C for TRANS = 'N', C H'*X*E + E'*X*H = H'*(U*E) + (U*E)'*H + (U*H)'*E + E'*(U*H), C for TRANS = 'T', or 'C', C C and if UPLO = 'L', C C H*X*E' + E*X*H' = (H*L')*E' + E*(H*L')' + H*(E*L')' + (E*L')*H', C for TRANS = 'N', C H'*X*E + E'*X*H = H'*(L'*E) + (L'*E)'*H + (L'*H)'*E + E'*(L'*H), C for TRANS = 'T', or 'C', C C which involve operations like in BLAS 2 and 3 (DTRMV and DSYR2K). C This approach ensures that the matrices H*U, U*H, H*L', or L'*H C are upper Hessenberg, and E*U, U*E, E*L', or L'*E are upper C triangular. C C NUMERICAL ASPECTS C C The algorithm requires approximately N**3/2 operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2019. 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, TWO, HALF PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ HALF = 0.5D0 ) C .. Scalar Arguments .. CHARACTER TRANS, UPLO INTEGER INFO, LDE, LDH, LDR, LDWORK, LDX, N DOUBLE PRECISION ALPHA, BETA C .. Array Arguments .. DOUBLE PRECISION DWORK(*), E(LDE,*), H(LDH,*), R(LDR,*), X(LDX,*) C .. Local Scalars .. LOGICAL LTRANS, LUPLO INTEGER I, J, J1 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DSCAL, DTRMV, $ MB01OE, 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( N.LT.0 ) THEN INFO = -3 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDH.LT.1 .OR. ( LTRANS .AND. LDH.LT.N ) .OR. $ ( .NOT.LTRANS .AND. LDH.LT.N ) ) THEN INFO = -9 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.N*N ) $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.0 ) ) THEN INFO = -13 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01OD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C IF ( BETA.EQ.ZERO ) THEN IF ( ALPHA.EQ.ZERO ) THEN C C Special case alpha = 0. C CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) ELSE C C Special case beta = 0. C IF ( ALPHA.NE.ONE ) $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, N, N, R, LDR, INFO ) END IF RETURN END IF C C General case: beta <> 0. C Compute W = H*U or W = U*H in DWORK, and apply the corresponding C updating formula (see METHOD section). C Workspace: need N*N. C CALL DSCAL( N, HALF, X, LDX+1 ) C IF ( .NOT.LTRANS ) THEN C C For convenience, swap the subdiagonal entries in H with C those in the first column, and finally restore them. C IF ( N.GT.2 ) $ CALL DSWAP( N-2, H(3,1), 1, H(3,2), LDH+1 ) C IF ( LUPLO ) THEN C DO 20 J = 1, N - 1 J1 = J + 1 CALL DCOPY( J, X(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, H, LDH, $ DWORK(1+(J-1)*N), 1 ) DO 10 I = 2, J DWORK(I+(J-1)*N) = DWORK(I+(J-1)*N) + H(I,1)*X(I-1,J) 10 CONTINUE DWORK(J1+(J-1)*N) = H(J1,1)*X(J,J) 20 CONTINUE C CALL DCOPY( N, X(1,N), 1, DWORK(1+(N-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', N, H, LDH, $ DWORK(1+(N-1)*N), 1 ) C DO 30 I = 2, N DWORK(I+(N-1)*N) = DWORK(I+(N-1)*N) + H(I,1)*X(I-1,N) 30 CONTINUE C ELSE C DO 50 J = 1, N - 1 J1 = J + 1 CALL DCOPY( J, X(J,1), LDX, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', J, H, LDH, $ DWORK(1+(J-1)*N), 1 ) DO 40 I = 2, J DWORK(I+(J-1)*N) = DWORK(I+(J-1)*N) + H(I,1)*X(J,I-1) 40 CONTINUE DWORK(J1+(J-1)*N) = H(J1,1)*X(J,J) 50 CONTINUE C CALL DCOPY( N, X(N,1), LDX, DWORK(1+(N-1)*N), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', N, H, LDH, $ DWORK(1+(N-1)*N), 1 ) C DO 60 I = 2, N DWORK(I+(N-1)*N) = DWORK(I+(N-1)*N) + H(I,1)*X(N,I-1) 60 CONTINUE C END IF C IF ( N.GT.2 ) $ CALL DSWAP( N-2, H(3,1), 1, H(3,2), LDH+1 ) C ELSE C IF ( LUPLO ) THEN C DO 70 J = 1, N - 1 J1 = J + 1 CALL DCOPY( J, H(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, X, LDX, $ DWORK(1+(J-1)*N), 1 ) CALL DAXPY( J, H(J1,J), X(1,J1), 1, DWORK(1+(J-1)*N), 1 ) DWORK(J1+(J-1)*N) = H(J1,J)*X(J1,J1) 70 CONTINUE C CALL DCOPY( N, H(1,N), 1, DWORK(1+(N-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', N, X, LDX, $ DWORK(1+(N-1)*N), 1 ) C ELSE C DO 80 J = 1, N - 1 J1 = J + 1 CALL DCOPY( J, H(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'Tran', 'NoDiag', J, X, LDX, $ DWORK(1+(J-1)*N), 1 ) CALL DAXPY( J, H(J1,J), X(J1,1), LDX, DWORK(1+(J-1)*N), $ 1 ) DWORK(J1+(J-1)*N) = H(J1,J)*X(J1,J1) 80 CONTINUE C CALL DCOPY( N, H(1,N), 1, DWORK(1+(N-1)*N), 1 ) CALL DTRMV( UPLO, 'Tran', 'NoDiag', N, X, LDX, $ DWORK(1+(N-1)*N), 1 ) C END IF C END IF C CALL MB01OE( UPLO, TRANS, N, ALPHA, BETA, R, LDR, DWORK, N, E, $ LDE ) C C Compute W = E*U or W = U*E in DWORK, and apply the corresponding C updating formula (see METHOD section). C Workspace: need N*N. C IF ( .NOT.LTRANS ) THEN C IF ( LUPLO ) THEN C DO 90 J = 1, N CALL DCOPY( J, X(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, E, LDE, $ DWORK(1+(J-1)*N), 1 ) 90 CONTINUE C ELSE C DO 100 J = 1, N CALL DCOPY( J, X(J,1), LDX, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', J, E, LDE, $ DWORK(1+(J-1)*N), 1 ) 100 CONTINUE C END IF C ELSE C IF ( LUPLO ) THEN C DO 110 J = 1, N CALL DCOPY( J, E(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, X, LDX, $ DWORK(1+(J-1)*N), 1 ) 110 CONTINUE C ELSE C DO 120 J = 1, N CALL DCOPY( J, E(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'Tran', 'NoDiag', J, X, LDX, $ DWORK(1+(J-1)*N), 1 ) 120 CONTINUE C END IF C END IF C CALL MB01OE( UPLO, TRANS, N, ONE, BETA, R, LDR, H, LDH, DWORK, $ N ) C CALL DSCAL( N, TWO, X, LDX+1 ) C RETURN C *** Last line of MB01OD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01VD.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01VD.f0000644000175000017500000013307515012430707017373 0ustar00lilgelilge00000000000000 SUBROUTINE MB01VD( TRANA, TRANB, MA, NA, MB, NB, ALPHA, BETA, $ A, LDA, B, LDB, C, LDC, MC, NC, INFO ) C C PURPOSE C C To perform the following matrix operation C C C = alpha*kron( op(A), op(B) ) + beta*C, C C where alpha and beta are real scalars, op(M) is either matrix M or C its transpose, M', and kron( X, Y ) denotes the Kronecker product C of the matrices X and Y. C C ARGUMENTS C C Mode Parameters C C TRANA CHARACTER*1 C Specifies the form of op(A) to be used as follows: C = 'N': op(A) = A; C = 'T': op(A) = A'; C = 'C': op(A) = A'. C C TRANB CHARACTER*1 C Specifies the form of op(B) to be used as follows: C = 'N': op(B) = B; C = 'T': op(B) = B'; C = 'C': op(B) = B'. C C Input/Output Parameters C C MA (input) INTEGER C The number of rows of the matrix op(A). MA >= 0. C C NA (input) INTEGER C The number of columns of the matrix op(A). NA >= 0. C C MB (input) INTEGER C The number of rows of the matrix op(B). MB >= 0. C C NB (input) INTEGER C The number of columns of the matrix op(B). NB >= 0. C C ALPHA (input) DOUBLE PRECISION C The scalar alpha. When alpha is zero then A and B need not C be set before entry. C C BETA (input) DOUBLE PRECISION C The scalar beta. When beta is zero then C need not be C set before entry. C C A (input) DOUBLE PRECISION array, dimension (LDA,ka), C where ka is NA when TRANA = 'N', and is MA otherwise. C If TRANA = 'N', the leading MA-by-NA part of this array C must contain the matrix A; otherwise, the leading NA-by-MA C part of this array must contain the matrix A. C C LDA INTEGER C The leading dimension of the array A. C LDA >= max(1,MA), if TRANA = 'N'; C LDA >= max(1,NA), if TRANA = 'T' or 'C'. C C B (input) DOUBLE PRECISION array, dimension (LDB,kb) C where kb is NB when TRANB = 'N', and is MB otherwise. C If TRANB = 'N', the leading MB-by-NB part of this array C must contain the matrix B; otherwise, the leading NB-by-MB C part of this array must contain the matrix B. C C LDB INTEGER C The leading dimension of the array B. C LDB >= max(1,MB), if TRANB = 'N'; C LDB >= max(1,NB), if TRANB = 'T' or 'C'. C C C (input/output) DOUBLE PRECISION array, dimension (LDC,NC) C On entry, if beta is nonzero, the leading MC-by-NC part of C this array must contain the given matric C, where C MC = MA*MB and NC = NA*NB. C On exit, the leading MC-by-NC part of this array contains C the computed matrix expression C C = alpha*kron( op(A), op(B) ) + beta*C. C C LDC INTEGER C The leading dimension of the array C. C LDC >= max(1,MC). C C MC (output) INTEGER C The number of rows of the matrix C. MC = MA*MB. C C NC (output) INTEGER C The number of columns of the matrix C. NC = NA*NB. 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 Kronecker product of the matrices op(A) and op(B) is computed C column by column. C C FURTHER COMMENTS C C The multiplications by zero elements in A are avoided, if the C matrix A is considered to be sparse, i.e., if C (number of zeros in A)/(MA*NA) >= SPARST = 0.8. The code makes C NB+1 passes through the matrix A, and MA*NA passes through the C matrix B. If LDA and/or LDB are very large, and op(A) = A' and/or C op(B) = B', it could be more efficient to transpose A and/or B C before calling this routine, and use the 'N' values for TRANA C and/or TRANB. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, February 2000. 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 ) DOUBLE PRECISION SPARST PARAMETER ( SPARST = 0.8D0 ) C .. Scalar Arguments .. CHARACTER TRANA, TRANB INTEGER INFO, LDA, LDB, LDC, MA, MB, MC, NA, NB, NC DOUBLE PRECISION ALPHA, BETA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) C .. Local Scalars .. LOGICAL SPARSE, TRANSA, TRANSB INTEGER I, IC, J, JC, K, L, LC, NZ DOUBLE PRECISION AIJ C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLASET, DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C C .. Executable Statements .. C C Test the input scalar arguments. C TRANSA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) TRANSB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) MC = MA*MB INFO = 0 IF( .NOT.( TRANSA .OR. LSAME( TRANA, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( TRANSB .OR. LSAME( TRANB, 'N' ) ) ) THEN INFO = -2 ELSE IF( MA.LT.0 ) THEN INFO = -3 ELSE IF( NA.LT.0 ) THEN INFO = -4 ELSE IF( MB.LT.0 ) THEN INFO = -5 ELSE IF( NB.LT.0 ) THEN INFO = -6 ELSE IF( ( TRANSA .AND. LDA.LT.NA ) .OR. LDA.LT.1 .OR. $ ( .NOT.TRANSA .AND. LDA.LT.MA ) ) THEN INFO = -10 ELSE IF( ( TRANSB .AND. LDB.LT.NB ) .OR. LDB.LT.1 .OR. $ ( .NOT.TRANSB .AND. LDB.LT.MB ) ) THEN INFO = -12 ELSE IF( LDC.LT.MAX( 1, MC ) ) THEN INFO = -14 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01VD', -INFO ) RETURN END IF C C Quick return, if possible. C NC = NA*NB IF ( MC.EQ.0 .OR. NC.EQ.0 ) $ RETURN C IF ( ALPHA.EQ.ZERO ) THEN IF ( BETA.EQ.ZERO ) THEN CALL DLASET( 'Full', MC, NC, ZERO, ZERO, C, LDC ) ELSE IF ( BETA.NE.ONE ) THEN C DO 10 J = 1, NC CALL DSCAL( MC, BETA, C(1,J), 1 ) 10 CONTINUE C END IF RETURN END IF C DUM(1) = ZERO JC = 1 NZ = 0 C C Compute the Kronecker product of the matrices op(A) and op(B), C C = alpha*kron( op(A), op(B) ) + beta*C. C First, check if A is sparse. Here, A is considered as being sparse C if (number of zeros in A)/(MA*NA) >= SPARST. C DO 30 J = 1, NA C DO 20 I = 1, MA IF ( TRANSA ) THEN IF ( A(J,I).EQ.ZERO ) $ NZ = NZ + 1 ELSE IF ( A(I,J).EQ.ZERO ) $ NZ = NZ + 1 END IF 20 CONTINUE C 30 CONTINUE C SPARSE = DBLE( NZ )/DBLE( MA*NA ).GE.SPARST C IF ( .NOT.TRANSA .AND. .NOT.TRANSB ) THEN C C Case op(A) = A and op(B) = B. C IF ( BETA.EQ.ZERO ) THEN IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta = 0, alpha = 1, A sparse. C DO 80 J = 1, NA C DO 70 K = 1, NB IC = 1 C DO 60 I = 1, MA AIJ = A(I,J) IF ( AIJ.EQ.ZERO ) THEN CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) ELSE IF ( AIJ.EQ.ONE ) THEN CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) ELSE LC = IC C DO 50 L = 1, MB C(LC,JC) = AIJ*B(L,K) LC = LC + 1 50 CONTINUE C END IF IC = IC + MB 60 CONTINUE C JC = JC + 1 70 CONTINUE C 80 CONTINUE C ELSE C C Case beta = 0, alpha = 1, A not sparse. C DO 120 J = 1, NA C DO 110 K = 1, NB IC = 1 C DO 100 I = 1, MA AIJ = A(I,J) LC = IC C DO 90 L = 1, MB C(LC,JC) = AIJ*B(L,K) LC = LC + 1 90 CONTINUE C IC = IC + MB 100 CONTINUE C JC = JC + 1 110 CONTINUE C 120 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta = 0, alpha <> 1, A sparse. C DO 160 J = 1, NA C DO 150 K = 1, NB IC = 1 C DO 140 I = 1, MA AIJ = ALPHA*A(I,J) IF ( AIJ.EQ.ZERO ) THEN CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) ELSE LC = IC C DO 130 L = 1, MB C(LC,JC) = AIJ*B(L,K) LC = LC + 1 130 CONTINUE C END IF IC = IC + MB 140 CONTINUE C JC = JC + 1 150 CONTINUE C 160 CONTINUE C ELSE C C Case beta = 0, alpha <> 1, A not sparse. C DO 200 J = 1, NA C DO 190 K = 1, NB IC = 1 C DO 180 I = 1, MA AIJ = ALPHA*A(I,J) LC = IC C DO 170 L = 1, MB C(LC,JC) = AIJ*B(L,K) LC = LC + 1 170 CONTINUE C IC = IC + MB 180 CONTINUE C JC = JC + 1 190 CONTINUE C 200 CONTINUE C END IF END IF ELSE IF ( BETA.EQ.ONE ) THEN IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta = 1, alpha = 1, A sparse. C DO 240 J = 1, NA C DO 230 K = 1, NB IC = 1 C DO 220 I = 1, MA AIJ = A(I,J) IF ( AIJ.NE.ZERO ) THEN LC = IC C DO 210 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(L,K) LC = LC + 1 210 CONTINUE C END IF IC = IC + MB 220 CONTINUE C JC = JC + 1 230 CONTINUE C 240 CONTINUE C ELSE C C Case beta = 1, alpha = 1, A not sparse. C DO 280 J = 1, NA C DO 270 K = 1, NB IC = 1 C DO 260 I = 1, MA AIJ = A(I,J) LC = IC C DO 250 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(L,K) LC = LC + 1 250 CONTINUE C IC = IC + MB 260 CONTINUE C JC = JC + 1 270 CONTINUE C 280 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta = 1, alpha <> 1, A sparse. C DO 320 J = 1, NA C DO 310 K = 1, NB IC = 1 C DO 300 I = 1, MA AIJ = ALPHA*A(I,J) IF ( AIJ.NE.ZERO ) THEN LC = IC C DO 290 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(L,K) LC = LC + 1 290 CONTINUE C END IF IC = IC + MB 300 CONTINUE C JC = JC + 1 310 CONTINUE C 320 CONTINUE C ELSE C C Case beta = 1, alpha <> 1, A not sparse. C DO 360 J = 1, NA C DO 350 K = 1, NB IC = 1 C DO 340 I = 1, MA AIJ = ALPHA*A(I,J) LC = IC C DO 330 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(L,K) LC = LC + 1 330 CONTINUE C IC = IC + MB 340 CONTINUE C JC = JC + 1 350 CONTINUE C 360 CONTINUE C END IF END IF ELSE IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta <> 0 or 1, alpha = 1, A sparse. C DO 400 J = 1, NA C DO 390 K = 1, NB IC = 1 C DO 380 I = 1, MA AIJ = A(I,J) C IF ( AIJ.EQ.ZERO ) THEN CALL DSCAL( MB, BETA, C(IC,JC), 1 ) ELSE LC = IC C DO 370 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) LC = LC + 1 370 CONTINUE C END IF IC = IC + MB 380 CONTINUE C JC = JC + 1 390 CONTINUE C 400 CONTINUE C ELSE C C Case beta <> 0 or 1, alpha = 1, A not sparse. C DO 440 J = 1, NA C DO 430 K = 1, NB IC = 1 C DO 420 I = 1, MA AIJ = A(I,J) LC = IC C DO 410 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) LC = LC + 1 410 CONTINUE C IC = IC + MB 420 CONTINUE C JC = JC + 1 430 CONTINUE C 440 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta <> 0 or 1, alpha <> 1, A sparse. C DO 480 J = 1, NA C DO 470 K = 1, NB IC = 1 C DO 460 I = 1, MA AIJ = ALPHA*A(I,J) C IF ( AIJ.EQ.ZERO ) THEN CALL DSCAL( MB, BETA, C(IC,JC), 1 ) ELSE LC = IC C DO 450 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) LC = LC + 1 450 CONTINUE C END IF IC = IC + MB 460 CONTINUE C JC = JC + 1 470 CONTINUE C 480 CONTINUE C ELSE C C Case beta <> 0 or 1, alpha <> 1, A not sparse. C DO 520 J = 1, NA C DO 510 K = 1, NB IC = 1 C DO 500 I = 1, MA AIJ = ALPHA*A(I,J) LC = IC C DO 490 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) LC = LC + 1 490 CONTINUE C IC = IC + MB 500 CONTINUE C JC = JC + 1 510 CONTINUE C 520 CONTINUE C END IF END IF END IF ELSE IF ( TRANSA .AND. .NOT.TRANSB ) THEN C C Case op(A) = A' and op(B) = B. C IF ( BETA.EQ.ZERO ) THEN IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta = 0, alpha = 1, A sparse. C DO 560 J = 1, NA C DO 550 K = 1, NB IC = 1 C DO 540 I = 1, MA AIJ = A(J,I) IF ( AIJ.EQ.ZERO ) THEN CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) ELSE IF ( AIJ.EQ.ONE ) THEN CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) ELSE LC = IC C DO 530 L = 1, MB C(LC,JC) = AIJ*B(L,K) LC = LC + 1 530 CONTINUE C END IF IC = IC + MB 540 CONTINUE C JC = JC + 1 550 CONTINUE C 560 CONTINUE C ELSE C C Case beta = 0, alpha = 1, A not sparse. C DO 600 J = 1, NA C DO 590 K = 1, NB IC = 1 C DO 580 I = 1, MA AIJ = A(J,I) LC = IC C DO 570 L = 1, MB C(LC,JC) = AIJ*B(L,K) LC = LC + 1 570 CONTINUE C IC = IC + MB 580 CONTINUE C JC = JC + 1 590 CONTINUE C 600 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta = 0, alpha <> 1, A sparse. C DO 640 J = 1, NA C DO 630 K = 1, NB IC = 1 C DO 620 I = 1, MA AIJ = ALPHA*A(J,I) IF ( AIJ.EQ.ZERO ) THEN CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) ELSE LC = IC C DO 610 L = 1, MB C(LC,JC) = AIJ*B(L,K) LC = LC + 1 610 CONTINUE C END IF IC = IC + MB 620 CONTINUE C JC = JC + 1 630 CONTINUE C 640 CONTINUE C ELSE C C Case beta = 0, alpha <> 1, A not sparse. C DO 680 J = 1, NA C DO 670 K = 1, NB IC = 1 C DO 660 I = 1, MA AIJ = ALPHA*A(J,I) LC = IC C DO 650 L = 1, MB C(LC,JC) = AIJ*B(L,K) LC = LC + 1 650 CONTINUE C IC = IC + MB 660 CONTINUE C JC = JC + 1 670 CONTINUE C 680 CONTINUE C END IF END IF ELSE IF ( BETA.EQ.ONE ) THEN IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta = 1, alpha = 1, A sparse. C DO 720 J = 1, NA C DO 710 K = 1, NB IC = 1 C DO 700 I = 1, MA AIJ = A(J,I) IF ( AIJ.NE.ZERO ) THEN LC = IC C DO 690 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(L,K) LC = LC + 1 690 CONTINUE C END IF IC = IC + MB 700 CONTINUE C JC = JC + 1 710 CONTINUE C 720 CONTINUE C ELSE C C Case beta = 1, alpha = 1, A not sparse. C DO 760 J = 1, NA C DO 750 K = 1, NB IC = 1 C DO 740 I = 1, MA AIJ = A(J,I) LC = IC C DO 730 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(L,K) LC = LC + 1 730 CONTINUE C IC = IC + MB 740 CONTINUE C JC = JC + 1 750 CONTINUE C 760 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta = 1, alpha <> 1, A sparse. C DO 800 J = 1, NA C DO 790 K = 1, NB IC = 1 C DO 780 I = 1, MA AIJ = ALPHA*A(J,I) IF ( AIJ.NE.ZERO ) THEN LC = IC C DO 770 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(L,K) LC = LC + 1 770 CONTINUE C END IF IC = IC + MB 780 CONTINUE C JC = JC + 1 790 CONTINUE C 800 CONTINUE C ELSE C C Case beta = 1, alpha <> 1, A not sparse. C DO 840 J = 1, NA C DO 830 K = 1, NB IC = 1 C DO 820 I = 1, MA AIJ = ALPHA*A(J,I) LC = IC C DO 810 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(L,K) LC = LC + 1 810 CONTINUE C IC = IC + MB 820 CONTINUE C JC = JC + 1 830 CONTINUE C 840 CONTINUE C END IF END IF ELSE IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta <> 0 or 1, alpha = 1, A sparse. C DO 880 J = 1, NA C DO 870 K = 1, NB IC = 1 C DO 860 I = 1, MA AIJ = A(J,I) C IF ( AIJ.EQ.ZERO ) THEN CALL DSCAL( MB, BETA, C(IC,JC), 1 ) ELSE LC = IC C DO 850 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) LC = LC + 1 850 CONTINUE C END IF IC = IC + MB 860 CONTINUE C JC = JC + 1 870 CONTINUE C 880 CONTINUE C ELSE C C Case beta <> 0 or 1, alpha = 1, A not sparse. C DO 920 J = 1, NA C DO 910 K = 1, NB IC = 1 C DO 900 I = 1, MA AIJ = A(J,I) LC = IC C DO 890 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) LC = LC + 1 890 CONTINUE C IC = IC + MB 900 CONTINUE C JC = JC + 1 910 CONTINUE C 920 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta <> 0 or 1, alpha <> 1, A sparse. C DO 960 J = 1, NA C DO 950 K = 1, NB IC = 1 C DO 940 I = 1, MA AIJ = ALPHA*A(J,I) C IF ( AIJ.EQ.ZERO ) THEN CALL DSCAL( MB, BETA, C(IC,JC), 1 ) ELSE LC = IC C DO 930 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) LC = LC + 1 930 CONTINUE C END IF IC = IC + MB 940 CONTINUE C JC = JC + 1 950 CONTINUE C 960 CONTINUE C ELSE C C Case beta <> 0 or 1, alpha <> 1, A not sparse. C DO 1000 J = 1, NA C DO 990 K = 1, NB IC = 1 C DO 980 I = 1, MA AIJ = ALPHA*A(J,I) LC = IC C DO 970 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) LC = LC + 1 970 CONTINUE C IC = IC + MB 980 CONTINUE C JC = JC + 1 990 CONTINUE C 1000 CONTINUE C END IF END IF END IF ELSE IF ( TRANSB .AND. .NOT.TRANSA ) THEN C C Case op(A) = A and op(B) = B'. C IF ( BETA.EQ.ZERO ) THEN IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta = 0, alpha = 1, A sparse. C DO 1080 J = 1, NA C DO 1070 K = 1, NB IC = 1 C DO 1060 I = 1, MA AIJ = A(I,J) IF ( AIJ.EQ.ZERO ) THEN CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) ELSE IF ( AIJ.EQ.ONE ) THEN CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) ELSE LC = IC C DO 1050 L = 1, MB C(LC,JC) = AIJ*B(K,L) LC = LC + 1 1050 CONTINUE C END IF IC = IC + MB 1060 CONTINUE C JC = JC + 1 1070 CONTINUE C 1080 CONTINUE C ELSE C C Case beta = 0, alpha = 1, A not sparse. C DO 1120 J = 1, NA C DO 1110 K = 1, NB IC = 1 C DO 1100 I = 1, MA AIJ = A(I,J) LC = IC C DO 1090 L = 1, MB C(LC,JC) = AIJ*B(K,L) LC = LC + 1 1090 CONTINUE C IC = IC + MB 1100 CONTINUE C JC = JC + 1 1110 CONTINUE C 1120 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta = 0, alpha <> 1, A sparse. C DO 1160 J = 1, NA C DO 1150 K = 1, NB IC = 1 C DO 1140 I = 1, MA AIJ = ALPHA*A(I,J) IF ( AIJ.EQ.ZERO ) THEN CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) ELSE LC = IC C DO 1130 L = 1, MB C(LC,JC) = AIJ*B(K,L) LC = LC + 1 1130 CONTINUE C END IF IC = IC + MB 1140 CONTINUE C JC = JC + 1 1150 CONTINUE C 1160 CONTINUE C ELSE C C Case beta = 0, alpha <> 1, A not sparse. C DO 1200 J = 1, NA C DO 1190 K = 1, NB IC = 1 C DO 1180 I = 1, MA AIJ = ALPHA*A(I,J) LC = IC C DO 1170 L = 1, MB C(LC,JC) = AIJ*B(K,L) LC = LC + 1 1170 CONTINUE C IC = IC + MB 1180 CONTINUE C JC = JC + 1 1190 CONTINUE C 1200 CONTINUE C END IF END IF ELSE IF ( BETA.EQ.ONE ) THEN IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta = 1, alpha = 1, A sparse. C DO 1240 J = 1, NA C DO 1230 K = 1, NB IC = 1 C DO 1220 I = 1, MA AIJ = A(I,J) IF ( AIJ.NE.ZERO ) THEN LC = IC C DO 1210 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1210 CONTINUE C END IF IC = IC + MB 1220 CONTINUE C JC = JC + 1 1230 CONTINUE C 1240 CONTINUE C ELSE C C Case beta = 1, alpha = 1, A not sparse. C DO 1280 J = 1, NA C DO 1270 K = 1, NB IC = 1 C DO 1260 I = 1, MA AIJ = A(I,J) LC = IC C DO 1250 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1250 CONTINUE C IC = IC + MB 1260 CONTINUE C JC = JC + 1 1270 CONTINUE C 1280 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta = 1, alpha <> 1, A sparse. C DO 1320 J = 1, NA C DO 1310 K = 1, NB IC = 1 C DO 1300 I = 1, MA AIJ = ALPHA*A(I,J) IF ( AIJ.NE.ZERO ) THEN LC = IC C DO 1290 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1290 CONTINUE C END IF IC = IC + MB 1300 CONTINUE C JC = JC + 1 1310 CONTINUE C 1320 CONTINUE C ELSE C C Case beta = 1, alpha <> 1, A not sparse. C DO 1360 J = 1, NA C DO 1350 K = 1, NB IC = 1 C DO 1340 I = 1, MA AIJ = ALPHA*A(I,J) LC = IC C DO 1330 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1330 CONTINUE C IC = IC + MB 1340 CONTINUE C JC = JC + 1 1350 CONTINUE C 1360 CONTINUE C END IF END IF ELSE IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta <> 0 or 1, alpha = 1, A sparse. C DO 1400 J = 1, NA C DO 1390 K = 1, NB IC = 1 C DO 1380 I = 1, MA AIJ = A(I,J) C IF ( AIJ.EQ.ZERO ) THEN CALL DSCAL( MB, BETA, C(IC,JC), 1 ) ELSE LC = IC C DO 1370 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1370 CONTINUE C END IF IC = IC + MB 1380 CONTINUE C JC = JC + 1 1390 CONTINUE C 1400 CONTINUE C ELSE C C Case beta <> 0 or 1, alpha = 1, A not sparse. C DO 1440 J = 1, NA C DO 1430 K = 1, NB IC = 1 C DO 1420 I = 1, MA AIJ = A(I,J) LC = IC C DO 1410 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1410 CONTINUE C IC = IC + MB 1420 CONTINUE C JC = JC + 1 1430 CONTINUE C 1440 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta <> 0 or 1, alpha <> 1, A sparse. C DO 1480 J = 1, NA C DO 1470 K = 1, NB IC = 1 C DO 1460 I = 1, MA AIJ = ALPHA*A(I,J) C IF ( AIJ.EQ.ZERO ) THEN CALL DSCAL( MB, BETA, C(IC,JC), 1 ) ELSE LC = IC C DO 1450 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1450 CONTINUE C END IF IC = IC + MB 1460 CONTINUE C JC = JC + 1 1470 CONTINUE C 1480 CONTINUE C ELSE C C Case beta <> 0 or 1, alpha <> 1, A not sparse. C DO 1520 J = 1, NA C DO 1510 K = 1, NB IC = 1 C DO 1500 I = 1, MA AIJ = ALPHA*A(I,J) LC = IC C DO 1490 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1490 CONTINUE C IC = IC + MB 1500 CONTINUE C JC = JC + 1 1510 CONTINUE C 1520 CONTINUE C END IF END IF END IF ELSE C C Case op(A) = A' and op(B) = B'. C IF ( BETA.EQ.ZERO ) THEN IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta = 0, alpha = 1, A sparse. C DO 1580 J = 1, NA C DO 1570 K = 1, NB IC = 1 C DO 1560 I = 1, MA AIJ = A(J,I) IF ( AIJ.EQ.ZERO ) THEN CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) ELSE IF ( AIJ.EQ.ONE ) THEN CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) ELSE LC = IC C DO 1550 L = 1, MB C(LC,JC) = AIJ*B(K,L) LC = LC + 1 1550 CONTINUE C END IF IC = IC + MB 1560 CONTINUE C JC = JC + 1 1570 CONTINUE C 1580 CONTINUE C ELSE C C Case beta = 0, alpha = 1, A not sparse. C DO 1620 J = 1, NA C DO 1610 K = 1, NB IC = 1 C DO 1600 I = 1, MA AIJ = A(J,I) LC = IC C DO 1590 L = 1, MB C(LC,JC) = AIJ*B(K,L) LC = LC + 1 1590 CONTINUE C IC = IC + MB 1600 CONTINUE C JC = JC + 1 1610 CONTINUE C 1620 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta = 0, alpha <> 1, A sparse. C DO 1660 J = 1, NA C DO 1650 K = 1, NB IC = 1 C DO 1640 I = 1, MA AIJ = ALPHA*A(J,I) IF ( AIJ.EQ.ZERO ) THEN CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) ELSE LC = IC C DO 1630 L = 1, MB C(LC,JC) = AIJ*B(K,L) LC = LC + 1 1630 CONTINUE C END IF IC = IC + MB 1640 CONTINUE C JC = JC + 1 1650 CONTINUE C 1660 CONTINUE C ELSE C C Case beta = 0, alpha <> 1, A not sparse. C DO 1700 J = 1, NA C DO 1690 K = 1, NB IC = 1 C DO 1680 I = 1, MA AIJ = ALPHA*A(J,I) LC = IC C DO 1670 L = 1, MB C(LC,JC) = AIJ*B(K,L) LC = LC + 1 1670 CONTINUE C IC = IC + MB 1680 CONTINUE C JC = JC + 1 1690 CONTINUE C 1700 CONTINUE C END IF END IF ELSE IF ( BETA.EQ.ONE ) THEN IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta = 1, alpha = 1, A sparse. C DO 1740 J = 1, NA C DO 1730 K = 1, NB IC = 1 C DO 1720 I = 1, MA AIJ = A(J,I) IF ( AIJ.NE.ZERO ) THEN LC = IC C DO 1710 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1710 CONTINUE C END IF IC = IC + MB 1720 CONTINUE C JC = JC + 1 1730 CONTINUE C 1740 CONTINUE C ELSE C C Case beta = 1, alpha = 1, A not sparse. C DO 1780 J = 1, NA C DO 1770 K = 1, NB IC = 1 C DO 1760 I = 1, MA AIJ = A(J,I) LC = IC C DO 1750 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1750 CONTINUE C IC = IC + MB 1760 CONTINUE C JC = JC + 1 1770 CONTINUE C 1780 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta = 1, alpha <> 1, A sparse. C DO 1820 J = 1, NA C DO 1810 K = 1, NB IC = 1 C DO 1800 I = 1, MA AIJ = ALPHA*A(J,I) IF ( AIJ.NE.ZERO ) THEN LC = IC C DO 1790 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1790 CONTINUE C END IF IC = IC + MB 1800 CONTINUE C JC = JC + 1 1810 CONTINUE C 1820 CONTINUE C ELSE C C Case beta = 1, alpha <> 1, A not sparse. C DO 1860 J = 1, NA C DO 1850 K = 1, NB IC = 1 C DO 1840 I = 1, MA AIJ = ALPHA*A(J,I) LC = IC C DO 1830 L = 1, MB C(LC,JC) = C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1830 CONTINUE C IC = IC + MB 1840 CONTINUE C JC = JC + 1 1850 CONTINUE C 1860 CONTINUE C END IF END IF ELSE IF ( ALPHA.EQ.ONE ) THEN IF ( SPARSE ) THEN C C Case beta <> 0 or 1, alpha = 1, A sparse. C DO 1900 J = 1, NA C DO 1890 K = 1, NB IC = 1 C DO 1880 I = 1, MA AIJ = A(J,I) C IF ( AIJ.EQ.ZERO ) THEN CALL DSCAL( MB, BETA, C(IC,JC), 1 ) ELSE LC = IC C DO 1870 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1870 CONTINUE C END IF IC = IC + MB 1880 CONTINUE C JC = JC + 1 1890 CONTINUE C 1900 CONTINUE C ELSE C C Case beta <> 0 or 1, alpha = 1, A not sparse. C DO 1940 J = 1, NA C DO 1930 K = 1, NB IC = 1 C DO 1920 I = 1, MA AIJ = A(J,I) LC = IC C DO 1910 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1910 CONTINUE C IC = IC + MB 1920 CONTINUE C JC = JC + 1 1930 CONTINUE C 1940 CONTINUE C END IF ELSE IF ( SPARSE ) THEN C C Case beta <> 0 or 1, alpha <> 1, A sparse. C DO 1980 J = 1, NA C DO 1970 K = 1, NB IC = 1 C DO 1960 I = 1, MA AIJ = ALPHA*A(J,I) C IF ( AIJ.EQ.ZERO ) THEN CALL DSCAL( MB, BETA, C(IC,JC), 1 ) ELSE LC = IC C DO 1950 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1950 CONTINUE C END IF IC = IC + MB 1960 CONTINUE C JC = JC + 1 1970 CONTINUE C 1980 CONTINUE C ELSE C C Case beta <> 0 or 1, alpha <> 1, A not sparse. C DO 2020 J = 1, NA C DO 2010 K = 1, NB IC = 1 C DO 2000 I = 1, MA AIJ = ALPHA*A(J,I) LC = IC C DO 1990 L = 1, MB C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) LC = LC + 1 1990 CONTINUE C IC = IC + MB 2000 CONTINUE C JC = JC + 1 2010 CONTINUE C 2020 CONTINUE C END IF END IF END IF END IF RETURN C *** Last line of MB01VD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02RD.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02RD.f0000644000175000017500000001171415012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE MB02RD( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) C C PURPOSE C C To solve a system of linear equations C H * X = B or H' * X = B C with an upper Hessenberg N-by-N matrix H using the LU C factorization computed by MB02SD. C C ARGUMENTS C C Mode Parameters C C TRANS CHARACTER*1 C Specifies the form of the system of equations: C = 'N': H * X = B (No transpose) C = 'T': H'* X = B (Transpose) C = 'C': H'* X = B (Conjugate transpose = Transpose) C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix H. N >= 0. C C NRHS (input) INTEGER C The number of right hand sides, i.e., the number of C columns of the matrix B. NRHS >= 0. C C H (input) DOUBLE PRECISION array, dimension (LDH,N) C The factors L and U from the factorization H = P*L*U C as computed by MB02SD. C C LDH INTEGER C The leading dimension of the array H. LDH >= max(1,N). C C IPIV (input) INTEGER array, dimension (N) C The pivot indices from MB02SD; for 1<=i<=N, row i of the C matrix was interchanged with row IPIV(i). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,NRHS) C On entry, the right hand side matrix B. C On exit, the solution matrix X. C C LDB INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C Error Indicator C C INFO (output) 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 uses the factorization C H = P * L * U C where P is a permutation matrix, L is lower triangular with unit C diagonal elements (and one nonzero subdiagonal), and U is upper C triangular. C C REFERENCES C C - C C NUMERICAL ASPECTS C 2 C The algorithm requires 0( N x NRHS ) operations. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. C C REVISIONS C C - C C KEYWORDS C C Hessenberg form, matrix algebra. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) C .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDB, LDH, N, NRHS C .. C .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION B( LDB, * ), H( LDH, * ) C .. Local Scalars .. LOGICAL NOTRAN INTEGER J, JP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DSWAP, DTRSM, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C C Test the input parameters. C INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02RD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN C IF( NOTRAN ) THEN C C Solve H * X = B. C C Solve L * X = B, overwriting B with X. C C L is represented as a product of permutations and unit lower C triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), C where each transformation L(i) is a rank-one modification of C the identity matrix. C DO 10 J = 1, N - 1 JP = IPIV( J ) IF( JP.NE.J ) $ CALL DSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) CALL DAXPY( NRHS, -H( J+1, J ), B( J, 1 ), LDB, B( J+1, 1 ), $ LDB ) 10 CONTINUE C C Solve U * X = B, overwriting B with X. C CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, $ NRHS, ONE, H, LDH, B, LDB ) C ELSE C C Solve H' * X = B. C C Solve U' * X = B, overwriting B with X. C CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, $ ONE, H, LDH, B, LDB ) C C Solve L' * X = B, overwriting B with X. C DO 20 J = N - 1, 1, -1 CALL DAXPY( NRHS, -H( J+1, J ), B( J+1, 1 ), LDB, B( J, 1 ), $ LDB ) JP = IPIV( J ) IF( JP.NE.J ) $ CALL DSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) 20 CONTINUE END IF C RETURN C *** Last line of MB02RD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04MD.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04MD.f0000644000175000017500000001731415012430707017362 0ustar00lilgelilge00000000000000 SUBROUTINE MB04MD( N, MAXRED, A, LDA, SCALE, INFO ) C C PURPOSE C C To reduce the 1-norm of a general real matrix A by balancing. C This involves diagonal similarity transformations applied C iteratively to A to make the rows and columns as close in norm as C possible. C C This routine can be used instead LAPACK Library routine DGEBAL, C when no reduction of the 1-norm of the matrix is possible with C DGEBAL, as for upper triangular matrices. LAPACK Library routine C DGEBAK, with parameters ILO = 1, IHI = N, and JOB = 'S', should C be used to apply the backward transformation. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C MAXRED (input/output) DOUBLE PRECISION C On entry, the maximum allowed reduction in the 1-norm of C A (in an iteration) if zero rows or columns are C encountered. C If MAXRED > 0.0, MAXRED must be larger than one (to enable C the norm reduction). C If MAXRED <= 0.0, then the value 10.0 for MAXRED is C used. C On exit, if the 1-norm of the given matrix A is non-zero, C the ratio between the 1-norm of the given matrix and the C 1-norm of the balanced matrix. Usually, this ratio will be C larger than one, but it can sometimes be one, or even less C than one (for instance, for some companion matrices). 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 input matrix A. C On exit, the leading N-by-N part of this array contains C the balanced matrix. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C SCALE (output) DOUBLE PRECISION array, dimension (N) C The scaling factors applied to A. If D(j) is the scaling C factor applied to row and column j, then SCALE(j) = D(j), C for j = 1,...,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 METHOD C C Balancing consists of applying a diagonal similarity C transformation inv(D) * A * D to make the 1-norms of each row C of A and its corresponding column nearly equal. C C Information about the diagonal matrix D is returned in the vector C SCALE. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. C Supersedes Release 2.0 routine MB04AD by T.W.C. Williams, C Kingston Polytechnic, United Kingdom, October 1984. C This subroutine is based on LAPACK routine DGEBAL, and routine C BALABC (A. Varga, German Aerospace Research Establishment, DLR). C C C REVISIONS C C - C C KEYWORDS C C Balancing, eigenvalue, matrix algebra, matrix operations, C similarity transformation. C C ********************************************************************* C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC PARAMETER ( SCLFAC = 1.0D+1 ) DOUBLE PRECISION FACTOR, MAXR PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) C .. C .. Scalar Arguments .. INTEGER INFO, LDA, N DOUBLE PRECISION MAXRED C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), SCALE( * ) C .. C .. Local Scalars .. LOGICAL NOCONV INTEGER I, ICA, IRA, J DOUBLE PRECISION ANORM, C, CA, F, G, MAXNRM, R, RA, S, SFMAX1, $ SFMAX2, SFMIN1, SFMIN2, SRED C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, IDAMAX C .. C .. External Subroutines .. EXTERNAL DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. C .. Executable Statements .. C C Test the scalar input arguments. C INFO = 0 C IF( N.LT.0 ) THEN INFO = -1 ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04MD', -INFO ) RETURN END IF C IF( N.EQ.0 ) $ RETURN C DO 10 I = 1, N SCALE( I ) = ONE 10 CONTINUE C C Compute the 1-norm of matrix A and exit if it is zero. C ANORM = DLANGE( '1-norm', N, N, A, LDA, SCALE ) IF( ANORM.EQ.ZERO ) $ RETURN C C Set some machine parameters and the maximum reduction in the C 1-norm of A if zero rows or columns are encountered. C SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 C SRED = MAXRED IF( SRED.LE.ZERO ) SRED = MAXR C MAXNRM = MAX( ANORM/SRED, SFMIN1 ) C C Balance the matrix. C C Iterative loop for norm reduction. C 20 CONTINUE NOCONV = .FALSE. C DO 80 I = 1, N C = ZERO R = ZERO C DO 30 J = 1, N IF( J.EQ.I ) $ GO TO 30 C = C + ABS( A( J, I ) ) R = R + ABS( A( I, J ) ) 30 CONTINUE ICA = IDAMAX( N, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = IDAMAX( N, A( I, 1 ), LDA ) RA = ABS( A( I, IRA ) ) C C Special case of zero C and/or R. C IF( C.EQ.ZERO .AND. R.EQ.ZERO ) $ GO TO 80 IF( C.EQ.ZERO ) THEN IF( R.LE.MAXNRM) $ GO TO 80 C = MAXNRM END IF IF( R.EQ.ZERO ) THEN IF( C.LE.MAXNRM ) $ GO TO 80 R = MAXNRM END IF C C Guard against zero C or R due to underflow. C G = R / SCLFAC F = ONE S = C + R 40 CONTINUE IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 50 F = F*SCLFAC C = C*SCLFAC CA = CA*SCLFAC R = R / SCLFAC G = G / SCLFAC RA = RA / SCLFAC GO TO 40 C 50 CONTINUE G = C / SCLFAC 60 CONTINUE IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 70 F = F / SCLFAC C = C / SCLFAC G = G / SCLFAC CA = CA / SCLFAC R = R*SCLFAC RA = RA*SCLFAC GO TO 60 C C Now balance. C 70 CONTINUE IF( ( C+R ).GE.FACTOR*S ) $ GO TO 80 IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN IF( F*SCALE( I ).LE.SFMIN1 ) $ GO TO 80 END IF IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN IF( SCALE( I ).GE.SFMAX1 / F ) $ GO TO 80 END IF G = ONE / F SCALE( I ) = SCALE( I )*F NOCONV = .TRUE. C CALL DSCAL( N, G, A( I, 1 ), LDA ) CALL DSCAL( N, F, A( 1, I ), 1 ) C 80 CONTINUE C IF( NOCONV ) $ GO TO 20 C C Set the norm reduction parameter. C MAXRED = ANORM/DLANGE( '1-norm', N, N, A, LDA, SCALE ) C RETURN C *** End of MB04MD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01MD.f0000644000000000000000000000013215012430707016164 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01MD.f0000644000175000017500000002426215012430707017366 0ustar00lilgelilge00000000000000 SUBROUTINE TB01MD( JOBU, UPLO, N, M, A, LDA, B, LDB, U, LDU, $ DWORK, INFO ) C C PURPOSE C C To reduce the pair (B,A) to upper or lower controller Hessenberg C form using (and optionally accumulating) unitary state-space C transformations. C C ARGUMENTS C C Mode Parameters C C JOBU CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix U the unitary state-space transformations for C reducing the system, as follows: C = 'N': Do not form U; C = 'I': U is initialized to the unit matrix and the C unitary transformation matrix U is returned; C = 'U': The given matrix U is updated by the unitary C transformations used in the reduction. C C UPLO CHARACTER*1 C Indicates whether the user wishes the pair (B,A) to be C reduced to upper or lower controller Hessenberg form as C follows: C = 'U': Upper controller Hessenberg form; C = 'L': Lower controller Hessenberg form. C C Input/Output Parameters C C N (input) INTEGER C The actual state dimension, i.e. the order of the C matrix A. N >= 0. C C M (input) INTEGER C The actual input dimension, i.e. the number of columns of C 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 state transition matrix A to be transformed. C On exit, the leading N-by-N part of this array contains C the transformed state transition matrix U' * A * U. C The annihilated elements are set to zero. 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 matrix B to be transformed. C On exit, the leading N-by-M part of this array contains C the transformed input matrix U' * B. C The annihilated elements are set to zero. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) C On entry, if JOBU = 'U', then the leading N-by-N part of C this array must contain a given matrix U (e.g. from a C previous call to another SLICOT routine), and on exit, the C leading N-by-N part of this array contains the product of C the input matrix U and the state-space transformation C matrix which reduces the given pair to controller C Hessenberg form. C On exit, if JOBU = 'I', then the leading N-by-N part of C this array contains the matrix of accumulated unitary C similarity transformations which reduces the given pair C to controller Hessenberg form. C If JOBU = 'N', the array U is not referenced and can be C supplied as a dummy array (i.e. set parameter LDU = 1 and C declare this array to be U(1,1) in the calling program). C C LDU INTEGER C The leading dimension of array U. If JOBU = 'U' or C JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (MAX(N,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 unitary state-space transformation U, which C reduces the pair (B,A) to one of the following controller C Hessenberg forms: C C |* . . . *|* . . . . . . *| C | . .|. .| C | . .|. .| C | . .|. .| C [U'B|U'AU] = | *|. .| N C | |* .| C | | . .| C | | . .| C | | . .| C | | * . . *| C M N C C if UPLO = 'U', or C C |* . . * | | C |. . | | C |. . | | C |. . | | C [U'AU|U'B] = |. *| | N C |. .|* | C |. .|. . | C |. .|. . | C |. .|. . | C |* . . . . . . *|* . . . *| C N M C if UPLO = 'L'. C C If M >= N, then the matrix U'B is trapezoidal and U'AU is full. C If M = 0, but N > 0, the array A is unchanged on exit. C C REFERENCES C C [1] Van Dooren, P. and Verhaegen, M.H.G. C On the use of unitary state-space transformations. C In : Contemporary Mathematics on Linear Algebra and its Role C in Systems Theory, 47, AMS, Providence, 1985. C C NUMERICAL ASPECTS C C The algorithm requires O((N + M) x N**2) operations and is C backward stable (see [1]). C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TB01AD by M. Vanbegin, and C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. C C REVISIONS C C February 1997, April 2021. C C KEYWORDS C C Controllability, controller Hessenberg form, orthogonal C transformation, unitary transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBU, UPLO INTEGER INFO, LDA, LDB, LDU, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), U(LDU,*) C .. Local Scalars .. LOGICAL LJOBA, LJOBI, LUPLO INTEGER II, J, M1, N1, NJ, PAR1, PAR2, PAR3, PAR4, PAR5, $ PAR6 DOUBLE PRECISION DZ C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARFG, DLASET, DLATZM, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C INFO = 0 LUPLO = LSAME( UPLO, 'U' ) LJOBI = LSAME( JOBU, 'I' ) LJOBA = LJOBI.OR.LSAME( JOBU, 'U' ) C C Test the input scalar arguments. C IF( .NOT.LJOBA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( M.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( .NOT.LJOBA .AND. LDU.LT.1 .OR. $ LJOBA .AND. LDU.LT.MAX( 1, N ) ) THEN INFO = -10 END IF C IF ( INFO.NE.0 ) THEN C C Error return C CALL XERBLA( 'TB01MD', -INFO ) RETURN END IF C IF ( LJOBI ) THEN C C Initialize U to the identity matrix. C CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 ) $ RETURN C M1 = M + 1 N1 = N - 1 C C Perform transformations involving both B and A. C DO 20 J = 1, MIN( M, N1 ) NJ = N - J IF ( LUPLO ) THEN PAR1 = J PAR2 = J PAR3 = J + 1 PAR4 = M PAR5 = N ELSE PAR1 = M - J + 1 PAR2 = NJ + 1 PAR3 = 1 PAR4 = M - J PAR5 = NJ END IF C CALL DLARFG( NJ+1, B(PAR2,PAR1), B(PAR3,PAR1), 1, DZ ) C C Update A. C CALL DLATZM( 'Left', NJ+1, N, B(PAR3,PAR1), 1, DZ, A(PAR2,1), $ A(PAR3,1), LDA, DWORK ) CALL DLATZM( 'Right', N, NJ+1, B(PAR3,PAR1), 1, DZ, A(1,PAR2), $ A(1,PAR3), LDA, DWORK ) C IF ( LJOBA ) THEN C C Update U. C CALL DLATZM( 'Right', N, NJ+1, B(PAR3,PAR1), 1, DZ, $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) END IF C IF ( J.NE.M ) THEN C C Update B C CALL DLATZM( 'Left', NJ+1, PAR4-PAR3+1, B(PAR3,PAR1), 1, DZ, $ B(PAR2,PAR3), B(PAR3,PAR3), LDB, DWORK ) END IF C DO 10 II = PAR3, PAR5 B(II,PAR1) = ZERO 10 CONTINUE C 20 CONTINUE C DO 40 J = M1, N1 C C Perform next transformations only involving A. C NJ = N - J IF ( LUPLO ) THEN PAR1 = J - M PAR2 = J PAR3 = J + 1 PAR4 = N PAR5 = J - M + 1 PAR6 = N ELSE PAR1 = N + M1 - J PAR2 = NJ + 1 PAR3 = 1 PAR4 = NJ PAR5 = 1 PAR6 = N + M - J END IF C CALL DLARFG( NJ+1, A(PAR2,PAR1), A(PAR3,PAR1), 1, DZ ) C C Update A. C CALL DLATZM( 'Left', NJ+1, PAR6-PAR5+1, A(PAR3,PAR1), 1, DZ, $ A(PAR2,PAR5), A(PAR3,PAR5), LDA, DWORK ) CALL DLATZM( 'Right', N, NJ+1, A(PAR3,PAR1), 1, DZ, $ A(1,PAR2), A(1,PAR3), LDA, DWORK ) C IF ( LJOBA ) THEN C C Update U. C CALL DLATZM( 'Right', N, NJ+1, A(PAR3,PAR1), 1, DZ, $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) END IF C DO 30 II = PAR3, PAR4 A(II,PAR1) = ZERO 30 CONTINUE C 40 CONTINUE C RETURN C *** Last line of TB01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03ID.f0000644000000000000000000000013215012430707016153 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03ID.f0000644000175000017500000017273715012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE MB03ID( COMPQ, COMPU, N, A, LDA, C, LDC, D, LDD, B, $ LDB, F, LDF, Q, LDQ, U1, LDU1, U2, LDU2, NEIG, $ IWORK, LIWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To move the eigenvalues with strictly negative real parts of an C N-by-N real skew-Hamiltonian/Hamiltonian pencil aS - bH in C structured Schur form, with C C ( 0 I ) ( A D ) ( B F ) C S = J Z' J' Z, J = ( ), Z = ( ), H = ( ), C ( -I 0 ) ( 0 C ) ( 0 -B' ) C C to the leading principal subpencil, while keeping the triangular C form. Above, A is upper triangular, B is upper quasi-triangular, C and C is lower triangular. C The matrices Z and H are transformed by an orthogonal symplectic C matrix U and an orthogonal matrix Q such that C C ( Aout Dout ) C Zout = U' Z Q = ( ), and C ( 0 Cout ) C (1) C ( Bout Fout ) C Hout = J Q' J' H Q = ( ), C ( 0 -Bout' ) C C where Aout, Bout and Cout remain in triangular form. The notation C M' denotes the transpose of the matrix M. C Optionally, if COMPQ = 'I' or COMPQ = 'U', the orthogonal matrix Q C that fulfills (1) is computed. C Optionally, if COMPU = 'I' or COMPU = 'U', the orthogonal C symplectic matrix C C ( U1 U2 ) C U = ( ) C ( -U2 U1 ) C C that fulfills (1) is computed. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether or not the orthogonal transformations C should be accumulated in the array Q, as follows: C = 'N': Q is not computed; C = 'I': the array Q is initialized internally to the unit C matrix, and the orthogonal matrix Q is returned; C = 'U': the array Q contains an orthogonal matrix Q0 on C entry, and the matrix Q0*Q is returned, where Q C is the product of the orthogonal transformations C that are applied to the pencil aS - bH to reorder C the eigenvalues. C C COMPU CHARACTER*1 C Specifies whether or not the orthogonal symplectic C transformations should be accumulated in the arrays U1 and C U2, as follows: C = 'N': U1 and U2 are not computed; C = 'I': the arrays U1 and U2 are initialized internally, C and the submatrices U1 and U2 defining the C orthogonal symplectic matrix U are returned; C = 'U': the arrays U1 and U2 contain the corresponding C submatrices of an orthogonal symplectic matrix U0 C on entry, and the updated submatrices U1 and U2 C of the matrix product U0*U are returned, where U C is the product of the orthogonal symplectic C transformations that are applied to the pencil C aS - bH to reorder the eigenvalues. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular matrix A. The elements of the C strictly lower triangular part of this array are not used. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Aout. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C C (input/output) DOUBLE PRECISION array, dimension C (LDC, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the lower triangular matrix C. The elements of the C strictly upper triangular part of this array are not used. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Cout. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1, N/2). C C D (input/output) DOUBLE PRECISION array, dimension C (LDD, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix D. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Dout. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1, N/2). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper quasi-triangular matrix B. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper quasi-triangular part of C the matrix Bout. C The part below the first subdiagonal of this array is C not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C F (input/output) DOUBLE PRECISION array, dimension C (LDF, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the symmetric matrix C F. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed upper triangular part of the C matrix Fout. C The strictly lower triangular part of this array is not C referenced, except for the element F(N/2,N/2-1), but its C initial value is preserved. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1, N/2). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) C On entry, if COMPQ = 'U', then the leading N-by-N part of C this array must contain a given matrix Q0, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q0 and the transformation matrix Q C used to transform the matrices Z and H. C On exit, if COMPQ = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q. C If COMPQ = 'N' this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'. C C U1 (input/output) DOUBLE PRECISION array, dimension C (LDU1, N/2) C On entry, if COMPU = 'U', then the leading N/2-by-N/2 part C of this array must contain the upper left block of a C given matrix U0, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper left block U1 of C the product of the input matrix U0 and the transformation C matrix U used to transform the matrices Z and H. C On exit, if COMPU = 'I', then the leading N/2-by-N/2 part C of this array contains the upper left block U1 of the C orthogonal symplectic transformation matrix U. C If COMPU = 'N' this array is not referenced. C C LDU1 INTEGER C The leading dimension of the array U1. C LDU1 >= 1, if COMPU = 'N'; C LDU1 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'. C C U2 (input/output) DOUBLE PRECISION array, dimension C (LDU2, N/2) C On entry, if COMPU = 'U', then the leading N/2-by-N/2 part C of this array must contain the upper right block of a C given matrix U0, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper right block U2 of C the product of the input matrix U0 and the transformation C matrix U used to transform the matrices Z and H. C On exit, if COMPU = 'I', then the leading N/2-by-N/2 part C of this array contains the upper right block U2 of the C orthogonal symplectic transformation matrix U. C If COMPU = 'N' this array is not referenced. C C LDU2 INTEGER C The leading dimension of the array U2. C LDU2 >= 1, if COMPU = 'N'; C LDU2 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'. C C NEIG (output) INTEGER C The number of eigenvalues in aS - bH with strictly C negative real part. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= N+1. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The dimension of the array DWORK. C If COMPQ = 'N', C LDWORK >= MAX(2*N+48,171); C if COMPQ = 'I' or COMPQ = 'U', C LDWORK >= MAX(4*N+48,171). C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: the periodic QZ algorithm did not converge in SLICOT C Library routine MB03BB; C = 2: an error occured during the execution of MB03CD; C = 3: an error occured during the execution of MB03GD. C C METHOD C C The algorithm reorders the eigenvalues like the following scheme: C C Step 1: Reorder the eigenvalues in the subpencil aC'*A - bB. C I. Reorder the eigenvalues with negative real parts to the C top. C II. Reorder the eigenvalues with positive real parts to the C bottom. C C Step 2: Reorder the remaining eigenvalues with negative real C parts in the pencil aS - bH. C I. Exchange the eigenvalues between the last diagonal block C in aC'*A - bB and the last diagonal block in aS - bH. C II. Move the eigenvalues of the R-th block to the (MM+1)-th C block, where R denotes the number of upper quasi- C triangular blocks in aC'*A - bB and MM denotes the current C number of blocks in aC'*A - bB with eigenvalues with C negative real parts. C C The algorithm uses a sequence of orthogonal transformations as C described on page 25 in [1]. To achieve those transformations the C elementary subroutines MB03CD and MB03GD are called for the C corresponding matrix structures. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, November 21, 2008. C V. Sima, Dec. 2009 (SLICOT version of the routine DHAFNX). C C REVISIONS C C V. Sima, Aug. 2009; Feb. 2010; Oct. 2010; Nov. 2010; Feb. 2011, C Sep. 2011. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue reordering, upper (quasi-)triangular matrix, C skew-Hamiltonian/Hamiltonian pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF, TEN PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0, $ TEN = 1.0D+1 ) C C .. Scalar Arguments .. CHARACTER COMPQ, COMPU INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDQ, LDU1, LDU2, $ LDWORK, LIWORK, N, NEIG C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), DWORK( * ), F( LDF, * ), $ Q( LDQ, * ), U1( LDU1, * ), U2( LDU2, * ) C C .. Local Scalars .. LOGICAL LCMPQ, LCMPU, LINIQ, LINIU, LUPDQ, LUPDU INTEGER DIM1, DIM2, HLP, I, I1, IA, IB, IB1, IB2, IB3, $ IBS, IC, IHUPLE, IQ1, IQ2, IQ3, IQLOLE, IQLORI, $ IQUPLE, IQUPRI, IR, IS, ITMP1, ITMP2, ITMP3, $ IUPD, IUUPLE, IUUPRI, IWRK1, IWRK2, IWRK3, $ IWRK4, IWRK5, IZLORI, IZUPLE, IZUPRI, J, K, $ LDW, M, MM, MP, NCOL, NCOLS, NROW, NROWS, $ OPTDW, R, SDIM, UPDS DOUBLE PRECISION A2, BASE, C2, DN, F2, LGBAS, NRMB, PREC, Q11, $ Q12, Q21, Q22, TMPA, TMPC, TOL, U11, U12 C C .. Local Arrays .. INTEGER IDUM( 8 ) DOUBLE PRECISION DUM( 3, 4 ), PAR( 2 ), PRD( 2, 2, 3 ) C C .. External Functions .. LOGICAL LSAME INTEGER MA01CD DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS, LSAME, MA01CD C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLASET, DSCAL, $ MA02AD, MB01RU, MB01RX, MB03BB, MB03CD, MB03GD, $ XERBLA C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, LOG, MAX, MIN, MOD, SIGN C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LINIU = LSAME( COMPU, 'I' ) LUPDU = LSAME( COMPU, 'U' ) LCMPQ = LINIQ .OR. LUPDQ LCMPU = LINIU .OR. LUPDU C IF( LCMPQ ) THEN OPTDW = MAX( 4*N + 48, 171 ) ELSE OPTDW = MAX( 2*N + 48, 171 ) END IF C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -13 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN INFO = -15 ELSE IF( LDU1.LT.1 .OR. ( LCMPU .AND. LDU1.LT.M ) ) THEN INFO = -17 ELSE IF( LDU2.LT.1 .OR. ( LCMPU .AND. LDU2.LT.M ) ) THEN INFO = -19 ELSE IF( LIWORK.LT.N+1 ) THEN INFO = -22 ELSE IF( LDWORK.LT.OPTDW ) THEN INFO = -24 END IF IF( INFO.NE.0) THEN CALL XERBLA( 'MB03ID', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN NEIG = 0 RETURN END IF C C Determine machine constants. C PREC = DLAMCH( 'Precision' ) BASE = DLAMCH( 'Base' ) LGBAS = LOG( BASE ) DN = DBLE( N )*PREC TOL = MIN( DBLE( M ), TEN )*PREC C PAR( 1 ) = PREC PAR( 2 ) = DLAMCH( 'Safe minimum' ) C C STEP 0: Determine location and size of diagonal blocks. C IWORK(J) and IWORK(IS+J) are used to indicate the C beginning index and the kind of eigenvalues of the C J-th diagonal block of the subpencil aC'*A - bB. C To find IWORK(IS+J) for the block J of size dim, compute C -T -1 C sign( trace(C(rng,rng) *B(rng,rng)*A(rng,rng) ) ), C C where rng = J:J+dim-1. For dim = 2, it is assumed that C both eigenvalues of the matrix above have real parts with C the same sign (true for a structured Schur form). C I = 1 J = 1 IS = M + 1 C C Partition blocks. C NRMB = DLANHS( 'One', M, B, LDB, DWORK ) C C WHILE( I.LE.M-1 ) DO C 10 CONTINUE IF( I.LE.M-1 ) THEN IWORK( J ) = I IF( ABS( B( I+1, I ) ).LE.TOL*NRMB ) THEN C C 1-by-1 block. C B( I+1, I ) = ZERO IWORK( IS+J ) = SIGN( ONE, A( I, I )*B( I, I )*C( I, I ) ) I = I + 1 ELSE C C 2-by-2 block. C U11 = B( I+1, I )*A( I, I+1 ) U12 = B( I+1, I )*C( I+1, I ) TMPA = B( I+1, I+1 )*A( I, I ) - U11 TMPC = B( I, I )*C( I+1, I+1 ) - U12 IF( ABS( TMPA ).LE.PREC*ABS( U11 ) .AND. $ ABS( TMPC ).LE.PREC*ABS( U12 ) ) THEN C C Severe cancellation. Use the periodic QZ algorithm. C Workspace: 30. C IDUM( 1 ) = 1 IDUM( 2 ) = 2 IDUM( 3 ) = 3 IDUM( 4 ) = 1 IDUM( 5 ) = -1 IDUM( 6 ) = -1 CALL DLACPY( 'Full', 2, 2, B( I, I ), LDB, PRD, 2 ) CALL DLACPY( 'Upper', 2, 2, A( I, I ), LDA, $ PRD( 1, 1, 2 ), 2 ) CALL MA02AD( 'Lower', 2, 2, C( I, I ), LDC, $ PRD( 1, 1, 3 ), 2 ) PRD( 2, 1, 2 ) = ZERO PRD( 2, 1, 3 ) = ZERO CALL MB03BB( BASE, LGBAS, PREC, 3, IDUM, IDUM( 4 ), 1, $ PRD, 2, 2, DWORK, DWORK( 3 ), DWORK( 5 ), $ IDUM( 7 ), DWORK( 7 ), INFO ) IF( INFO.EQ.1 ) $ RETURN IF( DWORK( 5 ).EQ.ZERO .OR. DWORK( 6 ).EQ.ZERO .OR. $ ABS( DWORK( 1 ) ).LE.DN* ABS( DWORK( 3 ) ) ) $ THEN IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = MA01CD( DWORK( 1 ), IDUM( 7 ), $ DWORK( 2 ), IDUM( 8 ) ) END IF ELSE IF( C( I, I ).EQ.ZERO .OR. A( I+1, I+1 ).EQ.ZERO ) THEN C C The pencil has infinite eigenvalues or it is singular. C IWORK( IS+J ) = 0 ELSE U11 = TMPA/A( I+1, I+1 ) + TMPC/C( I, I ) IF( U11.EQ.ZERO ) THEN IWORK( IS+J ) = 0 ELSE IWORK( IS+J ) = SIGN( ONE, U11 )* $ SIGN( ONE, A( I, I )*C( I+1, I+1 ) ) END IF END IF I = I + 2 END IF J = J + 1 GO TO 10 C C END WHILE 10 C END IF C IF( I.EQ.M ) THEN C C 1-by-1 block C IWORK( J ) = I IWORK( IS+J ) = SIGN( ONE, A( I, I )*B( I, I )*C( I, I ) ) J = J + 1 END IF C R = J - 1 C C Initialize Q if appropriate. C IF( LINIQ ) THEN IUPD = M + 1 UPDS = M CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) ELSE IF( LUPDQ ) THEN IUPD = 1 UPDS = N END IF C C Initialize U1 and U2 if appropriate. C IF( LINIU ) THEN CALL DLASET( 'Full', M, M, ZERO, ONE, U1, LDU1 ) CALL DLASET( 'Full', M, M, ZERO, ZERO, U2, LDU2 ) END IF C IF( M.GT.1 ) THEN C C Save the elements A(M,M-1), C(M-1,M), and F(M,M-1), which might C be overwritten. C A2 = A( M, M-1 ) C2 = C( M-1, M ) F2 = F( M, M-1 ) END IF C C STEP 1: Reorder the eigenvalues in the subpencil aC'*A - bB. C MM = 0 MP = J C C I. Reorder the eigenvalues with negative real parts to the top. C C Set pointers for the inputs and outputs of MB03CD. C IQ1 = 1 IQ2 = IQ1 + 16 IQ3 = IQ2 + 16 IA = IQ3 + 16 IB = IA + 16 IC = IB + 16 IWRK1 = IC + 16 IWRK2 = IA C K = 1 IB3 = M + 1 IWORK( R+1 ) = IB3 C C WHILE( K.LE.R ) DO C 20 CONTINUE IF( K.LE.R ) THEN IF( IWORK( IS+K ).LT.0 ) THEN DO 30 J = K - 1, MM + 1, -1 C C IB1, IB2, and IB3 are pointers to 3 consecutive blocks. C IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1), C C(ib1:ib3-1,ib1:ib3-1), and B(ib1:ib3-1,ib1:ib3-1) to C DWORK as inputs for MB03CD. Also, set the additional C zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL MA02AD( 'Lower', SDIM, SDIM, C( IB1, IB1 ), LDC, $ DWORK( IC ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, $ DWORK( IB+1 ), SDIM+1 ) IF( DIM1.EQ.2 ) THEN DWORK( IA+1 ) = ZERO DWORK( IC+1 ) = ZERO END IF IF( DIM2.EQ.2 ) THEN I1 = SDIM*( SDIM - 1 ) - 1 DWORK( IA+I1 ) = ZERO DWORK( IC+I1 ) = ZERO END IF DWORK( IB+SDIM-1 ) = ZERO IF( SDIM.EQ.4 ) THEN DWORK( IB+2 ) = ZERO DWORK( IB+7 ) = ZERO END IF C C Perform eigenvalue/matrix block exchange. C Workspace: IWRK1 + 16*DIM1 + 10*DIM2 + 22 <= IWRK1 + 74, C if SDIM > 2, and IWRK1 - 1, otherwise. C CALL MB03CD( 'Upper', DIM1, DIM2, PREC, DWORK( IC ), $ SDIM, DWORK( IA ), SDIM, DWORK( IB ), $ SDIM, DWORK( IQ1 ), SDIM, DWORK( IQ2 ), $ SDIM, DWORK( IQ3 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Copy the transformed diagonal block of B, if sdim > 2. C IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) END IF C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 NROW = IB3 - 1 NCOL = M - IB1 + 1 CALL DLACPY( 'Lower', SDIM-1, SDIM-1, A( IB1+1, IB1 ), $ LDA, DUM, 3 ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ A( IB1+1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, C( IB1, IB1+1 ), $ LDC, DUM( 1, 2 ), 3 ) CALL DLASET( 'Upper', SDIM-1, SDIM-1, ZERO, ZERO, $ C( IB1, IB1+1 ), LDC ) C C Update A. C Workspace: IWRK2 + 2*N - 1. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), NROW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), NROW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ A( IB1, IB1 ), LDA, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Lower', SDIM-1, SDIM-1, DUM, 3, $ A( IB1+1, IB1 ), LDA ) C C Update C. C CALL DGEMM( 'No Transpose', 'No Transpose', NCOL, SDIM, $ SDIM, ONE, C( IB1, IB1 ), LDC, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), NCOL ) CALL DLACPY( 'Full', NCOL, SDIM, DWORK( IWRK2 ), NCOL, $ C( IB1, IB1 ), LDC ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NROW, $ SDIM, ONE, DWORK( IQ2 ), SDIM, C( IB1, 1 ), $ LDC, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NROW, DWORK( IWRK2 ), SDIM, $ C( IB1, 1 ), LDC ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, DUM( 1, 2 ), 3, $ C( IB1, IB1+1 ), LDC ) C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, M, SDIM, $ ONE, DWORK( IQ2 ), SDIM, D( IB1, 1 ), LDD, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, M, DWORK( IWRK2 ), SDIM, $ D( IB1, 1 ), LDD ) C C Update B. C IF( SDIM.GT.2 ) THEN NROW = NROWS NCOL = NCOLS IBS = IB3 LDW = MAX( 1, NROW ) ELSE IBS = IB1 LDW = NROW END IF CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ3 ), SDIM, $ B( IB1, IBS ), LDB, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IBS ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ3 ), SDIM, $ F( IB1, IB3 ), LDF, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, IB3 ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ3 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK2 + 2*N - 1, if COMPQ = 'I'; C IWRK2 + 4*N - 1, if COMPQ = 'U'. C CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ, $ DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ, $ DWORK( IQ3 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( IUPD, M+IB1 ), LDQ ) END IF C IF( LCMPU ) THEN C C Update U1. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U1( 1, IB1 ), LDU1, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U1( 1, IB1 ), LDU1 ) END IF C IF( LUPDU ) THEN C C Update U2. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U2( 1, IB1 ), LDU2, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U2( 1, IB1 ), LDU2 ) END IF C C Update index lists IWORK(1:M) and IWORK(M+2:N+1) if a C 1-by-1 and 2-by-2 block have been swapped. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF C C Update IWORK(M+2:N+1). C HLP = IWORK( IS+J ) IWORK( IS+J ) = IWORK( IS+J+1 ) IWORK( IS+J+1 ) = HLP 30 CONTINUE MM = MM + 1 END IF K = K + 1 GO TO 20 C C END WHILE 20 C END IF C C II. Reorder the eigenvalues with positive real parts to the bottom. C K = R C C WHILE( K.GE.MM+1 ) DO C 40 CONTINUE IF( K.GE.MM+1 ) THEN IF( IWORK( IS+K ).GT.0 ) THEN DO 50 J = K, MP - 2 IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1), C C(ib1:ib3-1,ib1:ib3-1), and B(ib1:ib3-1,ib1:ib3-1) to C DWORK as inputs for MB03CD. Also, set the additional C zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL MA02AD( 'Lower', SDIM, SDIM, C( IB1, IB1 ), LDC, $ DWORK( IC ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, $ DWORK( IB+1 ), SDIM+1 ) IF( DIM1.EQ.2 ) THEN DWORK( IA+1 ) = ZERO DWORK( IC+1 ) = ZERO END IF IF( DIM2.EQ.2 ) THEN I1 = SDIM*( SDIM - 1 ) - 1 DWORK( IA+I1 ) = ZERO DWORK( IC+I1 ) = ZERO END IF DWORK( IB+SDIM-1 ) = ZERO IF( SDIM.EQ.4 ) THEN DWORK( IB+2 ) = ZERO DWORK( IB+7 ) = ZERO END IF C C Perform eigenvalue/matrix block exchange. C CALL MB03CD( 'Upper', DIM1, DIM2, PREC, DWORK( IC ), $ SDIM, DWORK( IA ), SDIM, DWORK( IB ), $ SDIM, DWORK( IQ1 ), SDIM, DWORK( IQ2 ), $ SDIM, DWORK( IQ3 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Copy the transformed diagonal block of B, if sdim > 2. C IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) END IF C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 NROW = IB3 - 1 NCOL = M - IB1 + 1 CALL DLACPY( 'Lower', SDIM-1, SDIM-1, A( IB1+1, IB1 ), $ LDA, DUM, 3 ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ A( IB1+1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, C( IB1, IB1+1 ), $ LDC, DUM( 1, 2 ), 3 ) CALL DLASET( 'Upper', SDIM-1, SDIM-1, ZERO, ZERO, $ C( IB1, IB1+1 ), LDC ) C C Update A. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), NROW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), NROW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ2 ), SDIM, $ A( IB1, IB1 ), LDA, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Lower', SDIM-1, SDIM-1, DUM, 3, $ A( IB1+1, IB1 ), LDA ) C C Update C. C CALL DGEMM( 'No Transpose', 'No Transpose', NCOL, SDIM, $ SDIM, ONE, C( IB1, IB1 ), LDC, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), NCOL ) CALL DLACPY( 'Full', NCOL, SDIM, DWORK( IWRK2 ), NCOL, $ C( IB1, IB1 ), LDC ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NROW, $ SDIM, ONE, DWORK( IQ2 ), SDIM, C( IB1, 1 ), $ LDC, ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NROW, DWORK( IWRK2 ), SDIM, $ C( IB1, 1 ), LDC ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, DUM( 1, 2 ), 3, $ C( IB1, IB1+1 ), LDC ) C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, M, SDIM, $ ONE, DWORK( IQ2 ), SDIM, D( IB1, 1 ), LDD, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, M, DWORK( IWRK2 ), SDIM, $ D( IB1, 1 ), LDD ) C C Update B. C IF( SDIM.GT.2 ) THEN NROW = NROWS NCOL = NCOLS IBS = IB3 LDW = MAX( 1, NROW ) ELSE IBS = IB1 LDW = NROW END IF CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, $ SDIM, ONE, DWORK( IQ3 ), SDIM, $ B( IB1, IBS ), LDB, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IBS ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, $ SDIM, ONE, DWORK( IQ3 ), SDIM, $ F( IB1, IB3 ), LDF, ZERO, DWORK( IWRK2 ), $ SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, IB3 ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ3 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ, $ DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', UPDS, $ SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ, $ DWORK( IQ3 ), SDIM, ZERO, DWORK( IWRK2 ), $ UPDS ) CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS, $ Q( IUPD, M+IB1 ), LDQ ) END IF C IF( LCMPU ) THEN C C Update U1. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U1( 1, IB1 ), LDU1, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U1( 1, IB1 ), LDU1 ) END IF C IF( LUPDU ) THEN C C Update U2. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U2( 1, IB1 ), LDU2, $ DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ), $ M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U2( 1, IB1 ), LDU2 ) END IF C C Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block C have been swapped. IWORK(M+2:N+1) is not needed anymore, C so it is not necessary to update it. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF 50 CONTINUE MP = MP - 1 END IF K = K - 1 GO TO 40 C C END WHILE 40 C END IF C C STEP 2: Reorder the remaining eigenvalues with negative real parts. C C Set pointers for the inputs and outputs of MB03GD. C IQUPLE = 1 IUUPLE = IQUPLE + 16 IZUPLE = IUUPLE + 16 IHUPLE = IZUPLE + 16 IWRK5 = IHUPLE + 16 IWRK3 = IZUPLE IWRK4 = IWRK3 + 2*N ITMP1 = IWRK3 + N ITMP2 = ITMP1 + 4 ITMP3 = ITMP2 + 4 C DO 70 K = R, MP, -1 C C I. Exchange the eigenvalues between two diagonal blocks. C IR = IWORK( R ) DIM1 = IWORK( R+1 ) - IR SDIM = 2*DIM1 C IF( DIM1.EQ.2 ) THEN A( M, IR ) = ZERO C( IR, M ) = ZERO C C Build the (small) symmetric matrix F(M-1:M,M-1:M). C F( M, IR ) = F( IR, M ) END IF C C Calculate position of submatrices in DWORK. C IZUPRI = IZUPLE + DIM1*SDIM IZLORI = IZUPRI + DIM1 IUUPRI = IUUPLE + DIM1*SDIM IQLOLE = IQUPLE + DIM1 IQUPRI = IQUPLE + DIM1*SDIM IQLORI = IQUPRI + DIM1 C C Generate input matrices for MB03GD built of submatrices of A, C D, C, B, and F. C CALL DLACPY( 'Upper', DIM1, DIM1, A( IR, IR ), LDA, $ DWORK( IZUPLE ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, D( IR, IR ), LDD, $ DWORK( IZUPRI ), SDIM ) CALL DLACPY( 'Lower', DIM1, DIM1, C( IR, IR ), LDC, $ DWORK( IZLORI ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB, $ DWORK( IHUPLE ), SDIM ) CALL DLACPY( 'Upper', DIM1, DIM1, F( IR, IR ), LDB, $ DWORK( IHUPLE+DIM1*SDIM ), SDIM ) IF( DIM1.EQ.2 ) THEN DWORK( IZUPLE+1 ) = ZERO DWORK( IZLORI+SDIM ) = ZERO END IF C C Perform eigenvalue exchange. C Workspace: IWRK5 + 11, if SDIM = 4. C CALL MB03GD( SDIM, DWORK( IZUPLE ), SDIM, DWORK( IHUPLE ), $ SDIM, PAR, DWORK( IQUPLE ), SDIM, DWORK( IUUPLE ), $ SDIM, DWORK( IWRK5 ), LDWORK-IWRK5+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 3 RETURN END IF C IF( DIM1.EQ.2 ) THEN C C Update A by transformations from the right. C Workspace: IWRK3 + N - 1. C CALL DLACPY( 'Full', M, DIM1, A( 1, IR ), LDA, $ DWORK( IWRK3 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM, $ ZERO, A( 1, IR ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, D( 1, IR ), LDD, DWORK( IQLOLE ), SDIM, $ ONE, A( 1, IR ), LDA ) C C Update D by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM, $ ZERO, DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, D( 1, IR ), LDD, DWORK( IQLORI ), SDIM, $ ONE, DWORK( ITMP1 ), M ) CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, D( 1, IR ), $ LDD ) C C Compute intermediate product Cf*Q21, with C Cf = C(M-1:M,M-1:M). C CALL DGEMM( 'No Transpose', 'No Transpose', DIM1, DIM1, $ DIM1, ONE, C( IR, IR ), LDC, DWORK( IQLOLE ), $ SDIM, ZERO, DWORK( ITMP1 ), DIM1 ) C C Update C by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', DIM1, DIM1, $ DIM1, ONE, C( IR, IR ), LDC, DWORK( IQLORI ), $ SDIM, ZERO, DWORK( IWRK3 ), DIM1 ) CALL DLACPY( 'Full', DIM1, DIM1, DWORK( IWRK3 ), DIM1, $ C( IR, IR ), LDC ) C C Update A by transformations from the left. C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IUUPLE ), SDIM, A( IR, IR ), LDA, $ ZERO, DWORK( IWRK3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ -ONE, DWORK( IUUPRI ), SDIM, DWORK( ITMP1 ), $ DIM1, ONE, DWORK( IWRK3 ), DIM1 ) CALL DLACPY( 'Full', DIM1, DIM1, DWORK( IWRK3 ), DIM1, $ A( IR, IR ), LDA ) C C Update D by transformations from the left. C CALL DLACPY( 'Full', DIM1, M, D( IR, 1 ), LDD, $ DWORK( IWRK3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M, DIM1, $ ONE, DWORK( IUUPLE ), SDIM, DWORK( IWRK3 ), $ DIM1, ZERO, D( IR, 1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M, DIM1, $ -ONE, DWORK( IUUPRI ), SDIM, C( IR, 1 ), LDC, $ ONE, D( IR, 1 ), LDD ) C C Update C by transformations from the left. C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M, DIM1, $ ONE, DWORK( IUUPRI ), SDIM, DWORK( IWRK3 ), $ DIM1, ZERO, DWORK( ITMP1 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M, DIM1, $ ONE, DWORK( IUUPLE ), SDIM, C( IR, 1 ), LDC, $ ONE, DWORK( ITMP1 ), DIM1 ) CALL DLACPY( 'Full', DIM1, M, DWORK( ITMP1 ), DIM1, $ C( IR, 1 ), LDC ) C C Update B by transformations from the right. C CALL DLACPY( 'Full', M, DIM1, B( 1, IR ), LDB, $ DWORK( IWRK3 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM, $ ZERO, B( 1, IR ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, F( 1, IR ), LDF, DWORK( IQLOLE ), SDIM, $ ONE, B( 1, IR ), LDB ) C C Update F by transformations from the right. C CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM, $ ZERO, DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, DIM1, $ ONE, F( 1, IR ), LDF, DWORK( IQLORI ), SDIM, $ ONE, DWORK( ITMP1 ), M ) CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, F( 1, IR ), $ LDF ) C C Compute intermediate products Bf'*Q21 and Bf'*Q22, with C Bf = B(M-1:M,M-1:M). C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ), $ SDIM, ZERO, DWORK( ITMP1 ), DIM1 ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI ), $ SDIM, ZERO, DWORK( ITMP2 ), DIM1 ) C C Update B by transformations from the left. C CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB, $ DWORK( ITMP3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ), $ DIM1, ZERO, B( IR, IR ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( IQLORI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, B( IR, IR ), LDB ) C C Update F by transformations from the left. C CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ZERO, $ ONE, DWORK( ITMP1 ), DIM1, DWORK( IQLORI ), $ SDIM, F( IR, IR ), LDF, INFO ) CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ONE, $ ONE, DWORK( ITMP1 ), DIM1, DWORK( IQUPRI ), $ SDIM, DWORK( ITMP2 ), DIM1, INFO ) CALL DLACPY( 'Upper', DIM1, DIM1, DWORK( ITMP1 ), DIM1, $ F( IR, IR ), LDF ) C IF( LCMPQ ) THEN C C Update Q. C Workspace: IWRK4 + 2*N - 1. C CALL DLACPY( 'Full', N, DIM1, Q( 1, IR ), LDQ, $ DWORK( IWRK4 ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK4 ), N, $ DWORK( IQUPLE ), SDIM, ZERO, Q( 1, IR ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q( 1, M+IR ), LDQ, $ DWORK( IQLOLE ), SDIM, ONE, Q( 1, IR ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK4 ), N, $ DWORK( IQUPRI ), SDIM, ZERO, DWORK( IWRK3 ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q( 1, M+IR ), LDQ, $ DWORK( IQLORI ), SDIM, ONE, DWORK( IWRK3 ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( IWRK3 ), N, $ Q( 1, M+IR ), LDQ ) END IF C IF( LCMPU ) THEN C C Update U. C Workspace: ITMP1 + N - 1. C CALL DLACPY( 'Full', M, DIM1, U1( 1, IR ), LDU1, $ DWORK( ITMP1 ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, $ DIM1, ONE, DWORK( ITMP1 ), M, $ DWORK( IUUPLE ), SDIM, ZERO, U1( 1, IR ), $ LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, $ DIM1, -ONE, U2( 1, IR ), LDU2, $ DWORK( IUUPRI ), SDIM, ONE, U1( 1, IR ), $ LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, $ DIM1, ONE, DWORK( ITMP1 ), M, $ DWORK( IUUPRI ), SDIM, ZERO, DWORK( IWRK3 ), $ M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, DIM1, $ DIM1, ONE, U2( 1, IR ), LDU2, $ DWORK( IUUPLE ), SDIM, ONE, DWORK( IWRK3 ), $ M ) CALL DLACPY( 'Full', M, DIM1, DWORK( IWRK3 ), M, $ U2( 1, IR ), LDU2 ) END IF C ELSE U11 = DWORK( IUUPLE ) U12 = DWORK( IUUPRI ) Q11 = DWORK( IQUPLE ) Q21 = DWORK( IQLOLE ) Q12 = DWORK( IQUPRI ) Q22 = DWORK( IQLORI ) C C Update A by transformations from the right. C CALL DCOPY( M, A( 1, IR ), 1, DWORK( IWRK3 ), 1 ) CALL DSCAL( M, Q11, A( 1, IR ), 1 ) CALL DAXPY( M, Q21, D( 1, IR ), 1, A( 1, IR ), 1 ) C C Update D by transformations from the right. C CALL DSCAL( M, Q22, D( 1, IR ), 1 ) CALL DAXPY( M, Q12, DWORK( IWRK3 ), 1, D( 1, IR ), 1 ) C C Compute intermediate product C(M,M)*Q21. C TMPC = C( IR, IR )*Q21 C C Update C by transformations from the right. C C( IR, IR ) = C( IR, IR )*Q22 C C Update A by transformations from the left. C A( IR, IR ) = U11*A( IR, IR ) - U12*TMPC C C Update D by transformations from the left. C CALL DCOPY( M, D( IR, 1 ), LDD, DWORK( IWRK3 ), 1 ) CALL DSCAL( M, U11, D( IR, 1 ), LDD ) CALL DAXPY( M, -U12, C( IR, 1 ), LDC, D( IR, 1 ), LDD ) C C Update C by transformations from the left. C CALL DSCAL( M, U11, C( IR, 1 ), LDC ) CALL DAXPY( M, U12, DWORK( IWRK3 ), 1, C( IR, 1 ), LDC ) C C Update B by transformations from the right. C CALL DCOPY( M-1, B( 1, IR ), 1, DWORK( IWRK3 ), 1 ) CALL DSCAL( M-1, Q11, B( 1, IR ), 1 ) CALL DAXPY( M-1, Q21, F( 1, IR ), 1, B( 1, IR ), 1 ) C C Update F by transformations from the right. C CALL DSCAL( M-1, Q22, F( 1, IR ), 1 ) CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, F( 1, IR ), 1 ) C C Update B by transformations from the left. C B( M, M ) = -B( M, M ) C IF( LCMPQ ) THEN C C Update Q. C CALL DCOPY( N, Q( 1, IR ), 1, DWORK( IWRK4 ), 1 ) CALL DSCAL( N, Q11, Q( 1, IR ), 1 ) CALL DAXPY( N, Q21, Q( 1, IR+M ), 1, Q( 1, IR ), 1 ) CALL DSCAL( N, Q22, Q( 1, IR+M ), 1 ) CALL DAXPY( N, Q12, DWORK( IWRK4 ), 1, Q( 1, IR+M ), 1 ) END IF C IF( LCMPU ) THEN C C Update U. C CALL DCOPY( M, U1( 1, IR ), 1, DWORK( IWRK4 ), 1 ) CALL DSCAL( M, U11, U1( 1, IR ), 1 ) CALL DAXPY( M, -U12, U2( 1, IR ), 1, U1( 1, IR ), 1 ) CALL DSCAL( M, U11, U2( 1, IR ), 1 ) CALL DAXPY( M, U12, DWORK( IWRK4 ), 1, U2( 1, IR ), 1 ) END IF END IF C MM = MM + 1 DO 60 J = R - 1, MM, -1 IB1 = IWORK( J ) IB2 = IWORK( J+1 ) IB3 = IWORK( J+2 ) DIM1 = IB2 - IB1 DIM2 = IB3 - IB2 SDIM = DIM1 + DIM2 C C Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1), C C(ib1:ib3-1,ib1:ib3-1), and B(ib1:ib3-1,ib1:ib3-1) to C DWORK as inputs for MB03CD. Also, set the additional C zero elements. C CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA, $ DWORK( IA ), SDIM ) CALL MA02AD( 'Lower', SDIM, SDIM, C( IB1, IB1 ), LDC, $ DWORK( IC ), SDIM ) CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB, $ DWORK( IB ), SDIM ) CALL DCOPY( SDIM-1, B( IB1+1, IB1 ), LDB+1, DWORK( IB+1 ), $ SDIM+1 ) IF( DIM1.EQ.2 ) THEN DWORK( IA+1 ) = ZERO DWORK( IC+1 ) = ZERO END IF IF( DIM2.EQ.2 ) THEN I1 = SDIM*( SDIM - 1 ) - 1 DWORK( IA+I1 ) = ZERO DWORK( IC+I1 ) = ZERO END IF DWORK( IB+SDIM-1 ) = ZERO IF( SDIM.EQ.4 ) THEN DWORK( IB+2 ) = ZERO DWORK( IB+7 ) = ZERO END IF C C Perform eigenvalue/matrix block exchange. C CALL MB03CD( 'Upper', DIM1, DIM2, PREC, DWORK( IC ), SDIM, $ DWORK( IA ), SDIM, DWORK( IB ), SDIM, $ DWORK( IQ1 ), SDIM, DWORK( IQ2 ), SDIM, $ DWORK( IQ3 ), SDIM, DWORK( IWRK1 ), $ LDWORK-IWRK1+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Copy the transformed diagonal block of B, if sdim > 2. C IF( SDIM.GT.2 ) THEN CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM, $ B( IB1, IB1 ), LDB ) CALL DCOPY( SDIM-1, DWORK( IB+1 ), SDIM+1, $ B( IB1+1, IB1 ), LDB+1 ) END IF C NROWS = IB1 - 1 NCOLS = M - IB3 + 1 NROW = IB3 - 1 NCOL = M - IB1 + 1 CALL DLACPY( 'Lower', SDIM-1, SDIM-1, A( IB1+1, IB1 ), LDA, $ DUM, 3 ) CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO, $ A( IB1+1, IB1 ), LDA ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, C( IB1, IB1+1 ), LDC, $ DUM( 1, 2 ), 3 ) CALL DLASET( 'Upper', SDIM-1, SDIM-1, ZERO, ZERO, $ C( IB1, IB1+1 ), LDC ) C C Update A. C CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), NROW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), NROW, $ A( 1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, SDIM, $ ONE, DWORK( IQ2 ), SDIM, A( IB1, IB1 ), LDA, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ A( IB1, IB1 ), LDA ) CALL DLACPY( 'Lower', SDIM-1, SDIM-1, DUM, 3, $ A( IB1+1, IB1 ), LDA ) C C Update C. C CALL DGEMM( 'No Transpose', 'No Transpose', NCOL, SDIM, $ SDIM, ONE, C( IB1, IB1 ), LDC, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), NCOL ) CALL DLACPY( 'Full', NCOL, SDIM, DWORK( IWRK2 ), NCOL, $ C( IB1, IB1 ), LDC ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NROW, SDIM, $ ONE, DWORK( IQ2 ), SDIM, C( IB1, 1 ), LDC, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NROW, DWORK( IWRK2 ), SDIM, $ C( IB1, 1 ), LDC ) CALL DLACPY( 'Upper', SDIM-1, SDIM-1, DUM( 1, 2 ), 3, $ C( IB1, IB1+1 ), LDC ) C C Update D. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, SDIM, $ ONE, D( 1, IB1 ), LDD, DWORK( IQ3 ), SDIM, $ ZERO, DWORK( IWRK2 ), M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ D( 1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, M, SDIM, $ ONE, DWORK( IQ2 ), SDIM, D( IB1, 1 ), LDD, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, M, DWORK( IWRK2 ), SDIM, $ D( IB1, 1 ), LDD ) C C Update B. C IF( SDIM.GT.2 ) THEN NROW = NROWS NCOL = NCOLS IBS = IB3 LDW = MAX( 1, NROW ) ELSE IBS = IB1 LDW = NROW END IF CALL DGEMM( 'No Transpose', 'No Transpose', NROW, SDIM, $ SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW, $ B( 1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOL, SDIM, $ ONE, DWORK( IQ3 ), SDIM, B( IB1, IBS ), LDB, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM, $ B( IB1, IBS ), LDB ) C C Update F. C CALL DGEMM( 'No Transpose', 'No Transpose', NROWS, SDIM, $ SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), LDW ) CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW, $ F( 1, IB1 ), LDF ) CALL DGEMM( 'Transpose', 'No Transpose', SDIM, NCOLS, SDIM, $ ONE, DWORK( IQ3 ), SDIM, F( IB1, IB3 ), LDF, $ ZERO, DWORK( IWRK2 ), SDIM ) CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM, $ F( IB1, IB3 ), LDF ) CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE, $ F( IB1, IB1 ), LDF, DWORK( IQ3 ), SDIM, $ F( IB1, IB1 ), LDF, DWORK( IWRK2 ), $ LDWORK-IWRK2+1, INFO ) CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 ) C IF( LCMPQ ) THEN C C Update Q. C CALL DGEMM( 'No Transpose', 'No Transpose', N, SDIM, $ SDIM, ONE, Q( 1, IB1 ), LDQ, DWORK( IQ1 ), $ SDIM, ZERO, DWORK( IWRK2 ), N ) CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N, $ Q( 1, IB1 ), LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, SDIM, $ SDIM, ONE, Q( 1, M+IB1 ), LDQ, DWORK( IQ3 ), $ SDIM, ZERO, DWORK( IWRK2 ), N ) CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N, $ Q( 1, M+IB1 ), LDQ ) END IF C IF( LCMPU ) THEN C C Update U. C CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U1( 1, IB1 ), LDU1, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U1( 1, IB1 ), LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, SDIM, $ SDIM, ONE, U2( 1, IB1 ), LDU2, DWORK( IQ2 ), $ SDIM, ZERO, DWORK( IWRK2 ), M ) CALL DLACPY( 'Full', M, SDIM, DWORK( IWRK2 ), M, $ U2( 1, IB1 ), LDU2 ) END IF C C Update index list IWORK(1:M)if a 1-by-1 and 2-by-2 block C have been swapped. C HLP = DIM2 - DIM1 IF( HLP.EQ.1 ) THEN C C First block was 2-by-2. C IWORK( J+1 ) = IB1 + 1 ELSE IF( HLP.EQ.-1 ) THEN C C Second block was 2-by-2. C IWORK( J+1 ) = IB1 + 2 END IF 60 CONTINUE 70 CONTINUE C IF( M.GT.1 ) THEN C C Restore the elements A(M,M-1), C(M-1,M), and F(M,M-1). C A( M, M-1 ) = A2 C( M-1, M ) = C2 F( M, M-1 ) = F2 END IF C IF( MM.GT.0 ) THEN NEIG = IWORK( MM+1 ) - 1 ELSE NEIG = 0 END IF C RETURN C *** Last line of MB03ID *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04MU.f0000644000000000000000000000013215012430707016207 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04MU.f0000644000175000017500000001141515012430707017405 0ustar00lilgelilge00000000000000 SUBROUTINE SB04MU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, $ INFO ) 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 control-4.1.2/src/slicot/src/PaxHeaders/TF01ND.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TF01ND.f0000644000175000017500000001776315012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE TF01ND( UPLO, N, M, P, NY, A, LDA, B, LDB, C, LDC, D, $ LDD, U, LDU, X, Y, LDY, DWORK, INFO ) C C PURPOSE C C To compute the output sequence of a linear time-invariant C open-loop system given by its discrete-time state-space model C (A,B,C,D), where A is an N-by-N upper or lower Hessenberg matrix. C C The initial state vector x(1) must be supplied by the user. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Indicates whether the user wishes to use an upper or lower C Hessenberg matrix as follows: C = 'U': Upper Hessenberg matrix; C = 'L': Lower Hessenberg matrix. 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 number of system inputs. M >= 0. C C P (input) INTEGER C The number of system outputs. P >= 0. C C NY (input) INTEGER C The number of output vectors y(k) to be computed. C NY >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C If UPLO = 'U', the leading N-by-N upper Hessenberg part C of this array must contain the state matrix A of the C system. C If UPLO = 'L', the leading N-by-N lower Hessenberg part C of this array must contain the state matrix A of the C system. C The remainder of the leading N-by-N part is not C referenced. 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 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 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 link matrix D of the system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C U (input) DOUBLE PRECISION array, dimension (LDU,NY) C The leading M-by-NY part of this array must contain the C input vector sequence u(k), for k = 1,2,...,NY. C Specifically, the k-th column of U must contain u(k). C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,M). C C X (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the initial state vector C x(1) which consists of the N initial states of the system. C On exit, this array contains the final state vector C x(NY+1) of the N states of the system at instant NY. C C Y (output) DOUBLE PRECISION array, dimension (LDY,NY) C The leading P-by-NY part of this array contains the output C vector sequence y(1),y(2),...,y(NY) such that the k-th C column of Y contains y(k) (the outputs at instant k), C for k = 1,2,...,NY. C C LDY INTEGER C The leading dimension of array Y. LDY >= MAX(1,P). 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 METHOD C C Given an initial state vector x(1), the output vector sequence C y(1), y(2),..., y(NY) is obtained via the formulae C C x(k+1) = A x(k) + B u(k) C y(k) = C x(k) + D u(k), C C where each element y(k) is a vector of length P containing the C outputs at instant k and k = 1,2,...,NY. C C REFERENCES C C [1] Luenberger, D.G. C Introduction to Dynamic Systems: Theory, Models and C Applications. C John Wiley & Sons, New York, 1979. C C NUMERICAL ASPECTS C C The algorithm requires approximately ((N+M)xP + (N/2+M)xN) x NY C multiplications and additions. C C FURTHER COMMENTS C C The processing time required by this routine will be approximately C half that required by the SLICOT Library routine TF01MD, which C treats A as a general matrix. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TF01BD by S. Van Huffel, Katholieke C Univ. Leuven, Belgium. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. C C KEYWORDS C C Discrete-time system, Hessenberg form, multivariable system, C state-space model, state-space representation, time response. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDY, M, N, NY, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) C .. Local Scalars .. LOGICAL LUPLO INTEGER I, IK C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, DTRMV, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C INFO = 0 LUPLO = LSAME( UPLO, 'U' ) C C Test the input scalar arguments. C IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) 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( NY.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( LDU.LT.MAX( 1, M ) ) THEN INFO = -15 ELSE IF( LDY.LT.MAX( 1, P ) ) THEN INFO = -18 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TF01ND', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( P, NY ).EQ.0 ) THEN RETURN ELSE IF ( N.EQ.0 ) THEN C C Non-dynamic system: compute the output vectors. C IF ( M.EQ.0 ) THEN CALL DLASET( 'Full', P, NY, ZERO, ZERO, Y, LDY ) ELSE CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, $ D, LDD, U, LDU, ZERO, Y, LDY ) END IF RETURN END IF C CALL DCOPY( N, X, 1, DWORK, 1 ) C DO 30 IK = 1, NY CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, DWORK, 1, ZERO, $ Y(1,IK), 1 ) C CALL DTRMV( UPLO, 'No transpose', 'Non-unit', N, A, LDA, $ DWORK, 1 ) C IF ( LUPLO ) THEN C DO 10 I = 2, N DWORK(I) = DWORK(I) + A(I,I-1)*X(I-1) 10 CONTINUE C ELSE C DO 20 I = 1, N - 1 DWORK(I) = DWORK(I) + A(I,I+1)*X(I+1) 20 CONTINUE C END IF C CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(1,IK), 1, ONE, $ DWORK, 1 ) C CALL DCOPY( N, DWORK, 1, X, 1 ) 30 CONTINUE C CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, D, LDD, $ U, LDU, ONE, Y, LDY ) C RETURN C *** Last line of TF01ND *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09JV.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB09JV.f0000644000175000017500000010563415012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE AB09JV( JOB, DICO, JOBEV, STBCHK, N, M, P, NV, PV, $ A, LDA, B, LDB, C, LDC, D, LDD, AV, LDAV, $ EV, LDEV, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To construct a state-space representation (A,BS,CS,DS) of the C projection of V*G or conj(V)*G containing the poles of G, from the C state-space representations (A,B,C,D) and (AV-lambda*EV,BV,CV,DV), C of the transfer-function matrices G and V, respectively. C G is assumed to be a stable transfer-function matrix and C the state matrix A must be in a real Schur form. C When computing the stable projection of V*G, it is assumed C that G and V have completely distinct poles. C When computing the stable projection of conj(V)*G, it is assumed C that G and conj(V) have completely distinct poles. C C Note: For a transfer-function matrix G, conj(G) denotes the C conjugate of G given by G'(-s) for a continuous-time system or C G'(1/z) for a discrete-time system. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the projection to be computed as follows: C = 'V': compute the projection of V*G containing C the poles of G; C = 'C': compute the projection of conj(V)*G containing C the poles of G. C C DICO CHARACTER*1 C Specifies the type of the systems as follows: C = 'C': G and V are continuous-time systems; C = 'D': G and V are discrete-time systems. C C JOBEV CHARACTER*1 C Specifies whether EV is a general square or an identity C matrix as follows: C = 'G': EV is a general square matrix; C = 'I': EV is the identity matrix. C C STBCHK CHARACTER*1 C Specifies whether stability/antistability of V is to be C checked as follows: C = 'C': check stability if JOB = 'C' or antistability if C JOB = 'V'; C = 'N': do not check stability or antistability. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the state vector of the system with C the transfer-function matrix G. N >= 0. C C M (input) INTEGER C The dimension of the input vector of the system with C the transfer-function matrix G. M >= 0. C C P (input) INTEGER C The dimension of the output vector of the system with the C transfer-function matrix G, and also the dimension of C the input vector if JOB = 'V', or of the output vector C if JOB = 'C', of the system with the transfer-function C matrix V. P >= 0. C C NV (input) INTEGER C The dimension of the state vector of the system with C the transfer-function matrix V. NV >= 0. C C PV (input) INTEGER C The dimension of the output vector, if JOB = 'V', or C of the input vector, if JOB = 'C', of the system with C the transfer-function matrix V. PV >= 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 matrix A of the system with the transfer-function C matrix G in a real Schur form. 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 C the input/state matrix B of the system with the C transfer-function matrix G. The matrix BS is equal to B. C C LDB INTEGER C The leading dimension of the 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 output matrix C of the system with the C transfer-function matrix G. C On exit, if INFO = 0, the leading PV-by-N part of this C array contains the output matrix CS of the projection of C V*G, if JOB = 'V', or of conj(V)*G, if JOB = 'C'. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P,PV). 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 feedthrough matrix D of the system with the C transfer-function matrix G. C On exit, if INFO = 0, the leading PV-by-M part of C this array contains the feedthrough matrix DS of the C projection of V*G, if JOB = 'V', or of conj(V)*G, C if JOB = 'C'. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1,P,PV). C C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) C On entry, the leading NV-by-NV part of this array must C contain the state matrix AV of the system with the C transfer-function matrix V. C On exit, if INFO = 0, the leading NV-by-NV part of this C array contains a condensed matrix as follows: C if JOBEV = 'I', it contains the real Schur form of AV; C if JOBEV = 'G' and JOB = 'V', it contains a quasi-upper C triangular matrix representing the real Schur matrix C in the real generalized Schur form of the pair (AV,EV); C if JOBEV = 'G', JOB = 'C' and DICO = 'C', it contains a C quasi-upper triangular matrix corresponding to the C generalized real Schur form of the pair (AV',EV'); C if JOBEV = 'G', JOB = 'C' and DICO = 'D', it contains an C upper triangular matrix corresponding to the generalized C real Schur form of the pair (EV',AV'). C C LDAV INTEGER C The leading dimension of the array AV. LDAV >= MAX(1,NV). C C EV (input/output) DOUBLE PRECISION array, dimension (LDEV,NV) C On entry, if JOBEV = 'G', the leading NV-by-NV part of C this array must contain the descriptor matrix EV of the C system with the transfer-function matrix V. C If JOBEV = 'I', EV is assumed to be an identity matrix C and is not referenced. C On exit, if INFO = 0 and JOBEV = 'G', the leading NV-by-NV C part of this array contains a condensed matrix as follows: C if JOB = 'V', it contains an upper triangular matrix C corresponding to the real generalized Schur form of the C pair (AV,EV); C if JOB = 'C' and DICO = 'C', it contains an upper C triangular matrix corresponding to the generalized real C Schur form of the pair (AV',EV'); C if JOB = 'C' and DICO = 'D', it contains a quasi-upper C triangular matrix corresponding to the generalized C real Schur form of the pair (EV',AV'). C C LDEV INTEGER C The leading dimension of the array EV. C LDEV >= MAX(1,NV), if JOBEV = 'G'; C LDEV >= 1, if JOBEV = 'I'. C C BV (input/output) DOUBLE PRECISION array, C dimension (LDBV,MBV), where MBV = P, if JOB = 'V', and C MBV = PV, if JOB = 'C'. C On entry, the leading NV-by-MBV part of this array must C contain the input matrix BV of the system with the C transfer-function matrix V. C On exit, if INFO = 0, the leading NV-by-MBV part of this C array contains Q'*BV, where Q is the orthogonal matrix C that reduces AV to the real Schur form or the left C orthogonal matrix used to reduce the pair (AV,EV), C (AV',EV') or (EV',AV') to the generalized real Schur form. C C LDBV INTEGER C The leading dimension of the array BV. LDBV >= MAX(1,NV). C C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) C On entry, the leading PCV-by-NV part of this array must C contain the output matrix CV of the system with the C transfer-function matrix V, where PCV = PV, if JOB = 'V', C or PCV = P, if JOB = 'C'. C On exit, if INFO = 0, the leading PCV-by-NV part of this C array contains CV*Q, where Q is the orthogonal matrix that C reduces AV to the real Schur form, or CV*Z, where Z is the C right orthogonal matrix used to reduce the pair (AV,EV), C (AV',EV') or (EV',AV') to the generalized real Schur form. C C LDCV INTEGER C The leading dimension of the array CV. C LDCV >= MAX(1,PV) if JOB = 'V'; C LDCV >= MAX(1,P) if JOB = 'C'. C C DV (input) DOUBLE PRECISION array, C dimension (LDDV,MBV), where MBV = P, if JOB = 'V', and C MBV = PV, if JOB = 'C'. C The leading PCV-by-MBV part of this array must contain C the feedthrough matrix DV of the system with the C transfer-function matrix V, where PCV = PV, if JOB = 'V', C or PCV = P, if JOB = 'C'. C C LDDV INTEGER C The leading dimension of the array DV. C LDDV >= MAX(1,PV) if JOB = 'V'; C LDDV >= MAX(1,P) if JOB = 'C'. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = 0, if JOBEV = 'I'; C LIWORK = NV+N+6, if JOBEV = 'G'. 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 >= LW1, if JOBEV = 'I', C LDWORK >= LW2, if JOBEV = 'G', where C LW1 = MAX( 1, NV*(NV+5), NV*N + MAX( a, PV*N, PV*M ) ) C a = 0, if DICO = 'C' or JOB = 'V', C a = 2*NV, if DICO = 'D' and JOB = 'C'; C LW2 = MAX( 2*NV*NV + MAX( 11*NV+16, P*NV, PV*NV ), C NV*N + MAX( NV*N+N*N, PV*N, PV*M ) ). C For good 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: the reduction of the pair (AV,EV) to the real C generalized Schur form failed (JOBEV = 'G'), C or the reduction of the matrix AV to the real C Schur form failed (JOBEV = 'I); C = 2: the solution of the Sylvester equation failed C because the matrix A and the pencil AV-lambda*EV C have common eigenvalues (if JOB = 'V'), or the C pencil -AV-lambda*EV and A have common eigenvalues C (if JOB = 'C' and DICO = 'C'), or the pencil C AV-lambda*EV has an eigenvalue which is the C reciprocal of one of eigenvalues of A C (if JOB = 'C' and DICO = 'D'); C = 3: the solution of the Sylvester equation failed C because the matrices A and AV have common C eigenvalues (if JOB = 'V'), or the matrices A C and -AV have common eigenvalues (if JOB = 'C' and C DICO = 'C'), or the matrix A has an eigenvalue C which is the reciprocal of one of eigenvalues of AV C (if JOB = 'C' and DICO = 'D'); C = 4: JOB = 'V' and the pair (AV,EV) has not completely C unstable generalized eigenvalues, or JOB = 'C' and C the pair (AV,EV) has not completely stable C generalized eigenvalues. C C METHOD C C If JOB = 'V', the matrices of the stable projection of V*G are C computed as C C BS = B, CS = CV*X + DV*C, DS = DV*D, C C where X satisfies the generalized Sylvester equation C C AV*X - EV*X*A + BV*C = 0. C C If JOB = 'C', the matrices of the stable projection of conj(V)*G C are computed using the following formulas: C C - for a continuous-time system, the matrices BS, CS and DS of C the stable projection are computed as C C BS = B, CS = BV'*X + DV'*C, DS = DV'*D, C C where X satisfies the generalized Sylvester equation C C AV'*X + EV'*X*A + CV'*C = 0. C C - for a discrete-time system, the matrices BS, CS and DS of C the stable projection are computed as C C BS = B, CS = BV'*X*A + DV'*C, DS = DV'*D + BV'*X*B, C C where X satisfies the generalized Sylvester equation C C EV'*X - AV'*X*A = CV'*C. C C REFERENCES C C [1] Varga, A. C Efficient and numerically reliable implementation of the C frequency-weighted Hankel-norm approximation model reduction C approach. C Proc. 2001 ECC, Porto, Portugal, 2001. C C [2] Zhou, K. C Frequency-weighted H-infinity norm and optimal Hankel norm C model reduction. C IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995. C C NUMERICAL ASPECTS C C The implemented methods rely on numerically stable algorithms. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. C D. Sima, University of Bucharest, March 2001. C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. C C REVISIONS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. C V. Sima, Research Institute for Informatics, Bucharest, June 2001. C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. C V. Sima, Research Institute for Informatics, Bucharest, May 2010. C C KEYWORDS C C Frequency weighting, model reduction, multivariable system, C state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOB, JOBEV, STBCHK INTEGER INFO, LDA, LDAV, LDB, LDBV, LDC, LDCV, $ LDD, LDDV, LDEV, LDWORK, M, N, NV, P, PV C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), AV(LDAV,*), B(LDB,*), BV(LDBV,*), $ C(LDC,*), CV(LDCV,*), D(LDD,*), DV(LDDV,*), $ DWORK(*), EV(LDEV,*) C .. Local Scalars .. CHARACTER*1 EVTYPE, STDOM LOGICAL CONJS, DISCR, STABCK, UNITEV DOUBLE PRECISION ALPHA, DIF, SCALE, TOLINF, WORK INTEGER I, IA, IERR, KAI, KAR, KB, KC, KE, KF, KQ, KW, $ KZ, LDW, LDWN, LW, SDIM C .. Local Arrays .. LOGICAL BWORK(1) C .. External Functions .. LOGICAL DELCTG, LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DELCTG, DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL AB09JX, DGEMM, DGGES, DLACPY, DLASET, DSWAP, $ DTGSYL, DTRSYL, SB04PY, TB01WD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, SQRT C C .. Executable Statements .. C CONJS = LSAME( JOB, 'C' ) DISCR = LSAME( DICO, 'D' ) UNITEV = LSAME( JOBEV, 'I' ) STABCK = LSAME( STBCHK, 'C' ) C INFO = 0 IF( UNITEV ) THEN IF ( DISCR .AND. CONJS ) THEN IA = 2*NV ELSE IA = 0 END IF LW = MAX( 1, NV*( NV + 5 ), NV*N + MAX( IA, PV*N, PV*M ) ) ELSE LW = MAX( 2*NV*NV + MAX( 11*NV+16, P*NV, PV*NV ), $ NV*N + MAX( NV*N + N*N, PV*N, PV*M ) ) END IF C C Test the input scalar arguments. C LDWN = MAX( 1, N ) LDW = MAX( 1, NV ) IF( .NOT. ( LSAME( JOB, 'V' ) .OR. CONJS ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -2 ELSE IF( .NOT. ( LSAME( JOBEV, 'G' ) .OR. UNITEV ) ) THEN INFO = -3 ELSE IF( .NOT. ( LSAME( STBCHK, 'N' ) .OR. STABCK ) ) 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( NV.LT.0 ) THEN INFO = -8 ELSE IF( PV.LT.0 ) THEN INFO = -9 ELSE IF( LDA.LT.LDWN ) THEN INFO = -11 ELSE IF( LDB.LT.LDWN ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P, PV ) ) THEN INFO = -15 ELSE IF( LDD.LT.MAX( 1, P, PV ) ) THEN INFO = -17 ELSE IF( LDAV.LT.LDW ) THEN INFO = -19 ELSE IF( LDEV.LT.1 .OR. ( .NOT.UNITEV .AND. LDEV.LT.NV ) ) THEN INFO = -21 ELSE IF( LDBV.LT.LDW ) THEN INFO = -23 ELSE IF( ( .NOT.CONJS .AND. LDCV.LT.MAX( 1, PV ) ) .OR. $ ( CONJS .AND. LDCV.LT.MAX( 1, P ) ) ) THEN INFO = -25 ELSE IF( ( .NOT.CONJS .AND. LDDV.LT.MAX( 1, PV ) ) .OR. $ ( CONJS .AND. LDDV.LT.MAX( 1, P ) ) ) THEN INFO = -27 ELSE IF( LDWORK.LT.LW ) THEN INFO = -30 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09JV', -INFO ) RETURN END IF C C Quick return if possible. C IF( P.EQ.0 .OR. PV.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Set options for stability/antistability checking. C IF( DISCR ) THEN ALPHA = ONE ELSE ALPHA = ZERO END IF C WORK = ONE TOLINF = DLAMCH( 'Precision' ) C IF( UNITEV ) THEN C C EV is the identity matrix. C IF( NV.GT.0 ) THEN C C Reduce AV to the real Schur form using an orthogonal C similarity transformation AV <- Q'*AV*Q and apply the C transformation to BV and CV: BV <- Q'*BV and CV <- CV*Q. C C Workspace needed: NV*(NV+5); C prefer larger. C KW = NV*( NV + 2 ) + 1 IF( CONJS ) THEN STDOM = 'S' ALPHA = ALPHA + SQRT( TOLINF ) CALL TB01WD( NV, PV, P, AV, LDAV, BV, LDBV, CV, LDCV, $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), $ DWORK(KW), LDWORK-KW+1, IERR ) ELSE STDOM = 'U' ALPHA = ALPHA - SQRT( TOLINF ) CALL TB01WD( NV, P, PV, AV, LDAV, BV, LDBV, CV, LDCV, $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), $ DWORK(KW), LDWORK-KW+1, IERR ) END IF IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF IF( STABCK ) THEN C C Check stability/antistability of eigenvalues of AV. C CALL AB09JX( DICO, STDOM, 'S', NV, ALPHA, DWORK, $ DWORK(NV+1), DWORK, TOLINF, IERR ) IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF END IF C WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) C END IF C KW = NV*N + 1 IF( CONJS ) THEN C C Compute the projection of conj(V)*G. C C Total workspace needed: NV*N + MAX( a, PV*N, PV*M ), where C a = 0, if DICO = 'C', C a = 2*NV, if DICO = 'D'. C C Compute -CV'*C. C Workspace needed: NV*N. C CALL DGEMM( 'T', 'N', NV, N, P, -ONE, CV, LDCV, C, LDC, $ ZERO, DWORK, LDW ) C IF( DISCR ) THEN C C Compute X and SCALE satisfying C C AV'*X*A - X = -SCALE*CV'*C. C C Additional workspace needed: 2*NV. C CALL SB04PY( 'T', 'N', -1, NV, N, AV, LDAV, A, LDA, $ DWORK, LDW, SCALE, DWORK(KW), IERR ) IF( IERR.NE.0 ) THEN INFO = 3 RETURN END IF C C Construct CS = DV'*C + BV'*X*A/SCALE, C DS = DV'*D + BV'*X*B/SCALE. C C Additional workspace needed: MAX( PV*N, PV*M ). C C C <- DV'*C. C CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) C C D <- DV'*D. C CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) C C C <- C + BV'*X*A/SCALE. C CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, $ DWORK, LDW, ZERO, DWORK(KW), PV ) CALL DGEMM( 'N', 'N', PV, N, N, ONE, DWORK(KW), PV, $ A, LDA, ONE, C, LDC ) C C D <- D + BV'*X*B/SCALE. C CALL DGEMM( 'N', 'N', PV, M, N, ONE, DWORK(KW), PV, $ B, LDB, ONE, D, LDD ) ELSE C C Compute X and SCALE satisfying C C AV'*X + X*A + SCALE*CV'*C = 0. C IF( N.GT.0 ) THEN CALL DTRSYL( 'T', 'N', 1, NV, N, AV, LDAV, A, LDA, $ DWORK, LDW, SCALE, IERR ) IF( IERR.NE.0 ) THEN INFO = 3 RETURN END IF END IF C C Construct CS = DV'*C + BV'*X/SCALE, C DS = DV'*D. C Additional workspace needed: MAX( PV*N, PV*M ). C C Construct C <- DV'*C + BV'*X/SCALE. C CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, $ DWORK, LDW, ONE, C, LDC ) C C Construct D <- DV'*D. C CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) END IF ELSE C C Compute the projection of V*G. C C Total workspace needed: NV*N + MAX( PV*N, PV*M ). C C Compute -BV*C. C Workspace needed: NV*N. C CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, $ ZERO, DWORK, LDW ) C C Compute X and SCALE satisfying C C AV*X - X*A + SCALE*BV*C = 0. C IF( N.GT.0 ) THEN CALL DTRSYL( 'N', 'N', -1, NV, N, AV, LDAV, A, LDA, $ DWORK, LDW, SCALE, IERR ) IF( IERR.NE.0 ) THEN INFO = 3 RETURN END IF END IF C C Construct CS = DV*C + CV*X/SCALE, C DS = DV*D. C Additional workspace needed: MAX( PV*N, PV*M ). C C Construct C <- DV*C + CV*X/SCALE. C CALL DGEMM( 'N', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) CALL DGEMM( 'N', 'N', PV, N, NV, ONE / SCALE, CV, LDCV, $ DWORK, LDW, ONE, C, LDC ) C C Construct D <- DV*D. C CALL DGEMM( 'N', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) END IF ELSE C C EV is a general matrix. C IF( NV.GT.0 ) THEN TOLINF = TOLINF * DLANGE( '1', NV, NV, EV, LDEV, DWORK ) C C Reduce (AV,EV), or (AV',EV') or (EV',AV') to a generalized C real Schur form using an orthogonal equivalence C transformation and apply the orthogonal transformation C appropriately to BV and CV, or CV' and BV'. C C Workspace needed: 2*NV*NV + MAX( 11*NV+16, NV*P, NV*PV ); C prefer larger. C KQ = 1 KZ = KQ + NV*NV KAR = KZ + NV*NV KAI = KAR + NV KB = KAI + NV KW = KB + NV C IF( CONJS ) THEN STDOM = 'S' ALPHA = ALPHA + SQRT( TOLINF ) C C Transpose AV and EV, if non-scalar. C DO 10 I = 1, NV - 1 CALL DSWAP( NV-I, AV(I+1,I), 1, AV(I,I+1), LDAV ) CALL DSWAP( NV-I, EV(I+1,I), 1, EV(I,I+1), LDEV ) 10 CONTINUE C IF( DISCR ) THEN C C Reduce (EV',AV') to a generalized real Schur form C using orthogonal transformation matrices Q and Z C such that Q'*EV'*Z results in a quasi-triangular form C and Q'*AV'*Z results upper triangular. C Total workspace needed: 2*NV*NV + 11*NV + 16. C EVTYPE = 'R' CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', $ DELCTG, NV, EV, LDEV, AV, LDAV, SDIM, $ DWORK(KAR), DWORK(KAI), DWORK(KB), $ DWORK(KQ), LDW, DWORK(KZ), LDW, $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) ELSE C C Reduce (AV',EV') to a generalized real Schur form C using orthogonal transformation matrices Q and Z C such that Q'*AV'*Z results in a quasi-triangular form C and Q'*EV'*Z results upper triangular. C Total workspace needed: 2*NV*NV + 11*NV + 16. C EVTYPE = 'G' CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', $ DELCTG, NV, AV, LDAV, EV, LDEV, SDIM, $ DWORK(KAR), DWORK(KAI), DWORK(KB), $ DWORK(KQ), LDW, DWORK(KZ), LDW, $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) END IF IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF IF( STABCK ) THEN C C Check stability/antistability of generalized C eigenvalues of the pair (AV,EV). C CALL AB09JX( DICO, STDOM, EVTYPE, NV, ALPHA, $ DWORK(KAR), DWORK(KAI), DWORK(KB), $ TOLINF, IERR ) IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF END IF WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) C C Compute Z'*BV and CV*Q. C Total workspace needed: 2*NV*NV + NV*MAX(P,PV). C KW = KAR CALL DLACPY( 'Full', NV, PV, BV, LDBV, DWORK(KW), LDW ) CALL DGEMM( 'T', 'N', NV, PV, NV, ONE, DWORK(KZ), LDW, $ DWORK(KW), LDW, ZERO, BV, LDBV ) CALL DLACPY( 'Full', P, NV, CV, LDCV, DWORK(KW), P ) CALL DGEMM( 'N', 'N', P, NV, NV, ONE, DWORK(KW), P, $ DWORK(KQ), LDW, ZERO, CV, LDCV ) ELSE C C Reduce (AV,EV) to a generalized real Schur form C using orthogonal transformation matrices Q and Z C such that Q'*AV*Z results in a quasi-triangular form C and Q'*EV*Z results upper triangular. C Total workspace needed: 2*NV*NV + 11*NV + 16. C STDOM = 'U' EVTYPE = 'G' ALPHA = ALPHA - SQRT( TOLINF ) CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', $ DELCTG, NV, AV, LDAV, EV, LDEV, SDIM, $ DWORK(KAR), DWORK(KAI), DWORK(KB), $ DWORK(KQ), LDW, DWORK(KZ), LDW, $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF IF( STABCK ) THEN C C Check stability/antistability of generalized C eigenvalues of the pair (AV,EV). C CALL AB09JX( DICO, STDOM, EVTYPE, NV, ALPHA, $ DWORK(KAR), DWORK(KAI), DWORK(KB), $ TOLINF, IERR ) IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF END IF WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) C C Compute Q'*BV and CV*Z. C Total workspace needed: 2*NV*NV + NV*MAX(P,PV). C KW = KAR CALL DLACPY( 'Full', NV, P, BV, LDBV, DWORK(KW), LDW ) CALL DGEMM( 'T', 'N', NV, P, NV, ONE, DWORK(KQ), LDW, $ DWORK(KW), LDW, ZERO, BV, LDBV ) CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KW), PV ) CALL DGEMM( 'N', 'N', PV, NV, NV, ONE, DWORK(KW), PV, $ DWORK(KZ), LDW, ZERO, CV, LDCV ) END IF WORK = MAX( WORK, DBLE( 2*NV*NV + NV*MAX( P, PV ) ) ) C END IF C KC = 1 KF = KC + NV*N KE = KF + NV*N KW = KE + N*N CALL DLASET( 'Full', NV, N, ZERO, ZERO, DWORK(KF), LDW ) C IF( CONJS ) THEN C C Compute the projection of conj(V)*G. C C Total workspace needed: NV*N + MAX( NV*N+N*N, PV*N, PV*M ) C C Compute CV'*C. C Workspace needed: NV*N. C CALL DGEMM( 'T', 'N', NV, N, P, ONE, CV, LDCV, C, LDC, $ ZERO, DWORK(KC), LDW ) C IF( DISCR ) THEN C C Compute X and SCALE satisfying C C EV'*X - AV'*X*A = SCALE*CV'*C by solving equivalently C C EV'*X - Y*A = SCALE*CV'*C, C AV'*X - Y = 0. C C Additional workspace needed: C real NV*N + N*N; C integer NV+N+6. C IF( N.GT.0 ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN $ ) CALL DTGSYL( 'N', 0, NV, N, EV, LDEV, A, LDA, $ DWORK(KC), LDW, AV, LDAV, DWORK(KE), $ LDWN, DWORK(KF), LDW, SCALE, DIF, $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) IF( IERR.NE.0 ) THEN INFO = 2 RETURN END IF END IF C C Construct C <- DV'*C + BV'*X*A/SCALE, C D <- DV'*D + BV'*X*B/SCALE. C C Additional workspace needed: MAX( PV*N, PV*M ). C C C <- DV'*C. C KW = KF CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) C C D <- DV'*D. C CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) C C C <- C + BV'*X*A/SCALE. C CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, $ DWORK(KC), LDW, ZERO, DWORK(KW), PV ) CALL DGEMM( 'N', 'N', PV, N, N, ONE, DWORK(KW), PV, $ A, LDA, ONE, C, LDC ) C C D <- D + BV'*X*B/SCALE. C CALL DGEMM( 'N', 'N', PV, M, N, ONE, DWORK(KW), PV, $ B, LDB, ONE, D, LDD ) ELSE C C Compute X and SCALE satisfying C C AV'*X + EV'*X*A + SCALE*CV'*C = 0 by solving equivalently C C AV'*X - Y*A = -SCALE*CV'*C, C EV'*X - Y*(-I) = 0. C C Additional workspace needed: C real NV*N+N*N; C integer NV+N+6. C IF( N.GT.0 ) THEN CALL DLASET( 'Full', N, N, ZERO, -ONE, DWORK(KE), LDWN $ ) CALL DTGSYL( 'N', 0, NV, N, AV, LDAV, A, LDA, $ DWORK(KC), LDW, EV, LDEV, DWORK(KE), $ LDWN, DWORK(KF), LDW, SCALE, DIF, $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) C C Note that the computed solution in DWORK(KC) is -X. C IF( IERR.NE.0 ) THEN INFO = 2 RETURN END IF END IF C C Construct C <- DV'*C + BV'*X/SCALE. C KW = KF CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) CALL DGEMM( 'T', 'N', PV, N, NV, -ONE / SCALE, BV, LDBV, $ DWORK(KC), LDW, ONE, C, LDC ) C C Construct D <- DV'*D. C CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) END IF ELSE C C Compute the projection of V*G. C C Total workspace needed: NV*N + MAX( NV*N+N*N, PV*N, PV*M ) C C Compute -BV*C. C Workspace needed: NV*N. C CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, $ ZERO, DWORK, LDW ) C C Compute X and SCALE satisfying C C AV*X - EV*X*A + SCALE*BV*C = 0 by solving equivalently C C AV*X - Y*A = -SCALE*BV*C, C EV*X - Y = 0. C C Additional workspace needed: C real NV*N + N*N; C integer NV+N+6. C IF( N.GT.0 ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN ) CALL DTGSYL( 'N', 0, NV, N, AV, LDAV, A, LDA, $ DWORK(KC), LDW, EV, LDEV, DWORK(KE), LDWN, $ DWORK(KF), LDW, SCALE, DIF, DWORK(KW), $ LDWORK-KW+1, IWORK, IERR ) IF( IERR.NE.0 ) THEN INFO = 2 RETURN END IF END IF C C Construct C <- DV*C + CV*X/SCALE. C KW = KF CALL DGEMM( 'N', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) CALL DGEMM( 'N', 'N', PV, N, NV, ONE / SCALE, CV, LDCV, $ DWORK, LDW, ONE, C, LDC ) C C Construct D <- DV*D. C CALL DGEMM( 'N', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, $ ZERO, DWORK(KW), PV ) CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) END IF END IF C DWORK(1) = MAX( WORK, DBLE( LW ) ) C RETURN C *** Last line of AB09JV *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01QD.f0000644000000000000000000000013015012430707016160 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MC01QD.f0000644000175000017500000001276615012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE MC01QD( DA, DB, A, B, RQ, IWARN, INFO ) C C PURPOSE C C To compute, for two given real polynomials A(x) and B(x), the C quotient polynomial Q(x) and the remainder polynomial R(x) of C A(x) divided by B(x). C C The polynomials Q(x) and R(x) satisfy the relationship C C A(x) = B(x) * Q(x) + R(x), C C where the degree of R(x) is less than the degree of B(x). C C ARGUMENTS C C Input/Output Parameters C C DA (input) INTEGER C The degree of the numerator polynomial A(x). DA >= -1. C C DB (input/output) INTEGER C On entry, the degree of the denominator polynomial B(x). C DB >= 0. C On exit, if B(DB+1) = 0.0 on entry, then DB contains the C index of the highest power of x for which B(DB+1) <> 0.0. C C A (input) DOUBLE PRECISION array, dimension (DA+1) C This array must contain the coefficients of the C numerator polynomial A(x) in increasing powers of x C unless DA = -1 on entry, in which case A(x) is taken C to be the zero polynomial. C C B (input) DOUBLE PRECISION array, dimension (DB+1) C This array must contain the coefficients of the C denominator polynomial B(x) in increasing powers of x. C C RQ (output) DOUBLE PRECISION array, dimension (DA+1) C If DA < DB on exit, then this array contains the C coefficients of the remainder polynomial R(x) in C increasing powers of x; Q(x) is the zero polynomial. C Otherwise, the leading DB elements of this array contain C the coefficients of R(x) in increasing powers of x, and C the next (DA-DB+1) elements contain the coefficients of C Q(x) in increasing powers of x. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = k: if the degree of the denominator polynomial B(x) has C been reduced to (DB - k) because B(DB+1-j) = 0.0 on C entry for j = 0, 1, ..., k-1 and B(DB+1-k) <> 0.0. 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 on entry, DB >= 0 and B(i) = 0.0, where C i = 1, 2, ..., DB+1. C C METHOD C C Given real polynomials C DA C A(x) = a(1) + a(2) * x + ... + a(DA+1) * x C C and C DB C B(x) = b(1) + b(2) * x + ... + b(DB+1) * x C C where b(DB+1) is non-zero, the routine computes the coeffcients of C the quotient polynomial C DA-DB C Q(x) = q(1) + q(2) * x + ... + q(DA-DB+1) * x C C and the remainder polynomial C DB-1 C R(x) = r(1) + r(2) * x + ... + r(DB) * x C C such that A(x) = B(x) * Q(x) + R(x). C C The algorithm used is synthetic division of polynomials (see [1]), C which involves the following steps: C C (a) compute q(k+1) = a(DB+k+1) / b(DB+1) C C and C C (b) set a(j) = a(j) - q(k+1) * b(j-k) for j = k+1, ..., DB+k. C C Steps (a) and (b) are performed for k = DA-DB, DA-DB-1, ..., 0 and C the algorithm terminates with r(i) = a(i) for i = 1, 2, ..., DB. C C REFERENCES C C [1] Knuth, D.E. C The Art of Computer Programming, (Vol. 2, Seminumerical C Algorithms). C Addison-Wesley, Reading, Massachusetts (2nd Edition), 1981. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01ED by A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Elementary polynomial operations, polynomial operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER DA, DB, INFO, IWARN C .. Array Arguments .. DOUBLE PRECISION A(*), B(*), RQ(*) C .. Local Scalars .. INTEGER N DOUBLE PRECISION Q C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, XERBLA C .. Executable Statements .. C C Test the input scalar arguments. C IWARN = 0 INFO = 0 IF( DA.LT.-1 ) THEN INFO = -1 ELSE IF( DB.LT.0 ) THEN INFO = -2 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MC01QD', -INFO ) RETURN END IF C C WHILE ( DB >= 0 and B(DB+1) = 0 ) DO 20 IF ( DB.GE.0 ) THEN IF ( B(DB+1).EQ.ZERO ) THEN DB = DB - 1 IWARN = IWARN + 1 GO TO 20 END IF END IF C END WHILE 20 IF ( DB.EQ.-1 ) THEN INFO = 1 RETURN END IF C C B(x) is non-zero. C IF ( DA.GE.0 ) THEN N = DA CALL DCOPY( N+1, A, 1, RQ, 1 ) C WHILE ( N >= DB ) DO 40 IF ( N.GE.DB ) THEN IF ( RQ(N+1).NE.ZERO ) THEN Q = RQ(N+1)/B(DB+1) CALL DAXPY( DB, -Q, B, 1, RQ(N-DB+1), 1 ) RQ(N+1) = Q END IF N = N - 1 GO TO 40 END IF C END WHILE 40 END IF C RETURN C *** Last line of MC01QD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03CZ.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03CZ.f0000644000175000017500000001036715012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE MB03CZ( A, LDA, B, LDB, D, LDD, CO1, SI1, CO2, SI2, $ CO3, SI3 ) C C PURPOSE C C To compute unitary matrices Q1, Q2, and Q3 for a complex 2-by-2 C regular pencil aAB - bD, with A, B, D upper triangular, such that C Q3' A Q2, Q2' B Q1, Q3' D Q1 are still upper triangular, but the C eigenvalues are in reversed order. The matrices Q1, Q2, and Q3 are C represented by C C ( CO1 SI1 ) ( CO2 SI2 ) ( CO3 SI3 ) C Q1 = ( ), Q2 = ( ), Q3 = ( ). C ( -SI1' CO1 ) ( -SI2' CO2 ) ( -SI3' CO3 ) C C The notation M' denotes the conjugate transpose of the matrix M. C C ARGUMENTS C C Input/Output Parameters C C A (input) COMPLEX*16 array, dimension (LDA, 2) C On entry, the leading 2-by-2 upper triangular part of C this array must contain the matrix A of the pencil. C The (2,1) entry is not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= 2. C C B (input) COMPLEX*16 array, dimension (LDB, 2) C On entry, the leading 2-by-2 upper triangular part of C this array must contain the matrix B of the pencil. C The (2,1) entry is not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= 2. C C D (input) COMPLEX*16 array, dimension (LDD, 2) C On entry, the leading 2-by-2 upper triangular part of C this array must contain the matrix D of the pencil. C The (2,1) entry is not referenced. C C LDD INTEGER C The leading dimension of the array D. LDD >= 2. C C CO1 (output) DOUBLE PRECISION C The upper left element of the unitary matrix Q1. C C SI1 (output) COMPLEX*16 C The upper right element of the unitary matrix Q1. C C CO2 (output) DOUBLE PRECISION C The upper left element of the unitary matrix Q2. C C SI2 (output) COMPLEX*16 C The upper right element of the unitary matrix Q2. C C CO3 (output) DOUBLE PRECISION C The upper left element of the unitary matrix Q3. C C SI3 (output) COMPLEX*16 C The upper right element of the unitary matrix Q3. C C METHOD C C The algorithm uses unitary transformations as described on page 37 C in [1]. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, April 21, 2009. C C REVISIONS C C V. Sima, Aug. 2009 (SLICOT version of the routine ZBTFEX). C V. Sima, Nov. 2009, Nov. 2010, Dec. 2010. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue exchange, matrix pencil, upper triangular matrix. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER LDA, LDB, LDD DOUBLE PRECISION CO1, CO2, CO3 COMPLEX*16 SI1, SI2, SI3 C C .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), D( LDD, * ) C C .. Local Scalars .. COMPLEX*16 F, G, TMP C C .. External Subroutines .. EXTERNAL ZLARTG C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C C Computations. C G = A( 1, 1 )*B( 1, 1 )*D( 2, 2 ) - A( 2, 2 )*B( 2, 2 )*D( 1, 1 ) F = ( A( 1, 1 )*B( 1, 2 ) + A( 1, 2 )*B( 2, 2 ) )*D( 2, 2 ) - $ A( 2, 2 )*B( 2, 2 )*D( 1, 2 ) CALL ZLARTG( F, G, CO1, SI1, TMP ) F = ( A( 1, 2 )*D( 2, 2 ) - A( 2, 2 )*D( 1, 2 ) )*B( 1, 1 ) + $ A( 2, 2 )*D( 1, 1 )*B( 1, 2 ) CALL ZLARTG( F, G, CO2, SI2, TMP ) F = ( B( 1, 2 )*D( 1, 1 ) - B( 1, 1 )*D( 1, 2 ) )*A( 1, 1 ) + $ A( 1, 2 )*B( 2, 2 )*D( 1, 1 ) CALL ZLARTG( F, G, CO3, SI3, TMP ) C RETURN C *** Last line of MB03CZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02ID.f0000644000000000000000000000013215012430707016151 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02ID.f0000644000175000017500000002167415012430707017357 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION MA02ID( TYP, NORM, N, A, LDA, QG, $ LDQG, DWORK ) C C PURPOSE C C To compute the value of the one norm, or the Frobenius norm, or C the infinity norm, or the element of largest absolute value C of a real skew-Hamiltonian matrix C C [ A G ] T T C X = [ T ], G = -G, Q = -Q, C [ Q A ] C C or of a real Hamiltonian matrix C C [ A G ] T T C X = [ T ], G = G, Q = Q, C [ Q -A ] C C where A, G and Q are real n-by-n matrices. C C Note that for this kind of matrices the infinity norm is equal C to the one norm. C C FUNCTION VALUE C C MA02ID DOUBLE PRECISION C The computed norm. C C ARGUMENTS C C Mode Parameters C C TYP CHARACTER*1 C Specifies the type of the input matrix X: C = 'S': X is skew-Hamiltonian; C = 'H': X is Hamiltonian. C C NORM CHARACTER*1 C Specifies the value to be returned in MA02ID: C = '1' or 'O': one norm of X; C = 'F' or 'E': Frobenius norm of X; C = 'I': infinity norm of X; C = 'M': max(abs(X(i,j)). 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 On entry, the leading N-by-N part of this array must C contain the matrix A. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input) DOUBLE PRECISION array, dimension (LDQG,N+1) C On entry, the leading N-by-N+1 part of this array must C contain in columns 1:N the lower triangular part of the C matrix Q and in columns 2:N+1 the upper triangular part C of the matrix G. If TYP = 'S', the parts containing the C diagonal and the first supdiagonal of this array are not C referenced. C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C where LDWORK >= 2*N when NORM = '1', NORM = 'I' or C NORM = 'O'; otherwise, DWORK is not referenced. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLANHA). C V. Sima, Jan. 2016 (removed O(N) tests in several loops). C C KEYWORDS C C Elementary matrix operations, Hamiltonian matrix, skew-Hamiltonian C matrix. 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 NORM, TYP INTEGER LDA, LDQG, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*) C .. Local Scalars .. LOGICAL LSH INTEGER I, J DOUBLE PRECISION DSCL, DSUM, SCALE, SUM, TEMP, VALUE C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLAPY2 EXTERNAL DLANGE, DLAPY2, LSAME C .. External Subroutines .. EXTERNAL DLASSQ C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C C .. Executable Statements .. C LSH = LSAME( TYP, 'S' ) C IF ( N.EQ.0 ) THEN VALUE = ZERO C ELSE IF ( LSAME( NORM, 'M' ) .AND. LSH ) THEN C C Find max(abs(A(i,j))). C VALUE = DLANGE( 'MaxElement', N, N, A, LDA, DWORK ) IF ( N.GT.1 ) THEN DO 30 J = 1, N+1 DO 10 I = 1, J-2 VALUE = MAX( VALUE, ABS( QG(I,J) ) ) 10 CONTINUE DO 20 I = J+1, N VALUE = MAX( VALUE, ABS( QG(I,J) ) ) 20 CONTINUE 30 CONTINUE END IF C ELSE IF ( LSAME( NORM, 'M' ) ) THEN C C Find max( abs( A(i,j) ), abs( QG(i,j) ) ). C VALUE = MAX( DLANGE( 'MaxElement', N, N, A, LDA, DWORK ), $ DLANGE( 'MaxElement', N, N+1, QG, LDQG, $ DWORK ) ) C ELSE IF ( ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. $ LSAME( NORM, 'I' ) ) .AND. LSH ) THEN C C Find the column and row sums of A (in one pass). C VALUE = ZERO DO 40 I = 1, N DWORK(I) = ZERO 40 CONTINUE C DO 60 J = 1, N SUM = ZERO DO 50 I = 1, N TEMP = ABS( A(I,J) ) SUM = SUM + TEMP DWORK(I) = DWORK(I) + TEMP 50 CONTINUE DWORK(N+J) = SUM 60 CONTINUE C C Compute the maximal absolute column sum. C DO 90 J = 1, N DO 70 I = 1, J-2 TEMP = ABS( QG(I,J) ) DWORK(I) = DWORK(I) + TEMP DWORK(J-1) = DWORK(J-1) + TEMP 70 CONTINUE SUM = DWORK(N+J) DO 80 I = J+1, N TEMP = ABS( QG(I,J) ) SUM = SUM + TEMP DWORK(N+I) = DWORK(N+I) + TEMP 80 CONTINUE VALUE = MAX( VALUE, SUM ) 90 CONTINUE DO 100 I = 1, N-1 TEMP = ABS( QG(I,N+1) ) DWORK(I) = DWORK(I) + TEMP DWORK(N) = DWORK(N) + TEMP 100 CONTINUE DO 110 I = 1, N VALUE = MAX( VALUE, DWORK(I) ) 110 CONTINUE C ELSE IF ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. $ LSAME( NORM, 'I' ) ) THEN C C Find the column and row sums of A (in one pass). C VALUE = ZERO DO 120 I = 1, N DWORK(I) = ZERO 120 CONTINUE C DO 140 J = 1, N SUM = ZERO DO 130 I = 1, N TEMP = ABS( A(I,J) ) SUM = SUM + TEMP DWORK(I) = DWORK(I) + TEMP 130 CONTINUE DWORK(N+J) = SUM 140 CONTINUE C C Compute the maximal absolute column sum. C SUM = DWORK(N+1) + ABS( QG(1,1) ) DO 150 I = 2, N TEMP = ABS( QG(I,1) ) SUM = SUM + TEMP DWORK(N+I) = DWORK(N+I) + TEMP 150 CONTINUE VALUE = MAX( VALUE, SUM ) DO 180 J = 2, N DO 160 I = 1, J-2 TEMP = ABS( QG(I,J) ) DWORK(I) = DWORK(I) + TEMP DWORK(J-1) = DWORK(J-1) + TEMP 160 CONTINUE DWORK(J-1) = DWORK(J-1) + ABS( QG(J-1,J) ) SUM = DWORK(N+J) + ABS( QG(J,J) ) DO 170 I = J+1, N TEMP = ABS( QG(I,J) ) SUM = SUM + TEMP DWORK(N+I) = DWORK(N+I) + TEMP 170 CONTINUE VALUE = MAX( VALUE, SUM ) 180 CONTINUE DO 190 I = 1, J-2 TEMP = ABS( QG(I,N+1) ) DWORK(I) = DWORK(I) + TEMP DWORK(N) = DWORK(N) + TEMP 190 CONTINUE DWORK(N) = DWORK(N) + ABS( QG(N,N+1) ) DO 200 I = 1, N VALUE = MAX( VALUE, DWORK(I) ) 200 CONTINUE C ELSE IF ( ( LSAME( NORM, 'F' ) .OR. $ LSAME( NORM, 'E' ) ) .AND. LSH ) THEN C C Find normF(A). C SCALE = ZERO SUM = ONE DO 210 J = 1, N CALL DLASSQ( N, A(1,J), 1, SCALE, SUM ) 210 CONTINUE C C Add normF(G) and normF(Q). C IF ( N.GT.1 ) $ CALL DLASSQ( N-1, QG(2,1), 1, SCALE, SUM ) IF ( N.GT.2 ) $ CALL DLASSQ( N-2, QG(3,2), 1, SCALE, SUM ) DO 220 J = 3, N-1 CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) 220 CONTINUE CALL DLASSQ( N-2, QG(1,N), 1, SCALE, SUM ) CALL DLASSQ( N-1, QG(1,N+1), 1, SCALE, SUM ) VALUE = SQRT( TWO )*SCALE*SQRT( SUM ) C ELSE IF ( LSAME( NORM, 'F' ) .OR. LSAME( NORM, 'E' ) ) THEN C SCALE = ZERO SUM = ONE DO 230 J = 1, N CALL DLASSQ( N, A(1,J), 1, SCALE, SUM ) 230 CONTINUE C DSCL = ZERO DSUM = ONE CALL DLASSQ( 1, QG(1,1), 1, DSCL, DSUM ) IF ( N.GT.1 ) $ CALL DLASSQ( N-1, QG(2,1), 1, SCALE, SUM ) DO 240 J = 2, N CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) CALL DLASSQ( 2, QG(J-1,J), 1, DSCL, DSUM ) CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) 240 CONTINUE CALL DLASSQ( N-1, QG(1,N+1), 1, SCALE, SUM ) CALL DLASSQ( 1, QG(N,N+1), 1, DSCL, DSUM ) VALUE = DLAPY2( SQRT( TWO )*SCALE*SQRT( SUM ), $ DSCL*SQRT( DSUM ) ) END IF C MA02ID = VALUE RETURN C *** Last line of MA02ID *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01SD.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01SD.f0000644000175000017500000000553615012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE MB01SD( JOBS, M, N, A, LDA, R, C ) C C PURPOSE C C To scale a general M-by-N matrix A using the row and column C scaling factors in the vectors R and C. C C ARGUMENTS C C Mode Parameters C C JOBS CHARACTER*1 C Specifies the scaling operation to be done, as follows: C = 'R': row scaling, i.e., A will be premultiplied C by diag(R); C = 'C': column scaling, i.e., A will be postmultiplied C by diag(C); C = 'B': both row and column scaling, i.e., A will be C replaced by diag(R) * A * diag(C). 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 (LDA,N) C On entry, the M-by-N matrix A. C On exit, the scaled matrix. See JOBS for the form of the C scaled matrix. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C R (input) DOUBLE PRECISION array, dimension (M) C The row scale factors for A. C R is not referenced if JOBS = 'C'. C C C (input) DOUBLE PRECISION array, dimension (N) C The column scale factors for A. C C is not referenced if JOBS = 'R'. C C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, April 1998. C Based on the RASP routine DMSCAL. C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER JOBS INTEGER LDA, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), C(*), R(*) C .. Local Scalars .. INTEGER I, J DOUBLE PRECISION CJ C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. Executable Statements .. C C Quick return if possible. C IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN C IF( LSAME( JOBS, 'C' ) ) THEN C C Column scaling, no row scaling. C DO 20 J = 1, N CJ = C(J) DO 10 I = 1, M A(I,J) = CJ*A(I,J) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( JOBS, 'R' ) ) THEN C C Row scaling, no column scaling. C DO 40 J = 1, N DO 30 I = 1, M A(I,J) = R(I)*A(I,J) 30 CONTINUE 40 CONTINUE ELSE IF( LSAME( JOBS, 'B' ) ) THEN C C Row and column scaling. C DO 60 J = 1, N CJ = C(J) DO 50 I = 1, M A(I,J) = CJ*R(I)*A(I,J) 50 CONTINUE 60 CONTINUE END IF C RETURN C *** Last line of MB01SD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01UZ.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01UZ.f0000644000175000017500000004264415012430707017421 0ustar00lilgelilge00000000000000 SUBROUTINE MB01UZ( SIDE, UPLO, TRANS, M, N, ALPHA, T, LDT, A, LDA, $ ZWORK, LZWORK, INFO ) C C PURPOSE C C To compute one of the matrix products C C T : = alpha*op( T ) * A, or T : = alpha*A * op( T ), C C where alpha is a scalar, A is an M-by-N matrix, T is a triangular C matrix, and op( T ) is one of C C op( T ) = T, or op( T ) = T', the transpose of T, or C op( T ) = conj(T'), the conjugate transpose of T. C C A block-row/column algorithm is used, if possible. The result C overwrites the array T. C C ARGUMENTS C C Mode Parameters C C SIDE CHARACTER*1 C Specifies whether the triangular matrix T appears on the C left or right in the matrix product, as follows: C = 'L': T := alpha * op( T ) * A; C = 'R': T := alpha * A * op( T ). C C UPLO CHARACTER*1. C Specifies whether the matrix T is an upper or lower C triangular matrix, as follows: C = 'U': T is an upper triangular matrix; C = 'L': T is a lower triangular matrix. C C TRANS CHARACTER*1 C Specifies the form of op( T ) to be used in the matrix C multiplication as follows: C = 'N': op( T ) = T; C = 'T': op( T ) = T'; C = 'C': op( T ) = conj(T'). 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 ALPHA (input) COMPLEX*16 C The scalar alpha. When alpha is zero then T and A need not C be set before entry. C C T (input/output) COMPLEX*16 array, dimension C (LDT,max(K,N)), when SIDE = 'L', and C (LDT,K), when SIDE = 'R', C where K is M if SIDE = 'L' and is N if SIDE = 'R'. C On entry with UPLO = 'U', the leading K-by-K upper C triangular part of this array must contain the upper C triangular matrix T. The elements below the diagonal C do not need to be zero. C On entry with UPLO = 'L', the leading K-by-K lower C triangular part of this array must contain the lower C triangular matrix T. The elements above the diagonal C do not need to be zero. C On exit, the leading M-by-N part of this array contains C the corresponding product defined by SIDE, UPLO, and C TRANS. C C LDT INTEGER C The leading dimension of the array T. C LDT >= max(1,M), if SIDE = 'L'; C LDT >= max(1,M,N), if SIDE = 'R'. C C A (input) COMPLEX*16 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 Workspace C C ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal value C of LZWORK. C On exit, if INFO = -12, ZWORK(1) returns the minimum C value of LZWORK. C C LZWORK The length of the array ZWORK. C LZWORK >= 1, if alpha = 0 or MIN(M,N) = 0; C LZWORK >= M, if SIDE = 'L'; C LZWORK >= N, if SIDE = 'R'. C For good performance, LZWORK should be larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK 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 A block-row/column size is found based on the available workspace. C BLAS 3 gemm and trmm are used if possible. C C CONTRIBUTORS C C V. Sima, June 2021. C C REVISIONS C C V. Sima, August 2021. C C KEYWORDS C C Elementary matrix operations. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) C .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO INTEGER INFO, LDA, LDT, LZWORK, M, N COMPLEX*16 ALPHA C .. Array Arguments .. COMPLEX*16 A(LDA,*), T(LDT,*), ZWORK(*) C .. Local Scalars .. CHARACTER SKEW, TRANC, UPLOC LOGICAL FILLIN, LQUERY, LSIDE, LTRAN, LUPLO, TTRAN INTEGER BL, I, II, IJ, J, K, L, MN, NB, NC, NR, WRKMIN, $ WRKOPT COMPLEX*16 TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL MA02EZ, XERBLA, ZCOPY, ZGEMM, ZGEMV, ZGEQRF, $ ZLACGV, ZLACPY, ZLASET, ZTRMM C .. Intrinsic Functions .. INTRINSIC DBLE, DCONJG, INT, MAX, MIN C C .. Executable Statements .. C C Decode and test the input scalar arguments. C INFO = 0 LSIDE = LSAME( SIDE, 'L' ) LUPLO = LSAME( UPLO, 'U' ) TTRAN = LSAME( TRANS, 'T' ) LTRAN = LSAME( TRANS, 'C' ) .OR. TTRAN IF ( LSIDE ) THEN K = M L = N ELSE K = N L = M END IF MN = MIN( M, N ) C C Ensure that at least two rows or columns of A fit into the C workspace, if optimal workspace is required. C WRKMIN = 1 IF ( ALPHA.NE.ZERO .AND. MN.GT.0 ) $ WRKMIN = MAX( WRKMIN, K ) LQUERY = LZWORK.EQ.-1 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.LTRAN ).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 ( LDT.LT.MAX( 1, M ) .OR. ( .NOT.LSIDE .AND. LDT.LT.N ) ) $ THEN INFO = -8 ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LQUERY ) THEN IF ( ALPHA.NE.ZERO .AND. MN.GT.0 ) THEN CALL ZGEQRF( M, MAX( M,N ), A, LDA, ZWORK, ZWORK, -1, INFO ) WRKOPT = MAX( WRKMIN, 2*L, INT( ZWORK(1) ) ) ZWORK(1) = DBLE( WRKOPT ) ELSE ZWORK(1) = ONE END IF RETURN ELSE IF ( LZWORK.LT.WRKMIN ) THEN ZWORK(1) = DBLE( WRKMIN ) INFO = -12 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01UZ', -INFO ) RETURN END IF C C Quick return, if possible. C IF ( MN.EQ.0 ) $ RETURN C IF ( ALPHA.EQ.ZERO ) THEN C C Set T to zero and return. C CALL ZLASET( 'Full', M, N, ZERO, ZERO, T, LDT ) RETURN END IF C C Set the panel (block-row/column) size NB. C NB = MAX( 1, MIN( K, INT( LZWORK/L ) ) ) C IF ( LZWORK.GE.M*N ) THEN C C Enough workspace for a fast BLAS 3 calculation. C Save A in the workspace and compute one of the matrix products C T : = alpha * op( triu( T ) ) * A, or C T : = alpha * A * op( triu( T ) ), C involving the upper/lower triangle of T. C CALL ZLACPY( 'All', M, N, A, LDA, ZWORK, M ) CALL ZTRMM( SIDE, UPLO, TRANS, 'NonUnit', M, N, ALPHA, T, LDT, $ ZWORK, M ) CALL ZLACPY( 'All', M, N, ZWORK, M, T, LDT ) C ELSE IF ( NB.GT.1 ) THEN C C Use BLAS 3 calculations in a loop. BL is the number of panels. C C If UPLO = 'L' and TRANS <> 'N', change the format so that to C correspond to UPLO = 'U' and TRANS = 'N'. C If UPLO = 'U' and TRANS <> 'N', change the format so that to C correspond to UPLO = 'L' and TRANS = 'N'. C IF ( LTRAN ) THEN CALL MA02EZ( UPLO, TRANS, 'General', K, T, LDT ) IF ( LUPLO ) THEN UPLOC = 'Lower' ELSE UPLOC = 'Upper' END IF TRANC = 'NoTran' LUPLO = .NOT.LUPLO LTRAN = .NOT.LTRAN ELSE UPLOC = UPLO TRANC = TRANS END IF C BL = MAX( 1, INT( K/NB ) ) J = MIN( K, NB*BL ) C IF ( LSIDE ) THEN C IF ( LUPLO ) THEN C C Compute the last rows. C IF ( J.EQ.M ) THEN NR = NB II = M - NB + 1 BL = BL - 1 ELSE NR = M - J II = J + 1 END IF CALL ZLACPY( 'All', NR, N, A(II,1), LDA, ZWORK, NR ) CALL ZTRMM( SIDE, UPLOC, TRANC, 'NonUnit', NR, N, ALPHA, $ T(II,II), LDT, ZWORK, NR ) CALL ZLACPY( 'All', NR, N, ZWORK, NR, T(II,1), LDT ) C DO 10 I = 1, BL IJ = II II = II - NB CALL ZLACPY( 'All', NB, N, A(II,1), LDA, ZWORK, NB ) CALL ZTRMM( SIDE, UPLOC, TRANC, 'NonUnit', NB, N, $ ALPHA, T(II,II), LDT, ZWORK, NB ) CALL ZGEMM( TRANC, 'NoTrans', NB, N, M-IJ+1, ALPHA, $ T(II,IJ), LDT, A(IJ,1), LDA, ONE, ZWORK, $ NB ) CALL ZLACPY( 'All', NB, N, ZWORK, NB, T(II,1), LDT ) 10 CONTINUE C ELSE C C Compute the first rows. C IF ( J.EQ.M ) THEN NR = NB BL = BL - 1 ELSE NR = M - J END IF CALL ZLACPY( 'All', NR, N, A, LDA, ZWORK, NR ) CALL ZTRMM( SIDE, UPLOC, TRANC, 'NonUnit', NR, N, ALPHA, $ T, LDT, ZWORK, NR ) CALL ZLACPY( 'All', NR, N, ZWORK, NR, T, LDT ) II = NR + 1 C DO 20 I = 1, BL CALL ZLACPY( 'All', NB, N, A(II,1), LDA, ZWORK, NB ) CALL ZTRMM( SIDE, UPLOC, TRANC, 'NonUnit', NB, N, $ ALPHA, T(II,II), LDT, ZWORK, NB ) CALL ZGEMM( TRANC, 'NoTrans', NB, N, II-1, ALPHA, $ T(II,1), LDT, A, LDA, ONE, ZWORK, NB ) CALL ZLACPY( 'All', NB, N, ZWORK, NB, T(II,1), LDT ) II = II + NB 20 CONTINUE C END IF C ELSE C IF ( LUPLO ) THEN C C Compute the first columns. C II = 1 IF ( J.EQ.N ) THEN NC = NB BL = BL - 1 ELSE NC = N - J END IF CALL ZLACPY( 'All', M, NC, A, LDA, ZWORK, M ) CALL ZTRMM( SIDE, UPLOC, TRANC, 'NonUnit', M, NC, ALPHA, $ T, LDT, ZWORK, M ) CALL ZLACPY( 'All', M, NC, ZWORK, M, T, LDT ) II = II + NC C DO 30 I = 1, BL IJ = II - 1 CALL ZLACPY( 'All', M, NB, A(1,II), LDA, ZWORK, M ) CALL ZTRMM( SIDE, UPLOC, TRANC, 'NonUnit', M, NB, $ ALPHA, T(II,II), LDT, ZWORK, M ) CALL ZGEMM( TRANC, 'NoTrans', M, NB, IJ, ALPHA, A, $ LDA, T(1,II), LDT, ONE, ZWORK, M ) CALL ZLACPY( 'All', M, NB, ZWORK, M, T(1,II), LDT ) II = II + NB 30 CONTINUE C ELSE C C Compute the last columns. C IF ( J.EQ.N ) THEN NC = NB II = N - NB + 1 BL = BL - 1 ELSE NC = N - J II = J + 1 END IF CALL ZLACPY( 'All', M, NC, A(1,II), LDA, ZWORK, M ) CALL ZTRMM( SIDE, UPLOC, TRANC, 'NonUnit', M, NC, ALPHA, $ T(II,II), LDT, ZWORK, M ) CALL ZLACPY( 'All', M, NC, ZWORK, M, T(1,II), LDT ) C DO 40 I = 1, BL IJ = II II = II - NB CALL ZLACPY( 'All', M, NB, A(1,II), LDA, ZWORK, M ) CALL ZTRMM( SIDE, UPLOC, TRANC, 'NonUnit', M, NB, $ ALPHA, T(II,II), LDT, ZWORK, M ) CALL ZGEMM( TRANC, 'NoTrans', M, NB, NC, ALPHA, $ A(1,IJ), LDA, T(IJ,II), LDT, ONE, ZWORK, $ M ) CALL ZLACPY( 'All', M, NB, ZWORK, M, T(1,II), LDT ) NC = NC + NB 40 CONTINUE C END IF C END IF C ELSE C C Use BLAS 2 calculations in a loop. C FILLIN = LTRAN .AND. ( ( LSIDE .AND. LUPLO ) .OR. $ ( .NOT.LSIDE .AND. .NOT.LUPLO ) ) IF ( FILLIN ) THEN C C Fill-in the other part of T. C IF ( TTRAN ) THEN SKEW = 'NotSkew' ELSE SKEW = 'General' END IF CALL MA02EZ( UPLO, TRANS, SKEW, K, T, LDT ) END IF C IF ( LSIDE ) THEN C IF ( LUPLO ) THEN C IF ( .NOT.LTRAN ) THEN TEMP = DCONJG( ALPHA ) C DO 50 I = 1, M CALL ZCOPY( M-I+1, T(I,I), LDT, ZWORK, 1 ) CALL ZLACGV( M-I+1, ZWORK, 1 ) CALL ZGEMV( 'CTrans', M-I+1, N, TEMP, A(I,1), LDA, $ ZWORK, 1, ZERO, T(I,1), LDT ) CALL ZLACGV( N, T(I,1), LDT ) 50 CONTINUE C ELSE IF ( TTRAN ) THEN C DO 60 I = 1, M CALL ZCOPY( I, T(I,1), LDT, ZWORK, 1 ) CALL ZGEMV( TRANS, I, N, ALPHA, A, LDA, ZWORK, 1, $ ZERO, T(I,1), LDT ) 60 CONTINUE C ELSE TEMP = DCONJG( ALPHA ) C DO 70 I = 1, M CALL ZCOPY( I, T(I,1), LDT, ZWORK, 1 ) CALL ZLACGV( I, ZWORK, 1 ) CALL ZGEMV( TRANS, I, N, TEMP, A, LDA, ZWORK, 1, $ ZERO, T(I,1), LDT ) CALL ZLACGV( N, T(I,1), LDT ) 70 CONTINUE C END IF C ELSE C IF ( .NOT.LTRAN ) THEN TEMP = DCONJG( ALPHA ) C DO 80 I = 1, M CALL ZCOPY( I, T(I,1), LDT, ZWORK, 1 ) CALL ZLACGV( I, ZWORK, 1 ) CALL ZGEMV( 'CTrans', I, N, TEMP, A, LDA, ZWORK, $ 1, ZERO, T(I,1), LDT ) CALL ZLACGV( N, T(I,1), LDT ) 80 CONTINUE C ELSE IF ( TTRAN ) THEN C DO 90 I = 1, M CALL ZCOPY( M-I+1, T(I,I), 1, ZWORK, 1 ) CALL ZGEMV( TRANS, M-I+1, N, ALPHA, A(I,1), LDA, $ ZWORK, 1, ZERO, T(I,1), LDT ) 90 CONTINUE C ELSE TEMP = DCONJG( ALPHA ) C DO 100 I = 1, M CALL ZCOPY( M-I+1, T(I,I), 1, ZWORK, 1 ) CALL ZGEMV( TRANS, M-I+1, N, TEMP, A(I,1), LDA, $ ZWORK, 1, ZERO, T(I,1), LDT ) CALL ZLACGV( N, T(I,1), LDT ) 100 CONTINUE C END IF C END IF C ELSE C IF ( LUPLO ) THEN C IF ( TTRAN ) THEN C DO 110 I = 1, N CALL ZCOPY( N-I+1, T(I,I), LDT, ZWORK, 1 ) CALL ZGEMV( 'NoTran', M, N-I+1, ALPHA, A(1,I), LDA, $ ZWORK, 1, ZERO, T(1,I), 1 ) 110 CONTINUE C ELSE IF ( LTRAN ) THEN C DO 120 I = 1, N CALL ZCOPY( N-I+1, T(I,I), LDT, ZWORK, 1 ) CALL ZLACGV( N-I+1, ZWORK, 1 ) CALL ZGEMV( 'NoTran', M, N-I+1, ALPHA, A(1,I), $ LDA, ZWORK, 1, ZERO, T(1,I), 1 ) 120 CONTINUE C ELSE C DO 130 I = 1, N CALL ZCOPY( I, T(1,I), 1, ZWORK, 1 ) CALL ZGEMV( 'NoTran', M, I, ALPHA, A, LDA, ZWORK, $ 1, ZERO, T(1,I), 1 ) 130 CONTINUE C END IF C ELSE C IF ( LTRAN ) THEN C DO 140 I = 1, N CALL ZCOPY( I, T(1,I), 1, ZWORK, 1 ) CALL ZGEMV( 'NoTran', M, I, ALPHA, A, LDA, ZWORK, $ 1, ZERO, T(1,I), 1 ) 140 CONTINUE C ELSE C DO 150 I = 1, N CALL ZCOPY( N-I+1, T(I,I), 1, ZWORK, 1 ) CALL ZGEMV( 'NoTran', M, N-I+1, ALPHA, A(1,I), LDA, $ ZWORK, 1, ZERO, T(1,I), 1 ) 150 CONTINUE C END IF C END IF C END IF C END IF C ZWORK(1) = DBLE( MAX( WRKMIN, WRKOPT ) ) RETURN C *** Last line of MB01UZ *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03AY.f0000644000000000000000000000013215012430707016203 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SG03AY.f0000644000175000017500000005130715012430707017405 0ustar00lilgelilge00000000000000 SUBROUTINE SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) C C PURPOSE C C To solve for X either the reduced generalized continuous-time C Lyapunov equation C C T T C A * X * E + E * X * A = SCALE * Y (1) C C or C C T T C A * X * E + E * X * A = 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 .. INTEGER DIMMAT, I, INFO1, KB, KH, KL, LB, LH, LL DOUBLE PRECISION AK11, AK12, AK21, AK22, AL11, AL12, AL21, AL22, $ EK11, EK12, EK22, EL11, EL12, EL22, SCALE1 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 parameters. 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( 'SG03AY', -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)*E(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)*A(1:LL-1,LL:LH)) C IF ( LL .GT. 1 ) THEN 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-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, $ A(1,LL), LDA, ZERO, TM, 2 ) CALL DGEMM( 'T', 'N', LH-KH+1, LB, KB, MONE, 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) = E(LL,LL)*A(KL,KL) + A(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) = EL11*AK11 + AL11*EK11 MAT(1,2) = EL11*AK21 MAT(2,1) = EL11*AK12 + AL11*EK12 MAT(2,2) = EL11*AK22 + AL11*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) AL22 = A(LH,LH) C EK11 = E(KL,KL) C EL11 = E(LL,LL) EL12 = E(LL,LH) EL22 = E(LH,LH) C MAT(1,1) = EL11*AK11 + AL11*EK11 MAT(1,2) = AL21*EK11 MAT(2,1) = EL12*AK11 + AL12*EK11 MAT(2,2) = EL22*AK11 + AL22*EK11 C RHS(1) = X(KL,LL) RHS(2) = X(KL,LH) C ELSE C DIMMAT = 4 C AK11 = A(KL,KL) AK12 = A(KL,KH) AK21 = A(KH,KL) AK22 = A(KH,KH) C AL11 = A(LL,LL) AL12 = A(LL,LH) AL21 = A(LH,LL) AL22 = A(LH,LH) C EK11 = E(KL,KL) EK12 = E(KL,KH) EK22 = E(KH,KH) C EL11 = E(LL,LL) EL12 = E(LL,LH) EL22 = E(LH,LH) C MAT(1,1) = EL11*AK11 + AL11*EK11 MAT(1,2) = EL11*AK21 MAT(1,3) = AL21*EK11 MAT(1,4) = ZERO C MAT(2,1) = EL11*AK12 + AL11*EK12 MAT(2,2) = EL11*AK22 + AL11*EK22 MAT(2,3) = AL21*EK12 MAT(2,4) = AL21*EK22 C MAT(3,1) = EL12*AK11 + AL12*EK11 MAT(3,2) = EL12*AK21 MAT(3,3) = EL22*AK11 + AL22*EK11 MAT(3,4) = EL22*AK21 C MAT(4,1) = EL12*AK12 + AL12*EK12 MAT(4,2) = EL12*AK22 + AL12*EK22 MAT(4,3) = EL22*AK12 + AL22*EK12 MAT(4,4) = EL22*AK22 + AL22*EK22 C RHS(1) = X(KL,LL) IF ( KL .EQ. LL ) THEN RHS(2) = X(KL,KH) ELSE RHS(2) = X(KH,LL) END IF RHS(3) = X(KL,LH) RHS(4) = X(KH,LH) C END IF C CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) IF ( INFO1 .NE. 0 ) $ INFO = 1 CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) C C Scaling. C IF ( SCALE1 .NE. ONE ) THEN DO 80 I = 1, N CALL DSCAL( N, SCALE1, X(1,I), 1 ) 80 CONTINUE SCALE = SCALE*SCALE1 END IF C IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN X(KL,LL) = RHS(1) ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN X(KL,LL) = RHS(1) X(KH,LL) = RHS(2) ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN X(KL,LL) = RHS(1) X(KL,LH) = RHS(2) ELSE X(KL,LL) = RHS(1) X(KH,LL) = RHS(2) X(KL,LH) = RHS(3) X(KH,LH) = RHS(4) END IF C C Update right hand sides (II). C C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - C A(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*E(LL:LH,LL:LH)) C C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - C E(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*A(LL:LH,LL:LH)) C IF ( KL .LT. LL ) THEN IF ( LB .EQ. 2 ) $ CALL DGEMV( 'N', KB, 2, ONE, X(KL,LL), LDX, $ E(LL,LH), 1, ZERO, TM(1,2), 1 ) CALL DCOPY( KB, X(KL,LL), 1, TM, 1 ) CALL DSCAL( KB, E(LL,LL), TM, 1 ) CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, A(KL,KH+1), $ LDA, TM, 2, ONE, X(KH+1,LL), LDX ) CALL DGEMM( 'N', 'N', KB, LB, LB, ONE, X(KL,LL), LDX, $ A(LL,LL), LDA, ZERO, TM, 2 ) CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, E(KL,KH+1), $ LDE, TM, 2, ONE, X(KH+1,LL), LDX ) END IF C GOTO 60 END IF C END WHILE 60 C GOTO 20 END IF C END WHILE 20 C ELSE C C Solve equation (2). C C Outer Loop. Compute block column X(:,LL:LH). LB denotes the C number of columns in this block column. C LL = N + 1 C WHILE ( LL .GT. 1 ) DO 100 IF ( LL .GT. 1 ) THEN LH = LL - 1 IF ( LH .EQ. 1 ) THEN LB = 1 ELSE IF ( A(LL-1,LL-2) .NE. ZERO ) THEN LB = 2 ELSE LB = 1 END IF END IF LL = LL - LB C C Copy elements of solution already known by symmetry. C C X(LH+1:N,LL:LH) = X(LL:LH,LH+1:N)' C IF ( LH .LT. N ) THEN DO 120 I = LL, LH CALL DCOPY( N-LH, X(I,LH+1), LDX, X(LH+1,I), 1 ) 120 CONTINUE END IF C C Inner Loop. Compute block X(KL:KH,LL:LH). KB denotes the C number of rows in this block. C KL = LH + 1 C WHILE ( KL .GT. 1 ) DO 140 IF ( KL .GT. 1 ) THEN KH = KL - 1 IF ( KH .EQ. 1 ) THEN KB = 1 ELSE IF ( A(KL-1,KL-2) .NE. ZERO ) THEN KB = 2 ELSE KB = 1 END IF END IF KL = KL - KB C C Update right hand sides (I). C C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - C (A(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*E(KL:LH,LL:LH)' C C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - C (E(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*A(KL:LH,LL:LH)' C IF ( KH .LT. N ) THEN CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, A(KL,KH+1), $ LDA, X(KH+1,LL), LDX, ZERO, TM, 2 ) CALL DGEMM( 'N', 'T', KB, LL-KL+1, LB, MONE, TM, 2, $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) IF ( LB .EQ. 2 ) CALL DAXPY( KB, -E(LH,LH), TM(1,2), $ 1, X(KL,LH), 1 ) CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, E(KL,KH+1), $ LDE, X(KH+1,LL), LDX, ZERO, TM, 2 ) CALL DGEMM( 'N', 'T', KB, LH-KL+1, LB, MONE, TM, 2, $ A(KL,LL), LDA, ONE, X(KL,KL), 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) = E(LL,LL)*A(KL,KL) + A(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) = EL11*AK11 + AL11*EK11 MAT(1,2) = EL11*AK12 + AL11*EK12 MAT(2,1) = EL11*AK21 MAT(2,2) = EL11*AK22 + AL11*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) AL22 = A(LH,LH) C EK11 = E(KL,KL) C EL11 = E(LL,LL) EL12 = E(LL,LH) EL22 = E(LH,LH) C MAT(1,1) = EL11*AK11 + AL11*EK11 MAT(1,2) = EL12*AK11 + AL12*EK11 MAT(2,1) = AL21*EK11 MAT(2,2) = EL22*AK11 + AL22*EK11 C RHS(1) = X(KL,LL) RHS(2) = X(KL,LH) C ELSE C DIMMAT = 4 C AK11 = A(KL,KL) AK12 = A(KL,KH) AK21 = A(KH,KL) AK22 = A(KH,KH) C AL11 = A(LL,LL) AL12 = A(LL,LH) AL21 = A(LH,LL) AL22 = A(LH,LH) C EK11 = E(KL,KL) EK12 = E(KL,KH) EK22 = E(KH,KH) C EL11 = E(LL,LL) EL12 = E(LL,LH) EL22 = E(LH,LH) C MAT(1,1) = EL11*AK11 + AL11*EK11 MAT(1,2) = EL11*AK12 + AL11*EK12 MAT(1,3) = EL12*AK11 + AL12*EK11 MAT(1,4) = EL12*AK12 + AL12*EK12 C MAT(2,1) = EL11*AK21 MAT(2,2) = EL11*AK22 + AL11*EK22 MAT(2,3) = EL12*AK21 MAT(2,4) = EL12*AK22 + AL12*EK22 C MAT(3,1) = AL21*EK11 MAT(3,2) = AL21*EK12 MAT(3,3) = EL22*AK11 + AL22*EK11 MAT(3,4) = EL22*AK12 + AL22*EK12 C MAT(4,1) = ZERO MAT(4,2) = AL21*EK22 MAT(4,3) = EL22*AK21 MAT(4,4) = EL22*AK22 + AL22*EK22 C RHS(1) = X(KL,LL) IF ( KL .EQ. LL ) THEN RHS(2) = X(KL,KH) ELSE RHS(2) = X(KH,LL) END IF RHS(3) = X(KL,LH) RHS(4) = X(KH,LH) C END IF C CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) IF ( INFO1 .NE. 0 ) $ INFO = 1 CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) C C Scaling. C IF ( SCALE1 .NE. ONE ) THEN DO 160 I = 1, N CALL DSCAL( N, SCALE1, X(1,I), 1 ) 160 CONTINUE SCALE = SCALE*SCALE1 END IF C IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN X(KL,LL) = RHS(1) ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN X(KL,LL) = RHS(1) X(KH,LL) = RHS(2) ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN X(KL,LL) = RHS(1) X(KL,LH) = RHS(2) ELSE X(KL,LL) = RHS(1) X(KH,LL) = RHS(2) X(KL,LH) = RHS(3) X(KH,LH) = RHS(4) END IF C C Update right hand sides (II). C C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - C (A(KL:KH,KL:KH)*X(KL:KH,LL:LH))*E(KL:LL-1,LL:LH)' C C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - C (E(KL:KH,KL:KH)*X(KL:KH,LL:LH))*A(KL:LL-1,LL:LH)' C IF ( KL .LT. LL ) THEN CALL DGEMM( 'N', 'N', KB, LB, KB, ONE, A(KL,KL), LDA, $ X(KL,LL), LDX, ZERO, TM, 2 ) CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) CALL DGEMV( 'T', KB, LB, ONE, X(KL,LL), LDX, E(KL,KL), $ LDE, ZERO, TM, 2 ) IF ( KB .EQ. 2 ) THEN CALL DCOPY( LB, X(KH,LL), LDX, TM(2,1), 2 ) CALL DSCAL( LB, E(KH,KH), TM(2,1), 2 ) END IF CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) END IF C GOTO 140 END IF C END WHILE 140 C GOTO 100 END IF C END WHILE 100 C END IF C RETURN C *** Last line of SG03AY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB05OD.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB05OD.f0000644000175000017500000004215615012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE MB05OD( BALANC, N, NDIAG, DELTA, A, LDA, MDIG, IDIG, $ IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute exp(A*delta) where A is a real N-by-N matrix and delta C is a scalar value. The routine also returns the minimal number of C accurate digits in the 1-norm of exp(A*delta) and the number of C accurate digits in the 1-norm of exp(A*delta) at 95% confidence C level. C C ARGUMENTS C C Mode Parameters C C BALANC CHARACTER*1 C Specifies whether or not a balancing transformation (done C by SLICOT Library routine MB04MD) is required, as follows: C = 'N', do not use balancing; C = 'S', use balancing (scaling). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C NDIAG (input) INTEGER C The specified order of the diagonal Pade approximant. C In the absence of further information NDIAG should C be set to 9. NDIAG should not exceed 15. NDIAG >= 1. C C DELTA (input) DOUBLE PRECISION C The scalar value delta of the problem. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On input, the leading N-by-N part of this array must C contain the matrix A of the problem. (This is not needed C if DELTA = 0.) C On exit, if INFO = 0, the leading N-by-N part of this C array contains the solution matrix exp(A*delta). C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C MDIG (output) INTEGER C The minimal number of accurate digits in the 1-norm of C exp(A*delta). C C IDIG (output) INTEGER C The number of accurate digits in the 1-norm of C exp(A*delta) at 95% confidence level. C C Workspace C C IWORK INTEGER array, dimension (N) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= N*(2*N+NDIAG+1)+NDIAG, if N > 1. C LDWORK >= 1, if N <= 1. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: if MDIG = 0 and IDIG > 0, warning for possible C inaccuracy (the exponential has been computed); C = 2: if MDIG = 0 and IDIG = 0, warning for severe C inaccuracy (the exponential has been computed); C = 3: if balancing has been requested, but it failed to C reduce the matrix norm and was not actually used. 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 norm of matrix A*delta (after a possible C balancing) is too large to obtain an accurate C result; C = 2: if the coefficient matrix (the denominator of the C Pade approximant) is exactly singular; try a C different value of NDIAG; C = 3: if the solution exponential would overflow, possibly C due to a too large value DELTA; the calculations C stopped prematurely. This error is not likely to C appear. C C METHOD C C The exponential of the matrix A is evaluated from a diagonal Pade C approximant. This routine is a modification of the subroutine C PADE, described in reference [1]. The routine implements an C algorithm which exploits the identity C C (exp[(2**-m)*A]) ** (2**m) = exp(A), C C where m is an integer determined by the algorithm, to improve the C accuracy for matrices with large norms. C C REFERENCES C C [1] Ward, R.C. C Numerical computation of the matrix exponential with accuracy C estimate. C SIAM J. Numer. Anal., 14, pp. 600-610, 1977. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. C Supersedes Release 2.0 routine MB05CD by T.W.C. Williams, Kingston C Polytechnic, March 1982. C C REVISIONS C C June 14, 1997, April 25, 2003, December 12, 2004. C C KEYWORDS C C Continuous-time system, matrix algebra, matrix exponential, C matrix operations, Pade approximation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, EIGHT, TEN, TWELVE, $ NINTEN, TWO4, FOUR7, TWOHND PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, $ TWO = 2.0D0, FOUR = 4.0D0, EIGHT = 8.0D0, $ TEN = 10.0D0, TWELVE = 12.0D0, $ NINTEN = 19.0D0, TWO4 = 24.0D0, $ FOUR7 = 47.0D0, TWOHND = 200.0D0 ) C .. Scalar Arguments .. CHARACTER BALANC INTEGER IDIG, INFO, IWARN, LDA, LDWORK, MDIG, N, $ NDIAG DOUBLE PRECISION DELTA C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), DWORK(*) C .. Local Scalars .. LOGICAL LBALS CHARACTER ACTBAL INTEGER BASE, I, IFAIL, IJ, IK, IM1, J, JWORA1, JWORA2, $ JWORA3, JWORV1, JWORV2, K, M, MPOWER, NDAGM1, $ NDAGM2, NDEC, NDECM1 DOUBLE PRECISION ANORM, AVGEV, BD, BIG, EABS, EAVGEV, EMNORM, $ EPS, FACTOR, FN, GN, MAXRED, OVRTH2, OVRTHR, P, $ RERL, RERR, S, SD2, SIZE, SMALL, SS, SUM2D, $ TEMP, TMP1, TR, U, UNDERF, VAR, VAREPS, XN C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DNRM2 EXTERNAL DASUM, DLAMCH, DLANGE, DNRM2, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DGETRF, DGETRS, DLACPY, $ DLASCL, DLASET, DSCAL, MB04MD, MB05OY, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, EXP, INT, LOG, LOG10, MAX, MIN, MOD, SQRT C .. Executable Statements .. C IWARN = 0 INFO = 0 LBALS = LSAME( BALANC, 'S' ) C C Test the input scalar arguments. C IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LBALS ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NDIAG.LT.1 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDWORK.LT.1 .OR. $ ( LDWORK.LT.N*( 2*N + NDIAG + 1 ) + NDIAG .AND. N.GT.1 ) $ ) THEN INFO = -11 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB05OD', -INFO ) RETURN END IF C C Quick return if possible. C EPS = DLAMCH( 'Epsilon' ) NDEC = INT( LOG10( ONE/EPS ) + ONE ) C IF ( N.EQ.0 ) THEN MDIG = NDEC IDIG = NDEC RETURN END IF C C Set some machine parameters. C BASE = DLAMCH( 'Base' ) NDECM1 = NDEC - 1 UNDERF = DLAMCH( 'Underflow' ) OVRTHR = DLAMCH( 'Overflow' ) OVRTH2 = SQRT( OVRTHR ) C IF ( DELTA.EQ.ZERO ) THEN C C The DELTA = 0 case. C CALL DLASET( 'Full', N, N, ZERO, ONE, A, LDA ) MDIG = NDECM1 IDIG = NDECM1 RETURN END IF C IF ( N.EQ.1 ) THEN C C The 1-by-1 case. C A(1,1) = EXP( A(1,1)*DELTA ) MDIG = NDECM1 IDIG = NDECM1 RETURN END IF C C Set pointers for the workspace. C JWORA1 = 1 JWORA2 = JWORA1 + N*N JWORA3 = JWORA2 + N*NDIAG JWORV1 = JWORA3 + N*N JWORV2 = JWORV1 + N C C Compute Pade coefficients in DWORK(JWORV2:JWORV2+NDIAG-1). C DWORK(JWORV2) = HALF C DO 20 I = 2, NDIAG IM1 = I - 1 DWORK(JWORV2+IM1) = DWORK(JWORV2+I-2)*DBLE( NDIAG - IM1 )/ $ DBLE( I*( 2*NDIAG - IM1 ) ) 20 CONTINUE C VAREPS = EPS**2*( ( DBLE( BASE )**2 - ONE )/ $ ( TWO4*LOG( DBLE( BASE ) ) ) ) XN = DBLE( N ) TR = ZERO C C Apply a translation with the mean of the eigenvalues of A*DELTA. C DO 40 I = 1, N CALL DSCAL( N, DELTA, A(1,I), 1 ) TR = TR + A(I,I) 40 CONTINUE C AVGEV = TR/XN IF ( AVGEV.GT.LOG( OVRTHR ) .OR. AVGEV.LT.LOG( UNDERF ) ) $ AVGEV = ZERO IF ( AVGEV.NE.ZERO ) THEN ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) C DO 60 I = 1, N A(I,I) = A(I,I) - AVGEV 60 CONTINUE C TEMP = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) IF ( TEMP.GT.HALF*ANORM ) THEN C DO 80 I = 1, N A(I,I) = A(I,I) + AVGEV 80 CONTINUE C AVGEV = ZERO END IF END IF ACTBAL = BALANC IF ( LBALS ) THEN C C Balancing (scaling) has been requested. First, save A. C CALL DLACPY( 'Full', N, N, A, LDA, DWORK(JWORA1), N ) MAXRED = TWOHND CALL MB04MD( N, MAXRED, A, LDA, DWORK(JWORV1), INFO ) IF ( MAXRED.LT.ONE ) THEN C C Recover the matrix and reset DWORK(JWORV1,...,JWORV1+N-1) C to 1, as no reduction of the norm occured (unlikely event). C CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA ) ACTBAL = 'N' DWORK(JWORV1) = ONE CALL DCOPY( N-1, DWORK(JWORV1), 0, DWORK(JWORV1+1), 1 ) IWARN = 3 END IF END IF C C Scale the matrix by 2**(-M), where M is the minimum integer C so that the resulted matrix has the 1-norm less than 0.5. C ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) M = 0 IF ( ANORM.GE.HALF ) THEN MPOWER = INT( LOG( OVRTHR )/LOG( TWO ) ) M = INT( LOG( ANORM )/LOG( TWO ) ) + 1 IF ( M.GT.MPOWER ) THEN C C Error return: The norm of A*DELTA is too large. C INFO = 1 RETURN END IF FACTOR = TWO**M IF ( M+1.LT.MPOWER ) THEN M = M + 1 FACTOR = FACTOR*TWO END IF C DO 120 I = 1, N CALL DSCAL( N, ONE/FACTOR, A(1,I), 1 ) 120 CONTINUE C END IF NDAGM1 = NDIAG - 1 NDAGM2 = NDAGM1 - 1 IJ = 0 C C Compute the factors of the diagonal Pade approximant. C The loop 200 takes the accuracy requirements into account: C Pade coefficients decrease with K, so the calculations should C be performed in backward order, one column at a time. C (A BLAS 3 implementation in forward order, using DGEMM, could C possibly be less accurate.) C DO 200 J = 1, N CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, A(1,J), 1, ZERO, $ DWORK(JWORA2), 1 ) IK = 0 C DO 140 K = 1, NDAGM2 CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, $ DWORK(JWORA2+IK), 1, ZERO, DWORK(JWORA2+IK+N), $ 1 ) IK = IK + N 140 CONTINUE C DO 180 I = 1, N S = ZERO U = ZERO IK = NDAGM2*N + I - 1 C DO 160 K = NDAGM1, 1, -1 P = DWORK(JWORV2+K)*DWORK(JWORA2+IK) IK = IK - N S = S + P IF ( MOD( K+1, 2 ).EQ.0 ) THEN U = U + P ELSE U = U - P END IF 160 CONTINUE C P = DWORK(JWORV2)*A(I,J) S = S + P U = U - P IF ( I.EQ.J ) THEN S = S + ONE U = U + ONE END IF DWORK(JWORA3+IJ) = S DWORK(JWORA1+IJ) = U IJ = IJ + 1 180 CONTINUE C 200 CONTINUE C C Compute the exponential of the scaled matrix, using diagonal Pade C approximants. As, in theory [1], the denominator of the Pade C approximant should be very well conditioned, no condition estimate C is computed. C CALL DGETRF( N, N, DWORK(JWORA1), N, IWORK, IFAIL ) IF ( IFAIL.GT.0 ) THEN C C Error return: The matrix is exactly singular. C INFO = 2 RETURN END IF C CALL DLACPY( 'Full', N, N, DWORK(JWORA3), N, A, LDA ) CALL DGETRS( 'No transpose', N, N, DWORK(JWORA1), N, IWORK, A, $ LDA, IFAIL ) C C Prepare for the calculation of the accuracy estimates. C Note that ANORM here is in the range [1, e]. C ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) IF ( ANORM.GE.ONE ) THEN EABS = ( NINTEN*XN + FOUR7 )*( EPS*ANORM ) ELSE EABS = ( ( NINTEN*XN + FOUR7 )*EPS )*ANORM END IF IF ( M.NE.0 ) THEN VAR = XN*VAREPS FN = ( FOUR*XN )/( ( XN + TWO )*( XN + ONE ) ) GN = ( ( TWO*XN + TEN )*XN - FOUR )/( ( ( XN + TWO )**2 ) $ *( ( XN + ONE )**2 ) ) C C Square-up the computed exponential matrix M times, with caution C for avoiding overflows. C DO 220 K = 1, M IF ( ANORM.GT.OVRTH2 ) THEN C C The solution could overflow. C CALL DGEMM( 'No transpose', 'No transpose', N, N, N, $ ONE/ANORM, A, LDA, A, LDA, ZERO, $ DWORK(JWORA1), N ) S = DLANGE( '1-norm', N, N, DWORK(JWORA1), N, $ DWORK(JWORA1) ) IF ( ANORM.LE.OVRTHR/S ) THEN CALL DLASCL( 'General', N, N, ONE, ANORM, N, N, $ DWORK(JWORA1), N, INFO ) TEMP = OVRTHR ELSE C C Error return: The solution would overflow. C This will not happen on most machines, due to the C selection of M. C INFO = 3 RETURN END IF ELSE CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, $ A, LDA, A, LDA, ZERO, DWORK(JWORA1), N ) TEMP = ANORM**2 END IF IF ( EABS.LT.ONE ) THEN EABS = ( TWO*ANORM + EABS )*EABS + XN*( EPS*TEMP ) ELSE IF ( EABS.LT.SQRT( ONE - XN*EPS + OVRTHR/TEMP )*ANORM - $ ANORM ) THEN EABS = XN*( EPS*TEMP ) + TWO*( ANORM*EABS ) + EABS**2 ELSE EABS = OVRTHR END IF C TMP1 = FN*VAR + GN*( TEMP*VAREPS ) IF ( TMP1.GT.OVRTHR/TEMP ) THEN VAR = OVRTHR ELSE VAR = TMP1*TEMP END IF C CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA ) ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) 220 CONTINUE C ELSE VAR = ( TWELVE*XN )*VAREPS END IF C C Apply back transformations, if balancing was effectively used. C CALL MB05OY( ACTBAL, N, 1, N, A, LDA, DWORK(JWORV1), INFO ) EAVGEV = EXP( AVGEV ) EMNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) C C Compute auxiliary quantities needed for the accuracy estimates. C BIG = ONE SMALL = ONE IF ( LBALS ) THEN C C Compute norms of the diagonal scaling matrix and its inverse. C DO 240 I = 1, N U = DWORK(JWORV1+I-1) IF ( BIG.LT.U ) BIG = U IF ( SMALL.GT.U ) SMALL = U 240 CONTINUE C SUM2D = DNRM2( N, DWORK(JWORV1), 1 ) ELSE SUM2D = SQRT( XN ) END IF C C Update the exponential for the initial translation, and update the C auxiliary quantities needed for the accuracy estimates. C SD2 = SQRT( EIGHT*XN*VAREPS )*ANORM BD = SQRT( VAR ) SS = MAX( BD, SD2 ) BD = MIN( BD, SD2 ) SD2 = SS*SQRT( ONE + ( BD/SS )**2 ) IF ( SD2.LE.ONE ) THEN SD2 = ( TWO/XN )*SUM2D*SD2 ELSE IF ( SUM2D/XN.LT.OVRTHR/TWO/SD2 ) THEN SD2 = ( TWO/XN )*SUM2D*SD2 ELSE SD2 = OVRTHR END IF IF ( LBALS ) THEN SIZE = ZERO ELSE IF ( SD2.LT.OVRTHR - EMNORM ) THEN SIZE = EMNORM + SD2 ELSE SIZE = OVRTHR END IF END IF C DO 260 J = 1, N SS = DASUM( N, A(1,J), 1 ) CALL DSCAL( N, EAVGEV, A(1,J), 1 ) IF ( LBALS ) THEN BD = DWORK(JWORV1+J-1) SIZE = MAX( SIZE, SS + SD2/BD ) END IF 260 CONTINUE C C Set the accuracy estimates and warning errors, if any. C RERR = LOG10( BIG ) + LOG10( EABS ) - LOG10( SMALL ) - $ LOG10( EMNORM ) - LOG10( EPS ) IF ( SIZE.GT.EMNORM ) THEN RERL = LOG10( ( SIZE/EMNORM - ONE )/EPS ) ELSE RERL = ZERO END IF MDIG = MIN( NDEC - INT( RERR + HALF ), NDECM1 ) IDIG = MIN( NDEC - INT( RERL + HALF ), NDECM1 ) C IF ( MDIG.LE.0 ) THEN MDIG = 0 IWARN = 1 END IF IF ( IDIG.LE.0 ) THEN IDIG = 0 IWARN = 2 END IF C RETURN C *** Last line of MB05OD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03HD.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03HD.f0000644000175000017500000002163415012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE MB03HD( N, A, LDA, B, LDB, MACPAR, Q, LDQ, DWORK, $ INFO ) C C PURPOSE C C To determine an orthogonal matrix Q, for a real regular 2-by-2 or C 4-by-4 skew-Hamiltonian/Hamiltonian pencil C C ( A11 A12 ) ( B11 B12 ) C aA - bB = a ( ) - b ( ) C ( 0 A11' ) ( 0 -B11' ) C C in structured Schur form, such that J Q' J' (aA - bB) Q is still C in structured Schur form but the eigenvalues are exchanged. The C notation M' denotes the transpose of the matrix M. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aA - bB. N = 2 or N = 4. C C A (input) DOUBLE PRECISION array, dimension (LDA, N) C If N = 4, the leading N/2-by-N upper trapezoidal part of C this array must contain the first block row of the skew- C Hamiltonian matrix A of the pencil aA - bB in structured C Schur form. Only the entries (1,1), (1,2), (1,4), and C (2,2) are referenced. C If N = 2, this array is not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= N/2. C C B (input) DOUBLE PRECISION array, dimension (LDB, N) C The leading N/2-by-N part of this array must contain the C first block row of the Hamiltonian matrix B of the C pencil aA - bB in structured Schur form. The entry (2,3) C is not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= N/2. C C MACPAR (input) DOUBLE PRECISION array, dimension (2) C Machine parameters: C MACPAR(1) (machine precision)*base, DLAMCH( 'P' ); C MACPAR(2) safe minimum, DLAMCH( 'S' ). C This argument is not used for N = 2. C C Q (output) DOUBLE PRECISION array, dimension (LDQ, N) C The leading N-by-N part of this array contains the C orthogonal transformation matrix Q. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (24) C If N = 2, then DWORK is not referenced. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: the leading N/2-by-N/2 block of the matrix B is C numerically singular, but slightly perturbed values C have been used. This is a warning. C C METHOD C C The algorithm uses orthogonal transformations as described on page C 31 in [2]. The structure is exploited. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical computation of deflating subspaces of skew- C Hamiltonian/Hamiltonian pencils. C SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002. C C [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 16, 2008. C V. Sima, Sep. 2009 (SLICOT version of the routine DHAUEX). C C REVISIONS C C V. Sima, Nov. 2009, Nov. 2010, Apr. 2016. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue exchange, skew-Hamiltonian/Hamiltonian pencil, C structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) C C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDQ, N C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), $ MACPAR( * ), Q( LDQ, * ) C C .. Local Scalars .. INTEGER ITAU, IWRK DOUBLE PRECISION CO, D, NRM, S, SI, SMIN, SMLN, T C C .. Local Arrays .. DOUBLE PRECISION PAR( 3 ) C C .. External Subroutines .. EXTERNAL DGEMM, DGEQR2, DLACPY, DLARTG, DLASCL, DORG2R, $ DROT, MB02UW C C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C INFO = 0 C C Computations. C IF( N.EQ.4 ) THEN C C Set machine constants. C PAR( 1 ) = MACPAR( 1 ) PAR( 2 ) = MACPAR( 2 ) C C Compute si*inv(B11)*[ A11 A12 B12 ], using blocks of A and B. C X11 = si*inv(B11)*A11. C Also, set SMIN to avoid overflows in matrix multiplications. C DWORK( 1 ) = A( 1, 1 ) DWORK( 2 ) = ZERO DWORK( 5 ) = A( 1, 2 ) DWORK( 6 ) = A( 2, 2 ) DWORK( 9 ) = ZERO DWORK( 10 ) = -A( 1, 4 ) DWORK( 11 ) = -DWORK( 1 ) DWORK( 12 ) = -DWORK( 5 ) DWORK( 13 ) = -DWORK( 10 ) DWORK( 14 ) = ZERO DWORK( 15 ) = ZERO DWORK( 16 ) = -DWORK( 6 ) DWORK( 17 ) = B( 1, 3 ) DWORK( 18 ) = B( 1, 4 ) DWORK( 21 ) = B( 1, 4 ) DWORK( 22 ) = B( 2, 4 ) C SMLN = TWO*PAR( 2 ) / PAR( 1 ) SMIN = SQRT( SMLN ) / $ MAX( ABS( DWORK( 1 ) ), SMLN, ABS( DWORK( 10 ) ), $ ABS( DWORK( 5 ) ) + ABS( DWORK( 6 ) ), $ ABS( DWORK( 18 ) ) + $ MAX( ABS( DWORK( 17 ) ), ABS( DWORK( 22 ) ) ) ) PAR( 3 ) = SMIN CALL MB02UW( .FALSE., 2, 6, PAR, B, LDB, DWORK, 4, SI, INFO ) C C Compute X22 = -d*inv(B11')*A11'. C CALL MB02UW( .TRUE., 2, 2, PAR, B, LDB, DWORK( 11 ), 4, D, $ INFO ) C C Take si = min( si, d ) as unique scaling factor. C IF( SI.LT.D ) THEN CALL DLASCL( 'G', 0, 0, D, SI, 2, 2, DWORK( 11 ), 4, INFO ) ELSE IF( SI.GT.D ) THEN CALL DLASCL( 'G', 0, 0, SI, D, 2, 6, DWORK, 4, INFO ) END IF C C Compute X12 = si*( inv(B11)*A12 - ( inv(B11)*B12 )*X22 ). C CALL DGEMM( 'No Transpose', 'No Transpose', 2, 2, 2, -ONE, $ DWORK( 17 ), 4, DWORK( 11 ), 4, ONE, DWORK( 9 ), $ 4 ) C C Scale X11, X12, and X22, so that 1-norm of X11 is 1. C NRM = MAX( ABS( DWORK( 1 ) ) + ABS( DWORK( 2 ) ), $ ABS( DWORK( 5 ) ) + ABS( DWORK( 6 ) ), SMLN ) IF ( NRM.GT.ONE ) THEN CALL DLASCL( 'G', 0, 0, NRM, ONE, 2, 4, DWORK, 4, INFO ) CALL DLASCL( 'G', 0, 0, NRM, ONE, 2, 2, DWORK( 11 ), 4, $ INFO ) END IF C C Compute s = trace(X11). C S = DWORK( 1 ) + DWORK( 6 ) C C Compute Y2, the last two columns of Y = X*X - s*X + t*I4, C where X = ( Xij ), i,j = 1,2, X21 = 0, t = det(X11). C T = DWORK( 1 )*DWORK( 6 ) - DWORK( 2 )*DWORK( 5 ) C CALL DLACPY( 'Full', 4, 2, DWORK( 9 ), 4, Q, LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', 2, 2, 4, ONE, $ DWORK, 4, DWORK( 9 ), 4, -S, Q, LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', 2, 2, 2, ONE, $ DWORK( 11 ), 4, DWORK( 11 ), 4, -S, Q( 3, 1 ), $ LDQ ) Q( 3, 1 ) = Q( 3, 1 ) + T Q( 4, 2 ) = Q( 4, 2 ) + T C ITAU = 1 IWRK = 3 C C Triangularize Y2 and compute the orthogonal transformation C matrix. C CALL DGEQR2( 4, 2, Q, LDQ, DWORK( ITAU ), DWORK( IWRK ), INFO ) CALL DORG2R( 4, 4, 2, Q, LDQ, DWORK( ITAU ), DWORK( IWRK ), $ INFO ) C C Use the last two columns of Q to build a 2-by-4 matrix W. C Postmultiply A with the first column of Q, and premultiply C by W. Then, annihilate the second element of the result. C DWORK( 21 ) = A( 1, 1 )*Q( 1, 1 ) + A( 1, 2 )*Q( 2, 1 ) + $ A( 1, 4 )*Q( 4, 1 ) DWORK( 22 ) = A( 2, 2 )*Q( 2, 1 ) - A( 1, 4 )*Q( 3, 1 ) DWORK( 23 ) = A( 1, 1 )*Q( 3, 1 ) DWORK( 24 ) = A( 1, 2 )*Q( 3, 1 ) + A( 2, 2 )*Q( 4, 1 ) DWORK( 9 ) = Q( 3, 3 )*DWORK( 21 ) + Q( 4, 3 )*DWORK( 22 ) $ - Q( 1, 3 )*DWORK( 23 ) - Q( 2, 3 )*DWORK( 24 ) DWORK( 10 ) = Q( 3, 4 )*DWORK( 21 ) + Q( 4, 4 )*DWORK( 22 ) $ - Q( 1, 4 )*DWORK( 23 ) - Q( 2, 4 )*DWORK( 24 ) CALL DLARTG( DWORK( 9 ), DWORK( 10 ), CO, SI, T ) CALL DROT( 4, Q( 1, 3 ), 1, Q( 1, 4 ), 1, CO, SI ) C ELSE CALL DLARTG( B( 1, 2 ), TWO*B( 1, 1 ), CO, SI, T ) Q( 1, 1 ) = CO Q( 2, 1 ) = -SI Q( 1, 2 ) = SI Q( 2, 2 ) = CO END IF C RETURN C *** Last line of MB03HD *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03BS.f0000644000000000000000000000013215012430707016176 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SG03BS.f0000644000175000017500000005305615012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE SG03BS( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, $ ZWORK, INFO ) C C PURPOSE C C To compute the Cholesky factor U of the matrix X, X = U**H * U or C X = U * U**H, which is the solution of the generalized d-stable C discrete-time Lyapunov equation C C H H 2 H C A * X * A - E * X * E = - SCALE * B * B, (1) C C or the conjugate transposed equation C C H H 2 H C A * X * A - E * X * E = - SCALE * B * B , (2) C C respectively, where A, E, B, and U are complex N-by-N matrices. C The Cholesky factor U of the solution is computed without first C finding X. The pencil A - lambda * E must be in complex C generalized Schur form (A and E are upper triangular and the C diagonal elements of E are non-negative real numbers). Moreover, C it must be d-stable, i.e., the moduli of its eigenvalues must be C less than one. B must be an upper triangular matrix with real C non-negative entries on its main diagonal. C C The resulting matrix U is upper triangular. The entries on its C main diagonal are non-negative. SCALE is an output scale factor C set to avoid overflow in U. C C ARGUMENTS C C Mode Parameters C C TRANS CHARACTER*1 C Specifies whether equation (1) or equation (2) is to be C solved: C = 'N': Solve equation (1); C = 'C': Solve equation (2). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices. N >= 0. C C A (input/workspace) COMPLEX*16 array, dimension (LDA,N) C The leading N-by-N upper triangular part of this array C must contain the triangular matrix A. The lower triangular C part is used as workspace, but the diagonal is restored. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C E (input/workspace) COMPLEX*16 array, dimension (LDE,N) C The leading N-by-N upper triangular part of this array C must contain the triangular matrix E. If TRANS = 'N', the C strictly lower triangular part is used as workspace. C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,N). C C B (input/output) COMPLEX*16 array, dimension (LDB,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the matrix B. C On exit, the leading N-by-N upper triangular part of this C array contains the solution matrix U. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,N). C C SCALE (output) DOUBLE PRECISION C The scale factor set to avoid overflow in U. C 0 < SCALE <= 1. C C Workspace C C DWORK DOUBLE PRECISION array, dimension LDWORK, where C LDWORK = 0, if N <= 1; C LDWORK = MAX(N-1,10), if N > 1. C C ZWORK COMPLEX*16, dimension MAX(3*N-3,0) 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 = 3: the pencil A - lambda * E is not stable, i.e., there C there are eigenvalues outside the open unit circle; C = 4: the LAPACK routine ZSTEIN utilized to factorize M3 C failed to converge. This error is unlikely to occur. C C METHOD C C The method used by the routine is an extension of Hammarling's C algorithm [1] to generalized Lyapunov equations. The real case is C described in [2]. C C We present the method for solving equation (1). Equation (2) can C be treated in a similar fashion. For simplicity, assume SCALE = 1. C C Since all matrices A, E, B, and U are upper triangular, we use the C following partitioning C C ( A11 A12 ) ( E11 E12 ) C A = ( ), E = ( ), C ( 0 A22 ) ( 0 E22 ) C C ( B11 B12 ) ( U11 U12 ) C B = ( ), U = ( ), (3) C ( 0 B22 ) ( 0 U22 ) C C where the size of the (1,1)-blocks is 1-by-1. C C We compute U11, U12**H and U22 in three steps. C C Step I: C C From (1) and (3) we get the 1-by-1 equation C C H H H H H C A11 * U11 * U11 * A11 - E11 * U11 * U11 * E11 = -B11 * B11. C C For brevity, details are omitted here. The technique for C computing U11 is similar to those applied to standard Lyapunov C equations in Hammarling's algorithm ([1], section 5). C C Furthermore, the auxiliary scalars M1 and M2 defined as follows C C M1 = A11 / E11 , M2 = B11 / E11 / U11 , C C are computed in a numerically reliable way. C C Step II: C C We solve for U12**H the linear system of equations, with C scaling to prevent overflow, C C H H H C ( M1 * A22 - E22 ) U12 = C C H H H C = - M2 * B12 + U11 * ( E12 - M1 * A12 ) . C C Step III: C C One can show that C C H H H H C A22 * U22 * U22 * A22 - E22 * U22 * U22 * E22 = C C H H C - B22 * B22 - y * y (4) C C holds, where y is defined as follows C C H H H H C y = ( B12 U11 * A12 + A22 * U12 ) * M3EV, C C where M3EV is a matrix which fulfils C C ( I - M2*M2 -M2*M1**H ) H C M3 = ( ) = M3EV * M3EV . C ( -M1*M2 I - M1*M1**H ) C C M3 is positive semidefinite and its rank is equal to 1. C Therefore, a matrix M3EV can be found by solving the Hermitian C eigenvalue problem for M3 such that y consists of one column. C C If B22_tilde is the square triangular matrix arising from the C QR-factorization C C ( B22_tilde ) ( B22 ) C Q * ( ) = ( ), C ( 0 ) ( y**H ) C C then C C H H H C - B22 * B22 - y * y = - B22_tilde * B22_tilde. C C Replacing the right hand side in (4) by the term C - B22_tilde**H * B22_tilde leads to a generalized Lyapunov C equation like (1), but of dimension N-1. C C The solution U of the equation (1) can be obtained by recursive C application of the steps I to III. C C REFERENCES C C [1] Hammarling, S.J. C Numerical solution of the stable, non-negative definite C Lyapunov equation. C IMA J. Num. Anal., 2, pp. 303-323, 1982. 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 The routine requires 2*N**3 flops. Note that we count a single C floating point arithmetic operation as one flop. C C FURTHER COMMENTS C C The Lyapunov equation may be very ill-conditioned. In particular, C if the pencil A - lambda * E has a pair of almost reciprocal C eigenvalues, then the Lyapunov equation will be ill-conditioned. C Perturbed values were used to solve the equation. C A condition estimate can be obtained from the routine SG03AD. C C CONTRIBUTOR C C V. Sima, June 2021. C C REVISIONS C C V. Sima, July 2021, Oct. 2021, Nov. 2021. 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 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. CHARACTER TRANS DOUBLE PRECISION SCALE INTEGER INFO, LDA, LDB, LDE, N C .. Array Arguments .. DOUBLE PRECISION DWORK(*) COMPLEX*16 A(LDA,*), B(LDB,*), E(LDE,*), ZWORK(*) C .. Local Scalars .. COMPLEX*16 M1, R, S, X, Z DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, M2, SCALE1, SMLNUM, T, $ UII INTEGER APT, I, J, KL, KL1, UPT, WPT LOGICAL NOTRNS C .. Local Arrays .. COMPLEX*16 M3(2,2), M3C(2,1) DOUBLE PRECISION D(2), ES(2), W(2) INTEGER IWORK(7) C .. External Functions .. DOUBLE PRECISION DLAMCH LOGICAL LSAME EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DLABAD, MA02EZ, XERBLA, ZAXPY, ZCOPY, ZDSCAL, $ ZLACGV, ZLARFG, ZLARTG, ZLASCL, ZLATRS, ZROT, $ ZSCAL, ZSTEIN, ZTRMV C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, MAX, SQRT 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, 'C' ) ) ) 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 ( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE INFO = 0 END IF IF ( INFO.NE.0 ) THEN CALL XERBLA( 'SG03BS', -INFO ) RETURN END IF C SCALE = ONE C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' )/EPS BIGNUM = ONE/SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) C C Set workspace pointers. C UPT = 1 WPT = N APT = 2*N - 1 C C Set constant input for ZSTEIN. C IWORK(2) = 1 IWORK(3) = 0 IWORK(4) = 2 IWORK(5) = 0 W(1) = ONE W(2) = ZERO C IF ( NOTRNS ) THEN C C Solve equation (1). C C Store the last N-1 diagonal elements of A. C Fill-in the strictly lower triangular part of E with the C conjugate transpose of the strictly upper triangular part. C IF ( N.GT.1 ) $ CALL ZCOPY( N-1, A(2,2), LDA+1, ZWORK(APT), 1 ) CALL MA02EZ( 'Upper', 'Conj', 'NoSkew', N, E, LDE ) C C Main Loop. Compute the row elements U(KL,KL:N). C DO 60 KL = 1, N C C STEP I: Compute U(KL,KL) and the auxiliary scalars M1 and C M2. (For the moment the result U(KL,KL) is stored C in UII). C DELTA1 = DBLE( E(KL,KL) ) T = ABS( A(KL,KL) ) M2 = MAX( DELTA1, T ) DELTA1 = DELTA1/M2 T = T/M2 IF ( DELTA1.LE.T ) THEN INFO = 3 RETURN END IF DELTA1 = SQRT( ONE - T )*SQRT( ONE + T )*M2 T = DBLE( B(KL,KL) )*SMLNUM IF ( T.GT.DELTA1 ) THEN SCALE1 = DELTA1/T SCALE = SCALE1*SCALE CALL ZLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO ) END IF C UII = DBLE( B(KL,KL) )/DELTA1 C IF ( KL.LT.N ) THEN C M1 = A(KL,KL)/DBLE( E(KL,KL) ) M2 = DELTA1/DBLE( E(KL,KL) ) C C STEP II: Compute U(KL,KL+1:N) by solving a linear system C of equations. (For the moment the result is C stored in the workspace.) C C Fill-in the lower triangular part of A22 with the C conjugate transpose of the upper triangular part. C CALL MA02EZ( 'Upper', 'Conj', 'General', N-KL+1, $ A(KL,KL), LDA ) C C Form right hand side of the system of equations. C KL1 = KL + 1 CALL ZCOPY( N-KL, E(KL1,KL), 1, ZWORK(UPT), 1 ) CALL ZAXPY( N-KL, -M1, A(KL1,KL), 1, ZWORK(UPT), 1 ) I = UPT C DO 10 J = KL1, N ZWORK(I) = DCMPLX( UII )*ZWORK(I) - $ DCMPLX( M2 )*DCONJG( B(KL,J) ) I = I + 1 10 CONTINUE C C Form the coefficient matrix. C DO 30 J = KL1, N DO 20 I = J, N A(I,J) = M1*A(I,J) - E(I,J) 20 CONTINUE 30 CONTINUE C C Solve the system, with scaling to prevent overflow. C CALL ZLATRS( 'Lower', 'NoConj', 'NoDiag', 'NoNorm', N-KL, $ A(KL1,KL1), LDA, ZWORK(UPT), SCALE1, DWORK, $ INFO ) IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE UII = SCALE1*UII CALL ZLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO ) END IF C C Restore the diagonal of A22. C A(KL,KL) = DCONJG( A(KL,KL) ) CALL ZCOPY( N-KL, ZWORK(APT+KL-1), 1, A(KL1,KL1), LDA+1 ) C C STEP III: Form the right hand side matrix C B(KL+1:N,KL+1:N) of the (smaller) Lyapunov C equation to be solved during the next pass of C the main loop. C C Compute auxiliary matrices M3 and Y. The factorization C M3 = M3C * M3C**H is found by solving the special C symmetric eigenvalue problem. (D is the diagonal of M3.) C M3(1,2) = -M2*DCONJG( M1 ) C X = M3(1,2) CALL ZLARFG( 1, X, M3(1,2), 1, Z ) D(1) = ABS( M1 )**2 D(2) = M2**2 ES(1) = DBLE( X ) C CALL ZSTEIN( 2, D, ES, 1, W, IWORK(2), IWORK(4), M3C, 2, $ DWORK, IWORK(6), IWORK, INFO ) IF ( INFO.NE.0 ) THEN INFO = 4 RETURN END IF M3C(1,1) = ( CONE - Z )*M3C(1,1) C C Compute auxiliary vector Y in ZWORK(WPT). C CALL ZCOPY( N-KL, ZWORK(UPT), 1, ZWORK(WPT), 1 ) CALL ZTRMV( 'Upper', 'Conj', 'NonUnit', N-KL, $ A(KL1,KL1), LDA, ZWORK(WPT), 1 ) CALL ZAXPY( N-KL, DCMPLX( UII ), A(KL1,KL), 1, $ ZWORK(WPT), 1 ) CALL ZSCAL( N-KL, M3C(2,1), ZWORK(WPT), 1 ) CALL ZLACGV( N-KL, ZWORK(WPT), 1 ) CALL ZAXPY( N-KL, DCONJG( M3C(1,1) ), B(KL,KL1), LDB, $ ZWORK(WPT), 1 ) C C Overwrite B(KL+1:N,KL+1:N) with the triangular matrix C from the QR-factorization of the (N-KL+1)-by-(N-KL) C matrix C C ( B(KL+1:N,KL+1:N) ) C ( ) . C ( Y**H ) C DO 40 I = 1, N-KL X = B(KL+I,KL+I) Z = ZWORK(WPT+I-1) CALL ZLARTG( X, Z, C, S, R ) B(KL+I,KL+I) = R IF ( I.LT.N-KL ) $ CALL ZROT( N-KL-I, B(KL+I,KL1+I), LDB, $ ZWORK(WPT+I), 1, C, S ) 40 CONTINUE C C Make main diagonal elements of B(KL+1:N,KL+1:N) positive. C DO 50 I = KL1, N IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( N-I+1, MONE, B(I,I), LDB ) 50 CONTINUE C C Overwrite right hand side with the part of the solution C computed in step II. C CALL ZLACGV( N-KL, ZWORK(UPT), 1 ) CALL ZCOPY( N-KL, ZWORK(UPT), 1, B(KL,KL1), LDB ) C END IF C C Overwrite right hand side with the part of the solution C computed in step I. C B(KL,KL) = UII C 60 CONTINUE C ELSE C C Solve equation (2). C C Store the first N-1 diagonal elements of A. C IF ( N.GT.1 ) $ CALL ZCOPY( N-1, A, LDA+1, ZWORK(APT), 1 ) C C Main Loop. Compute the column elements U(1:KL,KL). C DO 110 KL = N, 1, -1 C C STEP I: Compute U(KL,KL) and the auxiliary scalars M1 and C M2. (For the moment the result U(KL,KL) is stored C in UII). C DELTA1 = DBLE( E(KL,KL) ) T = ABS( A(KL,KL) ) M2 = MAX( DELTA1, T ) DELTA1 = DELTA1/M2 T = T/M2 IF ( DELTA1.LE.T ) THEN INFO = 3 RETURN END IF DELTA1 = SQRT( ONE - T )*SQRT( ONE + T )*M2 T = DBLE( B(KL,KL) )*SMLNUM IF ( T.GT.DELTA1 ) THEN SCALE1 = DELTA1/T SCALE = SCALE1*SCALE CALL ZLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO ) END IF C UII = DBLE( B(KL,KL) )/DELTA1 C IF ( KL.GT.1 ) THEN C M1 = DCONJG( A(KL,KL) )/DBLE( E(KL,KL) ) M2 = DELTA1/DBLE( E(KL,KL) ) C C STEP II: Compute U(1:KL,KL) by solving a linear system C of equations. (For the moment the result is C stored in the workspace.) C C Fill-in the strictly lower triangular part of A22 with C the transpose of the strictly upper triangular part. C KL1 = KL - 1 CALL MA02EZ( 'Upper', 'Trans', 'General', KL1, A, LDA ) C C Form right hand side of the system of equations. C CALL ZCOPY( KL1, E(1,KL), 1, ZWORK(UPT), 1 ) CALL ZAXPY( KL1, -M1, A(1,KL), 1, ZWORK(UPT), 1 ) CALL ZDSCAL( KL1, UII, ZWORK(UPT), 1 ) CALL ZAXPY( KL1, -DCMPLX( M2 ), B(1,KL), 1, ZWORK(UPT), $ 1 ) C C Form the coefficient matrix. C DO 80 J = 1, KL1 DO 70 I = 1, J A(I,J) = M1*A(I,J) - E(I,J) 70 CONTINUE 80 CONTINUE C C Solve the system, with scaling to prevent overflow. C CALL ZLATRS( 'Upper', 'NoConj', 'NoDiag', 'NoNorm', KL1, $ A, LDA, ZWORK(UPT), SCALE1, DWORK, INFO ) IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE UII = SCALE1*UII CALL ZLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO ) END IF C C Restore the upper triangular part of A22. C CALL MA02EZ( 'Lower', 'Trans', 'General', KL1, A, LDA ) CALL ZCOPY( KL1, ZWORK(APT), 1, A, LDA+1 ) C C STEP III: Form the right hand side matrix C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov C equation to be solved during the next pass of C the main loop. C C Compute auxiliary matrices M3 and Y. The factorization C M3 = M3C * M3C**H is found by solving the special C symmetric eigenvalue problem. (D is the diagonal of M3.) C M3(1,2) = -M2*DCONJG( M1 ) C X = M3(1,2) CALL ZLARFG( 1, X, M3(1,2), 1, Z ) D(1) = ABS( M1 )**2 D(2) = M2**2 ES(1) = DBLE( X ) C CALL ZSTEIN( 2, D, ES, 1, W, IWORK(2), IWORK(4), M3C, 2, $ DWORK, IWORK(6), IWORK, INFO ) IF ( INFO.NE.0 ) THEN INFO = 4 RETURN END IF M3C(1,1) = ( CONE - Z )*M3C(1,1) C C Compute auxiliary vector Y in B(1:KL,KL). C CALL ZSCAL( KL1, M3C(1,1), B(1,KL), 1 ) CALL ZCOPY( KL1, ZWORK(UPT), 1, ZWORK(WPT), 1 ) CALL ZTRMV( 'Upper', 'NoTrans', 'NonUnit', KL1, A, LDA, $ ZWORK(WPT), 1 ) CALL ZAXPY( KL1, DCMPLX( UII ), A(1,KL), 1, ZWORK(WPT), $ 1 ) CALL ZAXPY( KL1, M3C(2,1), ZWORK(WPT), 1, B(1,KL), 1 ) C C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix C from the RQ-factorization of the (KL-1)-by-KL matrix C C ( ) C ( B(1:KL-1,1:KL-1) Y ) . C ( ) C DO 90 I = KL1, 1, -1 X = B(I,I) Z = B(I,KL) CALL ZLARTG( X, Z, C, S, R ) B(I,I) = R IF ( I.GT.1 ) $ CALL ZROT( I-1, B(1,I), 1, B(1,KL), 1, C, S ) 90 CONTINUE C C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. C DO 100 I = 1, KL1 IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( I, MONE, B(1,I), 1 ) 100 CONTINUE C C Overwrite right hand side with the part of the solution C computed in step II. C CALL ZCOPY( KL1, ZWORK(UPT), 1, B(1,KL), 1 ) C END IF C C Overwrite right hand side with the part of the solution C computed in step I. C B(KL,KL) = UII C 110 CONTINUE C END IF C RETURN C *** Last line of SG03BS *** END control-4.1.2/src/slicot/src/PaxHeaders/IB03BD.f0000644000000000000000000000013215012430707016140 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/IB03BD.f0000644000175000017500000013036115012430707017340 0ustar00lilgelilge00000000000000 SUBROUTINE IB03BD( INIT, NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2, $ NPRINT, U, LDU, Y, LDY, X, LX, TOL1, TOL2, $ IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a set of parameters for approximating a Wiener system C in a least-squares sense, using a neural network approach and a C MINPACK-like Levenberg-Marquardt algorithm. The Wiener system C consists of a linear part and a static nonlinearity, and it is C represented as C C x(t+1) = A*x(t) + B*u(t) C z(t) = C*x(t) + D*u(t), C C y(t) = f(z(t),wb(1:L)), C C where t = 1, 2, ..., NSMP, and f is a nonlinear function, C evaluated by the SLICOT Library routine NF01AY. The parameter C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), C where theta corresponds to the linear part, and wb(i), i = 1 : L, C correspond to the nonlinear part. See SLICOT Library routine C NF01AD for further details. C C The sum of squares of the error functions, defined by C C e(t) = y(t) - Y(t), t = 1, 2, ..., NSMP, C C is minimized, where Y(t) is the measured output vector. The C functions and their Jacobian matrices are evaluated by SLICOT C Library routine NF01BF (the FCN routine in the call of MD03BD). C C ARGUMENTS C C Mode Parameters C C INIT CHARACTER*1 C Specifies which parts have to be initialized, as follows: C = 'L' : initialize the linear part only, X already C contains an initial approximation of the C nonlinearity; C = 'S' : initialize the static nonlinearity only, X C already contains an initial approximation of the C linear part; C = 'B' : initialize both linear and nonlinear parts; C = 'N' : do not initialize anything, X already contains C an initial approximation. C If INIT = 'S' or 'B', the error functions for the C nonlinear part, and their Jacobian matrices, are evaluated C by SLICOT Library routine NF01BE (used as a second FCN C routine in the MD03BD call for the initialization step, C see METHOD). C C Input/Output Parameters C C NOBR (input) INTEGER C If INIT = 'L' or 'B', NOBR is the number of block rows, s, C in the input and output block Hankel matrices to be C processed for estimating the linear part. NOBR > 0. C (In the MOESP theory, NOBR should be larger than n, C the estimated dimension of state vector.) C This parameter is ignored if INIT is 'S' or 'N'. C C M (input) INTEGER C The number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L >= 0, and L > 0, if C INIT = 'L' or 'B'. C C NSMP (input) INTEGER C The number of input and output samples, t. NSMP >= 0, and C NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'. C C N (input/output) INTEGER C The order of the linear part. C If INIT = 'L' or 'B', and N < 0 on entry, the order is C assumed unknown and it will be found by the routine. C Otherwise, the input value will be used. If INIT = 'S' C or 'N', N must be non-negative. The values N >= NOBR, C or N = 0, are not acceptable if INIT = 'L' or 'B'. C C NN (input) INTEGER C The number of neurons which shall be used to approximate C the nonlinear part. NN >= 0. C C ITMAX1 (input) INTEGER C The maximum number of iterations for the initialization of C the static nonlinearity. C This parameter is ignored if INIT is 'N' or 'L'. C Otherwise, ITMAX1 >= 0. C C ITMAX2 (input) INTEGER C The maximum number of iterations. ITMAX2 >= 0. C C NPRINT (input) INTEGER C This parameter enables controlled printing of iterates if C it is positive. In this case, FCN is called with IFLAG = 0 C at the beginning of the first iteration and every NPRINT C iterations thereafter and immediately prior to return, C and the current error norm is printed. Other intermediate C results could be printed by modifying the corresponding C FCN routine (NF01BE and/or NF01BF). If NPRINT <= 0, no C special calls of FCN with IFLAG = 0 are made. C C U (input) DOUBLE PRECISION array, dimension (LDU, M) C The leading NSMP-by-M part of this array must contain the C set of input samples, C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,NSMP). C C Y (input) DOUBLE PRECISION array, dimension (LDY, L) C The leading NSMP-by-L part of this array must contain the C set of output samples, C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). C C LDY INTEGER C The leading dimension of array Y. LDY >= MAX(1,NSMP). C C X (input/output) DOUBLE PRECISION array dimension (LX) C On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part C of this array must contain the initial parameters for C the nonlinear part of the system. C On entry, if INIT = 'S', the elements lin1 : lin2 of this C array must contain the initial parameters for the linear C part of the system, corresponding to the output normal C form, computed by SLICOT Library routine TB01VD, where C lin1 = (NN*(L+2) + 1)*L + 1; C lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M. C On entry, if INIT = 'N', the elements 1 : lin2 of this C array must contain the initial parameters for the C nonlinear part followed by the initial parameters for the C linear part of the system, as specified above. C This array need not be set on entry if INIT = 'B'. C On exit, the elements 1 : lin2 of this array contain the C optimal parameters for the nonlinear part followed by the C optimal parameters for the linear part of the system, as C specified above. C C LX (input/output) INTEGER C On entry, this parameter must contain the intended length C of X. If N >= 0, then LX >= NX := lin2 (see parameter X). C If N is unknown (N < 0 on entry), a large enough estimate C of N should be used in the formula of lin2. C On exit, if N < 0 on entry, but LX is not large enough, C then this parameter contains the actual length of X, C corresponding to the computed N. Otherwise, its value C is unchanged. C C Tolerances C C TOL1 DOUBLE PRECISION C If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance C which measures the relative error desired in the sum of C squares, as well as the relative error desired in the C approximate solution, for the initialization step of C nonlinear part. Termination occurs when either both the C actual and predicted relative reductions in the sum of C squares, or the relative error between two consecutive C iterates are at most TOL1. If the user sets TOL1 < 0, C then SQRT(EPS) is used instead TOL1, where EPS is the C machine precision (see LAPACK Library routine DLAMCH). C This parameter is ignored if INIT is 'N' or 'L'. C C TOL2 DOUBLE PRECISION C If TOL2 >= 0, TOL2 is the tolerance which measures the C relative error desired in the sum of squares, as well as C the relative error desired in the approximate solution, C for the whole optimization process. Termination occurs C when either both the actual and predicted relative C reductions in the sum of squares, or the relative error C between two consecutive iterates are at most TOL2. If the C user sets TOL2 < 0, then SQRT(EPS) is used instead TOL2. C This default value could require many iterations, C especially if TOL1 is larger. If INIT = 'S' or 'B', it is C advisable that TOL2 be larger than TOL1, and spend more C time with cheaper iterations. C C Workspace C C IWORK INTEGER array, dimension (MAX( LIW1, LIW2, LIW3 )), where C LIW1 = LIW2 = 0, if INIT = 'S' or 'N'; otherwise, C LIW1 = M+L; C LIW2 = MAX(M*NOBR+N,M*(N+L)); C LIW3 = 3+MAX(NN*(L+2)+2,NX+L), if INIT = 'S' or 'B'; C LIW3 = 3+NX+L, if INIT = 'L' or 'N'. C On output, if INFO = 0, IWORK(1) and IWORK(2) return the C (total) number of function and Jacobian evaluations, C respectively (including the initialization step, if it was C performed), and if INIT = 'L' or INIT = 'B', IWORK(3) C specifies how many locations of DWORK contain reciprocal C condition number estimates (see below); otherwise, C IWORK(3) = 0. If INFO = 0, the entries 4 to 3+NX of IWORK C define a permutation matrix P such that J*P = Q*R, where C J is the final calculated Jacobian, Q is an orthogonal C matrix (not stored), and R is upper triangular with C diagonal elements of nonincreasing magnitude (possibly C for each block column of J). Column j of P is column C IWORK(3+j) of the identity matrix. Moreover, the entries C 4+NX:3+NX+L of this array contain the ranks of the final C submatrices S_k (see description of LMPARM in MD03BD). C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On entry, if desired, and if INIT = 'S' or 'B', the C entries DWORK(1:4) are set to initialize the random C numbers generator for the nonlinear part parameters (see C the description of the argument XINIT of SLICOT Library C routine MD03BD); this enables to obtain reproducible C results. The same seed is used for all outputs. C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK, DWORK(2) returns the residual error norm (the C sum of squares), DWORK(3) returns the number of iterations C performed, and DWORK(4) returns the final Levenberg C factor, for optimizing the parameters of both the linear C part and the static nonlinearity part. If INIT = 'S' or C INIT = 'B' and INFO = 0, then the elements DWORK(5) to C DWORK(8) contain the corresponding four values for the C initialization step (see METHOD). (If L > 1, DWORK(8) C contains the maximum of the Levenberg factors for all C outputs.) If INIT = 'L' or INIT = 'B', and INFO = 0, C DWORK(9) to DWORK(8+IWORK(3)) contain reciprocal condition C number estimates set by SLICOT Library routines IB01AD, C IB01BD, and IB01CD. C On exit, if INFO = -21, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C In the formulas below, N should be taken not larger than C NOBR - 1, if N < 0 on entry. C LDWORK = MAX( LW1, LW2, LW3, LW4 ), where C LW1 = 0, if INIT = 'S' or 'N'; otherwise, C LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR, C 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + C MAX( LDW1, LDW2 ), C (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) + C MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ), C where, C LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, C L*NOBR*N + C MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, C 2*(L*NOBR-L)*N+N*N+8*N, C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) C LDW2 >= 0, if M = 0; C LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) + C MAX( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; C LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ), C LDW4 = N*(N+1) + 2*N + C MAX( N*L*(N+1) + 2*N*N + L*N, 4*N ); C LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L; C LDW6 = NSMP*L + (N+L)*(N+M) + N + C MAX(1, N*N*L + N*L + N, N*N + C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), C N*M)); C LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise, C LW2 = NSMP*L + BSN + C MAX( 4, NSMP + C MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), C BSN**2 + BSN + C MAX( NSMP + 2*NN, 5*BSN ) ) ); C LW3 = MAX( LDW7, NSMP*L + (N+L)*(2*N+M) + 2*N ); C LDW7 = NSMP*L + (N+L)*(N+M) + 3*N+M+L, if M > 0; C LDW7 = NSMP*L + (N+L)*N + 2*N+L, if M = 0; C LW4 = NSMP*L + NX + C MAX( 4, NSMP*L + C MAX( NSMP*L*( BSN + LTHS ) + C MAX( NSMP*L + L1, L2 + NX ), C NX*( BSN + LTHS ) + NX + C MAX( NSMP*L + L1, NX + L3 ) ) ), C L0 = MAX( N*(N+L), N+M+L ), if M > 0; C L0 = MAX( N*(N+L), L ), if M = 0; C L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0); C L2 = 4*NX + 1, if L <= 1 or BSN = 0; otherwise, C L2 = BSN + MAX(3*BSN+1,LTHS); C L2 = MAX(L2,4*LTHS+1), if NSMP > BSN; C L2 = MAX(L2,(NSMP-BSN)*(L-1)), if BSN < NSMP < 2*BSN; C L3 = 4*NX, if L <= 1 or BSN = 0; C L3 = LTHS*BSN + 2*NX + 2*MAX(BSN,LTHS), C if L > 1 and BSN > 0, C with BSN = NN*( L + 2 ) + 1, C LTHS = N*( L + M + 1 ) + L*M. C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C < 0: the user set IFLAG = IWARN in (one of) the C subroutine(s) FCN, i.e., NF01BE, if INIT = 'S' C or 'B', and/or NF01BF; this value cannot be returned C without changing the FCN routine(s); C otherwise, IWARN has the value k*100 + j*10 + i, C where k is defined below, i refers to the whole C optimization process, and j refers to the C initialization step (j = 0, if INIT = 'L' or 'N'), C and the possible values for i and j have the C following meaning (where TOL* denotes TOL1 or TOL2, C and similarly for ITMAX*): C = 1: both actual and predicted relative reductions in C the sum of squares are at most TOL*; C = 2: relative error between two consecutive iterates is C at most TOL*; C = 3: conditions for i or j = 1 and i or j = 2 both hold; C = 4: the cosine of the angle between the vector of error C function values and any column of the Jacobian is at C most EPS in absolute value; C = 5: the number of iterations has reached ITMAX* without C satisfying any convergence condition; C = 6: TOL* is too small: no further reduction in the sum C of squares is possible; C = 7: TOL* is too small: no further improvement in the C approximate solution X is possible; C = 8: the vector of function values e is orthogonal to the C columns of the Jacobian to machine precision. C The digit k is normally 0, but if INIT = 'L' or 'B', it C can have a value in the range 1 to 6 (see IB01AD, IB01BD C and IB01CD). In all these cases, the entries DWORK(1:4), C DWORK(5:8) (if INIT = 'S' or 'B'), and DWORK(9:8+IWORK(3)) C (if INIT = 'L' or 'B'), are set as described above. 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 otherwise, INFO has the value k*100 + j*10 + i, C where k is defined below, i refers to the whole C optimization process, and j refers to the C initialization step (j = 0, if INIT = 'L' or 'N'), C and the possible values for i and j have the C following meaning: C = 1: the routine FCN returned with INFO <> 0 for C IFLAG = 1; C = 2: the routine FCN returned with INFO <> 0 for C IFLAG = 2; C = 3: the routine QRFACT returned with INFO <> 0; C = 4: the routine LMPARM returned with INFO <> 0. C In addition, if INIT = 'L' or 'B', i could also be C = 5: if a Lyapunov equation could not be solved; C = 6: if the identified linear system is unstable; C = 7: if the QR algorithm failed on the state matrix C of the identified linear system. C QRFACT and LMPARM are generic names for SLICOT Library C routines NF01BS and NF01BP, respectively, for the whole C optimization process, and MD03BA and MD03BB, respectively, C for the initialization step (if INIT = 'S' or 'B'). C The digit k is normally 0, but if INIT = 'L' or 'B', it C can have a value in the range 1 to 10 (see IB01AD/IB01BD). C C METHOD C C If INIT = 'L' or 'B', the linear part of the system is C approximated using the combined MOESP and N4SID algorithm. If C necessary, this algorithm can also choose the order, but it is C advantageous if the order is already known. C C If INIT = 'S' or 'B', the output of the approximated linear part C is computed and used to calculate an approximation of the static C nonlinearity using the Levenberg-Marquardt algorithm [1,3]. C This step is referred to as the (nonlinear) initialization step. C C As last step, the Levenberg-Marquardt algorithm is used again to C optimize the parameters of the linear part and the static C nonlinearity as a whole. Therefore, it is necessary to parametrise C the matrices of the linear part. The output normal form [2] C parameterisation is used. C C The Jacobian is computed analytically, for the nonlinear part, and C numerically, for the linear part. C C REFERENCES C C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. C User's Guide for MINPACK-1. C Applied Math. Division, Argonne National Laboratory, Argonne, C Illinois, Report ANL-80-74, 1980. C C [2] Peeters, R.L.M., Hanzon, B., and Olivi, M. C Balanced realizations of discrete-time stable all-pass C systems and the tangential Schur algorithm. C Proceedings of the European Control Conference, C 31 August - 3 September 1999, Karlsruhe, Germany. C Session CP-6, Discrete-time Systems, 1999. C C [3] More, J.J. C The Levenberg-Marquardt algorithm: implementation and theory. C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg C and New York, pp. 105-116, 1978. C C NUMERICAL ASPECTS C C The Levenberg-Marquardt algorithm described in [3] is scaling C invariant and globally convergent to (maybe local) minima. C The convergence rate near a local minimum is quadratic, if the C Jacobian is computed analytically, and linear, if the Jacobian C is computed numerically. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C V. Sima, March, 2002, Apr. 2002, Feb. 2004, March 2005. C C KEYWORDS C C Least-squares approximation, Levenberg-Marquardt algorithm, C matrix operations, optimization. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C FACTOR is a scaling factor for variables (see MD03BD). DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 100.0D0 ) C Condition estimation and internal scaling of variables are used C (see MD03BD). CHARACTER COND, SCALE PARAMETER ( COND = 'E', SCALE = 'I' ) C Default tolerances are used in MD03BD for measuring the C orthogonality between the vector of function values and columns C of the Jacobian (GTOL), and for the rank estimations (TOL). DOUBLE PRECISION GTOL, TOL PARAMETER ( GTOL = 0.0D0, TOL = 0.0D0 ) C For INIT = 'L' or 'B', additional parameters are set: C The following six parameters are used in the call of IB01AD; CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH PARAMETER ( ALG = 'Fast QR', BATCH = 'One batch', $ CONCT = 'Not connect', CTRL = 'Not confirm', $ JOBD = 'Not MOESP', METH = 'MOESP' ) C The following three parameters are used in the call of IB01BD; CHARACTER JOB, JOBCK, METHB PARAMETER ( JOB = 'All matrices', $ JOBCK = 'No Kalman gain', $ METHB = 'Combined MOESP+N4SID' ) C The following two parameters are used in the call of IB01CD; CHARACTER COMUSE, JOBXD PARAMETER ( COMUSE = 'Use B, D', $ JOBXD = 'D also' ) C TOLN controls the estimated order in IB01AD (default value); DOUBLE PRECISION TOLN PARAMETER ( TOLN = -1.0D0 ) C RCOND controls the rank decisions in IB01AD, IB01BD, and IB01CD C (default); DOUBLE PRECISION RCOND PARAMETER ( RCOND = -1.0D0 ) C .. Scalar Arguments .. CHARACTER INIT INTEGER INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK, $ LDY, LX, M, N, NN, NOBR, NPRINT, NSMP DOUBLE PRECISION TOL1, TOL2 C .. Array Arguments .. DOUBLE PRECISION DWORK(*), U(LDU, *), X(*), Y(LDY, *) INTEGER IWORK(*) C .. Local Scalars .. INTEGER AC, BD, BSN, I, IA, IB, IDIAG, IK, INFOL, IQ, $ IR, IRCND, IRCNDB, IRY, IS, ISAD, ISV, IV, IW1, $ IW2, IW3, IWARNL, IX, IX0, J, JWORK, LDAC, LDR, $ LIPAR, LNOL, LTHS, ML, MNO, N2, NFEV, NJEV, NS, $ NSML, NTHS, NX, WRKOPT, Z LOGICAL INIT1, INIT2 C .. Local Arrays .. LOGICAL BWORK(1) INTEGER IPAR(7) DOUBLE PRECISION RCND(16), SEED(4), WORK(4) C .. External Functions .. EXTERNAL LSAME LOGICAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, IB01AD, IB01BD, IB01CD, MD03BA, MD03BB, $ MD03BD, NF01BE, NF01BF, NF01BP, NF01BS, TB01VD, $ TB01VY, TF01MX, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. C .. Executable Statements .. C C Check the scalar input parameters. C INIT1 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'L' ) INIT2 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'S' ) C ML = M + L INFO = 0 IWARN = 0 IF ( .NOT.( INIT1 .OR. INIT2 .OR. LSAME( INIT, 'N' ) ) ) THEN INFO = -1 ELSEIF ( INIT1 .AND. NOBR.LE.0 ) THEN INFO = -2 ELSEIF ( M.LT.0 ) THEN INFO = -3 ELSEIF ( L.LT.0 .OR. ( INIT1 .AND. L.EQ.0 ) ) THEN INFO = -4 ELSEIF ( NSMP.LT.0 .OR. $ ( INIT1 .AND. NSMP.LT.2*( ML + 1 )*NOBR - 1 ) ) THEN INFO = -5 ELSEIF ( ( N.LT.0 .AND. .NOT.INIT1 ) .OR. $ ( ( N.EQ.0 .OR. N.GE.NOBR ) .AND. INIT1 ) ) THEN INFO = -6 ELSEIF ( NN.LT.0 ) THEN INFO = -7 ELSEIF ( INIT2 .AND. ( ITMAX1.LT.0 ) ) THEN INFO = -8 ELSEIF ( ITMAX2.LT.0 ) THEN INFO = -9 ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN INFO = -12 ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN INFO = -14 ELSE LNOL = L*NOBR - L MNO = M*NOBR BSN = NN*( L + 2 ) + 1 NTHS = BSN*L NSML = NSMP*L IF ( N.GT.0 ) THEN LDAC = N + L ISAD = LDAC*( N + M ) N2 = N*N END IF C C Check the workspace size. C JWORK = 0 IF ( INIT1 ) THEN C Workspace for IB01AD. JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR IF ( N.GT.0 ) THEN C Workspace for IB01BD. IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + $ 1, MNO + 3*N + L ) ) IF ( M.GT.0 ) THEN IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + $ MAX( LDAC**2, 4*M*LDAC + 1 ) ELSE IW2 = 0 END IF JWORK = MAX( JWORK, $ ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) ) C Workspace for IB01CD. IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) IW2 = N*( N + 1 ) + 2*N + $ MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N ) JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) C Workspace for TF01MX. JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) C Workspace for TB01VD. JWORK = MAX( JWORK, NSML + ISAD + N + $ MAX( 1, N2*L + N*L + N, $ N2 + MAX( N2 + N*MAX( N, L ) + $ 6*N + MIN( N, L ), N*M ) ) ) END IF END IF C IF ( INIT2 ) THEN C Workspace for MD03BD (initialization of the nonlinear part). JWORK = MAX( JWORK, NSML + BSN + $ MAX( 4, NSMP + $ MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), $ BSN**2 + BSN + $ MAX( NSMP + 2*NN, 5*BSN ) ) ) ) IF ( N.GT.0 .AND. .NOT.INIT1 ) THEN C Workspace for TB01VY. JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N ) C Workspace for TF01MX. IF ( M.GT.0 ) THEN IW1 = N + M ELSE IW1 = 0 END IF JWORK = MAX( JWORK, NSML + ISAD + IW1 + LDAC + N ) END IF END IF C IF ( N.GE.0 ) THEN C C Find the number of parameters. C LTHS = N*( ML + 1 ) + L*M NX = NTHS + LTHS C IF ( LX.LT.NX ) THEN INFO = -16 CALL XERBLA( 'IB03BD', -INFO ) RETURN END IF C C Workspace for MD03BD (whole optimization). C IF ( M.GT.0 ) THEN IW1 = LDAC + M ELSE IW1 = L END IF IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) IF ( L.LE.1 .OR. BSN.EQ.0 ) THEN IW3 = 4*NX IW2 = IW3 + 1 ELSE IW2 = BSN + MAX( 3*BSN + 1, LTHS ) IF ( NSMP.GT.BSN ) THEN IW2 = MAX( IW2, 4*LTHS + 1 ) IF ( NSMP.LT.2*BSN ) $ IW2 = MAX( IW2, ( NSMP - BSN )*( L - 1 ) ) END IF IW3 = LTHS*BSN + 2*NX + 2*MAX( BSN, LTHS ) END IF JWORK = MAX( JWORK, NSML + NX + $ MAX( 4, NSML + $ MAX( NSML*( BSN + LTHS ) + $ MAX( NSML + IW1, IW2 + NX ), $ NX*( BSN + LTHS ) + NX + $ MAX( NSML + IW1, NX + IW3 ) ) $ ) ) END IF C IF ( LDWORK.LT.JWORK ) THEN INFO = -21 DWORK(1) = JWORK END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB03BD', -INFO ) RETURN END IF C C Initialize the pointers to system matrices and save the possible C seed for random numbers generation. C Z = 1 AC = Z + NSML CALL DCOPY( 4, DWORK, 1, SEED, 1 ) C WRKOPT = 1 C IF ( INIT1 ) THEN C C Initialize the linear part. C If N < 0, the order of the system is determined by IB01AD; C otherwise, the given order will be used. C The workspace needed is defined for the options set above C in the PARAMETER statements. C Workspace: need: 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR; C prefer: larger. C Integer workspace: M+L. (If METH = 'N', (M+L)*NOBR.) C NS = N IR = 1 ISV = 2*ML*NOBR LDR = ISV IF ( LSAME( JOBD, 'M' ) ) $ LDR = MAX( LDR, 3*MNO ) ISV = IR + LDR*ISV JWORK = ISV + L*NOBR C CALL IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L, $ NSMP, U, LDU, Y, LDY, N, DWORK(IR), LDR, $ DWORK(ISV), RCOND, TOLN, IWORK, DWORK(JWORK), $ LDWORK-JWORK+1, IWARNL, INFOL ) C IF( INFOL.NE.0 ) THEN INFO = 100*INFOL RETURN END IF IF( IWARNL.NE.0 ) $ IWARN = 100*IWARNL WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) IRCND = 0 IF ( LSAME( METH, 'N' ) ) THEN IRCND = 2 CALL DCOPY( IRCND, DWORK(JWORK+1), 1, RCND, 1 ) END IF C IF ( NS.GE.0 ) THEN N = NS ELSE C C Find the number of parameters. C LDAC = N + L ISAD = LDAC*( N + M ) N2 = N*N LTHS = N*( ML + 1 ) + L*M NX = NTHS + LTHS C IF ( LX.LT.NX ) THEN LX = NX INFO = -16 CALL XERBLA( 'IB03BD', -INFO ) RETURN END IF C Workspace for IB01BD. IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + 1, $ MNO + 3*N + L ) ) IF ( M.GT.0 ) THEN IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + $ MAX( LDAC**2, 4*M*LDAC + 1 ) ELSE IW2 = 0 END IF JWORK = ISV + ISAD + MAX( IW1, IW2 ) C Workspace for IB01CD. IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) IW2 = N*( N + 1 ) + 2*N + MAX( N*L*( N + 1 ) + 2*N2 + L*N, $ 4*N ) JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) C Workspace for TF01MX. JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) C Workspace for TB01VD. JWORK = MAX( JWORK, NSML + ISAD + N + $ MAX( 1, N2*L + N*L + N, $ N2 + MAX( N2 + N*MAX( N, L ) + $ 6*N + MIN( N, L ), N*M ) ) ) C Workspace for MD03BD (whole optimization). IF ( M.GT.0 ) THEN IW1 = LDAC + M ELSE IW1 = L END IF IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) IF ( L.LE.1 .OR. BSN.EQ.0 ) THEN IW3 = 4*NX IW2 = IW3 + 1 ELSE IW2 = BSN + MAX( 3*BSN + 1, LTHS ) IF ( NSMP.GT.BSN ) THEN IW2 = MAX( IW2, 4*LTHS + 1 ) IF ( NSMP.LT.2*BSN ) $ IW2 = MAX( IW2, ( NSMP - BSN )*( L - 1 ) ) END IF IW3 = LTHS*BSN + 2*NX + 2*MAX( BSN, LTHS ) END IF JWORK = MAX( JWORK, NSML + NX + $ MAX( 4, NSML + $ MAX( NSML*( BSN + LTHS ) + $ MAX( NSML + IW1, IW2 + NX ), $ NX*( BSN + LTHS ) + NX + $ MAX( NSML + IW1, NX + IW3 ) ) $ ) ) IF ( LDWORK.LT.JWORK ) THEN INFO = -21 DWORK(1) = JWORK CALL XERBLA( 'IB03BD', -INFO ) RETURN END IF END IF C BD = AC + LDAC*N IX = BD + LDAC*M IA = ISV IB = IA + LDAC*N IQ = IB + LDAC*M IF ( LSAME( JOBCK, 'N' ) ) THEN IRY = IQ IS = IQ IK = IQ JWORK = IQ ELSE IRY = IQ + N2 IS = IRY + L*L IK = IS + N*L JWORK = IK + N*L END IF C C The workspace needed is defined for the options set above C in the PARAMETER statements. C Workspace: C need: 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + C max( LDW1,LDW2 ), where, C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, C L*NOBR*N + C max( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, C 2*(L*NOBR-L)*N+N*N+8*N, C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) C LDW2 >= 0, if M = 0; C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ C max( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; C prefer: larger. C Integer workspace: MAX(M*NOBR+N,M*(N+L)). C CALL IB01BD( METHB, JOB, JOBCK, NOBR, N, M, L, NSMP, DWORK(IR), $ LDR, DWORK(IA), LDAC, DWORK(IA+N), LDAC, $ DWORK(IB), LDAC, DWORK(IB+N), LDAC, DWORK(IQ), N, $ DWORK(IRY), L, DWORK(IS), N, DWORK(IK), N, RCOND, $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, BWORK, $ IWARNL, INFOL ) C IF( INFOL.EQ.-30 ) THEN INFO = -21 DWORK(1) = DWORK(JWORK) CALL XERBLA( 'IB03BD', -INFO ) RETURN END IF IF( INFOL.NE.0 ) THEN INFO = 100*INFOL RETURN END IF IF( IWARNL.NE.0 ) $ IWARN = 100*IWARNL WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) IRCNDB = 4 IF ( LSAME( JOBCK, 'K' ) ) $ IRCNDB = IRCNDB + 8 CALL DCOPY( IRCNDB, DWORK(JWORK+1), 1, RCND(IRCND+1), 1 ) IRCND = IRCND + IRCNDB C C Copy the system matrices to the beginning of DWORK, to save C space, and redefine the pointers. C CALL DCOPY( ISAD, DWORK(IA), 1, DWORK, 1 ) IA = 1 IB = IA + LDAC*N IX0 = IB + LDAC*M IV = IX0 + N C C Compute the initial condition of the system. On normal exit, C DWORK(i), i = JWORK+2:JWORK+1+N*N, C DWORK(j), j = JWORK+2+N*N:JWORK+1+N*N+L*N, and C DWORK(k), k = JWORK+2+N*N+L*N:JWORK+1+N*N+L*N+N*M, C contain the transformed system matrices At, Ct, and Bt, C respectively, corresponding to the real Schur form of the C estimated system state matrix A. The transformation matrix is C stored in DWORK(IV:IV+N*N-1). C The workspace needed is defined for the options set above C in the PARAMETER statements. C Workspace: C need: (N+L)*(N+M) + N + N*N + 2 + N*( N + M + L ) + C max( 5*N, 2, min( LDW1, LDW2 ) ), where, C LDW1 = NSMP*L*(N + 1) + 2*N + max( 2*N*N, 4*N), C LDW2 = N*(N + 1) + 2*N + C max( N*L*(N + 1) + 2*N*N + L*N, 4*N); C prefer: larger. C Integer workspace: N. C JWORK = IV + N2 CALL IB01CD( 'X needed', COMUSE, JOBXD, N, M, L, NSMP, $ DWORK(IA), LDAC, DWORK(IB), LDAC, DWORK(IA+N), $ LDAC, DWORK(IB+N), LDAC, U, LDU, Y, LDY, $ DWORK(IX0), DWORK(IV), N, RCOND, IWORK, $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFOL ) C IF( INFOL.EQ.-26 ) THEN INFO = -21 DWORK(1) = DWORK(JWORK) CALL XERBLA( 'IB03BD', -INFO ) RETURN END IF IF( INFOL.EQ.1 ) $ INFOL = 10 IF( INFOL.NE.0 ) THEN INFO = 100*INFOL RETURN END IF IF( IWARNL.NE.0 ) $ IWARN = 100*IWARNL WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) IRCND = IRCND + 1 RCND(IRCND) = DWORK(JWORK+1) C C Now, save the system matrices and x0 in the final location. C IF ( IV.LT.AC ) THEN CALL DCOPY( ISAD+N, DWORK(IA), 1, DWORK(AC), 1 ) ELSE DO 10 J = AC + ISAD + N - 1, AC, -1 DWORK(J) = DWORK(IA+J-AC) 10 CONTINUE END IF C C Compute the output of the linear part. C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, C if M > 0; C NSMP*L + (N + L)*N + 2*N + L, if M = 0; C prefer larger. C JWORK = IX + N CALL DCOPY( N, DWORK(IX), 1, X(NTHS+1), 1 ) CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, X(NTHS+1), $ DWORK(Z), NSMP, DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) C C Convert the state-space representation to output normal form. C Workspace: C need: NSMP*L + (N + L)*(N + M) + N + C MAX(1, N*N*L + N*L + N, N*N + C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), N*M)); C prefer: larger. C CALL TB01VD( 'Apply', N, M, L, DWORK(AC), LDAC, DWORK(BD), $ LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), LDAC, $ DWORK(IX), X(NTHS+1), LTHS, DWORK(JWORK), $ LDWORK-JWORK+1, INFOL ) C IF( INFOL.GT.0 ) THEN INFO = INFOL + 4 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C END IF C LIPAR = 7 IW1 = 0 IW2 = 0 IDIAG = AC C IF ( INIT2 ) THEN C C Initialize the nonlinear part. C IF ( .NOT.INIT1 ) THEN BD = AC + LDAC*N IX = BD + LDAC*M C C Convert the output normal form to state-space model. C Workspace: need NSMP*L + (N + L)*(2*N + M) + 2*N. C (NSMP*L locations are reserved for the output of the linear C part.) C JWORK = IX + N CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), $ LDAC, DWORK(BD), LDAC, DWORK(AC+N), LDAC, $ DWORK(BD+N), LDAC, DWORK(IX), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) C C Compute the output of the linear part. C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, C if M > 0; C NSMP*L + (N + L)*N + 2*N + L, if M = 0; C prefer larger. C CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, $ DWORK(IX), DWORK(Z), NSMP, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) END IF C C Optimize the parameters of the nonlinear part. C Workspace: C need NSMP*L + BSN + C MAX( 4, NSMP + C MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), C BSN**2 + BSN + MAX( NSMP + 2*NN, 5*BSN ) )); C prefer larger. C Integer workspace: NN*(L + 2) + 2. C WORK(1) = ZERO CALL DCOPY( 3, WORK(1), 0, WORK(2), 1 ) C C Set the integer parameters needed, including the number of C neurons. C IPAR(1) = NSMP IPAR(2) = L IPAR(3) = NN JWORK = IDIAG + BSN C DO 30 I = 0, L - 1 CALL DCOPY( 4, SEED, 1, DWORK(JWORK), 1 ) CALL MD03BD( 'Random initialization', SCALE, COND, NF01BE, $ MD03BA, MD03BB, NSMP, BSN, ITMAX1, FACTOR, $ NPRINT, IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), $ LDY, X(I*BSN+1), DWORK(IDIAG), NFEV, NJEV, $ TOL1, TOL1, GTOL, TOL, IWORK, DWORK(JWORK), $ LDWORK-JWORK+1, IWARNL, INFOL ) IF( INFOL.NE.0 ) THEN INFO = 10*INFOL RETURN END IF IF ( IWARNL.LT.0 ) THEN INFO = INFOL IWARN = IWARNL GO TO 50 ELSEIF ( IWARNL.GT.0 ) THEN IF ( IWARN.GT.100 ) THEN IWARN = MAX( IWARN, ( IWARN/100 )*100 + 10*IWARNL ) ELSE IWARN = MAX( IWARN, 10*IWARNL ) END IF END IF WORK(1) = MAX( WORK(1), DWORK(JWORK) ) WORK(2) = MAX( WORK(2), DWORK(JWORK+1) ) WORK(4) = MAX( WORK(4), DWORK(JWORK+3) ) WORK(3) = WORK(3) + DWORK(JWORK+2) IW1 = NFEV + IW1 IW2 = NJEV + IW2 30 CONTINUE C END IF C C Main iteration. C Workspace: C need NSMP*L + NX + C MAX( 4, NSMP*L + C MAX( NSMP*L*( BSN + LTHS ) + C MAX( NSMP*L + LDW1, LDW2 + NX ), C NX*( BSN + LTHS ) + NX + C MAX( NSMP*L + LDW1, NX + LDW3 ) ) ), C LDW0 = MAX( N*(N+L), N+M+L ), if M > 0; C LDW0 = MAX( N*(N+L), L ), if M = 0; C LDW1 = NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + LDW0); C LDW2 = 4*NX + 1, if L <= 1 or BSN = 0; otherwise, C LDW2 = BSN + MAX(3*BSN+1,LTHS); C LDW2 = MAX(LDW2, 4*LTHS+1), if NSMP > BSN; C LDW2 = MAX(LDW2, (NSMP-BSN)*(L-1)), if BSN < NSMP < 2*BSN; C LDW3 = 4*NX, if L <= 1 or BSN = 0; C LDW3 = LTHS*BSN + 2*NX + 2*MAX(BSN,LTHS), C if L > 1 and BSN > 0; C prefer larger. C Integer workspace: NX+L. C C Set the integer parameters describing the Jacobian structure C and the number of neurons. C IPAR(1) = LTHS IPAR(2) = L IPAR(3) = NSMP IPAR(4) = BSN IPAR(5) = M IPAR(6) = N IPAR(7) = NN JWORK = IDIAG + NX C CALL MD03BD( 'Given initialization', SCALE, COND, NF01BF, $ NF01BS, NF01BP, NSML, NX, ITMAX2, FACTOR, NPRINT, $ IPAR, LIPAR, U, LDU, Y, LDY, X, DWORK(IDIAG), NFEV, $ NJEV, TOL2, TOL2, GTOL, TOL, IWORK, DWORK(JWORK), $ LDWORK-JWORK+1, IWARNL, INFO ) IF( INFO.NE.0 ) $ RETURN C DO 40 I = 1, NX + L IWORK(I+3) = IWORK(I) 40 CONTINUE C 50 CONTINUE IWORK(1) = IW1 + NFEV IWORK(2) = IW2 + NJEV IF ( IWARNL.LT.0 ) THEN IWARN = IWARNL ELSE IWARN = IWARN + IWARNL END IF CALL DCOPY( 4, DWORK(JWORK), 1, DWORK, 1 ) IF ( INIT2 ) $ CALL DCOPY( 4, WORK, 1, DWORK(5), 1 ) IF ( INIT1 ) THEN IWORK(3) = IRCND CALL DCOPY( IRCND, RCND, 1, DWORK(9), 1 ) ELSE IWORK(3) = 0 END IF C RETURN C C *** Last line of IB03BD *** END control-4.1.2/src/slicot/src/PaxHeaders/IB03AD.f0000644000000000000000000000013215012430707016137 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/IB03AD.f0000644000175000017500000012650515012430707017344 0ustar00lilgelilge00000000000000 SUBROUTINE IB03AD( INIT, ALG, STOR, NOBR, M, L, NSMP, N, NN, $ ITMAX1, ITMAX2, NPRINT, U, LDU, Y, LDY, X, LX, $ TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a set of parameters for approximating a Wiener system C in a least-squares sense, using a neural network approach and a C Levenberg-Marquardt algorithm. Conjugate gradients (CG) or C Cholesky algorithms are used to solve linear systems of equations. C The Wiener system is represented as C C x(t+1) = A*x(t) + B*u(t) C z(t) = C*x(t) + D*u(t), C C y(t) = f(z(t),wb(1:L)), C C where t = 1, 2, ..., NSMP, and f is a nonlinear function, C evaluated by the SLICOT Library routine NF01AY. The parameter C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), C where wb(i), i = 1 : L, correspond to the nonlinear part, and C theta corresponds to the linear part. See SLICOT Library routine C NF01AD for further details. C C The sum of squares of the error functions, defined by C C e(t) = y(t) - Y(t), t = 1, 2, ..., NSMP, C C is minimized, where Y(t) is the measured output vector. The C functions and their Jacobian matrices are evaluated by SLICOT C Library routine NF01BB (the FCN routine in the call of MD03AD). C C ARGUMENTS C C Mode Parameters C C INIT CHARACTER*1 C Specifies which parts have to be initialized, as follows: C = 'L' : initialize the linear part only, X already C contains an initial approximation of the C nonlinearity; C = 'S' : initialize the static nonlinearity only, X C already contains an initial approximation of the C linear part; C = 'B' : initialize both linear and nonlinear parts; C = 'N' : do not initialize anything, X already contains C an initial approximation. C If INIT = 'S' or 'B', the error functions for the C nonlinear part, and their Jacobian matrices, are evaluated C by SLICOT Library routine NF01BA (used as a second FCN C routine in the MD03AD call for the initialization step, C see METHOD). C C ALG CHARACTER*1 C Specifies the algorithm used for solving the linear C systems involving a Jacobian matrix J, as follows: C = 'D' : a direct algorithm, which computes the Cholesky C factor of the matrix J'*J + par*I is used, where C par is the Levenberg factor; C = 'I' : an iterative Conjugate Gradients algorithm, which C only needs the matrix J, is used. C In both cases, matrix J is stored in a compressed form. C C STOR CHARACTER*1 C If ALG = 'D', specifies the storage scheme for the C symmetric matrix J'*J, as follows: C = 'F' : full storage is used; C = 'P' : packed storage is used. C The option STOR = 'F' usually ensures a faster execution. C This parameter is not relevant if ALG = 'I'. C C Input/Output Parameters C C NOBR (input) INTEGER C If INIT = 'L' or 'B', NOBR is the number of block rows, s, C in the input and output block Hankel matrices to be C processed for estimating the linear part. NOBR > 0. C (In the MOESP theory, NOBR should be larger than n, C the estimated dimension of state vector.) C This parameter is ignored if INIT is 'S' or 'N'. C C M (input) INTEGER C The number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L >= 0, and L > 0, if C INIT = 'L' or 'B'. C C NSMP (input) INTEGER C The number of input and output samples, t. NSMP >= 0, and C NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'. C C N (input/output) INTEGER C The order of the linear part. C If INIT = 'L' or 'B', and N < 0 on entry, the order is C assumed unknown and it will be found by the routine. C Otherwise, the input value will be used. If INIT = 'S' C or 'N', N must be non-negative. The values N >= NOBR, C or N = 0, are not acceptable if INIT = 'L' or 'B'. C C NN (input) INTEGER C The number of neurons which shall be used to approximate C the nonlinear part. NN >= 0. C C ITMAX1 (input) INTEGER C The maximum number of iterations for the initialization of C the static nonlinearity. C This parameter is ignored if INIT is 'N' or 'L'. C Otherwise, ITMAX1 >= 0. C C ITMAX2 (input) INTEGER C The maximum number of iterations. ITMAX2 >= 0. C C NPRINT (input) INTEGER C This parameter enables controlled printing of iterates if C it is positive. In this case, FCN is called with IFLAG = 0 C at the beginning of the first iteration and every NPRINT C iterations thereafter and immediately prior to return, C and the current error norm is printed. Other intermediate C results could be printed by modifying the corresponding C FCN routine (NF01BA and/or NF01BB). If NPRINT <= 0, no C special calls of FCN with IFLAG = 0 are made. C C U (input) DOUBLE PRECISION array, dimension (LDU, M) C The leading NSMP-by-M part of this array must contain the C set of input samples, C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,NSMP). C C Y (input) DOUBLE PRECISION array, dimension (LDY, L) C The leading NSMP-by-L part of this array must contain the C set of output samples, C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). C C LDY INTEGER C The leading dimension of array Y. LDY >= MAX(1,NSMP). C C X (input/output) DOUBLE PRECISION array dimension (LX) C On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part C of this array must contain the initial parameters for C the nonlinear part of the system. C On entry, if INIT = 'S', the elements lin1 : lin2 of this C array must contain the initial parameters for the linear C part of the system, corresponding to the output normal C form, computed by SLICOT Library routine TB01VD, where C lin1 = (NN*(L+2) + 1)*L + 1; C lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M. C On entry, if INIT = 'N', the elements 1 : lin2 of this C array must contain the initial parameters for the C nonlinear part followed by the initial parameters for the C linear part of the system, as specified above. C This array need not be set on entry if INIT = 'B'. C On exit, the elements 1 : lin2 of this array contain the C optimal parameters for the nonlinear part followed by the C optimal parameters for the linear part of the system, as C specified above. C C LX (input/output) INTEGER C On entry, this parameter must contain the intended length C of X. If N >= 0, then LX >= NX := lin2 (see parameter X). C If N is unknown (N < 0 on entry), a large enough estimate C of N should be used in the formula of lin2. C On exit, if N < 0 on entry, but LX is not large enough, C then this parameter contains the actual length of X, C corresponding to the computed N. Otherwise, its value C is unchanged. C C Tolerances C C TOL1 DOUBLE PRECISION C If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance C which measures the relative error desired in the sum of C squares, for the initialization step of nonlinear part. C Termination occurs when the actual relative reduction in C the sum of squares is at most TOL1. In addition, if C ALG = 'I', TOL1 also measures the relative residual of C the solutions computed by the CG algorithm (for the C initialization step). Termination of a CG process occurs C when the relative residual is at most TOL1. C If the user sets TOL1 < 0, then SQRT(EPS) is used C instead TOL1, where EPS is the machine precision C (see LAPACK Library routine DLAMCH). C This parameter is ignored if INIT is 'N' or 'L'. C C TOL2 DOUBLE PRECISION C If TOL2 >= 0, TOL2 is the tolerance which measures the C relative error desired in the sum of squares, for the C whole optimization process. Termination occurs when the C actual relative reduction in the sum of squares is at C most TOL2. C If ALG = 'I', TOL2 also measures the relative residual of C the solutions computed by the CG algorithm (for the whole C optimization). Termination of a CG process occurs when the C relative residual is at most TOL2. C If the user sets TOL2 < 0, then SQRT(EPS) is used C instead TOL2. This default value could require many C iterations, especially if TOL1 is larger. If INIT = 'S' C or 'B', it is advisable that TOL2 be larger than TOL1, C and spend more time with cheaper iterations. C C Workspace C C IWORK INTEGER array, dimension (MAX( 3, LIW1, LIW2 )), where C LIW1 = LIW2 = 0, if INIT = 'S' or 'N'; otherwise, C LIW1 = M+L; C LIW2 = MAX(M*NOBR+N,M*(N+L)). C On output, if INFO = 0, IWORK(1) and IWORK(2) return the C (total) number of function and Jacobian evaluations, C respectively (including the initialization step, if it was C performed), and if INIT = 'L' or INIT = 'B', IWORK(3) C specifies how many locations of DWORK contain reciprocal C condition number estimates (see below); otherwise, C IWORK(3) = 0. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On entry, if desired, and if INIT = 'S' or 'B', the C entries DWORK(1:4) are set to initialize the random C numbers generator for the nonlinear part parameters (see C the description of the argument XINIT of SLICOT Library C routine MD03AD); this enables to obtain reproducible C results. The same seed is used for all outputs. C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK, DWORK(2) returns the residual error norm (the C sum of squares), DWORK(3) returns the number of iterations C performed, DWORK(4) returns the number of conjugate C gradients iterations performed, and DWORK(5) returns the C final Levenberg factor, for optimizing the parameters of C both the linear part and the static nonlinearity part. C If INIT = 'S' or INIT = 'B' and INFO = 0, then the C elements DWORK(6) to DWORK(10) contain the corresponding C five values for the initialization step (see METHOD). C (If L > 1, DWORK(10) contains the maximum of the Levenberg C factors for all outputs.) If INIT = 'L' or INIT = 'B', and C INFO = 0, DWORK(11) to DWORK(10+IWORK(3)) contain C reciprocal condition number estimates set by SLICOT C Library routines IB01AD, IB01BD, and IB01CD. C On exit, if INFO = -23, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C In the formulas below, N should be taken not larger than C NOBR - 1, if N < 0 on entry. C LDWORK = MAX( LW1, LW2, LW3, LW4 ), where C LW1 = 0, if INIT = 'S' or 'N'; otherwise, C LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR, C 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + C MAX( LDW1, LDW2 ), C (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) + C MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ), C where, C LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, C L*NOBR*N + C MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, C 2*(L*NOBR-L)*N+N*N+8*N, C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) C LDW2 >= 0, if M = 0; C LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) + C MAX( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; C LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ), C LDW4 = N*(N+1) + 2*N + C MAX( N*L*(N+1) + 2*N*N + L*N, 4*N ); C LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L; C LDW6 = NSMP*L + (N+L)*(N+M) + N + C MAX(1, N*N*L + N*L + N, N*N + C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), C N*M)); C LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise, C LW2 = NSMP*L + C MAX( 5, NSMP + 2*BSN + NSMP*BSN + C MAX( 2*NN + BSN, LDW7 ) ); C LDW7 = BSN*BSN, if ALG = 'D' and STOR = 'F'; C LDW7 = BSN*(BSN+1)/2, if ALG = 'D' and STOR = 'P'; C LDW7 = 3*BSN + NSMP, if ALG = 'I'; C LW3 = MAX( LDW8, NSMP*L + (N+L)*(2*N+M) + 2*N ); C LDW8 = NSMP*L + (N+L)*(N+M) + 3*N+M+L, if M > 0; C LDW8 = NSMP*L + (N+L)*N + 2*N+L, if M = 0; C LW4 = MAX( 5, NSMP*L + 2*NX + NSMP*L*( BSN + LTHS ) + C MAX( L1 + NX, NSMP*L + L1, L2 ) ), C L0 = MAX( N*(N+L), N+M+L ), if M > 0; C L0 = MAX( N*(N+L), L ), if M = 0; C L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0); C L2 = NX*NX, if ALG = 'D' and STOR = 'F'; C L2 = NX*(NX+1)/2, if ALG = 'D' and STOR = 'P'; C L2 = 3*NX + NSMP*L, if ALG = 'I', C with BSN = NN*( L + 2 ) + 1, C LTHS = N*( L + M + 1 ) + L*M. C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C < 0: the user set IFLAG = IWARN in (one of) the C subroutine(s) FCN, i.e., NF01BA, if INIT = 'S' C or 'B', and/or NF01BB; this value cannot be returned C without changing the FCN routine(s); C otherwise, IWARN has the value k*100 + j*10 + i, C where k is defined below, i refers to the whole C optimization process, and j refers to the C initialization step (j = 0, if INIT = 'L' or 'N'), C and the possible values for i and j have the C following meaning (where TOL* denotes TOL1 or TOL2, C and similarly for ITMAX*): C = 1: the number of iterations has reached ITMAX* without C satisfying the convergence condition; C = 2: if alg = 'I' and in an iteration of the Levenberg- C Marquardt algorithm, the CG algorithm finished C after 3*NX iterations (or 3*(lin1-1) iterations, for C the initialization phase), without achieving the C precision required in the call; C = 3: the cosine of the angle between the vector of error C function values and any column of the Jacobian is at C most FACTOR*EPS in absolute value (FACTOR = 100); C = 4: TOL* is too small: no further reduction in the sum C of squares is possible. C The digit k is normally 0, but if INIT = 'L' or 'B', it C can have a value in the range 1 to 6 (see IB01AD, IB01BD C and IB01CD). In all these cases, the entries DWORK(1:5), C DWORK(6:10) (if INIT = 'S' or 'B'), and C DWORK(11:10+IWORK(3)) (if INIT = 'L' or 'B'), are set as C described above. 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 otherwise, INFO has the value k*100 + j*10 + i, C where k is defined below, i refers to the whole C optimization process, and j refers to the C initialization step (j = 0, if INIT = 'L' or 'N'), C and the possible values for i and j have the C following meaning: C = 1: the routine FCN returned with INFO <> 0 for C IFLAG = 1; C = 2: the routine FCN returned with INFO <> 0 for C IFLAG = 2; C = 3: ALG = 'D' and SLICOT Library routines MB02XD or C NF01BU (or NF01BV, if INIT = 'S' or 'B') or C ALG = 'I' and SLICOT Library routines MB02WD or C NF01BW (or NF01BX, if INIT = 'S' or 'B') returned C with INFO <> 0. C In addition, if INIT = 'L' or 'B', i could also be C = 4: if a Lyapunov equation could not be solved; C = 5: if the identified linear system is unstable; C = 6: if the QR algorithm failed on the state matrix C of the identified linear system. C The digit k is normally 0, but if INIT = 'L' or 'B', it C can have a value in the range 1 to 10 (see IB01AD/IB01BD). C C METHOD C C If INIT = 'L' or 'B', the linear part of the system is C approximated using the combined MOESP and N4SID algorithm. If C necessary, this algorithm can also choose the order, but it is C advantageous if the order is already known. C C If INIT = 'S' or 'B', the output of the approximated linear part C is computed and used to calculate an approximation of the static C nonlinearity using the Levenberg-Marquardt algorithm [1]. C This step is referred to as the (nonlinear) initialization step. C C As last step, the Levenberg-Marquardt algorithm is used again to C optimize the parameters of the linear part and the static C nonlinearity as a whole. Therefore, it is necessary to parametrise C the matrices of the linear part. The output normal form [2] C parameterisation is used. C C The Jacobian is computed analytically, for the nonlinear part, and C numerically, for the linear part. C C REFERENCES C C [1] Kelley, C.T. C Iterative Methods for Optimization. C Society for Industrial and Applied Mathematics (SIAM), C Philadelphia (Pa.), 1999. C C [2] Peeters, R.L.M., Hanzon, B., and Olivi, M. C Balanced realizations of discrete-time stable all-pass C systems and the tangential Schur algorithm. C Proceedings of the European Control Conference, C 31 August - 3 September 1999, Karlsruhe, Germany. C Session CP-6, Discrete-time Systems, 1999. C C CONTRIBUTORS C C A. Riedel, R. Schneider, Chemnitz University of Technology, C Oct. 2000, during a stay at University of Twente, NL. C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, C Mar. 2002, Apr. 2002, Feb. 2004, March 2005, Nov. 2005. C C KEYWORDS C C Conjugate gradients, least-squares approximation, C Levenberg-Marquardt algorithm, matrix operations, optimization. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C The upper triangular part is used in MD03AD; CHARACTER UPLO PARAMETER ( UPLO = 'U' ) C For INIT = 'L' or 'B', additional parameters are set: C The following six parameters are used in the call of IB01AD; CHARACTER IALG, BATCH, CONCT, CTRL, JOBD, METH PARAMETER ( IALG = 'Fast QR', BATCH = 'One batch', $ CONCT = 'Not connect', CTRL = 'Not confirm', $ JOBD = 'Not MOESP', METH = 'MOESP' ) C The following three parameters are used in the call of IB01BD; CHARACTER JOB, JOBCK, METHB PARAMETER ( JOB = 'All matrices', $ JOBCK = 'No Kalman gain', $ METHB = 'Combined MOESP+N4SID' ) C The following two parameters are used in the call of IB01CD; CHARACTER COMUSE, JOBXD PARAMETER ( COMUSE = 'Use B, D', $ JOBXD = 'D also' ) C TOLN controls the estimated order in IB01AD (default value); DOUBLE PRECISION TOLN PARAMETER ( TOLN = -1.0D0 ) C RCOND controls the rank decisions in IB01AD, IB01BD, and IB01CD C (default); DOUBLE PRECISION RCOND PARAMETER ( RCOND = -1.0D0 ) C .. Scalar Arguments .. CHARACTER ALG, INIT, STOR INTEGER INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK, $ LDY, LX, M, N, NN, NOBR, NPRINT, NSMP DOUBLE PRECISION TOL1, TOL2 C .. Array Arguments .. DOUBLE PRECISION DWORK(*), U(LDU, *), X(*), Y(LDY, *) INTEGER IWORK(*) C .. Local Scalars .. INTEGER AC, BD, BSN, I, IA, IB, IK, INFOL, IQ, IR, $ IRCND, IRCNDB, IRY, IS, ISAD, ISV, IV, IW1, IW2, $ IWARNL, IX, IX0, J, JWORK, LDAC, LDR, LIPAR, $ LNOL, LTHS, ML, MNO, N2, NFEV, NJEV, NS, NSML, $ NTHS, NX, WRKOPT, Z LOGICAL CHOL, FULL, INIT1, INIT2 C .. Local Arrays .. LOGICAL BWORK(1) INTEGER IPAR(7) DOUBLE PRECISION RCND(16), SEED(4), WORK(5) C .. External Functions .. EXTERNAL LSAME LOGICAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, IB01AD, IB01BD, IB01CD, MD03AD, NF01BA, $ NF01BB, NF01BU, NF01BV, NF01BW, NF01BX, TB01VD, $ TB01VY, TF01MX, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. C .. Executable Statements .. C CHOL = LSAME( ALG, 'D' ) FULL = LSAME( STOR, 'F' ) INIT1 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'L' ) INIT2 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'S' ) C ML = M + L INFO = 0 IWARN = 0 IF ( .NOT.( INIT1 .OR. INIT2 .OR. LSAME( INIT, 'N' ) ) ) THEN INFO = -1 ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG, 'I' ) ) ) THEN INFO = -2 ELSEIF ( CHOL .AND. .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN INFO = -3 ELSEIF ( INIT1 .AND. NOBR.LE.0 ) THEN INFO = -4 ELSEIF ( M.LT.0 ) THEN INFO = -5 ELSEIF ( L.LT.0 .OR. ( INIT1 .AND. L.EQ.0 ) ) THEN INFO = -6 ELSEIF ( NSMP.LT.0 .OR. $ ( INIT1 .AND. NSMP.LT.2*( ML + 1 )*NOBR - 1 ) ) THEN INFO = -7 ELSEIF ( ( N.LT.0 .AND. .NOT.INIT1 ) .OR. $ ( ( N.EQ.0 .OR. N.GE.NOBR ) .AND. INIT1 ) ) THEN INFO = -8 ELSEIF ( NN.LT.0 ) THEN INFO = -9 ELSEIF ( INIT2 .AND. ( ITMAX1.LT.0 ) ) THEN INFO = -10 ELSEIF ( ITMAX2.LT.0 ) THEN INFO = -11 ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN INFO = -14 ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN INFO = -16 ELSE LNOL = L*NOBR - L MNO = M*NOBR BSN = NN*( L + 2 ) + 1 NTHS = BSN*L NSML = NSMP*L IF ( N.GT.0 ) THEN LDAC = N + L ISAD = LDAC*( N + M ) N2 = N*N END IF C C Check the workspace size. C JWORK = 0 IF ( INIT1 ) THEN C Workspace for IB01AD. JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR IF ( N.GT.0 ) THEN C Workspace for IB01BD. IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + $ 1, MNO + 3*N + L ) ) IF ( M.GT.0 ) THEN IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + $ MAX( LDAC**2, 4*M*LDAC + 1 ) ELSE IW2 = 0 END IF JWORK = MAX( JWORK, $ ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) ) C Workspace for IB01CD. IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) IW2 = N*( N + 1 ) + 2*N + $ MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N ) JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) C Workspace for TF01MX. JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) C Workspace for TB01VD. JWORK = MAX( JWORK, NSML + ISAD + N + $ MAX( 1, N2*L + N*L + N, $ N2 + MAX( N2 + N*MAX( N, L ) + $ 6*N + MIN( N, L ), N*M ) ) ) END IF END IF C IF ( INIT2 ) THEN C Workspace for MD03AD (initialization of the nonlinear part). IF ( CHOL ) THEN IF ( FULL ) THEN IW1 = BSN**2 ELSE IW1 = ( BSN*( BSN + 1 ) )/2 END IF ELSE IW1 = 3*BSN + NSMP END IF JWORK = MAX( JWORK, NSML + $ MAX( 5, NSMP + 2*BSN + NSMP*BSN + $ MAX( 2*NN + BSN, IW1 ) ) ) IF ( N.GT.0 .AND. .NOT.INIT1 ) THEN C Workspace for TB01VY. JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N ) C Workspace for TF01MX. IF ( M.GT.0 ) THEN IW1 = N + M ELSE IW1 = 0 END IF JWORK = MAX( JWORK, NSML + ISAD + IW1 + LDAC + N ) END IF END IF C IF ( N.GE.0 ) THEN C C Find the number of parameters. C LTHS = N*( ML + 1 ) + L*M NX = NTHS + LTHS C IF ( LX.LT.NX ) THEN INFO = -18 CALL XERBLA( 'IB03AD', -INFO ) RETURN END IF C C Workspace for MD03AD (whole optimization). C IF ( M.GT.0 ) THEN IW1 = LDAC + M ELSE IW1 = L END IF IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) IF ( CHOL ) THEN IF ( FULL ) THEN IW2 = NX**2 ELSE IW2 = ( NX*( NX + 1 ) )/2 END IF ELSE IW2 = 3*NX + NSML END IF JWORK = MAX( JWORK, $ 5, NSML + 2*NX + NSML*( BSN + LTHS ) + $ MAX( IW1 + NX, NSML + IW1, IW2 ) ) END IF C IF ( LDWORK.LT.JWORK ) THEN INFO = -23 DWORK(1) = JWORK END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB03AD', -INFO ) RETURN ENDIF C C Initialize the pointers to system matrices and save the possible C seed for random numbers generation. C Z = 1 AC = Z + NSML CALL DCOPY( 4, DWORK, 1, SEED, 1 ) C WRKOPT = 1 C IF ( INIT1 ) THEN C C Initialize the linear part. C If N < 0, the order of the system is determined by IB01AD; C otherwise, the given order will be used. C The workspace needed is defined for the options set above C in the PARAMETER statements. C Workspace: need: 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR; C prefer: larger. C Integer workspace: M+L. (If METH = 'N', (M+L)*NOBR.) C NS = N IR = 1 ISV = 2*ML*NOBR LDR = ISV IF ( LSAME( JOBD, 'M' ) ) $ LDR = MAX( LDR, 3*MNO ) ISV = IR + LDR*ISV JWORK = ISV + L*NOBR C CALL IB01AD( METH, IALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L, $ NSMP, U, LDU, Y, LDY, N, DWORK(IR), LDR, $ DWORK(ISV), RCOND, TOLN, IWORK, DWORK(JWORK), $ LDWORK-JWORK+1, IWARNL, INFOL ) C IF( INFOL.NE.0 ) THEN INFO = 100*INFOL RETURN END IF IF( IWARNL.NE.0 ) $ IWARN = 100*IWARNL WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) IRCND = 0 IF ( LSAME( METH, 'N' ) ) THEN IRCND = 2 CALL DCOPY( IRCND, DWORK(JWORK+1), 1, RCND, 1 ) END IF C IF ( NS.GE.0 ) THEN N = NS ELSE C C Find the number of parameters. C LDAC = N + L ISAD = LDAC*( N + M ) N2 = N*N LTHS = N*( ML + 1 ) + L*M NX = NTHS + LTHS C IF ( LX.LT.NX ) THEN LX = NX INFO = -18 CALL XERBLA( 'IB03AD', -INFO ) RETURN END IF C Workspace for IB01BD. IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + 1, $ MNO + 3*N + L ) ) IF ( M.GT.0 ) THEN IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + $ MAX( LDAC**2, 4*M*LDAC + 1 ) ELSE IW2 = 0 END IF JWORK = ISV + ISAD + MAX( IW1, IW2 ) C Workspace for IB01CD. IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) IW2 = N*( N + 1 ) + 2*N + MAX( N*L*( N + 1 ) + 2*N2 + L*N, $ 4*N ) JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) C Workspace for TF01MX. JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) C Workspace for TB01VD. JWORK = MAX( JWORK, NSML + ISAD + N + $ MAX( 1, N2*L + N*L + N, $ N2 + MAX( N2 + N*MAX( N, L ) + $ 6*N + MIN( N, L ), N*M ) ) ) C Workspace for MD03AD (whole optimization). IF ( M.GT.0 ) THEN IW1 = LDAC + M ELSE IW1 = L END IF IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) IF ( CHOL ) THEN IF ( FULL ) THEN IW2 = NX**2 ELSE IW2 = ( NX*( NX + 1 ) )/2 END IF ELSE IW2 = 3*NX + NSML END IF JWORK = MAX( JWORK, $ 5, NSML + 2*NX + NSML*( BSN + LTHS ) + $ MAX( IW1 + NX, NSML + IW1, IW2 ) ) IF ( LDWORK.LT.JWORK ) THEN INFO = -23 DWORK(1) = JWORK CALL XERBLA( 'IB03AD', -INFO ) RETURN END IF END IF C BD = AC + LDAC*N IX = BD + LDAC*M IA = ISV IB = IA + LDAC*N IQ = IB + LDAC*M IF ( LSAME( JOBCK, 'N' ) ) THEN IRY = IQ IS = IQ IK = IQ JWORK = IQ ELSE IRY = IQ + N2 IS = IRY + L*L IK = IS + N*L JWORK = IK + N*L END IF C C The workspace needed is defined for the options set above C in the PARAMETER statements. C Workspace: C need: 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + C max( LDW1,LDW2 ), where, C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, C L*NOBR*N + C max( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, C 2*(L*NOBR-L)*N+N*N+8*N, C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) C LDW2 >= 0, if M = 0; C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ C max( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; C prefer: larger. C Integer workspace: MAX(M*NOBR+N,M*(N+L)). C CALL IB01BD( METHB, JOB, JOBCK, NOBR, N, M, L, NSMP, DWORK(IR), $ LDR, DWORK(IA), LDAC, DWORK(IA+N), LDAC, $ DWORK(IB), LDAC, DWORK(IB+N), LDAC, DWORK(IQ), N, $ DWORK(IRY), L, DWORK(IS), N, DWORK(IK), N, RCOND, $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, BWORK, $ IWARNL, INFOL ) C IF( INFOL.EQ.-30 ) THEN INFO = -23 DWORK(1) = DWORK(JWORK) CALL XERBLA( 'IB03AD', -INFO ) RETURN END IF IF( INFOL.NE.0 ) THEN INFO = 100*INFOL RETURN END IF IF( IWARNL.NE.0 ) $ IWARN = 100*IWARNL WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) IRCNDB = 4 IF ( LSAME( JOBCK, 'K' ) ) $ IRCNDB = IRCNDB + 8 CALL DCOPY( IRCNDB, DWORK(JWORK+1), 1, RCND(IRCND+1), 1 ) IRCND = IRCND + IRCNDB C C Copy the system matrices to the beginning of DWORK, to save C space, and redefine the pointers. C CALL DCOPY( ISAD, DWORK(IA), 1, DWORK, 1 ) IA = 1 IB = IA + LDAC*N IX0 = IB + LDAC*M IV = IX0 + N C C Compute the initial condition of the system. On normal exit, C DWORK(i), i = JWORK+2:JWORK+1+N*N, C DWORK(j), j = JWORK+2+N*N:JWORK+1+N*N+L*N, and C DWORK(k), k = JWORK+2+N*N+L*N:JWORK+1+N*N+L*N+N*M, C contain the transformed system matrices At, Ct, and Bt, C respectively, corresponding to the real Schur form of the C estimated system state matrix A. The transformation matrix is C stored in DWORK(IV:IV+N*N-1). C The workspace needed is defined for the options set above C in the PARAMETER statements. C Workspace: C need: (N+L)*(N+M) + N + N*N + 2 + N*( N + M + L ) + C max( 5*N, 2, min( LDW1, LDW2 ) ), where, C LDW1 = NSMP*L*(N + 1) + 2*N + max( 2*N*N, 4*N), C LDW2 = N*(N + 1) + 2*N + C max( N*L*(N + 1) + 2*N*N + L*N, 4*N); C prefer: larger. C Integer workspace: N. C JWORK = IV + N2 CALL IB01CD( 'X needed', COMUSE, JOBXD, N, M, L, NSMP, $ DWORK(IA), LDAC, DWORK(IB), LDAC, DWORK(IA+N), $ LDAC, DWORK(IB+N), LDAC, U, LDU, Y, LDY, $ DWORK(IX0), DWORK(IV), N, RCOND, IWORK, $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFOL ) C IF( INFOL.EQ.-26 ) THEN INFO = -23 DWORK(1) = DWORK(JWORK) CALL XERBLA( 'IB03AD', -INFO ) RETURN END IF IF( INFOL.EQ.1 ) $ INFOL = 10 IF( INFOL.NE.0 ) THEN INFO = 100*INFOL RETURN END IF IF( IWARNL.NE.0 ) $ IWARN = 100*IWARNL WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) IRCND = IRCND + 1 RCND(IRCND) = DWORK(JWORK+1) C C Now, save the system matrices and x0 in the final location. C IF ( IV.LT.AC ) THEN CALL DCOPY( ISAD+N, DWORK(IA), 1, DWORK(AC), 1 ) ELSE DO 5 J = AC + ISAD + N - 1, AC, -1 DWORK(J) = DWORK(IA+J-AC) 5 CONTINUE END IF C C Compute the output of the linear part. C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, C if M > 0; C NSMP*L + (N + L)*N + 2*N + L, if M = 0; C prefer larger. C JWORK = IX + N CALL DCOPY( N, DWORK(IX), 1, X(NTHS+1), 1 ) CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, X(NTHS+1), $ DWORK(Z), NSMP, DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) C C Convert the state-space representation to output normal form. C Workspace: C need: NSMP*L + (N + L)*(N + M) + N + C MAX(1, N*N*L + N*L + N, N*N + C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), N*M)); C prefer: larger. C CALL TB01VD( 'Apply', N, M, L, DWORK(AC), LDAC, DWORK(BD), $ LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), LDAC, $ DWORK(IX), X(NTHS+1), LTHS, DWORK(JWORK), $ LDWORK-JWORK+1, INFOL ) C IF( INFOL.GT.0 ) THEN INFO = INFOL + 3 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C END IF C LIPAR = 7 IW1 = 0 IW2 = 0 C IF ( INIT2 ) THEN C C Initialize the nonlinear part. C IF ( .NOT.INIT1 ) THEN BD = AC + LDAC*N IX = BD + LDAC*M C C Convert the output normal form to state-space model. C Workspace: need NSMP*L + (N + L)*(2*N + M) + 2*N. C (NSMP*L locations are reserved for the output of the linear C part.) C JWORK = IX + N CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), $ LDAC, DWORK(BD), LDAC, DWORK(AC+N), LDAC, $ DWORK(BD+N), LDAC, DWORK(IX), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) C C Compute the output of the linear part. C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, C if M > 0; C NSMP*L + (N + L)*N + 2*N + L, if M = 0; C prefer larger. C CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, $ DWORK(IX), DWORK(Z), NSMP, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) END IF C C Optimize the parameters of the nonlinear part. C Workspace: C need NSMP*L + C MAX( 5, NSMP + 2*BSN + NSMP*BSN + C MAX( 2*NN + BSN, DW( sol ) ) ), C where, if ALG = 'D', C DW( sol ) = BSN*BSN, if STOR = 'F'; C DW( sol ) = BSN*(BSN+1)/2, if STOR = 'P'; C and DW( sol ) = 3*BSN + NSMP, if ALG = 'I'; C prefer larger. C JWORK = AC WORK(1) = ZERO CALL DCOPY( 4, WORK(1), 0, WORK(2), 1 ) C C Set the integer parameters needed, including the number of C neurons. C IPAR(1) = NSMP IPAR(2) = L IPAR(3) = NN C DO 10 I = 0, L - 1 CALL DCOPY( 4, SEED, 1, DWORK(JWORK), 1 ) IF ( CHOL ) THEN CALL MD03AD( 'Random initialization', ALG, STOR, UPLO, $ NF01BA, NF01BV, NSMP, BSN, ITMAX1, NPRINT, $ IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY, $ X(I*BSN+1), NFEV, NJEV, TOL1, TOL1, $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, $ INFOL ) ELSE CALL MD03AD( 'Random initialization', ALG, STOR, UPLO, $ NF01BA, NF01BX, NSMP, BSN, ITMAX1, NPRINT, $ IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY, $ X(I*BSN+1), NFEV, NJEV, TOL1, TOL1, $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, $ INFOL ) END IF C IF( INFOL.NE.0 ) THEN INFO = 10*INFOL RETURN END IF IF ( IWARNL.LT.0 ) THEN INFO = INFOL IWARN = IWARNL GO TO 20 ELSEIF ( IWARNL.GT.0 ) THEN IF ( IWARN.GT.100 ) THEN IWARN = MAX( IWARN, ( IWARN/100 )*100 + 10*IWARNL ) ELSE IWARN = MAX( IWARN, 10*IWARNL ) END IF END IF WORK(1) = MAX( WORK(1), DWORK(JWORK) ) WORK(2) = MAX( WORK(2), DWORK(JWORK+1) ) WORK(5) = MAX( WORK(5), DWORK(JWORK+4) ) WORK(3) = WORK(3) + DWORK(JWORK+2) WORK(4) = WORK(4) + DWORK(JWORK+3) IW1 = NFEV + IW1 IW2 = NJEV + IW2 10 CONTINUE C ENDIF C C Main iteration. C Workspace: need MAX( 5, NFUN + 2*NX + NFUN*( BSN + LTHS ) + C MAX( LDW1 + NX, NFUN + LDW1, DW( sol ) ) ), C where NFUN = NSMP*L, and C LDW1 = NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + C MAX( N*(N + L), N + M + L )), C if M > 0, C LDW1 = NFUN + MAX( 2*NN, (N + L)*N + 2*N + C MAX( N*(N + L), L ) ), C if M = 0; C if ALG = 'D', C DW( sol ) = NX*NX, if STOR = 'F'; C DW( sol ) = NX*(NX+1)/2, if STOR = 'P'; C and DW( sol ) = 3*NX + NFUN, if ALG = 'I', C and DW( f ) is the workspace needed by the C subroutine f; C prefer larger. C C Set the integer parameters describing the Jacobian structure C and the number of neurons. C IPAR(1) = LTHS IPAR(2) = L IPAR(3) = NSMP IPAR(4) = BSN IPAR(5) = M IPAR(6) = N IPAR(7) = NN C IF ( CHOL ) THEN CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB, $ NF01BU, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR, $ U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2, $ DWORK, LDWORK, IWARNL, INFO ) ELSE CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB, $ NF01BW, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR, $ U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2, $ DWORK, LDWORK, IWARNL, INFO ) END IF C IF( INFO.NE.0 ) $ RETURN C 20 CONTINUE IWORK(1) = IW1 + NFEV IWORK(2) = IW2 + NJEV IF ( IWARNL.LT.0 ) THEN IWARN = IWARNL ELSE IWARN = IWARN + IWARNL END IF IF ( INIT2 ) $ CALL DCOPY( 5, WORK, 1, DWORK(6), 1 ) IF ( INIT1 ) THEN IWORK(3) = IRCND CALL DCOPY( IRCND, RCND, 1, DWORK(11), 1 ) ELSE IWORK(3) = 0 END IF RETURN C C *** Last line of IB03AD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10MD.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10MD.f0000644000175000017500000005603015012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE SB10MD( NC, MP, LENDAT, F, ORD, MNB, NBLOCK, ITYPE, $ QUTOL, A, LDA, B, LDB, C, LDC, D, LDD, OMEGA, $ TOTORD, AD, LDAD, BD, LDBD, CD, LDCD, DD, LDDD, $ MJU, IWORK, LIWORK, DWORK, LDWORK, ZWORK, $ LZWORK, INFO ) C C PURPOSE C C To perform the D-step in the D-K iteration. It handles C continuous-time case. C C ARGUMENTS C C Input/Output Parameters C C NC (input) INTEGER C The order of the matrix A. NC >= 0. C C MP (input) INTEGER C The order of the matrix D. MP >= 0. C C LENDAT (input) INTEGER C The length of the vector OMEGA. LENDAT >= 2. C C F (input) INTEGER C The number of the measurements and controls, i.e., C the size of the block I_f in the D-scaling system. C F >= 0. C C ORD (input/output) INTEGER C The MAX order of EACH block in the fitting procedure. C ORD <= LENDAT-1. C On exit, if ORD < 1 then ORD = 1. C C MNB (input) INTEGER C The number of diagonal blocks in the block structure of C the uncertainty, and the length of the vectors NBLOCK C and ITYPE. 1 <= MNB <= MP. C C NBLOCK (input) INTEGER array, dimension (MNB) C The vector of length MNB containing the block structure C of the uncertainty. NBLOCK(I), I = 1:MNB, is the size of C each block. C C ITYPE (input) INTEGER array, dimension (MNB) C The vector of length MNB indicating the type of each C block. C For I = 1 : MNB, C ITYPE(I) = 1 indicates that the corresponding block is a C real block. IN THIS CASE ONLY MJU(JW) WILL BE ESTIMATED C CORRECTLY, BUT NOT D(S)! C ITYPE(I) = 2 indicates that the corresponding block is a C complex block. THIS IS THE ONLY ALLOWED VALUE NOW! C NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1. C C QUTOL (input) DOUBLE PRECISION C The acceptable mean relative error between the D(jw) and C the frequency responce of the estimated block C [ADi,BDi;CDi,DDi]. When it is reached, the result is C taken as good enough. C A good value is QUTOL = 2.0. C If QUTOL < 0 then only mju(jw) is being estimated, C not D(s). C C A (input/output) DOUBLE PRECISION array, dimension (LDA,NC) C On entry, the leading NC-by-NC part of this array must C contain the A matrix of the closed-loop system. C On exit, if MP > 0, the leading NC-by-NC part of this C array contains an upper Hessenberg matrix similar to A. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,NC). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,MP) C On entry, the leading NC-by-MP part of this array must C contain the B matrix of the closed-loop system. C On exit, the leading NC-by-MP part of this array contains C the transformed B matrix corresponding to the Hessenberg C form of A. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,NC). C C C (input/output) DOUBLE PRECISION array, dimension (LDC,NC) C On entry, the leading MP-by-NC part of this array must C contain the C matrix of the closed-loop system. C On exit, the leading MP-by-NC part of this array contains C the transformed C matrix corresponding to the Hessenberg C form of A. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,MP). C C D (input) DOUBLE PRECISION array, dimension (LDD,MP) C The leading MP-by-MP part of this array must contain the C D matrix of the closed-loop system. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1,MP). C C OMEGA (input) DOUBLE PRECISION array, dimension (LENDAT) C The vector with the frequencies. C C TOTORD (output) INTEGER C The TOTAL order of the D-scaling system. C TOTORD is set to zero, if QUTOL < 0. C C AD (output) DOUBLE PRECISION array, dimension (LDAD,MP*ORD) C The leading TOTORD-by-TOTORD part of this array contains C the A matrix of the D-scaling system. C Not referenced if QUTOL < 0. C C LDAD INTEGER C The leading dimension of the array AD. C LDAD >= MAX(1,MP*ORD), if QUTOL >= 0; C LDAD >= 1, if QUTOL < 0. C C BD (output) DOUBLE PRECISION array, dimension (LDBD,MP+F) C The leading TOTORD-by-(MP+F) part of this array contains C the B matrix of the D-scaling system. C Not referenced if QUTOL < 0. C C LDBD INTEGER C The leading dimension of the array BD. C LDBD >= MAX(1,MP*ORD), if QUTOL >= 0; C LDBD >= 1, if QUTOL < 0. C C CD (output) DOUBLE PRECISION array, dimension (LDCD,MP*ORD) C The leading (MP+F)-by-TOTORD part of this array contains C the C matrix of the D-scaling system. C Not referenced if QUTOL < 0. C C LDCD INTEGER C The leading dimension of the array CD. C LDCD >= MAX(1,MP+F), if QUTOL >= 0; C LDCD >= 1, if QUTOL < 0. C C DD (output) DOUBLE PRECISION array, dimension (LDDD,MP+F) C The leading (MP+F)-by-(MP+F) part of this array contains C the D matrix of the D-scaling system. C Not referenced if QUTOL < 0. C C LDDD INTEGER C The leading dimension of the array DD. C LDDD >= MAX(1,MP+F), if QUTOL >= 0; C LDDD >= 1, if QUTOL < 0. C C MJU (output) DOUBLE PRECISION array, dimension (LENDAT) C The vector with the upper bound of the structured C singular value (mju) for each frequency in OMEGA. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The length of the array IWORK. C LIWORK >= MAX( NC, 4*MNB-2, MP, 2*ORD+1 ), if QUTOL >= 0; C LIWORK >= MAX( NC, 4*MNB-2, MP ), if QUTOL < 0. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK, DWORK(2) returns the optimal value of LZWORK, C and DWORK(3) returns an estimate of the minimum reciprocal C of the condition numbers (with respect to inversion) of C the generated Hessenberg matrices. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( 3, LWM, LWD ), where C LWM = LWA + MAX( NC + MAX( NC, MP-1 ), C 2*MP*MP*MNB - MP*MP + 9*MNB*MNB + C MP*MNB + 11*MP + 33*MNB - 11 ); C LWD = LWB + MAX( 2, LW1, LW2, LW3, LW4, 2*ORD ), C if QUTOL >= 0; C LWD = 0, if QUTOL < 0; C LWA = MP*LENDAT + 2*MNB + MP - 1; C LWB = LENDAT*(MP + 2) + ORD*(ORD + 2) + 1; C LW1 = 2*LENDAT + 4*HNPTS; HNPTS = 2048; C LW2 = LENDAT + 6*HNPTS; MN = MIN( 2*LENDAT, 2*ORD+1 ); C LW3 = 2*LENDAT*(2*ORD + 1) + MAX( 2*LENDAT, 2*ORD + 1 ) + C MAX( MN + 6*ORD + 4, 2*MN + 1 ); C LW4 = MAX( ORD*ORD + 5*ORD, 6*ORD + 1 + MIN( 1, ORD ) ). C C ZWORK COMPLEX*16 array, dimension (LZWORK) C C LZWORK INTEGER C The length of the array ZWORK. C LZWORK >= MAX( LZM, LZD ), where C LZM = MAX( MP*MP + NC*MP + NC*NC + 2*NC, C 6*MP*MP*MNB + 13*MP*MP + 6*MNB + 6*MP - 3 ); C LZD = MAX( LENDAT*(2*ORD + 3), ORD*ORD + 3*ORD + 1 ), C if QUTOL >= 0; C LZD = 0, if QUTOL < 0. C C Error indicator C C INFO (output) INTEGER C = 0: successful exit; C < 0: if INFO = -i, the i-th argument had an illegal C value; C = 1: if one or more values w in OMEGA are (close to C some) poles of the closed-loop system, i.e., the C matrix jw*I - A is (numerically) singular; C = 2: the block sizes must be positive integers; C = 3: the sum of block sizes must be equal to MP; C = 4: the size of a real block must be equal to 1; C = 5: the block type must be either 1 or 2; C = 6: errors in solving linear equations or in matrix C inversion; C = 7: errors in computing eigenvalues or singular values. C = 1i: INFO on exit from SB10YD is i. (1i means 10 + i.) C C METHOD C C I. First, W(jw) for the given closed-loop system is being C estimated. C II. Now, AB13MD SLICOT subroutine can obtain the D(jw) scaling C system with respect to NBLOCK and ITYPE, and colaterally, C mju(jw). C If QUTOL < 0 then the estimations stop and the routine exits. C III. Now that we have D(jw), SB10YD subroutine can do block-by- C block fit. For each block it tries with an increasing order C of the fit, starting with 1 until the C (mean quadratic error + max quadratic error)/2 C between the Dii(jw) and the estimated frequency responce C of the block becomes less than or equal to the routine C argument QUTOL, or the order becomes equal to ORD. C IV. Arrange the obtained blocks in the AD, BD, CD and DD C matrices and estimate the total order of D(s), TOTORD. C V. Add the system I_f to the system obtained in IV. C C REFERENCES C C [1] Balas, G., Doyle, J., Glover, K., Packard, A. and Smith, R. C Mu-analysis and Synthesis toolbox - User's Guide, C The Mathworks Inc., Natick, MA, USA, 1998. C C CONTRIBUTORS C C Asparuh Markovski, Technical University of Sofia, July 2003. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. C A. Markovski, V. Sima, October 2003. C C KEYWORDS C C Frequency response, H-infinity optimal control, robust control, C structured singular value. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, $ THREE = 3.0D+0 ) INTEGER HNPTS PARAMETER ( HNPTS = 2048 ) C .. C .. Scalar Arguments .. INTEGER F, INFO, LDA, LDAD, LDB, LDBD, LDC, LDCD, LDD, $ LDDD, LDWORK, LENDAT, LIWORK, LZWORK, MNB, MP, $ NC, ORD, TOTORD DOUBLE PRECISION QUTOL C .. C .. Array Arguments .. INTEGER ITYPE(*), IWORK(*), NBLOCK(*) DOUBLE PRECISION A(LDA, *), AD(LDAD, *), B(LDB, *), BD(LDBD, *), $ C(LDC, *), CD(LDCD, *), D(LDD, *), DD(LDDD, *), $ DWORK(*), MJU(*), OMEGA(*) COMPLEX*16 ZWORK(*) C .. C .. Local Scalars .. CHARACTER BALEIG, INITA INTEGER CLWMAX, CORD, DLWMAX, I, IC, ICWRK, IDWRK, II, $ INFO2, IWAD, IWB, IWBD, IWCD, IWDD, IWGJOM, $ IWIFRD, IWRFRD, IWX, K, LCSIZE, LDSIZE, LORD, $ LW1, LW2, LW3, LW4, LWA, LWB, MAXCWR, MAXWRK, $ MN, W DOUBLE PRECISION MAQE, MEQE, MOD1, MOD2, RCND, RCOND, RQE, TOL, $ TOLER COMPLEX*16 FREQ C .. C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. C .. External Subroutines .. EXTERNAL AB13MD, DCOPY, DLACPY, DLASET, DSCAL, SB10YD, $ TB05AD, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DCMPLX, INT, MAX, MIN, SQRT C C Decode and test input parameters. C C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ C Workspace usage 1. C C real C IWX = 1 + MP*LENDAT IWGJOM = IWX + 2*MNB - 1 IDWRK = IWGJOM + MP LDSIZE = LDWORK - IDWRK + 1 C C complex C IWB = MP*MP + 1 ICWRK = IWB + NC*MP LCSIZE = LZWORK - ICWRK + 1 C INFO = 0 IF ( NC.LT.0 ) THEN INFO = -1 ELSE IF( MP.LT.0 ) THEN INFO = -2 ELSE IF( LENDAT.LT.2 ) THEN INFO = -3 ELSE IF( F.LT.0 ) THEN INFO = -4 ELSE IF( ORD.GT.LENDAT - 1 ) THEN INFO = -5 ELSE IF( MNB.LT.1 .OR. MNB.GT.MP ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, NC ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, NC ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, MP ) ) THEN INFO = -15 ELSE IF( LDD.LT.MAX( 1, MP ) ) THEN INFO = -17 ELSE IF( LDAD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDAD.LT.MP*ORD ) ) $ THEN INFO = -21 ELSE IF( LDBD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDBD.LT.MP*ORD ) ) $ THEN INFO = -23 ELSE IF( LDCD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDCD.LT.MP + F ) ) $ THEN INFO = -25 ELSE IF( LDDD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDDD.LT.MP + F ) ) $ THEN INFO = -27 ELSE C C Compute workspace. C II = MAX( NC, 4*MNB - 2, MP ) MN = MIN( 2*LENDAT, 2*ORD + 1 ) LWA = IDWRK - 1 LWB = LENDAT*( MP + 2 ) + ORD*( ORD + 2 ) + 1 LW1 = 2*LENDAT + 4*HNPTS LW2 = LENDAT + 6*HNPTS LW3 = 2*LENDAT*( 2*ORD + 1 ) + MAX( 2*LENDAT, 2*ORD + 1 ) + $ MAX( MN + 6*ORD + 4, 2*MN + 1 ) LW4 = MAX( ORD*ORD + 5*ORD, 6*ORD + 1 + MIN( 1, ORD ) ) C DLWMAX = LWA + MAX( NC + MAX( NC, MP - 1 ), $ 2*MP*MP*MNB - MP*MP + 9*MNB*MNB + MP*MNB + $ 11*MP + 33*MNB - 11 ) C CLWMAX = MAX( ICWRK - 1 + NC*NC + 2*NC, $ 6*MP*MP*MNB + 13*MP*MP + 6*MNB + 6*MP - 3 ) C IF ( QUTOL.GE.ZERO ) THEN II = MAX( II, 2*ORD + 1 ) DLWMAX = MAX( DLWMAX, $ LWB + MAX( 2, LW1, LW2, LW3, LW4, 2*ORD ) ) CLWMAX = MAX( CLWMAX, LENDAT*( 2*ORD + 3 ), $ ORD*( ORD + 3 ) + 1 ) END IF IF ( LIWORK.LT.II ) THEN INFO = -30 ELSE IF ( LDWORK.LT.MAX( 3, DLWMAX ) ) THEN INFO = -32 ELSE IF ( LZWORK.LT.CLWMAX ) THEN INFO = -34 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB10MD', -INFO ) RETURN END IF C ORD = MAX( 1, ORD ) TOTORD = 0 C C Quick return if possible. C IF( NC.EQ.0 .OR. MP.EQ.0 ) THEN DWORK(1) = THREE DWORK(2) = ZERO DWORK(3) = ONE RETURN END IF C TOLER = SQRT( DLAMCH( 'Epsilon' ) ) C BALEIG = 'C' RCOND = ONE MAXCWR = CLWMAX C C @@@ 1. Estimate W(jw) for the closed-loop system, @@@ C @@@ D(jw) and mju(jw) for each frequency. @@@ C DO 30 W = 1, LENDAT FREQ = DCMPLX( ZERO, OMEGA(W) ) IF ( W.EQ.1 ) THEN INITA = 'G' ELSE INITA = 'H' END IF C C Compute C*inv(jw*I-A)*B. C Integer workspace: need NC. C Real workspace: need LWA + NC + MAX(NC,MP-1); C prefer larger, C where LWA = MP*LENDAT + 2*MNB + MP - 1. C Complex workspace: need MP*MP + NC*MP + NC*NC + 2*NC. C CALL TB05AD( BALEIG, INITA, NC, MP, MP, FREQ, A, LDA, B, LDB, $ C, LDC, RCND, ZWORK, MP, DWORK, DWORK, ZWORK(IWB), $ NC, IWORK, DWORK(IDWRK), LDSIZE, ZWORK(ICWRK), $ LCSIZE, INFO2 ) C IF ( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF C RCOND = MIN( RCOND, RCND ) IF ( W.EQ.1 ) $ MAXWRK = INT( DWORK(IDWRK) + IDWRK - 1 ) IC = 0 C C D + C*inv(jw*I-A)*B C DO 20 K = 1, MP DO 10 I = 1, MP IC = IC + 1 ZWORK(IC) = ZWORK(IC) + DCMPLX ( D(I,K), ZERO ) 10 CONTINUE 20 CONTINUE C C Estimate D(jw) and mju(jw). C Integer workspace: need MAX(4*MNB-2,MP). C Real workspace: need LWA + 2*MP*MP*MNB - MP*MP + 9*MNB*MNB C + MP*MNB + 11*MP + 33*MNB - 11; C prefer larger. C Complex workspace: need 6*MP*MP*MNB + 13*MP*MP + 6*MNB + C 6*MP - 3. C CALL AB13MD( 'N', MP, ZWORK, MP, MNB, NBLOCK, ITYPE, $ DWORK(IWX), MJU(W), DWORK((W-1)*MP+1), $ DWORK(IWGJOM), IWORK, DWORK(IDWRK), LDSIZE, $ ZWORK(IWB), LZWORK-IWB+1, INFO2 ) C IF ( INFO2.NE.0 ) THEN INFO = INFO2 + 1 RETURN END IF C IF ( W.EQ.1 ) THEN MAXWRK = MAX( MAXWRK, INT( DWORK(IDWRK) ) + IDWRK - 1 ) MAXCWR = MAX( MAXCWR, INT( ZWORK(IWB) ) + IWB - 1 ) END IF C C Normalize D(jw) through it's last entry. C IF ( DWORK(W*MP).NE.ZERO ) $ CALL DSCAL( MP, ONE/DWORK(W*MP), DWORK((W-1)*MP+1), 1 ) C 30 CONTINUE C C Quick return if needed. C IF ( QUTOL.LT.ZERO ) THEN DWORK(1) = MAXWRK DWORK(2) = MAXCWR DWORK(3) = RCOND RETURN END IF C C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ C Workspace usage 2. C C real C IWRFRD = IWX IWIFRD = IWRFRD + LENDAT IWAD = IWIFRD + LENDAT IWBD = IWAD + ORD*ORD IWCD = IWBD + ORD IWDD = IWCD + ORD IDWRK = IWDD + 1 LDSIZE = LDWORK - IDWRK + 1 C C complex C ICWRK = ORD + 2 LCSIZE = LZWORK - ICWRK + 1 INITA = 'H' C C Use default tolerance for SB10YD. C TOL = -ONE C C @@@ 2. Clear imag parts of D(jw) for SB10YD. @@@ C DO 40 I = 1, LENDAT DWORK(IWIFRD+I-1) = ZERO 40 CONTINUE C C @@@ 3. Clear AD, BD, CD and initialize DD with I_(mp+f). @@@ C CALL DLASET( 'Full', MP*ORD, MP*ORD, ZERO, ZERO, AD, LDAD ) CALL DLASET( 'Full', MP*ORD, MP+F, ZERO, ZERO, BD, LDBD ) CALL DLASET( 'Full', MP+F, MP*ORD, ZERO, ZERO, CD, LDCD ) CALL DLASET( 'Full', MP+F, MP+F, ZERO, ONE, DD, LDDD ) C C @@@ 4. Block by block frequency identification. @@@ C DO 80 II = 1, MP C CALL DCOPY( LENDAT, DWORK(II), MP, DWORK(IWRFRD), 1 ) C C Increase CORD from 1 to ORD for every block, if needed. C CORD = 1 C 50 CONTINUE LORD = CORD C C Now, LORD is the desired order. C Integer workspace: need 2*N+1, where N = LORD. C Real workspace: need LWB + MAX( 2, LW1, LW2, LW3, LW4), C where C LWB = LENDAT*(MP+2) + C ORD*(ORD+2) + 1, C HNPTS = 2048, and C LW1 = 2*LENDAT + 4*HNPTS; C LW2 = LENDAT + 6*HNPTS; C MN = min( 2*LENDAT, 2*N+1 ) C LW3 = 2*LENDAT*(2*N+1) + C max( 2*LENDAT, 2*N+1 ) + C max( MN + 6*N + 4, 2*MN+1 ); C LW4 = max( N*N + 5*N, C 6*N + 1 + min( 1,N ) ); C prefer larger. C Complex workspace: need LENDAT*(2*N+3). C CALL SB10YD( 0, 1, LENDAT, DWORK(IWRFRD), DWORK(IWIFRD), $ OMEGA, LORD, DWORK(IWAD), ORD, DWORK(IWBD), $ DWORK(IWCD), DWORK(IWDD), TOL, IWORK, $ DWORK(IDWRK), LDSIZE, ZWORK, LZWORK, INFO2 ) C C At this point, LORD is the actual order reached by SB10YD, C 0 <= LORD <= CORD. C [ADi,BDi; CDi,DDi] is a minimal realization with ADi in C upper Hessenberg form. C The leading LORD-by-LORD part of ORD-by-ORD DWORK(IWAD) C contains ADi, the leading LORD-by-1 part of ORD-by-1 C DWORK(IWBD) contains BDi, the leading 1-by-LORD part of C 1-by-ORD DWORK(IWCD) contains CDi, DWORK(IWDD) contains DDi. C IF ( INFO2.NE.0 ) THEN INFO = 10 + INFO2 RETURN END IF C C Compare the original D(jw) with the fitted one. C MEQE = ZERO MAQE = ZERO C DO 60 W = 1, LENDAT FREQ = DCMPLX( ZERO, OMEGA(W) ) C C Compute CD*inv(jw*I-AD)*BD. C Integer workspace: need LORD. C Real workspace: need LWB + 2*LORD; C prefer larger. C Complex workspace: need 1 + ORD + LORD*LORD + 2*LORD. C CALL TB05AD( BALEIG, INITA, LORD, 1, 1, FREQ, $ DWORK(IWAD), ORD, DWORK(IWBD), ORD, $ DWORK(IWCD), 1, RCND, ZWORK, 1, $ DWORK(IDWRK), DWORK(IDWRK), ZWORK(2), ORD, $ IWORK, DWORK(IDWRK), LDSIZE, ZWORK(ICWRK), $ LCSIZE, INFO2 ) C IF ( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF C RCOND = MIN( RCOND, RCND ) IF ( W.EQ.1 ) $ MAXWRK = MAX( MAXWRK, INT( DWORK(IDWRK) ) + IDWRK - 1) C C DD + CD*inv(jw*I-AD)*BD C ZWORK(1) = ZWORK(1) + DCMPLX( DWORK(IWDD), ZERO ) C MOD1 = ABS( DWORK(IWRFRD+W-1) ) MOD2 = ABS( ZWORK(1) ) RQE = ABS( ( MOD1 - MOD2 )/( MOD1 + TOLER ) ) MEQE = MEQE + RQE MAQE = MAX( MAQE, RQE ) C 60 CONTINUE C MEQE = MEQE/LENDAT C IF ( ( ( MEQE + MAQE )/TWO.LE.QUTOL ) .OR. $ ( CORD.EQ.ORD ) ) THEN GOTO 70 END IF C CORD = CORD + 1 GOTO 50 C 70 TOTORD = TOTORD + LORD C C Copy ad(ii), bd(ii) and cd(ii) to AD, BD and CD, respectively. C CALL DLACPY( 'Full', LORD, LORD, DWORK(IWAD), ORD, $ AD(TOTORD-LORD+1,TOTORD-LORD+1), LDAD ) CALL DCOPY( LORD, DWORK(IWBD), 1, BD(TOTORD-LORD+1,II), 1 ) CALL DCOPY( LORD, DWORK(IWCD), 1, CD(II,TOTORD-LORD+1), LDCD ) C C Copy dd(ii) to DD. C DD(II,II) = DWORK(IWDD) C 80 CONTINUE C DWORK(1) = MAXWRK DWORK(2) = MAXCWR DWORK(3) = RCOND RETURN C C *** Last line of SB10MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01UX.f0000644000000000000000000000013215012430707016211 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01UX.f0000644000175000017500000002733715012430707017421 0ustar00lilgelilge00000000000000 SUBROUTINE MB01UX( SIDE, UPLO, TRANS, M, N, ALPHA, T, LDT, A, LDA, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute one of the matrix products C C A : = alpha*op( T ) * A, or A : = alpha*A * op( T ), C C where alpha is a scalar, A is an m-by-n matrix, T is a quasi- C triangular matrix, and op( T ) is one of C C op( T ) = T or op( T ) = T', the transpose of T. C C ARGUMENTS C C Mode Parameters C C SIDE CHARACTER*1 C Specifies whether the upper quasi-triangular matrix H C appears on the left or right in the matrix product as C follows: C = 'L': A := alpha*op( T ) * A; C = 'R': A := alpha*A * op( T ). C C UPLO CHARACTER*1. C Specifies whether the matrix T is an upper or lower C quasi-triangular matrix as follows: C = 'U': T is an upper quasi-triangular matrix; C = 'L': T is a lower quasi-triangular matrix. C C TRANS CHARACTER*1 C Specifies the form of op( T ) to be used in the matrix C multiplication as follows: C = 'N': op( T ) = T; C = 'T': op( T ) = T'; C = 'C': op( T ) = T'. 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 ALPHA (input) DOUBLE PRECISION C The scalar alpha. When alpha is zero then T is not C referenced and A need not be set before entry. C C T (input) DOUBLE PRECISION array, dimension (LDT,k) C where k is M when SIDE = 'L' and is N when SIDE = 'R'. C On entry with UPLO = 'U', the leading k-by-k upper C Hessenberg part of this array must contain the upper C quasi-triangular matrix T. The elements below the C subdiagonal are not referenced. C On entry with UPLO = 'L', the leading k-by-k lower C Hessenberg part of this array must contain the lower C quasi-triangular matrix T. The elements above the C supdiagonal are not referenced. C C LDT INTEGER C The leading dimension of the array T. LDT >= max(1,k), C where k is M when SIDE = 'L' and is N when SIDE = 'R'. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading M-by-N part of this array must C contain the matrix A. C On exit, the leading M-by-N part of this array contains C the computed product. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 and ALPHA<>0, DWORK(1) returns the C optimal value of LDWORK. C On exit, if INFO = -12, DWORK(1) returns the minimum C value of LDWORK. C This array is not referenced when alpha = 0. C C LDWORK The length of the array DWORK. C LDWORK >= 1, if alpha = 0 or MIN(M,N) = 0; C LDWORK >= 2*(M-1), if SIDE = 'L'; C LDWORK >= 2*(N-1), if SIDE = 'R'. C For maximal efficiency LDWORK should be at least C NOFF*N + M - 1, if SIDE = 'L'; C NOFF*M + N - 1, if SIDE = 'R'; C where NOFF is the number of nonzero elements on the C subdiagonal (if UPLO = 'U') or supdiagonal (if UPLO = 'L') C of T. 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 technique used in this routine is similiar to the technique C used in the SLICOT [1] subroutine MB01UW developed by Vasile Sima. C The required matrix product is computed in two steps. In the first C step, the triangle of T specified by UPLO is used; in the second C step, the contribution of the sub-/supdiagonal is added. If the C workspace can accommodate parts of A, a fast BLAS 3 DTRMM C operation is used in the first step. C C REFERENCES C C [1] Benner, P., Mehrmann, V., Sima, V., Van Huffel, S., and C Varga, A. C SLICOT - A subroutine library in systems and control theory. C In: Applied and computational control, signals, and circuits, C Vol. 1, pp. 499-539, Birkhauser, Boston, 1999. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, May 2008 (SLICOT version of the HAPACK routine DTRQML). C V. Sima, Aug. 2011. C C KEYWORDS C C Elementary 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, LDT, LDWORK, M, N DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), T(LDT,*) C .. Local Scalars .. LOGICAL LQUERY, LSIDE, LTRAN, LUP CHARACTER ATRAN INTEGER I, IERR, J, K, NOFF, PDW, PSAV, WRKMIN, WRKOPT, $ XDIF DOUBLE PRECISION TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DTRMM, DTRMV, $ XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C C .. Executable Statements .. C C Decode and test the input scalar arguments. C INFO = 0 LSIDE = LSAME( SIDE, 'L' ) LUP = LSAME( UPLO, 'U' ) LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) IF ( LSIDE ) THEN K = M ELSE K = N END IF WRKMIN = MAX( 1, 2*( K - 1 ) ) LQUERY = LDWORK.EQ.-1 C IF ( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) ) THEN INFO = -1 ELSE IF ( ( .NOT.LUP ).AND.( .NOT.LSAME( UPLO, 'L' ) ) ) THEN INFO = -2 ELSE IF ( ( .NOT.LTRAN ).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 ( LDT.LT.MAX( 1, K ) ) THEN INFO = -8 ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 ) THEN IF( LQUERY ) THEN IF ( LSIDE ) THEN WRKOPT = ( M/2 )*N + M - 1 ELSE WRKOPT = ( N/2 )*M + N - 1 END IF WRKOPT = MAX( WRKOPT, WRKMIN ) DWORK(1) = DBLE( WRKOPT ) RETURN ELSE IF ( LDWORK.LT.WRKMIN ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = -12 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01UX', -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 A to zero and return. C CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) RETURN END IF C C Save and count off-diagonal entries of T. C IF ( LUP ) THEN CALL DCOPY( K-1, T(2,1), LDT+1, DWORK, 1 ) ELSE CALL DCOPY( K-1, T(1,2), LDT+1, DWORK, 1 ) END IF NOFF = 0 C DO 5 I = 1, K-1 IF ( DWORK(I).NE.ZERO ) $ NOFF = NOFF + 1 5 CONTINUE C C Compute optimal workspace. C IF ( LSIDE ) THEN WRKOPT = NOFF*N + M - 1 ELSE WRKOPT = NOFF*M + N - 1 END IF C PSAV = K IF ( .NOT.LTRAN ) THEN XDIF = 0 ELSE XDIF = 1 END IF IF ( .NOT.LUP ) $ XDIF = 1 - XDIF IF ( .NOT.LSIDE ) $ XDIF = 1 - XDIF C IF ( LDWORK.GE.WRKOPT ) THEN C C Enough workspace for a fast BLAS 3 calculation. C Save relevant parts of A in the workspace and compute one of C the matrix products C A : = alpha*op( triu( T ) ) * A, or C A : = alpha*A * op( triu( T ) ), C involving the upper/lower triangle of T. C PDW = PSAV IF ( LSIDE ) THEN DO 20 J = 1, N DO 10 I = 1, M-1 IF ( DWORK(I).NE.ZERO ) THEN DWORK(PDW) = A(I+XDIF,J) PDW = PDW + 1 END IF 10 CONTINUE 20 CONTINUE ELSE DO 30 J = 1, N-1 IF ( DWORK(J).NE.ZERO ) THEN CALL DCOPY( M, A(1,J+XDIF), 1, DWORK(PDW), 1 ) PDW = PDW + M END IF 30 CONTINUE END IF CALL DTRMM( SIDE, UPLO, TRANS, 'Non-unit', M, N, ALPHA, T, $ LDT, A, LDA ) C C Add the contribution of the offdiagonal of T. C PDW = PSAV XDIF = 1 - XDIF IF( LSIDE ) THEN DO 50 J = 1, N DO 40 I = 1, M-1 TEMP = DWORK(I) IF ( TEMP.NE.ZERO ) THEN A(I+XDIF,J) = A(I+XDIF,J) + ALPHA * TEMP * $ DWORK(PDW) PDW = PDW + 1 END IF 40 CONTINUE 50 CONTINUE ELSE DO 60 J = 1, N-1 TEMP = DWORK(J)*ALPHA IF ( TEMP.NE.ZERO ) THEN CALL DAXPY( M, TEMP, DWORK(PDW), 1, A(1,J+XDIF), 1 ) PDW = PDW + M END IF 60 CONTINUE END IF ELSE C C Use a BLAS 2 calculation. C IF ( LSIDE ) THEN DO 80 J = 1, N C C Compute the contribution of the offdiagonal of T to C the j-th column of the product. C DO 70 I = 1, M - 1 DWORK(PSAV+I-1) = DWORK(I)*A(I+XDIF,J) 70 CONTINUE C C Multiply the triangle of T by the j-th column of A, C and add to the above result. C CALL DTRMV( UPLO, TRANS, 'Non-unit', M, T, LDT, A(1,J), $ 1 ) CALL DAXPY( M-1, ONE, DWORK(PSAV), 1, A(2-XDIF,J), 1 ) 80 CONTINUE ELSE IF ( LTRAN ) THEN ATRAN = 'N' ELSE ATRAN = 'T' END IF DO 100 I = 1, M C C Compute the contribution of the offdiagonal of T to C the i-th row of the product. C DO 90 J = 1, N - 1 DWORK(PSAV+J-1) = A(I,J+XDIF)*DWORK(J) 90 CONTINUE C C Multiply the i-th row of A by the triangle of T, C and add to the above result. C CALL DTRMV( UPLO, ATRAN, 'Non-unit', N, T, LDT, A(I,1), $ LDA ) CALL DAXPY( N-1, ONE, DWORK(PSAV), 1, A(I,2-XDIF), LDA ) 100 CONTINUE END IF C C Scale the result by alpha. C IF ( ALPHA.NE.ONE ) $ CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA, $ IERR ) END IF DWORK(1) = DBLE( MAX( WRKMIN, WRKOPT ) ) RETURN C *** Last line of MB01UX *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04RY.f0000644000000000000000000000013215012430707016220 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04RY.f0000644000175000017500000001707015012430707017421 0ustar00lilgelilge00000000000000 SUBROUTINE SB04RY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, $ DWORK, LDDWOR, INFO ) C C PURPOSE C C To solve a system of equations in Hessenberg form with one C right-hand side. C C ARGUMENTS C C Mode Parameters C C RC CHARACTER*1 C Indicates processing by columns or rows, as follows: C = 'R': Row transformations are applied; C = 'C': Column transformations are applied. C C UL CHARACTER*1 C Indicates whether A is upper or lower Hessenberg matrix, C as follows: C = 'U': A is upper Hessenberg; C = 'L': A is lower Hessenberg. C C Input/Output Parameters C C M (input) INTEGER C The order of the matrix A. M >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,M) C The leading M-by-M part of this array must contain a C matrix A in Hessenberg form. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C LAMBDA (input) DOUBLE PRECISION C This variable must contain the value to be multiplied with C the elements of A. C C D (input/output) DOUBLE PRECISION array, dimension (M) C On entry, this array must contain the right-hand side C vector of the Hessenberg system. C On exit, if INFO = 0, this array contains the solution C vector of the Hessenberg system. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used to test for near singularity of C the triangular factor R of the Hessenberg matrix. A matrix C whose estimated condition number is less than 1/TOL is C considered to be nonsingular. C C Workspace C C IWORK INTEGER array, dimension (M) C C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) C The leading M-by-M part of this array is used for C computing the triangular factor of the QR decomposition C of the Hessenberg matrix. The remaining 3*M elements are C used as workspace for the computation of the reciprocal C condition estimate. C C LDDWOR INTEGER C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if the Hessenberg matrix is (numerically) singular. C That is, its estimated reciprocal condition number C is less than or equal to TOL. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C D. Sima, University of Bucharest, May 2000. C C REVISIONS C C - C C Note that RC, UL, M, LDA, and LDDWOR must be such that the value C of the LOGICAL variable OK in the following statement is true. C C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) C .AND. C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) C .AND. C ( M.GE.0 ) C .AND. C ( LDA.GE.MAX( 1, M ) ) C .AND. C ( LDDWOR.GE.MAX( 1, M ) ) C C These conditions are not checked by the routine. C C KEYWORDS C C Hessenberg form, orthogonal transformation, real Schur form, C Sylvester equation. C C ****************************************************************** C DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER RC, UL INTEGER INFO, LDA, LDDWOR, M DOUBLE PRECISION LAMBDA, TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) C .. Local Scalars .. CHARACTER TRANS INTEGER J, J1, MJ DOUBLE PRECISION C, R, RCOND, S C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLARTG, DROT, DSCAL, DTRCON, DTRSV C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C INFO = 0 C C For speed, no tests on the input scalar arguments are made. C Quick return if possible. C IF ( M.EQ.0 ) $ RETURN C IF ( LSAME( UL, 'U' ) ) THEN C DO 20 J = 1, M CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) CALL DSCAL( MIN( J+1, M ), LAMBDA, DWORK(1,J), 1 ) DWORK(J,J) = DWORK(J,J) + ONE 20 CONTINUE C IF ( LSAME( RC, 'R' ) ) THEN TRANS = 'N' C C A is an upper Hessenberg matrix, row transformations. C DO 40 J = 1, M - 1 MJ = M - J IF ( DWORK(J+1,J).NE.ZERO ) THEN CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) DWORK(J,J) = R DWORK(J+1,J) = ZERO CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), $ LDDWOR, C, S ) CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) END IF 40 CONTINUE C ELSE TRANS = 'T' C C A is an upper Hessenberg matrix, column transformations. C DO 60 J = 1, M - 1 MJ = M - J IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, $ R ) DWORK(MJ+1,MJ+1) = R DWORK(MJ+1,MJ) = ZERO CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, $ S ) CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) END IF 60 CONTINUE C END IF ELSE C DO 80 J = 1, M J1 = MAX( J - 1, 1 ) CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) CALL DSCAL( M-J1+1, LAMBDA, DWORK(J1,J), 1 ) DWORK(J,J) = DWORK(J,J) + ONE 80 CONTINUE C IF ( LSAME( RC, 'R' ) ) THEN TRANS = 'N' C C A is a lower Hessenberg matrix, row transformations. C DO 100 J = 1, M - 1 MJ = M - J IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, $ R ) DWORK(MJ+1,MJ+1) = R DWORK(MJ,MJ+1) = ZERO CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), $ LDDWOR, C, S ) CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) END IF 100 CONTINUE C ELSE TRANS = 'T' C C A is a lower Hessenberg matrix, column transformations. C DO 120 J = 1, M - 1 MJ = M - J IF ( DWORK(J,J+1).NE.ZERO ) THEN CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) DWORK(J,J) = R DWORK(J,J+1) = ZERO CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, $ S ) CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) END IF 120 CONTINUE C END IF END IF C CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, $ DWORK(1,M+1), IWORK, INFO ) IF ( RCOND.LE.TOL ) THEN INFO = 1 ELSE CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) END IF C RETURN C *** Last line of SB04RY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04JD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04JD.f0000644000175000017500000001640215012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE MB04JD( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute an LQ factorization of an n-by-m matrix A (A = L * Q), C having a min(n,p)-by-p zero triangle in the upper right-hand side C corner, as shown below, for n = 8, m = 7, and p = 2: C C [ x x x x x 0 0 ] C [ x x x x x x 0 ] C [ x x x x x x x ] C [ x x x x x x x ] C A = [ x x x x x x x ], C [ x x x x x x x ] C [ x x x x x x x ] C [ x x x x x x x ] C C and optionally apply the transformations to an l-by-m matrix B C (from the right). The problem structure is exploited. This C computation is useful, for instance, in combined measurement and C time update of one iteration of the time-invariant Kalman filter C (square root covariance filter). C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix A. N >= 0. C C M (input) INTEGER C The number of columns of the matrix A. M >= 0. C C P (input) INTEGER C The order of the zero triagle. P >= 0. C C L (input) INTEGER C The number of rows of the matrix B. L >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) C On entry, the leading N-by-M part of this array must C contain the matrix A. The elements corresponding to the C zero MIN(N,P)-by-P upper trapezoidal/triangular part C (if P > 0) are not referenced. C On exit, the elements on and below the diagonal of this C array contain the N-by-MIN(N,M) lower trapezoidal matrix C L (L is lower triangular, if N <= M) of the LQ C factorization, and the relevant elements above the C diagonal contain the trailing components (the vectors v, C see Method) of the elementary reflectors used in the C factorization. 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 L-by-M part of this array must C contain the matrix B. C On exit, the leading L-by-M part of this array contains C the updated matrix B. C If L = 0, this array is not referenced. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,L). C C TAU (output) DOUBLE PRECISION array, dimension MIN(N,M) C The scalar factors of the elementary reflectors used. 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 The length of the array DWORK. C LDWORK >= MAX(1,N-1,N-P,L). 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 C METHOD C C The routine uses min(N,M) Householder transformations exploiting C the zero pattern of the 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 an (M-P+I-2)-vector. The components of v are stored C i i C in the i-th row of A, beginning from the location i+1, and tau C i C is stored in TAU(i). C C NUMERICAL ASPECTS C C The algorithm is backward stable. C C CONTRIBUTORS C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C C REVISIONS C C - C C KEYWORDS C C Elementary reflector, LQ factorization, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, L, LDA, LDB, LDWORK, M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION FIRST, WRKOPT C .. External Subroutines .. EXTERNAL DGELQF, DLARF, DLARFG, DORMLQ, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 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( L.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, L ) ) THEN INFO = -8 ELSE IF( LDWORK.LT.MAX( 1, N - 1, N - P, L ) ) THEN INFO = -11 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB04JD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( M, N ).EQ.0 ) THEN DWORK(1) = ONE RETURN ELSE IF( M.LE.P+1 ) THEN DO 5 I = 1, MIN( N, M ) TAU(I) = ZERO 5 CONTINUE DWORK(1) = ONE RETURN END IF C C Annihilate the superdiagonal elements of A and apply the C transformations to B, if L > 0. C Workspace: need MAX(N-1,L). 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 10 I = 1, MIN( N, P ) C C Exploit the structure of the I-th row of A. C CALL DLARFG( M-P, A(I,I), A(I,I+1), LDA, TAU(I) ) IF( TAU(I).NE.ZERO ) THEN C FIRST = A(I,I) A(I,I) = ONE C IF ( I.LT.N ) CALL DLARF( 'Right', N-I, M-P, A(I,I), LDA, $ TAU(I), A(I+1,I), LDA, DWORK ) IF ( L.GT.0 ) CALL DLARF( 'Right', L, M-P, A(I,I), LDA, $ TAU(I), B(1,I), LDB, DWORK ) C A(I,I) = FIRST END IF 10 CONTINUE C WRKOPT = MAX( ONE, DBLE( N - 1 ), DBLE( L ) ) C C Fast LQ factorization of the remaining trailing submatrix, if any. C Workspace: need N-P; prefer (N-P)*NB. C IF( N.GT.P ) THEN CALL DGELQF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), DWORK, $ LDWORK, INFO ) WRKOPT = MAX( WRKOPT, DWORK(1) ) C IF ( L.GT.0 ) THEN C C Apply the transformations to B. C Workspace: need L; prefer L*NB. C CALL DORMLQ( 'Right', 'Transpose', L, M-P, MIN(N,M)-P, $ A(P+1,P+1), LDA, TAU(P+1), B(1,P+1), LDB, $ DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, DWORK(1) ) END IF END IF C DWORK(1) = WRKOPT RETURN C *** Last line of MB04JD *** END control-4.1.2/src/slicot/src/PaxHeaders/FB01TD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/FB01TD.f0000644000175000017500000005726015012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE FB01TD( JOBX, MULTRC, N, M, P, SINV, LDSINV, AINV, $ LDAINV, AINVB, LDAINB, RINV, LDRINV, C, LDC, $ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To calculate a combined measurement and time update of one C iteration of the time-invariant Kalman filter. This update is C given for the square root information filter, using the condensed C controller Hessenberg form. C C ARGUMENTS C C Mode Parameters C C JOBX CHARACTER*1 C Indicates whether X is to be computed as follows: C i+1 C = 'X': X is computed and stored in array X; C i+1 C = 'N': X is not required. C i+1 C C MULTRC CHARACTER*1 -1/2 C Indicates how matrices R and C are to be passed to C i+1 i+1 C the routine as follows: C = 'P': Array RINV is not used and the array C must C -1/2 C contain the product R C ; C i+1 i+1 C = 'N': Arrays RINV and C must contain the matrices C as described below. C C Input/Output Parameters C C N (input) INTEGER C The actual state dimension, i.e., the order of the C -1 -1 C matrices S and A . N >= 0. C i C C M (input) INTEGER C The actual input dimension, i.e., the order of the matrix C -1/2 C Q . M >= 0. C i C C P (input) INTEGER C The actual output dimension, i.e., the order of the matrix C -1/2 C R . P >= 0. C i+1 C C SINV (input/output) DOUBLE PRECISION array, dimension C (LDSINV,N) C On entry, the leading N-by-N upper triangular part of this C -1 C array must contain S , the inverse of the square root C i C (right Cholesky factor) of the state covariance matrix C P (hence the information square root) at instant i. C i|i C On exit, the leading N-by-N upper triangular part of this C -1 C array contains S , the inverse of the square root (right C i+1 C Cholesky factor) of the state covariance matrix P C i+1|i+1 C (hence the information square root) at instant i+1. C The strict lower triangular part of this array is not C referenced. C C LDSINV INTEGER C The leading dimension of array SINV. LDSINV >= MAX(1,N). C C AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N) C -1 C The leading N-by-N part of this array must contain A , C the inverse of the state transition matrix of the discrete C system in controller Hessenberg form (e.g., as produced by C SLICOT Library Routine TB01MD). C C LDAINV INTEGER C The leading dimension of array AINV. LDAINV >= MAX(1,N). C C AINVB (input) DOUBLE PRECISION array, dimension (LDAINB,M) C -1 C The leading N-by-M part of this array must contain A B, C -1 C the product of A and the input weight matrix B of the C discrete system, in upper controller Hessenberg form C (e.g., as produced by SLICOT Library Routine TB01MD). C C LDAINB INTEGER C The leading dimension of array AINVB. LDAINB >= MAX(1,N). C C RINV (input) DOUBLE PRECISION array, dimension (LDRINV,*) C If MULTRC = 'N', then the leading P-by-P upper triangular C -1/2 C part of this array must contain R , the inverse of the C i+1 C covariance square root (right Cholesky factor) of the C output (measurement) noise (hence the information square C root) at instant i+1. C The strict lower triangular part of this array is not C referenced. C Otherwise, RINV is not referenced and can be supplied as a C dummy array (i.e., set parameter LDRINV = 1 and declare C this array to be RINV(1,1) in the calling program). C C LDRINV INTEGER C The leading dimension of array RINV. C LDRINV >= MAX(1,P) if MULTRC = 'N'; C LDRINV >= 1 if MULTRC = 'P'. C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C The leading P-by-N part of this array must contain C , C -1/2 i+1 C the output weight matrix (or the product R C if C i+1 i+1 C MULTRC = 'P') of the discrete system at instant i+1. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C QINV (input/output) DOUBLE PRECISION array, dimension C (LDQINV,M) C On entry, the leading M-by-M upper triangular part of this C -1/2 C array must contain Q , the inverse of the covariance C i C square root (right Cholesky factor) of the input (process) C noise (hence the information square root) at instant i. C On exit, the leading M-by-M upper triangular part of this C -1/2 C array contains (QINOV ) , the inverse of the covariance C i C square root (right Cholesky factor) of the process noise C innovation (hence the information square root) at C instant i. C The strict lower triangular part of this array is not C referenced. C C LDQINV INTEGER C The leading dimension of array QINV. LDQINV >= MAX(1,M). C C X (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain X , the estimated C i C filtered state at instant i. C On exit, if JOBX = 'X', and INFO = 0, then this array C contains X , the estimated filtered state at C i+1 C instant i+1. C On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then C -1 C this array contains S X . C i+1 i+1 C C RINVY (input) DOUBLE PRECISION array, dimension (P) C -1/2 C This array must contain R Y , the product of the C i+1 i+1 C -1/2 C upper triangular matrix R and the measured output C i+1 C vector Y at instant i+1. C i+1 C C Z (input) DOUBLE PRECISION array, dimension (M) C This array must contain Z , the mean value of the state C i C process noise at instant i. C C E (output) DOUBLE PRECISION array, dimension (P) C This array contains E , the estimated error at instant C i+1 C i+1. C C Tolerances C C TOL DOUBLE PRECISION C If JOBX = 'X', then TOL is used to test for near C -1 C singularity of the matrix S . If the user sets C i+1 C TOL > 0, then the given value of TOL is used as a C lower bound for the reciprocal condition number of that C matrix; a matrix whose estimated condition number is less C than 1/TOL is considered to be nonsingular. If the user C sets TOL <= 0, then an implicitly computed, default C tolerance, defined by TOLDEF = N*N*EPS, is used instead, C where EPS is the machine precision (see LAPACK Library C routine DLAMCH). C Otherwise, TOL is not referenced. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C where LIWORK = N if JOBX = 'X', C and LIWORK = 1 otherwise. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK. If INFO = 0 and JOBX = 'X', DWORK(2) returns C an estimate of the reciprocal of the condition number C -1 C (in the 1-norm) of S . C i+1 C C LDWORK The length of the array DWORK. C LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1)), C if JOBX = 'N'; C LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1), C 3*N), if JOBX = 'X'. 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; -1 C = 1: if JOBX = 'X' and the matrix S is singular, C i+1 -1 C i.e., the condition number estimate of S (in the C i+1 C -1 -1/2 C 1-norm) exceeds 1/TOL. The matrices S , Q C i+1 i C and E have been computed. C C METHOD C C The routine performs one recursion of the square root information C filter algorithm, summarized as follows: C C | -1/2 -1/2 | | -1/2 | C | Q 0 Q Z | | (QINOV ) * * | C | i i i | | i | C | | | | C | -1/2 -1/2 | | -1 -1 | C T | 0 R C R Y | = | 0 S S X | C | i+1 i+1 i+1 i+1| | i+1 i+1 i+1| C | | | | C | -1 -1 -1 -1 -1 | | | C | S A B S A S X | | 0 0 E | C | i i i i | | i+1 | C C (Pre-array) (Post-array) C C where T is an orthogonal transformation triangularizing the C -1/2 C pre-array, (QINOV ) is the inverse of the covariance square C i C root (right Cholesky factor) of the process noise innovation C -1 -1 C (hence the information square root) at instant i and (A ,A B) is C in upper controller Hessenberg form. C C An example of the pre-array is given below (where N = 6, M = 2, C and P = 3): C C |x x | | x| C | x | | x| C _______________________ C | | x x x x x x | x| C | | x x x x x x | x| C | | x x x x x x | x| C _______________________ C |x x | x x x x x x | x| C | x | x x x x x x | x| C | | x x x x x x | x| C | | x x x x x | x| C | | x x x x | x| C | | x x x | x| C C The inverse of the corresponding state covariance matrix P C i+1|i+1 C (hence the information matrix I) is then factorized as C C -1 -1 -1 C I = P = (S )' S C i+1|i+1 i+1|i+1 i+1 i+1 C C and one combined time and measurement update for the state is C given by X . C i+1 C C The triangularization is done entirely via Householder C transformations exploiting the zero pattern of the pre-array. C C REFERENCES C C [1] Anderson, B.D.O. and Moore, J.B. C Optimal Filtering. C Prentice Hall, Englewood Cliffs, New Jersey, 1979. C C [2] Van Dooren, P. and Verhaegen, M.H.G. C Condensed Forms for Efficient Time-Invariant Kalman Filtering. C SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988. C C [3] Verhaegen, M.H.G. and Van Dooren, P. C Numerical Aspects of Different Kalman Filter Implementations. C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. C C [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. C Algorithm 675: FORTRAN Subroutines for Computing the Square C Root Covariance Filter and Square Root Information Filter in C Dense or Hessenberg Forms. C ACM Trans. Math. Software, 15, pp. 243-256, 1989. C C NUMERICAL ASPECTS C C The algorithm requires approximately C C 3 2 2 3 C (1/6)N + N x (3/2 x M + P) + 2 x N x M + 2/3 x M C C operations and is backward stable (see [3]). C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C Supersedes Release 2.0 routine FB01HD by M. Vanbegin, C P. Van Dooren, and M.H.G. Verhaegen. C C REVISIONS C C February 20, 1998, November 20, 2003, February 14, 2004. C C KEYWORDS C C Controller Hessenberg form, Kalman filtering, optimal filtering, C orthogonal transformation, recursive estimation, square-root C filtering, square-root information filtering. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER JOBX, MULTRC INTEGER INFO, LDAINB, LDAINV, LDC, LDQINV, LDRINV, $ LDSINV, LDWORK, M, N, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION AINV(LDAINV,*), AINVB(LDAINB,*), C(LDC,*), $ DWORK(*), E(*), QINV(LDQINV,*), RINV(LDRINV,*), $ RINVY(*), SINV(LDSINV,*), X(*), Z(*) C .. Local Scalars .. LOGICAL LJOBX, LMULTR INTEGER I, I12, I13, I23, I32, I33, II, IJ, ITAU, JWORK, $ LDW, M1, MP1, N1, NM, NP, WRKOPT DOUBLE PRECISION RCOND C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL DDOT, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLACPY, DTRMM, DTRMV, MB02OD, $ MB04ID, MB04KD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C NP = N + P NM = N + M N1 = MAX( 1, N ) M1 = MAX( 1, M ) MP1 = M + 1 INFO = 0 LJOBX = LSAME( JOBX, 'X' ) LMULTR = LSAME( MULTRC, 'P' ) C C Test the input scalar arguments. C IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) 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( LDSINV.LT.N1 ) THEN INFO = -7 ELSE IF( LDAINV.LT.N1 ) THEN INFO = -9 ELSE IF( LDAINB.LT.N1 ) THEN INFO = -11 ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDQINV.LT.M1 ) THEN INFO = -17 ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(NM + M) + 3*M, $ NP*(N + 1) + N + $ MAX( N - 1, MP1 ), 3*N ) ) $ .OR. $ ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(NM + M) + 3*M, $ NP*(N + 1) + N + $ MAX( N - 1, MP1 ) ) ) ) THEN INFO = -25 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'FB01TD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, P ).EQ.0 ) THEN IF ( LJOBX ) THEN DWORK(1) = TWO DWORK(2) = ONE ELSE DWORK(1) = ONE END IF RETURN END IF C C Construction of the needed part of the pre-array in DWORK. C To save workspace, only the blocks (1,3), (3,1)-(3,3), (2,2), and C (2,3) will be constructed when needed as shown below. C C Storing SINV x AINVB and SINV x AINV in the (1,1) and (1,2) C blocks of DWORK, respectively. The upper trapezoidal structure of C [ AINVB AINV ] is fully exploited. Specifically, if M <= N, the C following partition is used: C C [ S1 S2 ] [ B1 A1 A3 ] C [ 0 S3 ] [ 0 A2 A4 ], C C where B1, A3, and S1 are M-by-M matrices, A1 and S2 are C M-by-(N-M), A2 and S3 are (N-M)-by-(N-M), A4 is (N-M)-by-M, and C B1, S1, A2, and S3 are upper triangular. The right hand side C matrix above is stored in the workspace. If M > N, the partition C is [ SINV ] [ B1 B2 A ], where B1 is N-by-N, B2 is N-by-(M-N), C and B1 and SINV are upper triangular. C The variables called Ixy define the starting positions where the C (x,y) blocks of the pre-array are initially stored in DWORK. C Workspace: need N*(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, 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 LDW = N1 I32 = N*M + 1 C CALL DLACPY( 'Upper', N, M, AINVB, LDAINB, DWORK, LDW ) CALL DLACPY( 'Full', MIN( M, N ), N, AINV, LDAINV, DWORK(I32), $ LDW ) IF ( N.GT.M ) $ CALL DLACPY( 'Upper', N-M, N, AINV(MP1,1), LDAINV, $ DWORK(I32+M), LDW ) C C [ B1 A1 ] C Compute SINV x [ 0 A2 ] or SINV x B1 as a product of upper C triangular matrices. C Workspace: need N*(M+N+1). C II = 1 I13 = N*NM + 1 WRKOPT = MAX( 1, N*NM + N ) C DO 10 I = 1, N CALL DCOPY( I, DWORK(II), 1, DWORK(I13), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, SINV, $ LDSINV, DWORK(I13), 1 ) CALL DCOPY( I, DWORK(I13), 1, DWORK(II), 1 ) II = II + N 10 CONTINUE C C [ A3 ] C Compute SINV x [ A4 ] or SINV x [ B2 A ]. C CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, M, $ ONE, SINV, LDSINV, DWORK(II), LDW ) C C Storing the process noise mean value in (1,3) block of DWORK. C Workspace: need N*(M+N) + M. C CALL DCOPY( M, Z, 1, DWORK(I13), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV, $ DWORK(I13), 1 ) C C Computing SINV x X in X. C CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV, $ X, 1 ) C C Triangularization (2 steps). C C Step 1: annihilate the matrix SINV x AINVB. C Workspace: need N*(N+2*M) + 3*M. C I12 = I13 + M ITAU = I12 + M*N JWORK = ITAU + M C CALL MB04KD( 'Upper', M, N, N, QINV, LDQINV, DWORK, LDW, $ DWORK(I32), LDW, DWORK(I12), M1, DWORK(ITAU), $ DWORK(JWORK) ) WRKOPT = MAX( WRKOPT, N*( NM + M ) + 3*M ) C IF ( N.EQ.0 ) THEN CALL DCOPY( P, RINVY, 1, E, 1 ) IF ( LJOBX ) $ DWORK(2) = ONE DWORK(1) = WRKOPT RETURN END IF C C Apply the transformations to the last column of the pre-array. C (Only the updated (3,3) block is now needed.) C IJ = 1 C DO 20 I = 1, M CALL DAXPY( MIN( I, N ), -DWORK(ITAU+I-1)*( DWORK(I13+I-1) + $ DDOT( MIN( I, N ), DWORK(IJ), 1, X, 1 ) ), $ DWORK(IJ), 1, X, 1 ) IJ = IJ + N 20 CONTINUE C C Now, the workspace for SINV x AINVB, as well as for the updated C (1,2) block of the pre-array, are no longer needed. C Move the computed (3,2) and (3,3) blocks of the pre-array in the C (1,1) and (1,2) block positions of DWORK, to save space for the C following computations. C Then, adjust the implicitly defined leading dimension of DWORK, C to make space for storing the (2,2) and (2,3) blocks of the C pre-array. C Workspace: need (P+N)*(N+1). C CALL DLACPY( 'Full', MIN( M, N ), N, DWORK(I32), LDW, DWORK, LDW ) IF ( N.GT.M ) $ CALL DLACPY( 'Upper', N-M, N, DWORK(I32+M), LDW, DWORK(MP1), $ LDW ) LDW = MAX( 1, NP ) C DO 40 I = N, 1, -1 DO 30 IJ = MIN( N, I+M ), 1, -1 DWORK(NP*(I-1)+P+IJ) = DWORK(N*(I-1)+IJ) 30 CONTINUE 40 CONTINUE C C Copy of RINV x C in the (1,1) block of DWORK. C CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDW ) IF ( .NOT.LMULTR ) $ CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N, $ ONE, RINV, LDRINV, DWORK, LDW ) C C Copy the inclusion measurement in the (1,2) block and the updated C X in the (2,2) block of DWORK. C I23 = NP*N + 1 I33 = I23 + P CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 ) CALL DCOPY( N, X, 1, DWORK(I33), 1 ) WRKOPT = MAX( WRKOPT, NP*( N + 1 ) ) C C Step 2: QR factorization of the first block column of the matrix C C [ RINV x C RINV x Y ], C [ SINV x AINV SINV x X ] C C where the second block row was modified at Step 1. C Workspace: need (P+N)*(N+1) + N + MAX(N-1,M+1); C prefer (P+N)*(N+1) + N + (M+1)*NB, where NB is the C optimal block size for DGEQRF called in MB04ID. C ITAU = I23 + NP JWORK = ITAU + N C CALL MB04ID( NP, N, MAX( N-MP1, 0 ), 1, DWORK, LDW, DWORK(I23), $ LDW, DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Output SINV, X, and E and set the optimal workspace dimension C (and the reciprocal of the condition number estimate). C CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV ) CALL DCOPY( N, DWORK(I23), 1, X, 1 ) IF( P.GT.0 ) $ CALL DCOPY( P, DWORK(I23+N), 1, E, 1 ) C IF ( LJOBX ) THEN C C Compute X. C Workspace: need 3*N. C CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit', $ '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND, $ TOL, IWORK, DWORK, INFO ) IF ( INFO.EQ.0 ) THEN WRKOPT = MAX( WRKOPT, 3*N ) DWORK(2) = RCOND END IF END IF C DWORK(1) = WRKOPT C RETURN C *** Last line of FB01TD*** END control-4.1.2/src/slicot/src/PaxHeaders/SG02CW.f0000644000000000000000000000013215012430707016202 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SG02CW.f0000644000175000017500000034346315012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE SG02CW( DICO, JOB, JOBE, FLAG, JOBG, UPLO, TRANS, N, M, $ A, LDA, E, LDE, G, LDG, X, LDX, F, LDF, K, LDK, $ XE, LDXE, R, LDR, C, LDC, NORMS, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute the residual matrix R for a continuous-time or C discrete-time Riccati equation and/or the "closed-loop system" C matrix op(C), using the formulas C C R = op(A)'*X + X*op(A) +/- X*G*X + Q, C C = op(A) +/- G*X, C or C R = op(A)'*X*op(E) + op(E)'*X*op(A) +/- op(E)'*X*G*X*op(E) + Q, C C = op(A) +/- G*X*op(E), C or C R = op(A)'*X*op(E) + op(E)'*X*op(A) +/- H*K + Q, C C = op(A) +/- B*K, C C in the continuous-time case, or the formulas C C R = op(A)'*X*op(A) - X +/- op(A)'*X*G*X*op(A) + Q, C C = op(A) +/- G*X*op(A), C or C R = op(A)'*X*op(A) - op(E)'*X*op(E) +/- op(A)'*X*G*X*op(A) + Q, C C = op(A) +/- G*X*op(A), C or C R = op(A)'*X*op(A) - op(E)'*X*op(E) +/- H*K + Q, C C = op(A) +/- B*K, C C in the discrete-time case, where X, G, and Q are symmetric C matrices, A, E, H, K, B are general matrices, and op(W) is one of C C op(W) = W or op(W) = W'. C _-1 C Instead of the symmetric N-by-N matrix G, G = B*R *B', the N-by-M C _-1 C matrix D, D = B*L , such that G = D*D', may be given on entry. C _ _ _ _ C The matrix R, with R = L'*L, is a weighting matrix of the optimal C _ _ C problem, if DICO = 'C', or it is R = B'*X*B + Rd, if DICO = 'D', C _ _ _ C with Rd a similar weighting matrix; L is a Cholesky factor of R, C _ _ C if R is positive definite. If R is not positive definite, which C may happen in the discrete-time case, a UdU' or LdL' factorization C is used to compute the matrices H and K. If M = 0, the residual C matrix of a (generalized) Lyapunov or Stein equation is computed. C To this end, set JOBG = 'D' and JOB = 'R' (since op(C) = A in this C case). C C Optionally, the quadratic term in the formulas for R is specified C as H*K, where C C H = L + op(E)'*X*B, if DICO = 'C', or C H = L + op(A)'*X*B, if DICO = 'D', and C _-1 C K = R *H', C C with L an N-by-M matrix. This is useful, e.g., for DICO = 'D', C _ _ C when L <> 0 and/or Rd is singular, hence R might be numerically C indefinite; it might be indefinite in the first iterations of C Newton's algorithm. Depending on JOB, part or all of the matrices C H, K, and B should be given in such a case. C _ C If R is positive definite, the quadratic term can be specified C as F*F', and the second term in the formulas for C is D*F', where C _-1 C F = H*L . C C The matrices F and/or D should be given. This option is not useful C when L = 0, unless F and D are available. If DICO = 'C', the C computational problem with L <> 0 is equivalent with one with C L = 0 after replacing C _-1 _-1 C A := A - B*R* L', Q := Q - L*R* L'. C _ _ C These formulas, with R replaced by Rd, can also be used in the C _ C discrete-time case, if Rd is nonsingular and well-conditioned with C respect to inversion. C C Optionally, the Frobenius norms of the product terms defining the C denominator of the relative residual are also computed. The norms C of Q and X are not computed. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of the Riccati equation, as follows: C = 'C': continuous-time algebraic Riccati equation; C = 'D': discrete-time algebraic Riccati equation. C C JOB CHARACTER*1 C Specifies which results must be computed, as follows: C = 'A': Both (all) matrices R and C must be computed; C = 'R': The matrix R only must be computed; C = 'C': The matrix C only must be computed; C = 'N': The matrices R and C and the norms must be C computed; C = 'B': The matrix R and the norms must be computed. C C JOBE CHARACTER*1 C Specifies whether E is a general or an identity matrix, C as follows: C = 'G': The matrix E is general and is given; C = 'I': The matrix E is assumed identity and is not given. C C FLAG CHARACTER*1 C Specifies which sign is used, as follows: C = 'P': The plus sign is used; C = 'M': The minus sign is used. C C JOBG CHARACTER*1 C Specifies how the quadratic term in the formulas for R is C defined, as follows: C = 'G': The matrix G is given; C = 'D': The matrix D is given; C = 'F': The matrix F is given; C = 'H': The matrices H and K are given. C C UPLO CHARACTER*1 C Specifies which triangles of the symmetric matrices X, G C (if JOBG = 'G'), and Q (if JOB <> 'C') are given, as C 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(W) to be used in the formulas C above, as follows: C = 'N': op(W) = W; C = 'T': op(W) = W'; C = 'C': op(W) = W'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, E, Q, X, C and R. N >= 0. C C M (input) INTEGER C If JOBG <> 'G', the number of columns of the matrices D, C F, and/or B, H, and K'. M >= 0. C If JOBG = 'G', the value of M is meaningless. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must contain the C matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C E (input) DOUBLE PRECISION array, dimension (LDE,*) C If JOBE = 'G' and (JOB <> 'C' or (DICO = 'C' and C (JOBG = 'G' or JOBG = 'D'))), the leading N-by-N part of C this array must contain the matrix E. C If JOBE = 'I' or (JOB = 'C' and (DICO = 'D' or C JOBG = 'F' or JOBG = 'H')), this array is not referenced. C C LDE INTEGER C The leading dimension of array E. C LDE >= MAX(1,N), if JOBE = 'G' and (JOB <> 'C' or C (DICO = 'C' and (JOBG = 'G' or C JOBG = 'D'))); C LDE >= 1, if JOBE = 'I' or (JOB = 'C' and C (DICO = 'D' or JOBG = 'F' or C JOBG = 'H')). C C G (input/works.) DOUBLE PRECISION array, dimension (LDG,*) C If JOBG = 'G', the leading N-by-N upper or lower C triangular part (depending on UPLO) of this array must C contain the upper or lower triangular part, respectively, C of the matrix G. The other strictly triangular part is not C referenced. If DICO = 'D', (JOB = 'R' or JOB = 'B'), and C JOBG = 'G', the diagonal elements of this array are C modified internally, but are restored on exit. C If JOBG = 'D' or (JOBG = 'F' and JOB <> 'R' and C JOB <> 'B'), the leading N-by-M part of this array must C contain the matrix D, so that G = D*D'. C If JOBG = 'H' and JOB <> 'R' and JOB <> 'B', the leading C N-by-M part of this array must contain the matrix B. C If (JOBG = 'F' or JOBG = 'H') and JOB = 'R' or JOB = 'B', C this array is not referenced. C C LDG INTEGER C The leading dimension of array G. C LDG >= MAX(1,N), if JOBG = 'G' or JOBG = 'D' or C (JOB <> 'R' and JOB <> 'B'); C LDG >= 1, if (JOBG = 'F' or JOBG = 'H') and C (JOB = 'R' or JOB = 'B'). C C X (input/works.) DOUBLE PRECISION array, dimension (LDX,N) C The leading N-by-N part of this array must contain the C symmetric matrix X, and it is unchanged on exit. C If DICO = 'D', JOBE = 'G' and JOB <> 'C', the diagonal C elements of this array are modified internally, but they C are restored on exit. C The full matrix X should be input if DICO = 'C', C JOBE = 'I', and the conditions in the lines of the table C below are satisfied C C JOBG JOB LDWORK C ---------------------------------------------- C 'F','H' 'A','R' LDWORK < N*N C 'G' 'A','R','N' LDWORK < 2*N*N C 'G' 'C' LDWORK < N*N C 'G' 'B' LDWORK < 3*N*N C 'D' 'R' (M<=N, LDWORK < N*N) or C (M> N, LDWORK < 3*N*N) C 'D' 'A' (M<=N, LDWORK < N*N) or C (LDWORK >= N*N and C LDWORK < 2*N*N) C ---------------------------------------------- C C For all the other cases, including when the optimal length C of the workspace array DWORK is used, only the relevant C upper or lower triangular part (depending on UPLO) of this C array must be input, and the other strictly triangular C part is not referenced. C C LDX INTEGER C The leading dimension of array X. LDX >= MAX(1,N). C C F (input) DOUBLE PRECISION array, dimension (LDF,*) C If JOBG = 'F', the leading N-by-M part of this array must C contain the matrix F. C If JOBG = 'H', the leading N-by-M part of this array must C contain the matrix H. C If JOBG = 'G' or JOBG = 'D', this array is not referenced. C C LDF INTEGER C The leading dimension of array F. C LDF >= MAX(1,N), if JOBG = 'F' or JOBG = 'H'; C LDF >= 1, if JOBG = 'G' or JOBG = 'D'. C C K (input) DOUBLE PRECISION array, dimension (LDK,*) C If JOBG = 'H', the leading M-by-N part of this array must C contain the matrix K. C If JOBG <> 'H', this array is not referenced. C C LDK INTEGER C The leading dimension of array K. C LDK >= MAX(1,M), if JOBG = 'H'; C LDK >= 1, if JOBG <> 'H'. C C XE (input) DOUBLE PRECISION array, dimension (LDXE,*) C If (JOBG = 'F' or JOBG = 'H'), JOB <> 'C', DICO = 'C', and C JOBE = 'G', the leading N-by-N part of this array must C contain the matrix product X*E, if TRANS = 'N', or E*X, if C TRANS = 'T' or 'C'. C If (JOBG = 'F' or JOBG = 'H'), JOB <> 'C', and DICO = 'D', C the leading N-by-N part of this array must contain the C matrix product X*A, if TRANS = 'N', or A*X, if TRANS = 'T' C or 'C'. C These matrix products are needed for computing F or H. C If JOBG = 'G' or JOBG = 'D' or JOB = 'C' or (DICO = 'C' C and JOBE = 'I') this array is not referenced. C C LDXE INTEGER C The leading dimension of array XE. C LDXE >= MAX(1,N), if (JOBG = 'F' or JOBG = 'H'), C JOB <> 'C', and either DICO = 'C' and C JOBE = 'G', or DICO = 'D'; C LDXE >= 1, if JOBG = 'G' or JOBG = 'D' or JOB = 'C' C or (DICO = 'C' and JOBE = 'I'). C C R (input/output) DOUBLE PRECISION array, dimension (LDR,*) C On entry, if JOB <> 'C', the leading N-by-N upper or lower C triangular part (depending on UPLO) of this array must C contain the upper or lower triangular part, respectively, C of the matrix Q. The other strictly triangular part is not C referenced. C On exit, if JOB <> 'C' and INFO = 0, the leading N-by-N C upper or lower triangular part (depending on UPLO) of this C array contains the upper or lower triangular part, C respectively, of the matrix R. C If JOB = 'C', this array is not referenced. C C LDR INTEGER C The leading dimension of array R. C LDR >= MAX(1,N), if JOB <> 'C'; C LDR >= 1, if JOB = 'C'. C C C (output) DOUBLE PRECISION array, dimension (LDC,*) C If JOB <> 'R' and JOB <> 'B' and INFO = 0, the leading C N-by-N part of this array contains the matrix op(C). C If JOB = 'R' or JOB = 'B', this array is not referenced. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,N), if JOB <> 'R' and JOB <> 'B'; C LDC >= 1, if JOB = 'R' or JOB = 'B'. C C NORMS (output) DOUBLE PRECISION array, dimension (LN) C If JOB = 'N' or JOB = 'B', LN = 2 or 3, if (DICO = 'C' or C JOBE = 'I'), or (DICO = 'D' and JOBE = 'G'), respectively. C If DICO = 'C', C NORMS(1) contains the Frobenius norm of the matrix C op(A)'*X (or of X*op(A)), if JOBE = 'I', or of the matrix C op(A)'*X*op(E) (or of op(E)'*X*op(A)), if JOBE = 'G'; C NORMS(2) contains the Frobenius norm of the matrix C product X*G*X, if JOBE = 'I', or of the matrix product C V = op(E)'*X*G*X*op(E), if JOBE = 'G' (for JOBG = 'G' or C JOBG = 'D'), or of V = F*F', if JOBG = 'F', or of V = H*K, C if JOBG = 'H'. C If DICO = 'D', C NORMS(1) contains the Frobenius norm of the matrix C op(A)'*X*op(A); C NORMS(2) contains the Frobenius norm of the matrix product C V = op(A)'*X*G*X*op(A), if JOBG = 'G' or JOBG = 'D', or of C V = F*F', if JOBG = 'F', or of V = H*K, if JOBG = 'H'; C if JOBE = 'G', NORMS(3) contains the Frobenius norm of the C matrix product op(E)'*X*op(E). C If JOB <> 'N' and JOB <> 'B', this array is not C referenced. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = -30, or if LDWORK = -2 on input, then C DWORK(1) returns the minimum value of LDWORK. C On exit, if INFO = 0, or if LDWORK = -1 on input, then C DWORK(1) returns the optimal value of LDWORK. C C LDWORK The length of the array DWORK. LDWORK >= MAX(v,1), with v C specified in the following table, where C a = 1, if JOBE = 'G'; C a = 0, if JOBE = 'I'. C C DICO JOBG JOB v C ----------------------------------------------- C 'C' 'F','H' 'A','C','R' 0 C 'C' 'F','H' 'N' a*N*N C 'C' 'F','H' 'B' N*N C 'C' 'G' 'A','C' a*N*N C 'C' 'G' 'N','R' (a+1)*N*N C 'C' 'G' 'B' (a+2)*N*N C 'C' 'D' 'A' N*MIN(M,(a+1)*N) C 'C' 'D' 'C' N*MIN(N,M) C 'C' 'D' 'N' N*(N+MIN(a*N,M)) C 'C' 'D' 'B' N*(N+MIN(N+a*N,M)) C 'C' 'D' 'R' N*MIN(a*N+M,(a+2)*N) C ----------------------------------------------- C 'D' 'F','H' 'A','C' 0 C 'D' 'F','H' 'N','R' a*N*N C 'D' 'F','H' 'B' (a+1)*N*N C 'D' 'G' 'A','C' N*N C 'D' 'G' 'N','R' 2*N*N C 'D' 'G' 'B' 3*N*N C 'D' 'D' 'A','N' N*MIN(MAX(N,M),2*N) C 'D' 'D' 'B' N*(N+MAX(N,M)) C 'D' 'D' 'C' N*MIN(N,M) C 'D' 'D' 'R' N*MIN(3*N,N+M) C ----------------------------------------------- C C If LDWORK = -1, an optimal workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C This evaluation assumes that only the specified triangle C of the array X is always used, and the other strict C triangle is not referenced. C C If LDWORK = -2, a minimal workspace query is assumed; the C routine only calculates the minimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C This evaluation assumes that full matrix is given in the C array X, when needed (see the table at the description of C the array X). 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 expressions are efficiently evaluated, using symmetry, C common matrix subexpressions, and proper order of matrix C multiplications. C If JOB = 'N' or JOB = 'B', then: C If DICO = 'C', the matrices op(op(A)'*X*op(E)) or op(X*op(A)), and C V = op(E)'*X*G*X*op(E) or V = F*F' or V = H*K, are efficiently C computed. C If DICO = 'D', the matrices op(A)'*X*op(A), V = op(A)'*X*G*X*op(A) C or V = F*F' or V = H*K, and op(E)'*X*op(E), if JOBE = 'G', are C efficiently computed. The results are used to evaluate R, op(C) C (if JOB = 'N'), and the norms. C If JOB <> 'N', then the needed parts of the intermediate results C are obtained and used to evaluate R and/or op(C). C C NUMERICAL ASPECTS C C The calculations are backward stable. C 3 2 C The algorithm requires approximately (a+b)N + cN M operations, C where, C a = 0, if JOBE = 'I', C a = 1, if JOBE = 'G' and (DICO = 'C' or C (DICO = 'D' and JOB = 'C')), C a = 1.5, if JOBE = 'G' and DICO = 'D', C and b and c are implicitly defined below. Specifically, the effort C is approximately as follows (using ^ to denote the power operator) C C For DICO = 'C': C C JOBG JOB C C R A, N, B C 'G' (a+1)*N^3 (a+2)*N^3 (a+2)*N^3,(a+2.5)*N^3 C 'D' (a+2)*N^2*M (a+1)*N^3+1.5*N^2*M (a+1)*N^3+2.5*N^2*M C 'F','H' N^2*M N^3+0.5*N^2*M N^3+1.5*N^2*M C C For DICO = 'D': C C JOBG JOB C C R A, N, B C 'G' 2*N^3 (a+3 )*N^3 (a+3 )*N^3 C 'D' 3*N^2*M (a+1.5)*N^3+1.5*N^2*M (a+1.5)*N^3+2.5*N^2*M C 'F','H' N^2*M (a+0.5)*N^3+0.5*N^2*M (a+0.5)*N^3+1.5*N^2*M C C For JOBG <> 'G' and JOB = 'B', the effort reduces by N^2*M in C both tables. C C An "operation" includes a multiplication, an addition, and some C address calculations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2013. C C REVISIONS C C V. Sima, Mar. 2013, Sep.-Dec. 2013, June 2014, May 2015. C C KEYWORDS C C Algebraic Riccati equation, elementary matrix operations, matrix C algebra, matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, FLAG, JOB, JOBE, JOBG, TRANS, UPLO INTEGER INFO, LDA, LDC, LDE, LDF, LDG, LDK, LDR, LDWORK, $ LDX, LDXE, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), C(LDC,*), DWORK(*), E(LDE,*), $ F(LDF,*), G(LDG,*), K(LDK,*), NORMS(*), $ R(LDR,*), X(LDX,*), XE(LDXE,*) C .. Local Scalars .. CHARACTER NSIDE, NT, NTRANS, SIDE, TR LOGICAL DISCR, FULLX, KEEPX, LCNDS, LCNDT, LCOND, LFLAG, $ LJOBA, LJOBB, LJOBC, LJOBE, LJOBF, LJOBG, LJOBH, $ LJOBL, LJOBN, LJOBR, LTRANS, LUPLO, NLJOBC, $ NLJOBR, UNITE, USE1, USEATW, USEC, USEOPT, $ WITHD, WITHE INTEGER I, IA, IB, IW, J, L, MINWRK, NM, NN, OPTWRK, WP, $ YP DOUBLE PRECISION ALPHA, BETA C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLANSY EXTERNAL DLANGE, DLANSY, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DSCAL, DSYMM, $ DSYR2K, DSYRK, MA02ED, MB01RB, MB01RU, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 C DISCR = LSAME( DICO, 'D' ) LJOBA = LSAME( JOB, 'A' ) LJOBC = LSAME( JOB, 'C' ) LJOBN = LSAME( JOB, 'N' ) LJOBB = LSAME( JOB, 'B' ) LJOBR = LSAME( JOB, 'R' ) LJOBE = LSAME( JOBE, 'G' ) LFLAG = LSAME( FLAG, 'M' ) LJOBG = LSAME( JOBG, 'G' ) LJOBF = LSAME( JOBG, 'F' ) LJOBH = LSAME( JOBG, 'H' ) LUPLO = LSAME( UPLO, 'U' ) LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) LJOBL = LJOBF .OR. LJOBH NLJOBC = .NOT.LJOBC NLJOBR = .NOT.LJOBR .AND. .NOT.LJOBB WITHD = .NOT.LJOBL .OR. NLJOBR UNITE = .NOT.LJOBE WITHE = LJOBE .AND. ( NLJOBC .OR. .NOT. ( DISCR .OR. LJOBL ) ) C IF ( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.LJOBA .AND. NLJOBC .AND. $ .NOT.LJOBN .AND. NLJOBR ) THEN INFO = -2 ELSE IF( UNITE .AND. .NOT.LSAME( JOBE, 'I' ) ) THEN INFO = -3 ELSE IF( .NOT.LFLAG .AND. .NOT.LSAME( FLAG, 'P' ) ) THEN INFO = -4 ELSE IF( .NOT.LJOBG .AND. .NOT.LSAME( JOBG, 'D' ) .AND. $ .NOT.LJOBL ) THEN INFO = -5 ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -6 ELSE IF( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN INFO = -7 ELSE IF( N.LT.0 ) THEN INFO = -8 ELSE IF( .NOT.LJOBG .AND. M.LT.0 ) THEN INFO = -9 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDE.LT.1 .OR. ( WITHE .AND. LDE.LT.N ) ) THEN INFO = -13 ELSE IF( LDG.LT.1 .OR. ( WITHD .AND. LDG.LT.N ) ) THEN INFO = -15 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDF.LT.1 .OR. ( LJOBL .AND. LDF.LT.N ) ) THEN INFO = -19 ELSE IF( LDK.LT.1 .OR. ( LJOBH .AND. LDK.LT.M ) ) THEN INFO = -21 ELSE IF( LDXE.LT.1 .OR. ( LJOBL .AND. NLJOBC .AND. LDXE.LT.N .AND. $ ( DISCR .OR. ( .NOT.DISCR .AND. LJOBE ) ) ) ) THEN INFO = -23 ELSE IF( LDR.LT.1 .OR. ( NLJOBC .AND. LDR.LT.N ) ) THEN INFO = -25 ELSE IF( LDC.LT.1 .OR. ( NLJOBR .AND. LDC.LT.N ) ) THEN INFO = -27 ELSE NN = N*N IF( .NOT.LJOBG ) $ NM = N*M IF ( LJOBE .OR. DISCR ) THEN IA = 1 ELSE IA = 0 END IF C IF ( LJOBN .OR. LJOBB ) THEN IF ( LJOBB ) THEN IB = 1 ELSE IB = 0 END IF IF ( LJOBL ) THEN IF ( LJOBB .AND. DISCR ) THEN MINWRK = ( IA + 1 )*NN ELSE IF ( LJOBE .OR. LJOBB ) THEN MINWRK = NN ELSE MINWRK = 0 END IF OPTWRK = MINWRK USE1 = .FALSE. ELSE IF ( LJOBG ) THEN MINWRK = ( IA + IB + 1 )*NN OPTWRK = ( IB + 2 )*NN USE1 = .FALSE. ELSE IF ( LJOBN ) THEN LCNDS = 4*M.LE.3*N ELSE LCNDS = 2*M.LE.3*N END IF IF ( DISCR ) THEN IF ( LJOBN ) THEN MINWRK = MIN( MAX( NN, NM ), 2*NN ) ELSE MINWRK = NN + MIN( MAX( NN, NM ), 2*NN ) END IF IF ( LCNDS ) THEN IF ( LJOBN ) THEN OPTWRK = MAX( NN, NM ) ELSE OPTWRK = NN + MAX( NN, NM ) END IF ELSE OPTWRK = ( IB + 2 )*NN END IF IF ( LJOBB ) $ OPTWRK = MAX( OPTWRK, MINWRK ) USE1 = LCNDS .OR. LDWORK.LT.( IB + 2 )*NN ELSE I = NN + MAX( IA*IB*NN, NM ) J = NN + ( IA + IB )*NN MINWRK = MIN( I, J ) IF ( LCNDS ) THEN OPTWRK = I ELSE OPTWRK = ( IA + IB + 1 )*NN END IF USE1 = LCNDS .AND. LDWORK.GE.I IF ( LJOBN ) THEN USE1 = LJOBE .AND. ( LCNDS .OR. LDWORK.LT.OPTWRK ) $ .OR. UNITE .AND. USE1 ELSE USE1 = USE1 .OR. LDWORK.LT.( IA + IB + 1 )*NN END IF END IF END IF C ELSE C LCOND = ( 3 + 2*IA )*M.LE.( 2 + 2*IA )*N C IF ( DISCR ) THEN IF ( LJOBL ) THEN IF ( LJOBE .AND. LJOBR ) THEN MINWRK = NN ELSE MINWRK = 0 END IF OPTWRK = MINWRK ELSE LCNDS = 4*M.LE.3*N LCNDT = 2*M.LE.3*N IF ( LJOBG ) THEN IF ( LJOBR ) THEN MINWRK = 2*NN ELSE MINWRK = NN END IF OPTWRK = MINWRK USE1 = .FALSE. ELSE IF ( LJOBC ) THEN MINWRK = MIN( NN, NM ) IF ( LCOND ) THEN OPTWRK = NM ELSE OPTWRK = 2*NN END IF USE1 = LCOND .OR. LDWORK.LT.NN ELSE IF ( LJOBR ) THEN MINWRK = MIN( NN + NM, 3*NN ) IF ( LCNDT ) THEN OPTWRK = NN + NM ELSE OPTWRK = 3*NN END IF USE1 = LCNDT .OR. LDWORK.LT.OPTWRK ELSE MINWRK = MIN( MAX( NN, NM ), 2*NN ) IF ( LCNDS ) THEN OPTWRK = MINWRK ELSE OPTWRK = 2*NN END IF USE1 = LCNDS .OR. LDWORK.LT.OPTWRK END IF END IF END IF C ELSE C IF ( LJOBL ) THEN MINWRK = 0 IF ( UNITE .AND. LJOBR ) THEN OPTWRK = NN ELSE OPTWRK = 0 END IF USE1 = .FALSE. ELSE LCNDS = 3*M.LE.2*N LCNDT = M.LE.N IF ( LJOBG ) THEN IF ( LJOBR ) THEN MINWRK = ( IA + 1 )*NN OPTWRK = 2*NN ELSE MINWRK = IA*NN IF ( LJOBC ) THEN OPTWRK = NN ELSE OPTWRK = 2*NN END IF END IF USE1 = .FALSE. ELSE IF ( LJOBC ) THEN MINWRK = MIN( NN, NM ) IF ( LCOND ) THEN OPTWRK = NM ELSE OPTWRK = NN END IF USE1 = LCOND .OR. LDWORK.LT.OPTWRK ELSE IF ( LJOBR ) THEN MINWRK = MIN( IA*NN + NM, ( IA + 2 )*NN ) IF ( LCNDT ) THEN OPTWRK = NN + IA*NM ELSE OPTWRK = 3*NN END IF USE1 = LCNDT .OR. LDWORK.LT.( IA + 2 )*NN ELSE MINWRK = MIN( NM, ( IA + 1 )*NN ) OPTWRK = 2*NN USE1 = MINWRK.EQ.NM .AND. LDWORK.LT.OPTWRK END IF END IF END IF C IF ( NLJOBC ) THEN USEATW = USE1 .OR. M.EQ.0 IF ( LJOBA ) $ USEATW = USEATW .OR. $ ( LJOBG .AND. LDWORK.LT.OPTWRK ) ELSE USEATW = .FALSE. END IF END IF END IF C IF ( LDWORK.EQ.-2 ) THEN DWORK(1) = MAX( 1, MINWRK ) RETURN ELSE IF ( LDWORK.EQ.-1 ) THEN DWORK(1) = MAX( 1, OPTWRK ) RETURN END IF C IF( LDWORK.LT.MINWRK ) THEN INFO = -30 DWORK(1) = MAX( 1, MINWRK ) END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SG02CW', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN IF ( LJOBN .OR. LJOBB ) THEN NORMS(1) = ZERO NORMS(2) = ZERO IF ( DISCR .AND. LJOBE ) $ NORMS(3) = ZERO END IF RETURN END IF C C Initialize DWORK positions. C IF ( LJOBN .OR. LJOBB ) THEN IF ( DISCR .OR. LJOBE .OR. LJOBG .OR. USE1 ) THEN WP = NN + 1 ELSE WP = 1 END IF IF ( .NOT.( DISCR .OR. LJOBE ) .AND. LJOBG ) THEN IF ( LJOBN ) THEN KEEPX = LDWORK.GE.2*NN ELSE KEEPX = LDWORK.GE.3*NN END IF ELSE KEEPX = .FALSE. END IF ELSE IF ( DISCR ) THEN WP = NN + 1 IF ( LJOBC .AND. .NOT.LJOBG .AND. .NOT.LCOND ) THEN USEOPT = LDWORK.GE.2*NN ELSE USEOPT = .FALSE. END IF ELSE IF ( LJOBL .OR. LJOBC ) THEN WP = 1 KEEPX = UNITE .AND. LDWORK.GE.OPTWRK ELSE IF ( LJOBG ) THEN KEEPX = UNITE .AND. ( LDWORK.GE.OPTWRK .OR. $ ( LJOBA .AND. LDWORK.GE.NN ) ) IF ( LDWORK.LT.2*NN ) THEN WP = 1 ELSE WP = NN + 1 END IF ELSE IF ( LDWORK.LT.OPTWRK ) THEN KEEPX = .FALSE. IF ( LJOBR ) THEN WP = IA*NM + 1 YP = WP + NN ELSE WP = NN + 1 END IF ELSE KEEPX = .TRUE. IF ( LJOBA ) THEN WP = NN + 1 ELSE IF ( USE1 ) THEN WP = IA*NM + 1 ELSE WP = NN + 1 YP = WP + NN END IF END IF END IF END IF END IF C IF ( LFLAG ) THEN BETA = -ONE ELSE BETA = ONE END IF C NT = 'No transpose' TR = 'Transpose' IF ( LTRANS ) THEN SIDE = 'Right' NSIDE = 'Left' NTRANS = NT ELSE SIDE = 'Left' NSIDE = 'Right' NTRANS = TR END IF C IF ( LJOBN ) THEN C C JOB = 'N'. C IF ( DISCR ) THEN C IF ( LJOBE ) THEN C C Compute op(E)'*X*op(E) in C and its norm. C C Workspace: N*N. C CALL MB01RU( UPLO, NTRANS, N, N, ZERO, ONE, C, LDC, E, $ LDE, X, LDX, DWORK, NN, INFO ) C NORMS(3) = DLANSY( 'F-norm', UPLO, N, C, LDC, DWORK ) C C Compute Q - op(E)'*X*op(E) in R. C IF ( LUPLO ) THEN C DO 10 J = 1, N CALL DAXPY( J, -ONE, C(1,J), 1, R(1,J), 1 ) 10 CONTINUE C ELSE C DO 20 J = 1, N CALL DAXPY( N-J+1, -ONE, C(J,J), 1, R(J,J), 1 ) 20 CONTINUE C END IF C ELSE C C Compute Q - X in R. C IF ( LUPLO ) THEN C DO 30 J = 1, N CALL DAXPY( J, -ONE, X(1,J), 1, R(1,J), 1 ) 30 CONTINUE C ELSE C DO 40 J = 1, N CALL DAXPY( N-J+1, -ONE, X(J,J), 1, R(J,J), 1 ) 40 CONTINUE C END IF C END IF C C Compute op(A)'*X*op(A) and its norm. C IF ( LJOBL ) THEN C C Compute in C the symmetric matrix C T = A'*XE, if TRANS = 'N'; C T = XE*A', if TRANS = 'T'. C CALL MB01RB( SIDE, UPLO, TR, N, N, ZERO, ONE, C, LDC, A, $ LDA, XE, LDXE, INFO ) ELSE C C First, compute in DWORK C W = X*A, if TRANS = 'N'; C W = A*X, if TRANS = 'T'. C C Workspace: N*N. C CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, A, LDA, ZERO, $ DWORK, N ) C C Compute in C the symmetric matrix C T = A'*W, if TRANS = 'N'; C T = W*A', if TRANS = 'T'. C CALL MB01RB( SIDE, UPLO, TR, N, N, ZERO, ONE, C, LDC, A, $ LDA, DWORK, N, INFO ) END IF C NORMS(1) = DLANSY( 'F-norm', UPLO, N, C, LDC, DWORK ) C C Update R := R + op(A)'*X*op(A). C IF ( LUPLO ) THEN C DO 50 J = 1, N CALL DAXPY( J, ONE, C(1,J), 1, R(1,J), 1 ) 50 CONTINUE C ELSE C DO 60 J = 1, N CALL DAXPY( N-J+1, ONE, C(J,J), 1, R(J,J), 1 ) 60 CONTINUE C END IF C IF ( LJOBL ) THEN C C Compute F*F' or H*K in C and its norm. C IF ( LJOBF ) THEN C CALL DSYRK( UPLO, NT, N, M, ONE, F, LDF, ZERO, C, $ LDC ) C ELSE C CALL MB01RB( 'Left', UPLO, NT, N, M, ZERO, ONE, C, $ LDC, F, LDF, K, LDK, INFO ) END IF C NORMS(2) = DLANSY( 'F-norm', UPLO, N, C, LDC, DWORK ) C C Update R := R +/- F*F' or R := R +/- H*K. C IF ( LUPLO ) THEN C DO 70 J = 1, N CALL DAXPY( J, BETA, C(1,J), 1, R(1,J), 1 ) 70 CONTINUE C ELSE C DO 80 J = 1, N CALL DAXPY( N-J+1, BETA, C(J,J), 1, R(J,J), 1 ) 80 CONTINUE C END IF C C Compute op(C) = A +/- op(D*F') or op(C) = A +/- op(B*K). C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C IF ( LJOBF ) THEN IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, M, BETA, F, LDF, G, LDG, $ ONE, C, LDC ) ELSE CALL DGEMM( NT, TR, N, N, M, BETA, G, LDG, F, LDF, $ ONE, C, LDC ) END IF C ELSE IF ( LTRANS ) THEN CALL DGEMM( TR, TR, N, N, M, BETA, K, LDK, G, LDG, $ ONE, C, LDC ) ELSE CALL DGEMM( NT, NT, N, N, M, BETA, G, LDG, K, LDK, $ ONE, C, LDC ) END IF C END IF C ELSE IF ( LJOBG ) THEN C C Compute V = op(A)'*X*G*X*op(A) and its norm. C First, compute in C the following product: C Z = +/- G*W ( TRANS = 'N' ) or C Z = +/- W*G ( TRANS = 'T' ). C Then, compute V in DWORK(WP), with C V = W'*Z ( TRANS = 'N' ) C V = Z*W' ( TRANS = 'T' ). C C Workspace: 2*N*N. C CALL DSYMM( SIDE, UPLO, N, N, BETA, G, LDG, DWORK, N, $ ZERO, C, LDC ) CALL MB01RB( SIDE, UPLO, TR, N, N, ZERO, ONE, DWORK(WP), $ N, DWORK, N, C, LDC, INFO ) C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK(WP), N, DWORK $ ) C C Update R := R +/- op(A)'*X*G*X*op(A) = R + V. C I = WP IF ( LUPLO ) THEN C DO 90 J = 1, N CALL DAXPY( J, ONE, DWORK(I), 1, R(1,J), 1 ) I = I + N 90 CONTINUE C ELSE C DO 100 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK(I), 1, R(J,J), 1 ) I = I + N + 1 100 CONTINUE C END IF C C Compute C op(C) = A +/- G*W, if TRANS = 'N'; C op(C) = A +/- W*G, if TRANS = 'T'. C DO 110 J = 1, N CALL DAXPY( N, ONE, A(1,J), 1, C(1,J), 1 ) 110 CONTINUE C ELSE IF ( M.GT.0 ) THEN C IF ( USE1 ) THEN C C To reduce memory requirements, save W in C. C Compute S = D'*W or S = W*D (stored in DWORK). C Then, compute C V = op(A)'*X*D*D'*X*op(A) (i.e., S'*S or S*S') C in C, and compute its norm; D in stored in array G. C C Workspace: MAX(N*N,N*M). C CALL DLACPY( 'All', N, N, DWORK, N, C, LDC ) IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, C, LDC, G, LDG, $ ZERO, DWORK, N ) CALL DSYRK( UPLO, NT, N, M, ONE, DWORK, N, ZERO, $ C, LDC ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, G, LDG, C, LDC, $ ZERO, DWORK, M ) CALL DSYRK( UPLO, TR, N, M, ONE, DWORK, M, ZERO, $ C, LDC ) END IF C NORMS(2) = DLANSY( 'F-norm', UPLO, N, C, LDC, DWORK ) C C Update R := R +/- op(A)'*X*D*D'*X*op(A) = R +/- V, and C compute C op(C) = A +/- D*D'*W = A +/- D*S, if TRANS = 'N'; C op(C) = A +/- W*D*D' = A +/- S*D', if TRANS = 'T'. C IF ( LUPLO ) THEN C DO 120 J = 1, N CALL DAXPY( J, BETA, C(1,J), 1, R(1,J), 1 ) 120 CONTINUE C ELSE C DO 130 J = 1, N CALL DAXPY( N-J+1, BETA, C(J,J), 1, R(J,J), 1 ) 130 CONTINUE C END IF C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, M, BETA, DWORK, N, G, $ LDG, ONE, C, LDC ) ELSE CALL DGEMM( NT, NT, N, N, M, BETA, G, LDG, DWORK, $ M, ONE, C, LDC ) END IF C ELSE C C Compute Y = D*D' in DWORK(WP), and Z in C, C Z = +/- Y*W ( TRANS = 'N' ) or C Z = +/- W*Y ( TRANS = 'T' ). C C Workspace: 2*N*N. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, $ DWORK(WP), N ) C CALL DSYMM( SIDE, UPLO, N, N, BETA, DWORK(WP), N, $ DWORK, N, ZERO, C, LDC ) C C Compute in DWORK(WP) a triangle of symmetric matrix C T = W'*Z, if TRANS = 'N'; C T = Z*W', if TRANS = 'T'. C and its norm. C CALL MB01RB( SIDE, UPLO, TR, N, N, ZERO, ONE, $ DWORK(WP), N, DWORK, N, C, LDC, INFO ) C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK(WP), N, $ DWORK ) C C Update R, R = R + T, and compute op(C) = A + Z. C I = WP IF ( LUPLO ) THEN C DO 140 J = 1, N CALL DAXPY( J, ONE, DWORK(I), 1, R(1,J), 1 ) I = I + N 140 CONTINUE C ELSE C DO 150 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK(I), 1, R(J,J), 1 ) I = I + N + 1 150 CONTINUE C END IF C DO 160 J = 1, N CALL DAXPY( N, ONE, A(1,J), 1, C(1,J), 1 ) 160 CONTINUE C END IF C ELSE C NORMS(2) = ZERO CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C END IF C ELSE C C Continuous-time case. C IF ( LJOBE ) THEN C C Compute C A'*X*E, if TRANS = 'N'; C E*X*A', if TRANS = 'T'. C IF ( LJOBL ) THEN C C Compute in C C T = A'*XE, if TRANS = 'N'; C T = XE*A', if TRANS = 'T'. C IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, N, ONE, XE, LDXE, A, LDA, $ ZERO, C, LDC ) ELSE CALL DGEMM( TR, NT, N, N, N, ONE, A, LDA, XE, LDXE, $ ZERO, C, LDC ) END IF C ELSE C C First, compute in DWORK C W = X*E, if TRANS = 'N'; C W = E*X, if TRANS = 'T'. C C Workspace: N*N. C CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, E, LDE, $ ZERO, DWORK, N ) C C Compute in C C T = A'*W, if TRANS = 'N'; C T = W*A', if TRANS = 'T'. C IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, N, ONE, DWORK, N, A, LDA, $ ZERO, C, LDC ) ELSE CALL DGEMM( TR, NT, N, N, N, ONE, A, LDA, DWORK, N, $ ZERO, C, LDC ) END IF C END IF C ELSE C C Compute in C C T = X*A, if TRANS = 'N'; C T = A*X, if TRANS = 'T'. C CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, A, LDA, ZERO, $ C, LDC ) C END IF C C Compute the norm of T. C NORMS(1) = DLANGE( 'F-norm', N, N, C, LDC, DWORK ) C C Compute Q + T + T' in R. C IF ( LUPLO ) THEN C DO 170 J = 1, N CALL DAXPY( J, ONE, C(1,J), 1, R(1,J), 1 ) CALL DAXPY( J, ONE, C(J,1), LDC, R(1,J), 1 ) 170 CONTINUE C ELSE C DO 180 J = 1, N CALL DAXPY( N-J+1, ONE, C(J,J), 1, R(J,J), 1 ) CALL DAXPY( N-J+1, ONE, C(J,J), LDC, R(J,J), 1 ) 180 CONTINUE C END IF C IF ( LJOBL ) THEN C C Compute F*F' or H*K in C and its norm. C IF ( LJOBF ) THEN C CALL DSYRK( UPLO, NT, N, M, ONE, F, LDF, ZERO, C, $ LDC ) ELSE C CALL MB01RB( 'Left', UPLO, NT, N, M, ZERO, ONE, C, $ LDC, F, LDF, K, LDK, INFO ) END IF C NORMS(2) = DLANSY( 'F-norm', UPLO, N, C, LDC, DWORK ) C C Update R := R +/- F*F' or R := R +/- op(H*K). C IF ( LUPLO ) THEN C DO 190 J = 1, N CALL DAXPY( J, BETA, C(1,J), 1, R(1,J), 1 ) 190 CONTINUE C ELSE C DO 200 J = 1, N CALL DAXPY( N-J+1, BETA, C(J,J), 1, R(J,J), 1 ) 200 CONTINUE C END IF C C Compute op(C) = A +/- op(D*F') or op(C) = A +/- op(B*K). C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C IF ( LJOBF ) THEN IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, M, BETA, F, LDF, G, LDG, $ ONE, C, LDC ) ELSE CALL DGEMM( NT, TR, N, N, M, BETA, G, LDG, F, LDF, $ ONE, C, LDC ) END IF C ELSE C IF ( LTRANS ) THEN CALL DGEMM( TR, TR, N, N, M, BETA, K, LDK, G, LDG, $ ONE, C, LDC ) ELSE CALL DGEMM( NT, NT, N, N, M, BETA, G, LDG, K, LDK, $ ONE, C, LDC ) END IF C END IF C ELSE IF ( LJOBG ) THEN C IF ( LJOBE ) THEN C C Compute V = op(E)'*X*G*X*op(E) in C, C V = W'*G*W, if TRANS = 'N'; C V = W*G*W', if TRANS = 'T'. C First, compute in DWORK(WP) C Z = G*W, if TRANS = 'N'; C Z = W*G, if TRANS = 'T'. C C Workspace: 2*N*N. C CALL DSYMM( SIDE, UPLO, N, N, ONE, G, LDG, DWORK, N, $ ZERO, DWORK(WP), N ) C C Then, compute in C the symmetric matrix V. C CALL MB01RB( SIDE, UPLO, TR, N, N, ZERO, ONE, C, LDC, $ DWORK, N, DWORK(WP), N, INFO ) I = WP C ELSE C C Compute V = X*G*X in C. C First, compute in DWORK C Z = G*X, if TRANS = 'N'; C Z = X*G, if TRANS = 'T'. C Then, compute in C the symmetric matrix V. C IF ( KEEPX ) THEN C C Copy the matrix X to DWORK(WP). C C Workspace: 2*N*N. C CALL DLACPY( UPLO, N, N, X, LDX, DWORK(WP), N ) CALL MA02ED( UPLO, N, DWORK(WP), N ) CALL DSYMM( SIDE, UPLO, N, N, ONE, G, LDG, $ DWORK(WP), N, ZERO, DWORK, N ) CALL MB01RB( SIDE, UPLO, TR, N, N, ZERO, ONE, C, $ LDC, DWORK(WP), N, DWORK, N, INFO ) ELSE C C Workspace: N*N. C CALL DSYMM( SIDE, UPLO, N, N, ONE, G, LDG, X, LDX, $ ZERO, DWORK, N ) CALL MB01RB( SIDE, UPLO, TR, N, N, ZERO, ONE, C, $ LDC, X, LDX, DWORK, N, INFO ) END IF C I = 1 END IF C C Compute the norm of V. C NORMS(2) = DLANSY( 'F-norm', UPLO, N, C, LDC, DWORK ) C C Update R := R +/- V. C IF ( LUPLO ) THEN C DO 210 J = 1, N CALL DAXPY( J, BETA, C(1,J), 1, R(1,J), 1 ) 210 CONTINUE C ELSE C DO 220 J = 1, N CALL DAXPY( N-J+1, BETA, C(J,J), 1, R(J,J), 1 ) 220 CONTINUE C END IF C C Compute op(C), op(C) = A +/- Z. C DO 230 J = 1, N CALL DCOPY( N, A(1,J), 1, C(1,J), 1 ) CALL DAXPY( N, BETA, DWORK(I), 1, C(1,J), 1 ) I = I + N 230 CONTINUE C ELSE IF ( M.GT.0 ) THEN C C Compute the matrix C V = op(E)'*X*D*D'*X*op(E), with D in array G. C IF ( USE1 ) THEN C C Workspace N*N + N*M (including for S'*S or S*S'). C IF ( LJOBE ) THEN C C Compute S = D'*W or S = W*D (stored in DWORK(WP)). C IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, DWORK, N, G, $ LDG, ZERO, DWORK(WP), N ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, G, LDG, DWORK, $ N, ZERO, DWORK(WP), M ) END IF C ELSE C C Compute S = X*D (stored in DWORK(WP)). C CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, G, $ LDG, ZERO, DWORK(WP), N ) END IF C C Compute V = S'*S or V = S*S' (in DWORK), and op(C). C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) IF ( UNITE .OR. LTRANS ) THEN CALL DSYRK( UPLO, NT, N, M, ONE, DWORK(WP), N, $ ZERO, DWORK, N ) IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, M, BETA, DWORK(WP), N, $ G, LDG, ONE, C, LDC ) ELSE CALL DGEMM( NT, TR, N, N, M, BETA, G, LDG, $ DWORK(WP), N, ONE, C, LDC ) END IF ELSE CALL DSYRK( UPLO, TR, N, M, ONE, DWORK(WP), M, $ ZERO, DWORK, N ) CALL DGEMM( NT, NT, N, N, M, BETA, G, LDG, $ DWORK(WP), M, ONE, C, LDC ) END IF C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK, N, $ DWORK ) C C Update R := R +/- op(E)'*X*D*D'*X*op(E). C I = 1 IF ( LUPLO ) THEN C DO 240 J = 1, N CALL DAXPY( J, BETA, DWORK(I), 1, R(1,J), 1 ) I = I + N 240 CONTINUE C ELSE C DO 250 J = 1, N CALL DAXPY( N-J+1, BETA, DWORK(I), 1, R(J,J), $ 1 ) I = I + N + 1 250 CONTINUE C END IF C ELSE C C Compute Y = D*D' in DWORK(WP) and compute in C C the following product (depending on TRANS): C Z = +/- Y*W | Z = +/- W*Y, if JOBE = 'G', or C Z = +/- op(Y*X), if JOBE = 'I'. C Then, compute T in DWORK(WP), C T = W'*Z | T = Z*W', if JOBE = 'G', or C T = X*Z | T = Z*X, if JOBE = 'I', C and its norm. Finally, update R and set op(C), C R = R + T; op(C) = A + Z. C C Workspace: (IA+1)*N*N. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, $ DWORK(WP), N ) C IF ( LJOBE ) THEN CALL DSYMM( SIDE, UPLO, N, N, BETA, DWORK(WP), N, $ DWORK, N, ZERO, C, LDC ) IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, N, ONE, C, LDC, DWORK, $ N, ZERO, DWORK(WP), N ) ELSE CALL DGEMM( TR, NT, N, N, N, ONE, DWORK, N, C, $ LDC, ZERO, DWORK(WP), N ) END IF ELSE CALL MA02ED( UPLO, N, DWORK, N ) CALL DSYMM( NSIDE, UPLO, N, N, BETA, X, LDX, $ DWORK, N, ZERO, C, LDC ) CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, C, LDC, $ ZERO, DWORK, N ) END IF C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK(WP), N, $ DWORK ) I = WP C IF ( LUPLO ) THEN C DO 260 J = 1, N CALL DAXPY( J, ONE, DWORK(I), 1, R(1,J), 1 ) I = I + N 260 CONTINUE C ELSE C DO 270 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK(I), 1, R(J,J), 1 ) I = I + N + 1 270 CONTINUE C END IF C DO 280 J = 1, N CALL DAXPY( N, ONE, A(1,J), 1, C(1,J), 1 ) 280 CONTINUE C END IF C ELSE C NORMS(2) = ZERO CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C END IF C END IF C ELSE IF ( LJOBB ) THEN C C JOB = 'B'. C IF ( DISCR ) THEN C IF ( LJOBE ) THEN C C Compute op(E)'*X*op(E) in DWORK and its norm. C C Workspace: 2*N*N. C CALL MB01RU( UPLO, NTRANS, N, N, ZERO, ONE, DWORK, N, E, $ LDE, X, LDX, DWORK(NN+1), NN, INFO ) C NORMS(3) = DLANSY( 'F-norm', UPLO, N, DWORK, N, DWORK ) C C Compute Q - op(E)'*X*op(E) in R. C I = 1 IF ( LUPLO ) THEN C DO 290 J = 1, N CALL DAXPY( J, -ONE, DWORK(I), 1, R(1,J), 1 ) I = I + N 290 CONTINUE C ELSE C DO 300 J = 1, N CALL DAXPY( N-J+1, -ONE, DWORK(I), 1, R(J,J), 1 ) I = I + N + 1 300 CONTINUE C END IF C ELSE C C Compute Q - X in R. C IF ( LUPLO ) THEN C DO 310 J = 1, N CALL DAXPY( J, -ONE, X(1,J), 1, R(1,J), 1 ) 310 CONTINUE C ELSE C DO 320 J = 1, N CALL DAXPY( N-J+1, -ONE, X(J,J), 1, R(J,J), 1 ) 320 CONTINUE C END IF C END IF C C Compute op(A)'*X*op(A) in DWORK and its norm. C IF ( LJOBL ) THEN C C Compute in DWORK the symmetric matrix C T = A'*XE, if TRANS = 'N'; C T = XE*A', if TRANS = 'T'. C C Workspace: N*N. C I = 1 CALL MB01RB( SIDE, UPLO, TR, N, N, ZERO, ONE, DWORK, N, $ A, LDA, XE, LDXE, INFO ) ELSE C IF ( USE1 ) THEN IW = 1 I = WP ELSE IW = WP I = 1 END IF C C First, compute W in DWORK(IW) C W = X*A, if TRANS = 'N'; C W = A*X, if TRANS = 'T'. C C Workspace: 2*N*N. C CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, A, LDA, ZERO, $ DWORK(IW), N ) C C Compute in DWORK(I) the symmetric matrix C T = A'*W, if TRANS = 'N'; C T = W*A', if TRANS = 'T'. C CALL MB01RB( SIDE, UPLO, TR, N, N, ZERO, ONE, DWORK(I), $ N, A, LDA, DWORK(IW), N, INFO ) END IF C NORMS(1) = DLANSY( 'F-norm', UPLO, N, DWORK(I), N, DWORK ) C C Update R := R + op(A)'*X*op(A). C IF ( LUPLO ) THEN C DO 330 J = 1, N CALL DAXPY( J, ONE, DWORK(I), 1, R(1,J), 1 ) I = I + N 330 CONTINUE C ELSE C DO 340 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK(I), 1, R(J,J), 1 ) I = I + N + 1 340 CONTINUE C END IF C IF ( LJOBL ) THEN C C Compute F*F' or H*K in DWORK and its norm. C C Workspace: N*N. C IF ( LJOBF ) THEN C CALL DSYRK( UPLO, NT, N, M, ONE, F, LDF, ZERO, DWORK, $ N ) C ELSE C CALL MB01RB( 'Left', UPLO, NT, N, M, ZERO, ONE, DWORK, $ N, F, LDF, K, LDK, INFO ) END IF C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK, N, DWORK ) C C Update R := R +/- F*F' or R := R +/- H*K. C I = 1 IF ( LUPLO ) THEN C DO 350 J = 1, N CALL DAXPY( J, BETA, DWORK(I), 1, R(1,J), 1 ) I = I + N 350 CONTINUE C ELSE C DO 360 J = 1, N CALL DAXPY( N-J+1, BETA, DWORK(I), 1, R(J,J), 1 ) I = I + N + 1 360 CONTINUE C END IF C ELSE IF ( LJOBG ) THEN C C Compute V = op(A)'*X*G*X*op(A) in DWORK and its norm, C using W in DWORK(IW). C C Workspace: 3*N*N. C CALL MB01RU( UPLO, NTRANS, N, N, ZERO, ONE, DWORK, N, $ DWORK(IW), N, G, LDG, DWORK(2*NN+1), NN, $ INFO ) C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK, N, DWORK ) C C Update R := R +/- op(A)'*X*G*X*op(A) = R + V. C I = 1 IF ( LUPLO ) THEN C DO 370 J = 1, N CALL DAXPY( J, BETA, DWORK(I), 1, R(1,J), 1 ) I = I + N 370 CONTINUE C ELSE C DO 380 J = 1, N CALL DAXPY( N-J+1, BETA, DWORK(I), 1, R(J,J), 1 ) I = I + N + 1 380 CONTINUE C END IF C ELSE IF ( M.GT.0 ) THEN C IF ( USE1 ) THEN C C Compute S = D'*W or S = W*D (stored in DWORK(WP)). C Then, compute C V = op(A)'*X*D*D'*X*op(A) (i.e., S'*S or S*S') C in DWORK, and compute its norm; D in stored in C array G. C C Workspace: N*N + N*M. C IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, DWORK, N, G, $ LDG, ZERO, DWORK(WP), N ) CALL DSYRK( UPLO, NT, N, M, ONE, DWORK(WP), N, $ ZERO, DWORK, N ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, G, LDG, $ DWORK, N, ZERO, DWORK(WP), M ) CALL DSYRK( UPLO, TR, N, M, ONE, DWORK(WP), M, $ ZERO, DWORK, N ) END IF C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK, N, $ DWORK ) C C Update R := R +/- op(A)'*X*D*D'*X*op(A) = R +/- V. C I = 1 IF ( LUPLO ) THEN C DO 390 J = 1, N CALL DAXPY( J, BETA, DWORK(I), 1, R(1,J), 1 ) I = I + N 390 CONTINUE C ELSE C DO 400 J = 1, N CALL DAXPY( N-J+1, BETA, DWORK(I), 1, R(J,J), 1) I = I + N + 1 400 CONTINUE C END IF C ELSE C C Compute Y = D*D' in DWORK. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, $ DWORK, N ) C C Compute V = op(A)'*X*Y*X*op(A), also in DWORK, and C its norm, using W in DWORK(IW). C C Workspace: 3*N*N. C CALL MB01RU( UPLO, NTRANS, N, N, ZERO, ONE, DWORK, N, $ DWORK(IW), N, DWORK, N, DWORK(2*NN+1), $ NN, INFO ) CALL DSCAL( N, ONE/TWO, DWORK, N+1 ) C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK, N, $ DWORK ) C C Update R, R = R +/- V. C I = 1 IF ( LUPLO ) THEN C DO 410 J = 1, N CALL DAXPY( J, BETA, DWORK(I), 1, R(1,J), 1 ) I = I + N 410 CONTINUE C ELSE C DO 420 J = 1, N CALL DAXPY( N-J+1, BETA, DWORK(I), 1, R(J,J), 1) I = I + N + 1 420 CONTINUE C END IF C END IF C ELSE C NORMS(2) = ZERO C END IF C ELSE C C Continuous-time case. C IF ( LJOBE ) THEN C C Compute C A'*X*E, if TRANS = 'N'; C E*X*A', if TRANS = 'T'. C IF ( LJOBL ) THEN C C Compute in DWORK C T = A'*XE, if TRANS = 'N'; C T = XE*A', if TRANS = 'T'. C C Workspace: N*N. C I = 1 IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, N, ONE, XE, LDXE, A, LDA, $ ZERO, DWORK, N ) ELSE CALL DGEMM( TR, NT, N, N, N, ONE, A, LDA, XE, LDXE, $ ZERO, DWORK, N ) END IF C ELSE C IF ( USE1 ) THEN IW = 1 I = WP ELSE IW = WP I = 1 END IF C C First, compute in DWORK(IW) C W = X*E, if TRANS = 'N'; C W = E*X, if TRANS = 'T'. C C Workspace: 2*N*N. C CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, E, LDE, $ ZERO, DWORK(IW), N ) C C Compute in DWORK(I) C T = A'*W, if TRANS = 'N'; C T = W*A', if TRANS = 'T'. C IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, N, ONE, DWORK(IW), N, A, $ LDA, ZERO, DWORK(I), N ) ELSE CALL DGEMM( TR, NT, N, N, N, ONE, A, LDA, $ DWORK(IW), N, ZERO, DWORK(I), N ) END IF C END IF C ELSE C C Compute in DWORK C T = X*A, if TRANS = 'N'; C T = A*X, if TRANS = 'T'. C C Workspace: N*N. C I = 1 CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, A, LDA, ZERO, $ DWORK, N ) C END IF C C Compute the norm of T. C NORMS(1) = DLANGE( 'F-norm', N, N, DWORK(I), N, DWORK ) C C Compute Q + T + T' in R. C IF ( LUPLO ) THEN L = I C DO 430 J = 1, N CALL DAXPY( J, ONE, DWORK(I), 1, R(1,J), 1 ) CALL DAXPY( J, ONE, DWORK(L), N, R(1,J), 1 ) I = I + N L = L + 1 430 CONTINUE C ELSE C DO 440 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK(I), 1, R(J,J), 1 ) CALL DAXPY( N-J+1, ONE, DWORK(I), N, R(J,J), 1 ) I = I + N + 1 440 CONTINUE C END IF C IF ( LJOBL ) THEN C C Compute F*F' or H*K in DWORK and its norm. C C Workspace: N*N. C IF ( LJOBF ) THEN C CALL DSYRK( UPLO, NT, N, M, ONE, F, LDF, ZERO, DWORK, $ N ) ELSE C CALL MB01RB( 'Left', UPLO, NT, N, M, ZERO, ONE, DWORK, $ N, F, LDF, K, LDK, INFO ) END IF C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK, N, DWORK ) C C Update R := R +/- F*F' or R := R +/- op(H*K). C I = 1 IF ( LUPLO ) THEN C DO 450 J = 1, N CALL DAXPY( J, BETA, DWORK(I), 1, R(1,J), 1 ) I = I + N 450 CONTINUE C ELSE C DO 460 J = 1, N CALL DAXPY( N-J+1, BETA, DWORK(I), 1, R(J,J), 1 ) I = I + N + 1 460 CONTINUE C END IF C ELSE IF ( LJOBG ) THEN C IF ( LJOBE ) THEN C C Compute V = op(E)'*X*G*X*op(E) in DWORK, using W C in DWORK(IW). C C Workspace: 3*N*N. C CALL MB01RU( UPLO, NTRANS, N, N, ZERO, ONE, DWORK, $ N, DWORK(IW), N, G, LDG, DWORK(2*NN+1), $ NN, INFO ) C ELSE C C Compute V = X*G*X in DWORK. C IF ( KEEPX ) THEN C C Copy the matrix X to DWORK(WP) and compute V. C C Workspace: 3*N*N. C CALL DLACPY( UPLO, N, N, X, LDX, DWORK(WP), N ) CALL MA02ED( UPLO, N, DWORK(WP), N ) CALL MB01RU( UPLO, NTRANS, N, N, ZERO, ONE, DWORK, $ N, DWORK(WP), N, G, LDG, $ DWORK(2*NN+1), NN, INFO ) ELSE C C Compute in DWORK the symmetric matrix V. C C Workspace: 2*N*N. C CALL MB01RU( UPLO, NTRANS, N, N, ZERO, ONE, DWORK, $ N, X, LDX, G, LDG, DWORK(NN+1), NN, $ INFO ) END IF C END IF C C Compute the norm of V. C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK, N, DWORK ) C C Update R := R +/- V. C I = 1 IF ( LUPLO ) THEN C DO 470 J = 1, N CALL DAXPY( J, BETA, DWORK(I), 1, R(1,J), 1 ) I = I + N 470 CONTINUE C ELSE C DO 480 J = 1, N CALL DAXPY( N-J+1, BETA, DWORK(I), 1, R(J,J), 1 ) I = I + N + 1 480 CONTINUE C END IF C ELSE IF ( M.GT.0 ) THEN C C Compute the matrix C V = op(E)'*X*D*D'*X*op(E), with D in array G. C IF ( USE1 ) THEN C C Workspace N*N + N*M (including for S'*S or S*S'). C IF ( LJOBE ) THEN C C Compute S = D'*W or S = W*D (stored in DWORK(WP)). C IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, DWORK, N, G, $ LDG, ZERO, DWORK(WP), N ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, G, LDG, $ DWORK, N, ZERO, DWORK(WP), M ) END IF C ELSE C C Compute S = X*D (stored in DWORK(WP)). C CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, G, $ LDG, ZERO, DWORK(WP), N ) END IF C C Compute V = S'*S or V = S*S' (in DWORK). C IF ( UNITE .OR. LTRANS ) THEN CALL DSYRK( UPLO, NT, N, M, ONE, DWORK(WP), N, $ ZERO, DWORK, N ) ELSE CALL DSYRK( UPLO, TR, N, M, ONE, DWORK(WP), M, $ ZERO, DWORK, N ) END IF C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK, N, $ DWORK ) C C Update R := R +/- op(E)'*X*D*D'*X*op(E). C I = 1 IF ( LUPLO ) THEN C DO 490 J = 1, N CALL DAXPY( J, BETA, DWORK(I), 1, R(1,J), 1 ) I = I + N 490 CONTINUE C ELSE C DO 500 J = 1, N CALL DAXPY( N-J+1, BETA, DWORK(I), 1, R(J,J), $ 1 ) I = I + N + 1 500 CONTINUE C END IF C ELSE C C Compute Y = D*D' in DWORK and compute also in DWORK C the following product (depending on TRANS): C T = +/- W'*Y*W | T = +/- W*Y*W', if JOBE = 'G', or C T = +/- X*Y*X, if JOBE = 'I', C and its norm. Finally, update R, C R = R + T. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, DWORK, $ N ) C IF ( LJOBE ) THEN C C Workspace: 3*N*N. C CALL MB01RU( UPLO, NTRANS, N, N, ZERO, BETA, DWORK, $ N, DWORK(IW), N, DWORK, N, $ DWORK(2*NN+1), NN, INFO ) CALL DSCAL( N, ONE/TWO, DWORK, N+1 ) C ELSE IF ( LDWORK.GE.3*NN ) THEN C C Workspace: 3*N*N. C CALL DLACPY( UPLO, N, N, X, LDX, DWORK(NN+1), N ) CALL MA02ED( UPLO, N, DWORK(NN+1), N ) CALL MB01RU( UPLO, NTRANS, N, N, ZERO, BETA, DWORK, $ N, DWORK(NN+1), N, DWORK, N, $ DWORK(2*NN+1), NN, INFO ) CALL DSCAL( N, ONE/TWO, DWORK, N+1 ) C ELSE C C Workspace: 2*N*N. C CALL MA02ED( UPLO, N, DWORK, N ) CALL DSYMM( NSIDE, UPLO, N, N, BETA, X, LDX, $ DWORK, N, ZERO, DWORK(NN+1), N ) CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, $ DWORK(NN+1), N, ZERO, DWORK, N ) END IF C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK, N, $ DWORK ) I = 1 C IF ( LUPLO ) THEN C DO 510 J = 1, N CALL DAXPY( J, ONE, DWORK(I), 1, R(1,J), 1 ) I = I + N 510 CONTINUE C ELSE C DO 520 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK(I), 1, R(J,J), 1 ) I = I + N + 1 520 CONTINUE C END IF C END IF C ELSE C NORMS(2) = ZERO C END IF C END IF C ELSE C C JOB <> 'N' and JOB <> 'B'. C IF ( DISCR ) THEN C C Discrete-time case. C IF ( LJOBL ) THEN C C Using F or H and K (JOBG = 'F' or 'H'). C IF ( NLJOBC ) THEN C C Start to compute the residual: C R = Q + op(A)'*X*op(A); C R := R - op(E)'*X*op(E), if JOBE = 'G'. C CALL MB01RB( SIDE, UPLO, TR, N, N, ONE, ONE, R, LDR, $ A, LDA, XE, LDXE, INFO ) C IF ( LJOBE ) THEN IF ( LJOBR ) THEN C C Workspace: N*N. C CALL MB01RU( UPLO, NTRANS, N, N, ONE, -ONE, R, $ LDR, E, LDE, X, LDX, DWORK, NN, $ INFO ) ELSE C C Use C as workspace. C CALL MB01RU( UPLO, NTRANS, N, N, ONE, -ONE, R, $ LDR, E, LDE, X, LDX, C, NN, INFO ) END IF END IF C IF ( LJOBF ) THEN C C Add/subtract F*F' to/from R. C CALL DSYRK( UPLO, NT, N, M, BETA, F, LDF, ONE, R, $ LDR ) ELSE C C Add/subtract H*K to/from R. C CALL MB01RB( 'Left', UPLO, NT, N, M, ONE, BETA, R, $ LDR, F, LDF, K, LDK, INFO ) END IF END IF C IF ( NLJOBR ) THEN C C Compute op(C) = A +/- op(D*F') or C op(C) = A +/- op(B*K). C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C IF ( LJOBF ) THEN IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, M, BETA, F, LDF, G, $ LDG, ONE, C, LDC ) ELSE CALL DGEMM( NT, TR, N, N, M, BETA, G, LDG, F, $ LDF, ONE, C, LDC ) END IF C ELSE IF ( LTRANS ) THEN CALL DGEMM( TR, TR, N, N, M, BETA, K, LDK, G, $ LDG, ONE, C, LDC ) ELSE CALL DGEMM( NT, NT, N, N, M, BETA, G, LDG, K, $ LDK, ONE, C, LDC ) END IF END IF C END IF C ELSE C C Usual case (JOBG = 'G' or JOBG = 'D'). C USEC = LJOBA .AND. USE1 C IF ( USEC ) THEN C C Compute in C C W = X*A, if TRANS = 'N'; C W = A*X, if TRANS = 'T'. C CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, A, LDA, $ ZERO, C, LDC ) C ELSE IF ( NLJOBC .OR. LJOBG .OR. USEOPT ) THEN C C Compute in DWORK C W = X*A, if TRANS = 'N'; C W = A*X, if TRANS = 'T'. C C Workspace: N*N. C CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, A, LDA, $ ZERO, DWORK, N ) END IF C IF ( LJOBC ) THEN C IF ( LJOBG ) THEN C C Compute op(C) = A +/- op(G*W): C C Workspace: N*N. C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) CALL DSYMM( SIDE, UPLO, N, N, BETA, G, LDG, DWORK, $ N, ONE, C, LDC ) C ELSE IF ( M.EQ.0 ) THEN C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C ELSE IF ( USE1 ) THEN C C Compute X*D in C. C CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, G, $ LDG, ZERO, C, LDC ) C C Compute in DWORK C D'*X*A ( TRANS = 'N' ) or C A*X*D ( TRANS = 'T' ). C Then, compute op(C). C C Workspace: N*M. C IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, A, LDA, C, $ LDC, ZERO, DWORK, N ) CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) CALL DGEMM( NT, TR, N, N, M, BETA, DWORK, N, G, $ LDG, ONE, C, LDC ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, C, LDC, A, $ LDA, ZERO, DWORK, M ) CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) CALL DGEMM( NT, NT, N, N, M, BETA, G, LDG, $ DWORK, M, ONE, C, LDC ) END IF C ELSE IF ( USEOPT ) THEN C C Compute D*D' in DWORK(WP) and then compute op(C). C C Workspace: 2*N*N. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, $ DWORK(WP), N ) CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) CALL DSYMM( SIDE, UPLO, N, N, BETA, DWORK(WP), N, $ DWORK, N, ONE, C, LDC ) ELSE C C Compute D*D' in C, and C T = D*D'*X ( TRANS = 'N' ) or C T = X*D*D' ( TRANS = 'T' ), C in DWORK. Then, compute op(C). C C Workspace: N*N. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, C, $ LDC ) CALL MA02ED( UPLO, N, C, LDC ) CALL DSYMM( NSIDE, UPLO, N, N, ONE, X, LDX, C, $ LDC, ZERO, DWORK, N ) C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, N, N, BETA, A, LDA, $ DWORK, N, ONE, C, LDC ) ELSE CALL DGEMM( NT, NT, N, N, N, BETA, DWORK, N, A, $ LDA, ONE, C, LDC ) END IF C END IF C ELSE C C Compute in R the symmetric matrix C R = Q + A'*W, if TRANS = 'N'; C R = Q + W*A', if TRANS = 'T'. C IF ( USEC ) THEN C CALL MB01RB( SIDE, UPLO, TR, N, N, ONE, ONE, R, $ LDR, A, LDA, C, LDC, INFO ) ELSE C C Workspace: N*N. C CALL MB01RB( SIDE, UPLO, TR, N, N, ONE, ONE, R, $ LDR, A, LDA, DWORK, N, INFO ) END IF C IF ( LJOBG ) THEN C IF ( LJOBR ) THEN C C Add/subtract V = op(A)'*X*G*X*op(A) to/from R. C C Workspace: 2*N*N. C CALL MB01RU( UPLO, NTRANS, N, N, ONE, BETA, R, $ LDR, DWORK, N, G, LDG, DWORK(WP), $ NN, INFO ) ELSE C C Compute in C the following product: C Z = +/- G*W ( TRANS = 'N' ) or C Z = +/- W*G ( TRANS = 'T' ). C C Workspace: N*N. C CALL DSYMM( SIDE, UPLO, N, N, BETA, G, LDG, $ DWORK, N, ZERO, C, LDC ) C C Add V to R, with C V = W'*Z ( TRANS = 'N' ) C V = Z*W' ( TRANS = 'T' ). C CALL MB01RB( SIDE, UPLO, TR, N, N, ONE, ONE, R, $ LDR, DWORK, N, C, LDC, INFO ) C C Compute op(C) = A + Z. C DO 530 J = 1, N CALL DAXPY( N, ONE, A(1,J), 1, C(1,J), 1 ) 530 CONTINUE C END IF C ELSE IF ( M.GT.0 ) THEN C IF ( LJOBR ) THEN C IF ( USE1 ) THEN C C Compute in DWORK(WP) the following product: C S = D'*W ( TRANS = 'N' ) or C S = W*D ( TRANS = 'T' ). C Then add/subtract V = S'*S or S*S' to/from R. C C Workspace: N*N + N*M. C IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, DWORK, $ N, G, LDG, ZERO, DWORK(WP), $ N ) CALL DSYRK( UPLO, NT, N, M, BETA, $ DWORK(WP), N, ONE, R, LDR ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, G, LDG, $ DWORK, N, ZERO, DWORK(WP), M ) CALL DSYRK( UPLO, TR, N, M, BETA, $ DWORK(WP), M, ONE, R, LDR ) END IF C ELSE C C Compute D*D' in DWORK(WP) and then update R. C C Workspace: 3*N*N. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, $ ZERO, DWORK(WP), N ) CALL MB01RU( UPLO, NTRANS, N, N, ONE, BETA, $ R, LDR, DWORK, N, DWORK(WP), N, $ DWORK(WP+NN), NN, INFO ) END IF C ELSE C IF ( USEC ) THEN C C Compute in DWORK the following product: C S = D'*W ( TRANS = 'N' ) or C S = W*D ( TRANS = 'T' ). C Then, add/subtract V = S'*S or V = S*S' C to/from R, and compute C op(C) = A +/- D*S ( TRANS = 'N' ) or C op(C) = A +/- S*D' ( TRANS = 'T' ). C C Workspace: N*M. C IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, C, LDC, $ G, LDG, ZERO, DWORK, N ) CALL DSYRK( UPLO, NT, N, M, BETA, DWORK, $ N, ONE, R, LDR ) CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) CALL DGEMM( NT, TR, N, N, M, BETA, DWORK, $ N, G, LDG, ONE, C, LDC ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, G, LDG, $ C, LDC, ZERO, DWORK, M ) CALL DSYRK( UPLO, TR, N, M, BETA, DWORK, $ M, ONE, R, LDR ) CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) CALL DGEMM( NT, NT, N, N, M, BETA, G, $ LDG, DWORK, M, ONE, C, LDC ) END IF C ELSE C C Compute Y = D*D' in DWORK(WP), and Z in C, C Z = +/- Y*W ( TRANS = 'N' ) or C Z = +/- W*Y ( TRANS = 'T' ). C C Workspace: 2*N*N. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, $ ZERO, DWORK(WP), N ) C CALL DSYMM( SIDE, UPLO, N, N, BETA, $ DWORK(WP), N, DWORK, N, ZERO, C, $ LDC ) C C Update R, C R = R + W'*Z, if TRANS = 'N'; C R = R + Z*W', if TRANS = 'T'. C CALL MB01RB( SIDE, UPLO, TR, N, N, ONE, ONE, $ R, LDR, DWORK, N, C, LDC, INFO ) C C Compute op(C) = A + Z. C DO 540 J = 1, N CALL DAXPY( N, ONE, A(1,J), 1, C(1,J), 1 ) 540 CONTINUE C END IF C END IF C ELSE IF ( NLJOBR ) THEN C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C END IF C END IF C END IF C IF ( NLJOBC ) THEN C IF ( UNITE ) THEN C C Subtract X from R. C IF ( LUPLO ) THEN C DO 550 J = 1, N CALL DAXPY( J, -ONE, X(1,J), 1, R(1,J), 1 ) 550 CONTINUE C ELSE C DO 560 J = 1, N CALL DAXPY( N-J+1, -ONE, X(J,J), 1, R(J,J), 1 ) 560 CONTINUE C END IF C ELSE IF ( .NOT.LJOBL ) THEN C C Subtract op(E)'*X*op(E) from R. C C Workspace: N*N. C CALL MB01RU( UPLO, NTRANS, N, N, ONE, -ONE, R, LDR, $ E, LDE, X, LDX, DWORK, NN, INFO ) END IF C END IF C ELSE C C Continuous-time case. C USEC = LJOBA .AND. USE1 FULLX = UNITE .AND. .NOT.KEEPX C IF ( LJOBE .AND. .NOT.LJOBL ) THEN C IF ( USEC ) THEN C C Compute the following product, stored in C: C W = X*E ( TRANS = 'N' ) or W = E*X ( TRANS = 'T' ). C CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, E, LDE, $ ZERO, C, LDC ) C ELSE IF ( LJOBG .OR. NLJOBC ) THEN C C Compute W above in DWORK(WP). C C Workspace: WP+N*N-1. C CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, E, LDE, $ ZERO, DWORK(WP), N ) END IF C ELSE IF ( USEC ) THEN IF ( KEEPX ) THEN CALL DLACPY( UPLO, N, N, X, LDX, C, LDC ) CALL MA02ED( UPLO, N, C, LDC ) END IF END IF C IF ( LJOBL ) THEN C IF ( NLJOBC ) THEN C C Compute Q + T + T' in the array R, where C T = A'*W or T = A'*X ( TRANS = 'N' ) C or C T = A*W' or T = A*X ( TRANS = 'T' ). C IF ( FULLX ) THEN C CALL DSYR2K( UPLO, NTRANS, N, N, ONE, A, LDA, X, $ LDX, ONE, R, LDR ) C ELSE IF ( UNITE ) THEN C IF ( LJOBR ) THEN C C Copy the matrix X to DWORK. C C Workspace: N*N. C CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) CALL MA02ED( UPLO, N, DWORK, N ) CALL DSYR2K( UPLO, NTRANS, N, N, ONE, A, LDA, $ DWORK, N, ONE, R, LDR ) ELSE C C Copy the matrix X to C. C CALL DLACPY( UPLO, N, N, X, LDX, C, LDC ) CALL MA02ED( UPLO, N, C, LDC ) CALL DSYR2K( UPLO, NTRANS, N, N, ONE, A, LDA, C, $ LDC, ONE, R, LDR ) END IF C ELSE C CALL DSYR2K( UPLO, NTRANS, N, N, ONE, A, LDA, XE, $ LDXE, ONE, R, LDR ) END IF C C Add/subtract F*F' or H*K to/from R. C IF ( LJOBF ) THEN CALL DSYRK( UPLO, NT, N, M, BETA, F, LDF, ONE, R, $ LDR ) ELSE CALL MB01RB( 'Left', UPLO, NT, N, M, ONE, BETA, R, $ LDR, F, LDF, K, LDK, INFO ) END IF END IF C IF ( NLJOBR ) THEN C C Compute op(C) = A +/- op(D*F') or C op(C) = A +/- op(B*K). C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C IF ( LJOBF ) THEN IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, M, BETA, F, LDF, G, $ LDG, ONE, C, LDC ) ELSE CALL DGEMM( NT, TR, N, N, M, BETA, G, LDG, F, $ LDF, ONE, C, LDC ) END IF C ELSE C IF ( LTRANS ) THEN CALL DGEMM( TR, TR, N, N, M, BETA, K, LDK, G, $ LDG, ONE, C, LDC ) ELSE CALL DGEMM( NT, NT, N, N, M, BETA, G, LDG, K, $ LDK, ONE, C, LDC ) END IF C END IF C END IF C ELSE C IF ( LJOBC ) THEN C C Compute op(C) = A +/- op(G*W) or op(C) = A +/- op(G*X) C IF ( LJOBG ) THEN C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C IF ( FULLX ) THEN C CALL DSYMM( SIDE, UPLO, N, N, BETA, G, LDG, X, $ LDX, ONE, C, LDC ) ELSE C IF ( UNITE ) THEN C C Copy the matrix X to DWORK. C C Workspace: N*N. C CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) CALL MA02ED( UPLO, N, DWORK, N ) END IF C CALL DSYMM( SIDE, UPLO, N, N, BETA, G, LDG, $ DWORK, N, ONE, C, LDC ) END IF C ELSE IF ( M.EQ.0 ) THEN C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C ELSE IF ( LJOBE ) THEN C IF ( USE1 ) THEN C C Compute X*D in C. C CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, G, $ LDG, ZERO, C, LDC ) C C Compute in DWORK C W = D'*X*E ( TRANS = 'N' ) or C W = E*X*D ( TRANS = 'T' ). C Then, compute C op(C) = A +/- D*W ( TRANS = 'N' ) or C op(C) = A +/- W*D' ( TRANS = 'T' ). C C Workspace: N*M. C IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, E, LDE, C, $ LDC, ZERO, DWORK, N ) CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) CALL DGEMM( NT, TR, N, N, M, BETA, DWORK, N, $ G, LDG, ONE, C, LDC ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, C, LDC, E, $ LDE, ZERO, DWORK, M ) CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) CALL DGEMM( NT, NT, N, N, M, BETA, G, LDG, $ DWORK, M, ONE, C, LDC ) END IF C ELSE C C Compute Y = D*D' in C, Y*X or X*Y in DWORK, and C then compute op(C). C C Workspace: N*N. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, $ C, LDC ) CALL MA02ED( UPLO, N, C, LDC ) CALL DSYMM( NSIDE, UPLO, N, N, ONE, X, LDX, C, $ LDC, ZERO, DWORK, N ) CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, N, N, BETA, E, LDE, $ DWORK, N, ONE, C, LDC ) ELSE CALL DGEMM( NT, NT, N, N, N, BETA, DWORK, N, $ E, LDE, ONE, C, LDC ) END IF C END IF C ELSE C CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C IF ( USE1 ) THEN C C Compute S = X*D in DWORK. C C Workspace: N*M. C CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, G, $ LDG, ZERO, DWORK, N ) C C Compute C op(C) = A +/- D*S' ( TRANS = 'N' ) or C op(C) = A +/- S*D' ( TRANS = 'T' ). C IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, M, BETA, DWORK, N, $ G, LDG, ONE, C, LDC ) ELSE CALL DGEMM( NT, TR, N, N, M, BETA, G, LDG, $ DWORK, N, ONE, C, LDC ) END IF C ELSE C C Compute D*D' in DWORK and then compute op(C). C C Workspace: N*N. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, $ DWORK, N ) CALL MA02ED( UPLO, N, DWORK, N ) CALL DSYMM( NSIDE, UPLO, N, N, BETA, X, LDX, $ DWORK, N, ONE, C, LDC ) END IF C END IF C ELSE C C Compute R (and op(C)). Start computation of R. C IF ( USEATW ) THEN C C Compute Q + T' + T in the array R, where C T = A'*W or T = A'*X ( TRANS = 'N' ) C or C T = A*W' or T = A*X ( TRANS = 'T' ). C IF ( FULLX ) THEN C CALL DSYR2K( UPLO, NTRANS, N, N, ONE, A, LDA, X, $ LDX, ONE, R, LDR ) C ELSE IF ( USEC ) THEN C CALL DSYR2K( UPLO, NTRANS, N, N, ONE, A, LDA, C, $ LDC, ONE, R, LDR ) ELSE C IF ( UNITE ) THEN C C Copy the matrix X to DWORK(WP). C C Workspace: WP+N*N-1. C CALL DLACPY( UPLO, N, N, X, LDX, DWORK(WP), $ N ) CALL MA02ED( UPLO, N, DWORK(WP), N ) END IF C CALL DSYR2K( UPLO, NTRANS, N, N, ONE, A, LDA, $ DWORK(WP), N, ONE, R, LDR ) END IF C END IF C ALPHA = BETA/TWO C IF ( LJOBG ) THEN C IF ( LJOBR ) THEN C C Compute R only. C Compute in DWORK the following matrix: C Z = A +/- 0.5*G*W | Z = A +/- 0.5*W*G C if JOBE = 'G', or C Z = A +/- 0.5*op(G*X), if JOBE = 'I'. C Then, similarly compute R: C R = Q + W'*Z + Z'*W | R = Q + W*Z' + Z*W' or C R = Q + Z'*X + X*Z | R = Q + Z*X + X*Z'. C CALL DLACPY( 'All', N, N, A, LDA, DWORK, N ) C IF ( FULLX ) THEN C C Workspace: N*N. C CALL DSYMM( SIDE, UPLO, N, N, ALPHA, G, LDG, $ X, LDX, ONE, DWORK, N ) CALL DSYR2K( UPLO, NTRANS, N, N, ONE, DWORK, $ N, X, LDX, ONE, R, LDR ) ELSE C IF ( UNITE ) THEN C C Copy the matrix X to DWORK(WP). C C Workspace: 2*N*N. C CALL DLACPY( UPLO, N, N, X, LDX, $ DWORK(WP), N ) CALL MA02ED( UPLO, N, DWORK(WP), N ) END IF C CALL DSYMM( SIDE, UPLO, N, N, ALPHA, G, LDG, $ DWORK(WP), N, ONE, DWORK, N ) CALL DSYR2K( UPLO, NTRANS, N, N, ONE, DWORK, $ N, DWORK(WP), N, ONE, R, LDR ) END IF C ELSE C C Compute R and op(C). C IF ( LDWORK.LT.OPTWRK ) THEN C IF ( FULLX ) THEN C CALL DSYMM( SIDE, UPLO, N, N, BETA, G, $ LDG, X, LDX, ZERO, C, LDC ) CALL MB01RB( SIDE, UPLO, NT, N, N, ONE, $ ONE, R, LDR, X, LDX, C, LDC, $ INFO ) ELSE C IF ( UNITE ) THEN C C Copy the matrix X to DWORK(WP). C C Workspace: 2*N*N. C CALL DLACPY( UPLO, N, N, X, LDX, $ DWORK(WP), N ) CALL MA02ED( UPLO, N, DWORK(WP), N ) END IF C CALL DSYMM( SIDE, UPLO, N, N, BETA, G, $ LDG, DWORK(WP), N, ZERO, C, $ LDC ) CALL MB01RB( SIDE, UPLO, TR, N, N, ONE, $ ONE, R, LDR, DWORK(WP), N, C, $ LDC, INFO ) END IF C C Compute op(C) = A + C. C DO 570 J = 1, N CALL DAXPY( N, ONE, A(1,J), 1, C(1,J), 1 ) 570 CONTINUE C ELSE C C Compute in DWORK the following matrix: C Z = A +/- 0.5*G*W | Z = A +/- 0.5*W*G or C Z = A +/- 0.5*op(G*X). C This is done in two steps, allowing to C get op(C). Then, compute R: C R = Q + W'*Z + Z'*W | R = Q + W*Z' + Z*W'; C R = Q + Z'*X + X*Z | R = Q + Z*X + X*Z'. C I = 1 IF ( FULLX ) THEN C C Workspace: N*N. C CALL DSYMM( SIDE, UPLO, N, N, ALPHA, G, $ LDG, X, LDX, ZERO, DWORK, N ) C C Compute op(C) = A + 2*Z and Z := A + Z. C DO 580 J = 1, N CALL DCOPY( N, A(1,J), 1, C(1,J), 1 ) CALL DAXPY( N, TWO, DWORK(I), 1, $ C(1,J), 1 ) CALL DAXPY( N, ONE, A(1,J), 1, $ DWORK(I), 1 ) I = I + N 580 CONTINUE C CALL DSYR2K( UPLO, NTRANS, N, N, ONE, $ DWORK, N, X, LDX, ONE, R, $ LDR ) ELSE C IF ( UNITE ) THEN C C Copy the matrix X to DWORK(WP). C C Workspace: 2*N*N. C CALL DLACPY( UPLO, N, N, X, LDX, $ DWORK(WP), N ) CALL MA02ED( UPLO, N, DWORK(WP), N ) END IF C CALL DSYMM( SIDE, UPLO, N, N, ALPHA, G, $ LDG, DWORK(WP), N, ZERO, $ DWORK, N ) C C Compute op(C) = A + 2*Z and Z := A + Z. C DO 590 J = 1, N CALL DCOPY( N, A(1,J), 1, C(1,J), 1 ) CALL DAXPY( N, TWO, DWORK(I), 1, $ C(1,J), 1 ) CALL DAXPY( N, ONE, A(1,J), 1, $ DWORK(I), 1 ) I = I + N 590 CONTINUE C CALL DSYR2K( UPLO, NTRANS, N, N, ONE, $ DWORK, N, DWORK(WP), N, ONE, $ R, LDR ) END IF C END IF C END IF C ELSE IF ( M.EQ.0 ) THEN C IF ( NLJOBR ) $ CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) C ELSE C C Use D. C IF ( LJOBR ) THEN C C Compute R only. C IF ( USEATW ) THEN C IF ( LJOBE ) THEN C C Compute in DWORK C S = D'*W or S = W*D (TRANS = 'N' or 'T'). C C Workspace: N*N + N*M. C IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, $ DWORK(WP), N, G, LDG, ZERO, $ DWORK, N ) J = N ELSE CALL DGEMM( TR, NT, M, N, N, ONE, G, $ LDG, DWORK(WP), N, ZERO, $ DWORK, M ) J = M END IF C C Update R = R +/- S'*S or R = R +/- S*S'. C CALL DSYRK( UPLO, NTRANS, N, M, BETA, $ DWORK, J, ONE, R, LDR ) ELSE C C Compute S = X*D in DWORK. C C Workspace: N*M. C CALL DSYMM( 'Left', UPLO, N, M, ONE, X, $ LDX, G, LDG, ZERO, DWORK, N ) C C Update R = R +/- S*S'. C CALL DSYRK( UPLO, NT, N, M, BETA, DWORK, $ N, ONE, R, LDR ) END IF C ELSE C C Compute Y = D*D' in DWORK(YP) and compute C in DWORK the following matrix: C Z = A +/- 0.5*Y*W | Z = A +/- 0.5*W*Y, or C Z = A +/- 0.5*op(Y*X). C Then, compute R: C R = Q + W'*Z + Z'*W | R = Q + W*Z' + Z*W'; C R = Q + Z'*X + X*Z | R = Q + Z*X + X*Z'. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, $ ZERO, DWORK(YP), N ) CALL DLACPY( 'All', N, N, A, LDA, DWORK, N ) C IF ( FULLX ) THEN C C Workspace: 2*N*N. C CALL DSYMM( SIDE, UPLO, N, N, ALPHA, $ DWORK(YP), N, X, LDX, ONE, $ DWORK, N ) CALL DSYR2K( UPLO, NTRANS, N, N, ONE, $ DWORK, N, X, LDX, ONE, R, $ LDR ) ELSE C C Workspace: 3*N*N. C IF ( UNITE ) THEN C C Copy the matrix X to DWORK(WP). C CALL DLACPY( UPLO, N, N, X, LDX, $ DWORK(WP), N ) CALL MA02ED( UPLO, N, DWORK(WP), N ) END IF C CALL DSYMM( SIDE, UPLO, N, N, ALPHA, $ DWORK(YP), N, DWORK(WP), N, $ ONE, DWORK, N ) CALL DSYR2K( UPLO, NTRANS, N, N, ONE, $ DWORK, N, DWORK(WP), N, ONE, $ R, LDR ) END IF C END IF C ELSE C C Compute R and op(C). C IF ( USE1 ) THEN C C Workspace: N*M. C IF ( LJOBE ) THEN C C Compute S in DWORK C S = D'*C | S = C*D (TRANS = 'N' or 'T'), C op(C) = A +/- D*S | op(C) = A +/- S*D', C and update R, C R = R +/- S'*S | R = R +/- S*S'. C IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, C, $ LDC, G, LDG, ZERO, DWORK, $ N ) CALL DLACPY( 'All', N, N, A, LDA, C, $ LDC ) CALL DGEMM( NT, TR, N, N, M, BETA, $ DWORK, N, G, LDG, ONE, C, $ LDC ) CALL DSYRK( UPLO, NT, N, M, BETA, $ DWORK, N, ONE, R, LDR ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, G, $ LDG, C, LDC, ZERO, DWORK, $ M ) CALL DLACPY( 'All', N, N, A, LDA, C, $ LDC ) CALL DGEMM( NT, NT, N, N, M, BETA, G, $ LDG, DWORK, M, ONE, C, $ LDC ) CALL DSYRK( UPLO, TR, N, M, BETA, $ DWORK, M, ONE, R, LDR ) END IF C ELSE C C Compute S = X*D in DWORK, C op(C) = A +/- op(D*S'), C and update R, R = R +/- S*S'. C CALL DSYMM( 'Left', UPLO, N, M, ONE, X, $ LDX, G, LDG, ZERO, DWORK, N ) CALL DLACPY( 'All', N, N, A, LDA, C, LDC ) IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, M, BETA, $ DWORK, N, G, LDG, ONE, C, $ LDC ) ELSE CALL DGEMM( NT, TR, N, N, M, BETA, G, $ LDG, DWORK, N, ONE, C, $ LDC ) END IF CALL DSYRK( UPLO, NT, N, M, BETA, DWORK, $ N, ONE, R, LDR ) END IF C ELSE IF ( LCNDS ) THEN C C Compute in C C S = D'*W | S = W*D (JOBE = 'G'), or C S = X*D (JOBE = 'I'), C and similarly compute in DWORK the product C Z = +/- 0.5*D*S | Z = +/- 0.5*S*D', or C Z = +/- 0.5*op(D*S'). C Then, compute C op(C) = A + 2*Z; C Z = A + Z; C R = Q + W'*Z + Z'*W | R = Q + W*Z' + Z*W'; C R = Q + Z'*X + X*Z | R = Q + Z*X + X*Z'. C C Workspace: need (IA+1)*N*N; C prefer 2*N*N. C IF ( LJOBE ) THEN C IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, $ DWORK(WP), N, G, LDG, ZERO, $ C, LDC ) CALL DGEMM( NT, TR, N, N, M, ALPHA, C, $ LDC, G, LDG, ZERO, DWORK, $ N ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, G, $ LDG, DWORK(WP), N, ZERO, $ C, LDC ) CALL DGEMM( NT, NT, N, N, M, ALPHA, G, $ LDG, C, LDC, ZERO, DWORK, $ N ) END IF C ELSE C CALL DSYMM( 'Left', UPLO, N, M, ONE, X, $ LDX, G, LDG, ZERO, C, LDC ) IF ( LTRANS ) THEN CALL DGEMM( NT, TR, N, N, M, ALPHA, C, $ LDC, G, LDG, ZERO, DWORK, $ N ) ELSE CALL DGEMM( NT, TR, N, N, M, ALPHA, G, $ LDG, C, LDC, ZERO, DWORK, $ N ) END IF C END IF C I = 1 C DO 600 J = 1, N CALL DCOPY( N, A(1,J), 1, C(1,J), 1 ) CALL DAXPY( N, TWO, DWORK(I), 1, C(1,J), $ 1 ) CALL DAXPY( N, ONE, A(1,J), 1, DWORK(I), $ 1 ) I = I + N 600 CONTINUE C IF ( FULLX ) THEN C C Workspace: N*N. C CALL DSYR2K( UPLO, NTRANS, N, N, ONE, $ DWORK, N, X, LDX, ONE, R, $ LDR ) ELSE C IF ( UNITE ) THEN C C Copy the matrix X to DWORK(WP). C C Workspace: 2*N*N. C CALL DLACPY( UPLO, N, N, X, LDX, $ DWORK(WP), N ) CALL MA02ED( UPLO, N, DWORK(WP), N ) END IF C CALL DSYR2K( UPLO, NTRANS, N, N, ONE, $ DWORK, N, DWORK(WP), N, ONE, $ R, LDR ) END IF C ELSE C C Compute Y = D*D' in C and compute in DWORK C the following product: C Z = +/- 0.5*Y*W | Z = +/- 0.5*W*Y, C if JOBE = 'G', or C Z = +/- 0.5*op(Y*X), if JOBE = 'I'. C Then, compute C op(C) = A + 2*Z; C Z = A + Z, C R = Q + W'*Z + Z'*W | R = Q + W*Z' + Z*W'; C R = Q + Z'*X + X*Z | R = Q + Z*X + X*Z'. C C Workspace: need (IA+1)*N*N; C prefer 2*N*N. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, $ ZERO, C, LDC ) C IF ( FULLX ) THEN C C Workspace: N*N. C CALL DSYMM( SIDE, UPLO, N, N, ALPHA, C, $ LDC, X, LDX, ZERO, DWORK, N ) ELSE C IF ( UNITE ) THEN C C Copy the matrix X to DWORK(WP). C C Workspace: 2*N*N. C CALL DLACPY( UPLO, N, N, X, LDX, $ DWORK(WP), N ) CALL MA02ED( UPLO, N, DWORK(WP), N ) END IF C CALL DSYMM( SIDE, UPLO, N, N, ALPHA, C, $ LDC, DWORK(WP), N, ZERO, $ DWORK, N ) END IF C I = 1 C DO 610 J = 1, N CALL DCOPY( N, A(1,J), 1, C(1,J), 1 ) CALL DAXPY( N, TWO, DWORK(I), 1, C(1,J), $ 1 ) CALL DAXPY( N, ONE, A(1,J), 1, DWORK(I), $ 1 ) I = I + N 610 CONTINUE C IF ( FULLX ) THEN C CALL DSYR2K( UPLO, NTRANS, N, N, ONE, $ DWORK, N, X, LDX, ONE, R, $ LDR ) ELSE C CALL DSYR2K( UPLO, NTRANS, N, N, ONE, $ DWORK, N, DWORK(WP), N, ONE, $ R, LDR ) END IF C END IF END IF END IF END IF END IF END IF END IF C DWORK(1) = MAX( 1, OPTWRK ) C RETURN C *** Last line of SG02CW *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01ND.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01ND.f0000644000175000017500000004651515012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE TG01ND( JOB, JOBT, N, M, P, A, LDA, E, LDE, B, LDB, $ C, LDC, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, $ NF, ND, NIBLCK, IBLCK, TOL, IWORK, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To compute equivalence transformation matrices Q and Z which C reduce the regular pole pencil A-lambda*E of the descriptor system C (A-lambda*E,B,C) to the form (if JOB = 'F') C C ( Af 0 ) ( Ef 0 ) C Q*A*Z = ( ) , Q*E*Z = ( ) , (1) C ( 0 Ai ) ( 0 Ei ) C C or to the form (if JOB = 'I') C C ( Ai 0 ) ( Ei 0 ) C Q*A*Z = ( ) , Q*E*Z = ( ) , (2) C ( 0 Af ) ( 0 Ef ) C C where the pair (Af,Ef) is in a generalized real Schur form, with C Ef nonsingular and upper triangular and Af in real Schur form. C The subpencil Af-lambda*Ef contains the finite eigenvalues. C The pair (Ai,Ei) is in a generalized real Schur form with C both Ai and Ei upper triangular. The subpencil Ai-lambda*Ei, C with Ai nonsingular and Ei nilpotent contains the infinite C eigenvalues and is in a block staircase form (see METHOD). C This decomposition corresponds to an additive decomposition of C the transfer-function matrix of the descriptor system as the C sum of a proper term and a polynomial term. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C = 'F': perform the finite-infinite separation; C = 'I': perform the infinite-finite separation. C C JOBT CHARACTER*1 C = 'D': compute the direct transformation matrices; C = 'I': compute the inverse transformation matrices C inv(Q) and inv(Z). C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix B, the number of columns C of the matrix C and the order of the square matrices A C and E. N >= 0. C C M (input) INTEGER C The number of columns of the matrix B. M >= 0. C C P (input) INTEGER C The number of rows of the matrix C. 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 N-by-N state matrix A. C On exit, the leading N-by-N part of this array contains C the transformed state matrix Q*A*Z (if JOBT = 'D') or C inv(Q)*A*inv(Z) (if JOBT = 'I') in the form C C ( Af 0 ) ( Ai 0 ) C ( ) for JOB = 'F', or ( ) for JOB = 'I', C ( 0 Ai ) ( 0 Af ) C C where Af is an NF-by-NF matrix in real Schur form, and Ai C is an (N-NF)-by-(N-NF) nonsingular and upper triangular C matrix. Ai has a block structure as in (3) or (4), where C A0,0 is ND-by-ND and Ai,i , for i = 1, ..., NIBLCK, is C IBLCK(i)-by-IBLCK(i). (See METHOD.) 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, the leading N-by-N part of this array must C contain the N-by-N descriptor matrix E. C On exit, the leading N-by-N part of this array contains C the transformed descriptor matrix Q*E*Z (if JOBT = 'D') or C inv(Q)*E*inv(Z) (if JOBT = 'I') in the form C C ( Ef 0 ) ( Ei 0 ) C ( ) for JOB = 'F', or ( ) for JOB = 'I', C ( 0 Ei ) ( 0 Ef ) C C where Ef is an NF-by-NF nonsingular and upper triangular C matrix, and Ei is an (N-NF)-by-(N-NF) nilpotent matrix in C an upper triangular block form as in (3) or (4). C C LDE INTEGER C The leading dimension of the array E. LDE >= 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 N-by-M input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix Q*B (if JOBT = 'D') or C inv(Q)*B (if JOBT = 'I'). C C LDB INTEGER C The leading dimension of the 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Z (if JOBT = 'D') or C*inv(Z) C (if JOBT = 'I'). C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C ALPHAR (output) DOUBLE PRECISION array, dimension (N) C ALPHAR(1:NF) will be set to the real parts of the diagonal C elements of Af that would result from reducing A and E to C the Schur form, and then further reducing both of them to C triangular form using unitary transformations, subject to C having the diagonal of E positive real. Thus, if Af(j,j) C is in a 1-by-1 block (i.e., Af(j+1,j) = Af(j,j+1) = 0), C then ALPHAR(j) = Af(j,j). Note that the (real or complex) C values (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,NF, are C the finite generalized eigenvalues of the matrix pencil C A - lambda*E. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N) C ALPHAI(1:NF) will be set to the imaginary parts of the C diagonal elements of Af that would result from reducing A C and E to Schur form, and then further reducing both of C them to triangular form using unitary transformations, C subject to having the diagonal of E positive real. Thus, C if Af(j,j) is in a 1-by-1 block (see above), then C ALPHAI(j) = 0. Note that the (real or complex) values C (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,NF, are the C finite generalized eigenvalues of the matrix pencil C A - lambda*E. C C BETA (output) DOUBLE PRECISION array, dimension (N) C BETA(1:NF) will be set to the (real) diagonal elements of C Ef that would result from reducing A and E to Schur form, C and then further reducing both of them to triangular form C using unitary transformations, subject to having the C diagonal of E positive real. Thus, if Af(j,j) is in a C 1-by-1 block (see above), then BETA(j) = Ef(j,j). C Note that the (real or complex) values C (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,NF, are the C finite generalized eigenvalues of the matrix pencil C A - lambda*E. C C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) C The leading N-by-N part of this array contains the C left transformation matrix Q, if JOBT = 'D', or its C inverse inv(Q), if JOBT = 'I'. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= 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 C right transformation matrix Z, if JOBT = 'D', or its C inverse inv(Z), if JOBT = 'I'. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1,N). C C NF (output) INTEGER C The order of the reduced matrices Af and Ef; also, the C number of finite generalized eigenvalues of the pencil C A-lambda*E. C C ND (output) INTEGER C The number of non-dynamic infinite eigenvalues of the C matrix pair (A,E). Note: N-ND is the rank of the matrix E. C C NIBLCK (output) INTEGER C If ND > 0, the number of infinite blocks minus one. C If ND = 0, then NIBLCK = 0. C C IBLCK (output) INTEGER array, dimension (N) C IBLCK(i) contains the dimension of the i-th block in the C staircase form (3), where i = 1,2,...,NIBLCK. 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 factorization with column pivoting whose estimated C condition number is less than 1/TOL. If the user sets C TOL <= 0, then an implicitly computed, default tolerance C TOLDEF = N**2*EPS, is used instead, where EPS is the C machine precision (see LAPACK Library routine DLAMCH). C TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (N+6) 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. LDWORK >= 1, and if N > 0, C LDWORK >= 4*N. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 = 1: the pencil A-lambda*E is not regular; C = 2: the QZ iteration did not converge; C = 3: (Af,Ef) and (Ai,Ei) have too close generalized C eigenvalues. C C METHOD C C For the separation of infinite structure, the reduction algorithm C of [1] is employed. This separation is achieved by computing C orthogonal matrices Q1 and Z1 such that Q1*A*Z1 and Q1*E*Z1 C have the form (if JOB = 'F') C C ( Af Ao ) ( Ef Eo ) C Q1*A*Z1 = ( ) , Q1*E*Z1 = ( ) , C ( 0 Ai ) ( 0 Ei ) C C or to the form (if JOB = 'I') C C ( Ai Ao ) ( Ei Eo ) C Q1*A*Z1 = ( ) , Q1*E*Z1 = ( ) . C ( 0 Af ) ( 0 Ef ) C C If JOB = 'F', the matrices Ai and Ei have the form C C ( A0,0 A0,k ... A0,1 ) ( 0 E0,k ... E0,1 ) C Ai = ( 0 Ak,k ... Ak,1 ) , Ei = ( 0 0 ... Ek,1 ) ; (3) C ( : : . : ) ( : : . : ) C ( 0 0 ... A1,1 ) ( 0 0 ... 0 ) C C if JOB = 'I' the matrices Ai and Ei have the form C C ( A1,1 ... A1,k A1,0 ) ( 0 ... E1,k E1,0 ) C Ai = ( : . : : ) , Ei = ( : . : : ) , (4) C ( : ... Ak,k Ak,0 ) ( : ... 0 Ek,0 ) C ( 0 ... 0 A0,0 ) ( 0 ... 0 0 ) C C where Ai,i, for i = 0, 1, ..., k, are nonsingular upper triangular C matrices. A0,0 corresponds to the non-dynamic infinite modes of C the system. C C In a second step, the transformation matrices Q2 and Z2 are C determined, of the form C C ( I -X ) ( I Y ) C Q2 = ( ) , Z2 = ( ) C ( 0 I ) ( 0 I ) C C such that with Q = Q2*Q1 and Z = Z1*Z2, Q*A*Z and Q*E*Z are C block diagonal as in (1) (if JOB = 'F') or in (2) (if JOB = 'I'). C X and Y are computed by solving generalized Sylvester equations. C C If we partition Q*B and C*Z according to (1) or (2) in the form C ( Bf ) and ( Cf Ci ), if JOB = 'F', or ( Bi ) and ( Ci Cf ), if C ( Bi ) ( Bf ) C JOB = 'I', then (Af-lambda*Ef,Bf,Cf) is the strictly proper part C of the original descriptor system and (Ai-lambda*Ei,Bi,Ci) is its C polynomial part. C C REFERENCES C C [1] Misra, P., Van Dooren, P., and Varga, A. C Computation of structural invariants of generalized C state-space systems. C Automatica, 30, pp. 1921-1936, 1994. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N**3 ) floating point operations. C C FURTHER COMMENTS C C The number of infinite poles is computed as C C NIBLCK C NINFP = Sum IBLCK(i) = N - ND - NF. C i=1 C C The multiplicities of infinite poles can be computed as follows: C there are IBLCK(k)-IBLCK(k+1) infinite poles of multiplicity C k, for k = 1, ..., NIBLCK, where IBLCK(NIBLCK+1) = 0. C Note that each infinite pole of multiplicity k corresponds to C an infinite eigenvalue of multiplicity k+1. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C July 1999. Based on the RASP routines SRISEP and RPDSGH. C C REVISIONS C C A. Varga, November 2002, September 2020. C V. Sima, December 2016. C C KEYWORDS C C Generalized eigenvalue problem, system poles, multivariable C system, orthogonal transformation, structural invariant. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER (ONE = 1.0D0, ZERO = 0.0D0) C .. Scalar Arguments .. CHARACTER JOB, JOBT INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, M, $ N, ND, NF, NIBLCK, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IBLCK( * ), IWORK(*) DOUBLE PRECISION A(LDA,*), ALPHAR(*), ALPHAI(*), B(LDB,*), $ BETA(*), C(LDC,*), DWORK(*), E(LDE,*), $ Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. LOGICAL LQUERY, TRINF, TRINV DOUBLE PRECISION DIF, SCALE INTEGER I, MINWRK, N1, N11, N2, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEMM, DLASET, DSWAP, DTGSYL, TG01MD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C C Test the input parameters. C INFO = 0 TRINF = LSAME( JOB, 'I' ) TRINV = LSAME( JOBT, 'I' ) IF( .NOT.LSAME( JOB, 'F' ) .AND. .NOT.TRINF ) THEN INFO = -1 ELSE IF( .NOT.LSAME( JOBT, 'D' ) .AND. .NOT.TRINV ) 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( LDE.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -20 ELSE IF( TOL.GE.ONE ) THEN INFO = -25 ELSE LQUERY = LDWORK.EQ.-1 IF( N.EQ.0 ) THEN MINWRK = 1 ELSE MINWRK = 4*N END IF IF( LQUERY ) THEN CALL TG01MD( JOB, N, M, P, A, LDA, E, LDE, B, LDB, C, LDC, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, NF, ND, $ NIBLCK, IBLCK, TOL, IWORK, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -28 END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01ND', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible C IF( N.EQ.0 ) THEN NF = 0 ND = 0 NIBLCK = 0 DWORK(1) = ONE RETURN END IF C C Compute the finite-infinite separation with A in Schur form C and E upper triangular. C Workspace: need 4*N. C CALL TG01MD( JOB, N, M, P, A, LDA, E, LDE, B, LDB, C, LDC, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, NF, ND, $ NIBLCK, IBLCK, TOL, IWORK, DWORK, LDWORK, INFO ) C IF( INFO.NE.0 ) $ RETURN WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C IF( TRINV ) THEN C C Transpose Z in-situ. C DO 10 I = 2, N CALL DSWAP( I-1, Z(1,I), 1, Z(I,1), LDZ ) 10 CONTINUE ELSE C C Transpose Q in-situ. C DO 20 I = 2, N CALL DSWAP( I-1, Q(1,I), 1, Q(I,1), LDQ ) 20 CONTINUE END IF C C Let be A and E partitioned as ( A11 A12 ) and ( E11 E12 ). C ( 0 A22 ) ( 0 E22 ) C Split the finite and infinite parts by using the following C left and right transformation matrices C ( I -X/scale ) ( I Y/scale ) C Qs = ( ) , Zs = ( ) , C ( 0 I ) ( 0 I ) C where X and Y are computed by solving the generalized C Sylvester equations C C A11 * Y - X * A22 = scale * A12 C E11 * Y - X * E22 = scale * E12. C C -Y is computed in A12 and -X is computed in E12. C C Integer workspace: need N+6. C IF( TRINF ) THEN N1 = N - NF N2 = NF ELSE N1 = NF N2 = N - NF END IF N11 = MIN( N1 + 1, N ) C IF( N1.GT.0 .AND. N2.GT.0 ) THEN CALL DTGSYL( 'No transpose', 0, N1, N2, A, LDA, A(N11,N11), $ LDA, A(1,N11), LDA, E, LDE, E(N11,N11), LDE, $ E(1,N11), LDE, SCALE, DIF, DWORK, LDWORK, IWORK, $ INFO ) IF( INFO.NE.0 ) THEN INFO = 3 RETURN END IF C C Transform B and C. C IF( SCALE.GT.0 ) $ SCALE = ONE/SCALE C C B1 <- B1 - X*B2. C CALL DGEMM( 'N', 'N', N1, M, N2, SCALE, E(1,N11), LDE, $ B(N11,1), LDB, ONE, B, LDB ) C C C2 <- C2 + C1*Y. C CALL DGEMM( 'N', 'N', P, N2, N1, -SCALE, C, LDC, A(1,N11), $ LDA, ONE, C(1,N11), LDC ) C IF( TRINV ) THEN C C Q2 <- Q2 + Q1*X. C CALL DGEMM( 'N', 'N', N, N2, N1, -SCALE, Q, LDQ, E(1,N11), $ LDE, ONE, Q(1,N11), LDQ ) C C Z1 <- Z1 - Y*Z2. C CALL DGEMM( 'N', 'N', N1, N, N2, SCALE, A(1,N11), LDA, $ Z(N11,1), LDZ, ONE, Z, LDZ ) ELSE C C Q1 <- Q1 - X*Q2. C CALL DGEMM( 'N', 'N', N1, N, N2, SCALE, E(1,N11), LDE, $ Q(N11,1), LDQ, ONE, Q, LDQ ) C C Z2 <- Z2 + Z1*Y. C CALL DGEMM( 'N', 'N', N, N2, N1, -SCALE, Z, LDZ, A(1,N11), $ LDA, ONE, Z(1,N11), LDZ ) END IF C C Set A12 and E12 to zero. C CALL DLASET( 'Full', N1, N2, ZERO, ZERO, A(1,N11), LDA ) CALL DLASET( 'Full', N1, N2, ZERO, ZERO, E(1,N11), LDE ) END IF C RETURN C *** Last line of TG01ND *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02PD.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02PD.f0000644000175000017500000000453115012430707017357 0ustar00lilgelilge00000000000000 SUBROUTINE MA02PD( M, N, A, LDA, NZR, NZC ) C C PURPOSE C C To compute the number of zero rows and zero columns of a real C matrix. 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) 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 NZR (output) INTEGER C The number of zero rows of the matrix A. C C NZC (output) INTEGER C The number of zero columns of the matrix A. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Sep. 2016. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, real matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. C .. Scalar Arguments .. INTEGER LDA, M, N, NZC, NZR C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) C .. C .. Local Scalars .. INTEGER I, J C C ..Intrinsic Functions.. INTRINSIC MIN C .. C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked. C NZC = 0 NZR = 0 C IF( MIN( M, N ).GT.0 ) THEN C C Scan columns 1 .. N. C I = 0 C WHILE ( I.LE.N ) DO 10 CONTINUE I = I + 1 IF( I.LE.N ) THEN DO 20 J = 1, M IF( A( J, I ).NE.ZERO ) $ GO TO 10 20 CONTINUE NZC = NZC + 1 GO TO 10 C C END WHILE 10 END IF C C Scan rows 1 .. M. C I = 0 C WHILE ( I.LE.M ) DO 30 CONTINUE I = I + 1 IF( I.LE.M ) THEN DO 40 J = 1, N IF( A( I, J ).NE.ZERO ) $ GO TO 30 40 CONTINUE NZR = NZR + 1 GO TO 30 C END IF C END WHILE 30 END IF RETURN C C *** Last line of MA02PD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB3JZP.f0000644000000000000000000000013215012430707016242 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB3JZP.f0000644000175000017500000006412315012430707017444 0ustar00lilgelilge00000000000000 SUBROUTINE MB3JZP( COMPQ, N, A, LDA, D, LDD, B, LDB, F, LDF, Q, $ LDQ, NEIG, TOL, DWORK, ZWORK, INFO ) C C PURPOSE C C To move the eigenvalues with strictly negative real parts of an C N-by-N complex skew-Hamiltonian/Hamiltonian pencil aS - bH in C structured Schur form to the leading principal subpencil, while C keeping the triangular form. On entry, we have C C ( A D ) ( B F ) C S = ( ), H = ( ), C ( 0 A' ) ( 0 -B' ) C C where A and B are upper triangular. C S and H are transformed by a unitary matrix Q such that C C ( Aout Dout ) C Sout = J Q' J' S Q = ( ), and C ( 0 Aout' ) C (1) C ( Bout Fout ) ( 0 I ) C Hout = J Q' J' H Q = ( ), with J = ( ), C ( 0 -Bout' ) ( -I 0 ) C C where Aout and Bout remain in upper triangular form. The notation C M' denotes the conjugate transpose of the matrix M. C Optionally, if COMPQ = 'I' or COMPQ = 'U', the unitary matrix Q C that fulfills (1) is computed. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether or not the unitary transformations C should be accumulated in the array Q, as follows: C = 'N': Q is not computed; C = 'I': the array Q is initialized internally to the unit C matrix, and the unitary matrix Q is returned; C = 'U': the array Q contains a unitary matrix Q0 on C entry, and the matrix Q0*Q is returned, where Q C is the product of the unitary transformations C that are applied to the pencil aS - bH to reorder C the eigenvalues. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) COMPLEX*16 array, dimension (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular matrix A. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Aout. C The strictly lower triangular part of this array is not C referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C D (input/output) COMPLEX*16 array, dimension (LDD, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the skew-Hermitian C matrix D. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Dout. C The strictly lower triangular part of this array is not C referenced. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1, N/2). C C B (input/output) COMPLEX*16 array, dimension (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular matrix B. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Bout. C The strictly lower triangular part of this array is not C referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C F (input/output) COMPLEX*16 array, dimension (LDF, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the Hermitian matrix C F. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Fout. C The strictly lower triangular part of this array is not C referenced. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1, N/2). C C Q (input/output) COMPLEX*16 array, dimension (LDQ, N) C On entry, if COMPQ = 'U', then the leading N-by-N part of C this array must contain a given matrix Q0, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q0 and the transformation matrix Q C used to transform the matrices S and H. C On exit, if COMPQ = 'I', then the leading N-by-N part of C this array contains the unitary transformation matrix Q. C If COMPQ = 'N' this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'. C C NEIG (output) INTEGER C The number of eigenvalues in aS - bH with strictly C negative real part. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance used to decide the sign of the eigenvalues. C If the user sets TOL > 0, then the given value of TOL is C used. If the user sets TOL <= 0, then an implicitly C computed, default tolerance, defined by MIN(N,10)*EPS, is C used instead, where EPS is the machine precision (see C LAPACK Library routine DLAMCH). A larger value might be C needed for pencils with multiple eigenvalues. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (N/2) C C ZWORK COMPLEX*16 array, dimension (N/2) C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value. C C METHOD C C The algorithm reorders the eigenvalues like the following scheme: C C Step 1: Reorder the eigenvalues in the subpencil aA - bB. C I. Reorder the eigenvalues with negative real parts to the C top. C II. Reorder the eigenvalues with positive real parts to the C bottom. C C Step 2: Reorder the remaining eigenvalues with negative real parts. C I. Exchange the eigenvalues between the last diagonal block C in aA - bB and the last diagonal block in aS - bH. C II. Move the eigenvalues in the N/2-th place to the (MM+1)-th C place, where MM denotes the current number of eigenvalues C with negative real parts in aA - bB. C C The algorithm uses a sequence of unitary transformations as C described on page 43 in [1]. To achieve those transformations the C elementary SLICOT Library subroutines MB03DZ and MB03HZ are called C for the corresponding matrix structures. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C complex floating point operations. C C FURTHER COMMENTS C C For large values of N, the routine applies the transformations on C panels of columns. The user may specify in INFO the desired number C of columns. If on entry INFO <= 0, then the routine estimates a C suitable value of this number. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2011. C M. Voigt, Max Planck Institute for Dynamics of Complex Technical C Systems, Dec. 2011. C C REVISIONS C C V. Sima, June 2013, June 2014, Nov. 2014. C M. Voigt, July 2013, July 2014. C C KEYWORDS C C Eigenvalue reordering, upper triangular matrix, C skew-Hamiltonian/Hamiltonian pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, TEN PARAMETER ( ZERO = 0.0D+0, TEN = 1.0D+1 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), CONE = ( 1.0D+0, $ 0.0D+0 ) ) C C .. Scalar Arguments .. CHARACTER COMPQ INTEGER INFO, LDA, LDB, LDD, LDF, LDQ, N, NEIG DOUBLE PRECISION TOL C C .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), D( LDD, * ), $ F( LDF, * ), Q( LDQ, * ), ZWORK( * ) DOUBLE PRECISION DWORK( * ) C C .. Local Scalars .. LOGICAL LCMPQ, LINIQ, LUPDQ INTEGER IC, ICS, IUPD, J, JE, JS, K, M, M1, MM, MP, NB, $ NC, UPDS DOUBLE PRECISION CO1, CO2, EPS COMPLEX*16 CJF, SI1, SI2, TMP C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C C .. External Subroutines .. EXTERNAL MB03DZ, MB03HZ, XERBLA, ZGEQRF, ZLASET, ZROT C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD C C .. Executable Statements .. C C Decode the input arguments. C NB = INFO M = N/2 M1 = MAX( 1, M ) NEIG = 0 LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LCMPQ = LINIQ .OR. LUPDQ C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -2 ELSE IF( LDA.LT.M1 ) THEN INFO = -4 ELSE IF( LDD.LT.M1 ) THEN INFO = -6 ELSE IF( LDB.LT.M1 ) THEN INFO = -8 ELSE IF( LDF.LT.M1 ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN INFO = -12 END IF IF( INFO.NE.0) THEN CALL XERBLA( 'MB3JZP', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C C A block algorithm is used for large M. C IF( NB.LE.0 ) THEN CALL ZGEQRF( M, M, A, LDA, ZWORK, ZWORK, -1, INFO ) NB = MIN( MAX( INT( ZWORK( 1 ) )/M1, 2 ), M ) END IF C EPS = TOL IF ( EPS.LE.ZERO ) THEN C C Use the default tolerance. C EPS = MIN( DBLE( N ), TEN )*DLAMCH( 'Precision' ) END IF C C STEP 0. Initializations. C IF( LINIQ ) THEN IUPD = M + 1 UPDS = M CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) ELSE IF( LUPDQ ) THEN IUPD = 1 UPDS = N END IF C C STEP 1. Reorder the eigenvalues in the subpencil aA - bB. C MM = 0 MP = M + 1 C C I. Reorder the eigenvalues with negative real parts to the top. C DO 180 K = 1, M IF( DBLE( A( K, K ) )* DBLE( B( K, K ) ) + $ DIMAG( A( K, K ) )*DIMAG( B( K, K ) ).LT. $ -ABS( A( K, K ) )* ABS( B( K, K ) )*EPS ) THEN C JS = K JE = MIN( M, JS+NB-1 ) IC = 1 DO 10 J = K - 1, MM + 1, -1 C C Perform eigenvalue exchange. C CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1, $ CO2, SI2 ) DWORK( IC ) = CO2 ZWORK( IC ) = -SI2 IC = IC + 1 C C Update A and D. C CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 ) A( J, J ) = CO2*A( J, J ) + $ SI2*A( J+1, J+1 )*DCONJG( SI1 ) A( J+1, J+1 ) = CO1*A( J+1, J+1 ) C CJF = -DCONJG( D( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 ) CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 ) D( J, J ) = CO2*D( J, J ) - SI2*TMP D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF C C Update B and F. C CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 ) B( J, J ) = CO2*B( J, J ) + $ SI2*B( J+1, J+1 )*DCONJG( SI1 ) B( J+1, J+1 ) = CO1*B( J+1, J+1 ) C CJF = DCONJG( F( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 ) CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 ) F( J, J ) = CO2*F( J, J ) - SI2*TMP F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, $ SI1 ) CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ), $ 1, CO2, SI2 ) END IF 10 CONTINUE C C Panel Updates. C C Update A. C ICS = 1 JE = K - 1 C C WHILE( JE.GT.2 ) DO 20 CONTINUE IF( JE.GE.MM+1 ) THEN NC = 0 IC = ICS ICS = ICS + NB DO 30 J = JE, MM + 1, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL ZROT( NC, A( J, JS+1 ), LDA, A( J+1, JS+1 ), LDA, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 30 CONTINUE JE = JE - NB GO TO 20 END IF C END WHILE 20 C DO 50 JS = K, M-1, NB JE = MIN( M-1, JS+NB-1 ) NC = JE - JS + 1 IC = 1 DO 40 J = K - 1, MM + 1, -1 CALL ZROT( NC, A( J, JS+1 ), LDA, A( J+1, JS+1 ), LDA, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 40 CONTINUE 50 CONTINUE C C Update B. C ICS = 1 JE = K - 1 C C WHILE( JE.GT.2 ) DO 60 CONTINUE IF( JE.GE.MM+1 ) THEN NC = 0 IC = ICS ICS = ICS + NB DO 70 J = JE, MM + 1, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL ZROT( NC, B( J, JS+1 ), LDB, B( J+1, JS+1 ), LDB, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 70 CONTINUE JE = JE - NB GO TO 60 END IF C END WHILE 60 C DO 90 JS = K, M-1, NB JE = MIN( M-1, JS+NB-1 ) NC = JE - JS + 1 IC = 1 DO 80 J = K - 1, MM + 1, -1 CALL ZROT( NC, B( J, JS+1 ), LDB, B( J+1, JS+1 ), LDB, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 80 CONTINUE 90 CONTINUE C C Update D. C ICS = 1 JE = K - 1 C C WHILE( JE.GT.2 ) DO 100 CONTINUE IF( JE.GE.MM+1 ) THEN NC = 0 IC = ICS ICS = ICS + NB DO 110 J = JE, MM + 1, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL ZROT( NC, D( J, JS+1 ), LDD, D( J+1, JS+1 ), LDD, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 110 CONTINUE JE = JE - NB GO TO 100 END IF C END WHILE 100 C DO 130 JS = K, M-1, NB JE = MIN( M-1, JS+NB-1 ) NC = JE - JS + 1 IC = 1 DO 120 J = K - 1, MM + 1, -1 CALL ZROT( NC, D( J, JS+1 ), LDD, D( J+1, JS+1 ), LDD, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 120 CONTINUE 130 CONTINUE C C Update F. C ICS = 1 JE = K - 1 C C WHILE( JE.GT.2 ) DO 140 CONTINUE IF( JE.GE.MM+1 ) THEN NC = 0 IC = ICS ICS = ICS + NB DO 150 J = JE, MM + 1, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL ZROT( NC, F( J, JS+1 ), LDF, F( J+1, JS+1 ), LDF, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 150 CONTINUE JE = JE - NB GO TO 140 END IF C END WHILE 140 C DO 170 JS = K, M-1, NB JE = MIN( M-1, JS+NB-1 ) NC = JE - JS + 1 IC = 1 DO 160 J = K - 1, MM + 1, -1 CALL ZROT( NC, F( J, JS+1 ), LDF, F( J+1, JS+1 ), LDF, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 160 CONTINUE 170 CONTINUE C MM = MM + 1 END IF 180 CONTINUE C C II. Reorder the eigenvalues with positive real parts to the bottom. C DO 280 K = M, MM + 1, -1 IF( DBLE( A( K, K ) )* DBLE( B( K, K ) ) + $ DIMAG( A( K, K ) )*DIMAG( B( K, K ) ).GT. $ ABS( A( K, K ) )* ABS( B( K, K ) )*EPS ) THEN C IC = 1 DO 190 J = K, MP - 2 C C Perform eigenvalue exchange. C CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1, $ CO2, SI2 ) DWORK( IC ) = CO2 ZWORK( IC ) = -SI2 IC = IC + 1 C C Update A and D. C CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 ) A( J, J ) = CO2*A( J, J ) + $ SI2*A( J+1, J+1 )*DCONJG( SI1 ) A( J+1, J+1 ) = CO1*A( J+1, J+1 ) CALL ZROT( MP-J-1, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, $ CO2, -SI2 ) C CJF = -DCONJG( D( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 ) CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 ) D( J, J ) = CO2*D( J, J ) - SI2*TMP D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF CALL ZROT( MP-J-1, D( J, J+1 ), LDD, D( J+1, J+1 ), LDD, $ CO2, -SI2 ) C C Update B and F. C CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 ) B( J, J ) = CO2*B( J, J ) + $ SI2*B( J+1, J+1 )*DCONJG( SI1 ) B( J+1, J+1 ) = CO1*B( J+1, J+1 ) CALL ZROT( MP-J-1, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, $ CO2, -SI2 ) C CJF = DCONJG( F( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 ) CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 ) F( J, J ) = CO2*F( J, J ) - SI2*TMP F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF CALL ZROT( MP-J-1, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF, $ CO2, -SI2 ) C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, $ SI1 ) CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ), $ 1, CO2, SI2 ) END IF 190 CONTINUE C C Panel Updates. C C Update A. C ICS = 1 DO 210 JS = MP, M, NB IC = ICS JE = MIN( JS+NB, M ) NC = MIN( NB, JE-JS+1 ) DO 200 J = K, MP-2 CALL ZROT( NC, A( J, JS ), LDA, A( J+1, JS ), $ LDA, DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 200 CONTINUE 210 CONTINUE C C Update D. C ICS = 1 DO 230 JS = MP, M, NB IC = ICS JE = MIN( JS+NB, M ) NC = MIN( NB, JE-JS+1 ) DO 220 J = K, MP-2 CALL ZROT( NC, D( J, JS ), LDD, D( J+1, JS ), $ LDD, DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 220 CONTINUE 230 CONTINUE C C Update B. C ICS = 1 DO 250 JS = MP, M, NB IC = ICS JE = MIN( JS+NB, M ) NC = MIN( NB, JE-JS+1 ) DO 240 J = K, MP-2 CALL ZROT( NC, B( J, JS ), LDB, B( J+1, JS ), $ LDB, DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 240 CONTINUE 250 CONTINUE C C Update F. C ICS = 1 DO 270 JS = MP, M, NB IC = ICS JE = MIN( JS+NB, M ) NC = MIN( NB, JE-JS+1 ) DO 260 J = K, MP-2 CALL ZROT( NC, F( J, JS ), LDF, F( J+1, JS ), $ LDF, DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 260 CONTINUE 270 CONTINUE C MP = MP - 1 END IF 280 CONTINUE C C C The remaining M-MP+1 eigenvalues with negative real part are now in C the bottom right subpencil of aS - bH. C C STEP 2. Reorder the remaining M-MP+1 eigenvalues. C DO 380 K = M, MP, -1 C C I. Exchange the eigenvalues between two diagonal blocks. C C Perform eigenvalue exchange. C CALL MB03HZ( A( M, M ), D( M, M ), B( M, M ), F( M, M ), CO1, $ SI1 ) C C Update A and D. C TMP = DCONJG( A( M, M ) ) CALL ZROT( M, D( 1, M ), 1, A( 1, M ), 1, CO1, SI1 ) A( M, M ) = A( M, M )*CO1 + TMP*DCONJG( SI1 )**2 D( M, M ) = D( M, M )*CO1 - TMP*DCONJG( SI1 )*CO1 C C Update B and F. C TMP = -DCONJG( B( M, M ) ) CALL ZROT( M, F( 1, M ), 1, B( 1, M ), 1, CO1, SI1 ) B( M, M ) = B( M, M )*CO1 + TMP*DCONJG( SI1 )**2 F( M, M ) = F( M, M )*CO1 - TMP*DCONJG( SI1 )*CO1 C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO1, SI1 ) END IF C C II. Move the eigenvalue in the M-th diagonal position to the C (MM+1)-th position. C MM = MM + 1 IC = 1 DO 290 J = M - 1, MM, -1 C C Perform eigenvalue exchange. C CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1, CO2, $ SI2 ) DWORK( IC ) = CO2 ZWORK( IC ) = -SI2 IC = IC + 1 C C Update A and D. C CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 ) A( J, J ) = CO2*A( J, J ) + $ SI2*A( J+1, J+1 )*DCONJG( SI1 ) A( J+1, J+1 ) = CO1*A( J+1, J+1 ) C CJF = -DCONJG( D( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 ) CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 ) D( J, J ) = CO2*D( J, J ) - SI2*TMP D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF C C Update B and F. C CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 ) B( J, J ) = CO2*B( J, J ) + $ SI2*B( J+1, J+1 )*DCONJG( SI1 ) B( J+1, J+1 ) = CO1*B( J+1, J+1 ) C CJF = DCONJG( F( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 ) CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 ) F( J, J ) = CO2*F( J, J ) - SI2*TMP F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, SI1 ) CALL ZROT( N, Q( 1, M+J+1 ), 1, Q( 1, M+J ), 1, CO2, SI2 $ ) END IF 290 CONTINUE C C Panel Updates. C C Update A. C ICS = 1 JE = M - 1 C C WHILE( JE.GT.2 ) DO 300 CONTINUE IF( JE.GE.MM ) THEN NC = 0 IC = ICS ICS = ICS + NB DO 310 J = JE, MM, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL ZROT( NC, A( J, JS+1 ), LDA, A( J+1, JS+1 ), LDA, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 310 CONTINUE JE = JE - NB GO TO 300 END IF C END WHILE 300 C C Update B. C ICS = 1 JE = M - 1 C C WHILE( JE.GT.2 ) DO 320 CONTINUE IF( JE.GE.MM ) THEN NC = 0 IC = ICS ICS = ICS + NB DO 330 J = JE, MM, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL ZROT( NC, B( J, JS+1 ), LDB, B( J+1, JS+1 ), LDB, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 330 CONTINUE JE = JE - NB GO TO 320 END IF C END WHILE 320 C C Update D. C ICS = 1 JE = M - 1 C C WHILE( JE.GT.2 ) DO 340 CONTINUE IF( JE.GE.MM ) THEN NC = 0 IC = ICS ICS = ICS + NB DO 350 J = JE, MM, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL ZROT( NC, D( J, JS+1 ), LDD, D( J+1, JS+1 ), LDD, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 350 CONTINUE JE = JE - NB GO TO 340 END IF C END WHILE 340 C C Update F. C ICS = 1 JE = M - 1 C C WHILE( JE.GT.2 ) DO 360 CONTINUE IF( JE.GE.MM ) THEN NC = 0 IC = ICS ICS = ICS + NB DO 370 J = JE, MM, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL ZROT( NC, F( J, JS+1 ), LDF, F( J+1, JS+1 ), LDF, $ DWORK( IC ), ZWORK( IC ) ) IC = IC + 1 370 CONTINUE JE = JE - NB GO TO 360 END IF C END WHILE 360 C 380 CONTINUE C NEIG = MM C RETURN C *** Last line of MB3JZP *** END control-4.1.2/src/slicot/src/PaxHeaders/MA01CD.f0000644000000000000000000000013215012430707016142 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA01CD.f0000644000175000017500000000541515012430707017343 0ustar00lilgelilge00000000000000 INTEGER FUNCTION MA01CD( A, IA, B, IB ) C C PURPOSE C C To compute, without over- or underflow, the sign of the sum of two C real numbers represented using integer powers of a base (usually, C the machine base). Any base can be used, but it should the same C for both numbers. The result is an integer with value 1, 0, or -1, C depending on the sum being found as positive, zero, or negative, C respectively. C C FUNCTION VALUE C C MA01CD INTEGER C The sign of the sum of the two numbers, which is usually C either 1, or -1. If both numbers are 0, or if they have C the same exponent and their sum is 0, the returned value C is 0. C C ARGUMENTS C C Input/Output Parameters C C A (input) DOUBLE PRECISION C The first real scalar. C C IA (input) INTEGER C Exponent of the base for the first real scalar. The scalar C is represented as A * BASE**(IA). C C B (input) DOUBLE PRECISION C The first real scalar. C C IB (input) INTEGER C Exponent of the base for the first real scalar. The scalar C is represented as B * BASE**(IB). C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Feb. 2010. C C REVISIONS C C - C C KEYWORDS C C Computer arithmetic, overflow, underflow. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER IA, IB DOUBLE PRECISION A, B C .. Local Scalars .. DOUBLE PRECISION S, SA, SB C .. Intrinsic Functions .. INTRINSIC ABS, LOG, SIGN C C .. Executable Statements .. C IF( A.EQ.ZERO .AND. B.EQ.ZERO ) THEN MA01CD = 0 ELSE IF( A.EQ.ZERO ) THEN MA01CD = SIGN( ONE, B ) ELSE IF( B.EQ.ZERO ) THEN MA01CD = SIGN( ONE, A ) ELSE IF( IA.EQ.IB ) THEN S = A + B IF( S.EQ.ZERO ) THEN MA01CD = 0 ELSE MA01CD = SIGN( ONE, S ) END IF ELSE SA = SIGN( ONE, A ) SB = SIGN( ONE, B ) IF( SA.EQ.SB ) THEN MA01CD = SA ELSE IF( IA.GT.IB ) THEN IF( ( LOG( ABS( A ) ) + IA - IB ).GE.LOG( ABS( B ) ) ) THEN MA01CD = SA ELSE MA01CD = SB END IF ELSE IF( ( LOG( ABS( B ) ) + IB - IA ).GE.LOG( ABS( A ) ) ) THEN MA01CD = SB ELSE MA01CD = SA END IF END IF END IF C RETURN C *** Last line of MA01CD *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02IZ.f0000644000000000000000000000013215012430707016177 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02IZ.f0000644000175000017500000002571315012430707017403 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION MA02IZ( TYP, NORM, N, A, LDA, QG, $ LDQG, DWORK ) C C PURPOSE C C To compute the value of the one norm, or the Frobenius norm, or C the infinity norm, or the element of largest absolute value C of a complex skew-Hamiltonian matrix C C [ A G ] H H C X = [ H ], G = -G, Q = -Q, C [ Q A ] C C or of a complex Hamiltonian matrix C C [ A G ] H H C X = [ H ], G = G, Q = Q, C [ Q -A ] C C where A, G and Q are complex n-by-n matrices. C C Note that for this kind of matrices the infinity norm is equal C to the one norm. C C FUNCTION VALUE C C MA02IZ DOUBLE PRECISION C The computed norm. C C ARGUMENTS C C Mode Parameters C C TYP CHARACTER*1 C Specifies the type of the input matrix X: C = 'S': X is skew-Hamiltonian; C = 'H': X is Hamiltonian. C C NORM CHARACTER*1 C Specifies the value to be returned in MA02IZ: C = '1' or 'O': one norm of X; C = 'F' or 'E': Frobenius norm of X; C = 'I': infinity norm of X; C = 'M': max(abs(X(i,j)). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C A (input) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the matrix A. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input) COMPLEX*16 array, dimension (LDQG,N+1) C On entry, the leading N-by-N+1 part of this array must C contain in columns 1:N the lower triangular part of the C matrix Q and in columns 2:N+1 the upper triangular part C of the matrix G. If TYP = 'S', the real parts of the C entries on the diagonal and the first superdiagonal of C this array, which should be zero, need not be set, since C they are not used. Similarly, if TYP = 'H', the imaginary C parts of the entries on the diagonal and the first C superdiagonal of this array, which should be zero, need C not be set. C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C where LDWORK >= 2*N when NORM = '1', NORM = 'I' or C NORM = 'O'; otherwise, DWORK is not referenced. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2011. C Based on the SLICOT Library routine MA02ID. C C REVISIONS C C V. Sima, Oct. 2012, Dec. 2015, Jan. 2016. C C KEYWORDS C C Elementary matrix operations, Hamiltonian matrix, skew-Hamiltonian C matrix. 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 NORM, TYP INTEGER LDA, LDQG, N C .. Array Arguments .. COMPLEX*16 A(LDA,*), QG(LDQG,*) DOUBLE PRECISION DWORK(*) C .. Local Scalars .. LOGICAL LSH INTEGER I, J DOUBLE PRECISION DSCL, DSUM, SCALE, SUM, TEMP, VALUE C .. Local Arrays .. DOUBLE PRECISION DUM(2) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAPY2, ZLANGE EXTERNAL DLAPY2, LSAME, ZLANGE C .. External Subroutines .. EXTERNAL DLASSQ, ZLASSQ C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX, SQRT C C .. Executable Statements .. C LSH = LSAME( TYP, 'S' ) C IF ( N.EQ.0 ) THEN VALUE = ZERO C ELSE IF ( LSAME( NORM, 'M' ) .AND. LSH ) THEN C C Find max( abs( A(i,j) ), abs( QG(i,j) ) ). C VALUE = ZLANGE( 'MaxElement', N, N, A, LDA, DUM ) DO 30 J = 1, N DO 10 I = 1, J-2 VALUE = MAX( VALUE, ABS( QG(I,J) ) ) 10 CONTINUE VALUE = MAX( VALUE, ABS( DIMAG( QG(J,J) ) ) ) DO 20 I = J+1, N VALUE = MAX( VALUE, ABS( QG(I,J) ) ) 20 CONTINUE VALUE = MAX( VALUE, ABS( DIMAG( QG(J,J+1) ) ) ) 30 CONTINUE DO 40 I = 1, N-1 VALUE = MAX( VALUE, ABS( QG(I,N+1) ) ) 40 CONTINUE C ELSE IF ( LSAME( NORM, 'M' ) ) THEN C C Find max( abs( A(i,j) ), abs( QG(i,j) ) ). C VALUE = ZLANGE( 'MaxElement', N, N, A, LDA, DUM ) DO 70 J = 1, N DO 50 I = 1, J-2 VALUE = MAX( VALUE, ABS( QG(I,J) ) ) 50 CONTINUE VALUE = MAX( VALUE, ABS( DBLE( QG(J,J) ) ) ) DO 60 I = J+1, N VALUE = MAX( VALUE, ABS( QG(I,J) ) ) 60 CONTINUE VALUE = MAX( VALUE, ABS( DBLE( QG(J,J+1) ) ) ) 70 CONTINUE DO 80 I = 1, N-1 VALUE = MAX( VALUE, ABS( QG(I,N+1) ) ) 80 CONTINUE C ELSE IF ( ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. $ LSAME( NORM, 'I' ) ) .AND. LSH ) THEN C C Find the column and row sums of A (in one pass). C VALUE = ZERO DO 90 I = 1, N DWORK(I) = ZERO 90 CONTINUE C DO 110 J = 1, N SUM = ZERO DO 100 I = 1, N TEMP = ABS( A(I,J) ) SUM = SUM + TEMP DWORK(I) = DWORK(I) + TEMP 100 CONTINUE DWORK(N+J) = SUM 110 CONTINUE C C Compute the maximal absolute column sum. C SUM = DWORK(N+1) + ABS( DIMAG( QG(1,1) ) ) DO 120 I = 2, N TEMP = ABS( QG(I,1) ) SUM = SUM + TEMP DWORK(N+I) = DWORK(N+I) + TEMP 120 CONTINUE VALUE = MAX( VALUE, SUM ) DO 150 J = 2, N DO 130 I = 1, J-2 TEMP = ABS( QG(I,J) ) DWORK(I) = DWORK(I) + TEMP DWORK(J-1) = DWORK(J-1) + TEMP 130 CONTINUE DWORK(J-1) = DWORK(J-1) + ABS( DIMAG( QG(J-1,J) ) ) SUM = DWORK(N+J) + ABS( DIMAG( QG(J,J) ) ) DO 140 I = J+1, N TEMP = ABS( QG(I,J) ) SUM = SUM + TEMP DWORK(N+I) = DWORK(N+I) + TEMP 140 CONTINUE VALUE = MAX( VALUE, SUM ) 150 CONTINUE DO 160 I = 1, N-1 TEMP = ABS( QG(I,N+1) ) DWORK(I) = DWORK(I) + TEMP DWORK(N) = DWORK(N) + TEMP 160 CONTINUE DWORK(N) = DWORK(N) + ABS( DIMAG( QG(N,N+1) ) ) DO 170 I = 1, N VALUE = MAX( VALUE, DWORK(I) ) 170 CONTINUE C ELSE IF ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. $ LSAME( NORM, 'I' ) ) THEN C C Find the column and row sums of A (in one pass). C VALUE = ZERO DO 180 I = 1, N DWORK(I) = ZERO 180 CONTINUE C DO 200 J = 1, N SUM = ZERO DO 190 I = 1, N TEMP = ABS( A(I,J) ) SUM = SUM + TEMP DWORK(I) = DWORK(I) + TEMP 190 CONTINUE DWORK(N+J) = SUM 200 CONTINUE C C Compute the maximal absolute column sum. C SUM = DWORK(N+1) + ABS( DBLE( QG(1,1) ) ) DO 210 I = 2, N TEMP = ABS( QG(I,1) ) SUM = SUM + TEMP DWORK(N+I) = DWORK(N+I) + TEMP 210 CONTINUE VALUE = MAX( VALUE, SUM ) DO 240 J = 2, N DO 220 I = 1, J-2 TEMP = ABS( QG(I,J) ) DWORK(I) = DWORK(I) + TEMP DWORK(J-1) = DWORK(J-1) + TEMP 220 CONTINUE DWORK(J-1) = DWORK(J-1) + ABS( DBLE( QG(J-1,J) ) ) SUM = DWORK(N+J) + ABS( DBLE( QG(J,J) ) ) DO 230 I = J+1, N TEMP = ABS( QG(I,J) ) SUM = SUM + TEMP DWORK(N+I) = DWORK(N+I) + TEMP 230 CONTINUE VALUE = MAX( VALUE, SUM ) 240 CONTINUE DO 250 I = 1, N-1 TEMP = ABS( QG(I,N+1) ) DWORK(I) = DWORK(I) + TEMP DWORK(N) = DWORK(N) + TEMP 250 CONTINUE DWORK(N) = DWORK(N) + ABS( DBLE( QG(N,N+1) ) ) DO 260 I = 1, N VALUE = MAX( VALUE, DWORK(I) ) 260 CONTINUE C ELSE IF ( ( LSAME( NORM, 'F' ) .OR. $ LSAME( NORM, 'E' ) ) .AND. LSH ) THEN C C Find normF(A). C SCALE = ZERO SUM = ONE DO 270 J = 1, N CALL ZLASSQ( N, A(1,J), 1, SCALE, SUM ) 270 CONTINUE C C Add normF(G) and normF(Q). C DSCL = ABS( DIMAG( QG(1,1) ) ) DSUM = ONE IF ( N.GT.1 ) THEN CALL ZLASSQ( N-1, QG(2,1), 1, SCALE, SUM ) DUM(1) = DIMAG( QG(1,2) ) DUM(2) = DIMAG( QG(2,2) ) CALL DLASSQ( 2, DUM, 1, DSCL, DSUM ) END IF IF ( N.GT.2 ) $ CALL ZLASSQ( N-2, QG(3,2), 1, SCALE, SUM ) DO 280 J = 3, N CALL ZLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) DUM(1) = DIMAG( QG(J-1,J) ) DUM(2) = DIMAG( QG(J, J) ) CALL DLASSQ( 2, DUM, 1, DSCL, DSUM ) CALL ZLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) 280 CONTINUE IF ( N.GT.1 ) $ CALL ZLASSQ( N-1, QG(1,N+1), 1, SCALE, SUM ) DUM(1) = DIMAG( QG(N,N+1) ) CALL DLASSQ( 1, DUM, 1, DSCL, DSUM ) VALUE = DLAPY2( SQRT( TWO )*SCALE*SQRT( SUM ), $ DSCL*SQRT( DSUM ) ) C ELSE IF ( LSAME( NORM, 'F' ) .OR. LSAME( NORM, 'E' ) ) THEN C C Find normF(A). C SCALE = ZERO SUM = ONE DO 290 J = 1, N CALL ZLASSQ( N, A(1,J), 1, SCALE, SUM ) 290 CONTINUE C C Add normF(G) and normF(Q). C DSCL = ABS( DBLE( QG(1,1) ) ) DSUM = ONE IF ( N.GT.1 ) THEN CALL ZLASSQ( N-1, QG(2,1), 1, SCALE, SUM ) DUM(1) = DBLE( QG(1,2) ) DUM(2) = DBLE( QG(2,2) ) CALL DLASSQ( 2, DUM, 1, DSCL, DSUM ) END IF IF ( N.GT.2 ) $ CALL ZLASSQ( N-2, QG(3,2), 1, SCALE, SUM ) DO 300 J = 3, N CALL ZLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) DUM(1) = DBLE( QG(J-1,J) ) DUM(2) = DBLE( QG(J, J) ) CALL DLASSQ( 2, DUM, 1, DSCL, DSUM ) CALL ZLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) 300 CONTINUE IF ( N.GT.1 ) $ CALL ZLASSQ( N-1, QG(1,N+1), 1, SCALE, SUM ) DUM(1) = DBLE( QG(N,N+1) ) CALL DLASSQ( 1, DUM, 1, DSCL, DSUM ) VALUE = DLAPY2( SQRT( TWO )*SCALE*SQRT( SUM ), $ DSCL*SQRT( DSUM ) ) END IF C MA02IZ = VALUE RETURN C *** Last line of MA02IZ *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01ID.f0000644000000000000000000000013215012430707016165 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01ID.f0000644000175000017500000005166115012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE TG01ID( JOBOBS, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE, $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, NOBSV, NIUOBS, $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) C C PURPOSE C C To compute orthogonal transformation matrices Q and Z which C reduce the N-th order descriptor system (A-lambda*E,B,C) C to the form C C ( Ano * ) ( Eno * ) ( Bno ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) , Q'*B = ( ) , C ( 0 Ao ) ( 0 Eo ) ( Bo ) C C C*Z = ( 0 Co ) , C C where the NOBSV-th order descriptor system (Ao-lambda*Eo,Bo,Co) C is a finite and/or infinite observable. The pencil C Ano - lambda*Eno is regular of order N-NOBSV and contains the C unobservable finite and/or infinite eigenvalues of the pencil C A-lambda*E. C C For JOBOBS = 'O' or 'I', the pencil ( Eo-lambda*Ao ) has full C ( Co ) C column rank NOBSV for all finite lambda and is in a staircase form C with C _ _ _ _ C ( Ek,k Ek,k-1 ... Ek,2 Ek,1 ) C ( _ _ _ _ ) C ( Eo ) = ( Ek-1,k Ek-1,k-1 ... Ek-1,2 Ek-1,1 ) , (1) C ( Co ) ( ... ... _ _ ) C ( 0 0 ... E1,2 E1,1 ) C ( _ ) C ( 0 0 ... 0 E0,1 ) C _ _ _ C ( Ak,k ... Ak,2 Ak,1 ) C ( ... _ _ ) C Ao = ( 0 ... A2,2 A2,1 ) , (2) C ( _ ) C ( 0 ... 0 A1,1 ) C _ C where Ei-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix C _ C (with CTAU(0) = P) and Ai,i is a CTAU(i)-by-CTAU(i) C upper triangular matrix. C C For JOBOBS = 'F', the pencil ( Ao-lambda*Eo ) has full C ( Co ) C column rank NOBSV for all finite lambda and is in a staircase form C with C _ _ _ _ C ( Ak,k Ak,k-1 ... Ak,2 Ak,1 ) C ( _ _ _ _ ) C ( Ao ) = ( Ak-1,k Ak-1,k-1 ... Ak-1,2 Ak-1,1 ) , (3) C ( Co ) ( ... ... _ _ ) C ( 0 0 ... A1,2 A1,1 ) C ( _ ) C ( 0 0 ... 0 A0,1 ) C _ _ _ C ( Ek,k ... Ek,2 Ek,1 ) C ( ... _ _ ) C Eo = ( 0 ... E2,2 E2,1 ) , (4) C ( _ ) C ( 0 ... 0 E1,1 ) C _ C where Ai-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix C _ C (with CTAU(0) = P) and Ei,i is a CTAU(i)-by-CTAU(i) C upper triangular matrix. C C For JOBOBS = 'O', the (N-NOBSV)-by-(N-NOBSV) regular pencil C Ano - lambda*Eno has the form C C ( Afno - lambda*Efno * ) C Ano - lambda*Eno = ( ) , C ( 0 Aino - lambda*Eino ) C C where: C 1) the NIUOBS-by-NIUOBS regular pencil Aino - lambda*Eino, C with Aino upper triangular and nonsingular, contains the C unobservable infinite eigenvalues of A - lambda*E; C 2) the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) regular pencil C Afno - lambda*Efno, with Efno upper triangular and C nonsingular, contains the unobservable finite C eigenvalues of A - lambda*E. C C Note: The significance of the two diagonal blocks can be C interchanged by calling the routine with the C arguments A and E interchanged. In this case, C Aino - lambda*Eino contains the unobservable zero C eigenvalues of A - lambda*E, while Afno - lambda*Efno C contains the unobservable nonzero finite and infinite C eigenvalues of A - lambda*E. C C For JOBOBS = 'F', the pencil Ano - lambda*Eno has the form C C Ano - lambda*Eno = Afno - lambda*Efno , C C where the regular pencil Afno - lambda*Efno, with Efno C upper triangular and nonsingular, contains the unobservable C finite eigenvalues of A - lambda*E. C C For JOBOBS = 'I', the pencil Ano - lambda*Eno has the form C C Ano - lambda*Eno = Aino - lambda*Eino , C C where the regular pencil Aino - lambda*Eino, with Aino C upper triangular and nonsingular, contains the unobservable C nonzero finite and infinite eigenvalues of A - lambda*E. C C The left and/or right orthogonal transformations Q and Z C performed to reduce the system matrices can be optionally C accumulated. C C The reduced order descriptor system (Ao-lambda*Eo,Bo,Co) has C the same transfer-function matrix as the original system C (A-lambda*E,B,C). C C ARGUMENTS C C Mode Parameters C C JOBOBS CHARACTER*1 C = 'O': separate both finite and infinite unobservable C eigenvalues; C = 'F': separate only finite unobservable eigenvalues; C = 'I': separate only nonzero finite and infinite C unobservable eigenvalues. C C COMPQ CHARACTER*1 C = 'N': do not compute Q; C = 'I': Q is initialized to the unit matrix, and the C orthogonal matrix Q is returned; C = 'U': Q must contain an orthogonal matrix Q1 on entry, C and the product Q1*Q is returned. C C COMPZ CHARACTER*1 C = 'N': do not compute Z; C = 'I': Z is initialized to the unit matrix, and the C orthogonal matrix Z is returned; C = 'U': Z must contain an orthogonal matrix Z1 on entry, C and the product Z1*Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the descriptor state vector; also the C order of square matrices A and E, the number of rows of C matrix B, and the number of columns of matrix C. N >= 0. C C M (input) INTEGER C The dimension of descriptor system input vector; also the C number of columns of matrix B. M >= 0. C C P (input) INTEGER C The dimension of descriptor system output vector; also the C number of rows of matrix C. 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 N-by-N state matrix A. C On exit, the leading N-by-N part of this array contains C the transformed state matrix Q'*A*Z, C C ( Ano * ) C Q'*A*Z = ( ) , C ( 0 Ao ) C C where Ao is NOBSV-by-NOBSV and Ano is C (N-NOBSV)-by-(N-NOBSV). C If JOBOBS = 'F', the matrix ( Ao ) is in the observability C ( Co ) C staircase form (3). C If JOBOBS = 'O' or 'I', the submatrix Ao is upper C triangular. C If JOBOBS = 'O', the submatrix Ano has the form C C ( Afno * ) C Ano = ( ) , C ( 0 Aino ) C C where the NIUOBS-by-NIUOBS matrix Aino is nonsingular and C upper triangular. C If JOBOBS = 'I', Ano is nonsingular and upper triangular. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the N-by-N descriptor matrix E. C On exit, the leading N-by-N part of this array contains C the transformed state matrix Q'*E*Z, C C ( Eno * ) C Q'*E*Z = ( ) , C ( 0 Eo ) C C where Eo is NOBSV-by-NOBSV and Eno is C (N-NOBSV)-by-(N-NOBSV). C If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the C ( Co ) C observability staircase form (1). C If JOBOBS = 'F', the submatrix Eo is upper triangular. C If JOBOBS = 'O', the Eno matrix has the form C C ( Efno * ) C Eno = ( ) , C ( 0 Eino ) C C where the NIUOBS-by-NIUOBS matrix Eino is nilpotent C and the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) matrix Efno C is nonsingular and upper triangular. C If JOBOBS = 'F', Eno is nonsingular and upper triangular. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,MAX(M,P)) C On entry, the leading N-by-M part of this array must C contain the N-by-M input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix Q'*B. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,N) if M > 0 or LDB >= 1 if M = 0. 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C C C*Z = ( 0 Co ) , C C where Co is P-by-NOBSV. C If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the C ( Co ) C observability staircase form (1). C If JOBOBS = 'F', the matrix ( Ao ) is in the observability C ( Co ) C staircase form (3). C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,M,P). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C If COMPQ = 'N': Q is not referenced. C If COMPQ = 'I': on entry, Q need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Q, C where Q' is the product of transformations C which are applied to A, E, and B on C the left. C If COMPQ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix C Qc; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Qc*Q. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C If COMPZ = 'N': Z is not referenced. C If COMPZ = 'I': on entry, Z need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Z, C which is the product of transformations C applied to A, E, and C on the right. C If COMPZ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix C Zc; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Zc*Z. C C LDZ INTEGER C The leading dimension of array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. C C NOBSV (output) INTEGER C The order of the reduced matrices Ao and Eo, and the C number of columns of reduced matrix Co; also the order of C observable part of the pair (C, A-lambda*E). C C NIUOBS (output) INTEGER C For JOBOBS = 'O', the order of the reduced matrices C Aino and Eino; also the number of unobservable C infinite eigenvalues of the pencil A - lambda*E. C For JOBOBS = 'F' or 'I', NIUOBS has no significance C and is set to zero. C C NLBLCK (output) INTEGER C For JOBOBS = 'O' or 'I', the number k, of full column rank C _ C blocks Ei-1,i in the staircase form of the pencil C (Eo-lambda*Ao) (see (1) and (2)). C ( Co ) C For JOBOBS = 'F', the number k, of full column rank blocks C _ C Ai-1,i in the staircase form of the pencil (Ao-lambda*Eo) C ( Co ) C (see (3) and (4)). C C CTAU (output) INTEGER array, dimension (N) C CTAU(i), for i = 1, ..., NLBLCK, is the column dimension C _ _ C of the full column rank block Ei-1,i or Ai-1,i in the C staircase form (1) or (3) for JOBOBS = 'O' or 'I', or C for JOBOBS = 'F', respectively. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determinations when C transforming (A'-lambda*E',C')'. If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C reciprocal condition numbers in rank determinations; a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*N*EPS, is used instead, where EPS C is the machine precision (see LAPACK Library routine C DLAMCH). TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (P) C C DWORK DOUBLE PRECISION array, dimension (MAX(N,2*P)) 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 subroutine is based on the dual of the reduction C algorithms of [1]. C C REFERENCES C C [1] A. Varga C Computation of Irreducible Generalized State-Space C Realizations. C Kybernetika, vol. 26, pp. 89-106, 1990. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N**3 ) floating point operations. C C FURTHER COMMENTS C C If the system matrices A, E and C are badly scaled, it is C generally recommendable to scale them with the SLICOT routine C TG01AD, before calling TG01ID. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C March 1999. Based on the RASP routine RPDSCF. C C REVISIONS C C July 1999, V. Sima, Research Institute for Informatics, Bucharest. C May 2003, March 2004, V. Sima. C C KEYWORDS C C Observability, minimal realization, orthogonal canonical form, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOBOBS INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, $ M, N, NIUOBS, NLBLCK, NOBSV, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER CTAU( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), $ Z( LDZ, * ) C .. Local Scalars .. CHARACTER JOBQ, JOBZ LOGICAL FINOBS, ILQ, ILZ, INFOBS INTEGER I, ICOMPQ, ICOMPZ, LBA, LBE, NR C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB07MD, DSWAP, MA02BD, MA02CD, TB01XD, $ TG01HX, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C C Decode JOBOBS. C IF( LSAME( JOBOBS, 'O') ) THEN FINOBS = .TRUE. INFOBS = .TRUE. ELSE IF( LSAME( JOBOBS, 'F') ) THEN FINOBS = .TRUE. INFOBS = .FALSE. ELSE IF( LSAME( JOBOBS, 'I') ) THEN FINOBS = .FALSE. INFOBS = .TRUE. ELSE FINOBS = .FALSE. INFOBS = .FALSE. END IF C C Decode COMPQ. C IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'U' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF C C Decode COMPZ. C IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'U' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF C C Test the input scalar parameters. C INFO = 0 IF( .NOT.FINOBS .AND. .NOT.INFOBS ) THEN INFO = -1 ELSE IF( ICOMPQ.LE.0 ) THEN INFO = -2 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN INFO = -12 ELSE IF( LDC.LT.MAX( 1, M, P ) ) THEN INFO = -14 ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -16 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -18 ELSE IF( TOL.GE.ONE ) THEN INFO = -23 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01ID', -INFO ) RETURN END IF C JOBQ = COMPQ JOBZ = COMPZ C C Build the dual system. C CALL AB07MD( 'Z', N, M, P, A, LDA, B, LDB, C, LDC, DUM, 1, $ INFO ) DO 10 I = 2, N CALL DSWAP( I-1, E(I,1), LDE, E(1,I), 1 ) 10 CONTINUE C IF( FINOBS ) THEN C C Perform finite observability form reduction. C CALL TG01HX( JOBZ, JOBQ, N, N, P, M, N, MAX( 0, N-1 ), A, LDA, $ E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NR, $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) IF( NLBLCK.GT.1 ) THEN LBA = CTAU(1) + CTAU(2) - 1 ELSE IF( NLBLCK.EQ.1 ) THEN LBA = CTAU(1) - 1 ELSE LBA = 0 END IF IF( ILQ ) JOBQ = 'U' IF( ILZ ) JOBZ = 'U' LBE = 0 ELSE NR = N LBA = MAX( 0, N-1 ) LBE = LBA END IF C IF( INFOBS ) THEN C C Perform infinite observability form reduction. C CALL TG01HX( JOBZ, JOBQ, N, N, P, M, NR, LBA, E, LDE, $ A, LDA, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NOBSV, $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) IF( FINOBS ) THEN NIUOBS = NR - NOBSV ELSE NIUOBS = 0 END IF IF( NLBLCK.GT.1 ) THEN LBE = CTAU(1) + CTAU(2) - 1 ELSE IF( NLBLCK.EQ.1 ) THEN LBE = CTAU(1) - 1 ELSE LBE = 0 END IF LBA = 0 ELSE NOBSV = NR NIUOBS = 0 END IF C C Compute the pertransposed dual system exploiting matrix shapes. C LBA = MAX( LBA, NIUOBS-1, N-NOBSV-NIUOBS-1 ) IF ( P.EQ.0 .OR. NR.EQ.0 ) $ LBE = MAX( 0, N - 1 ) CALL TB01XD( 'Z', N, P, M, LBA, MAX( 0, N-1 ), A, LDA, B, LDB, $ C, LDC, DUM, 1, INFO ) CALL MA02CD( N, LBE, MAX( 0, N-1 ), E, LDE ) IF( ILZ ) CALL MA02BD( 'Right', N, N, Z, LDZ ) IF( ILQ ) CALL MA02BD( 'Right', N, N, Q, LDQ ) RETURN C *** Last line of TG01ID *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09BD.f0000644000000000000000000000013215012430707016136 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB09BD.f0000644000175000017500000003206215012430707017335 0ustar00lilgelilge00000000000000 SUBROUTINE AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA, $ B, LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, $ DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable C original state-space representation (A,B,C,D) by using either the C square-root or the balancing-free square-root Singular C Perturbation Approximation (SPA) model reduction method. 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 JOB CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root SPA method; C = 'N': use the balancing-free square-root SPA method. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of C the resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. NR is set as follows: C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR C is the desired order on entry and NMIN is the order of a C minimal realization of the given system; NMIN is C determined as the number of Hankel singular values greater C than N*EPS*HNORM(A,B,C), where EPS is the machine C precision (see LAPACK Library Routine DLAMCH) and C HNORM(A,B,C) is the Hankel norm of the system (computed C in HSV(1)); C if ORDSEL = 'A', NR is equal to the number of Hankel C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). 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, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the C reduced order system. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, it contains the Hankel singular values of C the original system ordered decreasingly. HSV(1) is the C Hankel norm of the system. C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL1 = c*HNORM(A,B,C), where c is a constant in the C interval [0.00001,0.001], and HNORM(A,B,C) is the C Hankel-norm of the given system (computed in HSV(1)). C For computing a minimal realization, the recommended C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the C machine precision (see LAPACK Library Routine DLAMCH). C This value is used by default if TOL1 <= 0 on entry. C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the given system. The recommended value is C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default C if TOL2 <= 0 on entry. C If TOL2 > 0, then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension (MAX(1,2*N)) C On exit with INFO = 0, IWORK(1) contains the order of the C minimal realization of the system. 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,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than the order of a minimal realization of the C given system. In this case, the resulting NR is C set automatically to a value corresponding to the C order of a minimal realization of the system. 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 the real Schur form failed; C = 2: the state matrix A is not stable (if DICO = 'C') C or not convergent (if DICO = 'D'); C = 3: the computation of Hankel singular values failed. C C METHOD C C Let be the stable linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09BD determines for C the given system (1), the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t) (2) C C such that C C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], C C where G and Gr are transfer-function matrices of the systems C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the C infinity-norm of G. C C If JOB = 'B', the balancing-based square-root SPA method of [1] C is used and the resulting model is balanced. C C If JOB = 'N', the balancing-free square-root SPA method of [2] C is used. C By setting TOL1 = TOL2, the routine can be used to compute C Balance & Truncate approximations. C C REFERENCES C C [1] Liu Y. and Anderson B.D.O. C Singular Perturbation Approximation of Balanced Systems, C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. C C [2] Varga A. C Balancing-free square-root algorithm for computing singular C perturbation approximations. C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, C Vol. 2, pp. 1062-1065. C C NUMERICAL ASPECTS C C The implemented methods rely on accuracy enhancing square-root or C balancing-free square-root techniques. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C March 1998. C Based on the RASP routine SRBFSP. C C REVISIONS C C May 2, 1998. C November 11, 1998, V. Sima, Research Institute for Informatics, C Bucharest. C C KEYWORDS C C Balancing, minimal state-space representation, model reduction, C multivariable system, singular perturbation approximation, C state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, C100 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, JOB, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, $ M, N, NR, P DOUBLE PRECISION TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), HSV(*) C .. Local Scalars .. LOGICAL FIXORD INTEGER IERR, KI, KR, KT, KTI, KW, NN DOUBLE PRECISION MAXRED, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB09BX, TB01ID, TB01WD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C .. Executable Statements .. C INFO = 0 IWARN = 0 FIXORD = LSAME( ORDSEL, 'F' ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -3 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) 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( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -8 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -14 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -16 ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN INFO = -19 ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + $ ( N*( N + 1 ) )/2 ) ) THEN INFO = -22 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09BD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 IWORK(1) = 0 DWORK(1) = ONE RETURN END IF C C Allocate working storage. C NN = N*N KT = 1 KR = KT + NN KI = KR + N KW = KI + N C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Reduce A to the real Schur form using an orthogonal similarity C transformation A <- T'*A*T and apply the transformation to C B and C: B <- T'*B and C <- C*T. C CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF C WRKOPT = DWORK(KW) + DBLE( KW-1 ) C KTI = KT + NN KW = KTI + NN CALL AB09BX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, $ C, LDC, D, LDD, HSV, DWORK(KT), N, DWORK(KTI), N, $ TOL1, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, IWARN, $ IERR ) C IF( IERR.NE.0 ) THEN INFO = IERR + 1 RETURN END IF C DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) C RETURN C *** Last line of AB09BD *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01SW.f0000644000000000000000000000013015012430707016205 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MC01SW.f0000644000175000017500000000361315012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE MC01SW( A, B, M, E ) C C PURPOSE C C To find the mantissa M and the exponent E of a real number A such C that C A = M * B**E C 1 <= ABS( M ) < B C if A is non-zero. If A is zero, then M and E are set to 0. C C ARGUMENTS C C Input/Output Parameters C C A (input) DOUBLE PRECISION C The number whose mantissa and exponent are required. C C B (input) INTEGER C The base of the floating-point arithmetic. C C M (output) DOUBLE PRECISION C The mantissa of the floating-point representation of A. C C E (output) INTEGER C The exponent of the floating-point representation of A. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01GZ by A.J. Geurts. C C REVISIONS C C - C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER B, E DOUBLE PRECISION A, M C .. Local Scalars .. DOUBLE PRECISION DB C .. Intrinsic Functions .. INTRINSIC ABS, DBLE C .. Executable Statements .. C C Quick return if possible. C IF ( A.EQ.ZERO ) THEN M = ZERO E = 0 RETURN END IF C C A non-zero. C DB = DBLE( B ) M = ABS( A ) E = 0 C WHILE ( M >= B ) DO 20 IF ( M.GE.DB ) THEN M = M/DB E = E + 1 GO TO 20 END IF C END WHILE 20 C WHILE ( M < 1 ) DO 40 IF ( M.LT.ONE ) THEN M = M*DB E = E - 1 GO TO 40 END IF C END WHILE 40 C IF ( A.LT.ZERO ) M = -M C RETURN C *** Last line of MC01SW *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03OU.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03OU.f0000644000175000017500000003564515012430707017421 0ustar00lilgelilge00000000000000 SUBROUTINE SB03OU( DISCR, LTRANS, N, M, A, LDA, B, LDB, TAU, U, $ LDU, SCALE, DWORK, LDWORK, INFO ) C C PURPOSE C C To solve for X = op(U)'*op(U) either the stable non-negative C definite continuous-time Lyapunov equation C 2 C op(A)'*X + X*op(A) = -scale *op(B)'*op(B) (1) C C or the convergent non-negative definite discrete-time Lyapunov C equation C 2 C op(A)'*X*op(A) - X = -scale *op(B)'*op(B) (2) C C where op(K) = K or K' (i.e., the transpose of the matrix K), A is C an N-by-N matrix in real Schur form, op(B) is an M-by-N matrix, C U is an upper triangular matrix containing the Cholesky factor of C the solution matrix X, X = op(U)'*op(U), and scale is an output C scale factor, set less than or equal to 1 to avoid overflow in X. C If matrix B has full rank then the solution matrix X will be C positive-definite and hence the Cholesky factor U will be C nonsingular, but if B is rank deficient then X may only be C positive semi-definite and U will be singular. C C In the case of equation (1) the matrix A must be stable (that C is, all the eigenvalues of A must have negative real parts), C and for equation (2) the matrix A must be convergent (that is, C all the eigenvalues of A must lie inside the unit circle). C C ARGUMENTS C C Mode Parameters C C DISCR LOGICAL C Specifies the type of Lyapunov equation to be solved as C follows: C = .TRUE. : Equation (2), discrete-time case; C = .FALSE.: Equation (1), continuous-time case. C C LTRANS LOGICAL C Specifies the form of op(K) to be used, as follows: C = .FALSE.: op(K) = K (No transpose); C = .TRUE. : op(K) = K**T (Transpose). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A and the number of columns in C matrix op(B). N >= 0. C C M (input) INTEGER C The number of rows in matrix op(B). M >= 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 a real Schur form matrix S. The elements C below the upper Hessenberg part of the array A are not C referenced. The 2-by-2 blocks must only correspond to C complex conjugate pairs of eigenvalues (not to real C eigenvalues). 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 if LTRANS = .FALSE., and dimension (LDB,M), if C LTRANS = .TRUE.. C On entry, if LTRANS = .FALSE., the leading M-by-N part of C this array must contain the coefficient matrix B of the C equation. C On entry, if LTRANS = .TRUE., the leading N-by-M part of C this array must contain the coefficient matrix B of the C equation. C On exit, if LTRANS = .FALSE., the leading C MIN(M,N)-by-MIN(M,N) upper triangular part of this array C contains the upper triangular matrix R (as defined in C METHOD), and the M-by-MIN(M,N) strictly lower triangular C part together with the elements of the array TAU are C overwritten by details of the matrix P (also defined in C METHOD). When M < N, columns (M+1),...,N of the array B C are overwritten by the matrix Z (see METHOD). C On exit, if LTRANS = .TRUE., the leading C MIN(M,N)-by-MIN(M,N) upper triangular part of C B(1:N,M-N+1), if M >= N, or of B(N-M+1:N,1:M), if M < N, C contains the upper triangular matrix R (as defined in C METHOD), and the remaining elements (below the diagonal C of R) together with the elements of the array TAU are C overwritten by details of the matrix P (also defined in C METHOD). When M < N, rows 1,...,(N-M) of the array B C are overwritten by the matrix Z (see METHOD). C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,M), if LTRANS = .FALSE., C LDB >= MAX(1,N), if LTRANS = .TRUE.. C C TAU (output) DOUBLE PRECISION array of dimension (MIN(N,M)) C This array contains the scalar factors of the elementary C reflectors defining the matrix P. C C U (output) DOUBLE PRECISION array of dimension (LDU,N) C The leading N-by-N upper triangular part of this array C contains the Cholesky factor of the solution matrix X of C the problem, X = op(U)'*op(U). C The array U may be identified with B in the calling C statement, if B is properly dimensioned, and the C intermediate results returned in B are not needed. C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,N). 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 Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the C optimal value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,4*N). C For optimum performance LDWORK should sometimes be larger. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 = 1: if the Lyapunov equation is (nearly) singular C (warning indicator); C if DISCR = .FALSE., this means that while the matrix C A has computed eigenvalues with negative real parts, C it is only just stable in the sense that small C perturbations in A can make one or more of the C eigenvalues have a non-negative real part; C if DISCR = .TRUE., this means that while the matrix C A has computed eigenvalues inside the unit circle, C it is nevertheless only just convergent, in the C sense that small perturbations in A can make one or C more of the eigenvalues lie outside the unit circle; C perturbed values were used to solve the equation C (but the matrix A is unchanged); C = 2: if matrix A is not stable (that is, one or more of C the eigenvalues of A has a non-negative real part), C if DISCR = .FALSE., or not convergent (that is, one C or more of the eigenvalues of A lies outside the C unit circle), if DISCR = .TRUE.; C = 3: if matrix A has two or more consecutive non-zero C elements on the first sub-diagonal, so that there is C a block larger than 2-by-2 on the diagonal; C = 4: if matrix A has a 2-by-2 diagonal block with real C eigenvalues instead of a complex conjugate pair. C C METHOD C C The method used by the routine is based on the Bartels and C Stewart method [1], except that it finds the upper triangular C matrix U directly without first finding X and without the need C to form the normal matrix op(B)'*op(B) [2]. C C If LTRANS = .FALSE., the matrix B is factored as C C B = P ( R ), M >= N, B = P ( R Z ), M < N, C ( 0 ) C C (QR factorization), where P is an M-by-M orthogonal matrix and C R is a square upper triangular matrix. C C If LTRANS = .TRUE., the matrix B is factored as C C B = ( 0 R ) P, M >= N, B = ( Z ) P, M < N, C ( R ) C C (RQ factorization), where P is an M-by-M orthogonal matrix and C R is a square upper triangular matrix. C C These factorizations are used to solve the continuous-time C Lyapunov equation in the canonical form C 2 C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), C C or the discrete-time Lyapunov equation in the canonical form C 2 C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F), C C where U and F are N-by-N upper triangular matrices, and C C F = R, if M >= N, or C C F = ( R ), if LTRANS = .FALSE., or C ( 0 ) C C F = ( 0 Z ), if LTRANS = .TRUE., if M < N. C ( 0 R ) C C The canonical equation is solved for U. C C REFERENCES C C [1] Bartels, R.H. and Stewart, G.W. C Solution of the matrix equation A'X + XB = C. C Comm. A.C.M., 15, pp. 820-826, 1972. C C [2] 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 The Lyapunov equation may be very ill-conditioned. In particular, C if A is only just stable (or convergent) then the Lyapunov C equation will be ill-conditioned. "Large" elements in U relative C to those of A and B, or a "small" value for scale, are symptoms C of ill-conditioning. A condition estimate can be computed using C SLICOT Library routine SB03MD. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. C Supersedes Release 2.0 routine SB03CZ by Sven Hammarling, C NAG Ltd, United Kingdom. C Partly based on routine PLYAPS by A. Varga, University of Bochum, C May 1992. C C REVISIONS C C Dec. 1997, April 1998, May 1999, July 2011. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. LOGICAL DISCR, LTRANS INTEGER INFO, LDA, LDB, LDU, LDWORK, M, N DOUBLE PRECISION SCALE C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*), U(LDU,*) C .. Local Scalars .. LOGICAL LQUERY INTEGER I, J, K, L, MINWRK, MN, WRKOPT C .. External Subroutines .. EXTERNAL DCOPY, DGEQRF, DGERQF, DLACPY, DLASET, SB03OT, $ 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 = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( ( LDB.LT.MAX( 1, M ) .AND. .NOT.LTRANS ) .OR. $ ( LDB.LT.MAX( 1, N ) .AND. LTRANS ) ) THEN INFO = -8 ELSE IF( LDU.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE MINWRK = MAX( 1, 4*N ) LQUERY = LDWORK.EQ.-1 IF( LQUERY ) THEN IF ( LTRANS ) THEN CALL DGERQF( N, M, B, LDB, TAU, DWORK, -1, INFO ) ELSE CALL DGEQRF( M, N, B, LDB, TAU, DWORK, -1, INFO ) END IF WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -14 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB03OU', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C MN = MIN( N, M ) IF ( MN.EQ.0 ) THEN SCALE = ONE DWORK(1) = ONE RETURN 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 NB refers to the optimal block size for the immediately C following subroutine, as returned by ILAENV.) C IF ( LTRANS ) THEN C C Case op(K) = K'. C C Perform the RQ factorization of B. C Workspace: need N; C prefer N*NB. C CALL DGERQF( N, M, B, LDB, TAU, DWORK, LDWORK, INFO ) C C The triangular matrix F is constructed in the array U so that C U can share the same memory as B. C IF ( M.GE.N ) THEN CALL DLACPY( 'Upper', MN, N, B(1,M-N+1), LDB, U, LDU ) ELSE C DO 10 I = M, 1, -1 CALL DCOPY( N-M+I, B(1,I), 1, U(1,N-M+I), 1 ) 10 CONTINUE C CALL DLASET( 'Full', N, N-M, ZERO, ZERO, U, LDU ) END IF ELSE C C Case op(K) = K. C C Perform the QR factorization of B. C Workspace: need N; C prefer N*NB. C CALL DGEQRF( M, N, B, LDB, TAU, DWORK, LDWORK, INFO ) CALL DLACPY( 'Upper', MN, N, B, LDB, U, LDU ) IF ( M.LT.N ) $ CALL DLASET( 'Upper', N-M, N-M, ZERO, ZERO, U(M+1,M+1), $ LDU ) END IF WRKOPT = DWORK(1) C C Solve the canonical Lyapunov equation C 2 C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), C C or C 2 C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F) C C for U. C CALL SB03OT( DISCR, LTRANS, N, A, LDA, U, LDU, SCALE, DWORK, $ INFO ) IF ( INFO.NE.0 .AND. INFO.NE.1 ) $ RETURN C C Make the diagonal elements of U non-negative. C IF ( LTRANS ) THEN C DO 30 J = 1, N IF ( U(J,J).LT.ZERO ) THEN C DO 20 I = 1, J U(I,J) = -U(I,J) 20 CONTINUE C END IF 30 CONTINUE C ELSE K = 1 C DO 50 J = 1, N DWORK(K) = U(J,J) L = 1 C DO 40 I = 1, J IF ( DWORK(L).LT.ZERO ) U(I,J) = -U(I,J) L = L + 1 40 CONTINUE C K = K + 1 50 CONTINUE C END IF C DWORK(1) = MAX( WRKOPT, 4*N ) RETURN C *** Last line of SB03OU *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04WR.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04WR.f0000644000175000017500000003066515012430707017416 0ustar00lilgelilge00000000000000 SUBROUTINE MB04WR( JOB, TRANS, N, ILO, Q1, LDQ1, Q2, LDQ2, CS, $ TAU, DWORK, LDWORK, INFO ) C C PURPOSE C C To generate orthogonal symplectic matrices U or V, defined as C products of symplectic reflectors and Givens rotations C C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) C .... C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), C C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) C .... C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ), C C as returned by the SLICOT Library routines MB04TS or MB04TB. The C matrices U and V are returned in terms of their first N/2 rows: C C [ U1 U2 ] [ V1 V2 ] C U = [ ], V = [ ]. C [ -U2 U1 ] [ -V2 V1 ] C C ARGUMENTS C C Input/Output Parameters C C JOB CHARACTER*1 C Specifies whether the matrix U or the matrix V is C required: C = 'U': generate U; C = 'V': generate V. C C TRANS CHARACTER*1 C If JOB = 'U' then TRANS must have the same value as C the argument TRANA in the previous call of MB04TS or C MB04TB. C If JOB = 'V' then TRANS must have the same value as C the argument TRANB in the previous call of MB04TS or C MB04TB. C C N (input) INTEGER C The order of the matrices Q1 and Q2. N >= 0. C C ILO (input) INTEGER C ILO must have the same value as in the previous call of C MB04TS or MB04TB. U and V are equal to the unit matrix C except in the submatrices C U([ilo:n n+ilo:2*n], [ilo:n n+ilo:2*n]) and C V([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]), C respectively. C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. C C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1,N) C On entry, if JOB = 'U' and TRANS = 'N' then the C leading N-by-N part of this array must contain in its i-th C column the vector which defines the elementary reflector C FU(i). C If JOB = 'U' and TRANS = 'T' or TRANS = 'C' then the C leading N-by-N part of this array must contain in its i-th C row the vector which defines the elementary reflector C FU(i). C If JOB = 'V' and TRANS = 'N' then the leading N-by-N C part of this array must contain in its i-th row the vector C which defines the elementary reflector FV(i). C If JOB = 'V' and TRANS = 'T' or TRANS = 'C' then the C leading N-by-N part of this array must contain in its i-th C column the vector which defines the elementary reflector C FV(i). C On exit, if JOB = 'U' and TRANS = 'N' then the leading C N-by-N part of this array contains the matrix U1. C If JOB = 'U' and TRANS = 'T' or TRANS = 'C' then the C leading N-by-N part of this array contains the matrix C U1**T. C If JOB = 'V' and TRANS = 'N' then the leading N-by-N C part of this array contains the matrix V1**T. C If JOB = 'V' and TRANS = 'T' or TRANS = 'C' then the C leading N-by-N part of this array contains the matrix V1. C C LDQ1 INTEGER C The leading dimension of the array Q1. LDQ1 >= MAX(1,N). C C Q2 (input/output) DOUBLE PRECISION array, dimension (LDQ2,N) C On entry, if JOB = 'U' then the leading N-by-N part of C this array must contain in its i-th column the vector C which defines the elementary reflector HU(i). C If JOB = 'V' then the leading N-by-N part of this array C must contain in its i-th row the vector which defines the C elementary reflector HV(i). C On exit, if JOB = 'U' then the leading N-by-N part of C this array contains the matrix U2. C If JOB = 'V' then the leading N-by-N part of this array C contains the matrix V2**T. C C LDQ2 INTEGER C The leading dimension of the array Q2. LDQ2 >= MAX(1,N). C C CS (input) DOUBLE PRECISION array, dimension (2N) C On entry, if JOB = 'U' then the first 2N elements of C this array must contain the cosines and sines of the C symplectic Givens rotations GU(i). C If JOB = 'V' then the first 2N-2 elements of this array C must contain the cosines and sines of the symplectic C Givens rotations GV(i). C C TAU (input) DOUBLE PRECISION array, dimension (N) C On entry, if JOB = 'U' then the first N elements of C this array must contain the scalar factors of the C elementary reflectors FU(i). C If JOB = 'V' then the first N-1 elements of this array C must contain the scalar factors of the elementary C reflectors FV(i). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -12, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1,2*(N-ILO+1)). 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] Benner, P., Mehrmann, V., and Xu, H. C A numerically stable, structure preserving method for C computing the eigenvalues of real Hamiltonian or symplectic C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. C C [2] Kressner, D. C Block algorithms for orthogonal symplectic factorizations. C BIT, 43 (4), pp. 775-790, 2003. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSU). C V. Sima, Aug. 2011. C C KEYWORDS C C Elementary matrix operations, Hamiltonian matrix, orthogonal C symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. Scalar Arguments .. CHARACTER JOB, TRANS INTEGER ILO, INFO, LDQ1, LDQ2, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) C .. Local Scalars .. LOGICAL COMPU, LQUERY, LTRAN INTEGER I, IERR, J, MINWRK, NH, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLASET, MB04WD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) COMPU = LSAME( JOB, 'U' ) IF ( .NOT.COMPU .AND. .NOT.LSAME( JOB, 'V' ) ) THEN INFO = -1 ELSE IF ( .NOT.LTRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN INFO = -2 ELSE IF ( N.LT.0 ) THEN INFO = -3 ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF ( LDQ1.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF ( LDQ2.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE LQUERY = LDWORK.EQ.-1 IF ( COMPU ) THEN NH = N - ILO + 1 ELSE NH = N - ILO END IF MINWRK = MAX( 1, 2*NH ) IF ( LQUERY ) THEN IF ( NH.LT.0 ) THEN WRKOPT = ONE ELSE CALL MB04WD( TRANS, TRANS, NH, NH, NH, Q1, LDQ1, Q2, $ LDQ2, CS, TAU, DWORK, -1, IERR ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) END IF DWORK(1) = DBLE( WRKOPT ) RETURN ELSE IF ( LDWORK.LT.MINWRK ) THEN DWORK(1) = DBLE( MINWRK ) INFO = -12 END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04WR', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C IF ( COMPU ) THEN CALL DLASET( 'All', N, ILO-1, ZERO, ONE, Q1, LDQ1 ) CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q1(1,ILO), $ LDQ1 ) CALL DLASET( 'All', N, ILO-1, ZERO, ZERO, Q2, LDQ2 ) CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q2(1,ILO), $ LDQ2 ) END IF IF ( COMPU .AND. .NOT.LTRAN ) THEN C C Generate U1 and U2. C CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH, $ Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO), $ TAU(ILO), DWORK, LDWORK, IERR ) ELSE IF ( COMPU.AND.LTRAN ) THEN C C Generate U1**T and U2. C CALL MB04WD( 'Transpose', 'No Transpose', NH, NH, NH, $ Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO), $ TAU(ILO), DWORK, LDWORK, IERR ) ELSE IF ( .NOT.COMPU .AND. .NOT.LTRAN ) THEN C C Generate V1**T and V2**T. C C Shift the vectors which define the elementary reflectors one C column to the bottom, and set the first ilo rows and C columns to those of the unit matrix. C DO 40 I = 1, N DO 10 J = N, MAX( I, ILO )+1, -1 Q1(J,I) = ZERO 10 CONTINUE DO 20 J = MAX( I, ILO ), ILO+1, -1 Q1(J,I) = Q1(J-1,I) 20 CONTINUE DO 30 J = ILO, 1, -1 Q1(J,I) = ZERO 30 CONTINUE IF ( I.LE.ILO ) Q1(I,I) = ONE 40 CONTINUE DO 80 I = 1, N DO 50 J = N, MAX( I, ILO )+1, -1 Q2(J,I) = ZERO 50 CONTINUE DO 60 J = MAX( I, ILO ), ILO+1, -1 Q2(J,I) = Q2(J-1,I) 60 CONTINUE DO 70 J = ILO, 1, -1 Q2(J,I) = ZERO 70 CONTINUE 80 CONTINUE C IF ( NH.GT.0 ) THEN CALL MB04WD( 'Transpose', 'Transpose', NH, NH, NH, $ Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2, $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) ELSE DWORK(1) = ONE END IF ELSE IF ( .NOT.COMPU .AND. LTRAN ) THEN C C Generate V1 and V2**T. C C Shift the vectors which define the elementary reflectors one C column to the right/bottom, and set the first ilo rows and C columns to those of the unit matrix. C DO 110 J = N, ILO + 1, -1 DO 90 I = 1, J-1 Q1(I,J) = ZERO 90 CONTINUE DO 100 I = J+1, N Q1(I,J) = Q1(I,J-1) 100 CONTINUE 110 CONTINUE CALL DLASET( 'All', N, ILO, ZERO, ONE, Q1, LDQ1 ) DO 150 I = 1, N DO 120 J = N, MAX( I, ILO )+1, -1 Q2(J,I) = ZERO 120 CONTINUE DO 130 J = MAX( I, ILO ), ILO+1, -1 Q2(J,I) = Q2(J-1,I) 130 CONTINUE DO 140 J = ILO, 1, -1 Q2(J,I) = ZERO 140 CONTINUE 150 CONTINUE C IF ( NH.GT.0 ) THEN CALL MB04WD( 'No Transpose', 'Transpose', NH, NH, NH, $ Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2, $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) ELSE DWORK(1) = ONE END IF END IF RETURN C *** Last line of MB04WR *** END control-4.1.2/src/slicot/src/PaxHeaders/DF01MD.f0000644000000000000000000000013215012430707016150 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/DF01MD.f0000644000175000017500000001676215012430707017360 0ustar00lilgelilge00000000000000 SUBROUTINE DF01MD( SICO, N, DT, A, DWORK, INFO ) C C PURPOSE C C To compute the sine transform or cosine transform of a real C signal. C C ARGUMENTS C C Mode Parameters C C SICO CHARACTER*1 C Indicates whether the sine transform or cosine transform C is to be computed as follows: C = 'S': The sine transform is computed; C = 'C': The cosine transform is computed. C C Input/Output Parameters C C N (input) INTEGER C The number of samples. N must be a power of 2 plus 1. C N >= 5. C C DT (input) DOUBLE PRECISION C The sampling time of the signal. C C A (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the signal to be C processed. C On exit, this array contains either the sine transform, if C SICO = 'S', or the cosine transform, if SICO = 'C', of the C given signal. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (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 Let A(1), A(2),..., A(N) be a real signal of N samples. C C If SICO = 'S', the routine computes the sine transform of A as C follows. First, transform A(i), i = 1,2,...,N, into the complex C signal B(i), i = 1,2,...,(N+1)/2, where C C B(1) = -2*A(2), C B(i) = {A(2i-2) - A(2i)} - j*A(2i-1) for i = 2,3,...,(N-1)/2, C B((N+1)/2) = 2*A(N-1) and j**2 = -1. C C Next, perform a discrete inverse Fourier transform on B(i) by C calling SLICOT Library Routine DG01ND, to give the complex signal C Z(i), i = 1,2,...,(N-1)/2, from which the real signal C(i) may be C obtained as follows: C C C(2i-1) = Re(Z(i)), C(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2. C C Finally, compute the sine transform coefficients S ,S ,...,S C 1 2 N C given by C C S = 0, C 1 C { [C(k) + C(N+1-k)] } C S = DT*{[C(k) - C(N+1-k)] - -----------------------}, C k { [2*sin(pi*(k-1)/(N-1))]} C C for k = 2,3,...,N-1, and C C S = 0. C N C C If SICO = 'C', the routine computes the cosine transform of A as C follows. First, transform A(i), i = 1,2,...,N, into the complex C signal B(i), i = 1,2,...,(N+1)/2, where C C B(1) = 2*A(1), C B(i) = 2*A(2i-1) + 2*j*{[A(2i-2) - A(2i)]} C for i = 2,3,...,(N-1)/2 and B((N+1)/2) = 2*A(N). C C Next, perform a discrete inverse Fourier transform on B(i) by C calling SLICOT Library Routine DG01ND, to give the complex signal C Z(i), i = 1,2,...,(N-1)/2, from which the real signal D(i) may be C obtained as follows: C C D(2i-1) = Re(Z(i)), D(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2. C C Finally, compute the cosine transform coefficients S ,S ,...,S C 1 2 N C given by C C S = 2*DT*[D(1) + A0], C 1 C { [D(k) - D(N+1-k)] } C S = DT*{[D(k) + D(N+1-k)] - -----------------------}, C k { [2*sin(pi*(k-1)/(N-1))]} C C C for k = 2,3,...,N-1, and C C S = 2*DT*[D(1) - A0], C N C (N-1)/2 C where A0 = 2*SUM A(2i). C i=1 C C REFERENCES C C [1] Rabiner, L.R. and Rader, C.M. C Digital Signal Processing. C IEEE Press, 1972. C C [2] Oppenheim, A.V. and Schafer, R.W. C Discrete-Time Signal Processing. C Prentice-Hall Signal Processing Series, 1989. C C NUMERICAL ASPECTS C C The algorithm requires 0( N*log(N) ) operations. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C Supersedes Release 2.0 routine DF01AD by F. Dumortier, and C R.M.C. Dekeyser, State University of Gent, Belgium. C C REVISIONS C C V. Sima, Jan. 2003. C C KEYWORDS C C Digital signal processing, fast Fourier transform, complex C signals. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, FOUR PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ FOUR = 4.0D0 ) C .. Scalar Arguments .. CHARACTER SICO INTEGER INFO, N DOUBLE PRECISION DT C .. Array Arguments .. DOUBLE PRECISION A(*), DWORK(*) C .. Local Scalars .. LOGICAL LSICO, LSIG INTEGER I, I2, IND1, IND2, M, MD2 DOUBLE PRECISION A0, PIBYM, W1, W2, W3 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DG01ND, XERBLA C .. Intrinsic Functions .. INTRINSIC ATAN, DBLE, MOD, SIN C .. Executable Statements .. C INFO = 0 LSICO = LSAME( SICO, 'S' ) C C Test the input scalar arguments. C IF( .NOT.LSICO .AND. .NOT.LSAME( SICO, 'C' ) ) THEN INFO = -1 ELSE M = 0 IF( N.GT.4 ) THEN M = N - 1 C WHILE ( MOD( M, 2 ).EQ.0 ) DO 10 CONTINUE IF ( MOD( M, 2 ).EQ.0 ) THEN M = M/2 GO TO 10 END IF C END WHILE 10 END IF IF ( M.NE.1 ) INFO = -2 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'DF01MD', -INFO ) RETURN END IF C C Initialisation. C M = N - 1 MD2 = ( N + 1 )/2 PIBYM = FOUR*ATAN( ONE )/DBLE( M ) I2 = 1 DWORK(MD2+1) = ZERO DWORK(2*MD2) = ZERO C IF ( LSICO ) THEN C C Sine transform. C LSIG = .TRUE. DWORK(1) = -TWO*A(2) DWORK(MD2) = TWO*A(M) C DO 20 I = 4, M, 2 I2 = I2 + 1 DWORK(I2) = A(I-2) - A(I) DWORK(MD2+I2) = -A(I-1) 20 CONTINUE C ELSE C C Cosine transform. C LSIG = .FALSE. DWORK(1) = TWO*A(1) DWORK(MD2) = TWO*A(N) A0 = A(2) C DO 30 I = 4, M, 2 I2 = I2 + 1 DWORK(I2) = TWO*A(I-1) DWORK(MD2+I2) = TWO*( A(I-2) - A(I) ) A0 = A0 + A(I) 30 CONTINUE C A0 = TWO*A0 END IF C C Inverse Fourier transform. C CALL DG01ND( 'Inverse', MD2-1, DWORK(1), DWORK(MD2+1), INFO ) C C Sine or cosine coefficients. C IF ( LSICO ) THEN A(1) = ZERO A(N) = ZERO ELSE A(1) = TWO*DT*( DWORK(1) + A0 ) A(N) = TWO*DT*( DWORK(1) - A0 ) END IF C IND1 = MD2 + 1 IND2 = N C DO 40 I = 1, M - 1, 2 W1 = DWORK(IND1) W2 = DWORK(IND2) IF ( LSIG ) W2 = -W2 W3 = TWO*SIN( PIBYM*DBLE( I ) ) A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 ) IND1 = IND1 + 1 IND2 = IND2 - 1 40 CONTINUE C IND1 = 2 IND2 = MD2 - 1 C DO 50 I = 2, M - 2, 2 W1 = DWORK(IND1) W2 = DWORK(IND2) IF ( LSIG ) W2 = -W2 W3 = TWO*SIN( PIBYM*DBLE( I ) ) A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 ) IND1 = IND1 + 1 IND2 = IND2 - 1 50 CONTINUE C RETURN C *** Last line of DF01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03RD.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03RD.f0000644000175000017500000003172315012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE SB03RD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, $ SCALE, SEP, FERR, WR, WI, IWORK, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To solve the real Lyapunov matrix equation C C op(A)'*X + X*op(A) = scale*C C C and/or estimate the separation between the matrices op(A) and C -op(A)', 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 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 On exit, if INFO = 0 or INFO = N+1, the leading N-by-N C part of this array contains the upper quasi-triangular C matrix in Schur canonical form from the Shur factorization C of A. The contents of array A is not modified if C 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 it must contain the orthogonal matrix U from the real C 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)'. 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 C an 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 the C 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; 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; C If FACT = 'N', LDWORK >= MAX(2*N*N,3*N). 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 the matrices A and -A' have common or very C close eigenvalues; perturbed values were used to C solve the equation (but the matrix A is unchanged). C C METHOD C C After reducing matrix A to real Schur canonical form (if needed), C the Bartels-Stewart algorithm is used. A set of equivalent linear C algebraic systems of equations of order at most four are formed C and solved using Gaussian elimination with complete pivoting. C C REFERENCES C C [1] 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 NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C FURTHER COMMENTS C C SEP is defined as the separation of op(A) and -op(A)': 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) ). C C I(N) is an N-by-N 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 C C where EPS is the machine precision. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. C Supersedes Release 2.0 routine MB03AD by Control Systems Research C Group, Kingston Polytechnic, United Kingdom, October 1982. C Based on DGELYP by P. Petkov, Tech. University of Sofia, September C 1993. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, May 2020. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER FACT, JOB, TRANA INTEGER INFO, LDA, LDC, LDU, LDWORK, N DOUBLE PRECISION FERR, SCALE, SEP C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), $ U( LDU, * ), WI( * ), WR( * ) C .. C .. Local Scalars .. LOGICAL NOFACT, NOTA, WANTBH, WANTSP, WANTX CHARACTER NOTRA, UPLO INTEGER I, IERR, KASE, LWA, MINWRK, SDIM DOUBLE PRECISION EST, SCALEF C .. C .. Local Arrays .. LOGICAL BWORK( 1 ) INTEGER ISAVE( 3 ) C .. C .. External Functions .. LOGICAL LSAME, SELECT DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS, LSAME, SELECT C .. C .. External Subroutines .. EXTERNAL DCOPY, DGEES, DLACN2, MB01RD, SB03MY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX C .. C .. Executable Statements .. C C Decode and Test input parameters. C WANTX = LSAME( JOB, 'X' ) WANTSP = LSAME( JOB, 'S' ) WANTBH = LSAME( JOB, 'B' ) NOFACT = LSAME( FACT, 'N' ) NOTA = LSAME( TRANA, 'N' ) C INFO = 0 IF( .NOT.WANTSP .AND. .NOT.WANTBH .AND. .NOT.WANTX ) THEN INFO = -1 ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. $ .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDU.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( WANTSP .AND. LDC.LT.1 .OR. $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN INFO = -10 END IF C C Compute workspace. C IF( WANTX ) THEN IF( NOFACT ) THEN MINWRK = MAX( N*N, 3*N ) ELSE MINWRK = N*N END IF ELSE IF( NOFACT ) THEN MINWRK = MAX( 2*N*N, 3*N ) ELSE MINWRK = 2*N*N END IF END IF IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN INFO = -18 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03RD', -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 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: need N*N. C UPLO = 'U' CALL MB01RD( UPLO, 'Transpose', 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 C Solve the transformed equation. C CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) IF( INFO.GT.0 ) $ INFO = N + 1 C C Transform back the solution. C CALL MB01RD( UPLO, 'No transpose', N, N, ZERO, ONE, C, LDC, U, $ LDU, C, LDC, DWORK, LDWORK, INFO ) 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 sep(op(A),-op(A)'). C Workspace: 2*N*N. C IF( NOTA ) THEN NOTRA = 'T' ELSE NOTRA = 'N' END IF C EST = ZERO KASE = 0 C REPEAT 30 CONTINUE CALL DLACN2( N*N, DWORK( N*N+1 ), DWORK, IWORK, EST, KASE, $ ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF, IERR ) ELSE CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF, IERR ) END IF GO TO 30 END IF C UNTIL KASE = 0 C SEP = SCALEF / EST C IF( WANTBH ) THEN C C Compute the estimate of the relative error. C FERR = DLAMCH( 'Precision' )* $ DLANHS( 'Frobenius', N, A, LDA, DWORK ) / SEP END IF END IF C DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) C RETURN C *** Last line of SB03RD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01FD.f0000644000000000000000000000013215012430707016162 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01FD.f0000644000175000017500000006262415012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE TG01FD( COMPQ, COMPZ, JOBA, L, N, M, P, A, LDA, E, LDE, $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, $ TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute for the descriptor system (A-lambda E,B,C) C the orthogonal transformation matrices Q and Z such that the C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is C in a SVD-like coordinate form with C C ( A11 A12 ) ( Er 0 ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) , C ( A21 A22 ) ( 0 0 ) C C where Er is an upper triangular invertible matrix. C Optionally, the A22 matrix can be further reduced to the form C C ( Ar X ) C A22 = ( ) , C ( 0 0 ) C C with Ar an upper triangular invertible matrix, and X either a full C or a zero matrix. C The left and/or right orthogonal transformations performed C to reduce E and A22 can be optionally accumulated. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C = 'N': do not compute Q; C = 'I': Q is initialized to the unit matrix, and the C orthogonal matrix Q is returned; C = 'U': Q must contain an orthogonal matrix Q1 on entry, C and the product Q1*Q is returned. C C COMPZ CHARACTER*1 C = 'N': do not compute Z; C = 'I': Z is initialized to the unit matrix, and the C orthogonal matrix Z is returned; C = 'U': Z must contain an orthogonal matrix Z1 on entry, C and the product Z1*Z is returned. C C JOBA CHARACTER*1 C = 'N': do not reduce A22; C = 'R': reduce A22 to a SVD-like upper triangular form. C = 'T': reduce A22 to an upper trapezoidal form. C C Input/Output Parameters C C L (input) INTEGER C The number of rows of matrices A, B, and E. L >= 0. C C N (input) INTEGER C The number of columns of matrices A, E, and C. N >= 0. C C M (input) INTEGER C The number of columns of matrix B. M >= 0. C C P (input) INTEGER C The number of rows of matrix C. P >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the state dynamics matrix A. C On exit, the leading L-by-N part of this array contains C the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix C is in the form C C ( A11 * * ) C Q'*A*Z = ( * Ar X ) , C ( * 0 0 ) C C where A11 is a RANKE-by-RANKE matrix and Ar is a C RNKA22-by-RNKA22 invertible upper triangular matrix. C If JOBA = 'R' then A has the above form with X = 0. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,L). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the descriptor matrix E. C On exit, the leading L-by-N part of this array contains C the transformed matrix Q'*E*Z. C C ( Er 0 ) C Q'*E*Z = ( ) , C ( 0 0 ) C C where Er is a RANKE-by-RANKE upper triangular invertible C matrix. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,L). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, the leading L-by-M part of this array must C contain the input/state matrix B. C On exit, the leading L-by-M part of this array contains C the transformed matrix Q'*B. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Z. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) C If COMPQ = 'N': Q is not referenced. C If COMPQ = 'I': on entry, Q need not be set; C on exit, the leading L-by-L part of this C array contains the orthogonal matrix Q, C where Q' is the product of Householder C transformations which are applied to A, C E, and B on the left. C If COMPQ = 'U': on entry, the leading L-by-L part of this C array must contain an orthogonal matrix C Q1; C on exit, the leading L-by-L part of this C array contains the orthogonal matrix C Q1*Q. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C If COMPZ = 'N': Z is not referenced. C If COMPZ = 'I': on entry, Z need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Z, C which is the product of Householder C transformations applied to A, E, and C C on the right. C If COMPZ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix C Z1; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Z1*Z. C C LDZ INTEGER C The leading dimension of array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. C C RANKE (output) INTEGER C The estimated rank of matrix E, and thus also the order C of the invertible upper triangular submatrix Er. C C RNKA22 (output) INTEGER C If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of C matrix A22, and thus also the order of the invertible C upper triangular submatrix Ar. C If JOBA = 'N', then RNKA22 is not referenced. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in determining the rank of E C and of A22. If the user sets TOL > 0, then the given C value of TOL is used as a lower bound for the C reciprocal condition numbers of leading submatrices C of R or R22 in the QR decompositions E * P = Q * R of E C or A22 * P22 = Q22 * R22 of A22. C A submatrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = L*N*EPS, is used instead, where C EPS is the machine precision (see LAPACK Library routine C DLAMCH). 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) returns the optimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ). C For optimal 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 computes a truncated QR factorization with column C pivoting of E, in the form C C ( E11 E12 ) C E * P = Q * ( ) C ( 0 E22 ) C C and finds the largest RANKE-by-RANKE leading submatrix E11 whose C estimated condition number is less than 1/TOL. RANKE defines thus C the rank of matrix E. Further E22, being negligible, is set to C zero, and an orthogonal matrix Y is determined such that C C ( E11 E12 ) = ( Er 0 ) * Y . C C The overal transformation matrix Z results as Z = P * Y' and the C resulting transformed matrices Q'*A*Z and Q'*E*Z have the form C C ( Er 0 ) ( A11 A12 ) C E <- Q'* E * Z = ( ) , A <- Q' * A * Z = ( ) , C ( 0 0 ) ( A21 A22 ) C C where Er is an upper triangular invertible matrix. C If JOBA = 'R' the same reduction is performed on A22 to obtain it C in the form C C ( Ar 0 ) C A22 = ( ) , C ( 0 0 ) C C with Ar an upper triangular invertible matrix. C If JOBA = 'T' then A22 is row compressed using the QR C factorization with column pivoting to the form C C ( Ar X ) C A22 = ( ) C ( 0 0 ) C C with Ar an upper triangular invertible matrix. C C The transformations are also applied to the rest of system C matrices C C B <- Q' * B, C <- C * Z. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( L*L*N ) floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C March 1999. Based on the RASP routine RPDSSV. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 1999, C May 2003, Jan. 2009, Apr. 2011, Sep. 2016, Nov. 2016, Feb. 2017. C C KEYWORDS C C Descriptor system, matrix algebra, matrix operations, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOBA INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK, $ LDZ, M, N, P, RANKE, RNKA22 DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), $ Z( LDZ, * ) C .. Local Scalars .. LOGICAL ILQ, ILZ, LQUERY, REDA, REDTR, WITHB, WITHC INTEGER I, ICOMPQ, ICOMPZ, IR1, IRE1, J, K, KW, LA22, $ LH, LN, LWR, NA22, WRKOPT DOUBLE PRECISION SVLMAX, TOLDEF C .. Local Arrays .. DOUBLE PRECISION SVAL(3) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DLASET, DORMQR, DORMRZ, DSWAP, DTZRZF, MB03OY, $ XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C C .. Executable Statements .. C C Decode COMPQ. C IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'U' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF C C Decode COMPZ. C IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'U' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF REDA = LSAME( JOBA, 'R' ) REDTR = LSAME( JOBA, 'T' ) WITHB = M.GT.0 WITHC = P.GT.0 LQUERY = ( LDWORK.EQ.-1 ) C C Test the input parameters. C LN = MIN( L, N ) INFO = 0 WRKOPT = MAX( 1, N+P, LN + MAX( 3*N-1, M, L ) ) IF( ICOMPQ.LE.0 ) THEN INFO = -1 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -2 ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA .AND. $ .NOT.REDTR ) THEN INFO = -3 ELSE IF( L.LT.0 ) 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( LDA.LT.MAX( 1, L ) ) THEN INFO = -9 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -11 ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.L ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN INFO = -17 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -19 ELSE IF( TOL.GE.ONE ) THEN INFO = -22 ELSE IF( LQUERY ) THEN CALL DORMQR( 'Left', 'Transpose', L, N, LN, E, LDE, DWORK, $ A, LDA, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(1) ) ) IF( WITHB ) THEN CALL DORMQR( 'Left', 'Transpose', L, M, LN, E, LDE, $ DWORK, B, LDB, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(1) ) ) END IF IF( ILQ ) THEN CALL DORMQR( 'Right', 'No Transpose', L, L, LN, E, LDE, $ DWORK, Q, LDQ, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(1) ) ) END IF CALL DTZRZF( LN, N, E, LDE, DWORK, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(1) ) ) CALL DORMRZ( 'Right', 'Transpose', L, N, LN, N, E, LDE, $ DWORK, A, LDA, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) ) IF( WITHC ) THEN CALL DORMRZ( 'Right', 'Transpose', P, N, LN, N, E, LDE, $ DWORK, C, LDC, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) ) END IF IF( ILZ ) THEN CALL DORMRZ( 'Right', 'Transpose', N, N, LN, N, E, LDE, $ DWORK, Z, LDZ, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) ) END IF ELSE IF( LDWORK.LT.WRKOPT ) THEN INFO = -25 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01FD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Initialize Q and Z if necessary. C IF( ICOMPQ.EQ.3 ) $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) C C Quick return if possible. C IF( L.EQ.0 .OR. N.EQ.0 ) THEN DWORK(1) = ONE RANKE = 0 IF( REDA .OR. REDTR ) RNKA22 = 0 RETURN END IF C TOLDEF = TOL IF( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance for rank determination. C TOLDEF = DBLE( L*N )*DLAMCH( 'EPSILON' ) END IF C SVLMAX = ZERO C C Compute the rank-revealing QR decomposition of E, C C ( E11 E12 ) C E * P = Qr * ( ) , C ( 0 E22 ) C C and determine the rank of E using incremental condition C estimation. C Workspace: MIN(L,N) + 3*N - 1. C LWR = LDWORK - LN KW = LN + 1 C CALL MB03OY( L, N, E, LDE, TOLDEF, SVLMAX, RANKE, SVAL, IWORK, $ DWORK, DWORK(KW), INFO ) C C Apply transformation on the rest of matrices. C IF( RANKE.GT.0 ) THEN C C A <-- Qr' * A. C Workspace: need MIN(L,N) + N; C prefer MIN(L,N) + N*NB. C CALL DORMQR( 'Left', 'Transpose', L, N, RANKE, E, LDE, DWORK, $ A, LDA, DWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) C C B <-- Qr' * B. C Workspace: need MIN(L,N) + M; C prefer MIN(L,N) + M*NB. C IF( WITHB ) THEN CALL DORMQR( 'Left', 'Transpose', L, M, RANKE, E, LDE, $ DWORK, B, LDB, DWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) END IF C C Q <-- Q * Qr. C Workspace: need MIN(L,N) + L; C prefer MIN(L,N) + L*NB. C IF( ILQ ) THEN CALL DORMQR( 'Right', 'No Transpose', L, L, RANKE, E, LDE, $ DWORK, Q, LDQ, DWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) END IF C C Set lower triangle of E to zero. C IF( L.GE.2 ) $ CALL DLASET( 'Lower', L-1, RANKE, ZERO, ZERO, E(2,1), LDE ) C C Compute A*P, C*P and Z*P by forward permuting the columns of C A, C and Z based on information in IWORK. C DO 10 J = 1, N IWORK(J) = -IWORK(J) 10 CONTINUE DO 30 I = 1, N IF( IWORK(I).LT.0 ) THEN J = I IWORK(J) = -IWORK(J) 20 CONTINUE K = IWORK(J) IF( IWORK(K).LT.0 ) THEN CALL DSWAP( L, A(1,J), 1, A(1,K), 1 ) IF( WITHC ) $ CALL DSWAP( P, C(1,J), 1, C(1,K), 1 ) IF( ILZ ) $ CALL DSWAP( N, Z(1,J), 1, Z(1,K), 1 ) IWORK(K) = -IWORK(K) J = K GO TO 20 END IF END IF 30 CONTINUE C C Determine an orthogonal matrix Y such that C C ( E11 E12 ) = ( Er 0 ) * Y . C C Compute E <-- E*Y', A <-- A*Y', C <-- C*Y', Z <-- Z*Y'. C IF( RANKE.LT.N ) THEN C C Workspace: need 2*N; C prefer N + N*NB. C KW = RANKE + 1 CALL DTZRZF( RANKE, N, E, LDE, DWORK, DWORK(KW), $ LDWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Workspace: need N + MAX(L,P,N); C prefer N + MAX(L,P,N)*NB. C LH = N - RANKE CALL DORMRZ( 'Right', 'Transpose', L, N, RANKE, LH, E, LDE, $ DWORK, A, LDA, DWORK(KW), LDWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) IF( WITHC ) THEN CALL DORMRZ( 'Right', 'Transpose', P, N, RANKE, LH, E, $ LDE, DWORK, C, LDC, DWORK(KW), LDWORK-KW+1, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) END IF IF( ILZ ) THEN CALL DORMRZ( 'Right', 'Transpose', N, N, RANKE, LH, E, $ LDE, DWORK, Z, LDZ, DWORK(KW), LDWORK-KW+1, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) END IF C C Set E12 and E22 to zero. C CALL DLASET( 'Full', L, LH, ZERO, ZERO, E(1,KW), LDE ) END IF ELSE CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) END IF C C Reduce A22 if necessary. C IF( REDA .OR. REDTR ) THEN LA22 = L - RANKE NA22 = N - RANKE IF( MIN( LA22, NA22 ).EQ.0 ) THEN RNKA22 = 0 ELSE C C Compute the rank-revealing QR decomposition of A22, C C ( R11 R12 ) C A22 * P2 = Q2 * ( ) , C ( 0 R22 ) C C and determine the rank of A22 using incremental C condition estimation. C Workspace: MIN(L,N) + 3*N - 1. C C Set the estimate of maximum singular value of A to detect C a negligible A matrix. C SVLMAX = DLANGE( 'Frobenius', L, N, A, LDA, DWORK ) IR1 = RANKE + 1 KW = MIN( LA22, NA22 ) + 1 CALL MB03OY( LA22, NA22, A(IR1,IR1), LDA, TOLDEF, $ SVLMAX, RNKA22, SVAL, IWORK, DWORK, $ DWORK(KW), INFO ) C C Apply transformation on the rest of matrices. C IF( RNKA22.GT.0 ) THEN C C A <-- diag(I, Q2') * A C Workspace: need MIN(L,N) + N; C prefer MIN(L,N) + N*NB. C CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, RNKA22, $ A(IR1,IR1), LDA, DWORK, A(IR1,1), LDA, $ DWORK(KW), LWR, INFO ) C C B <-- diag(I, Q2') * B C Workspace: need MIN(L,N) + M; C prefer MIN(L,N) + M*NB. C IF ( WITHB ) $ CALL DORMQR( 'Left', 'Transpose', LA22, M, RNKA22, $ A(IR1,IR1), LDA, DWORK, B(IR1,1), LDB, $ DWORK(KW), LWR, INFO ) C C Q <-- Q * diag(I, Q2) C Workspace: need MIN(L,N) + L; C prefer MIN(L,N) + L*NB. C IF( ILQ ) $ CALL DORMQR( 'Right', 'No transpose', L, LA22, RNKA22, $ A(IR1,IR1), LDA, DWORK, Q(1,IR1), LDQ, $ DWORK(KW), LWR, INFO ) C C Set lower triangle of A22 to zero. C IF( LA22.GE.2 ) $ CALL DLASET( 'Lower', LA22-1, RNKA22, ZERO, ZERO, $ A(IR1+1,IR1), LDA ) C C Compute A*diag(I,P2), C*diag(I,P2) and Z*diag(I,P2) C by forward permuting the columns of A, C and Z based C on information in IWORK. C DO 40 J = 1, NA22 IWORK(J) = -IWORK(J) 40 CONTINUE DO 60 I = 1, NA22 IF( IWORK(I).LT.0 ) THEN J = I IWORK(J) = -IWORK(J) 50 CONTINUE K = IWORK(J) IF( IWORK(K).LT.0 ) THEN CALL DSWAP( RANKE, A(1,RANKE+J), 1, $ A(1,RANKE+K), 1 ) IF( WITHC ) $ CALL DSWAP( P, C(1,RANKE+J), 1, $ C(1,RANKE+K), 1 ) IF( ILZ ) $ CALL DSWAP( N, Z(1,RANKE+J), 1, $ Z(1,RANKE+K), 1 ) IWORK(K) = -IWORK(K) J = K GO TO 50 END IF END IF 60 CONTINUE C IF( REDA .AND. RNKA22.LT.NA22 ) THEN C C Determine an orthogonal matrix Y2 such that C C ( R11 R12 ) = ( Ar 0 ) * Y2 . C C Compute A <-- A*diag(I, Y2'), C <-- C*diag(I, Y2'), C Z <-- Z*diag(I, Y2'). C Workspace: need 2*N. C prefer N + N*NB. C KW = RANKE + 1 CALL DTZRZF( RNKA22, NA22, A(IR1,IR1), LDA, DWORK, $ DWORK(KW), LDWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Workspace: need N + MAX(P,N); C prefer N + MAX(P,N)*NB. C LH = NA22 - RNKA22 CALL DORMRZ( 'Right', 'Transpose', RANKE, NA22, $ RNKA22, LH, A(IR1,IR1), LDA, DWORK, $ A(1,IR1), LDA, DWORK(KW), LDWORK-KW+1, $ INFO ) IF( WITHC ) THEN CALL DORMRZ( 'Right', 'Transpose', P, NA22, RNKA22, $ LH, A(IR1,IR1), LDA, DWORK, C(1,IR1), $ LDC, DWORK(KW), LDWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) END IF IF( ILZ ) THEN CALL DORMRZ( 'Right', 'Transpose', N, NA22, RNKA22, $ LH, A(IR1,IR1), LDA, DWORK, Z(1,IR1), $ LDZ, DWORK(KW), LDWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) END IF IRE1 = RANKE + RNKA22 + 1 C C Set R12 and R22 to zero. C CALL DLASET( 'Full', LA22, LH, ZERO, ZERO, $ A(IR1,IRE1), LDA ) END IF ELSE CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, $ A(IR1,IR1), LDA) END IF END IF END IF C DWORK(1) = WRKOPT C RETURN C *** Last line of TG01FD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB13BD.f0000644000000000000000000000013215012430707016131 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB13BD.f0000644000175000017500000003146215012430707017333 0ustar00lilgelilge00000000000000 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 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 A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C 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 control-4.1.2/src/slicot/src/PaxHeaders/SB08ED.f0000644000000000000000000000013215012430707016162 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB08ED.f0000644000175000017500000003103715012430707017362 0ustar00lilgelilge00000000000000 SUBROUTINE SB08ED( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC, $ D, LDD, NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK, $ LDWORK, IWARN, INFO ) C C PURPOSE C C To construct, for a given system G = (A,B,C,D), an output C injection matrix H and an orthogonal transformation matrix Z, such C that the systems C C Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), C*Z, D) C and C R = (Z'*(A+H*C)*Z, Z'*H, C*Z, I) C C provide a stable left coprime factorization of G in the form C -1 C G = R * Q, C C where G, Q and R are the corresponding transfer-function matrices. C The resulting state dynamics matrix of the systems Q and R has C eigenvalues lying inside a given stability domain. C The Z matrix is not explicitly computed. C C Note: If the given state-space representation is not detectable, C the undetectable part of the original system is automatically C deflated and the order of the systems Q and R is accordingly C reduced. 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 matrices B C and BR, and the number of columns of the matrix C. C N >= 0. C C M (input) INTEGER C The dimension of input vector, i.e. the number of columns C of the matrices B and D. M >= 0. C C P (input) INTEGER C The dimension of output vector, i.e. the number of rows C of the matrices C, D and DR, and the number of columns of C the matrices BR and DR. P >= 0. C C ALPHA (input) DOUBLE PRECISION array, dimension (2) C ALPHA(1) contains the desired stability degree to be C assigned for the eigenvalues of A+H*C, and ALPHA(2) C the stability margin. The eigenvalues outside the C ALPHA(2)-stability region will be assigned to have the C real parts equal to ALPHA(1) < 0 and unmodified C imaginary parts for a continuous-time system C (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1 C for a discrete-time system (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 NQ-by-NQ part of this array contains C the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the C state dynamics matrix of the numerator factor Q, in a C real Schur form. The leading NR-by-NR part of this matrix C represents the state dynamics matrix of a minimal C realization of the denominator factor R. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,MAX(M,P)) 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 leading NQ-by-M part of the matrix Z'*(B+H*D), the C input/state matrix of the numerator factor Q. C The remaining part of this array is needed as workspace. 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 leading P-by-NQ part of the matrix C*Z, the C state/output matrix of the numerator factor Q. C The first NR columns of this array represent the C state/output matrix of a minimal realization of the C denominator factor R. C The remaining part of this array is needed as workspace. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,M,P), if N > 0. C LDC >= 1, if N = 0. C C D (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) C The leading P-by-M part of this array must contain the C input/output matrix. D represents also the input/output C matrix of the numerator factor Q. C This array is modified internally, but restored on exit. C The remaining part of this array is needed as workspace. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,M,P). C C NQ (output) INTEGER C The order of the resulting factors Q and R. C Generally, NQ = N - NS, where NS is the number of C unobservable eigenvalues outside the stability region. C C NR (output) INTEGER C The order of the minimal realization of the factor R. C Generally, NR is the number of observable eigenvalues C of A outside the stability region (the number of modified C eigenvalues). C C BR (output) DOUBLE PRECISION array, dimension (LDBR,P) C The leading NQ-by-P part of this array contains the C leading NQ-by-P part of the output injection matrix C Z'*H, which moves the eigenvalues of A lying outside C the ALPHA-stable region to values on the ALPHA-stability C boundary. The first NR rows of this matrix form the C input/state matrix of a minimal realization of the C denominator factor R. C C LDBR INTEGER C The leading dimension of array BR. LDBR >= MAX(1,N). C C DR (output) DOUBLE PRECISION array, dimension (LDDR,P) C The leading P-by-P part of this array contains an C identity matrix representing the input/output matrix C of the denominator factor R. C C LDDR INTEGER C The leading dimension of array DR. LDDR >= MAX(1,P). C C Tolerances C C TOL DOUBLE PRECISION C The absolute tolerance level below which the elements of C C are considered zero (used for observability tests). C If the user sets TOL <= 0, then an implicitly computed, C default tolerance, defined by TOLDEF = N*EPS*NORM(C), C is used instead, where EPS is the machine precision C (see LAPACK Library routine DLAMCH) and NORM(C) denotes C the infinity-norm of C. 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, N*P + MAX( N*(N+5), 5*P, 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(H) <= 10*NORM(A)/NORM(C) 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 + H*C)*Z C along the diagonal. C C METHOD C C The subroutine uses the right coprime factorization algorithm C of [1] applied to G'. C C REFERENCES C C [1] Varga A. C Coprime factors model reduction method based on C square-root balancing-free techniques. C System Analysis, Modelling and Simulation, C vol. 11, pp. 303-311, 1993. C C NUMERICAL ASPECTS C 3 C The algorithm requires no more than 14N floating point C operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, July 1998. C Based on the RASP routine LCFS. 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, DLR Oberpfaffenhofen. C Nov 2003, A. Varga, DLR Oberpfaffenhofen. C Sep. 2005, A. Varga, German Aerospace Center. C C KEYWORDS C C Coprime factorization, eigenvalue, eigenvalue assignment, C feedback control, pole placement, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO INTEGER INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR, $ LDWORK, M, N, NQ, NR, P DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), ALPHA(*), B(LDB,*), BR(LDBR,*), $ C(LDC,*), D(LDD,*), DR(LDDR,*), DWORK(*) C .. Local Scalars .. LOGICAL DISCR INTEGER KBR, KW C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External subroutines .. EXTERNAL AB07MD, DLASET, MA02AD, MA02BD, SB08FD, TB01XD, $ XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN 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( P.LT.0 ) THEN INFO = -4 ELSE IF( ( DISCR .AND. ( ALPHA(1).LT.ZERO .OR. ALPHA(1).GE.ONE $ .OR. ALPHA(2).LT.ZERO .OR. ALPHA(2).GE.ONE ) ) $ .OR. $ ( .NOT.DISCR .AND. ( ALPHA(1).GE.ZERO .OR. ALPHA(2).GE.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( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) ) $ THEN INFO = -11 ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN INFO = -13 ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN INFO = -19 ELSE IF( LDWORK.LT.MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ) ) THEN INFO = -22 END IF IF( INFO.NE.0 )THEN C C Error return. C CALL XERBLA( 'SB08ED', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, P ).EQ.0 ) THEN NQ = 0 NR = 0 DWORK(1) = ONE CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR ) RETURN END IF C C Compute the dual system G' = (A',C',B',D'). C CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ INFO ) C C Compute the right coprime factorization of G' with C prescribed stability degree. C C Workspace needed: P*N; C Additional workspace: need MAX( N*(N+5), 5*P, 4*M ); C prefer larger. C KBR = 1 KW = KBR + P*N CALL SB08FD( DICO, N, P, M, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, $ NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW), $ LDWORK-KW+1, IWARN, INFO ) IF( INFO.EQ.0 ) THEN C C Determine the elements of the left coprime factorization from C those of the computed right coprime factorization and make the C state-matrix upper real Schur. C CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ), $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) C CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR ) CALL MA02BD( 'Left', NQ, P, BR, LDBR ) C END IF C DWORK(1) = DWORK(KW) + DBLE( KW-1 ) C RETURN C *** Last line of SB08ED *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03OD.f0000644000000000000000000000013215012430707016161 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03OD.f0000644000175000017500000002611315012430707017360 0ustar00lilgelilge00000000000000 SUBROUTINE MB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, $ RANK, SVAL, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute (optionally) a rank-revealing QR factorization of a C real general M-by-N matrix A, which may be rank-deficient, C and estimate its effective rank using incremental condition C estimation. C C The routine uses a QR factorization with column pivoting: C A * P = Q * R, where R = [ R11 R12 ], C [ 0 R22 ] C with R11 defined as the largest leading submatrix whose estimated C condition number is less than 1/RCOND. The order of R11, RANK, C is the effective rank of A. C C MB03OD does not perform any scaling of the matrix A. C C ARGUMENTS C C Mode Parameters C C JOBQR CHARACTER*1 C = 'Q': Perform a QR factorization with column pivoting; C = 'N': Do not perform the QR factorization (but assume C that it has been done outside). 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 with JOBQR = 'Q', the leading M by N part of this C array must contain the given matrix A. C On exit with JOBQR = 'Q', the leading min(M,N) by N upper C triangular part of A contains the triangular factor R, C and the elements below the diagonal, with the array TAU, C represent the orthogonal matrix Q as a product of C min(M,N) elementary reflectors. C On entry and on exit with JOBQR = 'N', the leading C min(M,N) by N upper triangular part of A contains the C triangular factor R, as determined by the QR factorization C with pivoting. The elements below the diagonal of A are C not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C JPVT (input/output) INTEGER array, dimension ( N ) C On entry with JOBQR = 'Q', if JPVT(i) <> 0, the i-th C column of A is an initial column, otherwise it is a free C column. Before the QR factorization of A, all initial C columns are permuted to the leading positions; only the C remaining free columns are moved as a result of column C pivoting during the factorization. For rank determination C it is preferable that all columns be free. C On exit with JOBQR = 'Q', if JPVT(i) = k, then the i-th C column of A*P was the k-th column of A. C Array JPVT is not referenced when JOBQR = 'N'. 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 RCOND >= 0. 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 TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) C On exit with JOBQR = 'Q', the leading min(M,N) elements of C TAU contain the scalar factors of the elementary C reflectors. C Array TAU is not referenced when JOBQR = 'N'. 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 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 length of the array DWORK. C LDWORK >= 3*N + 1, if JOBQR = 'Q'; C LDWORK >= max( 1, 2*min( M, N ) ), if JOBQR = 'N'. C For good performance when JOBQR = 'Q', LDWORK should be C larger. Specifically, LDWORK >= 2*N + ( N + 1 )*NB, where C NB is the optimal block size for the LAPACK Library C routine DGEQP3. 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 computes or uses a QR factorization with column C pivoting of A, A * P = Q * R, with R defined above, and then C finds the largest leading submatrix whose estimated condition C number is less than 1/RCOND, taking the possible positive value of C SVLMAX into account. This is performed using the LAPACK C incremental condition estimation scheme and a slightly modified C rank decision test. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005, C Aug. 2011. C C ****************************************************************** C C .. Parameters .. INTEGER IMAX, IMIN PARAMETER ( IMAX = 1, IMIN = 2 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBQR INTEGER INFO, LDA, LDWORK, M, N, RANK DOUBLE PRECISION RCOND, SVLMAX C .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * ) C .. Local Scalars .. LOGICAL LJOBQR, LQUERY INTEGER I, ISMAX, ISMIN, MAXWRK, MINWRK, MN DOUBLE PRECISION C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEQP3, DLAIC1, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN C .. C .. Executable Statements .. C LJOBQR = LSAME( JOBQR, 'Q' ) MN = MIN( M, N ) IF( LJOBQR ) THEN MINWRK = 3*N + 1 ELSE MINWRK = MAX( 1, 2*MN ) END IF MAXWRK = MINWRK C C Test the input scalar arguments. C INFO = 0 IF( .NOT.LJOBQR .AND. .NOT.LSAME( JOBQR, 'N' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( RCOND.LT.ZERO ) THEN INFO = -7 ELSE IF( SVLMAX.LT.ZERO ) THEN INFO = -8 ELSE LQUERY = LDWORK.EQ.-1 IF ( LJOBQR ) THEN CALL DGEQP3( M, N, A, LDA, JPVT, TAU, DWORK, -1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) END IF IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -13 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03OD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK( 1 ) = MAXWRK RETURN END IF C C Quick return if possible C IF( MN.EQ.0 ) THEN RANK = 0 SVAL( 1 ) = ZERO SVAL( 2 ) = ZERO SVAL( 3 ) = ZERO DWORK( 1 ) = ONE RETURN END IF C IF ( LJOBQR ) THEN C C Compute QR factorization with column pivoting of A: C A * P = Q * R C Workspace need 3*N + 1; C prefer 2*N + (N+1)*NB. C Details of Householder rotations stored in TAU. C CALL DGEQP3( M, N, A, LDA, JPVT, TAU, DWORK, LDWORK, INFO ) END IF C C Determine RANK using incremental condition estimation C ISMIN = 1 ISMAX = MN + 1 DWORK( ISMIN ) = ONE DWORK( ISMAX ) = ONE SMAX = ABS( A( 1, 1 ) ) SMIN = SMAX IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN RANK = 0 SVAL( 1 ) = SMAX SVAL( 2 ) = ZERO SVAL( 3 ) = ZERO ELSE RANK = 1 SMINPR = SMIN C 10 CONTINUE IF( RANK.LT.MN ) THEN I = RANK + 1 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 ) C IF( SVLMAX*RCOND.LE.SMAXPR ) THEN IF( SVLMAX*RCOND.LE.SMINPR ) THEN IF( SMAXPR*RCOND.LE.SMINPR ) THEN DO 20 I = 1, RANK DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) 20 CONTINUE DWORK( ISMIN+RANK ) = C1 DWORK( ISMAX+RANK ) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 GO TO 10 END IF END IF END IF END IF SVAL( 1 ) = SMAX SVAL( 2 ) = SMIN SVAL( 3 ) = SMINPR END IF C DWORK( 1 ) = MAXWRK RETURN C *** Last line of MB03OD *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01OY.f0000644000000000000000000000013215012430707016200 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/IB01OY.f0000644000175000017500000001075715012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE IB01OY( NS, NMAX, N, SV, INFO ) C C PURPOSE C C To ask for user's confirmation of the system order found by C SLICOT Library routine IB01OD. This routine may be modified, C but its interface must be preserved. C C ARGUMENTS C C Input/Output Parameters C C NS (input) INTEGER C The number of singular values. NS > 0. C C NMAX (input) INTEGER C The maximum value of the system order. 0 <= NMAX <= NS. C C N (input/output) INTEGER C On entry, the estimate of the system order computed by C IB01OD routine. 0 <= N <= NS. C On exit, the user's estimate of the system order, which C could be identical with the input value of N. C Note that the output value of N should be less than C or equal to NMAX. C C SV (input) DOUBLE PRECISION array, dimension ( NS ) C The singular values, in descending order, used for C determining the system order. 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 CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. C C REVISIONS C C - C C KEYWORDS C C Identification, parameter estimation, singular values, structure C identification. C C ********************************************************************* C C .. Parameters .. INTEGER INTRMN, OUTRMN PARAMETER ( INTRMN = 5, OUTRMN = 6 ) C INTRMN is the unit number for the (terminal) input device. C OUTRMN is the unit number for the (terminal) output device. C .. C .. Scalar Arguments .. INTEGER INFO, N, NMAX, NS C .. C .. Array Arguments .. DOUBLE PRECISION SV( * ) C .. C .. Local Scalars .. LOGICAL YES INTEGER I CHARACTER ANS C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL XERBLA C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 IF( NS.LE.0 ) THEN INFO = -1 ELSE IF( NMAX.LT.0 .OR. NMAX.GT.NS ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. N.GT.NS ) THEN INFO = -3 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB01OY', -INFO ) RETURN END IF C WRITE( OUTRMN, '(/'' Singular values (in descending order) used'', $ '' to estimate the system order:'', // $ (5D15.8) )' ) ( SV(I), I = 1, NS ) WRITE( OUTRMN, '(/'' Estimated order of the system, n = '', I5 )' $ ) N WRITE( OUTRMN, '(/'' Do you want this value of n to be used'', $ '' to determine the system matrices?'' )' ) C 10 CONTINUE WRITE( OUTRMN, '(/'' Type "yes" or "no": '' )' ) READ ( INTRMN, '( A )' ) ANS YES = LSAME( ANS, 'Y' ) IF( YES ) THEN IF( N.LE.NMAX ) THEN C C The value of n is adequate and has been confirmed. C RETURN ELSE C C The estimated value of n is not acceptable. C WRITE( OUTRMN, '(/'' n should be less than or equal'', $ '' to '', I5 )' ) NMAX WRITE( OUTRMN, '( '' (It may be useful to restart'', $ '' with a larger tolerance.)'' )' ) GO TO 20 END IF C ELSE IF( LSAME( ANS, 'N' ) ) THEN GO TO 20 ELSE C C Wrong answer should be re-entered. C GO TO 10 END IF C C Enter the desired value of n. C 20 CONTINUE WRITE( OUTRMN,'(/'' Enter the desired value of n (n <= '', I5, $ ''); n = '' )' ) NMAX READ ( INTRMN, * ) N IF ( N.LT.0 ) THEN C C The specified value of n is not acceptable. C WRITE( OUTRMN, '(/'' n should be larger than zero.'' )' ) GO TO 20 ELSE IF ( N.GT.NMAX ) THEN C C The specified value of n is not acceptable. C WRITE( OUTRMN, '(/'' n should be less than or equal to '', $ I5 )' ) NMAX GO TO 20 END IF C RETURN C C *** Last line of IB01OY *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09BX.f0000644000000000000000000000013215012430707016162 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB09BX.f0000644000175000017500000005444215012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE AB09BX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, $ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1, $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable C original state-space representation (A,B,C,D) by using either the C square-root or the balancing-free square-root C Singular Perturbation Approximation (SPA) model reduction method. C The state dynamics matrix A of the original system is an upper C quasi-triangular matrix in real Schur canonical form. The matrices C of a minimal realization are computed using the truncation C formulas: C C Am = TI * A * T , Bm = TI * B , Cm = C * T . (1) C C Am, Bm, Cm and D serve further for computing the SPA of the given C system. 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 JOB CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root SPA method; C = 'N': use the balancing-free square-root SPA method. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of C the resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. NR is set as follows: C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR C is the desired order on entry and NMIN is the order of a C minimal realization of the given system; NMIN is C determined as the number of Hankel singular values greater C than N*EPS*HNORM(A,B,C), where EPS is the machine C precision (see LAPACK Library Routine DLAMCH) and C HNORM(A,B,C) is the Hankel norm of the system (computed C in HSV(1)); C if ORDSEL = 'A', NR is equal to the number of Hankel C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). 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 in a real Schur C canonical form. C On exit, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the C reduced order system. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, it contains the Hankel singular values of C the original system ordered decreasingly. HSV(1) is the C Hankel norm of the system. C C T (output) DOUBLE PRECISION array, dimension (LDT,N) C If INFO = 0 and NR > 0, the leading N-by-NR part of this C array contains the right truncation matrix T in (1). C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,N). C C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) C If INFO = 0 and NR > 0, the leading NR-by-N part of this C array contains the left truncation matrix TI in (1). C C LDTI INTEGER C The leading dimension of array TI. LDTI >= MAX(1,N). C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL1 = c*HNORM(A,B,C), where c is a constant in the C interval [0.00001,0.001], and HNORM(A,B,C) is the C Hankel-norm of the given system (computed in HSV(1)). C For computing a minimal realization, the recommended C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the C machine precision (see LAPACK Library Routine DLAMCH). C This value is used by default if TOL1 <= 0 on entry. C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the given system. The recommended value is C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default C if TOL2 <= 0 on entry. C If TOL2 > 0, then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension (MAX(1,2*N)) C On exit with INFO = 0, IWORK(1) contains the order of the C minimal realization of the system. 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,N*(MAX(N,M,P)+5) + N*(N+1)/2). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than the order of a minimal realization of the C given system. In this case, the resulting NR is C set automatically to a value corresponding to the C order of a minimal realization of the system. 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 state matrix A is not stable (if DICO = 'C') C or not convergent (if DICO = 'D'); C = 2: the computation of Hankel singular values failed. C C METHOD C C Let be the stable linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t) (2) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09BX determines for C the given system (1), the matrices of a reduced NR order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t) (3) C C such that C C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], C C where G and Gr are transfer-function matrices of the systems C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the C infinity-norm of G. C C If JOB = 'B', the balancing-based square-root SPA method of [1] C is used and the resulting model is balanced. C C If JOB = 'N', the balancing-free square-root SPA method of [2] C is used. C By setting TOL1 = TOL2, the routine can be also used to compute C Balance & Truncate approximations. C C REFERENCES C C [1] Liu Y. and Anderson B.D.O. C Singular Perturbation Approximation of Balanced Systems, C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. C C [2] Varga A. C Balancing-free square-root algorithm for computing singular C perturbation approximations. C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, C Vol. 2, pp. 1062-1065. C C NUMERICAL ASPECTS C C The implemented methods rely on accuracy enhancing square-root or C balancing-free square-root techniques. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, March 1998. C Based on the RASP routine SRBFP1. C C REVISIONS C C May 2, 1998. C November 11, 1998, V. Sima, Research Institute for Informatics, C Bucharest. C December 1998, V. Sima, Katholieke Univ. Leuven, Leuven. C February 14, 1999, A. Varga, German Aerospace Center. C February 22, 1999, V. Sima, Research Institute for Informatics. C February 27, 2000, V. Sima, Research Institute for Informatics. C May 26, 2000, A. Varga, German Aerospace Center. C C KEYWORDS C C Balancing, minimal state-space representation, model reduction, C multivariable system, singular perturbation approximation, C state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOB, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, $ LDWORK, M, N, NR, P DOUBLE PRECISION TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) C .. Local Scalars .. LOGICAL BAL, DISCR, FIXORD, PACKED INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, NMINR, $ NR1, NS, WRKOPT DOUBLE PRECISION ATOL, RCOND, RTOL, SCALEC, SCALEO, TEMP C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB09DD, DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, $ DLACPY, DORGQR, DSCAL, DTPMV, DTRMM, DTRMV, $ MA02AD, MA02DD, MB03UD, SB03OU, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) BAL = LSAME( JOB, 'B' ) FIXORD = LSAME( ORDSEL, 'F' ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( BAL .OR. LSAME( JOB, 'N') ) ) THEN INFO = -2 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN INFO = -20 ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN INFO = -22 ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + $ ( N*( N + 1 ) )/2 ) ) THEN INFO = -25 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09BX', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 IWORK(1) = 0 DWORK(1) = ONE RETURN END IF C RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) C C Allocate N*MAX(N,M,P) and N working storage for the matrices U C and TAU, respectively. C KU = 1 KTAU = KU + N*MAX( N, M, P ) KW = KTAU + N LDW = LDWORK - KW + 1 C C Copy B in U. C CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) C C If DISCR = .FALSE., solve for Su the Lyapunov equation C 2 C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . C C If DISCR = .TRUE., solve for Su the Lyapunov equation C 2 C A*(Su*Su')*A' + scalec *B*B' = Su*Su' . C C Workspace: need N*(MAX(N,M,P) + 5); C prefer larger. C CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, $ DWORK(KTAU), TI, LDTI, SCALEC, DWORK(KW), LDW, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN ENDIF WRKOPT = INT( DWORK(KW) ) + KW - 1 C C Copy C in U. C CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) C C If DISCR = .FALSE., solve for Ru the Lyapunov equation C 2 C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * C'*C = 0 . C C If DISCR = .TRUE., solve for Ru the Lyapunov equation C 2 C A'*(Ru'*Ru)*A + scaleo * C'*C = Ru'*Ru . C C Workspace: need N*(MAX(N,M,P) + 5); C prefer larger. C CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, $ DWORK(KTAU), T, LDT, SCALEO, DWORK(KW), LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Allocate N*(N+1)/2 (or, if possible, N*N) working storage for the C matrix V, a packed (or unpacked) copy of Su, and save Su in V. C (The locations for TAU are reused here.) C KV = KTAU IF ( LDWORK-KV+1.LT.N*( N + 5 ) ) THEN PACKED = .TRUE. CALL MA02DD( 'Pack', 'Upper', N, TI, LDTI, DWORK(KV) ) KW = KV + ( N*( N + 1 ) )/2 ELSE PACKED = .FALSE. CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) KW = KV + N*N END IF C | x x | C Compute Ru*Su in the form | 0 x | in TI. C DO 10 J = 1, N CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, $ TI(1,J), 1 ) 10 CONTINUE C C Compute the singular value decomposition Ru*Su = V*S*UT C of the upper triangular matrix Ru*Su, with UT in TI and V in U. C C Workspace: need N*MAX(N,M,P) + N*(N+1)/2 + 5*N; C prefer larger. C CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 2 RETURN ENDIF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Scale singular values. C CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) C C Partition S, U and V conformally as: C C S = diag(S1,S2,S3), U = [U1,U2,U3] (U' in TI) and V = [V1,V2,V3] C (in U). C C Compute the order NR of reduced system, as the order of S1. C ATOL = RTOL*HSV(1) IF( FIXORD ) THEN IF( NR.GT.0 ) THEN IF( HSV(NR).LE.ATOL ) THEN NR = 0 IWARN = 1 FIXORD = .FALSE. ENDIF ENDIF ELSE ATOL = MAX( TOL1, ATOL ) NR = 0 ENDIF IF( .NOT.FIXORD ) THEN DO 20 J = 1, N IF( HSV(J).LE.ATOL ) GO TO 30 NR = NR + 1 20 CONTINUE 30 CONTINUE ENDIF C C Finish if the order of the reduced model is zero. C IF( NR.EQ.0 ) THEN C C Compute only Dr using singular perturbation formulas. C Workspace: need real 4*N; C need integer 2*N. C CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, D, $ LDD, RCOND, IWORK, DWORK, IERR ) IWORK(1) = 0 DWORK(1) = WRKOPT RETURN END IF C C Compute the order of minimal realization as the order of [S1 S2]. C NR1 = NR + 1 NMINR = NR IF( NR.LT.N ) THEN ATOL = MAX( TOL2, RTOL*HSV(1) ) DO 40 J = NR1, N IF( HSV(J).LE.ATOL ) GO TO 50 NMINR = NMINR + 1 40 CONTINUE 50 CONTINUE END IF C C Compute the order of S2. C NS = NMINR - NR C C Compute the truncation matrices. C C Compute TI' = | TI1' TI2' | = Ru'*| V1 V2 | in U. C CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NMINR, $ ONE, T, LDT, DWORK(KU), N ) C C Compute T = | T1 T2 | = Su*| U1 U2 | C (with Su packed, if not enough workspace). C CALL MA02AD( 'Full', NMINR, N, TI, LDTI, T, LDT ) IF ( PACKED ) THEN DO 60 J = 1, NMINR CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(KV), $ T(1,J), 1 ) 60 CONTINUE ELSE CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, $ NMINR, ONE, DWORK(KV), N, T, LDT ) END IF C IF( BAL ) THEN IJ = KU C C Square-Root SPA method. C C Compute the truncation matrices for balancing C -1/2 -1/2 C T1*S1 and TI1'*S1 C DO 70 J = 1, NR TEMP = ONE/SQRT( HSV(J) ) CALL DSCAL( N, TEMP, T(1,J), 1 ) CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) IJ = IJ + N 70 CONTINUE ELSE C C Balancing-Free SPA method. C C Compute orthogonal bases for the images of matrices T1 and C TI1'. C C Workspace: need N*MAX(N,M,P) + 2*NR; C prefer N*MAX(N,M,P) + NR*(NB+1) C (NB determined by ILAENV for DGEQRF). C KW = KTAU + NR LDW = LDWORK - KW + 1 CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, $ IERR ) CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), $ LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) ENDIF IF( NS.GT.0 ) THEN C C Compute orthogonal bases for the images of matrices T2 and C TI2'. C C Workspace: need N*MAX(N,M,P) + 2*NS; C prefer N*MAX(N,M,P) + NS*(NB+1) C (NB determined by ILAENV for DGEQRF). KW = KTAU + NS LDW = LDWORK - KW + 1 CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, $ IERR ) CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), $ LDW, IERR ) CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), $ LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), $ DWORK(KW), LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) ENDIF C C Transpose TI' in TI. C CALL MA02AD( 'Full', N, NMINR, DWORK(KU), N, TI, LDTI ) C IF( .NOT.BAL ) THEN C -1 C Compute (TI1*T1) *TI1 in TI. C CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, $ LDTI, T, LDT, ZERO, DWORK(KU), N ) CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, $ LDTI, IERR ) C IF( NS.GT.0 ) THEN C -1 C Compute (TI2*T2) *TI2 in TI2. C CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), $ N ) CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, $ TI(NR1,1), LDTI, IERR ) END IF END IF C C Compute TI*A*T (A is in RSF). C IJ = KU DO 80 J = 1, N K = MIN( J+1, N ) CALL DGEMV( 'NoTranspose', NMINR, K, ONE, TI, LDTI, A(1,J), 1, $ ZERO, DWORK(IJ), 1 ) IJ = IJ + N 80 CONTINUE CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, NMINR, N, ONE, $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) C C Compute TI*B and C*T. C CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, M, N, ONE, TI, $ LDTI, DWORK(KU), N, ZERO, B, LDB ) C CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NMINR, N, ONE, $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) C C Compute the singular perturbation approximation if possible. C Note that IERR = 1 on exit from AB09DD cannot appear here. C C Workspace: need real 4*(NMINR-NR); C need integer 2*(NMINR-NR). C CALL AB09DD( DICO, NMINR, M, P, NR, A, LDA, B, LDB, C, LDC, D, $ LDD, RCOND, IWORK, DWORK, IERR ) C IWORK(1) = NMINR DWORK(1) = WRKOPT C RETURN C *** Last line of AB09BX *** END control-4.1.2/src/slicot/src/PaxHeaders/AB13DD.f0000644000000000000000000000013215012430707016133 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB13DD.f0000644000175000017500000017615715012430707017350 0ustar00lilgelilge00000000000000 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 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 ) 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+2*NN ), N2 ) CALL DGEMM( 'Transpose', 'Transpose', N2, N, M, $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2 ), N2PM, $ B, LDB, ONE, DWORK( IPE+2*NN ), N2 ) ELSE IF ( FULLE ) $ CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, $ DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE, $ ZERO, DWORK( IPE+2*NN ), N2 ) END IF C C Compute the eigenvalues of the Hamiltonian pencil. C Additional workspace: need 16*N; C prefer larger. C CALL DGGEV( 'No Vectors', 'No Vectors', N2, DWORK( IPA ), $ N2, DWORK( IPE ), N2, DWORK( IR ), DWORK( II ), $ DWORK( IBT ), DWORK, N2, DWORK, N2, $ 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 ELSE IF ( .NOT.WITHD ) THEN C C Standard continuous-time case with D = 0. C Form the needed part of the Hamiltonian matrix explicitly: C H = H11 - H12*inv(H22)*H21/g. C Additional workspace: need 2*N*N+N. (from IBT) C IH = IBT IH12 = IH + NN ISL = IH12 + NN + N CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N ) C C Compute triangles of -C'*C/GAMMA and B*B'/GAMMA. C CALL DSYRK( 'Lower', 'Transpose', N, P, -ONE/GAMMA, C, LDC, $ ZERO, DWORK( IH12 ), N ) CALL DSYRK( 'Upper', 'No Transpose', N, M, ONE/GAMMA, B, $ LDB, ZERO, DWORK( IH12+N ), N ) C ELSE C C Standard continuous-time case with D <> 0 and the SVD of D C can be used. Compute explicitly the needed part of the C Hamiltonian matrix: C C (A+B1*S'*inv(g^2*Ip-S*S')*C1' g*B1*inv(g^2*Im-S'*S)*B1') C H = ( ) C ( -g*C1*inv(g^2*Ip-S*S')*C1' -H11' ) C C where g = GAMMA, B1 = B*V, C1 = C'*U, and H11 is the first C block of H. C Primary additional workspace: need 2*N*N+N (from IBT) C (for building the relevant part of the Hamiltonian matrix). C C Compute C1*sqrt(inv(g^2*Ip-S*S')) . C Additional workspace: need MAX(M,P)+N*P. C IH = IBT IH12 = IH + NN ISL = IH12 + NN + N C DO 250 I = 0, MINPM - 1 DWORK( ISL+I ) = ONE/SQRT( GAMMA**2 - DWORK( IS+I )**2 ) 250 CONTINUE C IF ( M.LT.P ) THEN DWORK( ISL+M ) = ONE / GAMMA CALL DCOPY( P-M-1, DWORK( ISL+M ), 0, DWORK( ISL+M+1 ), $ 1 ) END IF ISC = ISL + MAX( M, P ) CALL DLACPY( 'Full', N, P, DWORK( ICU ), N, DWORK( ISC ), $ N ) CALL MB01SD( 'Column', N, P, DWORK( ISC ), N, DWORK, $ DWORK( ISL ) ) C C Compute B1*S' . C Additional workspace: need N*M. C ISB = ISC + P*N CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ), $ N ) CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK, $ DWORK( IS ) ) C C Compute B1*S'*sqrt(inv(g^2*Ip-S*S')) . C CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK, $ DWORK( ISL ) ) C C Compute H11 . C CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N ) CALL DGEMM( 'No Transpose', 'Transpose', N, N, MINPM, ONE, $ DWORK( ISB ), N, DWORK( ISC ), N, ONE, $ DWORK( IH ), N ) C C Compute B1*sqrt(inv(g^2*Im-S'*S)) . C IF ( P.LT.M ) THEN DWORK( ISL+P ) = ONE / GAMMA CALL DCOPY( M-P-1, DWORK( ISL+P ), 0, DWORK( ISL+P+1 ), $ 1 ) END IF CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ), $ N ) CALL MB01SD( 'Column', N, M, DWORK( ISB ), N, DWORK, $ DWORK( ISL ) ) C C Compute the lower triangle of H21 and the upper triangle C of H12. C CALL DSYRK( 'Lower', 'No Transpose', N, P, -GAMMA, $ DWORK( ISC ), N, ZERO, DWORK( IH12 ), N ) CALL DSYRK( 'Upper', 'No Transpose', N, M, GAMMA, $ DWORK( ISB ), N, ZERO, DWORK( IH12+N ), N ) END IF C IF ( .NOT.USEPEN ) THEN C C Compute the eigenvalues of the Hamiltonian matrix by the C symplectic URV and the periodic Schur decompositions. C Additional workspace: need (2*N+8)*N; C prefer larger. C IWRK = ISL + NN CALL MB03XD( 'Both', 'Eigenvalues', 'No vectors', $ 'No vectors', N, DWORK( IH ), N, DWORK( IH12 ), $ N, DWORK( ISL ), N, TEMP, 1, TEMP, 1, TEMP, 1, $ TEMP, 1, DWORK( IR ), DWORK( II ), ILO, $ DWORK( IWRK ), DWORK( IWRK+N ), $ LDWORK-IWRK-N+1, IERR ) IF( IERR.GT.0 ) THEN INFO = 2 RETURN END IF MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK + N - 1, MAXWRK ) END IF C C Detect eigenvalues on the boundary of the stability domain, C if any. The test is based on a round-off level of eps*rho(H) C (after balancing) resulting in worst-case perturbations of C order sqrt(eps*rho(H)), for continuous-time systems, on the C real part of poles of multiplicity two (typical as GAMMA C approaches the infinity norm). Similarly, in the discrete-time C case. Above, rho(H) is the maximum modulus of eigenvalues C (continuous-time case). C C Compute maximum eigenvalue modulus and check the absolute real C parts (if DICO = 'C'), or moduli (if DICO = 'D'). C WMAX = ZERO C IF ( USEPEN ) THEN C C Additional workspace: need 2*N, if DICO = 'D'; (from IM) C 0, if DICO = 'C'. C DO 260 I = 0, N2 - 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 WMAX = MAX( WMAX, TM ) IF ( DISCR ) $ DWORK( IM+I ) = TM 260 CONTINUE C ELSE C DO 270 I = 0, N - 1 TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) WMAX = MAX( WMAX, TM ) 270 CONTINUE C END IF C NEI = 0 C IF ( USEPEN ) THEN C DO 280 I = 0, N2 - 1 IF ( DISCR ) THEN TM = ABS( ONE - DWORK( IM+I ) ) ELSE TM = ABS( DWORK( IR+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. C SAFMAX is used. C TM = SAFMAX END IF END IF IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN DWORK( IR+NEI ) = DWORK( IR+I ) / DWORK( IBT+I ) DWORK( II+NEI ) = DWORK( II+I ) / DWORK( IBT+I ) NEI = NEI + 1 END IF 280 CONTINUE C ELSE C DO 290 I = 0, N - 1 TM = ABS( DWORK( IR+I ) ) IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN DWORK( IR+NEI ) = DWORK( IR+I ) DWORK( II+NEI ) = DWORK( II+I ) NEI = NEI + 1 END IF 290 CONTINUE C END IF C IF( NEI.EQ.0 ) THEN C C There is no eigenvalue on the boundary of the stability C domain for G = ( ONE + TOL )*GAMMAL. The norm was found. C GPEAK( 1 ) = GAMMAL GPEAK( 2 ) = ONE GO TO 340 END IF C C Compute the frequencies where the gain G is attained and C generate new test frequencies. C NWS = 0 C IF ( DISCR ) THEN C DO 300 I = 0, NEI - 1 TM = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) DWORK( IR+I ) = MAX( EPS, TM ) NWS = NWS + 1 300 CONTINUE C ELSE C J = 0 C DO 310 I = 0, NEI - 1 IF ( DWORK( II+I ).GT.EPS ) THEN DWORK( IR+NWS ) = DWORK( II+I ) NWS = NWS + 1 ELSE IF ( DWORK( II+I ).EQ.EPS ) THEN J = J + 1 IF ( J.EQ.1 ) THEN DWORK( IR+NWS ) = EPS NWS = NWS + 1 END IF END IF 310 CONTINUE C END IF C CALL DLASRT( 'Increasing', NWS, DWORK( IR ), IERR ) LW = 1 C DO 320 I = 0, NWS - 1 IF ( DWORK( IR+LW-1 ).NE.DWORK( IR+I ) ) THEN DWORK( IR+LW ) = DWORK( IR+I ) LW = LW + 1 END IF 320 CONTINUE C IF ( LW.EQ.1 ) THEN IF ( ITER.EQ.1 .AND. NWS.GE.1 ) THEN C C Duplicate the frequency trying to force iteration. C DWORK( IR+1 ) = DWORK( IR ) LW = LW + 1 ELSE C C The norm was found. C GPEAK( 1 ) = GAMMAL GPEAK( 2 ) = ONE GO TO 340 END IF END IF C C Form the vector of mid-points and compute the gain at new test C frequencies. Save the current lower bound. C IWRK = IR + LW GAMMAS = GAMMAL C DO 330 I = 0, LW - 2 IF ( DISCR ) THEN OMEGA = ( DWORK( IR+I ) + DWORK( IR+I+1 ) ) / TWO ELSE OMEGA = SQRT( DWORK( IR+I )*DWORK( IR+I+1 ) ) END IF C C Additional workspace: need LDW2, see above; C prefer larger. 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 330 CONTINUE C C If the lower bound has not been improved, return. (This is a C safeguard against undetected modes of Hamiltonian matrix on the C boundary of the stability domain.) C IF ( GAMMAL.LT.GAMMAS*( ONE + TOL/TEN ) ) THEN GPEAK( 1 ) = GAMMAL GPEAK( 2 ) = ONE GO TO 340 END IF C C END WHILE C IF ( ITER.LE.MAXIT ) THEN GO TO 120 ELSE INFO = 4 RETURN END IF C 340 CONTINUE DWORK( 1 ) = MAXWRK CWORK( 1 ) = MAXCWK RETURN C *** Last line of AB13DD *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02FD.f0000644000000000000000000000013215012430707016146 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MA02FD.f0000644000175000017500000000455215012430707017350 0ustar00lilgelilge00000000000000 SUBROUTINE MA02FD( X1, X2, C, S, INFO ) C C PURPOSE C C To compute the coefficients c and s (c^2 + s^2 = 1) for a modified C hyperbolic plane rotation, such that, C C y1 := 1/c * x1 - s/c * x2 = sqrt(x1^2 - x2^2), C y2 := -s * y1 + c * x2 = 0, C C given two real numbers x1 and x2, satisfying either x1 = x2 = 0, C or abs(x2) < abs(x1). C C ARGUMENTS C C Input/Output Parameters C C X1 (input/output) DOUBLE PRECISION C On entry, the real number x1. C On exit, the real number y1. C C X2 (input) DOUBLE PRECISION C The real number x2. C The values x1 and x2 should satisfy either x1 = x2 = 0, or C abs(x2) < abs(x1). C C C (output) DOUBLE PRECISION C The cosines c of the modified hyperbolic plane rotation. C C S (output) DOUBLE PRECISION C The sines s of the modified hyperbolic plane rotation. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: if abs(x2) >= abs(x1) and either x1 <> 0 or x2 <> 0. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. C C KEYWORDS C C Orthogonal transformation, plane rotation. C C ***************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION X1, X2, C, S INTEGER INFO C .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT C .. Executable Statements .. C IF ( ( X1.NE.ZERO .OR. X2.NE.ZERO ) .AND. $ ABS( X2 ).GE.ABS( X1 ) ) THEN INFO = 1 ELSE INFO = 0 IF ( X1.EQ.ZERO ) THEN S = ZERO C = ONE ELSE S = X2 / X1 C C No overflows could appear in the next statement; underflows C are possible if X2 is tiny and X1 is huge, but then C abs(C) = ONE - delta, C where delta is much less than machine precision. C C = SIGN( SQRT( ONE - S ) * SQRT( ONE + S ), X1 ) X1 = C * X1 END IF END IF C RETURN C *** Last line of MA02FD *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BQ.f0000644000000000000000000000013015012430707016162 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/NF01BQ.f0000644000175000017500000004025215012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BQ( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, $ RANKS, X, TOL, DWORK, LDWORK, INFO ) C C PURPOSE C C To determine a vector x which solves the system of linear C equations C C J*x = b , D*x = 0 , C C in the least squares sense, where J is an m-by-n matrix, C D is an n-by-n diagonal matrix, and b is an m-vector. The matrix J C is the current Jacobian of a nonlinear least squares problem, C provided in a compressed form by SLICOT Library routine NF01BD. C It is assumed that a block QR factorization, with column pivoting, C of J is available, that is, J*P = Q*R, where P is a permutation C matrix, Q has orthogonal columns, and R is an upper triangular C matrix with diagonal elements of nonincreasing magnitude for each C block, as returned by SLICOT Library routine NF01BS. The routine C NF01BQ needs the upper triangle of R in compressed form, the C permutation matrix P, and the first n components of Q'*b C (' denotes the transpose). The system J*x = b, D*x = 0, is then C equivalent to C C R*z = Q'*b , P'*D*P*z = 0 , (1) C C where x = P*z. If this system does not have full rank, then an C approximate least squares solution is obtained (see METHOD). C On output, NF01BQ also provides an upper triangular matrix S C such that C C P'*(J'*J + D*D)*P = S'*S . C C The system (1) is equivalent to S*z = c , where c contains the C first n components of the vector obtained by applying to C [ (Q'*b)' 0 ]' the transformations which triangularized C [ R' P'*D*P ]', getting S. C C The matrix R has the following structure C C / R_1 0 .. 0 | L_1 \ C | 0 R_2 .. 0 | L_2 | C | : : .. : | : | , C | 0 0 .. R_l | L_l | C \ 0 0 .. 0 | R_l+1 / C C where the submatrices R_k, k = 1:l, have the same order BSN, C and R_k, k = 1:l+1, are square and upper triangular. This matrix C is stored in the compressed form C C / R_1 | L_1 \ C | R_2 | L_2 | C Rc = | : | : | , C | R_l | L_l | C \ X | R_l+1 / C C where the submatrix X is irrelevant. The matrix S has the same C structure as R, and its diagonal blocks are denoted by S_k, C k = 1:l+1. C C If l <= 1, then the full upper triangle of the matrix R is stored. C C ARGUMENTS C C Mode Parameters C C COND CHARACTER*1 C Specifies whether the condition of the matrices S_k should C be estimated, as follows: C = 'E' : use incremental condition estimation and store C the numerical rank of S_k in the array entry C RANKS(k), for k = 1:l+1; C = 'N' : do not use condition estimation, but check the C diagonal entries of S_k for zero values; C = 'U' : use the ranks already stored in RANKS(1:l+1). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix R. N = BN*BSN + ST >= 0. C (See parameter description below.) C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of the C matrix R, as follows: C IPAR(1) must contain ST, the number of columns of the C submatrices L_k and the order of R_l+1. ST >= 0. C IPAR(2) must contain BN, the number of blocks, l, in the C block diagonal part of R. BN >= 0. C IPAR(3) must contain BSM, the number of rows of the blocks C R_k, k = 1:l. BSM >= 0. C IPAR(4) must contain BSN, the number of columns of the C blocks R_k, k = 1:l. BSN >= 0. C BSM is not used by this routine, but assumed equal to BSN. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 4. C C R (input/output) DOUBLE PRECISION array, dimension (LDR, NC) C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. C On entry, the leading N-by-NC part of this array must C contain the (compressed) representation (Rc) of the upper C triangular matrix R. If BN > 1, the submatrix X in Rc is C not referenced. The zero strict lower triangles of R_k, C k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then C the full upper triangle of R must be stored. C On exit, the full upper triangles of R_k, k = 1:l+1, and C L_k, k = 1:l, are unaltered, and the strict lower C triangles of R_k, k = 1:l+1, contain the corresponding C strict upper triangles (transposed) of the upper C triangular matrix S. C If BN <= 1 or BSN = 0, then the transpose of the strict C upper triangle of S is stored in the strict lower triangle C of R. C C LDR INTEGER C The leading dimension of the array R. LDR >= MAX(1,N). C C IPVT (input) INTEGER array, dimension (N) C This array must define the permutation matrix P such that C J*P = Q*R. Column j of P is column IPVT(j) of the identity C matrix. C C DIAG (input) DOUBLE PRECISION array, dimension (N) C This array must contain the diagonal elements of the C matrix D. C C QTB (input) DOUBLE PRECISION array, dimension (N) C This array must contain the first n elements of the C vector Q'*b. C C RANKS (input or output) INTEGER array, dimension (r), where C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; C r = BN, if ST = 0 and BSN > 0; C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); C r = 0, if ST = 0 and BSN = 0. C On entry, if COND = 'U' and N > 0, this array must contain C the numerical ranks of the submatrices S_k, k = 1:l(+1). C On exit, if COND = 'E' or 'N' and N > 0, this array C contains the numerical ranks of the submatrices S_k, C k = 1:l(+1), estimated according to the value of COND. C C X (output) DOUBLE PRECISION array, dimension (N) C This array contains the least squares solution of the C system J*x = b, D*x = 0. C C Tolerances C C TOL DOUBLE PRECISION C If COND = 'E', the tolerance to be used for finding the C ranks of the submatrices S_k. If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C the reciprocal condition number; a (sub)matrix whose C estimated condition number is less than 1/TOL is C considered to be of full rank. If the user sets TOL <= 0, C then an implicitly computed, default tolerance, defined by C TOLDEF = N*EPS, is used instead, where EPS is the machine C precision (see LAPACK Library routine DLAMCH). C This parameter is not relevant if COND = 'U' or 'N'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, the first N elements of this array contain the C diagonal elements of the upper triangular matrix S, and C the next N elements contain the solution z. C If BN > 1 and BSN > 0, the elements 2*N+1 : 2*N+ST*(N-ST) C contain the submatrix (S(1:N-ST,N-ST+1:N))' of the C matrix S. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 2*N, if BN <= 1 or BSN = 0 and C COND <> 'E'; C LDWORK >= 4*N, if BN <= 1 or BSN = 0 and C COND = 'E'; C LDWORK >= ST*(N-ST) + 2*N, if BN > 1 and BSN > 0 and C COND <> 'E'; C LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST), C if BN > 1 and BSN > 0 and C COND = 'E'. 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 Standard plane rotations are used to annihilate the elements of C the diagonal matrix D, updating the upper triangular matrix R C and the first n elements of the vector Q'*b. A basic least squares C solution is computed. The computations exploit the special C structure and storage scheme of the matrix R. If one or more of C the submatrices S_k, k = 1:l+1, is singular, then the computed C result is not the basic least squares solution for the whole C problem, but a concatenation of (least squares) solutions of the C individual subproblems involving R_k, k = 1:l+1 (with adapted C right hand sides). C C REFERENCES C C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. C User's Guide for MINPACK-1. C Applied Math. Division, Argonne National Laboratory, Argonne, C Illinois, Report ANL-80-74, 1980. C C NUMERICAL ASPECTS C C The algorithm requires 0(N*(BSN+ST)) operations and is backward C stable, if R is nonsingular. C C FURTHER COMMENTS C C This routine is a structure-exploiting, LAPACK-based modification C of QRSOLV from the MINPACK package [1], and with optional C condition estimation. C The option COND = 'U' is useful when dealing with several C right-hand side vectors. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C - C C KEYWORDS C C Linear system of equations, matrix operations, plane rotations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER COND INTEGER INFO, LDR, LDWORK, LIPAR, N DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IPAR(*), IPVT(*), RANKS(*) DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*) C .. Local Scalars .. DOUBLE PRECISION QTBPJ INTEGER BN, BSM, BSN, I, IB, IBSN, IS, ITC, ITR, J, $ JW, K, KF, L, NC, NTHS, ST LOGICAL ECOND C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DSWAP, MB02YD, MB04OW, NF01BR, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Check the scalar input parameters. C ECOND = LSAME( COND, 'E' ) INFO = 0 IF( .NOT.( ECOND .OR. LSAME( COND, 'N' ) .OR. $ LSAME( COND, 'U' ) ) ) THEN INFO = -1 ELSEIF( N.LT.0 ) THEN INFO = -2 ELSEIF( LIPAR.LT.4 ) THEN INFO = -4 ELSE ST = IPAR(1) BN = IPAR(2) BSM = IPAR(3) BSN = IPAR(4) NTHS = BN*BSN IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN INFO = -3 ELSEIF ( N.NE.NTHS + ST ) THEN INFO = -2 ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE JW = 2*N IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN IF ( ECOND ) $ JW = 4*N ELSE JW = ST*NTHS + JW IF ( ECOND ) $ JW = 2*MAX( BSN, ST ) + JW END IF IF ( LDWORK.LT.JW ) $ INFO = -14 ENDIF ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01BQ', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN C C Special case: R is an upper triangular matrix. C Workspace: 4*N, if COND = 'E'; C 2*N, if COND <> 'E'. C CALL MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANKS(1), X, $ TOL, DWORK, LDWORK, INFO ) RETURN END IF C C General case: BN > 1 and BSN > 0. C Copy R and Q'*b to preserve input and initialize S. C In particular, save the diagonal elements of R in X. C IB = N + 1 IS = IB + N JW = IS + ST*NTHS I = 1 L = IS NC = BSN + ST KF = NC C DO 20 K = 1, BN C DO 10 J = 1, BSN X(I) = R(I,J) CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) I = I + 1 10 CONTINUE C 20 CONTINUE C C DWORK(IS) contains a copy of [ L_1' ... L_l' ]. C Workspace: ST*(N-ST)+2*N; C DO 30 J = BSN + 1, NC CALL DCOPY( NTHS, R(1,J), 1, DWORK(L), ST ) X(I) = R(I,J) CALL DCOPY( NC-J+1, R(I,J), LDR, R(I,J), 1 ) I = I + 1 L = L + 1 30 CONTINUE C CALL DCOPY( N, QTB, 1, DWORK(IB), 1 ) IF ( ST.GT.0 ) THEN ITR = NTHS + 1 ITC = BSN + 1 ELSE ITR = 1 ITC = 1 END IF IBSN = 0 C C Eliminate the diagonal matrix D using Givens rotations. C DO 50 J = 1, N IBSN = IBSN + 1 I = IBSN C C Prepare the row of D to be eliminated, locating the C diagonal element using P from the QR factorization. C L = IPVT(J) IF ( DIAG(L).NE.ZERO ) THEN QTBPJ = ZERO DWORK(J) = DIAG(L) C DO 40 K = J + 1, MIN( J + KF - 1, N ) DWORK(K) = ZERO 40 CONTINUE C C The transformations to eliminate the row of D modify only C a single element of Q'*b beyond the first n, which is C initially zero. C IF ( J.LT.NTHS ) THEN CALL MB04OW( BSN-IBSN+1, ST, 1, R(J,IBSN), LDR, $ R(ITR,ITC), LDR, DWORK(J), 1, DWORK(IB+J-1), $ BSN, DWORK(IB+NTHS), ST, QTBPJ, 1 ) IF ( IBSN.EQ.BSN ) $ IBSN = 0 ELSE IF ( J.EQ.NTHS ) THEN CALL MB04OW( 1, ST, 1, R(J,IBSN), LDR, R(ITR,ITC), LDR, $ DWORK(J), 1, DWORK(IB+J-1), BSN, $ DWORK(IB+NTHS), ST, QTBPJ, 1 ) KF = ST ELSE CALL MB04OW( 0, N-J+1, 1, R(J,IBSN), LDR, R(J,IBSN), LDR, $ DWORK(J), 1, DWORK(IB+J-1), 1, $ DWORK(IB+J-1), ST, QTBPJ, 1 ) END IF ELSE IF ( J.LT.NTHS ) THEN IF ( IBSN.EQ.BSN ) $ IBSN = 0 ELSE IF ( J.EQ.NTHS ) THEN KF = ST END IF END IF C C Store the diagonal element of S. C DWORK(J) = R(J,I) 50 CONTINUE C C Solve the triangular system for z. If the system is singular, C then obtain an approximate least squares solution. C Additional workspace: 2*MAX(BSN,ST), if COND = 'E'; C 0, if COND <> 'E'. C CALL NF01BR( COND, 'Upper', 'NoTranspose', N, IPAR, LIPAR, R, LDR, $ DWORK, DWORK(IS), 1, DWORK(IB), RANKS, TOL, $ DWORK(JW), LDWORK-JW+1, INFO ) I = 1 C C Restore the diagonal elements of R from X and interchange C the upper and lower triangular parts of R. C DO 70 K = 1, BN C DO 60 J = 1, BSN R(I,J) = X(I) CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) I = I + 1 60 CONTINUE C 70 CONTINUE C DO 80 J = BSN + 1, NC CALL DSWAP( NTHS, R(1,J), 1, DWORK(IS), ST ) R(I,J) = X(I) CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) I = I + 1 IS = IS + 1 80 CONTINUE C C Permute the components of z back to components of x. C DO 90 J = 1, N L = IPVT(J) X(L) = DWORK(N+J) 90 CONTINUE C RETURN C C *** Last line of NF01BQ *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04OW.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB04OW.f0000644000175000017500000004251515012430707017416 0ustar00lilgelilge00000000000000 SUBROUTINE SB04OW( M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, $ F, LDF, SCALE, IWORK, INFO ) C C PURPOSE C C To solve a periodic Sylvester equation C C A * R - L * B = scale * C (1) C D * L - R * E = scale * F, C C using Level 1 and 2 BLAS, where R and L are unknown M-by-N C matrices, (A, D), (B, E) and (C, F) are given matrix pairs of C size M-by-M, N-by-N and M-by-N, respectively, with real entries. C (A, D) and (B, E) must be in periodic Schur form, i.e. A, B are C upper quasi triangular and D, E are upper triangular. The solution C (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output scaling C factor chosen to avoid overflow. C C This routine is largely based on the LAPACK routine DTGSY2 C developed by Bo Kagstrom and Peter Poromaa. C C ARGUMENTS C C Input/Output Parameters C C M (input) INTEGER C The order of A and D, and the row dimension of C, F, R C and L. M >= 0. C C N (input) INTEGER C The order of B and E, and the column dimension of C, F, R C and L. N >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,M) C On entry, the leading M-by-M part of this array must C contain the upper quasi triangular matrix A. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,M). C C B (input) DOUBLE PRECISION array, dimension (LDB,N) C On entry, the leading N-by-N part of this array must C contain the upper quasi triangular matrix B. C C LDB INTEGER C The leading dimension of the 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 right-hand-side of the first matrix equation C in (1). C On exit, the leading M-by-N part of this array contains C the solution R. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,M). C C D (input) DOUBLE PRECISION array, dimension (LDD,M) C On entry, the leading M-by-M part of this array must C contain the upper triangular matrix D. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1,M). C C E (input) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the upper triangular matrix E. C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,N). C C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) C On entry, the leading M-by-N part of this array must C contain the right-hand-side of the second matrix equation C in (1). C On exit, the leading M-by-N part of this array contains C the solution L. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1,M). C C SCALE (output) DOUBLE PRECISION C On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the arrays C C and F will hold the solutions R and L, respectively, to C a slightly perturbed system but the input matrices A, B, D C and E have not been changed. If SCALE = 0, C and F will C hold solutions to the homogeneous system with C = F = 0. C Normally, SCALE = 1. C C Workspace C C IWORK INTEGER array, dimension (M+N+2) 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: the matrix products A*D and B*E have common or very C close eigenvalues. C C METHOD C C In matrix notation solving equation (1) corresponds to solving C Z*x = scale*b, where Z is defined as C C Z = [ kron(In, A) -kron(B', Im) ] (2) C [ -kron(E', Im) kron(In, D) ], C C Ik is the identity matrix of size k and X' is the transpose of X. C kron(X, Y) is the Kronecker product between the matrices X and Y. C In the process of solving (1), we solve a number of such systems C where Dim(Im), Dim(In) = 1 or 2. C C REFERENCES C C [1] Kagstrom, B. C A Direct Method for Reordering Eigenvalues in the Generalized C Real Schur Form of a Regular Matrix Pair (A,B). M.S. Moonen C et al (eds.), Linear Algebra for Large Scale and Real-Time C Applications, Kluwer Academic Publ., pp. 195-218, 1993. C C [2] Sreedhar, J. and Van Dooren, P. C A Schur approach for solving some periodic matrix equations. C U. Helmke et al (eds.), Systems and Networks: Mathematical C Theory and Applications, Akademie Verlag, Berlin, vol. 77, C pp. 339-362, 1994. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DTGPY2). C C KEYWORDS C C Matrix equation, periodic Sylvester equation. C C ****************************************************************** C C .. Parameters .. INTEGER LDZ PARAMETER ( LDZ = 8 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N DOUBLE PRECISION SCALE C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ E(LDE,*), F(LDF,*) C .. Local Scalars .. INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, $ K, MB, NB, P, Q, ZDIM DOUBLE PRECISION SCALOC C .. Local Arrays .. INTEGER IPIV(LDZ), JPIV(LDZ) DOUBLE PRECISION RHS(LDZ), Z(LDZ,LDZ) C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, $ DGETC2, DLASET, DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 IERR = 0 IF ( M.LE.0 ) THEN INFO = -1 ELSE IF ( N.LE.0 ) THEN INFO = -2 ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF ( LDC.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF ( LDD.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF ( LDE.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF ( LDF.LT.MAX( 1, M ) ) THEN INFO = -14 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'SB04OW', -INFO ) RETURN END IF C C Determine block structure of A. C P = 0 I = 1 10 CONTINUE IF ( I.GT.M ) $ GO TO 20 P = P + 1 IWORK(P) = I IF( I.EQ.M ) $ GO TO 20 IF ( A(I+1,I).NE.ZERO ) THEN I = I + 2 ELSE I = I + 1 END IF GO TO 10 20 CONTINUE IWORK(P+1) = M + 1 C C Determine block structure of B. C Q = P + 1 J = 1 30 CONTINUE IF ( J.GT.N ) $ GO TO 40 Q = Q + 1 IWORK(Q) = J IF( J.EQ.N ) $ GO TO 40 IF ( B(J+1,J).NE.ZERO ) THEN J = J + 2 ELSE J = J + 1 END IF GO TO 30 40 CONTINUE IWORK(Q+1) = N + 1 C C Solve (I, J) - subsystem C A(I,I) * R(I,J) - L(I,J) * B(J,J) = C(I,J) C D(I,I) * L(I,J) - R(I,J) * E(J,J) = F(I,J) C for I = P, P - 1, ..., 1; J = 1, 2, ..., Q. C SCALE = ONE SCALOC = ONE DO 120 J = P + 2, Q JS = IWORK(J) JSP1 = JS + 1 JE = IWORK(J+1) - 1 NB = JE - JS + 1 DO 110 I = P, 1, -1 C IS = IWORK(I) ISP1 = IS + 1 IE = IWORK(I+1) - 1 MB = IE - IS + 1 ZDIM = MB*NB*2 C IF ( ( MB.EQ.1 ).AND.( NB.EQ.1 ) ) THEN C C Build a 2-by-2 system Z * x = RHS. C Z(1,1) = A(IS,IS) Z(2,1) = -E(JS,JS) Z(1,2) = -B(JS,JS) Z(2,2) = D(IS,IS) C C Set up right hand side(s). C RHS(1) = C(IS,JS) RHS(2) = F(IS,JS) C C Solve Z * x = RHS. C CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF ( IERR.GT.0 ) $ INFO = IERR C CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF ( SCALOC.NE.ONE ) THEN DO 50 K = 1, N CALL DSCAL( M, SCALOC, C(1,K), 1 ) CALL DSCAL( M, SCALOC, F(1,K), 1 ) 50 CONTINUE SCALE = SCALE*SCALOC END IF C C Unpack solution vector(s). C C(IS,JS) = RHS(1) F(IS,JS) = RHS(2) C C Substitute R(I,J) and L(I,J) into remaining equation. C IF ( I.GT.1 ) THEN CALL DAXPY( IS-1, -RHS(1), A(1,IS), 1, C(1,JS), 1 ) CALL DAXPY( IS-1, -RHS(2), D(1,IS), 1, F(1,JS), 1 ) END IF IF ( J.LT.Q ) THEN CALL DAXPY( N-JE, RHS(2), B(JS,JE+1), LDB, C(IS,JE+1), $ LDC ) CALL DAXPY( N-JE, RHS(1), E(JS,JE+1), LDE, F(IS,JE+1), $ LDF ) END IF C ELSE IF ( ( MB.EQ.1 ).AND.( NB.EQ.2 ) ) THEN C C Build a 4-by-4 system Z * x = RHS. C Z(1,1) = A(IS,IS) Z(2,1) = ZERO Z(3,1) = -E(JS,JS) Z(4,1) = -E(JS,JSP1) C Z(1,2) = ZERO Z(2,2) = A(IS,IS) Z(3,2) = ZERO Z(4,2) = -E(JSP1,JSP1) C Z(1,3) = -B(JS,JS) Z(2,3) = -B(JS,JSP1) Z(3,3) = D(IS,IS) Z(4,3) = ZERO C Z(1,4) = -B(JSP1,JS) Z(2,4) = -B(JSP1,JSP1) Z(3,4) = ZERO Z(4,4) = D(IS,IS) C C Set up right hand side(s). C RHS(1) = C(IS,JS) RHS(2) = C(IS,JSP1) RHS(3) = F(IS,JS) RHS(4) = F(IS,JSP1) C C Solve Z * x = RHS. C CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF ( IERR.GT.0 ) $ INFO = IERR C CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF ( SCALOC.NE.ONE ) THEN DO 60 K = 1, N CALL DSCAL( M, SCALOC, C(1,K), 1 ) CALL DSCAL( M, SCALOC, F(1,K), 1 ) 60 CONTINUE SCALE = SCALE*SCALOC END IF C C Unpack solution vector(s). C C(IS,JS) = RHS(1) C(IS,JSP1) = RHS(2) F(IS,JS) = RHS(3) F(IS,JSP1) = RHS(4) C C Substitute R(I,J) and L(I,J) into remaining equation. C IF ( I.GT.1 ) THEN CALL DGER( IS-1, NB, -ONE, A(1,IS), 1, RHS(1), 1, $ C(1,JS), LDC ) CALL DGER( IS-1, NB, -ONE, D(1,IS), 1, RHS(3), 1, $ F(1,JS), LDF ) END IF IF ( J.LT.Q ) THEN CALL DAXPY( N-JE, RHS(3), B(JS,JE+1), LDB, C(IS,JE+1), $ LDC ) CALL DAXPY( N-JE, RHS(1), E(JS,JE+1), LDE, F(IS,JE+1), $ LDF ) CALL DAXPY( N-JE, RHS(4), B(JSP1,JE+1), LDB, $ C(IS,JE+1), LDC ) CALL DAXPY( N-JE, RHS(2), E(JSP1,JE+1), LDE, $ F(IS,JE+1), LDF ) END IF C ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN C C Build a 4-by-4 system Z * x = RHS. C Z(1,1) = A(IS,IS) Z(2,1) = A(ISP1,IS) Z(3,1) = -E(JS,JS) Z(4,1) = ZERO C Z(1,2) = A(IS,ISP1) Z(2,2) = A(ISP1,ISP1) Z(3,2) = ZERO Z(4,2) = -E(JS,JS) C Z(1,3) = -B(JS,JS) Z(2,3) = ZERO Z(3,3) = D(IS,IS) Z(4,3) = ZERO C Z(1,4) = ZERO Z(2,4) = -B(JS,JS) Z(3,4) = D(IS,ISP1) Z(4,4) = D(ISP1,ISP1) C C Set up right hand side(s). C RHS(1) = C(IS,JS) RHS(2) = C(ISP1,JS) RHS(3) = F(IS,JS) RHS(4) = F(ISP1,JS) C C Solve Z * x = RHS. C CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF ( IERR.GT.0 ) $ INFO = IERR C CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF ( SCALOC.NE.ONE ) THEN DO 70 K = 1, N CALL DSCAL( M, SCALOC, C(1,K), 1 ) CALL DSCAL( M, SCALOC, F(1,K), 1 ) 70 CONTINUE SCALE = SCALE*SCALOC END IF C C Unpack solution vector(s). C C(IS,JS) = RHS(1) C(ISP1,JS) = RHS(2) F(IS,JS) = RHS(3) F(ISP1,JS) = RHS(4) C C Substitute R(I,J) and L(I,J) into remaining equation. C IF ( I.GT.1 ) THEN CALL DGEMV( 'N', IS-1, MB, -ONE, A(1,IS), LDA, RHS(1), $ 1, ONE, C(1,JS), 1 ) CALL DGEMV( 'N', IS-1, MB, -ONE, D(1,IS), LDD, RHS(3), $ 1, ONE, F(1,JS), 1 ) END IF IF ( J.LT.Q ) THEN CALL DGER( MB, N-JE, ONE, RHS(3), 1, B(JS,JE+1), LDB, $ C(IS,JE+1), LDC ) CALL DGER( MB, N-JE, ONE, RHS(1), 1, E(JS,JE+1), LDE, $ F(IS,JE+1), LDF ) END IF C ELSE IF ( ( MB.EQ.2 ).AND.( NB.EQ.2 ) ) THEN C C Build an 8-by-8 system Z * x = RHS. C CALL DLASET( 'All', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) C Z(1,1) = A(IS,IS) Z(2,1) = A(ISP1,IS) Z(5,1) = -E(JS,JS) Z(7,1) = -E(JS,JSP1) C Z(1,2) = A(IS,ISP1) Z(2,2) = A(ISP1,ISP1) Z(6,2) = -E(JS,JS) Z(8,2) = -E(JS,JSP1) C Z(3,3) = A(IS,IS) Z(4,3) = A(ISP1,IS) Z(7,3) = -E(JSP1,JSP1) C Z(3,4) = A(IS,ISP1) Z(4,4) = A(ISP1,ISP1) Z(8,4) = -E(JSP1,JSP1) C Z(1,5) = -B(JS,JS) Z(3,5) = -B(JS,JSP1) Z(5,5) = D(IS,IS) C Z(2,6) = -B(JS,JS) Z(4,6) = -B(JS,JSP1) Z(5,6) = D(IS,ISP1) Z(6,6) = D(ISP1,ISP1) C Z(1,7) = -B(JSP1,JS) Z(3,7) = -B(JSP1,JSP1) Z(7,7) = D(IS,IS) C Z(2,8) = -B(JSP1,JS) Z(4,8) = -B(JSP1,JSP1) C Z(7,8) = D(IS,ISP1) Z(8,8) = D(ISP1,ISP1) C C Set up right hand side(s). C K = 1 II = MB*NB + 1 DO 80 JJ = 0, NB - 1 CALL DCOPY( MB, C(IS,JS+JJ), 1, RHS(K), 1 ) CALL DCOPY( MB, F(IS,JS+JJ), 1, RHS(II), 1 ) K = K + MB II = II + MB 80 CONTINUE C C Solve Z * x = RHS. C CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) IF ( IERR.GT.0 ) $ INFO = IERR C CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) IF ( SCALOC.NE.ONE ) THEN DO 90 K = 1, N CALL DSCAL( M, SCALOC, C(1,K), 1 ) CALL DSCAL( M, SCALOC, F(1,K), 1 ) 90 CONTINUE SCALE = SCALE*SCALOC END IF C C Unpack solution vector(s). C K = 1 II = MB*NB + 1 DO 100 JJ = 0, NB - 1 CALL DCOPY( MB, RHS(K), 1, C(IS,JS+JJ), 1 ) CALL DCOPY( MB, RHS(II), 1, F(IS,JS+JJ), 1 ) K = K + MB II = II + MB 100 CONTINUE C C Substitute R(I,J) and L(I,J) into remaining equation. C K = MB*NB + 1 IF ( I.GT.1 ) THEN CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, A(1,IS), $ LDA, RHS(1), MB, ONE, C(1,JS), LDC ) CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, D(1,IS), $ LDD, RHS(K), MB, ONE, F(1,JS), LDF ) END IF IF ( J.LT.Q ) THEN CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS(K), MB, $ B(JS,JE+1), LDB, ONE, C(IS,JE+1), LDC ) CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS(1), MB, $ E(JS,JE+1), LDE, ONE, F(IS,JE+1), LDF ) END IF C END IF C 110 CONTINUE 120 CONTINUE RETURN C *** Last line of SB04OW *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02OD.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02OD.f0000644000175000017500000002030715012430707017356 0ustar00lilgelilge00000000000000 SUBROUTINE MB02OD( SIDE, UPLO, TRANS, DIAG, NORM, M, N, ALPHA, A, $ LDA, B, LDB, RCOND, TOL, IWORK, DWORK, INFO ) C C PURPOSE C C To solve (if well-conditioned) one of the matrix equations C C op( A )*X = alpha*B, or X*op( A ) = alpha*B, C C where alpha is a scalar, X and B are m-by-n matrices, A is a unit, C or non-unit, upper or lower triangular matrix and op( A ) is one C of C C op( A ) = A or op( A ) = A'. C C An estimate of the reciprocal of the condition number of the C triangular matrix A, in either the 1-norm or the infinity-norm, is C also computed as C C RCOND = 1 / ( norm(A) * norm(inv(A)) ). C C and the specified matrix equation is solved only if RCOND is C larger than a given tolerance TOL. In that case, the matrix X is C overwritten on B. C C ARGUMENTS C C Mode Parameters C C SIDE CHARACTER*1 C Specifies whether op( A ) appears on the left or right C of X as follows: C = 'L': op( A )*X = alpha*B; C = 'R': X*op( A ) = alpha*B. C C UPLO CHARACTER*1 C Specifies whether the matrix A is an upper or lower C triangular matrix as follows: C = 'U': A is an upper triangular matrix; C = 'L': A is a lower triangular matrix. 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 DIAG CHARACTER*1 C Specifies whether or not A is unit triangular as follows: C = 'U': A is assumed to be unit triangular; C = 'N': A is not assumed to be unit triangular. C C NORM CHARACTER*1 C Specifies whether the 1-norm condition number or the C infinity-norm condition number is required: C = '1' or 'O': 1-norm; C = 'I': Infinity-norm. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of B. M >= 0. C C N (input) INTEGER C The number of columns of B. N >= 0. C C ALPHA (input) DOUBLE PRECISION C The scalar alpha. When alpha is zero then A is not C referenced and B need not be set before entry. C C A (input) DOUBLE PRECISION array, dimension (LDA,k), C where k is M when SIDE = 'L' and is N when SIDE = 'R'. C On entry with UPLO = 'U', the leading k-by-k upper C triangular part of this array must contain the upper C triangular matrix and the strictly lower triangular part C of A is not referenced. C On entry with UPLO = 'L', the leading k-by-k lower C triangular part of this array must contain the lower C triangular matrix and the strictly upper triangular part C of A is not referenced. C Note that when DIAG = 'U', the diagonal elements of A are C not referenced either, but are assumed to be unity. C C LDA INTEGER C The leading dimension of array A. C LDA >= max(1,M) when SIDE = 'L'; C LDA >= max(1,N) when SIDE = 'R'. 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 right-hand side matrix B. C On exit, if INFO = 0, the leading M-by-N part of this C array contains the solution matrix X. C Otherwise, this array is not modified by the routine. C C LDB INTEGER C The leading dimension of array B. LDB >= max(1,M). C C RCOND (output) DOUBLE PRECISION C The reciprocal of the condition number of the matrix A, C computed as RCOND = 1/(norm(A) * norm(inv(A))). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used to test for near singularity of C the matrix A. If the user sets TOL > 0, then the given C value of TOL is used as a lower bound for the reciprocal C condition number of that matrix; a matrix whose estimated C condition number is less than 1/TOL is considered to be C nonsingular. If the user sets TOL <= 0, then an implicitly C computed, default tolerance, defined by TOLDEF = k*k*EPS, C is used instead, where EPS is the machine precision (see C LAPACK Library routine DLAMCH). C C Workspace C C IWORK INTEGER array, dimension (k) C C DWORK DOUBLE PRECISION array, dimension (3*k) 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 A is numerically singular, i.e. the C condition number estimate of A (in the specified C norm) exceeds 1/TOL. C C METHOD C C An estimate of the reciprocal of the condition number of the C triangular matrix A (in the specified norm) is computed, and if C this estimate is larger then the given (or default) tolerance, C the specified matrix equation is solved using Level 3 BLAS C routine DTRSM. C C C REFERENCES C C None. C C NUMERICAL ASPECTS C 2 C The algorithm requires k N/2 operations. C C CONTRIBUTORS C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C C REVISIONS C C February 20, 1998. C C KEYWORDS C C Condition number, matrix algebra, matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DIAG, NORM, SIDE, TRANS, UPLO INTEGER INFO, LDA, LDB, M, N DOUBLE PRECISION ALPHA, RCOND, TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*) C .. Local Scalars .. LOGICAL LSIDE, ONENRM INTEGER NROWA DOUBLE PRECISION TOLDEF C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DTRCON, DTRSM, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C .. Executable Statements .. C LSIDE = LSAME( SIDE, 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) C C Test the input scalar arguments. C INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = -1 ELSE IF( ( .NOT.LSAME( UPLO, 'U' ) ).AND. $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = -2 ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = -3 ELSE IF( ( .NOT.LSAME( DIAG, 'U' ) ).AND. $ ( .NOT.LSAME( DIAG, 'N' ) ) )THEN INFO = -4 ELSE IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN INFO = -5 ELSE IF( M.LT.0 )THEN INFO = -6 ELSE IF( N.LT.0 )THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = -10 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = -12 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02OD', -INFO ) RETURN END IF C C Quick return if possible. C IF( NROWA.EQ.0 ) THEN RCOND = ONE RETURN END IF C TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) $ TOLDEF = DBLE( NROWA*NROWA )*DLAMCH( 'Epsilon' ) C CALL DTRCON( NORM, UPLO, DIAG, NROWA, A, LDA, RCOND, DWORK, $ IWORK, INFO ) C IF ( RCOND.GT.TOLDEF ) THEN CALL DTRSM( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, LDA, B, $ LDB ) ELSE INFO = 1 END IF C *** Last line of MB02OD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02UV.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02UV.f0000644000175000017500000001225015012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE MB02UV( N, A, LDA, IPIV, JPIV, INFO ) 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 control-4.1.2/src/slicot/src/PaxHeaders/TC04AD.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TC04AD.f0000644000175000017500000003744315012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE TC04AD( LERI, M, P, INDEX, PCOEFF, LDPCO1, LDPCO2, $ QCOEFF, LDQCO1, LDQCO2, N, RCOND, A, LDA, B, $ LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To find a state-space representation (A,B,C,D) with the same C transfer matrix T(s) as that of a given left or right polynomial C matrix representation, i.e. C C C*inv(sI-A)*B + D = T(s) = inv(P(s))*Q(s) = Q(s)*inv(P(s)). C C ARGUMENTS C C Mode Parameters C C LERI CHARACTER*1 C Indicates whether a left polynomial matrix representation C or a right polynomial matrix representation is input as C follows: C = 'L': A left matrix fraction is input; C = 'R': A right matrix fraction is input. C C Input/Output Parameters 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 INDEX (input) INTEGER array, dimension (MAX(M,P)) C If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the C maximum degree of the polynomials in the I-th row of the C denominator matrix P(s) of the given left polynomial C matrix representation. C If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the C maximum degree of the polynomials in the I-th column of C the denominator matrix P(s) of the given right polynomial C matrix representation. C C PCOEFF (input) DOUBLE PRECISION array, dimension C (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1. C If LERI = 'L' then porm = P, otherwise porm = M. C The leading porm-by-porm-by-kpcoef part of this array must C contain the coefficients of the denominator matrix P(s). C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if C LERI = 'L' then iorj = I, otherwise iorj = J. C Thus for LERI = 'L', P(s) = C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). C If LERI = 'R', PCOEFF is modified by the routine but C restored on exit. C C LDPCO1 INTEGER C The leading dimension of array PCOEFF. C LDPCO1 >= MAX(1,P) if LERI = 'L', C LDPCO1 >= MAX(1,M) if LERI = 'R'. C C LDPCO2 INTEGER C The second dimension of array PCOEFF. C LDPCO2 >= MAX(1,P) if LERI = 'L', C LDPCO2 >= MAX(1,M) if LERI = 'R'. C C QCOEFF (input) DOUBLE PRECISION array, dimension C (LDQCO1,LDQCO2,kpcoef) C If LERI = 'L' then porp = M, otherwise porp = P. C The leading porm-by-porp-by-kpcoef part of this array must C contain the coefficients of the numerator matrix Q(s). C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). C If LERI = 'R', QCOEFF is modified by the routine but C restored on exit. C C LDQCO1 INTEGER C The leading dimension of array QCOEFF. C LDQCO1 >= MAX(1,P) if LERI = 'L', C LDQCO1 >= MAX(1,M,P) if LERI = 'R'. C C LDQCO2 INTEGER C The second dimension of array QCOEFF. C LDQCO2 >= MAX(1,M) if LERI = 'L', C LDQCO2 >= MAX(1,M,P) if LERI = 'R'. C C N (output) INTEGER C The order of the resulting state-space representation. C porm C That is, N = SUM INDEX(I). C I=1 C C RCOND (output) DOUBLE PRECISION C The estimated reciprocal of the condition number of the C leading row (if LERI = 'L') or the leading column (if C LERI = 'R') coefficient matrix of P(s). C If RCOND is nearly zero, P(s) is nearly row or column C non-proper. C C A (output) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array contains the state C dynamics matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) C The leading N-by-M part of this array contains the C input/state matrix B; the remainder of the leading C N-by-MAX(M,P) part is used as internal workspace. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C C (output) DOUBLE PRECISION array, dimension (LDC,N) C The leading P-by-N part of this array contains the C state/output matrix C; the remainder of the leading C MAX(M,P)-by-N part is used as internal workspace. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,M,P). C C D (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) C The leading P-by-M part of this array contains the direct C transmission matrix D; the remainder of the leading C MAX(M,P)-by-MAX(M,P) part is used as internal workspace. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,M,P). C C Workspace C C IWORK INTEGER array, dimension (2*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,MAX(M,P)*(MAX(M,P)+4)). 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: if P(s) is not row (if LERI = 'L') or column C (if LERI = 'R') proper. Consequently, no state-space C representation is calculated. C C METHOD C C The method for a left matrix fraction will be described here; C right matrix fractions are dealt with by obtaining the dual left C polynomial matrix representation and constructing an equivalent C state-space representation for this. The first step is to check C if the denominator matrix P(s) is row proper; if it is not then C the routine returns with the Error Indicator (INFO) set to 1. C Otherwise, Wolovich's Observable Structure Theorem is used to C construct a state-space representation (A,B,C,D) in observable C companion form. The sizes of the blocks of matrix A and matrix C C here are precisely the row degrees of P(s), while their C 'non-trivial' columns are given easily from its coefficients. C Similarly, the matrix D is obtained from the leading coefficients C of P(s) and of the numerator matrix Q(s), while matrix B is given C by the relation Sbar(s)B = Q(s) - P(s)D, where Sbar(s) is a C polynomial matrix whose (j,k)(th) element is given by C C j-u(k-1)-1 C ( s , j = u(k-1)+1,u(k-1)+2,....,u(k) C Sbar = ( C j,k ( 0 , otherwise C C k C u(k) = SUM d , k = 1,2,...,M and d ,d ,...,d are the C i=1 i 1 2 M C controllability indices. For convenience in solving this, C' and B C are initially set up to contain the coefficients of P(s) and Q(s), C respectively, stored by rows. C C REFERENCES C C [1] Wolovich, W.A. C Linear Multivariate Systems, (Theorem 4.3.3). C Springer-Verlag, 1974. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TC01BD by T.W.C.Williams, Kingston C Polytechnic, United Kingdom, March 1982. C C REVISIONS C C February 22, 1998 (changed the name of TC01ND). C May 12, 1998. C C KEYWORDS C C Coprime matrix fraction, elementary polynomial operations, C polynomial matrix, state-space representation, transfer matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER LERI INTEGER INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, $ LDQCO1, LDQCO2, LDWORK, M, N, P DOUBLE PRECISION RCOND C .. Array Arguments .. INTEGER INDEX(*), IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), $ QCOEFF(LDQCO1,LDQCO2,*) C .. Local Scalars .. LOGICAL LLERI INTEGER I, IA, IBIAS, J, JA, JC, JW, JWORK, LDW, K, $ KPCOEF, KSTOP, MAXIND, MINDEX, MWORK, PWORK, $ WRKOPT DOUBLE PRECISION DWNORM C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, DLAMCH, DLANGE C .. External Subroutines .. EXTERNAL AB07MD, DCOPY, DGECON, DGEMM, DGETRF, DGETRI, $ DGETRS, DLACPY, DLASET, TC01OD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C INFO = 0 LLERI = LSAME( LERI, 'L' ) MINDEX = MAX( M, P ) C C Test the input scalar arguments. C IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( P.LT.0 ) THEN INFO = -3 ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN INFO = -6 ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN INFO = -7 ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR. $ ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, MINDEX ) ) ) THEN INFO = -9 ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR. $ ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MINDEX ) ) ) THEN INFO = -10 END IF C N = 0 IF ( INFO.EQ.0 ) THEN IF ( LLERI ) THEN PWORK = P MWORK = M ELSE PWORK = M MWORK = P END IF C MAXIND = 0 DO 10 I = 1, PWORK N = N + INDEX(I) IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I) 10 CONTINUE KPCOEF = MAXIND + 1 END IF C IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LDC.LT.MAX( 1, MINDEX ) ) THEN INFO = -18 ELSE IF( LDD.LT.MAX( 1, MINDEX ) ) THEN INFO = -20 ELSE IF( LDWORK.LT.MAX( 1, MINDEX*( MINDEX + 4 ) ) ) THEN INFO = -23 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TC04AD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( M.EQ.0 .OR. P.EQ.0 ) THEN N = 0 RCOND = ONE DWORK(1) = ONE RETURN END IF C IF ( .NOT.LLERI ) THEN C C Initialization for right matrix fraction: obtain the dual C system. C CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2, $ QCOEFF, LDQCO1, LDQCO2, INFO ) END IF C C Store leading row coefficient matrix of P(s). C LDW = MAX( 1, PWORK ) CALL DLACPY( 'Full', PWORK, PWORK, PCOEFF, LDPCO1, DWORK, LDW ) C C Check if P(s) is row proper: if not, exit. C DWNORM = DLANGE( '1-norm', PWORK, PWORK, DWORK, LDW, DWORK ) C CALL DGETRF( PWORK, PWORK, DWORK, LDW, IWORK, INFO ) C C Workspace: need PWORK*(PWORK + 4). 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 JWORK = LDW*PWORK + 1 C CALL DGECON( '1-norm', PWORK, DWORK, LDW, DWNORM, RCOND, $ DWORK(JWORK), IWORK(PWORK+1), INFO ) C WRKOPT = MAX( 1, PWORK*(PWORK + 4) ) C IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN C C Error return: P(s) is not row proper. C INFO = 1 RETURN ELSE C C Calculate the order of equivalent state-space representation, C and initialize A. C CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA ) C DWORK(JWORK) = ONE IF ( N.GT.1 ) CALL DCOPY( N-1, DWORK(JWORK), 0, A(2,1), LDA+1 ) C C Find the PWORK ordered 'non-trivial' columns row by row, C in PWORK row blocks, the I-th having INDEX(I) rows. C IBIAS = 2 C DO 50 I = 1, PWORK KSTOP = INDEX(I) + 1 IF ( KSTOP.NE.1 ) THEN IBIAS = IBIAS + INDEX(I) C C These rows given from the lower coefficients of row I C of P(s). C DO 40 K = 2, KSTOP IA = IBIAS - K C DO 20 J = 1, PWORK DWORK(JWORK+J-1) = -PCOEFF(I,J,K) 20 CONTINUE C CALL DGETRS( 'Transpose', PWORK, 1, DWORK, LDW, $ IWORK, DWORK(JWORK), LDW, INFO ) C JA = 0 C DO 30 J = 1, PWORK IF ( INDEX(J).NE.0 ) THEN JA = JA + INDEX(J) A(IA,JA) = DWORK(JWORK+J-1) END IF 30 CONTINUE C C Also, set up B and C (temporarily) for use when C finding B. C CALL DCOPY( MWORK, QCOEFF(I,1,K), LDQCO1, B(IA,1), $ LDB ) CALL DCOPY( PWORK, PCOEFF(I,1,K), LDPCO1, C(1,IA), 1 ) 40 CONTINUE C END IF 50 CONTINUE C C Calculate D from the leading coefficients of P and Q. C CALL DLACPY( 'Full', PWORK, MWORK, QCOEFF, LDQCO1, D, LDD ) C CALL DGETRS( 'No transpose', PWORK, MWORK, DWORK, LDW, IWORK, $ D, LDD, INFO ) C C For B and C as set up above, desired B = B - (C' * D). C CALL DGEMM( 'Transpose', 'No transpose', N, MWORK, PWORK, -ONE, $ C, LDC, D, LDD, ONE, B, LDB ) C C Finally, calculate C: zero, apart from ... C CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC ) C C PWORK ordered 'non-trivial' columns, equal to those C of inv(DWORK). C C Workspace: need PWORK*(PWORK + 1); C prefer PWORK*PWORK + PWORK*NB. C CALL DGETRI( PWORK, DWORK, LDW, IWORK, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) JC = 0 JW = 1 C DO 60 J = 1, PWORK IF ( INDEX(J).NE.0 ) THEN JC = JC + INDEX(J) CALL DCOPY( PWORK, DWORK(JW), 1, C(1,JC), 1 ) END IF JW = JW + LDW 60 CONTINUE C END IF C C For right matrix fraction, return to original (dual of dual) C system. C IF ( .NOT.LLERI ) THEN CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO ) C C Also, obtain dual of state-space representation. C CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, $ LDD, INFO ) END IF C C Set optimal workspace dimension. C DWORK(1) = WRKOPT C RETURN C *** Last line of TC04AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03FZ.f0000644000000000000000000000013215012430707016176 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03FZ.f0000644000175000017500000012756715012430707017414 0ustar00lilgelilge00000000000000 SUBROUTINE MB03FZ( COMPQ, COMPU, ORTH, N, Z, LDZ, B, LDB, FG, $ LDFG, NEIG, D, LDD, C, LDC, Q, LDQ, U, LDU, $ ALPHAR, ALPHAI, BETA, IWORK, LIWORK, DWORK, $ LDWORK, ZWORK, LZWORK, BWORK, INFO ) C C PURPOSE C C To compute the eigenvalues of a complex N-by-N skew-Hamiltonian/ C Hamiltonian pencil aS - bH, with C C ( B F ) ( Z11 Z12 ) C S = J Z' J' Z and H = ( ), Z = ( ), C ( G -B' ) ( Z21 Z22 ) C (1) C ( 0 I ) C J = ( ). C ( -I 0 ) C C The structured Schur form of the embedded real skew-Hamiltonian/ C C skew-Hamiltonian pencil, aB_S - bB_T, with B_S = J B_Z' J' B_Z, C C ( Re(Z11) -Im(Z11) | Re(Z12) -Im(Z12) ) C ( | ) C ( Im(Z11) Re(Z11) | Im(Z12) Re(Z12) ) C ( | ) C B_Z = (---------------------+---------------------) , C ( | ) C ( Re(Z21) -Im(Z21) | Re(Z22) -Im(Z22) ) C ( | ) C ( Im(Z21) Re(Z21) | Im(Z22) Re(Z22) ) C (2) C ( -Im(B) -Re(B) | -Im(F) -Re(F) ) C ( | ) C ( Re(B) -Im(B) | Re(F) -Im(F) ) C ( | ) C B_T = (-----------------+-----------------) , T = i*H, C ( | ) C ( -Im(G) -Re(G) | -Im(B') Re(B') ) C ( | ) C ( Re(G) -Im(G) | -Re(B') -Im(B') ) C C is determined and used to compute the eigenvalues. Optionally, if C COMPQ = 'C', an orthonormal basis of the right deflating subspace, C Def_-(S, H), of the pencil aS - bH in (1), corresponding to the C eigenvalues with strictly negative real part, is computed. Namely, C after transforming aB_S - bB_H, in the factored form, by unitary C matrices, we have B_Sout = J B_Zout' J' B_Zout, C C ( BA BD ) ( BB BF ) C B_Zout = ( ) and B_Hout = ( ), (3) C ( 0 BC ) ( 0 -BB' ) C C and the eigenvalues with strictly negative real part of the C complex pencil aB_Sout - bB_Hout are moved to the top. The C notation M' denotes the conjugate transpose of the matrix M. C Optionally, if COMPU = 'C', an orthonormal basis of the companion C subspace, range(P_U) [1], which corresponds to the eigenvalues C with negative real part, is computed. The embedding doubles the C multiplicities of the eigenvalues of the pencil aS - bH. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether to compute the right deflating subspace C corresponding to the eigenvalues of aS - bH with strictly C negative real part. C = 'N': do not compute the deflating subspace; C = 'C': compute the deflating subspace and store it in the C leading subarray of Q. C C COMPU CHARACTER*1 C Specifies whether to compute the companion subspace C corresponding to the eigenvalues of aS - bH with strictly C negative real part. C = 'N': do not compute the companion subspace; C = 'C': compute the companion subspace and store it in the C leading subarray of U. C C ORTH CHARACTER*1 C If COMPQ = 'C' or COMPU = 'C', specifies the technique for C computing the orthonormal bases of the deflating subspace C and companion subspace, as follows: C = 'P': QR factorization with column pivoting; C = 'S': singular value decomposition. C If COMPQ = 'N' and COMPU = 'N', the ORTH value is not C used. C C Input/Output Parameters C C N (input) INTEGER C Order of the pencil aS - bH. N >= 0, even. C C Z (input/output) COMPLEX*16 array, dimension (LDZ, N) C On entry, the leading N-by-N part of this array must C contain the non-trivial factor Z in the factorization C S = J Z' J' Z of the skew-Hamiltonian matrix S. C On exit, if COMPQ = 'C' or COMPU = 'C', the leading C N-by-N part of this array contains the upper triangular C matrix BA in (3) (see also METHOD). The strictly lower C triangular part is not zeroed. C If COMPQ = 'N' and COMPU = 'N', this array is unchanged C on exit. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1, N). C C B (input/output) COMPLEX*16 array, dimension (LDB, N) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C On exit, if COMPQ = 'C' or COMPU = 'C', the leading C N-by-N part of this array contains the upper triangular C matrix BB in (3) (see also METHOD). The strictly lower C triangular part is not zeroed. C If COMPQ = 'N' and COMPU = 'N', this array is unchanged C on exit. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N). C C FG (input/output) COMPLEX*16 array, dimension (LDFG, N) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C Hermitian matrix G, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C Hermitian matrix F. C On exit, if COMPQ = 'C' or COMPU = 'C', the leading C N-by-N part of this array contains the Hermitian matrix C BF in (3) (see also METHOD). The strictly lower triangular C part of the input matrix is preserved. The diagonal C elements might have tiny imaginary parts. C If COMPQ = 'N' and COMPU = 'N', this array is unchanged C on exit. C C LDFG INTEGER C The leading dimension of the array FG. LDFG >= MAX(1, N). C C NEIG (output) INTEGER C If COMPQ = 'C' or COMPU = 'C', the number of eigenvalues C in aS - bH with strictly negative real part. C C D (output) COMPLEX*16 array, dimension (LDD, N) C If COMPQ = 'C' or COMPU = 'C', the leading N-by-N part of C this array contains the matrix BD in (3) (see METHOD). C If COMPQ = 'N' and COMPU = 'N', this array is not C referenced. C C LDD INTEGER C The leading dimension of the array D. C LDD >= 1, if COMPQ = 'N' and COMPU = 'N'; C LDD >= MAX(1, N), if COMPQ = 'C' or COMPU = 'C'. C C C (output) COMPLEX*16 array, dimension (LDC, N) C If COMPQ = 'C' or COMPU = 'C', the leading N-by-N part of C this array contains the lower triangular matrix BC in (3) C (see also METHOD). The strictly upper triangular part is C not zeroed. C If COMPQ = 'N' and COMPU = 'N', this array is not C referenced. C C LDC INTEGER C The leading dimension of the array C. C LDC >= 1, if COMPQ = 'N' and COMPU = 'N'; C LDC >= MAX(1, N), if COMPQ = 'C' or COMPU = 'C'. C C Q (output) COMPLEX*16 array, dimension (LDQ, 2*N) C On exit, if COMPQ = 'C', the leading N-by-NEIG part of C this array contains an orthonormal basis of the right C deflating subspace corresponding to the eigenvalues of the C pencil aS - bH with strictly negative real part. C The remaining entries are meaningless. C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, 2*N), if COMPQ = 'C'. C C U (output) COMPLEX*16 array, dimension (LDU, 2*N) C On exit, if COMPU = 'C', the leading N-by-NEIG part of C this array contains an orthonormal basis of the companion C subspace corresponding to the eigenvalues of the C pencil aS - bH with strictly negative real part. The C remaining entries are meaningless. C If COMPU = 'N', this array is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= 1, if COMPU = 'N'; C LDU >= MAX(1, N), if COMPU = 'C'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The dimension of the array IWORK. LIWORK >= 2*N+9. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -26, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= c*N**2 + N + MAX(6*N, 27), where C c = 18, if COMPU = 'C'; C c = 16, if COMPQ = 'C' and COMPU = 'N'; C c = 13, if COMPQ = 'N' and COMPU = 'N'. C For good performance LDWORK should be generally 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 ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal LZWORK. C On exit, if INFO = -28, ZWORK(1) returns the minimum C value of LZWORK. C C LZWORK INTEGER C The dimension of the array ZWORK. C LZWORK >= 8*N + 28, if COMPQ = 'C'; C LZWORK >= 6*N + 28, if COMPQ = 'N' and COMPU = 'C'; C LZWORK >= 1, if COMPQ = 'N' and COMPU = 'N'. C For good performance LZWORK should be generally larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK C is issued by XERBLA. C C BWORK LOGICAL array, dimension (LBWORK) C LBWORK >= 0, if COMPQ = 'N' and COMPU = 'N'; C LBWORK >= N, if COMPQ = 'C' or COMPU = 'C'. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: the algorithm was not able to reveal information C about the eigenvalues from the 2-by-2 blocks in the C SLICOT Library routine MB03BD (called by MB04ED); C = 2: periodic QZ iteration failed in the SLICOT Library C routines MB03BD or MB03BZ when trying to C triangularize the 2-by-2 blocks; C = 3: the singular value decomposition failed in the LAPACK C routine ZGESVD (for ORTH = 'S'). C C METHOD C C First T = i*H is set. Then, the embeddings, B_Z and B_T, of the C matrices S and T, are determined and, subsequently, the SLICOT C Library routine MB04ED is applied to compute the structured Schur C form, i.e., the factorizations C C ~ ( BZ11 BZ12 ) C B_Z = U' B_Z Q = ( ) and C ( 0 BZ22 ) C C ~ ( T11 T12 ) C B_T = J Q' J' B_T Q = ( ), C ( 0 T11' ) C C where Q is real orthogonal, U is real orthogonal symplectic, BZ11, C BZ22' are upper triangular and T11 is upper quasi-triangular. C C Second, the SLICOT Library routine MB03IZ is applied, to compute a C ~ ~ C unitary matrix Q and a unitary symplectic matrix U, such that C C ~ ~ C ~ ~ ~ ( Z11 Z12 ) C U' B_Z Q = ( ~ ) =: B_Zout, C ( 0 Z22 ) C C ~ ~ ~ ( H11 H12 ) C J Q' J'(-i*B_T) Q = ( ) =: B_Hout, C ( 0 -H11' ) C ~ ~ C with Z11, Z22', H11 upper triangular, and such that the spectrum C C ~ ~ ~ C Spec_-(J B_Z' J' B_Z, -i*B_T) is contained in the spectrum of the C ~ ~ C 2*NEIG-by-2*NEIG leading principal subpencil aZ22'*Z11 - bH11. C C Finally, the right deflating subspace and the companion subspace C are computed. See also page 21 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C complex floating point operations. C C FURTHER COMMENTS C C This routine does not perform any scaling of the matrices. Scaling C might sometimes be useful, and it should be done externally. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, April 30, 2009 C V. Sima, Aug. 2009 (SLICOT version of the routine ZHAFDF). C C REVISIONS C V. Sima, Jan. 2011, Mar. 2011, Aug. 2011, Nov. 2011, July 2013, C Aug. 2014, Apr. 2020, May 2020. C M. Voigt, Jan. 2012. C C KEYWORDS C C Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian C pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) COMPLEX*16 CZERO, CONE, CIMAG PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ), $ CIMAG = ( 0.0D+0, 1.0D+0 ) ) C C .. Scalar Arguments .. CHARACTER COMPQ, COMPU, ORTH INTEGER INFO, LDB, LDC, LDD, LDFG, LDQ, LDU, LDWORK, $ LDZ, LIWORK, LZWORK, N, NEIG C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), DWORK( * ) COMPLEX*16 B( LDB, * ), C( LDC, * ), D( LDD, * ), $ FG( LDFG, * ), Q( LDQ, * ), U( LDU, * ), $ Z( LDZ, * ), ZWORK( * ) C C .. Local Scalars .. LOGICAL LCMP, LCMPQ, LCMPU, LQUERY, QR, QRP, SVD CHARACTER*14 CMPQ, CMPU, JOB INTEGER I, I1, IB, IEV, IFG, IQ, IQ2, IQB, IS, ITAU, $ IU, IUB, IW, IW1, IWRK, IZ11, IZ22, J, J1, J2, $ J3, JM1, JP2, M, MINDB, MINDW, MINZW, N2, NB, $ NC, NJ1, NN, OPTDW, OPTZW DOUBLE PRECISION EPS, NRMB, TOL COMPLEX*16 TMP C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C C .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DSCAL, MB03BZ, MB03IZ, MB04ED, $ XERBLA, ZAXPY, ZGEMM, ZGEQP3, ZGEQRF, ZGESVD, $ ZLACPY, ZSCAL, ZUNGQR C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, $ MIN, MOD, SQRT C C .. Executable Statements .. C C Decode the input arguments. C Using ORTH = 'Q' is not safe, but sometimes gives better results. C M = N/2 NN = N*N N2 = 2*N NEIG = 0 LCMPQ = LSAME( COMPQ, 'C' ) LCMPU = LSAME( COMPU, 'C' ) LCMP = LCMPQ .OR. LCMPU IF( LCMP ) THEN QR = LSAME( ORTH, 'Q' ) QRP = LSAME( ORTH, 'P' ) SVD = LSAME( ORTH, 'S' ) ELSE QR = .FALSE. QRP = .FALSE. SVD = .FALSE. END IF C IF( N.EQ.0 ) THEN MINDW = 1 MINZW = 1 ELSE IF( .NOT.LCMPU ) THEN I = 10 IF( .NOT.LCMPQ ) THEN J = 13 MINZW = 1 ELSE J = 16 MINZW = 4*N2 + 28 END IF ELSE I = 12 J = 18 IF( LCMPQ ) THEN MINZW = 4*N2 + 28 ELSE MINZW = 3*N2 + 28 END IF END IF MINDB = I*NN + N MINDW = J*NN + N + MAX( 3*N2, 27 ) END IF LQUERY = LDWORK.EQ.-1 .OR. LZWORK.EQ.-1 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) THEN INFO = -2 ELSE IF( LCMP .AND. .NOT. ( QR .OR. QRP .OR. SVD ) ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -4 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDFG.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDD.LT.1 .OR. ( LCMP .AND. LDD.LT.N ) ) THEN INFO = -13 ELSE IF( LDC.LT.1 .OR. ( LCMP .AND. LDC.LT.N ) ) THEN INFO = -15 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N2 ) ) THEN INFO = -17 ELSE IF( LDU.LT.1 .OR. ( LCMPU .AND. LDU.LT.N ) ) THEN INFO = -19 ELSE IF( LIWORK.LT.N2+9 ) THEN INFO = -24 ELSE IF( .NOT. LQUERY ) THEN IF( LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -26 ELSE IF( LZWORK.LT.MINZW ) THEN ZWORK( 1 ) = MINZW INFO = -28 END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03FZ', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN C C Compute optimal workspace. C IF( LCMPQ ) THEN CMPQ = 'Initialize' ELSE CMPQ = 'No Computation' END IF C IF( LCMPU ) THEN CMPU = 'Initialize' ELSE CMPU = 'No Computation' END IF C IF( LCMP ) THEN JOB = 'Triangularize' CALL ZGEQRF( N, N, Z, LDZ, ZWORK, ZWORK, -1, INFO ) I = INT( ZWORK( 1 ) ) NB = MAX( I/N, 2 ) ELSE JOB = 'Eigenvalues' END IF C IF( LQUERY ) THEN CALL MB04ED( JOB, CMPQ, CMPU, N2, DWORK, N2, DWORK, N, $ DWORK, N, DWORK, N2, DWORK, N, DWORK, N, $ ALPHAI, ALPHAR, BETA, IWORK, LIWORK, DWORK, $ -1, INFO ) OPTDW = MAX( MINDW, MINDB + INT( DWORK( 1 ) ) ) C IF( LCMP ) THEN IF( SVD ) THEN CALL ZGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, ZWORK, 1, $ ZWORK, 1, ZWORK, -1, DWORK, INFO ) J = INT( ZWORK( 1 ) ) ELSE IF( QR ) THEN J = M CALL ZGEQRF( N, J, Q, LDQ, ZWORK, ZWORK, -1, INFO ) ELSE J = N CALL ZGEQP3( N, J, Q, LDQ, IWORK, ZWORK, ZWORK, -1, $ DWORK, INFO ) END IF CALL ZUNGQR( N, J, J, Q, LDQ, ZWORK, ZWORK( 2 ), -1, $ INFO ) J = J + MAX( INT( ZWORK( 1 ) ), INT( ZWORK( 2 ) ) ) END IF OPTZW = MAX( MINZW, I, J ) ELSE OPTZW = MINZW END IF DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW RETURN ELSE OPTZW = MINZW END IF END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK( 1 ) = ONE ZWORK( 1 ) = CONE RETURN END IF C C Determine machine constants. C EPS = DLAMCH( 'Precision' ) TOL = SQRT( EPS ) C C Set up the embeddings of the matrices Z and H. C Real workspace: need w1, where C w1 = 12*N**2+N, if COMPU = 'C'; C w1 = 10*N**2+N, if COMPU = 'N'. C IQ = 1 IF( LCMPU ) THEN IU = IQ + N2*N2 IZ11 = IU + N2*N ELSE IU = 1 IZ11 = IQ + N2*N2 END IF IB = IZ11 + N2*N2 IFG = IB + NN IWRK = IFG + NN + N C C Build the embedding of Z. C IW = IZ11 IS = IW + N2*M DO 50 J = 1, N IW1 = IW DO 10 I = 1, M DWORK( IW ) = DBLE( Z( I, J ) ) IW = IW + 1 10 CONTINUE C DO 20 I = 1, M DWORK( IW ) = DIMAG( Z( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 20 CONTINUE CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IW1 = IW IS = IS + M C DO 30 I = M + 1, N DWORK( IW ) = DBLE( Z( I, J ) ) IW = IW + 1 30 CONTINUE C DO 40 I = M + 1, N DWORK( IW ) = DIMAG( Z( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 40 CONTINUE C CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IW1 = IW IS = IS + M IF( MOD( J, M ).EQ.0 ) THEN IW = IW + N2*M IS = IS + N2*M END IF 50 CONTINUE C C Build the embedding of B. C IW = IB IS = IW + N*M DO 80 J = 1, M IW1 = IW DO 60 I = 1, M DWORK( IW ) = -DIMAG( B( I, J ) ) IW = IW + 1 60 CONTINUE C DO 70 I = 1, M DWORK( IW ) = DBLE( B( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 70 CONTINUE CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IS = IS + M 80 CONTINUE C C Build the embeddings of F and G. C IW = IFG DO 110 J = 1, M + 1 DO 90 I = 1, M DWORK( IW ) = -DIMAG( FG( I, J ) ) IW = IW + 1 90 CONTINUE C IW = IW + J - 1 IS = IW DO 100 I = J, M DWORK( IW ) = DBLE( FG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 100 CONTINUE 110 CONTINUE C IW1 = IW I1 = IW DO 130 J = 2, M + 1 IS = I1 I1 = I1 + 1 DO 120 I = 1, J - 1 DWORK( IW ) = -DBLE( FG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 120 CONTINUE IW = IW + N - J + 1 130 CONTINUE CALL DLACPY( 'Full', M, M+1, DWORK( IFG ), N, DWORK( IW1-M ), N ) C C STEP 1: Apply MB04ED to transform the extended pencil to real C skew-Hamiltonian/skew-Hamiltonian Schur form. C C Real workspace: need w1 + w2, where C w2 = 6*N**2+MAX(6*N, 27), C if COMPQ = 'C' or COMPU = 'C'; C w2 = 3*N**2+MAX(6*N, 27), C if COMPQ = 'N' and COMPU = 'N'; C prefer larger. C Integer workspace: need 2*N+9. C CALL MB04ED( JOB, CMPQ, CMPU, N2, DWORK( IZ11 ), N2, DWORK( IB ), $ N, DWORK( IFG ), N, DWORK( IQ ), N2, DWORK( IU ), N, $ DWORK( IU+NN ), N, ALPHAI, ALPHAR, BETA, IWORK, $ LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 .AND. INFO.LT.3 ) $ RETURN OPTDW = MAX( MINDW, MINDB + INT( DWORK( IWRK ) ) ) C C Information about possibly inaccurate eigenvalues is not used. C Scale the eigenvalues. C CALL DSCAL( N, -ONE, ALPHAI, 1 ) C C Return if only the eigenvalues are desired. C IF( .NOT.LCMP ) THEN DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW RETURN END IF C C Convert the results to complex datatype. C IW = IZ11 DO 150 J = 1, N DO 140 I = 1, J Z( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 140 CONTINUE IW = IW + N2 - J 150 CONTINUE C IW = IZ11 + N2*N DO 180 J = 1, N DO 160 I = 1, N D( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 160 CONTINUE IW = IW + J - 1 C DO 170 I = J, N C( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 170 CONTINUE 180 CONTINUE C IW = IB DO 200 J = 1, N DO 190 I = 1, MIN( J + 1, N ) B( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 190 CONTINUE IW = IW + N - J - 1 200 CONTINUE C IW = IFG + N DO 220 J = 1, N DO 210 I = 1, J - 1 FG( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 210 CONTINUE FG( J, J ) = CZERO IW = IW + N - J + 1 220 CONTINUE C IF( LCMPQ ) THEN IW = IQ DO 240 J = 1, N2 DO 230 I = 1, N2 Q( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 230 CONTINUE 240 CONTINUE END IF C IF( LCMPU ) THEN IW = IU DO 260 J = 1, N2 DO 250 I = 1, N U( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 250 CONTINUE 260 CONTINUE END IF C C Triangularize the 2-by-2 diagonal blocks in B using the complex C version of the periodic QZ algorithm. C C Set up pointers on the inputs and outputs of MB03BZ. C A block algorithm is used for updating the matrices for large N. C IQ2 = 1 IQ = IQ2 + 4 IU = IQ + 4 IB = IU + 4 IZ11 = IB + 4 IZ22 = IZ11 + 4 IEV = IZ22 + 4 IQB = IEV + 4 IUB = IQB + 4*M IWRK = IUB + 4*M C C Set the signatures of the input matrices of MB03BZ. C IWORK( 1 ) = 1 IWORK( 2 ) = -1 IWORK( 3 ) = -1 C J = 1 J1 = 1 J2 = MIN( N, NB ) C WHILE( J.LT.N ) DO 270 CONTINUE IF( J.LT.N ) THEN NRMB = ABS( B( J, J ) ) + ABS( B( J+1, J+1 ) ) IF( ABS( B( J+1, J ) ).GT.NRMB*EPS ) THEN C C Triangularization step. Row transformations are blocked. C Workspace: need 8*N + 28, if COMPQ = 'C'; C 6*N + 28, if COMPQ = 'N'. C Real workspace: need 2. C Integer workspace: need 5. C NC = MAX( J2-J-1, 0 ) J3 = MIN( J2-J1+1, J-1 ) JM1 = MAX( J-1, 1 ) JP2 = MIN( J+2, N ) NJ1 = MAX( N-J-1, 1 ) CALL ZLACPY( 'Full', 2, 2, B( J, J ), LDB, ZWORK( IB ), 2 ) CALL ZLACPY( 'Upper', 2, 2, Z( J, J ), LDZ, ZWORK( IZ11 ), $ 2 ) ZWORK( IZ11+1 ) = CZERO ZWORK( IZ22 ) = DCONJG( C( J, J ) ) ZWORK( IZ22+1 ) = CZERO ZWORK( IZ22+2 ) = DCONJG( C( J+1, J ) ) ZWORK( IZ22+3 ) = DCONJG( C( J+1, J+1 ) ) C CALL MB03BZ( 'Schur form', 'Initialize', 3, 2, 1, 2, IWORK, $ ZWORK( IB ), 2, 2, ZWORK( IQ2 ), 2, 2, $ ZWORK( IEV ), ZWORK( IEV+2 ), IWORK( 4 ), $ DWORK, LDWORK, ZWORK( IWRK ), LZWORK-IWRK+1, $ INFO ) IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Update a panel of Z. C CALL ZGEMM( 'No Transpose', 'No Transpose', J-1, 2, 2, $ CONE, Z( 1, J ), LDZ, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), JM1 ) CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, Z( 1, J ), $ LDZ ) CALL ZLACPY( 'Upper', 2, 2, ZWORK( IZ11 ), 2, Z( J, J ), $ LDZ ) Z( J+1, J ) = CZERO CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, NC, $ 2, CONE, ZWORK( IU ), 2, Z( J, JP2 ), LDZ, $ CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, Z( J, JP2 ), $ LDZ ) C C Update the columns J and J+1 of D. C The transformations on rows are made outside this loop. C CALL ZGEMM( 'No Transpose', 'No Transpose', N, 2, 2, CONE, $ D( 1, J ), LDD, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), N ) CALL ZLACPY( 'Full', N, 2, ZWORK( IWRK ), N, D( 1, J ), $ LDD ) C C Similarly, update C. C C( J, J ) = DCONJG( ZWORK( IZ22 ) ) C( J+1, J ) = DCONJG( ZWORK( IZ22+2 ) ) C( J, J+1 ) = CZERO C( J+1, J+1 ) = DCONJG( ZWORK( IZ22+3 ) ) CALL ZGEMM( 'No Transpose', 'No Transpose', N-J-1, 2, 2, $ CONE, C( JP2, J ), LDC, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), NJ1 ) CALL ZLACPY( 'Full', N-J-1, 2, ZWORK( IWRK ), NJ1, $ C( JP2, J ), LDC ) C C Update a panel of B. C CALL ZGEMM( 'No Transpose', 'No Transpose', J-1, 2, 2, $ CONE, B( 1, J ), LDB, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), JM1 ) CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, B( 1, J ), $ LDB ) CALL ZLACPY( 'Upper', 2, 2, ZWORK( IB ), 2, B( J, J ), $ LDB ) B( J+1, J ) = CZERO CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, NC, $ 2, CONE, ZWORK( IQ2 ), 2, B( J, JP2 ), LDB, $ CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, B( J, JP2 ), $ LDB ) C C Update a panel of F. C TMP = FG( J+1, J ) FG( J+1, J ) = -FG( J, J+1 ) CALL ZGEMM( 'No Transpose', 'No Transpose', J+1, 2, 2, $ CONE, FG( 1, J ), LDFG, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), J+1 ) CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, FG( 1, J ), $ LDFG ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ J2-J+1, 2, CONE, ZWORK( IQ2 ), 2, FG( J, J ), $ LDFG, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2, $ FG( J, J ), LDFG ) FG( J+1, J ) = TMP C IF( LCMPQ ) THEN C C Update Q. C CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, $ CONE, Q( 1, J ), LDQ, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, $ Q( 1, J ), LDQ ) CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, $ CONE, Q( 1, N+J ), LDQ, ZWORK( IQ2 ), 2, $ CZERO, ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, $ Q( 1, N+J ), LDQ ) END IF C IF( LCMPU ) THEN C C Update U. C CALL ZGEMM( 'No Transpose', 'No Transpose', N, 2, 2, $ CONE, U( 1, J ), LDU, ZWORK( IU ), 2, CZERO, $ ZWORK( IWRK ), N ) CALL ZLACPY( 'Full', N, 2, ZWORK( IWRK ), N, U( 1, J ), $ LDU ) CALL ZGEMM( 'No Transpose', 'No Transpose', N, 2, 2, $ CONE, U( 1, N+J ), LDU, ZWORK( IU ), 2, $ CZERO, ZWORK( IWRK ), N ) CALL ZLACPY( 'Full', N, 2, ZWORK( IWRK ), N, U( 1, N+J ), $ LDU ) END IF C C Save the needed transformations. C BWORK( J ) = .TRUE. J = J + 2 CALL ZLACPY( 'Full', 2, 2, ZWORK( IQ2 ), 2, ZWORK( IQB ), $ 2 ) CALL ZLACPY( 'Full', 2, 2, ZWORK( IU ), 2, ZWORK( IUB ), 2 ) IQB = IQB + 4 IUB = IUB + 4 ELSE BWORK( J ) = .FALSE. B( J+1, J ) = CZERO J = J + 1 END IF C IF( J.GE.J2 .AND. J.LE.N ) THEN IQB = IEV + 4 IUB = IQB + 4*M C C Start to update the next panel of Z, B, and F for previous C transformations on rows. C I = 1 J1 = J2 + 1 J2 = MIN( N, J1 + NB - 1 ) NC = J2 - J1 + 1 C WHILE( I.LT.J-1 ) DO 280 CONTINUE IF( I.LT.J-1 ) THEN IF( BWORK( I ) ) THEN CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IUB ), 2, Z( I, J1 ), $ LDZ, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ Z( I, J1 ), LDZ ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, B( I, J1 ), $ LDB, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ B( I, J1 ), LDB ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, $ FG( I, J1 ), LDFG, CZERO, ZWORK( IWRK ), $ 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ FG( I, J1 ), LDFG ) IQB = IQB + 4 IUB = IUB + 4 C I = I + 2 ELSE I = I + 1 END IF GO TO 280 END IF C END WHILE 280 END IF GO TO 270 END IF C END WHILE 270 C J1 = 1 J2 = MIN( N, NB ) C WHILE( MAX( J1, J2 ).LE.N ) DO 290 CONTINUE IF( MAX( J1, J2 ).LE.N ) THEN IQB = IEV + 4 IUB = IQB + 4*M C C Update the panel of columns J1 to J2 of D and C for the C transformations on rows. C I = 1 NC = J2 - J1 + 1 C WHILE( I.LT.N ) DO 300 CONTINUE IF( I.LT.N ) THEN IF( BWORK( I ) ) THEN CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IUB ), 2, D( I, J1 ), $ LDD, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, D( I, J1 ), $ LDD ) C IF( I.GT.J1 ) THEN J3 = MIN( NC, I - J1 ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ J3, 2, CONE, ZWORK( IUB ), 2, C( I, J1 ), $ LDC, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, J3, ZWORK( IWRK ), 2, $ C( I, J1 ), LDC ) END IF C IQB = IQB + 4 IUB = IUB + 4 C I = I + 2 ELSE I = I + 1 END IF GO TO 300 END IF C END WHILE 300 J1 = J2 + 1 J2 = MIN( N, J1 + NB - 1 ) GO TO 290 C END WHILE 290 END IF C C Scale B and F by -i. C DO 310 I = 1, N CALL ZSCAL( I, -CIMAG, B( 1, I ), 1 ) 310 CONTINUE C DO 320 I = 1, N CALL ZSCAL( I, -CIMAG, FG( 1, I ), 1 ) 320 CONTINUE C C STEP 2: Apply MB03IZ to reorder the eigenvalues with strictly C negative real part to the top. C C Determine mode of computation. C IF( LCMPQ ) $ CMPQ = 'Update' IF( LCMPU ) $ CMPU = 'Update' C CALL MB03IZ( CMPQ, CMPU, N2, Z, LDZ, C, LDC, D, LDD, B, LDB, FG, $ LDFG, Q, LDQ, U, LDU, U( 1, N+1 ), LDU, NEIG, TOL, $ INFO ) C IF( QR ) $ NEIG = NEIG/2 ITAU = 1 IWRK = NEIG + 1 C IF( LCMPQ ) THEN C C STEP 3: Compute the right deflating subspace corresponding to C the eigenvalues with strictly negative real part. C IF( NEIG.LE.M ) THEN DO 330 I = 1, NEIG CALL ZAXPY( M, CIMAG, Q( M+1, I ), 1, Q( 1, I ), 1 ) 330 CONTINUE CALL ZLACPY( 'Full', M, NEIG, Q( N+1, 1 ), LDQ, Q( M+1, 1 ), $ LDQ ) DO 340 I = 1, NEIG CALL ZAXPY( M, CIMAG, Q( M+N+1, I ), 1, Q( M+1, I ), 1 ) 340 CONTINUE ELSE DO 350 I = 1, M CALL ZAXPY( M, CIMAG, Q( M+1, I ), 1, Q( 1, I ), 1 ) 350 CONTINUE CALL ZLACPY( 'Full', M, M, Q( N+1, 1 ), LDQ, Q( M+1, 1 ), $ LDQ ) DO 360 I = 1, M CALL ZAXPY( M, CIMAG, Q( M+N+1, I ), 1, Q( M+1, I ), 1 ) 360 CONTINUE C DO 370 I = 1, NEIG - M CALL ZAXPY( M, CIMAG, Q( M+1, M+I ), 1, Q( 1, M+I ), 1 ) 370 CONTINUE CALL ZLACPY( 'Full', M, NEIG-M, Q( N+1, M+1 ), LDQ, $ Q( M+1, M+1 ), LDQ ) DO 380 I = 1, NEIG - M CALL ZAXPY( M, CIMAG, Q( M+N+1, M+I ), 1, Q( M+1, M+I ), $ 1 ) 380 CONTINUE END IF C C Orthogonalize the basis given in Q(1:n,1:neig). C IF( SVD ) THEN C C Workspace: need 3*N; C prefer larger. C Real workspace: need 6*N. C CALL ZGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK, $ ZWORK, 1, ZWORK, 1, ZWORK, LZWORK, $ DWORK( IWRK ), INFO ) IF( INFO.GT.0 ) THEN INFO = 3 RETURN END IF OPTZW = MAX( OPTZW, INT( ZWORK( 1 ) ) ) IF( .NOT.LCMPU ) $ NEIG = NEIG/2 C ELSE IF( QR ) THEN C C Workspace: need N; C prefer M+M*NB, where NB is the optimal C blocksize. C CALL ZGEQRF( N, NEIG, Q, LDQ, ZWORK( ITAU ), $ ZWORK( IWRK ), LZWORK-IWRK+1, INFO ) ELSE C C Workspace: need 2*N+1; C prefer N+(N+1)*NB. C Real workspace: need 2*N. C DO 390 J = 1, NEIG IWORK( J ) = 0 390 CONTINUE CALL ZGEQP3( N, NEIG, Q, LDQ, IWORK, ZWORK, $ ZWORK( IWRK ), LZWORK-IWRK+1, DWORK, INFO ) END IF OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 ) C C Workspace: need 2*N; C prefer N+N*NB. C CALL ZUNGQR( N, NEIG, NEIG, Q, LDQ, ZWORK( ITAU ), $ ZWORK( IWRK ), LZWORK-IWRK+1, INFO ) OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 ) IF( QRP .AND. .NOT.LCMPU ) $ NEIG = NEIG/2 END IF END IF C IF( LCMPU ) THEN C C STEP 4: Compute the companion subspace corresponding to the C eigenvalues with strictly negative real part. C IF( NEIG.LE.M ) THEN DO 400 I = 1, NEIG CALL ZAXPY( M, CIMAG, U( M+1, I ), 1, U( 1, I ), 1 ) 400 CONTINUE CALL ZLACPY( 'Full', M, NEIG, U( 1, N+1 ), LDU, U( M+1, 1 ), $ LDU ) DO 410 I = 1, NEIG CALL ZAXPY( M, CIMAG, U( M+1, N+I ), 1, U( M+1, I ), 1 ) 410 CONTINUE ELSE DO 420 I = 1, M CALL ZAXPY( M, CIMAG, U( M+1, I ), 1, U( 1, I ), 1 ) 420 CONTINUE CALL ZLACPY( 'Full', M, NEIG, U( 1, N+1 ), LDU, U( M+1, 1 ), $ LDU ) DO 430 I = 1, M CALL ZAXPY( M, CIMAG, U( M+1, N+I ), 1, U( M+1, I ), 1 ) 430 CONTINUE C DO 440 I = 1, NEIG - M CALL ZAXPY( M, CIMAG, U( M+1, M+I ), 1, U( 1, M+I ), 1 ) 440 CONTINUE CALL ZLACPY( 'Full', M, NEIG-M, U( 1, N+M+1 ), LDU, $ U( M+1, M+1 ), LDU ) DO 450 I = 1, NEIG - M CALL ZAXPY( M, CIMAG, U( M+1, N+M+I ), 1, U( M+1, M+I ), $ 1 ) 450 CONTINUE END IF DO 470 J = 1, NEIG DO 460 I = M + 1, N U( I, J ) = -U( I, J ) 460 CONTINUE 470 CONTINUE C C Orthogonalize the basis given in U(1:n,1:neig). C IF( SVD ) THEN C C Workspace: need 3*N; C prefer larger. C Real workspace: need 6*N. C CALL ZGESVD( 'Overwrite', 'No V', N, NEIG, U, LDU, DWORK, $ ZWORK, 1, ZWORK, 1, ZWORK, LZWORK, $ DWORK( IWRK ), INFO ) IF( INFO.GT.0 ) THEN INFO = 3 RETURN END IF OPTZW = MAX( OPTZW, INT( ZWORK( 1 ) ) ) NEIG = NEIG/2 C ELSE IF( QR ) THEN C C Workspace: need N; C prefer M+M*NB, where NB is the optimal C blocksize. C CALL ZGEQRF( N, NEIG, U, LDU, ZWORK( ITAU ), $ ZWORK( IWRK ), LZWORK-IWRK+1, INFO ) ELSE C C Workspace: need 2*N+1; C prefer N+(N+1)*NB. C Real workspace: need 2*N. C DO 480 J = 1, NEIG IWORK( J ) = 0 480 CONTINUE CALL ZGEQP3( N, NEIG, U, LDU, IWORK, ZWORK, $ ZWORK( IWRK ), LZWORK-IWRK+1, DWORK, INFO ) END IF OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 ) C C Workspace: need 2*N; C prefer N+N*NB. C CALL ZUNGQR( N, NEIG, NEIG, U, LDU, ZWORK( ITAU ), $ ZWORK( IWRK ), LZWORK-IWRK+1, INFO ) OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 ) IF( QRP ) $ NEIG = NEIG/2 END IF END IF C DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW C *** Last line of MB03FZ *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09ND.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB09ND.f0000644000175000017500000004231115012430707017347 0ustar00lilgelilge00000000000000 SUBROUTINE AB09ND( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, $ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1, $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for an original C state-space representation (A,B,C,D) by using either the C square-root or the balancing-free square-root Singular C Perturbation Approximation (SPA) model reduction method for the C ALPHA-stable part of the system. 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 JOB CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root SPA method; C = 'N': use the balancing-free square-root SPA method. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of the C resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. For a system with NU ALPHA-unstable C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), C NR is set as follows: if ORDSEL = 'F', NR is equal to C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order C on entry, and NMIN is the order of a minimal realization C of the ALPHA-stable part of the given system; NMIN is C determined as the number of Hankel singular values greater C than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine C precision (see LAPACK Library Routine DLAMCH) and C HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable C part of the given system (computed in HSV(1)); C if ORDSEL = 'A', NR is the sum of NU and the number of C Hankel singular values greater than C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). C C ALPHA (input) DOUBLE PRECISION C Specifies the ALPHA-stability boundary for the eigenvalues C of the state dynamics matrix A. For a continuous-time C system (DICO = 'C'), ALPHA <= 0 is the boundary value for C the real parts of eigenvalues, while for a discrete-time C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the C boundary value for the moduli of eigenvalues. C The ALPHA-stability domain does not include the boundary. 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, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the reduced C order system. C The resulting A has a block-diagonal form with two blocks. C For a system with NU ALPHA-unstable eigenvalues and C NS ALPHA-stable eigenvalues (NU+NS = N), the leading C NU-by-NU block contains the unreduced part of A C corresponding to ALPHA-unstable eigenvalues in an C upper real Schur form. C The trailing (NR+NS-N)-by-(NR+NS-N) block contains C the reduced part of A corresponding to ALPHA-stable C eigenvalues. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C NS (output) INTEGER C The dimension of the ALPHA-stable subsystem. C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, the leading NS elements of HSV contain the C Hankel singular values of the ALPHA-stable part of the C original system ordered decreasingly. C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the C Hankel-norm of the ALPHA-stable part of the given system C (computed in HSV(1)). C If TOL1 <= 0 on entry, the used default value is C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of C ALPHA-stable eigenvalues of A and EPS is the machine C precision (see LAPACK Library Routine DLAMCH). C This value is appropriate to compute a minimal realization C of the ALPHA-stable part. C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the ALPHA-stable part of the given system. C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). C This value is used by default if TOL2 <= 0 on entry. C If TOL2 > 0, then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension (MAX(1,2*N)) C On exit, if INFO = 0, IWORK(1) contains the order of the C minimal realization of the ALPHA-stable part of the C system. 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,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than NSMIN, the sum of the order of the C ALPHA-unstable part and the order of a minimal C realization of the ALPHA-stable part of the given C system. In this case, the resulting NR is set equal C to NSMIN. C = 2: with ORDSEL = 'F', the selected order NR is less C than the order of the ALPHA-unstable part of the C given system. In this case NR is set equal to the C order of the ALPHA-unstable part. 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 computation of the ordered real Schur form of A C failed; C = 2: the separation of the ALPHA-stable/unstable diagonal C blocks failed because of very close eigenvalues; C = 3: the computation of Hankel singular values failed. C C METHOD C C Let be the following linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09ND determines for C the given system (1), the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t) (2) C C such that C C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], C C where G and Gr are transfer-function matrices of the systems C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the C infinity-norm of G. C C The following procedure is used to reduce a given G: C C 1) Decompose additively G as C C G = G1 + G2 C C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and C G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles. C C 2) Determine G1r, a reduced order approximation of the C ALPHA-stable part G1. C C 3) Assemble the reduced model Gr as C C Gr = G1r + G2. C C To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root C balancing-based SPA method of [1] is used, and for an ALPHA-stable C system, the resulting reduced model is balanced. C C If JOB = 'N', the balancing-free square-root SPA method of [2] C is used to reduce the ALPHA-stable part G1. C By setting TOL1 = TOL2, the routine can be used to compute C Balance & Truncate approximations as well. C C REFERENCES C C [1] Liu Y. and Anderson B.D.O. C Singular Perturbation Approximation of Balanced Systems, C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. C C [2] Varga A. C Balancing-free square-root algorithm for computing C singular perturbation approximations. C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, C Vol. 2, pp. 1062-1065. C C NUMERICAL ASPECTS C C The implemented methods rely on accuracy enhancing square-root or C balancing-free square-root techniques. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C February 1999. Based on the RASP routines SADSDC and SRBFSP. C C REVISIONS C C Mar. 1999, V. Sima, Research Institute for Informatics, Bucharest. C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. C C KEYWORDS C C Balancing, minimal realization, model reduction, multivariable C system, singular perturbation approximation, state-space model, C state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, C100 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, JOB, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, $ M, N, NR, NS, P DOUBLE PRECISION ALPHA, TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), HSV(*) C .. Local Scalars .. LOGICAL DISCR, FIXORD INTEGER IERR, IWARNL, KT, KTI, KU, KW, KWI, KWR, LWR, $ NN, NRA, NU, NU1, WRKOPT DOUBLE PRECISION ALPWRK, MAXRED C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB09BX, TB01ID, TB01KD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) FIXORD = LSAME( ORDSEL, 'F' ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -3 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) 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( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -8 ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN INFO = -9 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -17 ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN INFO = -21 ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + $ ( N*( N + 1 ) )/2 ) ) THEN INFO = -24 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09ND', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 IWORK(1) = 0 DWORK(1) = ONE RETURN END IF C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C Workspace: N. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Correct the value of ALPHA to ensure stability. C ALPWRK = ALPHA IF( DISCR ) THEN IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) ELSE IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) END IF C C Allocate working storage. C NN = N*N KU = 1 KWR = KU + NN KWI = KWR + N KW = KWI + N LWR = LDWORK - KW + 1 C C Reduce A to a block-diagonal real Schur form, with the C ALPHA-unstable part in the leading diagonal position, using a C non-orthogonal similarity transformation A <- inv(T)*A*T and C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. C C Workspace needed: N*(N+2); C Additional workspace: need 3*N; C prefer larger. C CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), $ DWORK(KWI), DWORK(KW), LWR, IERR ) C IF( IERR.NE.0 ) THEN IF( IERR.NE.3 ) THEN INFO = 1 ELSE INFO = 2 END IF RETURN END IF C WRKOPT = DWORK(KW) + DBLE( KW-1 ) C IWARNL = 0 NS = N - NU IF( FIXORD ) THEN NRA = MAX( 0, NR-NU ) IF( NR.LT.NU ) $ IWARNL = 2 ELSE NRA = 0 END IF C C Finish if only unstable part is present. C IF( NS.EQ.0 ) THEN NR = NU IWORK(1) = 0 DWORK(1) = WRKOPT RETURN END IF C NU1 = NU + 1 C C Allocate working storage. C KT = 1 KTI = KT + NN KW = KTI + NN C C Compute a SPA of the stable part. C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; C prefer larger. C CALL AB09BX( DICO, JOB, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, $ DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, IWORK, $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) IWARN = MAX( IWARN, IWARNL ) C IF( IERR.NE.0 ) THEN INFO = IERR + 1 RETURN END IF C NR = NRA + NU C DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C RETURN C *** Last line of AB09ND *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03OR.f0000644000000000000000000000013215012430707016205 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03OR.f0000644000175000017500000003214515012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE SB03OR( DISCR, LTRANS, N, M, S, LDS, A, LDA, C, LDC, $ SCALE, INFO ) C C PURPOSE C C To compute the solution of the Sylvester equations C C op(S)'*X + X*op(A) = scale*C, if DISCR = .FALSE. or C C op(S)'*X*op(A) - X = scale*C, if DISCR = .TRUE. C C where op(K) = K or K' (i.e., the transpose of the matrix K), S is C an N-by-N block upper triangular matrix with one-by-one and C two-by-two blocks on the diagonal, A is an M-by-M matrix (M = 1 or C M = 2), X and C are each N-by-M matrices, and scale is an output C scale factor, set less than or equal to 1 to avoid overflow in X. C The solution X is overwritten on C. C C SB03OR is a service routine for the Lyapunov solver SB03OT. C C ARGUMENTS C C Mode Parameters C C DISCR LOGICAL C Specifies the equation to be solved: C = .FALSE.: op(S)'*X + X*op(A) = scale*C; C = .TRUE. : op(S)'*X*op(A) - X = scale*C. C C LTRANS LOGICAL C Specifies the form of op(K) to be used, as follows: C = .FALSE.: op(K) = K (No transpose); C = .TRUE. : op(K) = K**T (Transpose). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix S and also the number of rows of C matrices X and C. N >= 0. C C M (input) INTEGER C The order of the matrix A and also the number of columns C of matrices X and C. M = 1 or M = 2. C C S (input) DOUBLE PRECISION array, dimension (LDS,N) C The leading N-by-N upper Hessenberg part of the array S C must contain the block upper triangular matrix. The C elements below the upper Hessenberg part of the array S C are not referenced. The array S must not contain C diagonal blocks larger than two-by-two and the two-by-two C blocks must only correspond to complex conjugate pairs of C eigenvalues, not to real eigenvalues. C C LDS INTEGER C The leading dimension of array S. LDS >= MAX(1,N). C C A (input) DOUBLE PRECISION array, dimension (LDS,M) C The leading M-by-M part of this array must contain a C given matrix, where M = 1 or M = 2. C C LDA INTEGER C The leading dimension of array A. LDA >= M. C C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) C On entry, C must contain an N-by-M matrix, where M = 1 or C M = 2. C On exit, C contains the N-by-M matrix X, the solution of C the Sylvester equation. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,N). 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 Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if DISCR = .FALSE., and S and -A have common C eigenvalues, or if DISCR = .TRUE., and S and A have C eigenvalues whose product is equal to unity; C a solution has been computed using slightly C perturbed values. C C METHOD C C The LAPACK scheme for solving Sylvester equations is adapted. C C REFERENCES C C [1] 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 2 C The algorithm requires 0(N M) operations and is backward stable. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. C Supersedes Release 2.0 routines SB03CW and SB03CX by C Sven Hammarling, NAG Ltd, United Kingdom, Oct. 1986. C Partly based on routine PLYAP4 by A. Varga, University of Bochum, C May 1992. C C REVISIONS C C December 1997, April 1998, May 1999, April 2000. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. Scalar Arguments .. LOGICAL DISCR, LTRANS INTEGER INFO, LDA, LDS, LDC, M, N DOUBLE PRECISION SCALE C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), S( LDS, * ) C .. Local Scalars .. LOGICAL TBYT INTEGER DL, INFOM, ISGN, J, L, L1, L2, L2P1, LNEXT DOUBLE PRECISION G11, G12, G21, G22, SCALOC, XNORM C .. C .. Local Arrays .. DOUBLE PRECISION AT( 2, 2 ), VEC( 2, 2 ), X( 2, 2 ) C .. C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. C .. External Subroutines .. EXTERNAL DLASY2, DSCAL, SB04PX, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C IF( N.LT.0 ) THEN INFO = -3 ELSE IF( .NOT.( M.EQ.1 .OR. M.EQ.2 ) ) THEN INFO = -4 ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDA.LT.M ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, N ) ) THEN INFO = -10 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB03OR', -INFO ) RETURN END IF C SCALE = ONE C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C ISGN = 1 TBYT = M.EQ.2 INFOM = 0 C C Construct A'. C AT(1,1) = A(1,1) IF ( TBYT ) THEN AT(1,2) = A(2,1) AT(2,1) = A(1,2) AT(2,2) = A(2,2) END IF C IF ( LTRANS ) THEN C C Start row loop (index = L). C L1 (L2) : row index of the first (last) row of X(L). C LNEXT = N C DO 20 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 20 L1 = L L2 = L IF( L.GT.1 ) THEN IF( S( L, L-1 ).NE.ZERO ) $ L1 = L1 - 1 LNEXT = L1 - 1 END IF DL = L2 - L1 + 1 L2P1 = MIN( L2+1, N ) C IF ( DISCR ) THEN C C Solve S*X*A' - X = scale*C. C C The L-th block of X is determined from C C S(L,L)*X(L)*A' - X(L) = C(L) - R(L), C C where C C N C R(L) = SUM [S(L,J)*X(J)] * A' . C J=L+1 C G11 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 1 ), 1 ) IF ( TBYT ) THEN G12 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 2 ), $ 1 ) VEC( 1, 1 ) = C( L1, 1 ) + G11*AT(1,1) + G12*AT(2,1) VEC( 1, 2 ) = C( L1, 2 ) + G11*AT(1,2) + G12*AT(2,2) ELSE VEC (1, 1 ) = C( L1, 1 ) + G11*AT(1,1) END IF IF ( DL.NE.1 ) THEN G21 = -DDOT( N-L2, S( L2, L2P1 ), LDS, C( L2P1, 1 ), $ 1 ) IF ( TBYT ) THEN G22 = -DDOT( N-L2, S( L2, L2P1 ), LDS, $ C( L2P1, 2 ), 1 ) VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) + $ G22*AT(2,1) VEC( 2, 2 ) = C( L2, 2 ) + G21*AT(1,2) + $ G22*AT(2,2) ELSE VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) END IF END IF CALL SB04PX( .FALSE., .FALSE., -ISGN, DL, M, S( L1, L1 ), $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, $ INFO ) ELSE C C Solve S*X + X*A' = scale*C. C C The L-th block of X is determined from C C S(L,L)*X(L) + X(L)*A' = C(L) - R(L), C C where C N C R(L) = SUM S(L,J)*X(J) . C J=L+1 C VEC( 1, 1 ) = C( L1, 1 ) - $ DDOT( N-L2, S( L1, L2P1 ), LDS, $ C( L2P1, 1 ), 1 ) IF ( TBYT ) $ VEC( 1, 2 ) = C( L1, 2 ) - $ DDOT( N-L2, S( L1, L2P1 ), LDS, $ C( L2P1, 2 ), 1 ) C IF ( DL.NE.1 ) THEN VEC( 2, 1 ) = C( L2, 1 ) - $ DDOT( N-L2, S( L2, L2P1 ), LDS, $ C( L2P1, 1 ), 1 ) IF ( TBYT ) $ VEC( 2, 2 ) = C( L2, 2 ) - $ DDOT( N-L2, S( L2, L2P1 ), LDS, $ C( L2P1, 2 ), 1 ) END IF CALL DLASY2( .FALSE., .FALSE., ISGN, DL, M, S( L1, L1 ), $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, $ INFO ) END IF INFOM = MAX( INFO, INFOM ) IF ( SCALOC.NE.ONE ) THEN C DO 10 J = 1, M CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 10 CONTINUE C SCALE = SCALE*SCALOC END IF C( L1, 1 ) = X( 1, 1 ) IF ( TBYT ) C( L1, 2 ) = X( 1, 2 ) IF ( DL.NE.1 ) THEN C( L2, 1 ) = X( 2, 1 ) IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) END IF 20 CONTINUE C ELSE C C Start row loop (index = L). C L1 (L2) : row index of the first (last) row of X(L). C LNEXT = 1 C DO 40 L = 1, N IF( L.LT.LNEXT ) $ GO TO 40 L1 = L L2 = L IF( L.LT.N ) THEN IF( S( L+1, L ).NE.ZERO ) $ L2 = L2 + 1 LNEXT = L2 + 1 END IF DL = L2 - L1 + 1 C IF ( DISCR ) THEN C C Solve A'*X'*S - X' = scale*C'. C C The L-th block of X is determined from C C A'*X(L)'*S(L,L) - X(L)' = C(L)' - R(L), C C where C C L-1 C R(L) = A' * SUM [X(J)'*S(J,L)] . C J=1 C G11 = -DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) IF ( TBYT ) THEN G21 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1 ) VEC( 1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 + AT(1,2)*G21 VEC( 2, 1 ) = C( L1, 2 ) + AT(2,1)*G11 + AT(2,2)*G21 ELSE VEC (1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 END IF IF ( DL .NE. 1 ) THEN G12 = -DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) IF ( TBYT ) THEN G22 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1 ) VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 + $ AT(1,2)*G22 VEC( 2, 2 ) = C( L2, 2 ) + AT(2,1)*G12 + $ AT(2,2)*G22 ELSE VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 END IF END IF CALL SB04PX( .FALSE., .FALSE., -ISGN, M, DL, AT, 2, $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, $ XNORM, INFO ) ELSE C C Solve A'*X' + X'*S = scale*C'. C C The L-th block of X is determined from C C A'*X(L)' + X(L)'*S(L,L) = C(L)' - R(L), C C where C L-1 C R(L) = SUM [X(J)'*S(J,L)]. C J=1 C VEC( 1, 1 ) = C( L1, 1 ) - $ DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) IF ( TBYT ) $ VEC( 2, 1 ) = C( L1, 2 ) - $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1) C IF ( DL.NE.1 ) THEN VEC( 1, 2 ) = C( L2, 1 ) - $ DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) IF ( TBYT ) $ VEC( 2, 2 ) = C( L2, 2 ) - $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1) END IF CALL DLASY2( .FALSE., .FALSE., ISGN, M, DL, AT, 2, $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, $ XNORM, INFO ) END IF INFOM = MAX( INFO, INFOM ) IF ( SCALOC.NE.ONE ) THEN C DO 30 J = 1, M CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) 30 CONTINUE C SCALE = SCALE*SCALOC END IF C( L1, 1 ) = X( 1, 1 ) IF ( TBYT ) C( L1, 2 ) = X( 2, 1 ) IF ( DL.NE.1 ) THEN C( L2, 1 ) = X( 1, 2 ) IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) END IF 40 CONTINUE END IF C INFO = INFOM RETURN C *** Last line of SB03OR *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03WD.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03WD.f0000644000175000017500000007775615012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE MB03WD( JOB, COMPZ, N, P, ILO, IHI, ILOZ, IHIZ, H, $ LDH1, LDH2, Z, LDZ1, LDZ2, WR, WI, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To compute the Schur decomposition and the eigenvalues of a C product of matrices, H = H_1*H_2*...*H_p, with H_1 an upper C Hessenberg matrix and H_2, ..., H_p upper triangular matrices, C without evaluating the product. Specifically, the matrices Z_i C are computed, such that C C Z_1' * H_1 * Z_2 = T_1, C Z_2' * H_2 * Z_3 = T_2, C ... C Z_p' * H_p * Z_1 = T_p, C C where T_1 is in real Schur form, and T_2, ..., T_p are upper C triangular. C C The routine works primarily with the Hessenberg and triangular C submatrices in rows and columns ILO to IHI, but optionally applies C the transformations to all the rows and columns of the matrices C H_i, i = 1,...,p. The transformations can be optionally C accumulated. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Indicates whether the user wishes to compute the full C Schur form or the eigenvalues only, as follows: C = 'E': Compute the eigenvalues only; C = 'S': Compute the factors T_1, ..., T_p of the full C Schur form, T = T_1*T_2*...*T_p. C C COMPZ CHARACTER*1 C Indicates whether or not the user wishes to accumulate C the matrices Z_1, ..., Z_p, as follows: C = 'N': The matrices Z_1, ..., Z_p are not required; C = 'I': Z_i is initialized to the unit matrix and the C orthogonal transformation matrix Z_i is returned, C i = 1, ..., p; C = 'V': Z_i must contain an orthogonal matrix Q_i on C entry, and the product Q_i*Z_i is returned, C i = 1, ..., p. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix H. N >= 0. C C P (input) INTEGER C The number of matrices in the product H_1*H_2*...*H_p. C P >= 1. C C ILO (input) INTEGER C IHI (input) INTEGER C It is assumed that all matrices H_j, j = 2, ..., p, are C already upper triangular in rows and columns 1:ILO-1 and C IHI+1:N, and H_1 is upper quasi-triangular in rows and C columns 1:ILO-1 and IHI+1:N, with H_1(ILO,ILO-1) = 0 C (unless ILO = 1), and H_1(IHI+1,IHI) = 0 (unless IHI = N). C The routine works primarily with the Hessenberg submatrix C in rows and columns ILO to IHI, but applies the C transformations to all the rows and columns of the C matrices H_i, i = 1,...,p, if JOB = 'S'. C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. C C ILOZ (input) INTEGER C IHIZ (input) INTEGER C Specify the rows of Z to which the transformations must be C applied if COMPZ = 'I' or COMPZ = 'V'. C 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. C C H (input/output) DOUBLE PRECISION array, dimension C (LDH1,LDH2,P) C On entry, the leading N-by-N part of H(*,*,1) must contain C the upper Hessenberg matrix H_1 and the leading N-by-N C part of H(*,*,j) for j > 1 must contain the upper C triangular matrix H_j, j = 2, ..., p. C On exit, if JOB = 'S', the leading N-by-N part of H(*,*,1) C is upper quasi-triangular in rows and columns ILO:IHI, C with any 2-by-2 diagonal blocks corresponding to a pair of C complex conjugated eigenvalues, and the leading N-by-N C part of H(*,*,j) for j > 1 contains the resulting upper C triangular matrix T_j. C If JOB = 'E', the contents of H are unspecified on exit. C C LDH1 INTEGER C The first leading dimension of the array H. C LDH1 >= max(1,N). C C LDH2 INTEGER C The second leading dimension of the array H. C LDH2 >= max(1,N). C C Z (input/output) DOUBLE PRECISION array, dimension C (LDZ1,LDZ2,P) C On entry, if COMPZ = 'V', the leading N-by-N-by-P part of C this array must contain the current matrix Q of C transformations accumulated by SLICOT Library routine C MB03VY. C If COMPZ = 'I', Z need not be set on entry. C On exit, if COMPZ = 'V', or COMPZ = 'I', the leading C N-by-N-by-P part of this array contains the transformation C matrices which produced the Schur form; the C transformations are applied only to the submatrices C Z_j(ILOZ:IHIZ,ILO:IHI), j = 1, ..., P. C If COMPZ = 'N', Z is not referenced. C C LDZ1 INTEGER C The first leading dimension of the array Z. C LDZ1 >= 1, if COMPZ = 'N'; C LDZ1 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'. C C LDZ2 INTEGER C The second leading dimension of the array Z. C LDZ2 >= 1, if COMPZ = 'N'; C LDZ2 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'. C C WR (output) DOUBLE PRECISION array, dimension (N) C WI (output) DOUBLE PRECISION array, dimension (N) C The real and imaginary parts, respectively, of the C computed eigenvalues ILO to IHI are stored in the C corresponding elements of WR and WI. If two eigenvalues C are computed as a complex conjugate pair, they are stored C in consecutive elements of WR and WI, say the i-th and C (i+1)th, with WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the C eigenvalues are stored in the same order as on the C diagonal of the Schur form returned in H. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= IHI-ILO+P-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 > 0: if INFO = i, ILO <= i <= IHI, the QR algorithm C failed to compute all the eigenvalues ILO to IHI C in a total of 30*(IHI-ILO+1) iterations; C the elements i+1:IHI of WR and WI contain those C eigenvalues which have been successfully computed. C C METHOD C C A refined version of the QR algorithm proposed in [1] and [2] is C used. The elements of the subdiagonal, diagonal, and the first C supradiagonal of current principal submatrix of H are computed C in the process. C C REFERENCES C C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. C The periodic Schur decomposition: algorithms and applications. C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, C 1992. C C [2] Sreedhar, J. and Van Dooren, P. C Periodic Schur form and some matrix equations. C Proc. of the Symposium on the Mathematical Theory of Networks C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. C C NUMERICAL ASPECTS C C The algorithm is numerically stable. C C FURTHER COMMENTS C C Note that for P = 1, the LAPACK Library routine DHSEQR could be C more efficient on some computer architectures than this routine, C because DHSEQR uses a block multishift QR algorithm. C When P is large and JOB = 'S', it could be more efficient to C compute the product matrix H, and use the LAPACK Library routines. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. C Partly based on the routine PSHQR by A. Varga C (DLR Oberpfaffenhofen), January 22, 1996. C C REVISIONS C C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. C C KEYWORDS C C Eigenvalue, eigenvalue decomposition, Hessenberg form, C orthogonal transformation, periodic systems, (periodic) Schur C form, real Schur form, similarity transformation, triangular form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) DOUBLE PRECISION DAT1, DAT2 PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) C .. C .. Scalar Arguments .. CHARACTER COMPZ, JOB INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH1, LDH2, LDWORK, $ LDZ1, LDZ2, N, P C .. C .. Array Arguments .. DOUBLE PRECISION DWORK( * ), H( LDH1, LDH2, * ), WI( * ), $ WR( * ), Z( LDZ1, LDZ2, * ) C .. C .. Local Scalars .. LOGICAL INITZ, WANTT, WANTZ INTEGER I, I1, I2, ITN, ITS, J, JMAX, JMIN, K, L, M, $ NH, NR, NROW, NZ DOUBLE PRECISION AVE, CS, DISC, H11, H12, H21, H22, H33, H33S, $ H43H34, H44, H44S, HH10, HH11, HH12, HH21, HH22, $ HP00, HP01, HP02, HP11, HP12, HP22, OVFL, S, $ SMLNUM, SN, TAU, TST1, ULP, UNFL, V1, V2, V3 C .. C .. Local Arrays .. DOUBLE PRECISION V( 3 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANHS, DLANTR EXTERNAL DLAMCH, DLANHS, DLANTR, LSAME C .. C .. External Subroutines .. EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DLARFX, DLARTG, $ DLASET, DROT, MB04PY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT C .. C .. Executable Statements .. C C Test the input scalar arguments. C WANTT = LSAME( JOB, 'S' ) INITZ = LSAME( COMPZ, 'I' ) WANTZ = LSAME( COMPZ, 'V' ) .OR. INITZ INFO = 0 IF( .NOT. ( WANTT .OR. LSAME( JOB, 'E' ) ) ) THEN INFO = -1 ELSE IF( .NOT. ( WANTZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( P.LT.1 ) THEN INFO = -4 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -6 ELSE IF( ILOZ.LT.1 .OR. ILOZ.GT.ILO ) THEN INFO = -7 ELSE IF( IHIZ.LT.IHI .OR. IHIZ.GT.N ) THEN INFO = -8 ELSE IF( LDH1.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDH2.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDZ1.LT.1 .OR. ( WANTZ .AND. LDZ1.LT.N ) ) THEN INFO = -13 ELSE IF( LDZ2.LT.1 .OR. ( WANTZ .AND. LDZ2.LT.N ) ) THEN INFO = -14 ELSE IF( LDWORK.LT.IHI - ILO + P - 1 ) THEN INFO = -18 END IF IF( INFO.EQ.0 ) THEN IF( ILO.GT.1 ) THEN IF( H( ILO, ILO-1, 1 ).NE.ZERO ) $ INFO = -5 ELSE IF( IHI.LT.N ) THEN IF( H( IHI+1, IHI, 1 ).NE.ZERO ) $ INFO = -6 END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03WD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C C Initialize Z, if necessary. C IF( INITZ ) THEN C DO 10 J = 1, P CALL DLASET( 'Full', N, N, ZERO, ONE, Z( 1, 1, J ), LDZ1 ) 10 CONTINUE C END IF C NH = IHI - ILO + 1 C IF( NH.EQ.1 ) THEN HP00 = ONE C DO 20 J = 1, P HP00 = HP00 * H( ILO, ILO, J ) 20 CONTINUE C WR( ILO ) = HP00 WI( ILO ) = ZERO RETURN END IF C C Set machine-dependent constants for the stopping criterion. C If norm(H) <= sqrt(OVFL), overflow should not occur. C UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( DBLE( NH ) / ULP ) C C Set the elements in rows and columns ILO to IHI to zero below the C first subdiagonal in H(*,*,1) and below the first diagonal in C H(*,*,j), j >= 2. In the same loop, compute and store in C DWORK(NH:NH+P-2) the 1-norms of the matrices H_2, ..., H_p, to be C used later. C I = NH S = ULP * DBLE( N ) IF( NH.GT.2 ) $ CALL DLASET( 'Lower', NH-2, NH-2, ZERO, ZERO, $ H( ILO+2, ILO, 1 ), LDH1 ) C DO 30 J = 2, P CALL DLASET( 'Lower', NH-1, NH-1, ZERO, ZERO, $ H( ILO+1, ILO, J ), LDH1 ) DWORK( I ) = S * DLANTR( '1-norm', 'Upper', 'NonUnit', NH, NH, $ H( ILO, ILO, J ), LDH1, DWORK ) I = I + 1 30 CONTINUE C C I1 and I2 are the indices of the first row and last column of H C to which transformations must be applied. If eigenvalues only are C being computed, I1 and I2 are set inside the main loop. C IF( WANTT ) THEN I1 = 1 I2 = N END IF C IF( WANTZ ) $ NZ = IHIZ - ILOZ + 1 C C ITN is the total number of QR iterations allowed. C ITN = 30*NH C C The main loop begins here. I is the loop index and decreases from C IHI to ILO in steps of 1 or 2. Each iteration of the loop works C with the active submatrix in rows and columns L to I. C Eigenvalues I+1 to IHI have already converged. Either L = ILO or C H(L,L-1) is negligible so that the matrix splits. C I = IHI C 40 CONTINUE L = ILO C C Perform QR iterations on rows and columns ILO to I until a C submatrix of order 1 or 2 splits off at the bottom because a C subdiagonal element has become negligible. C C Let T = H_2*...*H_p, and H = H_1*T. Part of the currently C free locations of WR and WI are temporarily used as workspace. C C WR(L:I): the current diagonal elements of h = H(L:I,L:I); C WI(L+1:I): the current elements of the first subdiagonal of h; C DWORK(NH-I+L:NH-1): the current elements of the first C supradiagonal of h. C DO 160 ITS = 0, ITN C C Initialization: compute H(I,I) (and H(I,I-1) if I > L). C HP22 = ONE IF( I.GT.L ) THEN HP12 = ZERO HP11 = ONE C DO 50 J = 2, P HP22 = HP22*H( I, I, J ) HP12 = HP11*H( I-1, I, J ) + HP12*H( I, I, J ) HP11 = HP11*H( I-1, I-1, J ) 50 CONTINUE C HH21 = H( I, I-1, 1 )*HP11 HH22 = H( I, I-1, 1 )*HP12 + H( I, I, 1 )*HP22 C WR( I ) = HH22 WI( I ) = HH21 ELSE C DO 60 J = 1, P HP22 = HP22*H( I, I, J ) 60 CONTINUE C WR( I ) = HP22 END IF C C Look for a single small subdiagonal element. C The loop also computes the needed current elements of the C diagonal and the first two supradiagonals of T, as well as C the current elements of the central tridiagonal of H. C DO 80 K = I, L + 1, -1 C C Evaluate H(K-1,K-1), H(K-1,K) (and H(K-1,K-2) if K > L+1). C HP00 = ONE HP01 = ZERO IF( K.GT.L+1 ) THEN HP02 = ZERO C DO 70 J = 2, P HP02 = HP00*H( K-2, K, J ) + HP01*H( K-1, K, J ) $ + HP02*H( K, K, J ) HP01 = HP00*H( K-2, K-1, J ) + HP01*H( K-1, K-1, J ) HP00 = HP00*H( K-2, K-2, J ) 70 CONTINUE C HH10 = H( K-1, K-2, 1 )*HP00 HH11 = H( K-1, K-2, 1 )*HP01 + H( K-1, K-1, 1 )*HP11 HH12 = H( K-1, K-2, 1 )*HP02 + H( K-1, K-1, 1 )*HP12 $ + H( K-1, K, 1 )*HP22 WI( K-1 ) = HH10 ELSE HH10 = ZERO HH11 = H( K-1, K-1, 1 )*HP11 HH12 = H( K-1, K-1, 1 )*HP12 + H( K-1, K, 1 )*HP22 END IF WR( K-1 ) = HH11 DWORK( NH-I+K-1) = HH12 C C Test for a negligible subdiagonal element. C TST1 = ABS( HH11 ) + ABS( HH22 ) IF( TST1.EQ.ZERO ) $ TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1, $ DWORK ) IF( ABS( HH21 ).LE.MAX( ULP*TST1, SMLNUM ) ) $ GO TO 90 C C Update the values for the next cycle. C HP22 = HP11 HP11 = HP00 HP12 = HP01 HH22 = HH11 HH21 = HH10 80 CONTINUE C 90 CONTINUE L = K C IF( L.GT.ILO ) THEN C C H(L,L-1) is negligible. C IF( WANTT ) THEN C C If H(L,L-1,1) is also negligible, set it to 0; otherwise, C annihilate the subdiagonal elements bottom-up, and C restore the triangular form of H(*,*,j). Since H(L,L-1) C is negligible, the second case can only appear when the C product of H(L-1,L-1,j), j >= 2, is negligible. C TST1 = ABS( H( L-1, L-1, 1 ) ) + ABS( H( L, L, 1 ) ) IF( TST1.EQ.ZERO ) $ TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1, $ DWORK ) IF( ABS( H( L, L-1, 1 ) ).GT.MAX( ULP*TST1, SMLNUM ) ) $ THEN C DO 110 K = I, L, -1 C DO 100 J = 1, P - 1 C C Compute G to annihilate from the right the C (K,K-1) element of the matrix H_j. C V( 1 ) = H( K, K-1, J ) CALL DLARFG( 2, H( K, K, J ), V, 1, TAU ) H( K, K-1, J ) = ZERO V( 2 ) = ONE C C Apply G from the right to transform the columns C of the matrix H_j in rows I1 to K-1. C CALL DLARFX( 'Right', K-I1, 2, V, TAU, $ H( I1, K-1, J ), LDH1, DWORK ) C C Apply G from the left to transform the rows of C the matrix H_(j+1) in columns K-1 to I2. C CALL DLARFX( 'Left', 2, I2-K+2, V, TAU, $ H( K-1, K-1, J+1 ), LDH1, DWORK ) C IF( WANTZ ) THEN C C Accumulate transformations in the matrix C Z_(j+1). C CALL DLARFX( 'Right', NZ, 2, V, TAU, $ Z( ILOZ, K-1, J+1 ), LDZ1, $ DWORK ) END IF 100 CONTINUE C IF( K.LT.I ) THEN C C Compute G to annihilate from the right the C (K+1,K) element of the matrix H_p. C V( 1 ) = H( K+1, K, P ) CALL DLARFG( 2, H( K+1, K+1, P ), V, 1, TAU ) H( K+1, K, P ) = ZERO V( 2 ) = ONE C C Apply G from the right to transform the columns C of the matrix H_p in rows I1 to K. C CALL DLARFX( 'Right', K-I1+1, 2, V, TAU, $ H( I1, K, P ), LDH1, DWORK ) C C Apply G from the left to transform the rows of C the matrix H_1 in columns K to I2. C CALL DLARFX( 'Left', 2, I2-K+1, V, TAU, $ H( K, K, 1 ), LDH1, DWORK ) C IF( WANTZ ) THEN C C Accumulate transformations in the matrix Z_1. C CALL DLARFX( 'Right', NZ, 2, V, TAU, $ Z( ILOZ, K, 1 ), LDZ1, DWORK ) END IF END IF 110 CONTINUE C H( L, L-1, P ) = ZERO END IF H( L, L-1, 1 ) = ZERO END IF END IF C C Exit from loop if a submatrix of order 1 or 2 has split off. C IF( L.GE.I-1 ) $ GO TO 170 C C Now the active submatrix is in rows and columns L to I. If C eigenvalues only are being computed, only the active submatrix C need be transformed. C IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF C IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN C C Exceptional shift. C S = ABS( WI( I ) ) + ABS( WI( I-1 ) ) H44 = DAT1*S + WR( I ) H33 = H44 H43H34 = DAT2*S*S ELSE C C Prepare to use Francis' double shift (i.e., second degree C generalized Rayleigh quotient). C H44 = WR( I ) H33 = WR( I-1 ) H43H34 = WI( I )*DWORK( NH-1 ) DISC = ( H33 - H44 )*HALF DISC = DISC*DISC + H43H34 IF( DISC.GT.ZERO ) THEN C C Real roots: use Wilkinson's shift twice. C DISC = SQRT( DISC ) AVE = HALF*( H33 + H44 ) IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN H33 = H33*H44 - H43H34 H44 = H33 / ( SIGN( DISC, AVE ) + AVE ) ELSE H44 = SIGN( DISC, AVE ) + AVE END IF H33 = H44 H43H34 = ZERO END IF END IF C C Look for two consecutive small subdiagonal elements. C DO 120 M = I - 2, L, -1 C C Determine the effect of starting the double-shift QR C iteration at row M, and see if this would make H(M,M-1) C negligible. C H11 = WR( M ) H12 = DWORK( NH-I+M ) H21 = WI( M+1 ) H22 = WR( M+1 ) H44S = H44 - H11 H33S = H33 - H11 V1 = ( H33S*H44S - H43H34 ) / H21 + H12 V2 = H22 - H11 - H33S - H44S V3 = WI( M+2 ) S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) V1 = V1 / S V2 = V2 / S V3 = V3 / S V( 1 ) = V1 V( 2 ) = V2 V( 3 ) = V3 IF( M.EQ.L ) $ GO TO 130 TST1 = ABS( V1 )*( ABS( WR( M-1 ) ) + $ ABS( H11 ) + ABS( H22 ) ) IF( ABS( WI( M ) )*( ABS( V2 ) + ABS( V3 ) ).LE.ULP*TST1 ) $ GO TO 130 120 CONTINUE C 130 CONTINUE C C Double-shift QR step. C DO 150 K = M, I - 1 C C The first iteration of this loop determines a reflection G C from the vector V and applies it from left and right to H, C thus creating a nonzero bulge below the subdiagonal. C C Each subsequent iteration determines a reflection G to C restore the Hessenberg form in the (K-1)th column, and thus C chases the bulge one step toward the bottom of the active C submatrix. NR is the order of G. C NR = MIN( 3, I-K+1 ) NROW = MIN( K+NR, I ) - I1 + 1 IF( K.GT.M ) $ CALL DCOPY( NR, H( K, K-1, 1 ), 1, V, 1 ) CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU ) IF( K.GT.M ) THEN H( K, K-1, 1 ) = V( 1 ) H( K+1, K-1, 1 ) = ZERO IF( K.LT.I-1 ) $ H( K+2, K-1, 1 ) = ZERO ELSE IF( M.GT.L ) THEN H( K, K-1, 1 ) = -H( K, K-1, 1 ) END IF C C Apply G from the left to transform the rows of the matrix C H_1 in columns K to I2. C CALL MB04PY( 'Left', NR, I2-K+1, V( 2 ), TAU, H( K, K, 1 ), $ LDH1, DWORK ) C C Apply G from the right to transform the columns of the C matrix H_p in rows I1 to min(K+NR,I). C CALL MB04PY( 'Right', NROW, NR, V( 2 ), TAU, H( I1, K, P ), $ LDH1, DWORK ) C IF( WANTZ ) THEN C C Accumulate transformations in the matrix Z_1. C CALL MB04PY( 'Right', NZ, NR, V( 2 ), TAU, $ Z( ILOZ, K, 1 ), LDZ1, DWORK ) END IF C DO 140 J = P, 2, -1 C C Apply G1 (and G2, if NR = 3) from the left to transform C the NR-by-NR submatrix of H_j in position (K,K) to upper C triangular form. C C Compute G1. C CALL DCOPY( NR-1, H( K+1, K, J ), 1, V, 1 ) CALL DLARFG( NR, H( K, K, J ), V, 1, TAU ) H( K+1, K, J ) = ZERO IF( NR.EQ.3 ) $ H( K+2, K, J ) = ZERO C C Apply G1 from the left to transform the rows of the C matrix H_j in columns K+1 to I2. C CALL MB04PY( 'Left', NR, I2-K, V, TAU, H( K, K+1, J ), $ LDH1, DWORK ) C C Apply G1 from the right to transform the columns of the C matrix H_(j-1) in rows I1 to min(K+NR,I). C CALL MB04PY( 'Right', NROW, NR, V, TAU, H( I1, K, J-1 ), $ LDH1, DWORK ) C IF( WANTZ ) THEN C C Accumulate transformations in the matrix Z_j. C CALL MB04PY( 'Right', NZ, NR, V, TAU, Z( ILOZ, K, J ), $ LDZ1, DWORK ) END IF C IF( NR.EQ.3 ) THEN C C Compute G2. C V( 1 ) = H( K+2, K+1, J ) CALL DLARFG( 2, H( K+1, K+1, J ), V, 1, TAU ) H( K+2, K+1, J ) = ZERO C C Apply G2 from the left to transform the rows of the C matrix H_j in columns K+2 to I2. C CALL MB04PY( 'Left', 2, I2-K-1, V, TAU, $ H( K+1, K+2, J ), LDH1, DWORK ) C C Apply G2 from the right to transform the columns of C the matrix H_(j-1) in rows I1 to min(K+3,I). C CALL MB04PY( 'Right', NROW, 2, V, TAU, $ H( I1, K+1, J-1 ), LDH1, DWORK ) C IF( WANTZ ) THEN C C Accumulate transformations in the matrix Z_j. C CALL MB04PY( 'Right', NZ, 2, V, TAU, $ Z( ILOZ, K+1, J ), LDZ1, DWORK ) END IF END IF 140 CONTINUE C 150 CONTINUE C 160 CONTINUE C C Failure to converge in remaining number of iterations. C INFO = I RETURN C 170 CONTINUE C IF( L.EQ.I ) THEN C C H(I,I-1,1) is negligible: one eigenvalue has converged. C Note that WR(I) has already been set. C WI( I ) = ZERO ELSE IF( L.EQ.I-1 ) THEN C C H(I-1,I-2,1) is negligible: a pair of eigenvalues have C converged. C C Transform the 2-by-2 submatrix of H_1*H_2*...*H_p in position C (I-1,I-1) to standard Schur form, and compute and store its C eigenvalues. If the Schur form is not required, then the C previously stored values of a similar submatrix are used. C For real eigenvalues, a Givens transformation is used to C triangularize the submatrix. C IF( WANTT ) THEN HP22 = ONE HP12 = ZERO HP11 = ONE C DO 180 J = 2, P HP22 = HP22*H( I, I, J ) HP12 = HP11*H( I-1, I, J ) + HP12*H( I, I, J ) HP11 = HP11*H( I-1, I-1, J ) 180 CONTINUE C HH21 = H( I, I-1, 1 )*HP11 HH22 = H( I, I-1, 1 )*HP12 + H( I, I, 1 )*HP22 HH11 = H( I-1, I-1, 1 )*HP11 HH12 = H( I-1, I-1, 1 )*HP12 + H( I-1, I, 1 )*HP22 ELSE HH11 = WR( I-1 ) HH12 = DWORK( NH-1 ) HH21 = WI( I ) HH22 = WR( I ) END IF C CALL DLANV2( HH11, HH12, HH21, HH22, WR( I-1 ), WI( I-1 ), $ WR( I ), WI( I ), CS, SN ) C IF( WANTT ) THEN C C Detect negligible diagonal elements in positions (I-1,I-1) C and (I,I) in H_j, J > 1. C JMIN = 0 JMAX = 0 C DO 190 J = 2, P IF( JMIN.EQ.0 ) THEN IF( ABS( H( I-1, I-1, J ) ).LE.DWORK( NH+J-2 ) ) $ JMIN = J END IF IF( ABS( H( I, I, J ) ).LE.DWORK( NH+J-2 ) ) JMAX = J 190 CONTINUE C IF( JMIN.NE.0 .AND. JMAX.NE.0 ) THEN C C Choose the shorter path if zero elements in both C (I-1,I-1) and (I,I) positions are present. C IF( JMIN-1.LE.P-JMAX+1 ) THEN JMAX = 0 ELSE JMIN = 0 END IF END IF C IF( JMIN.NE.0 ) THEN C DO 200 J = 1, JMIN - 1 C C Compute G to annihilate from the right the (I,I-1) C element of the matrix H_j. C V( 1 ) = H( I, I-1, J ) CALL DLARFG( 2, H( I, I, J ), V, 1, TAU ) H( I, I-1, J ) = ZERO V( 2 ) = ONE C C Apply G from the right to transform the columns of the C matrix H_j in rows I1 to I-1. C CALL DLARFX( 'Right', I-I1, 2, V, TAU, $ H( I1, I-1, J ), LDH1, DWORK ) C C Apply G from the left to transform the rows of the C matrix H_(j+1) in columns I-1 to I2. C CALL DLARFX( 'Left', 2, I2-I+2, V, TAU, $ H( I-1, I-1, J+1 ), LDH1, DWORK ) C IF( WANTZ ) THEN C C Accumulate transformations in the matrix Z_(j+1). C CALL DLARFX( 'Right', NZ, 2, V, TAU, $ Z( ILOZ, I-1, J+1 ), LDZ1, DWORK ) END IF 200 CONTINUE C H( I, I-1, JMIN ) = ZERO C ELSE IF( JMAX.GT.0 .AND. WI( I-1 ).EQ.ZERO ) $ CALL DLARTG( H( I-1, I-1, 1 ), H( I, I-1, 1 ), CS, SN, $ TAU ) C C Apply the transformation to H. C CALL DROT( I2-I+2, H( I-1, I-1, 1 ), LDH1, $ H( I, I-1, 1 ), LDH1, CS, SN ) CALL DROT( I-I1+1, H( I1, I-1, P ), 1, H( I1, I, P ), 1, $ CS, SN ) IF( WANTZ ) THEN C C Apply transformation to Z_1. C CALL DROT( NZ, Z( ILOZ, I-1, 1 ), 1, Z( ILOZ, I, 1 ), $ 1, CS, SN ) END IF C DO 210 J = P, MAX( 2, JMAX+1 ), -1 C C Compute G1 to annihilate from the left the (I,I-1) C element of the matrix H_j. C V( 1 ) = H( I, I-1, J ) CALL DLARFG( 2, H( I-1, I-1, J ), V, 1, TAU ) H( I, I-1, J ) = ZERO C C Apply G1 from the left to transform the rows of the C matrix H_j in columns I to I2. C CALL MB04PY( 'Left', 2, I2-I+1, V, TAU, $ H( I-1, I, J ), LDH1, DWORK ) C C Apply G1 from the right to transform the columns of C the matrix H_(j-1) in rows I1 to I. C CALL MB04PY( 'Right', I-I1+1, 2, V, TAU, $ H( I1, I-1, J-1 ), LDH1, DWORK ) C IF( WANTZ ) THEN C C Apply G1 to Z_j. C CALL MB04PY( 'Right', NZ, 2, V, TAU, $ Z( ILOZ, I-1, J ), LDZ1, DWORK ) END IF 210 CONTINUE C IF( JMAX.GT.0 ) THEN H( I, I-1, 1 ) = ZERO H( I, I-1, JMAX ) = ZERO ELSE IF( HH21.EQ.ZERO ) $ H( I, I-1, 1 ) = ZERO END IF END IF END IF END IF C C Decrement number of remaining iterations, and return to start of C the main loop with new value of I. C ITN = ITN - ITS I = L - 1 IF( I.GE.ILO ) $ GO TO 40 C RETURN C C *** Last line of MB03WD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03BE.f0000644000000000000000000000013215012430707016145 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03BE.f0000644000175000017500000001067115012430707017346 0ustar00lilgelilge00000000000000 SUBROUTINE MB03BE( K, AMAP, S, SINV, A, LDA1, LDA2 ) C C PURPOSE C C To apply at most 20 iterations of a real single shifted C periodic QZ algorithm to the 2-by-2 product of matrices stored C in the array A. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA1,LDA2,K) C On entry, the leading 2-by-2-by-K part of this array must C contain a 2-by-2 product (implicitly represented by its K C factors) in upper Hessenberg form. C On exit, the leading 2-by-2-by-K part of this array C contains the product after at most 20 iterations of a real C shifted periodic QZ algorithm. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= 2. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= 2. C C METHOD C C Ten iterations of a real single shifted periodic QZ algorithm are C applied to the 2-by-2 matrix product A. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLARL2. C V. Sima, June 2012. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER K, LDA1, LDA2, SINV C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*) C .. Local Scalars .. INTEGER I, L, AI DOUBLE PRECISION CS, SN, CT, ST, TEMP, ULP C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. External Subroutines .. EXTERNAL DLARTG, DROT, MB03AD C .. Intrinsic Functions .. INTRINSIC ABS, MAX C C .. Executable Statements .. C DO 20 I = 1, 20 CALL MB03AD( 'Single', K, 2, AMAP, S, SINV, A, LDA1, LDA2, $ CS, SN, CT, ST ) AI = AMAP(1) CALL DROT( 2, A(1,1,AI), LDA1, A(2,1,AI), LDA1, CS, SN ) C DO 10 L = K, 2, -1 AI = AMAP(L) IF ( S(AI).EQ.SINV ) THEN CALL DROT( 2, A(1,1,AI), 1, A(1,2,AI), 1, CS, SN ) TEMP = A(1,1,AI) CALL DLARTG( TEMP, A(2,1,AI), CS, SN, A(1,1,AI) ) A(2,1,AI) = ZERO TEMP = CS*A(1,2,AI) + SN*A(2,2,AI) A(2,2,AI) = CS*A(2,2,AI) - SN*A(1,2,AI) A(1,2,AI) = TEMP ELSE CALL DROT( 2, A(1,1,AI), LDA1, A(2,1,AI), LDA1, CS, SN ) TEMP = A(2,2,AI) CALL DLARTG( TEMP, A(2,1,AI), CS, SN, A(2,2,AI) ) A(2,1,AI) = ZERO SN = -SN TEMP = CS*A(1,1,AI) + SN*A(1,2,AI) A(1,2,AI) = CS*A(1,2,AI) - SN*A(1,1,AI) A(1,1,AI) = TEMP END IF 10 CONTINUE C AI = AMAP(1) CALL DROT( 2, A(1,1,AI), 1, A(1,2,AI), 1, CS, SN ) C IF ( I.EQ.6 ) THEN ULP = DLAMCH( 'Precision' ) IF ( ABS( A(2,1,AI) ).LT.ULP*( MAX( ABS( A(1,1,AI) ), $ ABS( A(1,2,AI) ), $ ABS( A(2,2,AI) ) ) ) ) $ GO TO 30 ELSE IF ( I.GT.10 ) THEN IF ( ABS( A(2,1,AI) ).LT.ULP*( MAX( ABS( A(1,1,AI) ), $ ABS( A(1,2,AI) ), $ ABS( A(2,2,AI) ) ) ) ) $ GO TO 30 END IF 20 CONTINUE C 30 CONTINUE C RETURN C *** Last line of MB03BE *** END control-4.1.2/src/slicot/src/PaxHeaders/SB08ND.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB08ND.f0000644000175000017500000002762615012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute a real polynomial E(z) such that C C (a) E(1/z) * E(z) = A(1/z) * A(z) and C (b) E(z) is stable - that is, E(z) has no zeros with modulus C greater than 1, C C which corresponds to computing the spectral factorization of the C real polynomial A(z) arising from discrete optimality problems. C C The input polynomial may be supplied either in the form C C A(z) = a(0) + a(1) * z + ... + a(DA) * z**DA C C or as C C B(z) = A(1/z) * A(z) C = b(0) + b(1) * (z + 1/z) + ... + b(DA) * (z**DA + 1/z**DA) C (1) C C ARGUMENTS C C Mode Parameters C C ACONA CHARACTER*1 C Indicates whether the coefficients of A(z) or B(z) = C A(1/z) * A(z) are to be supplied as follows: C = 'A': The coefficients of A(z) are to be supplied; C = 'B': The coefficients of B(z) are to be supplied. C C Input/Output Parameters C C DA (input) INTEGER C The degree of the polynomials A(z) and E(z). DA >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (DA+1) C On entry, if ACONA = 'A', this array must contain the C coefficients of the polynomial A(z) in increasing powers C of z, and if ACONA = 'B', this array must contain the C coefficients b ,b ,...,b of the polynomial B(z) in C 0 1 DA C equation (1). That is, A(i) = b for i = 1,2,...,DA+1. C i-1 C On exit, this array contains the coefficients of the C polynomial B(z) in eqation (1). Specifically, A(i) C contains b , for i = 1,2,...DA+1. C i-1 C C RES (output) DOUBLE PRECISION C An estimate of the accuracy with which the coefficients of C the polynomial E(z) have been computed (see also METHOD C and NUMERICAL ASPECTS). C C E (output) DOUBLE PRECISION array, dimension (DA+1) C The coefficients of the spectral factor E(z) in increasing C powers of z. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 5*DA+5. 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 = 2: if on entry, ACONA = 'B' but the supplied C coefficients of the polynomial B(z) are not the C coefficients of A(1/z) * A(z) for some real A(z); C in this case, RES and E are unassigned; C = 3: if the iterative process (see METHOD) has failed to C converge in 30 iterations; C = 4: if the last computed iterate (see METHOD) is C unstable. If ACONA = 'B', then the supplied C coefficients of the polynomial B(z) may not be the C coefficients of A(1/z) * A(z) for some real A(z). C C METHOD C _ _ C Let A(z) be the conjugate polynomial of A(z), i.e., A(z) = A(1/z). C C The method used by the routine is based on applying the C Newton-Raphson iteration to the function C _ _ C F(e) = A * A - e * e, C C which leads to the iteration formulae (see [1] and [2]) C C _(i) (i) _(i) (i) _ ) C q * x + x * q = 2 A * A ) C ) for i = 0, 1, 2,... C (i+1) (i) (i) ) C q = (q + x )/2 ) C C The iteration starts from C C (0) DA C q (z) = (b(0) + b(1) * z + ... + b(DA) * z ) / SQRT( b(0)) C C which is a Hurwitz polynomial that has no zeros in the closed unit C (i) C circle (see [2], Theorem 3). Then lim q = e, the convergence is C uniform and e is a Hurwitz polynomial. C C The iterates satisfy the following conditions: C (i) C (a) q has no zeros in the closed unit circle, C (i) (i-1) C (b) q <= q and C 0 0 C DA (i) 2 DA 2 C (c) SUM (q ) - SUM (A ) >= 0. C k=0 k k=0 k C (i) C The iterative process stops if q violates (a), (b) or (c), C or if the condition C _(i) (i) _ C (d) RES = ||(q q - A A)|| < tol, C C is satisfied, where || . || denotes the largest coefficient of C _(i) (i) _ C the polynomial (q q - A A) and tol is an estimate of the C _(i) (i) C rounding error in the computed coefficients of q q . If C (i-1) C condition (a) or (b) is violated then q is taken otherwise C (i) C q is used. Thus the computed reciprocal polynomial E(z) = z**DA C * q(1/z) is stable. If there is no convergence after 30 iterations C then the routine returns with the Error Indicator (INFO) set to 3, C and the value of RES may indicate whether or not the last computed C iterate is close to the solution. C (0) C If ACONA = 'B', then it is possible that q is not a Hurwitz C polynomial, in which case the equation e(1/z) * e(z) = B(z) has no C real solution (see [2], Theorem 3). C C REFERENCES C C [1] Kucera, V. C Discrete Linear Control, The polynomial Approach. C John Wiley & Sons, Chichester, 1979. C C [2] Vostry, Z. C New Algorithm for Polynomial Spectral Factorization with C Quadratic Convergence I. C Kybernetika, 11, pp. 415-422, 1975. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB08BD by F. Delebecque and C A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Factorization, Laplace transform, optimal control, optimal C filtering, polynomial operations, spectral factorization, zeros. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, $ TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER ACONA INTEGER DA, INFO, LDWORK DOUBLE PRECISION RES C .. Array Arguments .. DOUBLE PRECISION A(*), DWORK(*), E(*) C .. Local Scalars .. LOGICAL CONV, HURWTZ, LACONA INTEGER I, J, K, LALPHA, LAMBDA, LETA, LQ, LRO, NC, NCK DOUBLE PRECISION A0, RES0, S, SA0, TOLQ, W C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX EXTERNAL IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSCAL, DSWAP, SB08NY, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Executable Statements .. C INFO = 0 LACONA = LSAME( ACONA, 'A' ) C C Test the input scalar arguments. C IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN INFO = -1 ELSE IF( DA.LT.0 ) THEN INFO = -2 ELSE IF( LDWORK.LT.5*DA + 5 ) THEN INFO = -7 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB08ND', -INFO ) RETURN END IF C NC = DA + 1 IF ( .NOT.LACONA ) THEN IF ( A(1).LE.ZERO ) THEN INFO = 2 RETURN END IF CALL DCOPY( NC, A, 1, E, 1 ) ELSE CALL SB08NY( DA, A, E, W ) END IF C C Initialization. C LALPHA = 1 LRO = LALPHA + NC LETA = LRO + NC LAMBDA = LETA + NC LQ = LAMBDA + NC C A0 = E(1) SA0 = SQRT( A0 ) S = ZERO C DO 20 J = 1, NC W = E(J) A(J) = W W = W/SA0 E(J) = W DWORK(LQ-1+J) = W S = S + W**2 20 CONTINUE C RES0 = S - A0 C C The contents of the arrays is, cf [1], Section 7.6, C C E : the last computed Hurwitz polynomial q ; C i-1 C DWORK(LALPHA,..,LALPHA+DA-K) : alpha(k,0),...alpha(k,n-k); C (LRO,...,LRO+DA-K) : alpha(k,n-k),...,alpha(k); C (LETA,...,LETA+DA) : eta(0),...,eta(n); C (LAMBDA,...,LAMBDA+DA-1) : lambda(0),...,lambda(n-1) C C DWORK(LQ,...,LQ+DA) : the last computed polynomial q . C i I = 0 CONV = .FALSE. HURWTZ = .TRUE. C C WHILE ( I < 30 and CONV = FALSE and HURWTZ = TRUE ) DO 40 IF ( I.LT.30 .AND. .NOT.CONV .AND. HURWTZ ) THEN I = I + 1 CALL DCOPY( NC, A, 1, DWORK(LETA), 1 ) CALL DSCAL( NC, TWO, DWORK(LETA), 1 ) CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LALPHA), 1 ) C C Computation of lambda(k) and eta(k). C K = 1 C C WHILE ( K <= DA and HURWTZ = TRUE ) DO 60 IF ( ( K.LE.DA ) .AND. HURWTZ ) THEN NCK = NC - K CALL DCOPY( NCK+1, DWORK(LALPHA), -1, DWORK(LRO), 1 ) W = DWORK(LALPHA+NCK)/DWORK(LRO+NCK) IF ( ABS( W ).GE.ONE ) HURWTZ = .FALSE. IF ( HURWTZ ) THEN DWORK(LAMBDA+K-1) = W CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LALPHA), 1 ) W = DWORK(LETA+NCK)/DWORK(LALPHA) DWORK(LETA+NCK) = W CALL DAXPY( NCK-1, -W, DWORK(LALPHA+1), -1, $ DWORK(LETA+1), 1 ) K = K + 1 END IF GO TO 60 END IF C END WHILE 60 C C HURWTZ = The polynomial q is a Hurwitz polynomial. C i-1 IF ( HURWTZ ) THEN CALL DCOPY( NC, DWORK(LQ), 1, E, 1 ) C C Accuracy test. C CALL SB08NY( DA, E, DWORK(LQ), TOLQ ) CALL DAXPY( NC, -ONE, A, 1, DWORK(LQ), 1 ) RES = ABS( DWORK( IDAMAX( NC, DWORK(LQ), 1 ) + LQ - 1 ) ) CONV = ( RES.LT.TOLQ ) .OR. ( RES0.LT.ZERO ) C IF ( .NOT.CONV ) THEN DWORK(LETA) = HALF*DWORK(LETA)/DWORK(LALPHA) C C Computation of x and q . C i i C DWORK(LETA,...,LETA+DA) : eta(k,0),...,eta(k,n) C (LRO,...,LRO+DA-K+1) : eta(k,n-k+1),...,eta(k,0) C DO 80 K = DA, 1, -1 NCK = NC - K + 1 CALL DCOPY( NCK, DWORK(LETA), -1, DWORK(LRO), 1 ) W = DWORK(LAMBDA+K-1) CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LETA), 1 ) 80 CONTINUE C S = ZERO C DO 100 J = 0, DA W = HALF*( DWORK(LETA+J) + E(J+1) ) DWORK(LQ+J) = W S = S + W**2 100 CONTINUE C RES0 = S - A0 C C Test on the monotonicity of q . C 0 CONV = DWORK(LQ).GT.E(1) GO TO 40 END IF END IF END IF C END WHILE 40 C C Reverse the order of the coefficients in the array E. C CALL DSWAP( NC, E, 1, DWORK, -1 ) CALL DSWAP( NC, DWORK, 1, E, 1 ) C IF ( .NOT.CONV ) THEN IF ( HURWTZ ) THEN INFO = 3 ELSE IF ( I.EQ.1 ) THEN INFO = 2 ELSE INFO = 4 END IF END IF C RETURN C *** Last line of SB08ND *** END control-4.1.2/src/slicot/src/PaxHeaders/TB04CD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB04CD.f0000644000175000017500000005002215012430707017350 0ustar00lilgelilge00000000000000 SUBROUTINE TB04CD( JOBD, EQUIL, N, M, P, NPZ, A, LDA, B, LDB, C, $ LDC, D, LDD, NZ, LDNZ, NP, LDNP, ZEROSR, $ ZEROSI, POLESR, POLESI, GAINS, LDGAIN, TOL, $ IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the transfer function matrix G of a state-space C representation (A,B,C,D) of a linear time-invariant multivariable C system, using the pole-zeros method. The transfer function matrix C is returned in a minimal pole-zero-gain form. C C ARGUMENTS C C Mode Parameters 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 to be a zero matrix. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C Input/Output Parameters C C N (input) INTEGER C The order of the system (A,B,C,D). N >= 0. C C M (input) INTEGER C The number of the system inputs. M >= 0. C C P (input) INTEGER C The number of the system outputs. P >= 0. C C NPZ (input) INTEGER C The maximum number of poles or zeros of the single-input C single-output channels in the system. An upper bound C for NPZ is N. NPZ >= 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 original state dynamics matrix A. C On exit, if EQUIL = 'S', the leading N-by-N part of this C array contains the balanced matrix inv(S)*A*S, as returned C by SLICOT Library routine TB01ID. C If EQUIL = 'N', this array is unchanged on exit. 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 matrix B. C On exit, the contents of B are destroyed: all elements but C those in the first row are set to zero. 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 output matrix C. C On exit, if EQUIL = 'S', the leading P-by-N part of this C array contains the balanced matrix C*S, as returned by C SLICOT Library routine TB01ID. C If EQUIL = 'N', this array is unchanged on exit. 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 If JOBD = 'D', the leading P-by-M part of this array must C contain the matrix D. C If JOBD = 'Z', the array D is not referenced. 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 NZ (output) INTEGER array, dimension (LDNZ,M) C The leading P-by-M part of this array contains the numbers C of zeros of the elements of the transfer function C matrix G. Specifically, the (i,j) element of NZ contains C the number of zeros of the transfer function G(i,j) from C the j-th input to the i-th output. C C LDNZ INTEGER C The leading dimension of array NZ. LDNZ >= max(1,P). C C NP (output) INTEGER array, dimension (LDNP,M) C The leading P-by-M part of this array contains the numbers C of poles of the elements of the transfer function C matrix G. Specifically, the (i,j) element of NP contains C the number of poles of the transfer function G(i,j). C C LDNP INTEGER C The leading dimension of array NP. LDNP >= max(1,P). C C ZEROSR (output) DOUBLE PRECISION array, dimension (P*M*NPZ) C This array contains the real parts of the zeros of the C transfer function matrix G. The real parts of the zeros C are stored in a column-wise order, i.e., for the transfer C functions (1,1), (2,1), ..., (P,1), (1,2), (2,2), ..., C (P,2), ..., (1,M), (2,M), ..., (P,M); NPZ memory locations C are reserved for each transfer function, hence, the real C parts of the zeros for the (i,j) transfer function C are stored starting from the location ((j-1)*P+i-1)*NPZ+1. C Pairs of complex conjugate zeros are stored in consecutive C memory locations. Note that only the first NZ(i,j) entries C are initialized for the (i,j) transfer function. C C ZEROSI (output) DOUBLE PRECISION array, dimension (P*M*NPZ) C This array contains the imaginary parts of the zeros of C the transfer function matrix G, stored in a similar way C as the real parts of the zeros. C C POLESR (output) DOUBLE PRECISION array, dimension (P*M*NPZ) C This array contains the real parts of the poles of the C transfer function matrix G, stored in the same way as C the zeros. Note that only the first NP(i,j) entries are C initialized for the (i,j) transfer function. C C POLESI (output) DOUBLE PRECISION array, dimension (P*M*NPZ) C This array contains the imaginary parts of the poles of C the transfer function matrix G, stored in the same way as C the poles. C C GAINS (output) DOUBLE PRECISION array, dimension (LDGAIN,M) C The leading P-by-M part of this array contains the gains C of the transfer function matrix G. Specifically, C GAINS(i,j) contains the gain of the transfer function C G(i,j). C C LDGAIN INTEGER C The leading dimension of array GAINS. LDGAIN >= max(1,P). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in determining the C controllability of a single-input system (A,b) or (A',c'), C where b and c' are columns in B and C' (C transposed). If C the user sets TOL > 0, then the given value of TOL is used C as an absolute tolerance; elements with absolute value C less than TOL are considered neglijible. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used C instead, where EPS is the machine precision (see LAPACK C Library routine DLAMCH), and bc denotes the currently used C column in B or C' (see METHOD). 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) returns the optimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1, N*(N+P) + C MAX( N + MAX( N,P ), N*(2*N+3))) C If N >= P, N >= 1, the formula above can be written as C LDWORK >= N*(3*N + P + 3). 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: the QR algorithm failed to converge when trying to C compute the zeros of a transfer function; C = 2: the QR algorithm failed to converge when trying to C compute the poles of a transfer function. C The errors INFO = 1 or 2 are unlikely to appear. C C METHOD C C The routine implements the pole-zero method proposed in [1]. C This method is based on an algorithm for computing the transfer C function of a single-input single-output (SISO) system. C Let (A,b,c,d) be a SISO system. Its transfer function is computed C as follows: C C 1) Find a controllable realization (Ac,bc,cc) of (A,b,c). C 2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc). C 3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)). C 4) Compute the zeros of (Ao,bo,co,d). C 5) Compute the gain of (Ao,bo,co,d). C C This algorithm can be implemented using only orthogonal C transformations [1]. However, for better efficiency, the C implementation in TB04CD uses one elementary transformation C in Step 4 and r elementary transformations in Step 5 (to reduce C an upper Hessenberg matrix to upper triangular form). These C special elementary transformations are numerically stable C in practice. C C In the multi-input multi-output (MIMO) case, the algorithm C computes each element (i,j) of the transfer function matrix G, C for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1 C is performed once for each value of j (each column of B). The C matrices Ac and Ao result in Hessenberg form. C C REFERENCES C C [1] Varga, A. and Sima, V. C Numerically Stable Algorithm for Transfer Function Matrix C Evaluation. C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. C C NUMERICAL ASPECTS C C The algorithm is numerically stable in practice and requires about C 20*N**3 floating point operations at most, but usually much less. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, May 2002. C C REVISIONS C C - C C KEYWORDS C C Eigenvalue, state-space representation, transfer function, zeros. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, C100 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL, JOBD DOUBLE PRECISION TOL INTEGER INFO, LDA, LDB, LDC, LDD, LDGAIN, LDNP, LDNZ, $ LDWORK, M, N, NPZ, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), GAINS(LDGAIN,*), POLESI(*), $ POLESR(*), ZEROSI(*), ZEROSR(*) INTEGER IWORK(*), NP(LDNP,*), NZ(LDNZ,*) C .. Local Scalars .. DOUBLE PRECISION ANORM, DIJ, EPSN, MAXRED, TOLDEF INTEGER I, IA, IAC, IAS, IB, IC, ICC, IERR, IM, IP, $ IPM1, ITAU, ITAU1, IZ, J, JWK, JWORK, JWORK1, $ K, NCONT, WRKOPT LOGICAL DIJNZ, FNDEIG, WITHD C .. Local Arrays .. DOUBLE PRECISION Z(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DHSEQR, DLACPY, MA02AD, TB01ID, $ TB01ZD, TB04BX, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C C Test the input scalar parameters. C INFO = 0 WITHD = LSAME( JOBD, 'D' ) IF( .NOT.WITHD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) 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( NPZ.LT.0 ) 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, P ) ) THEN INFO = -12 ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN INFO = -14 ELSE IF( LDNZ.LT.MAX( 1, P ) ) THEN INFO = -16 ELSE IF( LDNP.LT.MAX( 1, P ) ) THEN INFO = -18 ELSE IF( LDGAIN.LT.MAX( 1, P ) ) THEN INFO = -24 ELSE IF( LDWORK.LT.MAX( 1, N*( N + P ) + $ MAX( N + MAX( N, P ), N*( 2*N + 3 ) ) ) $ ) THEN INFO = -28 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB04CD', -INFO ) RETURN END IF C C Quick return if possible. C DIJ = ZERO IF( MIN( N, P, M ).EQ.0 ) THEN IF( MIN( P, M ).GT.0 ) THEN C DO 20 J = 1, M C DO 10 I = 1, P NZ(I,J) = 0 NP(I,J) = 0 IF ( WITHD ) $ DIJ = D(I,J) GAINS(I,J) = DIJ 10 CONTINUE C 20 CONTINUE C END IF DWORK(1) = ONE RETURN END IF C C Prepare the computation of the default tolerance. C TOLDEF = TOL IF( TOLDEF.LE.ZERO ) THEN EPSN = DBLE( N )*DLAMCH( 'Epsilon' ) ANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) END IF C C Initializations. C IA = 1 IC = IA + N*N ITAU = IC + P*N JWORK = ITAU + N IAC = ITAU C K = 1 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 IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(S)*A*S, B <- inv(S)*B and C <- C*S, where S is a C diagonal scaling matrix. C Workspace: need N. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, IERR ) END IF C C Compute the transfer function matrix of the system (A,B,C,D), C in the pole-zero-gain form. C DO 80 J = 1, M C C Save A and C. C Workspace: need W1 = N*(N+P). C CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK(IC), P ) C C Remove the uncontrollable part of the system (A,B(J),C). C Workspace: need W1+N+MAX(N,P); C prefer larger. C CALL TB01ZD( 'No Z', N, P, DWORK(IA), N, B(1,J), DWORK(IC), P, $ NCONT, Z, 1, DWORK(ITAU), TOL, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) IF ( J.EQ.1 ) $ WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 C IB = IAC + NCONT*NCONT ICC = IB + NCONT ITAU1 = ICC + NCONT JWK = ITAU1 + NCONT IAS = ITAU1 JWORK1 = IAS + NCONT*NCONT C DO 70 I = 1, P IF ( NCONT.GT.0 ) THEN IF ( WITHD ) $ DIJ = D(I,J) C C Form the matrices of the state-space representation of C the dual system for the controllable part. C Workspace: need W2 = W1+N*(N+2). C CALL MA02AD( 'Full', NCONT, NCONT, DWORK(IA), N, $ DWORK(IAC), NCONT ) CALL DCOPY( NCONT, B(1,J), 1, DWORK(IB), 1 ) CALL DCOPY( NCONT, DWORK(IC+I-1), P, DWORK(ICC), 1 ) C C Remove the unobservable part of the system (A,B(J),C(I)). C Workspace: need W2+2*N; C prefer larger. C CALL TB01ZD( 'No Z', NCONT, 1, DWORK(IAC), NCONT, $ DWORK(ICC), DWORK(IB), 1, IP, Z, 1, $ DWORK(ITAU1), TOL, DWORK(JWK), LDWORK-JWK+1, $ IERR ) IF ( I.EQ.1 ) $ WRKOPT = MAX( WRKOPT, INT( DWORK(JWK) ) + JWK - 1 ) C IF ( IP.GT.0 ) THEN C C Save the state matrix of the minimal part. C Workspace: need W3 = W2+N*N. C CALL DLACPY( 'Full', IP, IP, DWORK(IAC), NCONT, $ DWORK(IAS), IP ) C C Compute the poles of the transfer function. C Workspace: need W3+N; C prefer larger. C CALL DHSEQR( 'Eigenvalues', 'No vectors', IP, 1, IP, $ DWORK(IAC), NCONT, POLESR(K), POLESI(K), $ Z, 1, DWORK(JWORK1), LDWORK-JWORK1+1, $ IERR ) IF ( IERR.NE.0 ) THEN INFO = 2 RETURN END IF WRKOPT = MAX( WRKOPT, $ INT( DWORK(JWORK1) ) + JWORK1 - 1 ) C C Compute the zeros of the transfer function. C IPM1 = IP - 1 DIJNZ = WITHD .AND. DIJ.NE.ZERO FNDEIG = DIJNZ .OR. IPM1.GT.0 IF ( .NOT.FNDEIG ) THEN IZ = 0 ELSE IF ( DIJNZ ) THEN C C Add the contribution due to D(i,j). C Note that the matrix whose eigenvalues have to C be computed remains in an upper Hessenberg form. C IZ = IP CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS), IP, $ DWORK(IAC), NCONT ) CALL DAXPY( IZ, -DWORK(ICC)/DIJ, DWORK(IB), 1, $ DWORK(IAC), NCONT ) ELSE IF( TOL.LE.ZERO ) $ TOLDEF = EPSN*MAX( ANORM, $ DLANGE( 'Frobenius', IP, 1, $ DWORK(IB), 1, DWORK ) $ ) C DO 30 IM = 1, IPM1 IF ( ABS( DWORK(IB+IM-1) ).GT.TOLDEF ) GO TO 40 30 CONTINUE C IZ = 0 GO TO 50 C 40 CONTINUE C C Restore (part of) the saved state matrix. C IZ = IP - IM CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS+IM*(IP+1)), $ IP, DWORK(IAC), NCONT ) C C Apply the output injection. C CALL DAXPY( IZ, -DWORK(IAS+IM*(IP+1)-IP)/ $ DWORK(IB+IM-1), DWORK(IB+IM), 1, $ DWORK(IAC), NCONT ) END IF C IF ( FNDEIG ) THEN C C Find the zeros. C Workspace: need W3+N; C prefer larger. C CALL DHSEQR( 'Eigenvalues', 'No vectors', IZ, 1, $ IZ, DWORK(IAC), NCONT, ZEROSR(K), $ ZEROSI(K), Z, 1, DWORK(JWORK1), $ LDWORK-JWORK1+1, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 RETURN END IF END IF C C Compute the gain. C 50 CONTINUE IF ( DIJNZ ) THEN GAINS(I,J) = DIJ ELSE CALL TB04BX( IP, IZ, DWORK(IAS), IP, DWORK(ICC), $ DWORK(IB), DIJ, POLESR(K), POLESI(K), $ ZEROSR(K), ZEROSI(K), GAINS(I,J), $ IWORK ) END IF NZ(I,J) = IZ NP(I,J) = IP ELSE C C Null element. C NZ(I,J) = 0 NP(I,J) = 0 END IF C ELSE C C Null element. C NZ(I,J) = 0 NP(I,J) = 0 END IF C K = K + NPZ 70 CONTINUE C 80 CONTINUE C RETURN C *** Last line of TB04CD *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01WD.f0000644000000000000000000000013015012430707016166 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MC01WD.f0000644000175000017500000000722415012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE MC01WD( DP, P, U1, U2, Q, INFO ) C C PURPOSE C C To compute, for a given real polynomial P(x) and a quadratic C polynomial B(x), the quotient polynomial Q(x) and the linear C remainder polynomial R(x) such that C C P(x) = B(x) * Q(x) + R(x), C C 2 C where B(x) = u1 + u2 * x + x , R(x) = q(1) + q(2) * (u2 + x) C and u1, u2, q(1) and q(2) are real scalars. C C ARGUMENTS C C Input/Output Parameters C C DP (input) INTEGER C The degree of the polynomial P(x). DP >= 0. C C P (input) DOUBLE PRECISION array, dimension (DP+1) C This array must contain the coefficients of P(x) in C increasing powers of x. C C U1 (input) DOUBLE PRECISION C The value of the constant term of the quadratic C polynomial B(x). C C U2 (input) DOUBLE PRECISION C The value of the coefficient of x of the quadratic C polynomial B(x). C C Q (output) DOUBLE PRECISION array, dimension (DP+1) C If DP >= 1 on entry, then elements Q(1) and Q(2) contain C the coefficients q(1) and q(2), respectively, of the C remainder polynomial R(x), and the next (DP-1) elements C of this array contain the coefficients of the quotient C polynomial Q(x) in increasing powers of x. C If DP = 0 on entry, then element Q(1) contains the C coefficient q(1) of the remainder polynomial R(x) = q(1); C Q(x) is the zero polynomial. 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 Given the real polynomials C C DP i 2 C P(x) = SUM p(i+1) * x and B(x) = u1 + u2 * x + x C i=0 C C the routine uses the recurrence relationships C C q(DP+1) = p(DP+1), C C q(DP) = p(DP) - u2 * q(DP+1) and C C q(i) = p(i) - u2 * q(i+1) - u1 * q(i+2) for i = DP-1, ..., 1 C C to determine the coefficients of the quotient polynomial C C DP-2 i C Q(x) = SUM q(i+3) * x C i=0 C C and the remainder polynomial C C R(x) = q(1) + q(2) * (u2 + x). C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01KD by A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Elementary polynomial operations, polynomial operations, C quadratic polynomial. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER DP, INFO DOUBLE PRECISION U1, U2 C .. Array Arguments .. DOUBLE PRECISION P(*), Q(*) C .. Local Scalars .. INTEGER I, N DOUBLE PRECISION A, B, C C .. External Subroutines .. EXTERNAL XERBLA C .. Executable Statements .. C C Test the input scalar arguments. C IF ( DP.LT.0 ) THEN INFO = -1 CALL XERBLA( 'MC01WD', -INFO ) RETURN END IF C INFO = 0 N = DP + 1 Q(N) = P(N) IF ( N.GT.1 ) THEN B = Q(N) Q(N-1) = P(N-1) - U2*B IF ( N.GT.2 ) THEN A = Q(N-1) C DO 20 I = N - 2, 1, -1 C = P(I) - U2*A - U1*B Q(I) = C B = A A = C 20 CONTINUE C END IF END IF C RETURN C *** Last line of MC01WD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03BB.f0000644000000000000000000000013215012430707016142 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03BB.f0000644000175000017500000003277515012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE MB03BB( BASE, LGBAS, ULP, K, AMAP, S, SINV, A, LDA1, $ LDA2, ALPHAR, ALPHAI, BETA, SCAL, DWORK, INFO ) C C PURPOSE C C To compute the eigenvalues of a general 2-by-2 matrix product via C a complex single shifted periodic QZ algorithm. C C ARGUMENTS C C Input/Output Parameters C C BASE (input) DOUBLE PRECISION C Machine base. C C LGBAS (input) DOUBLE PRECISION C Logarithm of BASE. C C ULP (input) DOUBLE PRECISION C Machine precision. C C K (input) INTEGER C The number of factors. K >= 1. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input) DOUBLE PRECISION array, dimension (LDA1,LDA2,K) C On entry, the leading 2-by-2-by-K part of this array must C contain a 2-by-2 product (implicitly represented by its K C factors) in upper Hessenberg-triangular form. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= 2. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= 2. C C ALPHAR (output) DOUBLE PRECISION array, dimension (2) C On exit, this array contains the scaled real part of the C two eigenvalues. If BETA(I) <> 0, then the I-th eigenvalue C (I = 1 : 2) is given by C (ALPHAR(I) + ALPHAI(I)*SQRT(-1) ) * (BASE)**SCAL(I). C C ALPHAI (output) DOUBLE PRECISION array, dimension (2) C On exit, this array contains the scaled imaginary part of C the two eigenvalues. ALPHAI(1) >= 0. C C BETA (output) DOUBLE PRECISION array, dimension (2) C On exit, this array contains information about infinite C eigenvalues. If BETA(I) = 0, then the I-th eigenvalue is C infinite. Otherwise, BETA(I) = 1.0. C C SCAL (output) INTEGER array, dimension (2) C On exit, this array contains the scaling exponents for the C two eigenvalues. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (8*K) C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: the periodic QZ algorithm did not converge; C = 2: the computed eigenvalues might be inaccurate. C Both values might be taken as warnings, since C approximations of eigenvalues are returned. C C METHOD C C A complex single shifted periodic QZ iteration is applied. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLACP2. C V. Sima, June 2010, July 2010, Aug. 2011, Sep. 2011, Oct. 2011. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. INTEGER INFO, K, LDA1, LDA2, SINV DOUBLE PRECISION BASE, LGBAS, ULP C .. Array Arguments .. DOUBLE PRECISION A(LDA1,LDA2,*), ALPHAI(2), ALPHAR(2), BETA(2), $ DWORK(*) INTEGER AMAP(*), S(*), SCAL(2) C .. Local Scalars .. INTEGER AI, I, IITER, J, PDM, PDW, SL DOUBLE PRECISION CS, CST, LHS, MISC, MISR, RHS, TEMPI, TEMPR COMPLEX*16 SN, SNT, TEMP C .. Local Arrays .. COMPLEX*16 T(2,2), Z(3,3) C .. External Functions .. DOUBLE PRECISION DLAPY2 EXTERNAL DLAPY2 C .. External Subroutines .. EXTERNAL DLADIV, ZLARTG, ZROT C .. Intrinsic Functions .. INTRINSIC ABS, DCMPLX, DCONJG, DBLE, DIMAG, DREAL, INT, $ LOG, MAX, MIN, MOD, SQRT C C .. Executable Statements .. C C Apply a complex single shifted periodic QZ iteration. C This might not be efficient but it seems to be reliable. C INFO = 0 PDW = 0 C DO 10 I = 1, K AI = AMAP(I) DWORK(PDW+1) = A(1,1,AI) DWORK(PDW+2) = ZERO DWORK(PDW+3) = A(2,1,AI) DWORK(PDW+4) = ZERO DWORK(PDW+5) = A(1,2,AI) DWORK(PDW+6) = ZERO DWORK(PDW+7) = A(2,2,AI) DWORK(PDW+8) = ZERO PDW = PDW + 8 10 CONTINUE C PDM = PDW C DO 40 IITER = 1, 80 C C Test for deflation. C LHS = DLAPY2( DWORK(3), DWORK(4) ) RHS = MAX( DLAPY2( DWORK(1), DWORK(2) ), $ DLAPY2( DWORK(7), DWORK(8) ) ) IF ( RHS.EQ.ZERO ) $ RHS = DLAPY2( DWORK(5), DWORK(6) ) IF ( LHS.LE.ULP*RHS ) $ GO TO 50 C C Start Iteration. C IF ( IITER.EQ.1 ) THEN C C Compute a randomly chosen initial unitary shift. C CALL ZLARTG( DCMPLX( ONE, -TWO ), DCMPLX( TWO, TWO ), CS, $ SN, TEMP ) ELSE IF ( MOD( IITER, 40 ).EQ.0 ) THEN C C Ad hoc shift. C CALL ZLARTG( DCMPLX( DBLE( I ), ONE ), DCMPLX( ONE, -TWO ), $ CS, SN, TEMP ) ELSE C C Compute the shift by a product QR decomposition. C CS = ONE SN = CZERO CALL ZLARTG( CONE, CONE, CST, SNT, TEMP ) PDW = PDM C DO 20 I = K, 2, -1 PDW = PDW - 8 TEMP = DCMPLX( DWORK(PDW+1), DWORK(PDW+2) ) Z(1,1) = TEMP Z(2,1) = CZERO Z(3,1) = CZERO Z(1,2) = CZERO Z(2,2) = TEMP Z(3,2) = DCMPLX( DWORK(PDW+3), DWORK(PDW+4) ) Z(1,3) = CZERO Z(2,3) = DCMPLX( DWORK(PDW+5), DWORK(PDW+6) ) Z(3,3) = DCMPLX( DWORK(PDW+7), DWORK(PDW+8) ) IF ( S(AMAP(I)).EQ.SINV ) THEN CALL ZROT( 3, Z(1,1), 1, Z(1,3), 1, CST, DCONJG( SNT ) $ ) CALL ZROT( 3, Z(1,1), 1, Z(1,2), 1, CS, DCONJG( SN ) $ ) CALL ZLARTG( Z(1,1), Z(3,1), CST, SNT, TEMP ) CALL ZLARTG( TEMP, Z(2,1), CS, SN, TEMP ) ELSE CALL ZROT( 3, Z(1,1), 3, Z(3,1), 3, CST, SNT ) CALL ZROT( 3, Z(1,1), 3, Z(2,1), 3, CS, SN ) TEMP = Z(3,3) CALL ZLARTG( TEMP, Z(3,1), CST, SNT, Z(3,3) ) SNT = -SNT CALL ZROT( 2, Z(1,1), 1, Z(1,3), 1, CST, DCONJG( SNT ) $ ) TEMP = Z(2,2) CALL ZLARTG( TEMP, Z(2,1), CS, SN, Z(2,2) ) SN = -SN END IF 20 CONTINUE C PDW = 0 Z(1,1) = DCMPLX( DWORK(PDW+1), DWORK(PDW+2) ) Z(2,1) = DCMPLX( DWORK(PDW+3), DWORK(PDW+4) ) Z(1,2) = -DCMPLX( DWORK(PDW+3), DWORK(PDW+4) ) Z(2,2) = CZERO Z(1,3) = -DCMPLX( DWORK(PDW+7), DWORK(PDW+8) ) Z(2,3) = CZERO CALL ZROT( 2, Z(1,1), 1, Z(1,3), 1, CST, DCONJG( SNT ) ) CALL ZROT( 2, Z(1,1), 1, Z(1,2), 1, CS, DCONJG( SN ) ) CALL ZLARTG( Z(1,1), Z(2,1), CS, SN, TEMP ) END IF CST = CS SNT = SN PDW = PDM C DO 30 I = K, 2, -1 PDW = PDW - 8 T(1,1) = DCMPLX( DWORK(PDW+1), DWORK(PDW+2) ) T(2,1) = DCMPLX( DWORK(PDW+3), DWORK(PDW+4) ) T(1,2) = DCMPLX( DWORK(PDW+5), DWORK(PDW+6) ) T(2,2) = DCMPLX( DWORK(PDW+7), DWORK(PDW+8) ) IF ( S(AMAP(I)).EQ.SINV) THEN CALL ZROT( 2, T(1,1), 1, T(1,2), 1, CS, DCONJG( SN ) ) TEMP = T(1,1) CALL ZLARTG( TEMP, T(2,1), CS, SN, T(1,1) ) T(2,1) = CZERO CALL ZROT( 1, T(1,2), 2, T(2,2), 2, CS, SN ) ELSE CALL ZROT( 2, T(1,1), 2, T(2,1), 2, CS, SN ) TEMP = T(2,2) CALL ZLARTG( TEMP, T(2,1), CS, SN, T(2,2) ) T(2,1) = CZERO SN = -SN CALL ZROT( 1, T(1,1), 1, T(1,2), 1, CS, DCONJG( SN ) ) END IF DWORK(PDW+1) = DREAL( T(1,1) ) DWORK(PDW+2) = DIMAG( T(1,1) ) DWORK(PDW+3) = DREAL( T(2,1) ) DWORK(PDW+4) = DIMAG( T(2,1) ) DWORK(PDW+5) = DREAL( T(1,2) ) DWORK(PDW+6) = DIMAG( T(1,2) ) DWORK(PDW+7) = DREAL( T(2,2) ) DWORK(PDW+8) = DIMAG( T(2,2) ) 30 CONTINUE C PDW = 0 T(1,1) = DCMPLX( DWORK(PDW+1), DWORK(PDW+2) ) T(2,1) = DCMPLX( DWORK(PDW+3), DWORK(PDW+4) ) T(1,2) = DCMPLX( DWORK(PDW+5), DWORK(PDW+6) ) T(2,2) = DCMPLX( DWORK(PDW+7), DWORK(PDW+8) ) CALL ZROT( 2, T(1,1), 2, T(2,1), 2, CST, SNT ) CALL ZROT( 2, T(1,1), 1, T(1,2), 1, CS, DCONJG( SN ) ) DWORK(PDW+1) = DREAL( T(1,1) ) DWORK(PDW+2) = DIMAG( T(1,1) ) DWORK(PDW+3) = DREAL( T(2,1) ) DWORK(PDW+4) = DIMAG( T(2,1) ) DWORK(PDW+5) = DREAL( T(1,2) ) DWORK(PDW+6) = DIMAG( T(1,2) ) DWORK(PDW+7) = DREAL( T(2,2) ) DWORK(PDW+8) = DIMAG( T(2,2) ) 40 CONTINUE C C Not converged. Set INFO = 1, but continue. C INFO = 1 C 50 CONTINUE C C Converged. C DO 70 J = 1, 2 PDW = 0 IF ( J.EQ.2 ) $ PDW = 6 TEMPI = ZERO TEMPR = ONE BETA(J) = ONE SCAL(J) = 0 C DO 60 I = 1, K RHS = DLAPY2( DWORK(PDW+1), DWORK(PDW+2) ) IF ( RHS.NE.ZERO ) THEN SL = INT( LOG( RHS ) / LGBAS ) DWORK(PDW+1) = DWORK(PDW+1) / ( BASE**DBLE( SL ) ) DWORK(PDW+2) = DWORK(PDW+2) / ( BASE**DBLE( SL ) ) ELSE SL = 0 END IF IF ( S(AMAP(I)).EQ.1 ) THEN LHS = TEMPI TEMPI = TEMPR*DWORK(PDW+2) + TEMPI*DWORK(PDW+1) TEMPR = TEMPR*DWORK(PDW+1) - LHS*DWORK(PDW+2) SCAL(J) = SCAL(J) + SL ELSE IF ( RHS.EQ.ZERO ) THEN BETA(J) = ZERO ELSE LHS = TEMPR RHS = TEMPI CALL DLADIV( LHS, RHS, DWORK(PDW+1), DWORK(PDW+2), $ TEMPR, TEMPI ) SCAL(J) = SCAL(J) - SL END IF IF ( ( MOD( I, 10 ).EQ.0 ) .OR. ( I.EQ.K ) ) THEN RHS = DLAPY2( TEMPR, TEMPI ) IF ( RHS.EQ.ZERO ) THEN SCAL(J) = 0 ELSE SL = INT( LOG( RHS ) / LGBAS ) TEMPR = TEMPR / ( BASE**DBLE( SL ) ) TEMPI = TEMPI / ( BASE**DBLE( SL ) ) SCAL(J) = SCAL(J) + SL END IF END IF PDW = PDW + 8 60 CONTINUE C ALPHAR(J) = TEMPR ALPHAI(J) = TEMPI 70 CONTINUE C IF ( TEMPI.GT.ZERO ) THEN ALPHAR(2) = ALPHAR(1) ALPHAI(2) = ALPHAI(1) ALPHAR(1) = TEMPR ALPHAI(1) = TEMPI TEMPR = BETA(2) BETA(2) = BETA(1) BETA(1) = TEMPR TEMPR = SCAL(2) SCAL(2) = SCAL(1) SCAL(1) = TEMPR END IF C C Enforce the needed eigenvalue structure for real matrices. C IF ( ALPHAI(1).NE.ZERO .OR. ALPHAI(2).NE.ZERO ) THEN C C Decide if there are two real or complex conjugate eigenvalues. C IF ( SCAL(1).GE.SCAL(2) ) THEN SL = SCAL(1) - SCAL(2) TEMPR = ALPHAR(2) / BASE**DBLE( SL ) TEMPI = ALPHAI(2) / BASE**DBLE( SL ) LHS = ALPHAR(1) - TEMPR RHS = ALPHAI(1) + TEMPI CST = ALPHAI(1) ELSE SL = SCAL(2) - SCAL(1) TEMPR = ALPHAR(1) / BASE**DBLE( SL ) TEMPI = ALPHAI(1) / BASE**DBLE( SL ) LHS = ALPHAR(2) - TEMPR RHS = ALPHAI(2) + TEMPI CST = ALPHAI(2) END IF C MISR = DLAPY2( CST, TEMPI ) MISC = DLAPY2( LHS, RHS ) / TWO C CS = MAX( DLAPY2( ALPHAR(1), ALPHAI(1) ), ONE, $ DLAPY2( ALPHAR(2), ALPHAI(2) ) ) IF ( MIN( MISR, MISC ).GT.CS*SQRT( ULP ) ) $ INFO = 2 C IF ( MISR.GT.MISC ) THEN C C Conjugate eigenvalues. C IF ( SCAL(1).GE.SCAL(2) ) THEN ALPHAR(1) = ( ALPHAR(1) + TEMPR ) / TWO ALPHAI(1) = ABS( ALPHAI(1) - TEMPI ) / TWO SCAL(2) = SCAL(1) ELSE ALPHAR(1) = ( ALPHAR(2) + TEMPR ) / TWO ALPHAI(1) = ABS( ALPHAI(2) - TEMPI ) / TWO SCAL(1) = SCAL(2) END IF ALPHAR(2) = ALPHAR(1) ALPHAI(2) = -ALPHAI(1) ELSE C C Two real eigenvalues. C ALPHAI(1) = ZERO ALPHAI(2) = ZERO END IF END IF C RETURN C *** Last line of MB03BB *** END control-4.1.2/src/slicot/src/PaxHeaders/TC01OD.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TC01OD.f0000644000175000017500000001530215012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2, $ QCOEFF, LDQCO1, LDQCO2, INFO ) C C PURPOSE C C To find the dual right (left) polynomial matrix representation of C a given left (right) polynomial matrix representation, where the C right and left polynomial matrix representations are of the form C Q(s)*inv(P(s)) and inv(P(s))*Q(s) respectively. C C ARGUMENTS C C Mode Parameters C C LERI CHARACTER*1 C Indicates whether a left or right matrix fraction is input C as follows: C = 'L': A left matrix fraction is input; C = 'R': A right matrix fraction is input. C C Input/Output Parameters 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 INDLIM (input) INTEGER C The highest value of K for which PCOEFF(.,.,K) and C QCOEFF(.,.,K) are to be transposed. C K = kpcoef + 1, where kpcoef is the maximum degree of the C polynomials in P(s). INDLIM >= 1. C C PCOEFF (input/output) DOUBLE PRECISION array, dimension C (LDPCO1,LDPCO2,INDLIM) C If LERI = 'L' then porm = P, otherwise porm = M. C On entry, the leading porm-by-porm-by-INDLIM part of this C array must contain the coefficients of the denominator C matrix P(s). C PCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of C polynomial (I,J) of P(s), where K = 1,2,...,INDLIM. C On exit, the leading porm-by-porm-by-INDLIM part of this C array contains the coefficients of the denominator matrix C P'(s) of the dual system. C C LDPCO1 INTEGER C The leading dimension of array PCOEFF. C LDPCO1 >= MAX(1,P) if LERI = 'L', C LDPCO1 >= MAX(1,M) if LERI = 'R'. C C LDPCO2 INTEGER C The second dimension of array PCOEFF. C LDPCO2 >= MAX(1,P) if LERI = 'L', C LDPCO2 >= MAX(1,M) if LERI = 'R'. C C QCOEFF (input/output) DOUBLE PRECISION array, dimension C (LDQCO1,LDQCO2,INDLIM) C On entry, the leading P-by-M-by-INDLIM part of this array C must contain the coefficients of the numerator matrix C Q(s). C QCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of C polynomial (I,J) of Q(s), where K = 1,2,...,INDLIM. C On exit, the leading M-by-P-by-INDLIM part of the array C contains the coefficients of the numerator matrix Q'(s) C of the dual system. C C LDQCO1 INTEGER C The leading dimension of array QCOEFF. C LDQCO1 >= MAX(1,M,P). C C LDQCO2 INTEGER C The second dimension of array QCOEFF. C LDQCO2 >= MAX(1,M,P). 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 If the given M-input/P-output left (right) polynomial matrix C representation has numerator matrix Q(s) and denominator matrix C P(s), its dual P-input/M-output right (left) polynomial matrix C representation simply has numerator matrix Q'(s) and denominator C matrix P'(s). C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TC01CD by T.W.C.Williams, Kingston C Polytechnic, United Kingdom, March 1982. C C REVISIONS C C - C C KEYWORDS C C Coprime matrix fraction, elementary polynomial operations, C polynomial matrix, state-space representation, transfer matrix. C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER LERI INTEGER INFO, INDLIM, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M, $ P C .. Array Arguments .. DOUBLE PRECISION PCOEFF(LDPCO1,LDPCO2,*), QCOEFF(LDQCO1,LDQCO2,*) C .. Local Scalars .. LOGICAL LLERI INTEGER J, K, MINMP, MPLIM, PORM C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C INFO = 0 LLERI = LSAME( LERI, 'L' ) MPLIM = MAX( M, P ) MINMP = MIN( M, P ) C C Test the input scalar arguments. C IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( P.LT.0 ) THEN INFO = -3 ELSE IF( INDLIM.LT.1 ) THEN INFO = -4 ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN INFO = -6 ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN INFO = -7 ELSE IF( LDQCO1.LT.MAX( 1, MPLIM ) ) THEN INFO = -9 ELSE IF( LDQCO2.LT.MAX( 1, MPLIM ) ) THEN INFO = -10 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TC01OD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( M.EQ.0 .OR. P.EQ.0 ) $ RETURN C IF ( MPLIM.NE.1 ) THEN C C Non-scalar system: transpose numerator matrix Q(s). C DO 20 K = 1, INDLIM C DO 10 J = 1, MPLIM IF ( J.LT.MINMP ) THEN CALL DSWAP( MINMP-J, QCOEFF(J+1,J,K), 1, $ QCOEFF(J,J+1,K), LDQCO1 ) ELSE IF ( J.GT.P ) THEN CALL DCOPY( P, QCOEFF(1,J,K), 1, QCOEFF(J,1,K), $ LDQCO1 ) ELSE IF ( J.GT.M ) THEN CALL DCOPY( M, QCOEFF(J,1,K), LDQCO1, QCOEFF(1,J,K), $ 1 ) END IF 10 CONTINUE C 20 CONTINUE C C Find dimension of denominator matrix P(s): M (P) for C right (left) polynomial matrix representation. C PORM = M IF ( LLERI ) PORM = P IF ( PORM.NE.1 ) THEN C C Non-scalar P(s): transpose it. C DO 40 K = 1, INDLIM C DO 30 J = 1, PORM - 1 CALL DSWAP( PORM-J, PCOEFF(J+1,J,K), 1, $ PCOEFF(J,J+1,K), LDPCO1 ) 30 CONTINUE C 40 CONTINUE C END IF END IF C RETURN C *** Last line of TC01OD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10QD.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10QD.f0000644000175000017500000004627415012430707017400 0ustar00lilgelilge00000000000000 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 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 with D21 = | 0 I | as obtained by the C subroutine SB10PD, C C (A3) | A-j*omega*I B2 | has full column rank for all omega, C | C1 D12 | C C C (A4) | A-j*omega*I B1 | has full row rank for all omega. C | C2 D21 | C 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 F (output) DOUBLE PRECISION array, dimension (LDF,N) C The leading M-by-N part of this array contains the state C feedback matrix F. C C LDF INTEGER C The leading dimension of the array F. LDF >= max(1,M). C C H (output) DOUBLE PRECISION array, dimension (LDH,NP) C The leading N-by-NP part of this array contains the output C injection matrix H. C C LDH INTEGER C The leading dimension of the array H. LDH >= max(1,N). 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 Y (output) DOUBLE PRECISION array, dimension (LDY,N) C The leading N-by-N part of this array contains the matrix C Y, solution of the Y-Riccati equation. C C LDY INTEGER C The leading dimension of the array Y. LDY >= max(1,N). C C XYCOND (output) DOUBLE PRECISION array, dimension (2) C XYCOND(1) contains an estimate of the reciprocal condition C number of the X-Riccati equation; C XYCOND(2) contains an estimate of the reciprocal condition C number of the Y-Riccati equation. C C Workspace C C IWORK INTEGER array, dimension C (max(2*max(N,M-NCON,NP-NMEAS),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(1,M*M + max(2*M1,3*N*N + C 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 where M1 = M - M2 and NP1 = NP - NP2. C For good performance, LDWORK must generally be larger. C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is C max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))). 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 controller is not admissible (too small value C of gamma); C = 2: if the X-Riccati equation was not solved C successfully (the controller is not admissible or C there are numerical difficulties); C = 3: if the Y-Riccati equation was not solved C successfully (the controller is not admissible or C there are numerical difficulties). C C METHOD C C The routine implements the Glover's and Doyle's formulas [1],[2] C modified as described in [3]. The X- and Y-Riccati equations C are solved with condition and accuracy estimates [4]. 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 [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. C DGRSVX and DMSRIC: Fortan 77 subroutines for solving C continuous-time matrix algebraic Riccati equations with C condition and accuracy estimates. C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. C Chemnitz, May 1998. C C NUMERICAL ASPECTS C C The precision of the solution of the matrix Riccati equations C can be controlled by the values of the condition numbers C XYCOND(1) and XYCOND(2) of these equations. C C FURTHER COMMENTS C C The Riccati equations are solved by the Schur approach C implementing condition and accuracy estimates. 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. 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, LDB, LDC, LDD, LDF, LDH, LDWORK, $ LDX, LDY, M, N, NCON, NMEAS, NP DOUBLE PRECISION GAMMA C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), DWORK( * ), F( LDF, * ), $ H( LDH, * ), X( LDX, * ), XYCOND( 2 ), $ Y( LDY, * ) LOGICAL BWORK( * ) C C .. C .. Local Scalars .. INTEGER INFO2, IW2, IWA, IWG, IWI, IWQ, IWR, IWRK, IWS, $ IWT, IWV, LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, $ NN, NP1, NP2 DOUBLE PRECISION ANORM, EPS, FERR, RCOND, SEP C .. C .. External Functions .. C DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL DLAMCH, DLANSY C .. C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, DSYCON, DSYMM, DSYRK, $ DSYTRF, DSYTRI, MB01RU, MB01RX, SB02RD, 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 NN = N*N 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( LDF.LT.MAX( 1, M ) ) THEN INFO = -16 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -20 ELSE IF( LDY.LT.MAX( 1, N ) ) THEN INFO = -22 ELSE C C Compute workspace. C MINWRK = MAX( 1, M*M + MAX( 2*M1, 3*NN + $ MAX( N*M, 10*NN + 12*N + 5 ) ), $ NP*NP + MAX( 2*NP1, 3*NN + $ MAX( N*NP, 10*NN + 12*N + 5 ) ) ) IF( LDWORK.LT.MINWRK ) $ INFO = -26 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10QD', -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 XYCOND( 1 ) = ONE XYCOND( 2 ) = ONE DWORK( 1 ) = ONE RETURN END IF ND1 = NP1 - M2 ND2 = M1 - NP2 N2 = 2*N C C Get the machine precision. C EPS = DLAMCH( 'Epsilon' ) C C Workspace usage. C IWA = M*M + 1 IWQ = IWA + NN IWG = IWQ + NN IW2 = IWG + NN C C Compute |D1111'||D1111 D1112| - gamma^2*Im1 . C |D1112'| C CALL DLASET( 'L', M1, M1, ZERO, -GAMMA*GAMMA, DWORK, M ) IF( ND1.GT.0 ) $ CALL DSYRK( 'L', 'T', M1, ND1, ONE, D, LDD, ONE, DWORK, M ) C C Compute inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . C |D1112'| C IWRK = IWA ANORM = DLANSY( 'I', 'L', M1, DWORK, M, DWORK( IWRK ) ) CALL DSYTRF( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF C LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 CALL DSYCON( 'L', M1, DWORK, M, IWORK, ANORM, RCOND, $ DWORK( IWRK ), IWORK( M1+1 ), INFO2 ) IF( RCOND.LT.EPS ) THEN INFO = 1 RETURN END IF C C Compute inv(R) block by block. C CALL DSYTRI( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), INFO2 ) C C Compute -|D1121 D1122|*inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . C |D1112'| C CALL DSYMM( 'R', 'L', M2, M1, -ONE, DWORK, M, D( ND1+1, 1 ), LDD, $ ZERO, DWORK( M1+1 ), M ) C C Compute |D1121 D1122|*inv(|D1111'|*|D1111 D1112| - C |D1112'| C C gamma^2*Im1)*|D1121'| + Im2 . C |D1122'| C CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( M1*(M+1)+1 ), M ) CALL MB01RX( 'Right', 'Lower', 'Transpose', M2, M1, ONE, -ONE, $ DWORK( M1*(M+1)+1 ), M, D( ND1+1, 1 ), LDD, $ DWORK( M1+1 ), M, INFO2 ) C C Compute D11'*C1 . C CALL DGEMM( 'T', 'N', M1, N, NP1, ONE, D, LDD, C, LDC, ZERO, $ DWORK( IW2 ), M ) C C Compute D1D'*C1 . C CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, DWORK( IW2+M1 ), $ M ) C C Compute inv(R)*D1D'*C1 in F . C CALL DSYMM( 'L', 'L', M, N, ONE, DWORK, M, DWORK( IW2 ), M, ZERO, $ F, LDF ) C C Compute Ax = A - B*inv(R)*D1D'*C1 . C CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, F, LDF, ONE, $ DWORK( IWA ), N ) C C Compute Cx = C1'*C1 - C1'*D1D*inv(R)*D1D'*C1 . C IF( ND1.EQ.0 ) THEN CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) ELSE CALL DSYRK( 'L', 'T', N, NP1, ONE, C, LDC, ZERO, $ DWORK( IWQ ), N ) CALL MB01RX( 'Left', 'Lower', 'Transpose', N, M, ONE, -ONE, $ DWORK( IWQ ), N, DWORK( IW2 ), M, F, LDF, INFO2 ) END IF C C Compute Dx = B*inv(R)*B' . C IWRK = IW2 CALL MB01RU( 'Lower', 'NoTranspose', N, M, ZERO, ONE, $ DWORK( IWG ), N, B, LDB, DWORK, M, DWORK( IWRK ), $ M*N, INFO2 ) C C Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 . C Workspace: need M*M + 13*N*N + 12*N + 5; C prefer larger. C IWT = IW2 IWV = IWT + NN IWR = IWV + NN IWI = IWR + N2 IWS = IWI + N2 IWRK = IWS + 4*NN C CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose', $ 'Lower', 'GeneralScaling', 'Stable', 'NotFactored', $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, $ X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ), $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 2 RETURN END IF C LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Compute F = -inv(R)*|D1D'*C1 + B'*X| . C IWRK = IW2 CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, X, LDX, ZERO, $ DWORK( IWRK ), M ) CALL DSYMM( 'L', 'L', M, N, -ONE, DWORK, M, DWORK( IWRK ), M, $ -ONE, F, LDF ) C C Workspace usage. C IWA = NP*NP + 1 IWQ = IWA + NN IWG = IWQ + NN IW2 = IWG + NN C C Compute |D1111|*|D1111' D1121'| - gamma^2*Inp1 . C |D1121| C CALL DLASET( 'U', NP1, NP1, ZERO, -GAMMA*GAMMA, DWORK, NP ) IF( ND2.GT.0 ) $ CALL DSYRK( 'U', 'N', NP1, ND2, ONE, D, LDD, ONE, DWORK, NP ) C C Compute inv(|D1111|*|D1111' D1121'| - gamma^2*Inp1) . C |D1121| C IWRK = IWA ANORM = DLANSY( 'I', 'U', NP1, DWORK, NP, DWORK( IWRK ) ) CALL DSYTRF( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF C LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) CALL DSYCON( 'U', NP1, DWORK, NP, IWORK, ANORM, RCOND, $ DWORK( IWRK ), IWORK( NP1+1 ), INFO2 ) IF( RCOND.LT.EPS ) THEN INFO = 1 RETURN END IF C C Compute inv(RT) . C CALL DSYTRI( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), INFO2 ) C C Compute -inv(|D1111||D1111' D1121'| - gamma^2*Inp1)*|D1112| . C |D1121| |D1122| C CALL DSYMM( 'L', 'U', NP1, NP2, -ONE, DWORK, NP, D( 1, ND2+1 ), $ LDD, ZERO, DWORK( NP1*NP+1 ), NP ) C C Compute [D1112' D1122']*inv(|D1111||D1111' D1121'| - C |D1121| C C gamma^2*Inp1)*|D1112| + Inp2 . C |D1122| C CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( NP1*(NP+1)+1 ), $ NP ) CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, NP1, ONE, -ONE, $ DWORK( NP1*(NP+1)+1 ), NP, D( 1, ND2+1 ), LDD, $ DWORK( NP1*NP+1 ), NP, INFO2 ) C C Compute B1*D11' . C CALL DGEMM( 'N', 'T', N, NP1, M1, ONE, B, LDB, D, LDD, ZERO, $ DWORK( IW2 ), N ) C C Compute B1*DD1' . C CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, $ DWORK( IW2+NP1*N ), N ) C C Compute B1*DD1'*inv(RT) in H . C CALL DSYMM( 'R', 'U', N, NP, ONE, DWORK, NP, DWORK( IW2 ), N, $ ZERO, H, LDH ) C C Compute Ay = A - B1*DD1'*inv(RT)*C . C CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) CALL DGEMM( 'N', 'N', N, N, NP, -ONE, H, LDH, C, LDC, ONE, $ DWORK( IWA ), N ) C C Compute Cy = B1*B1' - B1*DD1'*inv(RT)*DD1*B1' . C IF( ND2.EQ.0 ) THEN CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) ELSE CALL DSYRK( 'U', 'N', N, M1, ONE, B, LDB, ZERO, DWORK( IWQ ), $ N ) CALL MB01RX( 'Right', 'Upper', 'Transpose', N, NP, ONE, -ONE, $ DWORK( IWQ ), N, H, LDH, DWORK( IW2 ), N, INFO2 ) END IF C C Compute Dy = C'*inv(RT)*C . C IWRK = IW2 CALL MB01RU( 'Upper', 'Transpose', N, NP, ZERO, ONE, DWORK( IWG ), $ N, C, LDC, DWORK, NP, DWORK( IWRK), N*NP, INFO2 ) C C Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 . C Workspace: need NP*NP + 13*N*N + 12*N + 5; C prefer larger. C IWT = IW2 IWV = IWT + NN IWR = IWV + NN IWI = IWR + N2 IWS = IWI + N2 IWRK = IWS + 4*NN C CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose', $ 'Upper', 'GeneralScaling', 'Stable', 'NotFactored', $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, $ Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ), $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 3 RETURN END IF C LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Compute H = -|B1*DD1' + Y*C'|*inv(RT) . C IWRK = IW2 CALL DGEMM( 'N', 'T', N, NP, N, ONE, Y, LDY, C, LDC, ZERO, $ DWORK( IWRK ), N ) CALL DSYMM( 'R', 'U', N, NP, -ONE, DWORK, NP, DWORK( IWRK ), N, $ -ONE, H, LDH ) C DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10QD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04PA.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04PA.f0000644000175000017500000013600315012430707017357 0ustar00lilgelilge00000000000000 SUBROUTINE MB04PA( LHAM, N, K, NB, A, LDA, QG, LDQG, XA, LDXA, $ XG, LDXG, XQ, LDXQ, YA, LDYA, CS, TAU, DWORK ) C C PURPOSE C C To reduce a Hamiltonian like matrix C C [ A G ] T T C H = [ T ] , G = G , Q = Q, C [ Q -A ] C C or a skew-Hamiltonian like matrix C C [ A G ] T T C W = [ T ] , G = -G , Q = -Q, C [ Q A ] C C so that elements below the (k+1)-th subdiagonal in the first nb C columns of the (k+n)-by-n matrix A, and offdiagonal elements C in the first nb columns and rows of the n-by-n matrix Q are zero. C C The reduction is performed by an orthogonal symplectic C transformation UU'*H*UU and matrices U, XA, XG, XQ, and YA are C returned so that C C [ Aout + U*XA'+ YA*U' Gout + U*XG'+ XG*U' ] C UU'*H*UU = [ ]. C [ Qout + U*XQ'+ XQ*U' -Aout'- XA*U'- U*YA' ] C C Similarly, C C [ Aout + U*XA'+ YA*U' Gout + U*XG'- XG*U' ] C UU'*W*UU = [ ]. C [ Qout + U*XQ'- XQ*U' Aout'+ XA*U'+ U*YA' ] C C This is an auxiliary routine called by MB04PB. C C ARGUMENTS C C Mode Parameters C C LHAM LOGICAL C Specifies the type of matrix to be reduced: C = .FALSE. : skew-Hamiltonian like W; C = .TRUE. : Hamiltonian like H. C C Input/Output Parameters C C N (input) INTEGER C The number of columns of the matrix A. N >= 0. C C K (input) INTEGER C The offset of the reduction. Elements below the (K+1)-th C subdiagonal in the first NB columns of A are reduced C to zero. K >= 0. C C NB (input) INTEGER C The number of columns/rows to be reduced. N > NB >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading (K+N)-by-N part of this array must C contain the matrix A. C On exit, the leading (K+N)-by-N part of this array C contains the matrix Aout and in the zero part C information about the elementary reflectors used to C compute the reduction. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,K+N). C C QG (input/output) DOUBLE PRECISION array, dimension C (LDQG,N+1) C On entry, the leading N+K-by-N+1 part of this array must C contain in the bottom left part the lower triangular part C of the N-by-N matrix Q and in the remainder the upper C trapezoidal part of the last N columns of the N+K-by-N+K C matrix G. C On exit, the leading N+K-by-N+1 part of this array C contains parts of the matrices Q and G in the same fashion C as on entry only that the zero parts of Q contain C information about the elementary reflectors used to C compute the reduction. Note that if LHAM = .FALSE. then C the (K-1)-th and K-th subdiagonals are not referenced. C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N+K). C C XA (output) DOUBLE PRECISION array, dimension (LDXA,2*NB) C On exit, the leading N-by-(2*NB) part of this array C contains the matrix XA. C C LDXA INTEGER C The leading dimension of the array XA. LDXA >= MAX(1,N). C C XG (output) DOUBLE PRECISION array, dimension (LDXG,2*NB) C On exit, the leading (K+N)-by-(2*NB) part of this array C contains the matrix XG. C C LDXG INTEGER C The leading dimension of the array XG. LDXG >= MAX(1,K+N). C C XQ (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB) C On exit, the leading N-by-(2*NB) part of this array C contains the matrix XQ. C C LDXQ INTEGER C The leading dimension of the array XQ. LDXQ >= MAX(1,N). C C YA (output) DOUBLE PRECISION array, dimension (LDYA,2*NB) C On exit, the leading (K+N)-by-(2*NB) part of this array C contains the matrix YA. C C LDYA INTEGER C The leading dimension of the array YA. LDYA >= MAX(1,K+N). C C CS (output) DOUBLE PRECISION array, dimension (2*NB) C On exit, the first 2*NB elements of this array contain the C cosines and sines of the symplectic Givens rotations used C to compute the reduction. C C TAU (output) DOUBLE PRECISION array, dimension (NB) C On exit, the first NB elements of this array contain the C scalar factors of some of the elementary reflectors. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (3*NB) C C METHOD C C For details regarding the representation of the orthogonal C symplectic matrix UU within the arrays A, QG, CS, TAU see the C description of MB04PU. C C The contents of A and QG on exit are illustrated by the following C example with n = 5, k = 2 and nb = 2: C C ( a r r a a ) ( g g r r g g ) C ( a r r a a ) ( g g r r g g ) C ( a r r a a ) ( q g r r g g ) C A = ( r r r r r ), QG = ( t r r r r r ), C ( u2 r r r r ) ( u1 t r r r r ) C ( u2 u2 r a a ) ( u1 u1 r q g g ) C ( u2 u2 r a a ) ( u1 u1 r q q g ) C C where a, g and q denote elements of the original matrices, r C denotes a modified element, t denotes a scalar factor of an C applied elementary reflector and ui denote elements of the C matrix U. C C REFERENCES C C [1] C. F. VAN LOAN: C A symplectic method for approximating all the eigenvalues of C a Hamiltonian matrix. C Linear Algebra and its Applications, 61, pp. 233-251, 1984. C C [2] D. KRESSNER: C Block algorithms for orthogonal symplectic factorizations. C BIT, 43 (4), pp. 775-790, 2003. C C CONTRIBUTORS C C D. Kressner (Technical Univ. Berlin, Germany) and C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. C C REVISIONS C C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DLAPVL). C C KEYWORDS C C Elementary matrix operations, Hamiltonian matrix, C skew-Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D+0 ) C .. Scalar Arguments .. LOGICAL LHAM INTEGER K, LDA, LDQG, LDXA, LDXG, LDXQ, LDYA, N, NB C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*), $ XA(LDXA,*), XG(LDXG,*), XQ(LDXQ,*), YA(LDYA,*) C .. Local Scalars .. INTEGER I, J, NB1, NB2 DOUBLE PRECISION AKI, ALPHA, C, S, TAUQ, TEMP, TTEMP C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. External Subroutines .. EXTERNAL DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL, $ DSYMV, MB01MD C .. Intrinsic Functions .. INTRINSIC MIN C C .. Executable Statements .. C C Quick return if possible. C IF ( N+K.LE.0 ) THEN DWORK(1) = ONE RETURN END IF C NB1 = NB + 1 NB2 = NB + NB1 C IF ( LHAM ) THEN DO 50 I = 1, NB C C Transform i-th columns of A and Q. See routine MB04PU. C ALPHA = QG(K+I+1,I) CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ ) QG(K+I+1,I) = ONE TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) AKI = A(K+I+1,I) CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) ) AKI = A(K+I+1,I) CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) ) A(K+I+1,I) = ONE C C Update XA with first Householder reflection. C C xa = H(1:n,1:n)'*u1 CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, $ QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 ) C w1 = U1'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG, $ QG(K+I+1,I), 1, ZERO, DWORK, 1 ) C xa = xa + XA1*w1 CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, $ DWORK, 1, ONE, XA(I+1,I), 1 ) C w2 = U2'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 ) C xa = xa + XA2*w2 CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 ) C temp = YA1'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) C xa = xa + U1*temp CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), $ LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 ) C temp = YA2'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) C xa = xa + U2*temp CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) C xa = -tauq*xa CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) C C Update YA with first Householder reflection. C C ya = H(1:n,1:n)*u1 CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, $ QG(K+I+1,I), 1, ZERO, YA(1,I), 1 ) C temp = XA1'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) C ya = ya + U1*temp CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1), $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) C temp = XA2'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA, $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) C ya = ya + U2*temp CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) C ya = ya + YA1*w1 CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, $ DWORK, 1, ONE, YA(1,I), 1 ) C ya = ya + YA2*w2 CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB1), 1, ONE, YA(1,I), 1 ) C ya = -tauq*ya CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) C temp = -tauq*ya'*u1 TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) C ya = ya + temp*u1 CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) C C Update (i+1)-th column of A. C C A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) C A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) C A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)'; CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA, $ QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 ) C A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)'; CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA, $ A(K+I+1,1), LDA, ONE, A(1,I+1), 1 ) C C Update (i+1)-th row of A. C IF ( N.GT.I+1 ) THEN C A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)' CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), $ LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2), $ LDA ) C A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)' CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), $ LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2), $ LDA ) C A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)' CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), $ LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2), $ LDA ) C A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)' CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), $ LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2), $ LDA ) END IF C C Annihilate updated parts in YA. C DO 10 J = 1, I YA(K+I+1,J) = ZERO 10 CONTINUE DO 20 J = 1, I-1 YA(K+I+1,NB+J) = ZERO 20 CONTINUE C C Update XQ with first Householder reflection. C C xq = Q*u1 CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, $ QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 ) C xq = xq + XQ1*w1 CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, $ DWORK, 1, ONE, XQ(I+1,I), 1 ) C xq = xq + XQ2*w2 CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 ) C temp = XQ1'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) C xq = xq + U1*temp CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), $ LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) C temp = XQ2'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ, $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) C xq = xq + U2*temp CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) C xq = -tauq*xq CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) C temp = -tauq/2*xq'*u1 TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) C xq = xq + temp*u1 CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) C C Update (i+1)-th column and row of Q. C C Q(:,i+1) = Q(:,i+1) + U1 * XQ1(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, $ XQ(I+1,1), LDXQ, ONE, QG(K+I+1,I+1), 1 ) C Q(:,i+1) = Q(:,i+1) + U2 * XQ2(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ XQ(I+1,NB1), LDXQ, ONE, QG(K+I+1,I+1), 1 ) C Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, $ QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+1), 1 ) C Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+1), 1 ) C C Update XG with first Householder reflection. C C xg = G*u1 CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, $ QG(K+I+1,I), 1, ZERO, XG(1,I), 1 ) CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, $ QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 ) C xg = xg + XG1*w1 CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, $ DWORK, 1, ONE, XG(1,I), 1 ) C xg = xg + XG2*w2 CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 ) C temp = XG1'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ, $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) C xg = xg + U1*temp CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) C temp = XG2'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1), $ LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) C xg = xg + U2*temp CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) C xg = -tauq*xg CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 ) C temp = -tauq/2*xq'*u1 TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I), $ 1 ) C xg = xg + temp*u1 CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 ) C C Update (i+1)-th column and row of G. C C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG, $ QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 ) C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG, $ A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 ) C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, $ QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+2), LDQG ) C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I-1, ONE, XG(K+I+1,NB1), $ LDXG, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+2), $ LDQG ) C G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, $ XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+2), LDQG ) C G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+2), LDQG ) C C Annihilate updated parts in XG. C DO 30 J = 1, I XG(K+I+1,J) = ZERO 30 CONTINUE DO 40 J = 1, I-1 XG(K+I+1,NB+J) = ZERO 40 CONTINUE C C Apply orthogonal symplectic Givens rotation. C CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) IF ( N.GT.I+1 ) THEN CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG, $ C, S ) CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1, C, $ S ) END IF TEMP = A(K+I+1,I+1) TTEMP = QG(K+I+1,I+2) A(K+I+1,I+1) = C*TEMP + S*QG(K+I+1,I+1) QG(K+I+1,I+2) = C*TTEMP - S*TEMP QG(K+I+1,I+1) = -S*TEMP + C*QG(K+I+1,I+1) TTEMP = -S*TTEMP - C*TEMP TEMP = A(K+I+1,I+1) QG(K+I+1,I+1) = C*QG(K+I+1,I+1) + S*TTEMP A(K+I+1,I+1) = C*TEMP + S*QG(K+I+1,I+2) QG(K+I+1,I+2) = -S*TEMP + C*QG(K+I+1,I+2) CS(2*I-1) = C CS(2*I) = S QG(K+I+1,I) = TAUQ C C Update XA with second Householder reflection. C C xa = H(1:n,1:n)'*u2 CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, $ A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 ) IF ( N.GT.I+1 ) THEN C w1 = U1'*u2 CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1), $ LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 ) C xa = xa + XA1*w1 CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), $ LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 ) C w2 = U2'*u2 CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1), $ LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 ) C xa = xa + XA2*w2 CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), $ LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 ) C temp = YA1'*u2 CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1), $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) C xa = xa + U1*temp CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), $ LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) C temp = YA2'*u1 CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1), $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) C xa = xa + U2*temp CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), $ LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) END IF C xa = -tau*xa CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 ) C C Update YA with second Householder reflection. C C ya = H(1:n,1:n)*u2 CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, $ A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 ) IF ( N.GT.I+1 ) THEN C temp = XA1'*u2 CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, $ A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) C ya = ya + U1*temp CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) C temp = XA2'*u1 CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1), $ LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) C ya = ya + U2*temp CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), $ LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) END IF C ya = ya + YA1*w1 CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, $ DWORK, 1, ONE, YA(1,NB+I), 1 ) C ya = ya + YA2*w2 CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB1), 1, ONE, YA(1,NB+I), 1 ) C ya = -tau*ya CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 ) C temp = -tau*ya'*u2 TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) C ya = ya + temp*u2 CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) C C Update (i+1)-th column of A. C C H(1:n,i+1) = H(1:n,i+1) + ya CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 ) C H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2 CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1), $ 1 ) C C Update (i+1)-th row of A. C IF ( N.GT.I+1 ) THEN C H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)'; CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2), $ LDA ) C H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)' CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1, $ A(K+I+1,I+2), LDA ) END IF C C Annihilate updated parts in YA. C YA(K+I+1,NB+I) = ZERO C C Update XQ with second Householder reflection. C C xq = Q*u2 CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, $ A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 ) IF ( N.GT.I+1 ) THEN C xq = xq + XQ1*w1 CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), $ LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 ) C xq = xq + XQ2*w2 CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 ) C temp = XQ1'*u2 CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, $ A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) C xq = xq + U1*temp CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), $ LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) C temp = XQ2'*u2 CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), $ LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) C xq = xq + U2*temp CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), $ LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) END IF C xq = -tauq*xq CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 ) C temp = -tauq/2*xq'*u2 TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I), $ 1 ) C xq = xq + temp*u2 CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 ) C C Update (i+1)-th column and row of Q. C CALL DAXPY( N-I, ONE, XQ(I+1,NB+I), 1, QG(K+I+1,I+1), 1 ) C H(1:n,n+i+1) = H(1:n,n+i+1) + U * XQ(i+1,:)'; CALL DAXPY( N-I, XQ(I+1,NB+I), A(K+I+1,I), 1, $ QG(K+I+1,I+1), 1 ) C C Update XG with second Householder reflection. C C xg = G*u2 CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, $ A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 ) CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, $ A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 ) C xg = xg + XG1*w1 CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, $ DWORK, 1, ONE, XG(1,NB+I), 1 ) C xg = xg + XG2*w2 CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 ) IF ( N.GT.I+1 ) THEN C temp = XG1'*u2 CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) C xg = xg + U1*temp CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) C temp = XG2'*u2 CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1), $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) C xg = xg + U2*temp CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), $ LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) END IF C xg = -tauq*xg CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 ) C temp = -tauq/2*xg'*u1 TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, $ XG(K+I+1,NB+I), 1 ) C xg = xg + temp*u1 CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 ) C C Update (i+1)-th column and row of G. C CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 ) CALL DAXPY( N-I, ONE, XG(K+I+1,NB+I), 1, QG(K+I+1,I+2), $ LDQG ) CALL DAXPY( N-I, XG(K+I+1,NB+I), A(K+I+1,I), 1, $ QG(K+I+1,I+2), LDQG ) C C Annihilate updated parts in XG. C XG(K+I+1,NB+I) = ZERO C A(K+I+1,I) = AKI 50 CONTINUE ELSE DO 100 I = 1, NB C C Transform i-th columns of A and Q. C ALPHA = QG(K+I+1,I) CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ ) QG(K+I+1,I) = ONE TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) AKI = A(K+I+1,I) CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) ) AKI = A(K+I+1,I) CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) ) A(K+I+1,I) = ONE C C Update XA with first Householder reflection. C C xa = H(1:n,1:n)'*u1 CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, $ QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 ) C w1 = U1'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG, $ QG(K+I+1,I), 1, ZERO, DWORK, 1 ) C xa = xa + XA1*w1 CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, $ DWORK, 1, ONE, XA(I+1,I), 1 ) C w2 = U2'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 ) C xa = xa + XA2*w2 CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), $ LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 ) C temp = YA1'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) C xa = xa + U1*temp CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), $ LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 ) C temp = YA2'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) C xa = xa + U2*temp CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) C xa = -tauq*xa CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) C C Update YA with first Householder reflection. C C ya = H(1:n,1:n)*u1 CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, $ QG(K+I+1,I), 1, ZERO, YA(1,I), 1 ) C temp = XA1'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) C ya = ya + U1*temp CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1), $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) C temp = XA2'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA, $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) C ya = ya + U2*temp CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) C ya = ya + YA1*w1 CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, $ DWORK, 1, ONE, YA(1,I), 1 ) C ya = ya + YA2*w2 CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB1), 1, ONE, YA(1,I), 1 ) C ya = -tauq*ya CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) C temp = -tauq*ya'*u1 TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) C ya = ya + temp*u1 CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) C C Update (i+1)-th column of A. C C A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) C A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)'; CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) C A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)'; CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA, $ QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 ) C A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)'; CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA, $ A(K+I+1,1), LDA, ONE, A(1,I+1), 1 ) C C Update (i+1)-th row of A. C IF ( N.GT.I+1 ) THEN C A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)' CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), $ LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2), $ LDA ) C A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)' CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), $ LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2), $ LDA ) C A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)' CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), $ LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2), $ LDA ) C A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)' CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), $ LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2), $ LDA ) END IF C C Annihilate updated parts in YA. C DO 60 J = 1, I YA(K+I+1,J) = ZERO 60 CONTINUE DO 70 J = 1, I-1 YA(K+I+1,NB+J) = ZERO 70 CONTINUE C C Update XQ with first Householder reflection. C C xq = Q*u1 CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, $ QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 ) C xq = xq + XQ1*w1 CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, $ DWORK, 1, ONE, XQ(I+1,I), 1 ) C xq = xq + XQ2*w2 CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 ) C temp = XQ1'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) C xq = xq - U1*temp CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1), $ LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) C temp = XQ2'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ, $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) C xq = xq - U2*temp CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA, $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) C xq = -tauq*xq CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) C temp = -tauq/2*xq'*u1 TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) C xq = xq + temp*u1 CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) C C Update (i+1)-th column and row of Q. C IF ( N.GT.I+1 ) THEN C Q(:,i+1) = Q(:,i+1) - U1 * XQ1(i+1,:)'; CALL DGEMV( 'No transpose', N-I-1, I, -ONE, QG(K+I+2,1), $ LDQG, XQ(I+1,1), LDXQ, ONE, QG(K+I+2,I+1), $ 1 ) C Q(:,i+1) = Q(:,i+1) - U2 * XQ2(i+1,:)'; CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE, A(K+I+2,1), $ LDA, XQ(I+1,NB1), LDXQ, ONE, QG(K+I+2,I+1), $ 1 ) C Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)'; CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), $ LDXQ, QG(K+I+1,1), LDQG, ONE, QG(K+I+2,I+1), $ 1 ) C Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)'; CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), $ LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+2,I+1), $ 1 ) END IF C C Update XG with first Householder reflection. C C xg = G*u1 CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, $ QG(K+I+1,I), 1, ZERO, XG(1,I), 1 ) CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, $ QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 ) C xg = xg + XG1*w1 CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, $ DWORK, 1, ONE, XG(1,I), 1 ) C xg = xg + XG2*w2 CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 ) C temp = XG1'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ, $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) C xg = xg - U1*temp CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1), $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) C temp = XG2'*u1 CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1), $ LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) C xg = xg - U2*temp CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA, $ DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) C xg = -tauq*xg CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 ) C temp = -tauq/2*xq'*u1 TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I), $ 1 ) C xg = xg + temp*u1 CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 ) C C Update (i+1)-th column and row of G. C C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG, $ QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 ) C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG, $ A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 ) IF ( N.GT.I+1 ) THEN C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; CALL DGEMV( 'No transpose', N-I-1, I, -ONE, XG(K+I+2,1), $ LDXG, QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+3), $ LDQG ) C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE, $ XG(K+I+2,NB1), LDXG, A(K+I+1,1), LDA, ONE, $ QG(K+I+1,I+3), LDQG ) C G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)'; CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), $ LDQG, XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+3), $ LDQG ) C G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)'; CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), $ LDA, XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+3), $ LDQG ) END IF C C Annihilate updated parts in XG. C DO 80 J = 1, I XG(K+I+1,J) = ZERO 80 CONTINUE DO 90 J = 1, I-1 XG(K+I+1,NB+J) = ZERO 90 CONTINUE C C Apply orthogonal symplectic Givens rotation. C CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) IF ( N.GT.I+1 ) THEN CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG, $ C, -S ) CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1, $ C, -S ) END IF CS(2*I-1) = C CS(2*I) = S QG(K+I+1,I) = TAUQ C C Update XA with second Householder reflection. C C xa = H(1:n,1:n)'*u2 CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, $ A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 ) IF ( N.GT.I+1 ) THEN C w1 = U1'*u2 CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1), $ LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 ) C xa = xa + XA1*w1 CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), $ LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 ) C w2 = U2'*u2 CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1), $ LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 ) C xa = xa + XA2*w2 CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), $ LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 ) C temp = YA1'*u2 CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1), $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) C xa = xa + U1*temp CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), $ LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) C temp = YA2'*u1 CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1), $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) C xa = xa + U2*temp CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), $ LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) END IF C xa = -tau*xa CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 ) C C Update YA with second Householder reflection. C C ya = H(1:n,1:n)*u2 CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, $ A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 ) IF ( N.GT.I+1 ) THEN C temp = XA1'*u2 CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, $ A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) C ya = ya + U1*temp CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) C temp = XA2'*u1 CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1), $ LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) C ya = ya + U2*temp CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), $ LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) END IF C ya = ya + YA1*w1 CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, $ DWORK, 1, ONE, YA(1,NB+I), 1 ) C ya = ya + YA2*w2 CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, $ DWORK(NB1), 1, ONE, YA(1,NB+I), 1 ) C ya = -tau*ya CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 ) C temp = -tau*ya'*u2 TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) C ya = ya + temp*u2 CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) C C Update (i+1)-th column of A. C C H(1:n,i+1) = H(1:n,i+1) + ya CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 ) C H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2 CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1), $ 1 ) C C Update (i+1)-th row of A. C IF ( N.GT.I+1 ) THEN C H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)'; CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2), $ LDA ) C H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)' CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1, $ A(K+I+1,I+2), LDA ) END IF C C Annihilate updated parts in YA. C YA(K+I+1,NB+I) = ZERO C C Update XQ with second Householder reflection. C C xq = Q*u2 CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, $ A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 ) IF ( N.GT.I+1 ) THEN C xq = xq + XQ1*w1 CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), $ LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 ) C xq = xq + XQ2*w2 CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 ) C temp = XQ1'*u2 CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, $ A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) C xq = xq - U1*temp CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1), $ LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) C temp = XQ2'*u2 CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), $ LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) C xq = xq - U2*temp CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1), $ LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) END IF C xq = -tauq*xq CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 ) C temp = -tauq/2*xq'*u2 TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I), $ 1 ) C xq = xq + temp*u2 CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 ) C C Update (i+1)-th column and row of Q. C IF ( N.GT.I+1 ) THEN CALL DAXPY( N-I-1, ONE, XQ(I+2,NB+I), 1, QG(K+I+2,I+1), $ 1 ) C H(1:n,n+i+1) = H(1:n,n+i+1) - U * XQ(i+1,:)'; CALL DAXPY( N-I-1, -XQ(I+1,NB+I), A(K+I+2,I), 1, $ QG(K+I+2,I+1), 1 ) END IF C C Update XG with second Householder reflection. C C xg = G*u2 CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, $ A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 ) CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, $ A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 ) C xg = xg + XG1*w1 CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, $ DWORK, 1, ONE, XG(1,NB+I), 1 ) C xg = xg + XG2*w2 CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), $ LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 ) IF ( N.GT.I+1 ) THEN C temp = XG1'*u2 CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) C xg = xg - U1*temp CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1), $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) C temp = XG2'*u2 CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1), $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) C xg = xg - U2*temp CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1), $ LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) END IF C xg = -tauq*xg CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 ) C temp = -tauq/2*xg'*u1 TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, $ XG(K+I+1,NB+I), 1 ) C xg = xg + temp*u1 CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 ) C C Update (i+1)-th column and row of G. C CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 ) IF ( N.GT.I+1 ) THEN CALL DAXPY( N-I-1, -ONE, XG(K+I+2,NB+I), 1, $ QG(K+I+1,I+3), LDQG ) CALL DAXPY( N-I-1, XG(K+I+1,NB+I), A(K+I+2,I), 1, $ QG(K+I+1,I+3), LDQG ) END IF C C Annihilate updated parts in XG. C XG(K+I+1,NB+I) = ZERO C A(K+I+1,I) = AKI 100 CONTINUE END IF C RETURN C *** Last line of MB04PA *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01ND.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01ND.f0000644000175000017500000001657515012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE MB01ND( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) C C PURPOSE C C To perform the skew-symmetric rank 2 operation C C A := alpha*x*y' - alpha*y*x' + A, C C where alpha is a scalar, x and y are vectors of length n and A is C an n-by-n skew-symmetric matrix. C C This is a modified version of the vanilla implemented BLAS C routine DSYR2 written by Jack Dongarra, Jeremy Du Croz, C Sven Hammarling, and Richard Hanson. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies whether the upper or lower triangular part of C the array A is to be referenced as follows: C = 'U': only the strictly upper triangular part of A is to C be referenced; C = 'L': only the strictly lower triangular part of A is to C be referenced. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C ALPHA (input) DOUBLE PRECISION C The scalar alpha. If alpha is zero X and Y are not C referenced. C C X (input) DOUBLE PRECISION array, dimension C ( 1 + ( N - 1 )*abs( INCX ) ). C On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of C this array must contain the elements of the vector X. C C INCX (input) INTEGER C The increment for the elements of X. IF INCX < 0 then the C elements of X are accessed in reversed order. INCX <> 0. C C Y (input) DOUBLE PRECISION array, dimension C ( 1 + ( N - 1 )*abs( INCY ) ). C On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of C this array must contain the elements of the vector Y. C C INCY (input) INTEGER C The increment for the elements of Y. IF INCY < 0 then the C elements of Y are accessed in reversed order. INCY <> 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry with UPLO = 'U', the leading N-by-N part of this C array must contain the strictly upper triangular part of C the matrix A. The lower triangular part of this array is C not referenced. C On entry with UPLO = 'L', the leading N-by-N part of this C array must contain the strictly lower triangular part of C the matrix A. The upper triangular part of this array is C not referenced. C On exit with UPLO = 'U', the leading N-by-N part of this C array contains the strictly upper triangular part of the C updated matrix A. C On exit with UPLO = 'L', the leading N-by-N part of this C array contains the strictly lower triangular part of the C updated matrix A. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N) C C NUMERICAL ASPECTS C C Though being almost identical with the vanilla implementation C of the BLAS routine DSYR2 the performance of this routine could C be significantly lower in the case of vendor supplied, highly C optimized BLAS. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, May 2008 (SLICOT version of the HAPACK routine DSKR2). C C KEYWORDS C C Elementary matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, INCY, LDA, N CHARACTER UPLO C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) C .. Local Scalars .. DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF ( N.LT.0 )THEN INFO = 2 ELSE IF ( INCX.EQ.0 )THEN INFO = 5 ELSE IF ( INCY.EQ.0 )THEN INFO = 7 ELSE IF ( LDA.LT.MAX( 1, N ) )THEN INFO = 9 END IF C IF ( INFO.NE.0 )THEN CALL XERBLA( 'MB01ND', INFO ) RETURN END IF C C Quick return if possible. C IF ( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN C C Set up the start points in X and Y if the increments are not both C unity. C IF ( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN IF ( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX END IF IF ( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY END IF JX = KX JY = KY END IF C C Start the operations. In this version the elements of A are C accessed sequentially with one pass through the triangular part C of A. C IF ( LSAME( UPLO, 'U' ) )THEN C C Form A when A is stored in the upper triangle. C IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN DO 20 J = 2, N IF ( ( X(J).NE.ZERO ).OR.( Y(J).NE.ZERO ) )THEN TEMP1 = ALPHA*Y(J) TEMP2 = ALPHA*X(J) DO 10 I = 1, J-1 A(I,J) = A(I,J) + X(I)*TEMP1 - Y(I)*TEMP2 10 CONTINUE END IF 20 CONTINUE ELSE DO 40 J = 2, N IF ( ( X(JX).NE.ZERO ).OR.( Y(JY).NE.ZERO ) )THEN TEMP1 = ALPHA*Y(JY) TEMP2 = ALPHA*X(JX) IX = KX IY = KY DO 30 I = 1, J-1 A(I,J) = A(I,J) + X(IX)*TEMP1 - Y(IY)*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE END IF JX = JX + INCX JY = JY + INCY 40 CONTINUE END IF ELSE C C Form A when A is stored in the lower triangle. C IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN DO 60 J = 1, N-1 IF ( ( X(J).NE.ZERO ).OR.( Y(J).NE.ZERO ) )THEN TEMP1 = ALPHA*Y(J) TEMP2 = ALPHA*X(J) DO 50 I = J+1, N A(I,J) = A(I,J) + X(I)*TEMP1 - Y(I)*TEMP2 50 CONTINUE END IF 60 CONTINUE ELSE DO 80 J = 1, N-1 IF ( ( X(JX).NE.ZERO ).OR.( Y(JY).NE.ZERO ) )THEN TEMP1 = ALPHA*Y(JY) TEMP2 = ALPHA*X(JX) IX = JX IY = JY DO 70 I = J+1, N A(I,J) = A(I,J) + X(IX)*TEMP1 - Y(IY)*TEMP2 IX = IX + INCX IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX JY = JY + INCY 80 CONTINUE END IF END IF RETURN C *** Last line of MB01ND *** END control-4.1.2/src/slicot/src/PaxHeaders/SB01BD.f0000644000000000000000000000013015012430707016146 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB01BD.f0000644000175000017500000006661015012430707017355 0ustar00lilgelilge00000000000000 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 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 Dec. 29, 2012, V. Sima, Research Institute for Informatics, C Bucharest. 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 DCOPY, 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 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 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 ) THEN IF( K.LE.NPR ) THEN CALL DSWAP( K, WR(NPR+1), 1, WR, 1 ) ELSE CALL DCOPY( K, WR(NPR+1), 1, DWORK, 1 ) CALL DCOPY( NPR, WR, 1, DWORK(K+1), 1 ) CALL DCOPY( K+NPR, DWORK, 1, WR, 1 ) END IF END IF 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 control-4.1.2/src/slicot/src/PaxHeaders/SG02CX.f0000644000000000000000000000013215012430707016203 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SG02CX.f0000644000175000017500000006156315012430707017412 0ustar00lilgelilge00000000000000 SUBROUTINE SG02CX( JOBE, FLAG, JOBG, UPLO, TRANS, N, M, E, LDE, R, $ LDR, S, LDS, G, LDG, ALPHA, RNORM, DWORK, $ LDWORK, IWARN, INFO ) C C PURPOSE C C To find the line search parameter alpha minimizing the Frobenius C norm (in a MATLAB-style notation) C C P(alpha) := norm(R(X+alpha*S), 'fro') C = norm((1-alpha)*R(X) +/- alpha^2*V, 'fro'), C C where R(X) is the residual of a (generalized) continuous-time C algebraic Riccati equation C C 0 = op(A)'*X + X*op(A) +/- X*G*X + Q =: R(X), C or C 0 = op(A)'*X*op(E) + op(E)'*X*op(A) +/- op(E)'*X*G*X*op(E) + Q C =: R(X), C C V = op(E)'*S*G*S*op(E), and op(W) is either W or W'. The matrix S C is the Newton step. C _-1 C Instead of the symmetric N-by-N matrix G, G = B*R *B', the N-by-M C -1 C matrix D, D = B*L , such that G = D*D', may be given on entry. C _ _ C The matrix R, R = L'*L, is a weighting matrix of the optimal C problem, and L is its (Cholesky) factor. C C Optionally, V is specified as V = H*K, or V = F*F', but F or H and C K must be evaluated in S. See the SLICOT Library routine SG02CW C description for more details. C C ARGUMENTS C C Mode Parameters C C JOBE CHARACTER*1 C Specifies whether E is a general or an identity matrix, C as follows: C = 'G': The matrix E is general and is given; C = 'I': The matrix E is assumed identity and is not given. C C FLAG CHARACTER*1 C Specifies which sign is used, as follows: C = 'P': The plus sign is used; C = 'M': The minus sign is used. C C JOBG CHARACTER*1 C Specifies how the matrix product V is defined, as follows: C = 'G': The matrix G is given: V = op(E)'*S*G*S*op(E); C = 'D': The matrix D is given: V = op(E)'*S*D*D'*S*op(E); C = 'F': The matrix F is given: V = F*F'; C = 'H': The matrices H and K are given: V = H*K. C C UPLO CHARACTER*1 C Specifies which triangles of the symmetric matrices R, G, C if JOBG = 'G', and S, if JOBG = 'G' or JOBG = 'D', are C 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(W) to be used in the matrix C multiplication, as follows: C = 'N': op(W) = W; C = 'T': op(W) = W'; C = 'C': op(W) = W'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices E, R, and S. N >= 0. C C M (input) INTEGER C If JOBG <> 'G', the number of columns of the matrices D, C F, or K'. M >= 0. C If JOBG = 'G', the value of M is meaningless. C C E (input) DOUBLE PRECISION array, dimension (LDE,*) C If JOBE = 'G' and (JOBG = 'G' or JOBG = 'D'), the leading C N-by-N part of this array must contain the matrix E. C If JOBE = 'I' or JOBG = 'F' or JOBG = 'H', this array is C not referenced. C C LDE INTEGER C The leading dimension of array E. C LDE >= MAX(1,N), if JOBE = 'G' and (JOBG = 'G' or C JOBG = 'D'); C LDE >= 1, if JOBE = 'I' or JOBG = 'F' or C JOBG = 'H'. C C R (input) DOUBLE PRECISION array, dimension (LDR,N) C The leading N-by-N upper or lower triangular part C (depending on UPLO) of this array must contain the upper C or lower triangular part, respectively, of the matrix C R(X), the residual of the algebraic Riccati equation. C The other strictly triangular part is not referenced. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C S (input) DOUBLE PRECISION array, dimension (LDS,*) C If JOBG = 'G' or JOBG = 'D', the leading N-by-N part of C this array must contain the symmetric Newton step C matrix S. If JOBE = 'I', the full matrix must be given. C Otherwise, it is sufficient to input only the triangular C part specified by UPLO, and the remaining strictly C triangular part is not referenced. C If JOBG = 'F', this array is not referenced. C If JOBG = 'H', the leading M-by-N part of this array must C contain the matrix K. C C LDS INTEGER C The leading dimension of array S. C LDS >= MAX(1,N), if JOBG = 'G' or JOBG = 'D'; C LDS >= 1, if JOBG = 'F'; C LDS >= MAX(1,M), if JOBG = 'H'. C C G (input/works.) DOUBLE PRECISION array, dimension (LDG,*) C If JOBG = 'G', the leading N-by-N upper or lower C triangular part (depending on UPLO) of this array must C contain the upper or lower triangular part, respectively, C of the matrix G. The other strictly triangular part is not C referenced. The diagonal elements of this array are C modified internally, but are restored on exit. C If JOBG = 'D', the leading N-by-M part of this array must C contain the matrix D, so that G = D*D'. C If JOBG = 'F', the leading N-by-M part of this array must C contain the matrix F. C If JOBG = 'H', leading N-by-M part of this array must C contain the matrix H. C C LDG INTEGER C The leading dimension of array G. LDG >= MAX(1,N). C C ALPHA (output) DOUBLE PRECISION C If INFO = 0, ALPHA contains the real number alpha which C minimizes P(alpha) = norm(R(X+alpha*S), 'fro') in the C interval [0,2]. C If INFO = 1 or IWARN = 2, ALPHA is set equal to 1. C C RNORM (output) DOUBLE PRECISION C On exit, if INFO >= 0, RNORM contains the Frobenius norm C of the residual R(X+alpha*S). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if LDWORK = -1 on input, then DWORK(1) returns C the optimal value of LDWORK. C On exit, if LDWORK = -2 on input or INFO = -19, then C DWORK(1) returns the minimal value of LDWORK. C On exit, if INFO = 0, the leading N-by-N upper or lower C triangular part (depending on UPLO) of this array contains C the corresponding triangular part of the matrix V. C C LDWORK The length of the array DWORK. C LDWORK >= N*N + MAX( 2*N*N, 51 ), C if JOBG = 'G' and JOBE = 'G'; C LDWORK >= N*N + MAX( N*N, 51 ), C if JOBG = 'G' and JOBE = 'I', C or JOBG = 'F', or JOBG = 'H'; C LDWORK >= N*N + MAX( MAX( N*N, 51 ), MIN( 2*N*N, N*M ) ), C if JOBG = 'D' and JOBE = 'G'; C LDWORK >= N*N + MAX( N*N, N*M, 51 ), C if JOBG = 'D' and JOBE = 'I'. C For M <= N, the last two formulas simplify to C LDWORK >= N*N + MAX( N*N, 51). C C If LDWORK = -1, an optimal workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C If LDWORK = -2, a minimal workspace query is assumed; the C routine only calculates the minimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C Warning Indicator C C IWARN INTEGER C = 0: no warnings; C = 2: no optimal line search parameter t := alpha in [0,2] C was found; t = 1 was set. 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 = 1: an error occurred during the call of the SLICOT C Library routine MC01XD: the eigenvalues computation C for the 3-by-3 (generalized) eigenproblem failed. C ALPHA and RNORM are set as specified above. C C METHOD C C The matrix V is computed with the suitable formula, and used to C set up a third order polynomial whose roots in [0,2], if any, are C candidates for the solution of the minimum residual problem. C The roots of the polynomial are computed by solving an equivalent C 3-by-3 (generalized) eigenproblem. C C REFERENCES C C [1] Benner, P. C Contributions to the Numerical Solution of Algebraic C Riccati Equations and Related Eigenvalue Problems. C Fakultat fur Mathematik, Technische Universitat Chemnitz- C Zwickau, D-09107 Chemnitz, Germany, Feb. 1997. C C NUMERICAL ASPECTS C C The calculations are backward stable. The computational effort is C of the order of c*N**2*M operations. Here, M = N, if JOBG = 'G', C and the coefficient c varies between 0.5 and 2.5, depending on C JOBE and JOBG. (An "operation" includes a multiplication, an C addition, and some address calculations.) C The computed value of norm(R(X+alpha*S),'fro'), returned in RNORM, C could be inaccurate if R(X) is small, since then subtraction C cancellation could appear in the updating formula which is used. C (This can happen, e.g., when solving a Riccati equation by C Newton's method with line search, since then the sequence of R(.) C tends to zero.) In such a case, it is better to recompute the C residual from the data. C C FURTHER COMMENTS C C The routine does not ckeck if the matrix S is zero, when a quick C return with ALPHA = 1 is possible. C With suitable input arguments E and G, this routine may also be C used for discrete-time algebraic Riccati equations. (Matrix E C must be the current closed-loop matrix.) C C CONTRIBUTORS C C M. Slowik, Institut fur Mathematik, TU Berlin, July 2005. C P. Benner, Institut fur Mathematik, TU Chemnitz, July 2005. C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2005. C C REVISIONS C C V. Sima, Jan. 2013, Feb. 2013, Jun. 2013, Dec. 2013, Feb. 2014. C C KEYWORDS C C Algebraic Riccati equation, eigenvalues, generalized eigenproblem. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, SIX PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0, FOUR = 4.0D0, SIX = 6.0D0 ) C .. Scalar Arguments .. CHARACTER FLAG, JOBE, JOBG, TRANS, UPLO INTEGER INFO, IWARN, LDE, LDG, LDR, LDS, LDWORK, M, N DOUBLE PRECISION ALPHA, RNORM C .. Array Arguments .. DOUBLE PRECISION DWORK(*), E(LDE,*), G(LDG,*), R(LDR,*), S(LDS,*) C .. Local Scalars .. CHARACTER NT, NTRANS, SIDE, TR LOGICAL LCND, LFLAG, LJOBE, LJOBF, LJOBG, LJOBH, LJOBL, $ LQUERY, LTRANS, LUPLO, USE1, WWT INTEGER CRITNR, EVIPOS, EVQPOS, EVRPOS, I, J, NM, NMIN, $ NN, NOPT, RPOS, SP DOUBLE PRECISION BETA, DELTA, GAMMA, MX, PA, PB, PC, VNORM C .. Local Arrays .. DOUBLE PRECISION CRD(2), CRN(2) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLANSY EXTERNAL DDOT, DLANSY, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DGEMM, DLACPY, DLASCL, DSCAL, DSYMM, $ DSYRK, MB01RB, MB01RU, MC01XD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. Executable Statements .. C C Test the input scalar arguments. C IWARN = 0 INFO = 0 NN = N*N C LJOBE = LSAME( JOBE, 'G' ) LFLAG = LSAME( FLAG, 'M' ) LJOBG = LSAME( JOBG, 'G' ) LJOBF = LSAME( JOBG, 'F' ) LJOBH = LSAME( JOBG, 'H' ) LUPLO = LSAME( UPLO, 'U' ) LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) LJOBL = LJOBF .OR. LJOBH C IF ( .NOT.LJOBE .AND. .NOT.LSAME( JOBE, 'I' ) ) THEN INFO = -1 ELSE IF ( .NOT.LFLAG .AND. .NOT.LSAME( FLAG, 'P' ) ) THEN INFO = -2 ELSE IF ( .NOT.LJOBG .AND. .NOT.LSAME( JOBG, 'D' ) .AND. $ .NOT.LJOBL ) THEN INFO = -3 ELSE IF ( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -4 ELSE IF ( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN INFO = -5 ELSE IF ( N.LT.0 ) THEN INFO = -6 ELSE IF ( .NOT.LJOBG .AND. M.LT.0 ) THEN INFO = -7 ELSE IF ( LDE.LT.1 .OR. ( LJOBE .AND. .NOT.LJOBL .AND. LDE.LT.N ) $ ) THEN INFO = -9 ELSE IF ( LDR.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF ( LDS.LT.1 .OR. ( LJOBH .AND. LDS.LT.M ) .OR. $ ( .NOT.LJOBL .AND. LDS.LT.N ) ) THEN INFO = -13 ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE C C Check the needed size of the workspace. C LQUERY = LDWORK.EQ.-1 IF ( LJOBL ) THEN NMIN = NN + MAX( NN, 51 ) IF ( LQUERY ) $ NOPT = NMIN ELSE IF ( LJOBG ) THEN IF ( LJOBE ) THEN NMIN = NN + MAX( 2*NN, 51 ) ELSE NMIN = NN + MAX( NN, 51 ) END IF IF ( LQUERY ) $ NOPT = NMIN ELSE NM = N*M IF ( LJOBE ) THEN NMIN = NN + MAX( MAX( NN, 51 ), MIN( 2*NN, NM ) ) LCND = 2*M.GT.3*N IF ( LQUERY ) THEN IF ( LCND ) THEN NOPT = 3*NN ELSE NOPT = NN + NM END IF END IF ELSE NMIN = NN + MAX( NN, NM, 51 ) LCND = M.GT.3*N IF ( LQUERY ) THEN IF ( LCND ) THEN NOPT = 2*NN ELSE NOPT = NN + NM END IF END IF END IF IF ( LQUERY ) $ NOPT = MAX( NOPT, NMIN ) END IF IF ( LQUERY ) THEN C C The array DWORK should have at least 3 entries here. C CALL MC01XD( ALPHA, BETA, GAMMA, DELTA, DWORK, DWORK, DWORK, $ DWORK, -1, INFO ) NOPT = MAX( NOPT, NN + 9 + INT( DWORK(1) ) ) DWORK(1) = NOPT RETURN ELSE IF ( LDWORK.EQ.-2 ) THEN DWORK(1) = NMIN RETURN ELSE IF ( LDWORK.LT.NMIN ) THEN INFO = -19 DWORK(1) = NMIN END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SG02CX', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. ( .NOT.LJOBG .AND. M.EQ.0 ) ) THEN ALPHA = ONE RNORM = ZERO RETURN END IF C RNORM = DLANSY( 'F-norm', UPLO, N, R, LDR, DWORK ) IF ( RNORM.EQ.ZERO ) THEN ALPHA = ZERO RETURN END IF C C Initialize scalar arguments for the called routines. C NT = 'No transpose' IF ( LJOBE ) THEN TR = 'Transpose' IF ( LTRANS ) THEN SIDE = 'Right' NTRANS = NT ELSE SIDE = 'Left' NTRANS = TR END IF END IF C C Initialize DWORK positions. C SP = NN + 1 C C Compute the matrix C C V = op(E)'*S*G*S*op(E), or C V = op(E)'*S*D*D'*S*op(E), or C V = F*F', or V = H*K. C IF ( LJOBL ) THEN C C Compute F*F' or H*K. C C Workspace: N*N. C IF ( LJOBF ) THEN CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, DWORK, N ) ELSE CALL MB01RB( 'Left', UPLO, NT, N, M, ZERO, ONE, DWORK, N, G, $ LDG, S, LDS, INFO ) END IF C ELSE IF ( LJOBG ) THEN IF ( LJOBE ) THEN C C Compute the following steps, if TRANS = 'N' C 1. W = S*E (stored in DWORK(SP)); C 2. V = W'*G*W (stored in DWORK). C C Compute the following steps, if TRANS = 'T' C 1. W = E*S (stored in DWORK(SP)); C 2. V = W*G*W' (stored in DWORK). C C Workspace: 3*N*N. C CALL DSYMM( SIDE, UPLO, N, N, ONE, S, LDS, E, LDE, $ ZERO, DWORK(SP), N ) CALL MB01RU( UPLO, NTRANS, N, N, ZERO, ONE, DWORK, N, $ DWORK(SP), N, G, LDG, DWORK(SP+NN), NN, INFO ) ELSE C C Compute V = S*G*S (stored in DWORK). C C Workspace: 2*N*N. C CALL MB01RU( UPLO, NT, N, N, ZERO, ONE, DWORK, N, S, LDS, G, $ LDG, DWORK(SP), NN, INFO ) END IF C ELSE C WWT = N.GE.M IF ( LJOBE ) THEN USE1 = LCND .AND. LDWORK.GE.3*NN C IF ( USE1 ) THEN C C Compute C Y = D*D' in DWORK, C W = S*E or W = E*S in DWORK(SP), C V = W'*Y*W or V = W*Y*W' in DWORK. C C Workspace: 3*N*N. C CALL DSYMM( SIDE, UPLO, N, N, ONE, S, LDS, E, LDE, ZERO, $ DWORK(SP), N ) CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, DWORK, $ N ) CALL MB01RU( UPLO, NTRANS, N, N, ZERO, ONE, DWORK, N, $ DWORK(SP), N, DWORK, N, DWORK(SP+NN), NN, $ INFO ) CALL DSCAL( N, ONE/TWO, DWORK, N+1 ) C ELSE IF ( WWT ) THEN C C Compute W = S*D (stored in DWORK); C Compute W = E'*W or W = E*W (stored in DWORK(SP)). C C Workspace (including for W*W'): N*N + N*M. C CALL DSYMM( 'Left', UPLO, N, M, ONE, S, LDS, G, LDG, $ ZERO, DWORK, N ) C CALL DGEMM( NTRANS, NT, N, M, N, ONE, E, LDE, DWORK, N, $ ZERO, DWORK(SP), N ) ELSE C C Compute W = S*E or W = E*S (stored in DWORK); C Compute W = D'*W or W = W*D (stored in DWORK(SP)). C C Workspace (including for W'*W): N*N + N*M. C CALL DSYMM( SIDE, UPLO, N, N, ONE, S, LDS, E, LDE, $ ZERO, DWORK, N ) C IF ( LTRANS ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, DWORK, N, G, LDG, $ ZERO, DWORK(SP), N ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, G, LDG, DWORK, N, $ ZERO, DWORK(SP), M ) END IF END IF C ELSE USE1 = LCND .OR. LDWORK.LT.NN + NM C IF ( USE1 ) THEN C C Compute C Y = D*D' in DWORK, C W = S*Y*S in DWORK. C C Workspace: 2*N*N. C CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, DWORK, $ N ) CALL MB01RU( UPLO, NT, N, N, ZERO, ONE, DWORK, N, S, LDS, $ DWORK, N, DWORK(SP), NN, INFO ) CALL DSCAL( N, ONE/TWO, DWORK, N+1 ) C ELSE C C Compute W = S*D (stored in DWORK(SP)). C C Workspace (including for W*W'): N*M + N*N. C CALL DSYMM( 'Left', UPLO, N, M, ONE, S, LDS, G, LDG, $ ZERO, DWORK(SP), N ) END IF END IF C C Compute V = W*W' or V = W'*W (stored in DWORK). C IF ( .NOT.USE1 ) THEN IF ( WWT .OR. .NOT.LJOBE .OR. LTRANS ) THEN CALL DSYRK( UPLO, NT, N, M, ONE, DWORK(SP), N, ZERO, $ DWORK, N ) ELSE CALL DSYRK( UPLO, NTRANS, N, M, ONE, DWORK(SP), M, ZERO, $ DWORK, N ) END IF END IF END IF C C Initialize scalar values. C PB = ZERO CRITNR = 0 C C Compute the parameters alpha, beta, gamma. C VNORM = DLANSY( 'F-norm', UPLO, N, DWORK, N, DWORK ) C MX = MAX( ONE, RNORM, VNORM ) PA = ( RNORM/MX )*( RNORM/MX ) C I = 1 C IF ( LUPLO ) THEN C DO 10 J = 1, N PB = PB + TWO*DDOT( J-1, R(1,J), 1, DWORK(I), 1 )/MX/MX + $ ( R(J,J)/MX )*( DWORK(I+J-1)/MX ) I = I + N 10 CONTINUE C ELSE C DO 20 J = 1, N - 1 PB = PB + ( R(J,J)/MX )*( DWORK(I)/MX ) + $ TWO*DDOT( N-J, R(J+1,J), 1, DWORK(I+1), 1 )/MX/MX I = I + N + 1 20 CONTINUE C PB = PB + ( R(N,N)/MX )*( DWORK(I)/MX ) END IF C C Compute the coefficients of the derivative polynomial. C ALPHA = -TWO*PA IF ( LFLAG ) THEN BETA = TWO*( PA - TWO*PB ) GAMMA = SIX*PB ELSE BETA = TWO*( PA + TWO*PB ) GAMMA = -SIX*PB END IF DELTA = FOUR*( VNORM/MX )*( VNORM/MX ) C C Compute the roots of the polynomial. C C Workspace: N*N + 51. C EVRPOS = SP EVIPOS = EVRPOS + 3 EVQPOS = EVIPOS + 3 RPOS = EVQPOS + 3 C CALL MC01XD( ALPHA, BETA, GAMMA, DELTA, DWORK(EVRPOS), $ DWORK(EVIPOS), DWORK(EVQPOS), DWORK(RPOS), $ LDWORK-RPOS+1, INFO ) C IF ( INFO.NE.0 ) THEN INFO = 1 ALPHA = ONE RNORM = VNORM RETURN END IF C C Find the global minimum of the polynomial in [0,2], if it exists. C DO 30 J = 0, 2 C C Check if EVR(J+1)/EVQ(J+1) is a critical value. C IF ( DWORK(EVIPOS+J).EQ.ZERO ) THEN C C Check if EVR(J+1)/EVQ(J+1) is in [0,2]. C PA = DWORK(EVRPOS+J) PB = DWORK(EVQPOS+J) IF ( PA.GE.ZERO .AND. PB.GT.ZERO .AND. PA.LE.TWO*PB ) THEN C C Check the second derivative (min or max). C MX = MAX( ABS( BETA ), ABS( GAMMA ), DELTA, ABS( PA ), $ ABS( PB ) ) IF ( MX.GT.ZERO ) THEN PA = PA/MX PB = PB/MX PC = ( BETA/MX )*PB*PB + TWO*( GAMMA/MX )*PA*PB + $ THREE*( DELTA/MX )*PA*PA IF ( PC.GT.ZERO ) THEN CRITNR = CRITNR + 1 CRN(CRITNR) = DWORK(EVRPOS+J) CRD(CRITNR) = DWORK(EVQPOS+J) END IF END IF END IF END IF 30 CONTINUE C IF ( CRITNR.EQ.0 ) THEN C C No minimum is found in [0,2]. C IWARN = 2 ALPHA = ONE RNORM = VNORM RETURN END IF C C Compute the norm of R(X+ALPHA*S). C C Workspace: 2*N*N. C ALPHA = CRN(1)/CRD(1) PA = ONE - ALPHA C CALL DLACPY( UPLO, N, N, R, LDR, DWORK(SP), N ) CALL DLASCL( UPLO, 1, 1, ONE, PA, N, N, DWORK(SP), N, INFO ) C IF ( LFLAG ) THEN PA = -ALPHA*ALPHA ELSE PA = ALPHA*ALPHA END IF I = 0 C IF ( LUPLO ) THEN C DO 40 J = 1, N CALL DAXPY( J, PA, DWORK(I+1), 1, DWORK(SP+I), 1 ) I = I + N 40 CONTINUE C ELSE C DO 50 J = 1, N CALL DAXPY( N-J+1, PA, DWORK(I+1), 1, DWORK(SP+I), 1 ) I = I + N + 1 50 CONTINUE C END IF C RNORM = DLANSY( 'F-norm', UPLO, N, DWORK(SP), N, DWORK ) C C If two local minima are found in [0,2], choose the one for which C the norm of R(X+t*S) is minimal. C IF ( CRITNR.EQ.2 ) THEN BETA = CRN(2)/CRD(2) PB = ONE - BETA C CALL DLACPY( UPLO, N, N, R, LDR, DWORK(SP), N ) CALL DLASCL( UPLO, 1, 1, ONE, PB, N, N, DWORK(SP), N, INFO ) C IF ( LFLAG ) THEN PB = -BETA*BETA ELSE PB = BETA*BETA END IF I = 0 C IF ( LUPLO ) THEN C DO 60 J = 1, N CALL DAXPY( J, PB, DWORK(I+1), 1, DWORK(SP+I), 1 ) I = I + N 60 CONTINUE C ELSE C DO 70 J = 1, N CALL DAXPY( N-J+1, PB, DWORK(I+1), 1, DWORK(SP+I), 1 ) I = I + N + 1 70 CONTINUE C END IF C VNORM = DLANSY( 'F-norm', UPLO, N, DWORK(SP), N, DWORK ) C IF ( VNORM.LT.RNORM ) THEN ALPHA = BETA RNORM = VNORM END IF END IF C RETURN C *** Last line of SG02CX *** END control-4.1.2/src/slicot/src/PaxHeaders/TB04AD.f0000644000000000000000000000013215012430707016153 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB04AD.f0000644000175000017500000003314515012430707017355 0ustar00lilgelilge00000000000000 SUBROUTINE TB04AD( ROWCOL, N, M, P, A, LDA, B, LDB, C, LDC, D, $ LDD, NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, $ LDUCO2, TOL1, TOL2, IWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To find the transfer matrix T(s) of a given state-space C representation (A,B,C,D). T(s) is expressed as either row or C column polynomial vectors over monic least common denominator C polynomials. C C ARGUMENTS C C Mode Parameters C C ROWCOL CHARACTER*1 C Indicates whether the transfer matrix T(s) is required C as rows or columns over common denominators as follows: C = 'R': T(s) is required as rows over common denominators; C = 'C': T(s) is required as columns over common C denominators. C C Input/Output Parameters C C N (input) INTEGER C The order of the state-space representation, i.e. the C order of the original state dynamics 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/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the original state dynamics matrix A. C On exit, the leading NR-by-NR part of this array contains C the upper block Hessenberg state dynamics matrix A of a C transformed representation for the original system: this C is completely controllable if ROWCOL = 'R', or completely C observable if ROWCOL = 'C'. 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 if ROWCOL = 'R', and (LDB,MAX(M,P)) if ROWCOL = 'C'. C On entry, the leading N-by-M part of this array must C contain the original input/state matrix B; if C ROWCOL = 'C', the remainder of the leading N-by-MAX(M,P) C part is used as internal workspace. C On exit, the leading NR-by-M part of this array contains C the transformed input/state matrix B. 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 original state/output matrix C; if C ROWCOL = 'C', the remainder of the leading MAX(M,P)-by-N C part is used as internal workspace. C On exit, the leading P-by-NR part of this array contains C the transformed state/output matrix C. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,P) if ROWCOL = 'R'; C LDC >= MAX(1,M,P) if ROWCOL = 'C'. C C D (input) DOUBLE PRECISION array, dimension (LDD,M), C if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'. C The leading P-by-M part of this array must contain the C original direct transmission matrix D; if ROWCOL = 'C', C this array is modified internally, but restored on exit, C and the remainder of the leading MAX(M,P)-by-MAX(M,P) C part is used as internal workspace. C C LDD INTEGER C The leading dimension of array D. C LDD >= MAX(1,P) if ROWCOL = 'R'; C LDD >= MAX(1,M,P) if ROWCOL = 'C'. C C NR (output) INTEGER C The order of the transformed state-space representation. C C INDEX (output) INTEGER array, dimension (porm), where porm = P, C if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'. C The degrees of the denominator polynomials. C C DCOEFF (output) DOUBLE PRECISION array, dimension (LDDCOE,N+1) C The leading porm-by-kdcoef part of this array contains C the coefficients of each denominator polynomial, where C kdcoef = MAX(INDEX(I)) + 1. C DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of C the I-th denominator polynomial, where K = 1,2,...,kdcoef. C C LDDCOE INTEGER C The leading dimension of array DCOEFF. C LDDCOE >= MAX(1,P) if ROWCOL = 'R'; C LDDCOE >= MAX(1,M) if ROWCOL = 'C'. C C UCOEFF (output) DOUBLE PRECISION array, dimension C (LDUCO1,LDUCO2,N+1) C If ROWCOL = 'R' then porp = M, otherwise porp = P. C The leading porm-by-porp-by-kdcoef part of this array C contains the coefficients of the numerator matrix U(s). C UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; C if ROWCOL = 'R' then iorj = I, otherwise iorj = J. C Thus for ROWCOL = 'R', U(s) = C diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). C C LDUCO1 INTEGER C The leading dimension of array UCOEFF. C LDUCO1 >= MAX(1,P) if ROWCOL = 'R'; C LDUCO1 >= MAX(1,M) if ROWCOL = 'C'. C C LDUCO2 INTEGER C The second dimension of array UCOEFF. C LDUCO2 >= MAX(1,M) if ROWCOL = 'R'; C LDUCO2 >= MAX(1,P) if ROWCOL = 'C'. C C Tolerances C C TOL1 DOUBLE PRECISION C The tolerance to be used in determining the i-th row of C T(s), where i = 1,2,...,porm. If the user sets TOL1 > 0, C then the given value of TOL1 is used as an absolute C tolerance; elements with absolute value less than TOL1 are C considered neglijible. If the user sets TOL1 <= 0, then C an implicitly computed, default tolerance, defined in C the SLICOT Library routine TB01ZD, is used instead. C C TOL2 DOUBLE PRECISION C The tolerance to be used to separate out a controllable C subsystem of (A,B,C). If the user sets TOL2 > 0, then C the given value of TOL2 is used as a lower bound for the C reciprocal condition number (see the description of the C argument RCOND in the SLICOT routine MB03OD); a C (sub)matrix whose estimated condition number is less than C 1/TOL2 is considered to be of full rank. If the user sets C TOL2 <= 0, then an implicitly computed, default tolerance, C defined in the SLICOT Library routine TB01UD, is used C instead. C C Workspace C C IWORK INTEGER array, dimension (N+MAX(M,P)) C On exit, if INFO = 0, the first nonzero elements of C IWORK(1:N) return the orders of the diagonal blocks of A. 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, N*(N + 1) + MAX(N*MP + 2*N + MAX(N,MP), C 3*MP, PM)), C where MP = M, PM = P, if ROWCOL = 'R'; C MP = P, PM = M, if ROWCOL = '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 C METHOD C C The method for transfer matrices factorized by rows will be C described here: T(s) factorized by columns is dealt with by C operating on the dual of the original system. Each row of C T(s) is simply a single-output relatively left prime polynomial C matrix representation, so can be calculated by applying a C simplified version of the Orthogonal Structure Theorem to a C minimal state-space representation for the corresponding row of C the given system. A minimal state-space representation is obtained C using the Orthogonal Canonical Form to first separate out a C completely controllable one for the overall system and then, for C each row in turn, applying it again to the resulting dual SIMO C (single-input multi-output) system. Note that the elements of the C transformed matrix A so calculated are individually scaled in a C way which guarantees a monic denominator polynomial. C C REFERENCES C C [1] Williams, T.W.C. C An Orthogonal Structure Theorem for Linear Systems. C Control Systems Research Group, Kingston Polytechnic, C Internal Report 82/2, 1982. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. C Supersedes Release 3.0 routine TB01QD. C C REVISIONS C C - C C KEYWORDS C C Controllability, dual system, minimal realization, orthogonal C canonical form, orthogonal transformation, polynomial matrix, C transfer matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER ROWCOL INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, $ LDUCO2, LDWORK, M, N, NR, P DOUBLE PRECISION TOL1, TOL2 C .. Array Arguments .. INTEGER INDEX(*), IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DCOEFF(LDDCOE,*), DWORK(*), $ UCOEFF(LDUCO1,LDUCO2,*) C .. Local Scalars .. LOGICAL LROCOC, LROCOR CHARACTER*1 JOBD INTEGER I, IA, ITAU, J, JWORK, K, KDCOEF, MAXMP, MAXMPN, $ MPLIM, MWORK, N1, PWORK C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB07MD, DLASET, DSWAP, TB01XD, TB04AY, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C .. Executable Statements .. C INFO = 0 LROCOR = LSAME( ROWCOL, 'R' ) LROCOC = LSAME( ROWCOL, 'C' ) MAXMP = MAX( M, P ) MPLIM = MAX( 1, MAXMP ) MAXMPN = MAX( MAXMP, N ) N1 = MAX( 1, N ) IF ( LROCOR ) THEN C C T(s) given as rows over common denominators. C PWORK = P MWORK = M ELSE C C T(s) given as columns over common denominators. C PWORK = M MWORK = P END IF C C Test the input scalar arguments. C IF( .NOT.LROCOR .AND. .NOT.LROCOC ) 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.N1 ) THEN INFO = -6 ELSE IF( LDB.LT.N1 ) THEN INFO = -8 ELSE IF( ( LROCOC .AND. LDC.LT.MPLIM ) $ .OR. LDC.LT.MAX( 1, P ) ) THEN INFO = -10 ELSE IF( ( LROCOC .AND. LDD.LT.MPLIM ) $ .OR. LDD.LT.MAX( 1, P ) ) THEN INFO = -12 ELSE IF( LDDCOE.LT.MAX( 1, PWORK ) ) THEN INFO = -16 ELSE IF( LDUCO1.LT.MAX( 1, PWORK ) ) THEN INFO = -18 ELSE IF( LDUCO2.LT.MAX( 1, MWORK ) ) THEN INFO = -19 ELSE IF( LDWORK.LT.MAX( 1, N*( N + 1 ) + $ MAX( N*MWORK + 2*N + MAX( N, MWORK ), $ 3*MWORK, PWORK ) ) ) THEN INFO = -24 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB04AD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAXMPN.EQ.0 ) $ RETURN C JOBD = 'D' IA = 1 ITAU = IA + N*N JWORK = ITAU + N C IF ( LROCOC ) THEN C C Initialization for T(s) given as columns over common C denominators. C CALL AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ INFO ) END IF C C Initialize polynomial matrix U(s) to zero. C DO 10 K = 1, N + 1 CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, UCOEFF(1,1,K), $ LDUCO1 ) 10 CONTINUE C C Calculate T(s) by applying the Orthogonal Structure Theorem to C each of the PWORK MISO subsystems (A,B,C:I,D:I) in turn. C CALL TB04AY( N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, LDD, $ NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, LDUCO2, $ DWORK(IA), N1, DWORK(ITAU), TOL1, TOL2, IWORK, $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) DWORK(1) = DWORK(JWORK) + DBLE( JWORK-1 ) C IF ( LROCOC ) THEN C C For T(s) factorized by columns, return to original (dual of C dual) system, and reorder the rows and columns to get an upper C block Hessenberg state dynamics matrix. C CALL TB01XD( JOBD, N, MWORK, PWORK, IWORK(1)+IWORK(2)-1, N-1, $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) C IF ( MPLIM.NE.1 ) THEN C C Also, transpose U(s) (not 1-by-1). C KDCOEF = 0 C DO 20 I = 1, PWORK KDCOEF = MAX( KDCOEF, INDEX(I) ) 20 CONTINUE C KDCOEF = KDCOEF + 1 C DO 50 K = 1, KDCOEF C DO 40 J = 1, MPLIM - 1 CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, $ UCOEFF(J,J+1,K), LDUCO1 ) 40 CONTINUE C 50 CONTINUE C END IF END IF C RETURN C *** Last line of TB04AD *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01AY.f0000644000000000000000000000013015012430707016171 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/NF01AY.f0000644000175000017500000002444415012430707017377 0ustar00lilgelilge00000000000000 SUBROUTINE NF01AY( NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, LDZ, $ Y, LDY, DWORK, LDWORK, INFO ) C C PURPOSE C C To calculate the output of a set of neural networks with the C structure C C - tanh(w1'*z+b1) - C / : \ C z --- : --- sum(ws(i)*...)+ b(n+1) --- y, C \ : / C - tanh(wn'*z+bn) - C C given the input z and the parameter vectors wi, ws, and b, C where z, w1, ..., wn are vectors of length NZ, ws is a vector C of length n, b(1), ..., b(n+1) are scalars, and n is called the C number of neurons in the hidden layer, or just number of neurons. C Such a network is used for each L output variables. C C ARGUMENTS C C Input/Output Parameters C C NSMP (input) INTEGER C The number of training samples. NSMP >= 0. C C NZ (input) INTEGER C The length of each input sample. NZ >= 0. C C L (input) INTEGER C The length of each output sample. L >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters needed. C IPAR(1) must contain the number of neurons, n, per output C variable, denoted NN in the sequel. NN >= 0. C C LIPAR (input) INTEGER C The length of the vector IPAR. LIPAR >= 1. C C WB (input) DOUBLE PRECISION array, dimension (LWB) C The leading (NN*(NZ+2)+1)*L part of this array must C contain the weights and biases of the network. This vector C is partitioned into L vectors of length NN*(NZ+2)+1, C WB = [ wb(1), ..., wb(L) ]. Each wb(k), k = 1, ..., L, C corresponds to one output variable, and has the structure C wb(k) = [ w1(1), ..., w1(NZ), ..., wn(1), ..., wn(NZ), C ws(1), ..., ws(n), b(1), ..., b(n+1) ], C where wi(j) are the weights of the hidden layer, C ws(i) are the weights of the linear output layer, and C b(i) are the biases, as in the scheme above. C C LWB (input) INTEGER C The length of the array WB. C LWB >= ( NN*(NZ + 2) + 1 )*L. C C Z (input) DOUBLE PRECISION array, dimension (LDZ, NZ) C The leading NSMP-by-NZ part of this array must contain the C set of input samples, C Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ). C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1,NSMP). C C Y (output) DOUBLE PRECISION array, dimension (LDY, L) C The leading NSMP-by-L part of this array contains the set C of output samples, C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). C C LDY INTEGER C The leading dimension of the array Y. LDY >= MAX(1,NSMP). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 2*NN. C For better 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 C METHOD C C BLAS routines are used to compute the matrix-vector products. C C CONTRIBUTORS C C A. Riedel, R. Schneider, Chemnitz University of Technology, C Oct. 2000, during a stay at University of Twente, NL. C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. C C REVISIONS C C - C C KEYWORDS C C Input output description, neural network, nonlinear system, C simulation, system response. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. INTEGER INFO, L, LDWORK, LDY, LDZ, LIPAR, LWB, NSMP, NZ C .. Array Arguments .. DOUBLE PRECISION DWORK(*), WB(*), Y(LDY,*), Z(LDZ,*) INTEGER IPAR(*) C .. Local Scalars .. LOGICAL LAST INTEGER I, IB, J, K, LDWB, LJ, LK, M, MF, NN, NV, WS DOUBLE PRECISION BIGNUM, DF, SMLNUM, TMP C .. External Functions .. DOUBLE PRECISION DDOT, DLAMCH EXTERNAL DDOT, DLAMCH C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, EXP, LOG, MAX, MIN, MOD C .. C .. Executable Statements .. C INFO = 0 NN = IPAR(1) LDWB = NN*( NZ + 2 ) + 1 IF ( NSMP.LT.0 ) THEN INFO = -1 ELSEIF ( NZ.LT.0 ) THEN INFO = -2 ELSEIF ( L.LT.0 ) THEN INFO = -3 ELSEIF ( NN.LT.0 ) THEN INFO = -4 ELSEIF ( LIPAR.LT.1 ) THEN INFO = -5 ELSEIF ( LWB.LT.LDWB*L ) THEN INFO = -7 ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN INFO = -9 ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN INFO = -11 ELSEIF ( LDWORK.LT.2*NN ) THEN INFO = -13 ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01AY', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( MIN( NSMP, L ).EQ.0 ) $ RETURN C C Set parameters to avoid overflows and increase accuracy for C extreme values. C SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = LOG( SMLNUM ) BIGNUM = LOG( BIGNUM ) C WS = NZ*NN + 1 IB = WS + NN - 1 LK = 0 IF ( MIN( NZ, NN ).EQ.0 ) THEN NV = 2 ELSE NV = ( LDWORK - NN )/NN END IF C IF ( NV.GT.2 ) THEN MF = ( NSMP/NV )*NV LAST = MOD( NSMP, NV ).NE.0 C C Some BLAS 3 calculations can be used. C DO 70 K = 0, L - 1 TMP = WB(IB+NN+1+LK) C DO 10 J = 1, NN DWORK(J) = TWO*WB(IB+J+LK) 10 CONTINUE C DO 40 I = 1, MF, NV C C Compute -2*[w1 w2 ... wn]'*Z', where C Z = [z(i)';...; z(i+NV-1)']. C CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO, $ WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1), $ NN ) LJ = NN C DO 30 M = 1, NV DO 20 J = 1, NN C C Compute tanh(wj'*z(i) + bj), j = 1:n. C LJ = LJ + 1 DF = DWORK(LJ) - DWORK(J) IF ( ABS( DF ).GE.BIGNUM ) THEN IF ( DF.GT.ZERO ) THEN DWORK(LJ) = -ONE ELSE DWORK(LJ) = ONE END IF ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN DWORK(LJ) = ZERO ELSE DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE END IF 20 CONTINUE C 30 CONTINUE C Y(I, K+1) = TMP CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 ) CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN, $ WB(WS+LK), 1, ONE, Y(I, K+1), 1 ) 40 CONTINUE C IF ( LAST ) THEN C C Process the last samples. C NV = NSMP - MF I = MF + 1 C C Compute -2*[w1 w2 ... wn]'*Z', where C Z = [z(i)';...; z(NSMP)']. C CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO, $ WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1), $ NN ) LJ = NN C DO 60 M = 1, NV DO 50 J = 1, NN C C Compute tanh(wj'*z(i) + bj), j = 1:n. C LJ = LJ + 1 DF = DWORK(LJ) - DWORK(J) IF ( ABS( DF ).GE.BIGNUM ) THEN IF ( DF.GT.ZERO ) THEN DWORK(LJ) = -ONE ELSE DWORK(LJ) = ONE END IF ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN DWORK(LJ) = ZERO ELSE DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE END IF 50 CONTINUE C 60 CONTINUE C Y(I, K+1) = TMP IF ( NV.GT.1 ) $ CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 ) CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN, $ WB(WS+LK), 1, ONE, Y(I, K+1), 1 ) END IF C LK = LK + LDWB 70 CONTINUE C ELSE C C BLAS 2 calculations only can be used. C DO 110 K = 0, L - 1 TMP = WB(IB+NN+1+LK) C DO 80 J = 1, NN DWORK(J) = TWO*WB(IB+J+LK) 80 CONTINUE C DO 100 I = 1, NSMP C C Compute -2*[w1 w2 ... wn]'*z(i). C IF ( NZ.EQ.0 ) THEN DWORK(NN+1) = ZERO CALL DCOPY( NN, DWORK(NN+1), 0, DWORK(NN+1), 1 ) ELSE CALL DGEMV( 'Transpose', NZ, NN, -TWO, WB(1+LK), NZ, $ Z(I,1), LDZ, ZERO, DWORK(NN+1), 1 ) END IF C DO 90 J = NN + 1, 2*NN C C Compute tanh(wj'*z(i) + bj), j = 1:n. C DF = DWORK(J) - DWORK(J-NN) IF ( ABS( DF ).GE.BIGNUM ) THEN IF ( DF.GT.ZERO ) THEN DWORK(J) = -ONE ELSE DWORK(J) = ONE END IF ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN DWORK(J) = ZERO ELSE DWORK(J) = TWO/( ONE + EXP( DF ) ) - ONE END IF 90 CONTINUE C Y(I, K+1) = DDOT( NN, WB(WS+LK), 1, DWORK(NN+1), 1 ) + $ TMP 100 CONTINUE C LK = LK + LDWB 110 CONTINUE C END IF RETURN C C *** Last line of NF01AY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10ID.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10ID.f0000644000175000017500000004361415012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE SB10ID( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, $ FACTOR, NK, AK, LDAK, BK, LDBK, CK, LDCK, $ DK, LDDK, RCOND, IWORK, DWORK, LDWORK, BWORK, $ INFO ) C C PURPOSE C C To compute the matrices of the positive feedback controller C C | Ak | Bk | C K = |----|----| C | Ck | Dk | C C for the shaped plant C C | A | B | C G = |---|---| C | C | D | C C in the McFarlane/Glover Loop Shaping Design Procedure. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the plant. 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 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 of the shaped plant. 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 of the shaped plant. 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 of the shaped plant. 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 matrix D of the shaped plant. C C LDD INTEGER C The leading dimension of the array D. LDD >= max(1,NP). C C FACTOR (input) DOUBLE PRECISION C = 1 implies that an optimal controller is required; C > 1 implies that a suboptimal controller is required, C achieving a performance FACTOR less than optimal. C FACTOR >= 1. C C NK (output) INTEGER C The order of the positive feedback controller. NK <= N. C C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) C The leading NK-by-NK 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,NP) C The leading NK-by-NP 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 M-by-NK part of this array contains the C controller output matrix Ck. C C LDCK INTEGER C The leading dimension of the array CK. LDCK >= max(1,M). C C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) C The leading M-by-NP part of this array contains the C controller matrix Dk. C C LDDK INTEGER C The leading dimension of the array DK. LDDK >= max(1,M). C C RCOND (output) DOUBLE PRECISION array, dimension (2) C RCOND(1) contains an estimate of the reciprocal condition C number of the X-Riccati equation; C RCOND(2) contains an estimate of the reciprocal condition C number of the Z-Riccati equation. C C Workspace C C IWORK INTEGER array, dimension (max(2*N,N*N,M,NP)) 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 >= 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + C max( 6*N*N + 5 + max(1,4*N*N+8*N), N*NP + 2*N ). C For good performance, LDWORK must generally be larger. C An upper bound of LDWORK in the above formula is C LDWORK >= 10*N*N + M*M + NP*NP + 2*M*N + 2*N*NP + 4*N + C 5 + max(1,4*N*N+8*N). 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: the X-Riccati equation is not solved successfully; C = 2: the Z-Riccati equation is not solved successfully; C = 3: the iteration to compute eigenvalues or singular C values failed to converge; C = 4: the matrix Ip - D*Dk is singular; C = 5: the matrix Im - Dk*D is singular; C = 6: the closed-loop system is unstable. C C METHOD C C The routine implements the formulas given in [1]. C C REFERENCES C C [1] McFarlane, D. and Glover, K. C A loop shaping design procedure using H_infinity synthesis. C IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769, C 1992. C C NUMERICAL ASPECTS C C The accuracy of the results depends on the conditioning of the C two Riccati equations solved in the controller design (see the C output parameter RCOND). C C CONTRIBUTORS C C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, C Feb. 2001. C C KEYWORDS C C H_infinity control, Loop-shaping design, Robust 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, NK, NP DOUBLE PRECISION FACTOR C .. C .. Array Arguments .. INTEGER IWORK( * ) LOGICAL BWORK( * ) DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), $ RCOND( 2 ) C .. C .. Local Scalars .. CHARACTER*1 HINV INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, $ I11, I12, I13, INFO2, IWRK, J, LWA, LWAMAX, $ MINWRK, N2, NS, SDIM DOUBLE PRECISION SEP, FERR, GAMMA C .. C .. External Functions .. LOGICAL SELECT EXTERNAL SELECT C .. C .. External Subroutines .. EXTERNAL DGEES, DGEMM, DLACPY, DLASET, DPOTRF, DPOTRS, $ DSYRK, DTRSM, MB02VD, SB02RD, SB10JD, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, SQRT C .. C .. Executable Statements .. C C Decode and Test input parameters. 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -9 ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN INFO = -11 ELSE IF( FACTOR.LT.ONE ) THEN INFO = -12 ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN INFO = -19 ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN INFO = -21 END IF C C Compute workspace. C MINWRK = 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + $ MAX( 6*N*N + 5 + MAX( 1, 4*N*N + 8*N ), N*NP + 2*N ) IF( LDWORK.LT.MINWRK ) THEN INFO = -25 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10ID', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN RCOND( 1 ) = ONE RCOND( 2 ) = ONE DWORK( 1 ) = ONE RETURN END IF C C Workspace usage. C I1 = N*N I2 = I1 + N*N I3 = I2 + M*N I4 = I3 + M*N I5 = I4 + M*M I6 = I5 + NP*NP I7 = I6 + NP*N I8 = I7 + N*N I9 = I8 + N*N I10 = I9 + N*N I11 = I10 + N*N I12 = I11 + 2*N I13 = I12 + 2*N C IWRK = I13 + 4*N*N C C Compute D'*C . C CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, $ DWORK( I2+1 ), M ) C C Compute S = Im + D'*D . C CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I4+1 ), M ) CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ONE, DWORK( I4+1 ), M ) C C Factorize S, S = T'*T, with T upper triangular. C CALL DPOTRF( 'U', M, DWORK( I4+1 ), M, INFO2 ) C C -1 C Compute S D'*C . C CALL DPOTRS( 'U', M, N, DWORK( I4+1 ), M, DWORK( I2+1 ), M, $ INFO2 ) C C -1 C Compute B*T . C CALL DLACPY( 'F', N, M, B, LDB, DWORK( I3+1 ), N ) CALL DTRSM( 'R', 'U', 'N', 'N', N, M, ONE, DWORK( I4+1 ), M, $ DWORK( I3+1 ), N ) C C Compute R = Ip + D*D' . C CALL DLASET( 'U', NP, NP, ZERO, ONE, DWORK( I5+1 ), NP ) CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ONE, DWORK( I5+1 ), NP ) C C Factorize R, R = U'*U, with U upper triangular. C CALL DPOTRF( 'U', NP, DWORK( I5+1 ), NP, INFO2 ) C C -T C Compute U C . C CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I6+1 ), NP ) CALL DTRSM( 'L', 'U', 'T', 'N', NP, N, ONE, DWORK( I5+1 ), NP, $ DWORK( I6+1 ), NP ) C C -1 C Compute Ar = A - B*S D'*C . C CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N ) CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, DWORK( I2+1 ), M, $ ONE, DWORK( I7+1 ), N ) C C -1 C Compute the upper triangle of Cr = C'*R *C . C CALL DSYRK( 'U', 'T', N, NP, ONE, DWORK( I6+1 ), NP, ZERO, $ DWORK( I8+1 ), N ) C C -1 C Compute the upper triangle of Dr = B*S B' . C CALL DSYRK( 'U', 'N', N, M, ONE, DWORK( I3+1 ), N, ZERO, $ DWORK( I9+1 ), N ) C C Solution of the Riccati equation Ar'*X + X*Ar + Cr - X*Dr*X = 0 . C Workspace: need 10*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + C 5 + max(1,4*N*N+8*N). C prefer larger. C AK is used as workspace. C N2 = 2*N CALL SB02RD( 'A', 'C', HINV, 'N', 'U', 'G', 'S', 'N', 'O', N, $ DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK, $ DWORK( I9+1 ), N, DWORK( I8+1 ), N, DWORK, N, SEP, $ RCOND( 1 ), FERR, DWORK( I11+1 ), DWORK( I12+1 ), $ DWORK( I13+1 ), N2, IWORK, DWORK( IWRK+1 ), $ LDWORK-IWRK, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 1 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( MINWRK, LWA ) C C Solution of the Riccati equation Ar*Z + Z*Ar' + Dr - Z*Cr*Z = 0 . C CALL SB02RD( 'A', 'C', HINV, 'T', 'U', 'G', 'S', 'N', 'O', N, $ DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK, $ DWORK( I8+1 ), N, DWORK( I9+1 ), N, DWORK( I1+1 ), $ N, SEP, RCOND( 2 ), FERR, DWORK( I11+1 ), $ DWORK( I12+1 ), DWORK( I13+1 ), N2, IWORK, $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 2 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX ) C C -1 -1 C Compute F1 = -( S D'*C + S B'*X ) . C CALL DTRSM( 'R', 'U', 'T', 'N', N, M, ONE, DWORK( I4+1 ), M, $ DWORK( I3+1 ), N ) CALL DGEMM( 'T', 'N', M, N, N, -ONE, DWORK( I3+1 ), N, DWORK, N, $ -ONE, DWORK( I2+1 ), M ) C C Compute gamma . C CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK, N, DWORK( I1+1 ), N, $ ZERO, DWORK( I7+1 ), N ) CALL DGEES( 'N', 'N', SELECT, N, DWORK( I7+1 ), N, SDIM, $ DWORK( I11+1 ), DWORK( I12+1 ), DWORK( IWRK+1 ), N, $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX ) GAMMA = ZERO DO 10 I = 1, N GAMMA = MAX( GAMMA, DWORK( I11+I ) ) 10 CONTINUE GAMMA = FACTOR*SQRT( ONE + GAMMA ) C C Workspace usage. C Workspace: need 4*N*N + M*N + N*NP. C I4 = I3 + N*N I5 = I4 + N*N C C Compute Ac = A + B*F1 . C CALL DLACPY( 'F', N, N, A, LDA, DWORK( I4+1 ), N ) CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, DWORK( I2+1 ), M, $ ONE, DWORK( I4+1 ), N ) C C Compute W1' = (1-gamma^2)*In + Z*X . C CALL DLASET( 'F', N, N, ZERO, ONE-GAMMA*GAMMA, DWORK( I3+1 ), N ) CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1+1 ), N, DWORK, N, $ ONE, DWORK( I3+1 ), N ) C C Compute Bcp = gamma^2*Z*C' . C CALL DGEMM( 'N', 'T', N, NP, N, GAMMA*GAMMA, DWORK( I1+1 ), N, C, $ LDC, ZERO, BK, LDBK ) C C Compute C + D*F1 . C CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I5+1 ), NP ) CALL DGEMM( 'N', 'N', NP, N, M, ONE, D, LDD, DWORK( I2+1 ), M, $ ONE, DWORK( I5+1 ), NP ) C C Compute Acp = W1'*Ac + gamma^2*Z*C'*(C+D*F1) . C CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I3+1 ), N, $ DWORK( I4+1 ), N, ZERO, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, NP, ONE, BK, LDBK, $ DWORK( I5+1 ), NP, ONE, AK, LDAK ) C C Compute Ccp = B'*X . C CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK, N, ZERO, $ CK, LDCK ) C C Set Dcp = -D' . C DO 30 I = 1, M DO 20 J = 1, NP DK( I, J ) = -D( J, I ) 20 CONTINUE 30 CONTINUE C IWRK = I4 C C Reduce the generalized state-space description to a regular one. C Workspace: need 3*N*N + M*N. C Additional workspace: need 2*N*N + 2*N + N*MAX(5,N+M+NP). C prefer larger. C CALL SB10JD( N, NP, M, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, $ DWORK( I3+1 ), N, NK, DWORK( IWRK+1 ), LDWORK-IWRK, $ INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX ) C C Workspace usage. C Workspace: need 4*N*N + M*M + NP*NP + 2*M*N + 2*N*NP. C (NK <= N.) C I2 = NP*NP I3 = I2 + NK*NP I4 = I3 + M*M I5 = I4 + N*M I6 = I5 + NP*NK I7 = I6 + M*N C IWRK = I7 + ( N + NK )*( N + NK ) C C Compute Ip - D*Dk . C CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK, NP ) CALL DGEMM( 'N', 'N', NP, NP, M, -ONE, D, LDD, DK, LDDK, ONE, $ DWORK, NP ) C C -1 C Compute Bk*(Ip-D*Dk) . C CALL DLACPY( 'F', NK, NP, BK, LDBK, DWORK( I2+1 ), NK ) CALL MB02VD( 'N', NK, NP, DWORK, NP, IWORK, DWORK( I2+1 ), NK, $ INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 4 RETURN END IF C C Compute Im - Dk*D . C CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I3+1 ), M ) CALL DGEMM( 'N', 'N', M, M, NP, -ONE, DK, LDDK, D, LDD, ONE, $ DWORK( I3+1 ), M ) C C -1 C Compute B*(Im-Dk*D) . C CALL DLACPY( 'F', N, M, B, LDB, DWORK( I4+1 ), N ) CALL MB02VD( 'N', N, M, DWORK( I3+1 ), M, IWORK, DWORK( I4+1 ), N, $ INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 5 RETURN END IF C C Compute D*Ck . C CALL DGEMM( 'N', 'N', NP, NK, M, ONE, D, LDD, CK, LDCK, ZERO, $ DWORK( I5+1 ), NP ) C C Compute Dk*C . C CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, $ DWORK( I6+1 ), M ) C C Compute the closed-loop state matrix. C CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N+NK ) CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4+1 ), N, $ DWORK( I6+1 ), M, ONE, DWORK( I7+1 ), N+NK ) CALL DGEMM( 'N', 'N', NK, N, NP, ONE, DWORK( I2+1 ), NK, C, LDC, $ ZERO, DWORK( I7+N+1 ), N+NK ) CALL DGEMM( 'N', 'N', N, NK, M, ONE, DWORK( I4+1 ), N, CK, LDCK, $ ZERO, DWORK( I7+(N+NK)*N+1 ), N+NK ) CALL DLACPY( 'F', NK, NK, AK, LDAK, DWORK( I7+(N+NK)*N+N+1 ), $ N+NK ) CALL DGEMM( 'N', 'N', NK, NK, NP, ONE, DWORK( I2+1 ), NK, $ DWORK( I5+1 ), NP, ONE, DWORK( I7+(N+NK)*N+N+1 ), $ N+NK ) C C Compute the closed-loop poles. C Additional workspace: need 3*(N+NK); prefer larger. C The fact that M > 0, NP > 0, and NK <= N is used here. C CALL DGEES( 'N', 'N', SELECT, N+NK, DWORK( I7+1 ), N+NK, SDIM, $ DWORK, DWORK( N+NK+1 ), DWORK( IWRK+1 ), N, $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX ) C C Check the stability of the closed-loop system. C NS = 0 DO 40 I = 1, N+NK IF( DWORK( I ).GE.ZERO ) NS = NS + 1 40 CONTINUE IF( NS.GT.0 ) THEN INFO = 6 RETURN END IF C DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10ID *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02RZ.f0000644000000000000000000000013215012430707016211 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02RZ.f0000644000175000017500000001325015012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE MB02RZ( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) C C PURPOSE C C To solve a system of linear equations C H * X = B, H' * X = B or H**H * X = B C with a complex upper Hessenberg N-by-N matrix H using the LU C factorization computed by MB02SZ. C C ARGUMENTS C C Mode Parameters C C TRANS CHARACTER*1 C Specifies the form of the system of equations: C = 'N': H * X = B (No transpose) C = 'T': H'* X = B (Transpose) C = 'C': H**H * X = B (Conjugate transpose) C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix H. N >= 0. C C NRHS (input) INTEGER C The number of right hand sides, i.e., the number of C columns of the matrix B. NRHS >= 0. C C H (input) COMPLEX*16 array, dimension (LDH,N) C The factors L and U from the factorization H = P*L*U C as computed by MB02SZ. C C LDH INTEGER C The leading dimension of the array H. LDH >= max(1,N). C C IPIV (input) INTEGER array, dimension (N) C The pivot indices from MB02SZ; for 1<=i<=N, row i of the C matrix was interchanged with row IPIV(i). C C B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) C On entry, the right hand side matrix B. C On exit, the solution matrix X. C C LDB INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C INFO (output) 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 uses the factorization C H = P * L * U C where P is a permutation matrix, L is lower triangular with unit C diagonal elements (and one nonzero subdiagonal), and U is upper C triangular. C C REFERENCES C C - C C NUMERICAL ASPECTS C 2 C The algorithm requires 0( N x NRHS ) complex operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TB01FW by A.J. Laub, University of C Southern California, United States of America, May 1980. C C REVISIONS C C - C C KEYWORDS C C Frequency response, Hessenberg form, matrix algebra. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDB, LDH, N, NRHS C .. C .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 B( LDB, * ), H( LDH, * ) C .. Local Scalars .. LOGICAL NOTRAN INTEGER J, JP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZSWAP, ZTRSM C .. Intrinsic Functions .. INTRINSIC DCONJG, MAX C .. Executable Statements .. C C Test the input parameters. C INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02RZ', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN C IF( NOTRAN ) THEN C C Solve H * X = B. C C Solve L * X = B, overwriting B with X. C C L is represented as a product of permutations and unit lower C triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), C where each transformation L(i) is a rank-one modification of C the identity matrix. C DO 10 J = 1, N - 1 JP = IPIV( J ) IF( JP.NE.J ) $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) CALL ZAXPY( NRHS, -H( J+1, J ), B( J, 1 ), LDB, B( J+1, 1 ), $ LDB ) 10 CONTINUE C C Solve U * X = B, overwriting B with X. C CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, $ NRHS, ONE, H, LDH, B, LDB ) C ELSE IF( LSAME( TRANS, 'T' ) ) THEN C C Solve H' * X = B. C C Solve U' * X = B, overwriting B with X. C CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, $ H, LDH, B, LDB ) C C Solve L' * X = B, overwriting B with X. C DO 20 J = N - 1, 1, -1 CALL ZAXPY( NRHS, -H( J+1, J ), B( J+1, 1 ), LDB, B( J, 1 ), $ LDB ) JP = IPIV( J ) IF( JP.NE.J ) $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) 20 CONTINUE C ELSE C C Solve H**H * X = B. C C Solve U**H * X = B, overwriting B with X. C CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, $ H, LDH, B, LDB ) C C Solve L**H * X = B, overwriting B with X. C DO 30 J = N - 1, 1, -1 CALL ZAXPY( NRHS, -DCONJG( H( J+1, J ) ), B( J+1, 1 ), LDB, $ B( J, 1 ), LDB ) JP = IPIV( J ) IF( JP.NE.J ) $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) 30 CONTINUE C END IF C RETURN C *** Last line of MB02RZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04XD.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04XD.f0000644000175000017500000006036315012430707017377 0ustar00lilgelilge00000000000000 SUBROUTINE MB04XD( JOBU, JOBV, M, N, RANK, THETA, A, LDA, U, LDU, $ V, LDV, Q, INUL, TOL, RELTOL, DWORK, LDWORK, $ IWARN, INFO ) C C PURPOSE C C To compute a basis for the left and/or right singular subspace of C an M-by-N matrix A corresponding to its smallest singular values. C C ARGUMENTS C C Mode Parameters C C JOBU CHARACTER*1 C Specifies whether to compute the left singular subspace C as follows: C = 'N': Do not compute the left singular subspace; C = 'A': Return the (M - RANK) base vectors of the desired C left singular subspace in U; C = 'S': Return the first (min(M,N) - RANK) base vectors C of the desired left singular subspace in U. C C JOBV CHARACTER*1 C Specifies whether to compute the right singular subspace C as follows: C = 'N': Do not compute the right singular subspace; C = 'A': Return the (N - RANK) base vectors of the desired C right singular subspace in V; C = 'S': Return the first (min(M,N) - RANK) base vectors C of the desired right singular subspace in V. C C Input/Output Parameters C C M (input) INTEGER C The number of rows in matrix A. M >= 0. C C N (input) INTEGER C The number of columns in matrix A. N >= 0. C C RANK (input/output) INTEGER C On entry, if RANK < 0, then the rank of matrix A is C computed by the routine as the number of singular values C greater than THETA. C Otherwise, RANK must specify the rank of matrix A. C RANK <= min(M,N). C On exit, if RANK < 0 on entry, then RANK contains the C computed rank of matrix A. That is, the number of singular C values of A greater than THETA. C Otherwise, the user-supplied value of RANK may be changed C by the routine on exit if the RANK-th and the (RANK+1)-th C singular values of A are considered to be equal. C See also the description of parameter TOL below. C C THETA (input/output) DOUBLE PRECISION C On entry, if RANK < 0, then THETA must specify an upper C bound on the smallest singular values of A corresponding C to the singular subspace to be computed. THETA >= 0.0. C Otherwise, THETA must specify an initial estimate (t say) C for computing an upper bound on the (min(M,N) - RANK) C smallest singular values of A. If THETA < 0.0, then t is C computed by the routine. C On exit, if RANK >= 0 on entry, then THETA contains the C computed upper bound such that precisely RANK singular C values of A are greater than THETA + TOL. C Otherwise, THETA is unchanged. 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 from which the basis of a desired singular C subspace is to be computed. C NOTE that this array is destroyed. C C LDA INTEGER C The leading dimension of array A. LDA >= max(1,M). C C U (output) DOUBLE PRECISION array, dimension (LDU,*) C If JOBU = 'A', then the leading M-by-M part of this array C contains the (M - RANK) M-dimensional base vectors of the C desired left singular subspace of A corresponding to its C singular values less than or equal to THETA. These vectors C are stored in the i-th column(s) of U for which C INUL(i) = .TRUE., where i = 1,2,...,M. C C If JOBU = 'S', then the leading M-by-min(M,N) part of this C array contains the first (min(M,N) - RANK) M-dimensional C base vectors of the desired left singular subspace of A C corresponding to its singular values less than or equal to C THETA. These vectors are stored in the i-th column(s) of U C for which INUL(i) = .TRUE., where i = 1,2,..., min(M,N). C C Otherwise, U is not referenced (since JOBU = 'N') and can C be supplied as a dummy array (i.e. set parameter LDU = 1 C and declare this array to be U(1,1) in the calling C program). C C LDU INTEGER C The leading dimension of array U. C LDU >= max(1,M) if JOBU = 'A' or JOBU = 'S', C LDU >= 1 if JOBU = 'N'. C C V (output) DOUBLE PRECISION array, dimension (LDV,*) C If JOBV = 'A', then the leading N-by-N part of this array C contains the (N - RANK) N-dimensional base vectors of the C desired right singular subspace of A corresponding to its C singular values less than or equal to THETA. These vectors C are stored in the i-th column(s) of V for which C INUL(i) = .TRUE., where i = 1,2,...,N. C C If JOBV = 'S', then the leading N-by-min(M,N) part of this C array contains the first (min(M,N) - RANK) N-dimensional C base vectors of the desired right singular subspace of A C corresponding to its singular values less than or equal to C THETA. These vectors are stored in the i-th column(s) of V C for which INUL(i) = .TRUE., where i = 1,2,...,MIN( M,N). C C Otherwise, V is not referenced (since JOBV = 'N') and can C be supplied as a dummy array (i.e. set parameter LDV = 1 C and declare this array to be V(1,1) in the calling C program). C C LDV INTEGER C The leading dimension of array V. C LDV >= max(1,N) if JOBV = 'A' or JOBV = 'S', C LDV >= 1 if JOBV = 'N'. C C Q (output) DOUBLE PRECISION array, dimension (2*min(M,N)-1) C This array contains the partially diagonalized bidiagonal C matrix J computed from A, at the moment that the desired C singular subspace has been found. Specifically, the C leading p = min(M,N) entries of Q contain the diagonal C elements q(1),q(2),...,q(p) and the entries Q(p+1), C Q(p+2),...,Q(2*p-1) contain the superdiagonal elements C e(1),e(2),...,e(p-1) of J. C C INUL (output) LOGICAL array, dimension (max(M,N)) C If JOBU <> 'N' or JOBV <> 'N', then the indices of the C elements of this array with value .TRUE. indicate the C columns in U and/or V containing the base vectors of the C desired left and/or right singular subspace of A. They C also equal the indices of the diagonal elements of the C bidiagonal submatrices in the array Q, which correspond C to the computed singular subspaces. C C Tolerances C C TOL DOUBLE PRECISION C This parameter defines the multiplicity of singular values C by considering all singular values within an interval of C length TOL as coinciding. TOL is used in checking how many C singular values are less than or equal to THETA. Also in C computing an appropriate upper bound THETA by a bisection C method, TOL is used as a stopping criterion defining the C minimum (absolute) subinterval width. TOL is also taken C as an absolute tolerance for negligible elements in the C QR/QL iterations. If the user sets TOL to be less than or C equal to 0, then the tolerance is taken as specified in C SLICOT Library routine MB04YD document. C C RELTOL DOUBLE PRECISION C This parameter specifies the minimum relative width of an C interval. When an interval is narrower than TOL, or than C RELTOL times the larger (in magnitude) endpoint, then it C is considered to be sufficiently small and bisection has C converged. If the user sets RELTOL to be less than C BASE * EPS, where BASE is machine radix and EPS is machine C precision (see LAPACK Library routine DLAMCH), then the C tolerance is taken as BASE * EPS. 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 length of the array DWORK. C LDWORK = max(1, LDW + max(2*P + max(M,N), LDY)), where C P = min(M,N); C LDW = max(2*N, N*(N+1)/2), if JOBU <> 'N' and M large C enough than N; C LDW = 0, otherwise; C LDY = 8*P - 5, if JOBU <> 'N' or JOBV <> 'N'; C LDY = 6*P - 3, if JOBU = 'N' and JOBV = 'N'. 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 Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: if the rank of matrix A (as specified by the user) C has been lowered because a singular value of C multiplicity greater than 1 was found. 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 maximum number of QR/QL iteration steps C (30*MIN(M,N)) has been exceeded. C C METHOD C C The method used is the Partial Singular Value Decomposition (PSVD) C approach proposed by Van Huffel, Vandewalle and Haegemans, which C is an efficient technique (see [1]) for computing the singular C subspace of a matrix corresponding to its smallest singular C values. It differs from the classical SVD algorithm [3] at three C points, which results in high efficiency. Firstly, the Householder C transformations of the bidiagonalization need only to be applied C on the base vectors of the desired singular subspaces; secondly, C the bidiagonal matrix need only be partially diagonalized; and C thirdly, the convergence rate of the iterative diagonalization can C be improved by an appropriate choice between QL and QR iterations. C (Note, however, that LAPACK Library routine DGESVD, for computing C SVD, also uses either QL and QR iterations.) Depending on the gap, C the desired numerical accuracy and the dimension of the desired C singular subspace, the PSVD can be up to three times faster than C the classical SVD algorithm. C C The PSVD algorithm [1-2] for an M-by-N matrix A proceeds as C follows: C C Step 1: Bidiagonalization phase C ----------------------- C (a) If M is large enough than N, transform A into upper C triangular form R. C C (b) Transform A (or R) into bidiagonal form: C C |q(1) e(1) 0 ... 0 | C (0) | 0 q(2) e(2) . | C J = | . . | C | . e(N-1)| C | 0 ... q(N) | C C if M >= N, or C C |q(1) 0 0 ... 0 0 | C (0) |e(1) q(2) 0 . . | C J = | . . . | C | . q(M-1) . | C | 0 ... e(M-1) q(M)| C C if M < N, using Householder transformations. C In the second case, transform the matrix to the upper bidiagonal C form by applying Givens rotations. C C (c) If U is requested, initialize U with the identity matrix. C If V is requested, initialize V with the identity matrix. C C Step 2: Partial diagonalization phase C ----------------------------- C If the upper bound THETA is not given, then compute THETA such C that precisely (min(M,N) - RANK) singular values of the bidiagonal C matrix are less than or equal to THETA, using a bisection method C [4]. Diagonalize the given bidiagonal matrix J partially, using C either QR iterations (if the upper left diagonal element of the C considered bidiagonal submatrix is larger than the lower right C diagonal element) or QL iterations, such that J is split into C unreduced bidiagonal submatrices whose singular values are either C all larger than THETA or all less than or equal to THETA. C Accumulate the Givens rotations in U and/or V (if desired). C C Step 3: Back transformation phase C ------------------------- C (a) Apply the Householder transformations of Step 1(b) onto the C columns of U and/or V associated with the bidiagonal C submatrices with all singular values less than or equal to C THETA (if U and/or V is desired). C C (b) If M is large enough than N, and U is desired, then apply the C Householder transformations of Step 1(a) onto each computed C column of U in Step 3(a). C C REFERENCES C C [1] Van Huffel, S., Vandewalle, J. and Haegemans, A. C An efficient and reliable algorithm for computing the singular C subspace of a matrix associated with its smallest singular C values. C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. C C [2] Van Huffel, S. C Analysis of the total least squares problem and its use in C parameter estimation. C Doctoral dissertation, Dept. of Electr. Eng., Katholieke C Universiteit Leuven, Belgium, June 1987. C C [3] Chan, T.F. C An improved algorithm for computing the singular value C decomposition. C ACM TOMS, 8, pp. 72-83, 1982. C C [4] Van Huffel, S. and Vandewalle, J. C The partial total least squares algorithm. C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. C C NUMERICAL ASPECTS C C Using the PSVD a large reduction in computation time can be C gained in total least squares applications (cf [2 - 4]), in the C computation of the null space of a matrix and in solving C (non)homogeneous linear equations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. C Supersedes Release 2.0 routine MB04PD by S. Van Huffel, Katholieke C University Leuven, Belgium. C C REVISIONS C C V. Sima, July 10, 1997, Aug. 2011. C C KEYWORDS C C Bidiagonalization, singular subspace, singular value C decomposition, singular values. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBU, JOBV INTEGER INFO, IWARN, LDA, LDU, LDV, LDWORK, M, N, RANK DOUBLE PRECISION RELTOL, THETA, TOL C .. Array Arguments .. LOGICAL INUL(*) DOUBLE PRECISION A(LDA,*), DWORK(*), Q(*), U(LDU,*), V(LDV,*) C .. Local Scalars .. CHARACTER*1 JOBUY, JOBVY LOGICAL ALL, LJOBUA, LJOBUS, LJOBVA, LJOBVS, LQUERY, QR, $ WANTU, WANTV INTEGER I, IHOUSH, IJ, ITAU, ITAUP, ITAUQ, J, JU, JV, $ JWORK, K, LDW, LDY, MA, MINWRK, P, PP1, WRKOPT DOUBLE PRECISION CS, SN, TEMP C .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL ILAENV, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEBRD, DGEQRF, DLARTG, DLASET, DLASR, $ MB04XY, MB04YD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C IWARN = 0 INFO = 0 P = MIN( M, N ) K = MAX( M, N ) C C Determine whether U and/or V are/is to be computed. C LJOBUA = LSAME( JOBU, 'A' ) LJOBUS = LSAME( JOBU, 'S' ) LJOBVA = LSAME( JOBV, 'A' ) LJOBVS = LSAME( JOBV, 'S' ) WANTU = LJOBUA.OR.LJOBUS WANTV = LJOBVA.OR.LJOBVS LQUERY = LDWORK.EQ.-1 C C Test the input scalar arguments. C IF( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( RANK.GT.P ) THEN INFO = -5 ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( ( .NOT.WANTU .AND. LDU.LT.1 ) .OR. $ ( WANTU .AND. LDU.LT.MAX( 1, M ) ) ) THEN INFO = -10 ELSE IF( ( .NOT.WANTV .AND. LDV.LT.1 ) .OR. $ ( WANTV .AND. LDV.LT.MAX( 1, N ) ) ) THEN INFO = -12 ELSE C C Compute workspace. C QR = M.GE.ILAENV( 6, 'DGESVD', 'N' // 'N', M, N, 0, 0 ) IF ( QR.AND.WANTU ) THEN LDW = MAX( 2*N, N*( N + 1 )/2 ) ELSE LDW = 0 END IF IF ( WANTU.OR.WANTV ) THEN LDY = 8*P - 5 ELSE LDY = 6*P - 3 END IF MINWRK = MAX( 1, LDW + MAX( 2*P + K, LDY ) ) IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -18 ELSE IF( LQUERY ) THEN IF ( QR ) THEN CALL DGEQRF( M, N, A, LDA, DWORK, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, N + INT( DWORK(1) ) ) MA = N ELSE WRKOPT = MINWRK MA = M END IF CALL DGEBRD( MA, N, A, LDA, Q, Q, DWORK, DWORK, DWORK, -1, $ INFO ) WRKOPT = MAX( WRKOPT, LDW + 2*P + INT( DWORK(1) ) ) END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB04XD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF ( P.EQ.0 ) THEN IF ( RANK.GE.0 ) $ THETA = ZERO RANK = 0 RETURN END IF C C Initializations. C PP1 = P + 1 ALL = ( LJOBUA .AND. M.GT.N ) .OR. ( LJOBVA .AND. M.LT.N ) C IF ( ALL .AND. ( .NOT.QR ) ) THEN C DO 20 I = 1, P INUL(I) = .FALSE. 20 CONTINUE C DO 40 I = PP1, K INUL(I) = .TRUE. 40 CONTINUE C ELSE C DO 60 I = 1, K INUL(I) = .FALSE. 60 CONTINUE C END IF C C Step 1: Bidiagonalization phase 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 IF ( QR ) THEN C C 1.a.: M is large enough than N; transform A into upper C triangular form R by Householder transformations. C C Workspace: need 2*N; prefer N + N*NB. C ITAU = 1 JWORK = ITAU + N CALL DGEQRF( M, N, A, LDA, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = INT( DWORK(JWORK) )+JWORK-1 C C If (WANTU), store information on the Householder C transformations performed on the columns of A in N*(N+1)/2 C extra storage locations DWORK(K), for K = 1,2,...,N*(N+1)/2. C (The first N locations store the scalar factors of Householder C transformations.) C C Workspace: LDW = max(2*N, N*(N+1)/2). C IF ( WANTU ) THEN IHOUSH = JWORK K = IHOUSH I = N ELSE K = 1 END IF C DO 100 J = 1, N - 1 IF ( WANTU ) THEN I = I - 1 CALL DCOPY( I, A(J+1,J), 1, DWORK(K), 1 ) K = K + I END IF C DO 80 IJ = J + 1, N A(IJ,J) = ZERO 80 CONTINUE C 100 CONTINUE C MA = N WRKOPT = MAX( WRKOPT, K ) ELSE C C Workspace: LDW = 0. C K = 1 MA = M WRKOPT = 1 END IF C C 1.b.: Transform A (or R) into bidiagonal form Q using Householder C transformations. C C Workspace: need LDW + 2*min(M,N) + max(M,N); C prefer LDW + 2*min(M,N) + (M+N)*NB. C ITAUQ = K ITAUP = ITAUQ + P JWORK = ITAUP + P CALL DGEBRD( MA, N, A, LDA, Q, Q(PP1), DWORK(ITAUQ), $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C 1.c.: Initialize U (if WANTU) and V (if WANTV) with the identity C matrix. C IF ( WANTU ) THEN IF ( ALL ) THEN JU = M ELSE JU = P END IF CALL DLASET( 'Full', M, JU, ZERO, ONE, U, LDU ) JOBUY = 'U' ELSE JOBUY = 'N' END IF IF ( WANTV ) THEN IF ( ALL ) THEN JV = N ELSE JV = P END IF CALL DLASET( 'Full', N, JV, ZERO, ONE, V, LDV ) JOBVY = 'U' ELSE JOBVY = 'N' END IF C C If the matrix is lower bidiagonal, rotate to be upper bidiagonal C by applying Givens rotations on the left. C IF ( M.LT.N ) THEN C DO 120 I = 1, P - 1 CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP ) Q(I) = TEMP Q(P+I) = SN*Q(I+1) Q(I+1) = CS*Q(I+1) IF ( WANTU ) THEN C C Workspace: LDW + 4*min(M,N) - 2. C DWORK(JWORK+I-1) = CS DWORK(JWORK+P+I-2) = SN END IF 120 CONTINUE C C Update left singular vectors if desired. C IF( WANTU ) $ CALL DLASR( 'Right', 'Variable pivot', 'Forward', M, JU, $ DWORK(JWORK), DWORK(JWORK+P-1), U, LDU ) C END IF C C Step 2: Partial diagonalization phase. C ----------------------------- C Diagonalize the bidiagonal Q partially until convergence C to the desired left and/or right singular subspace. C C Workspace: LDW + 8*min(M,N) - 5, if WANTU or WANTV; C Workspace: LDW + 6*min(M,N) - 3, if JOBU = JOBV = 'N'. C CALL MB04YD( JOBUY, JOBVY, M, N, RANK, THETA, Q, Q(PP1), U, LDU, $ V, LDV, INUL, TOL, RELTOL, DWORK(JWORK), $ LDWORK-JWORK+1, IWARN, INFO ) IF ( WANTU.OR.WANTV ) THEN WRKOPT = MAX( WRKOPT, JWORK - 6 + 8*P ) ELSE WRKOPT = MAX( WRKOPT, JWORK - 4 + 6*P ) END IF IF ( INFO.GT.0 ) $ RETURN C C Step 3: Back transformation phase. C ------------------------- C 3.a.: Apply the Householder transformations of the bidiagonaliza- C tion onto the base vectors associated with the desired C bidiagonal submatrices. C C Workspace: LDW + 2*min(M,N). C CALL MB04XY( JOBU, JOBV, MA, N, A, LDA, DWORK(ITAUQ), $ DWORK(ITAUP), U, LDU, V, LDV, INUL, INFO ) C C 3.b.: If A was reduced to upper triangular form R and JOBU = 'A' C or JOBU = 'S' apply the Householder transformations of the C triangularization of A onto the desired base vectors. C IF ( QR.AND.WANTU ) THEN IF ( ALL ) THEN C DO 140 I = PP1, M INUL(I) = .TRUE. 140 CONTINUE C END IF K = IHOUSH I = N C DO 160 J = 1, N - 1 I = I - 1 CALL DCOPY( I, DWORK(K), 1, A(J+1,J), 1 ) K = K + I 160 CONTINUE C C Workspace: MIN(M,N) + 1. C JWORK = PP1 CALL MB04XY( JOBU, 'No V', M, N, A, LDA, DWORK(ITAU), $ DWORK(ITAU), U, LDU, DWORK(JWORK), 1, INUL, INFO ) WRKOPT = MAX( WRKOPT, PP1 ) END IF C C Set the optimal workspace. C DWORK(1) = WRKOPT RETURN C *** Last line of MB04XD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03JZ.f0000644000000000000000000000013215012430707016202 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03JZ.f0000644000175000017500000004347115012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE MB03JZ( COMPQ, N, A, LDA, D, LDD, B, LDB, F, LDF, Q, $ LDQ, NEIG, TOL, INFO ) C C PURPOSE C C To move the eigenvalues with strictly negative real parts of an C N-by-N complex skew-Hamiltonian/Hamiltonian pencil aS - bH in C structured Schur form to the leading principal subpencil, while C keeping the triangular form. On entry, we have C C ( A D ) ( B F ) C S = ( ), H = ( ), C ( 0 A' ) ( 0 -B' ) C C where A and B are upper triangular. C S and H are transformed by a unitary matrix Q such that C C ( Aout Dout ) C Sout = J Q' J' S Q = ( ), and C ( 0 Aout' ) C (1) C ( Bout Fout ) ( 0 I ) C Hout = J Q' J' H Q = ( ), with J = ( ), C ( 0 -Bout' ) ( -I 0 ) C C where Aout and Bout remain in upper triangular form. The notation C M' denotes the conjugate transpose of the matrix M. C Optionally, if COMPQ = 'I' or COMPQ = 'U', the unitary matrix Q C that fulfills (1) is computed. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether or not the unitary transformations C should be accumulated in the array Q, as follows: C = 'N': Q is not computed; C = 'I': the array Q is initialized internally to the unit C matrix, and the unitary matrix Q is returned; C = 'U': the array Q contains a unitary matrix Q0 on C entry, and the matrix Q0*Q is returned, where Q C is the product of the unitary transformations C that are applied to the pencil aS - bH to reorder C the eigenvalues. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) COMPLEX*16 array, dimension (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular matrix A. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Aout. C The strictly lower triangular part of this array is not C referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C D (input/output) COMPLEX*16 array, dimension (LDD, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the skew-Hermitian C matrix D. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Dout. C The strictly lower triangular part of this array is not C referenced. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1, N/2). C C B (input/output) COMPLEX*16 array, dimension (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular matrix B. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Bout. C The strictly lower triangular part of this array is not C referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C F (input/output) COMPLEX*16 array, dimension (LDF, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the Hermitian matrix C F. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Fout. C The strictly lower triangular part of this array is not C referenced. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1, N/2). C C Q (input/output) COMPLEX*16 array, dimension (LDQ, N) C On entry, if COMPQ = 'U', then the leading N-by-N part of C this array must contain a given matrix Q0, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q0 and the transformation matrix Q C used to transform the matrices S and H. C On exit, if COMPQ = 'I', then the leading N-by-N part of C this array contains the unitary transformation matrix Q. C If COMPQ = 'N' this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'. C C NEIG (output) INTEGER C The number of eigenvalues in aS - bH with strictly C negative real part. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance used to decide the sign of the eigenvalues. C If the user sets TOL > 0, then the given value of TOL is C used. If the user sets TOL <= 0, then an implicitly C computed, default tolerance, defined by MIN(N,10)*EPS, is C used instead, where EPS is the machine precision (see C LAPACK Library routine DLAMCH). A larger value might be C needed for pencils with multiple eigenvalues. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value. C C METHOD C C The algorithm reorders the eigenvalues like the following scheme: C C Step 1: Reorder the eigenvalues in the subpencil aA - bB. C I. Reorder the eigenvalues with negative real parts to the C top. C II. Reorder the eigenvalues with positive real parts to the C bottom. C C Step 2: Reorder the remaining eigenvalues with negative real parts. C I. Exchange the eigenvalues between the last diagonal block C in aA - bB and the last diagonal block in aS - bH. C II. Move the eigenvalues in the N/2-th place to the (MM+1)-th C place, where MM denotes the current number of eigenvalues C with negative real parts in aA - bB. C C The algorithm uses a sequence of unitary transformations as C described on page 43 in [1]. To achieve those transformations the C elementary SLICOT Library subroutines MB03DZ and MB03HZ are called C for the corresponding matrix structures. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C complex floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, April 6, 2009. C V. Sima, Aug. 2009 (SLICOT version of the routine ZHAUNX). C C REVISIONS C C V. Sima, Dec. 2010, Jan. 2011, Aug. 2014. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue reordering, upper triangular matrix, C skew-Hamiltonian/Hamiltonian pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, TEN PARAMETER ( ZERO = 0.0D+0, TEN = 1.0D+1 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), CONE = ( 1.0D+0, $ 0.0D+0 ) ) C C .. Scalar Arguments .. CHARACTER COMPQ INTEGER INFO, LDA, LDB, LDD, LDF, LDQ, N, NEIG DOUBLE PRECISION TOL C C .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), D( LDD, * ), $ F( LDF, * ), Q( LDQ, * ) C C .. Local Scalars .. LOGICAL LCMPQ, LINIQ, LUPDQ INTEGER IUPD, J, K, M, MM, MP, UPDS DOUBLE PRECISION CO1, CO2, EPS COMPLEX*16 CJF, SI1, SI2, TMP C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C C .. External Subroutines .. EXTERNAL MB03DZ, MB03HZ, XERBLA, ZLASET, ZROT C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 NEIG = 0 LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LCMPQ = LINIQ .OR. LUPDQ C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN INFO = -12 END IF IF( INFO.NE.0) THEN CALL XERBLA( 'MB03JZ', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C EPS = TOL IF ( EPS.LE.ZERO ) THEN C C Use the default tolerance. C EPS = MIN( DBLE( N ), TEN )*DLAMCH( 'Precision' ) END IF C C STEP 0. Initializations. C IF( LINIQ ) THEN IUPD = M + 1 UPDS = M CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) ELSE IF( LUPDQ ) THEN IUPD = 1 UPDS = N END IF C C STEP 1. Reorder the eigenvalues in the subpencil aA - bB. C MM = 0 MP = M + 1 C C I. Reorder the eigenvalues with negative real parts to the top. C DO 20 K = 1, M IF( DBLE( A( K, K ) )*DBLE( B( K, K ) ) + $ DIMAG( A( K, K ) )*DIMAG( B( K, K ) ).LT. $ -ABS( A( K, K ) )*ABS( B( K, K ) )*EPS ) THEN C DO 10 J = K - 1, MM + 1, -1 C C Perform eigenvalue exchange. C CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1, $ CO2, SI2 ) C C Update A and D. C CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 ) A( J, J ) = CO2*A( J, J ) + $ SI2*A( J+1, J+1 )*DCONJG( SI1 ) A( J+1, J+1 ) = CO1*A( J+1, J+1 ) CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, $ CO2, -SI2 ) C CJF = -DCONJG( D( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 ) CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 ) D( J, J ) = CO2*D( J, J ) - SI2*TMP D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF CALL ZROT( M-J, D( J, J+1 ), LDD, D( J+1, J+1 ), LDD, $ CO2, -SI2 ) C C Update B and F. C CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 ) B( J, J ) = CO2*B( J, J ) + $ SI2*B( J+1, J+1 )*DCONJG( SI1 ) B( J+1, J+1 ) = CO1*B( J+1, J+1 ) CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, $ CO2, -SI2 ) C CJF = DCONJG( F( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 ) CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 ) F( J, J ) = CO2*F( J, J ) - SI2*TMP F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF, $ CO2, -SI2 ) C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, $ SI1 ) CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ), $ 1, CO2, SI2 ) END IF 10 CONTINUE MM = MM + 1 END IF 20 CONTINUE C C II. Reorder the eigenvalues with positive real parts to the bottom. C DO 40 K = M, MM + 1, -1 IF( DBLE( A( K, K ) )*DBLE( B( K, K ) ) + $ DIMAG( A( K, K ) )*DIMAG( B( K, K ) ).GT. $ ABS( A( K, K ) )*ABS( B( K, K ) )*EPS ) THEN C DO 30 J = K, MP - 2 C C Perform eigenvalue exchange. C CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1, $ CO2, SI2 ) C C Update A and D. C CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 ) A( J, J ) = CO2*A( J, J ) + $ SI2*A( J+1, J+1 )*DCONJG( SI1 ) A( J+1, J+1 ) = CO1*A( J+1, J+1 ) CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, $ CO2, -SI2 ) C CJF = -DCONJG( D( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 ) CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 ) D( J, J ) = CO2*D( J, J ) - SI2*TMP D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF CALL ZROT( M-J, D( J, J+1 ), LDD, D( J+1, J+1 ), LDD, $ CO2, -SI2 ) C C Update B and F. C CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 ) B( J, J ) = CO2*B( J, J ) + $ SI2*B( J+1, J+1 )*DCONJG( SI1 ) B( J+1, J+1 ) = CO1*B( J+1, J+1 ) CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, $ CO2, -SI2 ) C CJF = DCONJG( F( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 ) CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 ) F( J, J ) = CO2*F( J, J ) - SI2*TMP F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF, $ CO2, -SI2 ) C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, $ SI1 ) CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ), $ 1, CO2, SI2 ) END IF 30 CONTINUE MP = MP - 1 END IF 40 CONTINUE C C The remaining M-MP+1 eigenvalues with negative real part are now in C the bottom right subpencil of aS - bH. C C STEP 2. Reorder the remaining M-MP+1 eigenvalues. C DO 60 K = M, MP, -1 C C I. Exchange the eigenvalues between two diagonal blocks. C C Perform eigenvalue exchange. C CALL MB03HZ( A( M, M ), D( M, M ), B( M, M ), F( M, M ), CO1, $ SI1 ) C C Update A and D. C TMP = DCONJG( A( M, M ) ) CALL ZROT( M, D( 1, M ), 1, A( 1, M ), 1, CO1, SI1 ) A( M, M ) = A( M, M )*CO1 + TMP*DCONJG( SI1 )**2 D( M, M ) = D( M, M )*CO1 - TMP*DCONJG( SI1 )*CO1 C C Update B and F. C TMP = -DCONJG( B( M, M ) ) CALL ZROT( M, F( 1, M ), 1, B( 1, M ), 1, CO1, SI1 ) B( M, M ) = B( M, M )*CO1 + TMP*DCONJG( SI1 )**2 F( M, M ) = F( M, M )*CO1 - TMP*DCONJG( SI1 )*CO1 C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO1, SI1 ) END IF C C II. Move the eigenvalue in the M-th diagonal position to the C (MM+1)-th position. C MM = MM + 1 DO 50 J = M - 1, MM, -1 C C Perform eigenvalue exchange. C CALL MB03DZ( A( J, J ), LDA, B( J, J ), LDB, CO1, SI1, CO2, $ SI2 ) C C Update A and D. C CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 ) A( J, J ) = CO2*A( J, J ) + $ SI2*A( J+1, J+1 )*DCONJG( SI1 ) A( J+1, J+1 ) = CO1*A( J+1, J+1 ) CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO2, $ -SI2 ) C CJF = -DCONJG( D( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*D( J+1, J+1 ) CALL ZROT( J, D( 1, J+1 ), 1, D( 1, J ), 1, CO2, SI2 ) D( J, J ) = CO2*D( J, J ) - SI2*TMP D( J+1, J+1 ) = CO2*D( J+1, J+1 ) + SI2*CJF CALL ZROT( M-J, D( J, J+1 ), LDD, D( J+1, J+1 ), LDD, CO2, $ -SI2 ) C C Update B and F. C CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 ) B( J, J ) = CO2*B( J, J ) + $ SI2*B( J+1, J+1 )*DCONJG( SI1 ) B( J+1, J+1 ) = CO1*B( J+1, J+1 ) CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, CO2, $ -SI2 ) C CJF = DCONJG( F( J, J+1 ) ) TMP = CO2*CJF - DCONJG( SI2 )*F( J+1, J+1 ) CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO2, SI2 ) F( J, J ) = CO2*F( J, J ) - SI2*TMP F( J+1, J+1 ) = CO2*F( J+1, J+1 ) + SI2*CJF CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF, CO2, $ -SI2 ) C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, SI1 ) CALL ZROT( N, Q( 1, M+J+1 ), 1, Q( 1, M+J ), 1, CO2, SI2 $ ) END IF 50 CONTINUE 60 CONTINUE C NEIG = MM C RETURN C *** Last line of MB03JZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01SD.f0000644000000000000000000000013015012430707016162 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MC01SD.f0000644000175000017500000001573315012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE MC01SD( DP, P, S, T, MANT, E, IWORK, INFO ) C C PURPOSE C C To scale the coefficients of the real polynomial P(x) such that C the coefficients of the scaled polynomial Q(x) = sP(tx) have C minimal variation, where s and t are real scalars. C C ARGUMENTS C C Input/Output Parameters C C DP (input) INTEGER C The degree of the polynomial P(x). DP >= 0. C C P (input/output) DOUBLE PRECISION array, dimension (DP+1) C On entry, this array must contain the coefficients of P(x) C in increasing powers of x. C On exit, this array contains the coefficients of the C scaled polynomial Q(x) in increasing powers of x. C C S (output) INTEGER C The exponent of the floating-point representation of the C scaling factor s = BASE**S, where BASE is the base of the C machine representation of floating-point numbers (see C LAPACK Library Routine DLAMCH). C C T (output) INTEGER C The exponent of the floating-point representation of the C scaling factor t = BASE**T. C C MANT (output) DOUBLE PRECISION array, dimension (DP+1) C This array contains the mantissas of the standard C floating-point representation of the coefficients of the C scaled polynomial Q(x) in increasing powers of x. C C E (output) INTEGER array, dimension (DP+1) C This array contains the exponents of the standard C floating-point representation of the coefficients of the C scaled polynomial Q(x) in increasing powers of x. C C Workspace C C IWORK INTEGER array, dimension (DP+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: if on entry, P(x) is the zero polynomial. C C METHOD C C Define the variation of the coefficients of the real polynomial C C 2 DP C P(x) = p(0) + p(1) * x + p(2) * x + ... + p(DP) x C C whose non-zero coefficients can be represented as C e(i) C p(i) = m(i) * BASE (where 1 <= ABS(m(i)) < BASE) C C by C C V = max(e(i)) - min(e(i)), C C where max and min are taken over the indices i for which p(i) is C non-zero. C DP i i C For the scaled polynomial P(cx) = SUM p(i) * c * x with C i=0 C j C c = (BASE) , the variation V(j) is given by C C V(j) = max(e(i) + j * i) - min(e(i) + j * i). C C Using the fact that V(j) is a convex function of j, the routine C determines scaling factors s = (BASE)**S and t = (BASE)**T such C that the coefficients of the scaled polynomial Q(x) = sP(tx) C satisfy the following conditions: C C (a) 1 <= q(0) < BASE and C C (b) the variation of the coefficients of Q(x) is minimal. C C Further details can be found in [1]. C C REFERENCES C C [1] Dunaway, D.K. C Calculation of Zeros of a Real Polynomial through C Factorization using Euclid's Algorithm. C SIAM J. Numer. Anal., 11, pp. 1087-1104, 1974. C C NUMERICAL ASPECTS C C Since the scaling is performed on the exponents of the floating- C point representation of the coefficients of P(x), no rounding C errors occur during the computation of the coefficients of Q(x). C C FURTHER COMMENTS C C The scaling factors s and t are BASE dependent. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01GD by A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Elementary polynomial operations, polynomial operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER DP, INFO, S, T C .. Array Arguments .. INTEGER E(*), IWORK(*) DOUBLE PRECISION MANT(*), P(*) C .. Local Scalars .. LOGICAL OVFLOW INTEGER BETA, DV, I, INC, J, LB, M, UB, V0, V1 C .. External Functions .. INTEGER MC01SX DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, MC01SX C .. External Subroutines .. EXTERNAL MC01SW, MC01SY, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, NINT C .. Executable Statements .. C C Test the input scalar arguments. C IF( DP.LT.0 ) THEN INFO = -1 C C Error return. C CALL XERBLA( 'MC01SD', -INFO ) RETURN END IF C INFO = 0 LB = 1 C WHILE ( LB <= DP+1 and P(LB) = 0 ) DO 20 IF ( LB.LE.DP+1 ) THEN IF ( P(LB).EQ.ZERO ) THEN LB = LB + 1 GO TO 20 END IF END IF C END WHILE 20 C C LB = MIN( i: P(i) non-zero). C IF ( LB.EQ.DP+2 ) THEN INFO = 1 RETURN END IF C UB = DP + 1 C WHILE ( P(UB) = 0 ) DO 40 IF ( P(UB).EQ.ZERO ) THEN UB = UB - 1 GO TO 40 END IF C END WHILE 40 C C UB = MAX(i: P(i) non-zero). C BETA = DLAMCH( 'Base' ) C DO 60 I = 1, DP + 1 CALL MC01SW( P(I), BETA, MANT(I), E(I) ) 60 CONTINUE C C First prescaling. C M = E(LB) IF ( M.NE.0 ) THEN C DO 80 I = LB, UB IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M 80 CONTINUE C END IF S = -M C C Second prescaling. C IF ( UB.GT.1 ) M = NINT( DBLE( E(UB) )/DBLE( UB-1 ) ) C DO 100 I = LB, UB IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M*(I-1) 100 CONTINUE C T = -M C V0 = MC01SX( LB, UB, E, MANT ) J = 1 C DO 120 I = LB, UB IF ( MANT(I).NE.ZERO ) IWORK(I) = E(I) + (I-1) 120 CONTINUE C V1 = MC01SX( LB, UB, IWORK, MANT ) DV = V1 - V0 IF ( DV.NE.0 ) THEN IF ( DV.GT.0 ) THEN J = 0 INC = -1 V1 = V0 DV = -DV C DO 130 I = LB, UB IWORK(I) = E(I) 130 CONTINUE C ELSE INC = 1 END IF C WHILE ( DV < 0 ) DO 140 IF ( DV.LT.0 ) THEN V0 = V1 C DO 150 I = LB, UB E(I) = IWORK(I) 150 CONTINUE C J = J + INC C DO 160 I = LB, UB IWORK(I) = E(I) + INC*(I-1 ) 160 CONTINUE C V1 = MC01SX( LB, UB, IWORK, MANT ) DV = V1 - V0 GO TO 140 END IF C END WHILE 140 T = T + J - INC END IF C C Evaluation of the output parameters. C DO 180 I = LB, UB CALL MC01SY( MANT(I), E(I), BETA, P(I), OVFLOW ) 180 CONTINUE C RETURN C *** Last line of MC01SD *** END control-4.1.2/src/slicot/src/PaxHeaders/MD03BA.f0000644000000000000000000000013015012430707016141 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MD03BA.f0000644000175000017500000001123215012430707017336 0ustar00lilgelilge00000000000000 SUBROUTINE MD03BA( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, $ GNORM, IPVT, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the QR factorization with column pivoting of an C m-by-n Jacobian matrix J (m >= n), that is, J*P = Q*R, where Q is C a matrix with orthogonal columns, P a permutation matrix, and C R an upper trapezoidal matrix with diagonal elements of C nonincreasing magnitude, and to apply the transformation Q' on C the error vector e (in-situ). The 1-norm of the scaled gradient C is also returned. C C This routine is an interface to SLICOT Library routine MD03BX, C for solving standard nonlinear least squares problems using SLICOT C routine MD03BD. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The number of columns of the Jacobian matrix J. N >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of the C matrix J, as follows: C IPAR(1) must contain the number of rows M of the Jacobian C matrix J. M >= N. C IPAR is provided for compatibility with SLICOT Library C routine MD03BD. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 1. C C FNORM (input) DOUBLE PRECISION C The Euclidean norm of the vector e. FNORM >= 0. C C J (input/output) DOUBLE PRECISION array, dimension (LDJ, N) C On entry, the leading M-by-N part of this array must C contain the Jacobian matrix J. C On exit, the leading N-by-N upper triangular part of this C array contains the upper triangular factor R of the C Jacobian matrix. Note that for efficiency of the later C calculations, the matrix R is delivered with the leading C dimension MAX(1,N), possibly much smaller than the value C of LDJ on entry. C C LDJ (input/output) INTEGER C The leading dimension of array J. C On entry, LDJ >= MAX(1,M). C On exit, LDJ >= MAX(1,N). C C E (input/output) DOUBLE PRECISION array, dimension (M) C On entry, this array must contain the error vector e. C On exit, this array contains the updated vector Q'*e. C C JNORMS (output) DOUBLE PRECISION array, dimension (N) C This array contains the Euclidean norms of the columns C of the Jacobian matrix, considered in the initial order. C C GNORM (output) DOUBLE PRECISION C If FNORM > 0, the 1-norm of the scaled vector C J'*Q'*e/FNORM, with each element i further divided C by JNORMS(i) (if JNORMS(i) is nonzero). C If FNORM = 0, the returned value of GNORM is 0. C C IPVT (output) INTEGER array, dimension (N) C This array defines the permutation matrix P such that C J*P = Q*R. Column j of P is column IPVT(j) of the identity C matrix. 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 length of the array DWORK. C LDWORK >= 1, if N = 0 or M = 1; C LDWORK >= 4*N+1, if N > 1. 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 C METHOD C C This routine calls SLICOT Library routine MD03BX to perform the C calculations. C C FURTHER COMMENTS C C For efficiency, the arguments are not checked. This is done in C the routine MD03BX (except for LIPAR). C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, Jacobian matrix, matrix algebra, C matrix operations. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INFO, LDJ, LDWORK, LIPAR, N DOUBLE PRECISION FNORM, GNORM C .. Array Arguments .. INTEGER IPAR(*), IPVT(*) DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) C .. External Subroutines .. EXTERNAL MD03BX C .. C .. Executable Statements .. C CALL MD03BX( IPAR(1), N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, $ DWORK, LDWORK, INFO ) RETURN C C *** Last line of MD03BA *** END control-4.1.2/src/slicot/src/PaxHeaders/TD04AD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TD04AD.f0000644000175000017500000003377615012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF, $ LDUCO1, LDUCO2, NR, A, LDA, B, LDB, C, LDC, D, $ LDD, TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To find a minimal state-space representation (A,B,C,D) for a C proper transfer matrix T(s) given as either row or column C polynomial vectors over denominator polynomials, possibly with C uncancelled common terms. C C ARGUMENTS C C Mode Parameters C C ROWCOL CHARACTER*1 C Indicates whether the transfer matrix T(s) is given as C rows or columns over common denominators as follows: C = 'R': T(s) is given as rows over common denominators; C = 'C': T(s) is given as columns over common denominators. C C Input/Output Parameters 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 INDEX (input) INTEGER array, dimension (porm), where porm = P, C if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'. C This array must contain the degrees of the denominator C polynomials in D(s). C C DCOEFF (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef), C where kdcoef = MAX(INDEX(I)) + 1. C The leading porm-by-kdcoef part of this array must contain C the coefficients of each denominator polynomial. C DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of the C I-th denominator polynomial in D(s), where C K = 1,2,...,kdcoef. C C LDDCOE INTEGER C The leading dimension of array DCOEFF. C LDDCOE >= MAX(1,P) if ROWCOL = 'R'; C LDDCOE >= MAX(1,M) if ROWCOL = 'C'. C C UCOEFF (input) DOUBLE PRECISION array, dimension C (LDUCO1,LDUCO2,kdcoef) C The leading P-by-M-by-kdcoef part of this array must C contain the numerator matrix U(s); if ROWCOL = 'C', this C array is modified internally but restored on exit, and the C remainder of the leading MAX(M,P)-by-MAX(M,P)-by-kdcoef C part is used as internal workspace. C UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; C if ROWCOL = 'R' then iorj = I, otherwise iorj = J. C Thus for ROWCOL = 'R', U(s) = C diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). C C LDUCO1 INTEGER C The leading dimension of array UCOEFF. C LDUCO1 >= MAX(1,P) if ROWCOL = 'R'; C LDUCO1 >= MAX(1,M,P) if ROWCOL = 'C'. C C LDUCO2 INTEGER C The second dimension of array UCOEFF. C LDUCO2 >= MAX(1,M) if ROWCOL = 'R'; C LDUCO2 >= MAX(1,M,P) if ROWCOL = 'C'. C C NR (output) INTEGER C The order of the resulting minimal realization, i.e. the C order of the state dynamics matrix A. C C A (output) DOUBLE PRECISION array, dimension (LDA,N), C porm C where N = SUM INDEX(I). C I=1 C The leading NR-by-NR part of this array contains the upper C block Hessenberg state dynamics matrix A of a minimal C realization. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) C The leading NR-by-M part of this array contains the C input/state matrix B of a minimal realization; the C remainder of the leading N-by-MAX(M,P) part is used as C internal workspace. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C C (output) DOUBLE PRECISION array, dimension (LDC,N) C The leading P-by-NR part of this array contains the C state/output matrix C of a minimal realization; the C remainder of the leading MAX(M,P)-by-N part is used as C internal workspace. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,M,P). C C D (output) DOUBLE PRECISION array, dimension (LDD,M), C if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'. C The leading P-by-M part of this array contains the direct C transmission matrix D; if ROWCOL = 'C', the remainder of C the leading MAX(M,P)-by-MAX(M,P) part is used as internal C workspace. C C LDD INTEGER C The leading dimension of array D. C LDD >= MAX(1,P) if ROWCOL = 'R'; C LDD >= MAX(1,M,P) if ROWCOL = 'C'. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determination when C transforming (A, B, C). If the user sets TOL > 0, then C the given value of TOL is used as a lower bound for the C reciprocal condition number (see the description of the C argument RCOND in the SLICOT routine MB03OD); a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance C (determined by the SLICOT routine TB01UD) is used instead. C C Workspace C C IWORK INTEGER array, dimension (N+MAX(M,P)) C On exit, if INFO = 0, the first nonzero elements of C IWORK(1:N) return the orders of the diagonal blocks of A. 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, N + MAX(N, 3*M, 3*P)). 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, then i is the first integer for which C ABS( DCOEFF(I,1) ) is so small that the calculations C would overflow (see SLICOT Library routine TD03AY); C that is, the leading coefficient of a polynomial is C nearly zero; no state-space representation is C calculated. C C METHOD C C The method for transfer matrices factorized by rows will be C described here: T(s) factorized by columns is dealt with by C operating on the dual T'(s). This description for T(s) is C actually the left polynomial matrix representation C C T(s) = inv(D(s))*U(s), C C where D(s) is diagonal with its (I,I)-th polynomial element of C degree INDEX(I). The first step is to check whether the leading C coefficient of any polynomial element of D(s) is approximately C zero; if so the routine returns with INFO > 0. Otherwise, C Wolovich's Observable Structure Theorem is used to construct a C state-space representation in observable companion form which C is equivalent to the above polynomial matrix representation. C The method is particularly easy here due to the diagonal form C of D(s). This state-space representation is not necessarily C controllable (as D(s) and U(s) are not necessarily relatively C left prime), but it is in theory completely observable; however, C its observability matrix may be poorly conditioned, so it is C treated as a general state-space representation and SLICOT C Library routine TB01PD is then called to separate out a minimal C realization from this general state-space representation by means C of orthogonal similarity transformations. C C REFERENCES C C [1] Patel, R.V. C Computation of Minimal-Order State-Space Realizations and C Observability Indices using Orthogonal Transformations. C Int. J. Control, 33, pp. 227-246, 1981. C C [2] Wolovich, W.A. C Linear Multivariable Systems, (Theorem 4.3.3). C Springer-Verlag, 1974. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. C Supersedes Release 3.0 routine TD01OD. C C REVISIONS C C - C C KEYWORDS C C Controllability, elementary polynomial operations, minimal C realization, polynomial matrix, state-space representation, C transfer matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER ROWCOL INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, $ LDUCO2, LDWORK, M, NR, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER INDEX(*), IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DCOEFF(LDDCOE,*), DWORK(*), $ UCOEFF(LDUCO1,LDUCO2,*) C .. Local Scalars .. LOGICAL LROCOC, LROCOR INTEGER I, J, JSTOP, K, KDCOEF, MPLIM, MWORK, N, PWORK C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLASET, DSWAP, TB01PD, TB01XD, TD03AY, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C INFO = 0 LROCOR = LSAME( ROWCOL, 'R' ) LROCOC = LSAME( ROWCOL, 'C' ) MPLIM = MAX( 1, M, P ) C C Test the input scalar arguments. C IF( .NOT.LROCOR .AND. .NOT.LROCOC ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( P.LT.0 ) THEN INFO = -3 ELSE IF( ( LROCOR .AND. LDDCOE.LT.MAX( 1, P ) ) .OR. $ ( LROCOC .AND. LDDCOE.LT.MAX( 1, M ) ) ) THEN INFO = -6 ELSE IF( ( LROCOR .AND. LDUCO1.LT.MAX( 1, P ) ) .OR. $ ( LROCOC .AND. LDUCO1.LT.MPLIM ) ) THEN INFO = -8 ELSE IF( ( LROCOR .AND. LDUCO2.LT.MAX( 1, M ) ) .OR. $ ( LROCOC .AND. LDUCO2.LT.MPLIM ) ) THEN INFO = -9 END IF C N = 0 IF ( INFO.EQ.0 ) THEN IF ( LROCOR ) THEN C C Initialization for T(s) given as rows over common C denominators. C PWORK = P MWORK = M ELSE C C Initialization for T(s) given as columns over common C denominators. C PWORK = M MWORK = P END IF C C Calculate N, the order of the resulting state-space C representation. C KDCOEF = 0 C DO 10 I = 1, PWORK KDCOEF = MAX( KDCOEF, INDEX(I) ) N = N + INDEX(I) 10 CONTINUE C KDCOEF = KDCOEF + 1 C IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDC.LT.MPLIM ) THEN INFO = -16 ELSE IF( ( LROCOR .AND. LDD.LT.MAX( 1, P ) ) .OR. $ ( LROCOC .AND. LDD.LT.MPLIM ) ) THEN INFO = -18 ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*M, 3*P ) ) ) THEN INFO = -22 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TD04AD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, M, P ).EQ.0 ) THEN NR = 0 DWORK(1) = ONE RETURN END IF C IF ( LROCOC ) THEN C C Initialize the remainder of the leading C MPLIM-by-MPLIM-by-KDCOEF part of U(s) to zero. C IF ( P.LT.M ) THEN C DO 20 K = 1, KDCOEF CALL DLASET( 'Full', M-P, MPLIM, ZERO, ZERO, $ UCOEFF(P+1,1,K), LDUCO1 ) 20 CONTINUE C ELSE IF ( P.GT.M ) THEN C DO 30 K = 1, KDCOEF CALL DLASET( 'Full', MPLIM, P-M, ZERO, ZERO, $ UCOEFF(1,M+1,K), LDUCO1 ) 30 CONTINUE C END IF C IF ( MPLIM.NE.1 ) THEN C C Non-scalar T(s) factorized by columns: transpose it (i.e. C U(s)). C JSTOP = MPLIM - 1 C DO 50 K = 1, KDCOEF C DO 40 J = 1, JSTOP CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, $ UCOEFF(J,J+1,K), LDUCO1 ) 40 CONTINUE C 50 CONTINUE C END IF END IF C C Construct non-minimal state-space representation (by Wolovich's C Structure Theorem) which has transfer matrix T(s) or T'(s) as C appropriate ... C CALL TD03AY( MWORK, PWORK, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, $ LDUCO2, N, A, LDA, B, LDB, C, LDC, D, LDD, INFO ) IF ( INFO.GT.0 ) $ RETURN C C and then separate out a minimal realization from this. C C Workspace: need N + MAX(N, 3*MWORK, 3*PWORK). C CALL TB01PD( 'Minimal', 'Scale', N, MWORK, PWORK, A, LDA, B, LDB, $ C, LDC, NR, TOL, IWORK, DWORK, LDWORK, INFO ) C IF ( LROCOC ) THEN C C If T(s) originally factorized by columns, find dual of minimal C state-space representation, and reorder the rows and columns C to get an upper block Hessenberg state dynamics matrix. C K = IWORK(1)+IWORK(2)-1 CALL TB01XD( 'D', NR, MWORK, PWORK, K, NR-1, A, LDA, B, LDB, $ C, LDC, D, LDD, INFO ) IF ( MPLIM.NE.1 ) THEN C C Also, retranspose U(s) if this is non-scalar. C DO 70 K = 1, KDCOEF C DO 60 J = 1, JSTOP CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, $ UCOEFF(J,J+1,K), LDUCO1 ) 60 CONTINUE C 70 CONTINUE C END IF END IF C RETURN C *** Last line of TD04AD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03OD.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB03OD.f0000644000175000017500000007660715012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE SB03OD( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B, $ LDB, SCALE, WR, WI, DWORK, LDWORK, INFO ) C C PURPOSE C C To solve for X = op(U)'*op(U) either the stable non-negative C definite continuous-time Lyapunov equation C 2 C op(A)'*X + X*op(A) = -scale *op(B)'*op(B), (1) C C or the convergent non-negative definite discrete-time Lyapunov C equation C 2 C op(A)'*X*op(A) - X = -scale *op(B)'*op(B), (2) C C where op(K) = K or K' (i.e., the transpose of the matrix K), A is C an N-by-N matrix, op(B) is an M-by-N matrix, U is an upper C triangular matrix containing the Cholesky factor of the solution C matrix X, X = op(U)'*op(U), and scale is an output scale factor, C set less than or equal to 1 to avoid overflow in X. If matrix B C has full rank then the solution matrix X will be positive definite C and hence the Cholesky factor U will be nonsingular, but if B is C rank deficient, then X may be only positive semi-definite and U C will be singular. C C In the case of equation (1) the matrix A must be stable (that is, C all the eigenvalues of A must have negative real parts), and for C equation (2) the matrix A must be convergent (that is, all the C eigenvalues of A must lie inside the unit circle). C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of Lyapunov equation to be solved, as C follows: C = 'C': Equation (1), continuous-time case; C = 'D': Equation (2), discrete-time case. 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 Q 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 Q. C C TRANS CHARACTER*1 C Specifies the form of op(K) to be used, as follows: C = 'N': op(K) = K (No transpose); C = 'T': op(K) = K**T (Transpose). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A and the number of columns of C the matrix op(B). N >= 0. C C M (input) INTEGER C The number of rows of the matrix op(B). M >= 0. C If M = 0, A is unchanged on exit, and Q, WR and WI are not C set. 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 S in Schur canonical C form; the elements below the upper Hessenberg part of the C array A are then not referenced. C On exit, the leading N-by-N upper Hessenberg part of this C array contains the upper quasi-triangular matrix S in C Schur canonical form from the Shur factorization of A. C The contents of the array A is not modified if FACT = 'F'. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C Q (input or output) DOUBLE PRECISION array, dimension C (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 of the C Schur factorization of A. C Otherwise, 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 of the Schur factorization of A. C The contents of the array Q is not modified if FACT = 'F'. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) C if TRANS = 'N', and dimension (LDB,max(M,N)), if C TRANS = 'T'. C On entry, if TRANS = 'N', the leading M-by-N part of this C array must contain the coefficient matrix B of the C equation. C On entry, if TRANS = 'T', the leading N-by-M part of this C array must contain the coefficient matrix B of the C equation. C On exit, the leading N-by-N part of this array contains C the upper triangular Cholesky factor U of the solution C matrix X of the problem, X = op(U)'*op(U). C If M = 0 and N > 0, then U is set to zero. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N,M), if TRANS = 'N'; C LDB >= MAX(1,N), if TRANS = 'T'. 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 WR (output) DOUBLE PRECISION array, dimension (N) C WI (output) DOUBLE PRECISION array, dimension (N) C If INFO >= 0 and INFO <= 3, WR and WI contain the real and C imaginary parts, respectively, of the eigenvalues of A. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or INFO = 1, DWORK(1) returns the C optimal value of LDWORK. C On exit, if INFO = -16, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C If M > 0, LDWORK >= MAX(1,4*N); C If M = 0, LDWORK >= 1. C For optimum performance LDWORK should sometimes be larger. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 = 1: if the Lyapunov equation is (nearly) singular C (warning indicator); C if DICO = 'C' this means that while the matrix A C (or the factor S) has computed eigenvalues with C negative real parts, it is only just stable in the C sense that small perturbations in A can make one or C more of the eigenvalues have a non-negative real C part; C if DICO = 'D' this means that while the matrix A C (or the factor S) has computed eigenvalues inside C the unit circle, it is nevertheless only just C convergent, in the sense that small perturbations C in A can make one or more of the eigenvalues lie C outside the unit circle; C perturbed values were used to solve the equation; C = 2: if FACT = 'N' and DICO = 'C', but the matrix A is C not stable (that is, one or more of the eigenvalues C of A has a non-negative real part), or DICO = 'D', C but the matrix A is not convergent (that is, one or C more of the eigenvalues of A lies outside the unit C circle); however, A will still have been factored C and the eigenvalues of A returned in WR and WI. C = 3: if FACT = 'F' and DICO = 'C', but the Schur factor S C supplied in the array A is not stable (that is, one C or more of the eigenvalues of S has a non-negative C real part), or DICO = 'D', but the Schur factor S C supplied in the array A is not convergent (that is, C one or more of the eigenvalues of S lies outside the C unit circle); the eigenvalues of A are still C returned in WR and WI; C = 4: if FACT = 'F' and the Schur factor S supplied in C the array A has two or more consecutive non-zero C elements on the first subdiagonal, so that there is C a block larger than 2-by-2 on the diagonal; C = 5: if FACT = 'F' and the Schur factor S supplied in C the array A has a 2-by-2 diagonal block with real C eigenvalues instead of a complex conjugate pair; C = 6: if FACT = 'N' and the LAPACK Library routine DGEES C has failed to converge. This failure is not likely C to occur. The matrix B will be unaltered but A will C be destroyed. C C METHOD C C The method used by the routine is based on the Bartels and Stewart C method [1], except that it finds the upper triangular matrix U C directly without first finding X and without the need to form the C normal matrix op(B)'*op(B). C C The Schur factorization of a square matrix A is given by C C A = QSQ', C C where Q is orthogonal and S is an N-by-N block upper triangular C matrix with 1-by-1 and 2-by-2 blocks on its diagonal (which C correspond to the eigenvalues of A). If A has already been C factored prior to calling the routine however, then the factors C Q and S may be supplied and the initial factorization omitted. C C If TRANS = 'N' and 6*M > 7*N, the matrix B is factored as C (QR factorization) C _ _ C B = P ( R ), C ( 0 ) C _ _ C where P is an M-by-M orthogonal matrix and R is a square upper C _ _ C triangular matrix. Then, the matrix B = RQ is factored as C _ C B = PR. C C If TRANS = 'N' and 6*M <= 7*N, the matrix BQ is factored as C C BQ = P ( R ), M >= N, BQ = P ( R Z ), M < N. C ( 0 ) C C If TRANS = 'T' and 6*M > 7*N, the matrix B is factored as C (RQ factorization) C _ _ C B = ( 0 R ) P, C _ _ C where P is an M-by-M orthogonal matrix and R is a square upper C _ _ C triangular matrix. Then, the matrix B = Q' R is factored as C _ C B = RP. C C If TRANS = 'T' and 6*M <= 7*N, the matrix Q' B is factored as C C ( Z ) C Q' B = ( 0 R ) P, M >= N, Q' B = ( ) P, M < N. C ( R ) C C These factorizations are utilised to either transform the C continuous-time Lyapunov equation to the canonical form C 2 C op(S)'*op(V)'*op(V) + op(V)'*op(V)*op(S) = -scale *op(F)'*op(F), C C or the discrete-time Lyapunov equation to the canonical form C 2 C op(S)'*op(V)'*op(V)*op(S) - op(V)'*op(V) = -scale *op(F)'*op(F), C C where V and F are upper triangular, and C C F = R, M >= N, F = ( R Z ), M < N, if TRANS = 'N'; C ( 0 0 ) C C F = R, M >= N, F = ( 0 Z ), M < N, if TRANS = 'T'. C ( 0 R ) C C The transformed equation is then solved for V, from which U is C obtained via the QR factorization of V*Q', if TRANS = 'N', or C via the RQ factorization of Q*V, if TRANS = 'T'. C C REFERENCES C C [1] Bartels, R.H. and Stewart, G.W. C Solution of the matrix equation A'X + XB = C. C Comm. A.C.M., 15, pp. 820-826, 1972. C C [2] 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 The Lyapunov equation may be very ill-conditioned. In particular, C if A is only just stable (or convergent) then the Lyapunov C equation will be ill-conditioned. A symptom of ill-conditioning C is "large" elements in U relative to those of A and B, or a C "small" value for scale. A condition estimate can be computed C using SLICOT Library routine SB03MD. C C SB03OD routine can be also used for solving "unstable" Lyapunov C equations, i.e., when matrix A has all eigenvalues with positive C real parts, if DICO = 'C', or with moduli greater than one, C if DICO = 'D'. Specifically, one may solve for X = op(U)'*op(U) C either the continuous-time Lyapunov equation C 2 C op(A)'*X + X*op(A) = scale *op(B)'*op(B), (3) C C or the discrete-time Lyapunov equation C 2 C op(A)'*X*op(A) - X = scale *op(B)'*op(B), (4) C C provided, for equation (3), the given matrix A is replaced by -A, C or, for equation (4), the given matrices A and B are replaced by C inv(A) and B*inv(A), if TRANS = 'N' (or inv(A)*B, if TRANS = 'T'), C respectively. Although the inversion generally can rise numerical C problems, in case of equation (4) it is expected that the matrix A C is enough well-conditioned, having only eigenvalues with moduli C greater than 1. However, if A is ill-conditioned, it could be C preferable to use the more general SLICOT Lyapunov solver SB03MD. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB03CD by Sven Hammarling, C NAG Ltd, United Kingdom. C C REVISIONS C C Dec. 1997, April 1998, May 1998, May 1999, Oct. 2001 (V. Sima). C March 2002 (A. Varga). C V. Sima, July 2011, Jan. - Feb. 2022, May 2022. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form, C Sylvester equation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, P95 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, P95 = 0.95D0 ) C .. Scalar Arguments .. CHARACTER DICO, FACT, TRANS INTEGER INFO, LDA, LDB, LDQ, LDWORK, M, N DOUBLE PRECISION SCALE C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), Q(LDQ,*), WI(*), $ WR(*) C .. Local Scalars .. DOUBLE PRECISION BIGNMS, BIGNUM, EMAX, EPS, MA, MATO, MB, MBTO, $ MN, MX, SAFMIN, SMLNUM, T, TMP INTEGER BL, I, IFAIL, INFORM, ITAU, J, JWORK, K, L, $ MAXMN, MINMN, MINWRK, NC, NM, NR, SDIM, WRKOPT LOGICAL CONT, ISTRAN, LASCL, LBSCL, LQUERY, LSCL, $ NOFACT, NUNITQ, SCALB, SMALLM C .. Local Arrays .. LOGICAL BWORK(1) C .. External Functions .. LOGICAL LSAME, MA02HD, SELECT DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANTR, DLAPY2 EXTERNAL DLAMCH, DLANGE, DLANHS, DLANTR, DLAPY2, LSAME, $ MA02HD, SELECT C .. External Subroutines .. EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DGEQRF, DGERQF, $ DLABAD, DLACPY, DLANV2, DLASCL, DLASET, DSCAL, $ DSWAP, DTRMM, MB01UY, SB03OT, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, SQRT C .. Executable Statements .. C C Test the input scalar arguments. C CONT = LSAME( DICO, 'C' ) NOFACT = LSAME( FACT, 'N' ) ISTRAN = LSAME( TRANS, 'T' ) LQUERY = LDWORK.EQ.-1 MINMN = MIN( M, N ) MAXMN = MAX( M, N ) C INFO = 0 IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN INFO = -1 ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN INFO = -2 ELSE IF( .NOT.ISTRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF ( ( ISTRAN .AND. ( LDB.LT.MAX( 1, N ) ) ) .OR. $ ( .NOT.ISTRAN .AND. ( LDB.LT.MAX( 1, MAXMN ) ) ) ) THEN INFO = -11 ELSE IF ( MINMN.EQ.0 ) THEN MINWRK = 1 ELSE MINWRK = 4*N END IF SMALLM = 6*M.LE.7*N IF( LQUERY ) THEN IF ( NOFACT ) THEN CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, $ SDIM, WR, WI, Q, LDQ, DWORK, -1, BWORK, $ IFAIL ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) ELSE WRKOPT = MINWRK END IF CALL DGEQRF( MAXMN, N, B, LDB, DWORK, DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + N ) ELSE IF( LDWORK.LT.MINWRK ) THEN DWORK(1) = MINWRK INFO = -16 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB03OD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C SCALE = ONE C C Quick return if possible. C IF ( ISTRAN ) THEN K = N L = M ELSE K = M L = N END IF MB = DLANGE( 'Max', K, L, B, LDB, DWORK ) IF ( MB.EQ.ZERO ) THEN IF ( N.GT.0 ) $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDB ) DWORK(1) = ONE RETURN END IF C C Set constants to control overflow. C EPS = DLAMCH( 'Precision' ) SAFMIN = DLAMCH( 'Safe minimum' ) SMLNUM = SAFMIN BIGNMS = ONE/SMLNUM CALL DLABAD( SMLNUM, BIGNMS ) SMLNUM = SQRT( SMLNUM )/EPS BIGNUM = ONE/SMLNUM C C Start the solution. 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 IF ( NOFACT ) THEN C C Find the Schur factorization of A, A = Q*S*Q'. C Workspace: need 3*N; C prefer larger. C CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, $ WR, WI, Q, LDQ, DWORK, LDWORK, BWORK, INFORM ) IF ( INFORM.NE.0 ) THEN INFO = 6 RETURN END IF WRKOPT = DWORK(1) ELSE C C Set the eigenvalues of the matrix A. C I = 1 C C WHILE( I.LT.N )LOOP 10 CONTINUE IF ( I.LT.N ) THEN IF ( A(I+1,I).NE.ZERO ) THEN CALL DLANV2( A(I,I), A(I,I+1), A(I+1,I), A(I+1,I+1), $ WR(I), WI(I), WR(I+1), WI(I+1), T, TMP ) I = I + 2 ELSE WR(I) = A(I,I) WI(I) = ZERO I = I + 1 END IF GO TO 10 END IF C END WHILE 10 IF ( I.EQ.N ) THEN WR(I) = A(I,I) WI(I) = ZERO END IF WRKOPT = 0 END IF C C Check for identity matrix Q. C NUNITQ = .NOT.MA02HD( 'All', N, N, ONE, Q, LDQ ) C C Check the eigenvalues for stability. C IF ( CONT ) THEN EMAX = WR(1) C DO 20 J = 2, N IF ( WR(J).GT.EMAX ) $ EMAX = WR(J) 20 CONTINUE C ELSE EMAX = DLAPY2( WR(1), WI(1) ) C DO 30 J = 2, N TMP = DLAPY2( WR(J), WI(J) ) IF ( TMP.GT.EMAX ) $ EMAX = TMP 30 CONTINUE C END IF C IF ( ( CONT ) .AND. ( EMAX.GE.ZERO ) .OR. $ ( .NOT.CONT ) .AND. ( EMAX.GE.ONE ) ) THEN IF ( NOFACT ) THEN INFO = 2 ELSE INFO = 3 END IF RETURN END IF C C Scale A if the maximum absolute value of its elements is outside C the range [SMLNUM,BIGNUM]. Scale similarly B. Scaling of B is done C before further processing if the maximum absolute value of its C elements is greater than BIGNMS; otherwise, it is postponed. C For continuous-time equations, scaling is also performed if the C maximum absolute values of A and B differ too much, or their C minimum (maximum) is too large (small). C MA = MIN( DLANHS( 'Max', N, A, LDA, DWORK ), BIGNMS ) MN = MIN( MA, MB ) MX = MAX( MA, MB ) C IF ( CONT ) THEN LSCL = MN.LT.MX*SMLNUM .OR. MX.LT.SMLNUM .OR. MN.GT.BIGNUM ELSE LSCL = .FALSE. END IF C IF ( LSCL ) THEN MATO = ONE MBTO = ONE LASCL = .TRUE. LBSCL = .TRUE. ELSE IF ( MA.GT.ZERO .AND. MA.LT.SMLNUM ) THEN MATO = SMLNUM LASCL = .TRUE. ELSE IF ( MA.GT.BIGNUM ) THEN MATO = BIGNUM LASCL = .TRUE. ELSE LASCL = .FALSE. END IF C IF ( MB.GT.ZERO .AND. MB.LT.SMLNUM ) THEN MBTO = SMLNUM LBSCL = .TRUE. ELSE IF ( MB.GT.BIGNUM ) THEN MBTO = BIGNUM LBSCL = .TRUE. ELSE MBTO = ONE LBSCL = .FALSE. END IF END IF C IF ( .NOT.CONT .AND. MATO.EQ.ONE ) $ MATO = P95 IF ( LASCL ) $ CALL DLASCL( 'Hess', 0, 0, MA, MATO, N, N, A, LDA, INFO ) C SCALB = MB.GT.BIGNMS MB = MIN( MB, BIGNMS ) IF ( LBSCL .AND. SCALB ) $ CALL DLASCL( 'Gen', 0, 0, MB, MBTO, K, L, B, LDB, INFO ) C C Transformation of the right hand side, involving one or two RQ or C QR factorizations. Also, do scaling, if it was postponed. C C Workspace: need MIN(M,N) + N; C prefer MIN(M,N) + N*NB. C ITAU = 1 JWORK = ITAU + MINMN C IF ( ISTRAN ) THEN NM = M IF ( NUNITQ ) THEN IF ( SMALLM ) THEN C _ C Compute B := Q' * B. C NC = INT( LDWORK / N ) C DO 40 J = 1, M, NC BL = MIN( M-J+1, NC ) CALL DGEMM( 'Trans', 'NoTran', N, BL, N, ONE, Q, $ LDQ, B(1,J), LDB, ZERO, DWORK, N ) CALL DLACPY( 'All', N, BL, DWORK, N, B(1,J), LDB ) 40 CONTINUE C ELSE C C If M > 7*N/6, perform the RQ factorization of B, C _ _ C B = ( 0 R ) P. C NM = N CALL DGERQF( N, M, B, LDB, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1, $ MINMN*N ) C C Form in B C _ _ _ C B := Q' * R, with B an N-by-MIN(M,N) matrix. C Use a BLAS 3 operation if enough workspace, and BLAS 2, C _ C otherwise: B is formed column by column. C IF ( LDWORK.GE.MINMN*N ) THEN J = 1 C DO 50 I = 1, MINMN CALL DCOPY( N, Q(N-MINMN+I,1), LDQ, DWORK(J), 1 ) J = J + N 50 CONTINUE C CALL DTRMM( 'Right', 'Upper', 'NoTran', 'NoUnit', N, $ MINMN, ONE, B(N-MINMN+1,M-MINMN+1), LDB, $ DWORK, N ) CALL DLACPY( 'Full', N, MINMN, DWORK, N, B, LDB ) ELSE C DO 60 J = 1, MINMN CALL DCOPY( J, B(1,M-MINMN+J), 1, DWORK, 1 ) CALL DGEMV( 'Trans', J, N, ONE, Q, LDQ, DWORK, 1, $ ZERO, B(1,J), 1 ) 60 CONTINUE C END IF END IF END IF C _ C Perform the RQ factorization of B to get the factor F. C Note that if M <= 7*N/6, the factorization is C _ _ C B := ( 0 F ) P, M >= N, B := ( Z' F' )' P, M < N. C Then, do scaling, if it was postponed. C Make the entries on the main diagonal are non-negative. C CALL DGERQF( N, NM, B, LDB, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, IFAIL ) IF ( N.GT.NM ) THEN IF ( LBSCL .AND. .NOT.SCALB ) THEN CALL DLASCL( 'Gen', 0, 0, MB, MBTO, N-M, M, B, LDB, $ INFO ) CALL DLASCL( 'Upper', 0, 0, MB, MBTO, M, M, B(N-M+1,1), $ LDB, INFO ) END IF C DO 70 I = M, 1, -1 CALL DCOPY( N-M+I, B(1,I), 1, B(1,N-M+I), 1 ) 70 CONTINUE C CALL DLASET( 'Full', N, N-M, ZERO, ZERO, B, LDB ) IF ( M.GT.1 ) $ CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, $ B(N-M+2,N-M+1), LDB ) ELSE IF ( M.GT.N .AND. M.EQ.NM ) $ CALL DLACPY( 'Upper', N, N, B(1,M-N+1), LDB, B, LDB ) IF ( LBSCL .AND. .NOT.SCALB ) $ CALL DLASCL( 'Upper', 0, 0, MB, MBTO, N, N, B, LDB, $ INFO ) END IF C DO 80 I = N - MINMN + 1, N IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( I, -ONE, B(1,I), 1 ) 80 CONTINUE C ELSE C NM = M IF ( NUNITQ ) THEN IF ( SMALLM ) THEN C _ C Compute B := B * Q. C NR = INT( LDWORK / N ) C DO 90 I = 1, M, NR BL = MIN( M-I+1, NR ) CALL DGEMM( TRANS, 'NoTran', BL, N, N, ONE, B(I,1), $ LDB, Q, LDQ, ZERO, DWORK, BL ) CALL DLACPY( 'All', BL, N, DWORK, BL, B(I,1), LDB ) 90 CONTINUE C ELSE C C If M > 7*N/6, perform the QR factorization of B, C _ _ C B = P ( R ). C ( 0 ) C CALL DGEQRF( M, N, B, LDB, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1, $ N*N ) C C Form in B C _ _ _ C B := R * Q, with B an n-by-n matrix. C Use a BLAS 3 operation if enough workspace, and BLAS 2, C _ C otherwise: B is formed row by row. C IF ( LDWORK.GE.N*N ) THEN CALL DLACPY( 'Full', N, N, Q, LDQ, DWORK, N ) CALL DTRMM( 'Left', 'Upper', 'NoTran', 'NoUnit', N, $ N, ONE, B, LDB, DWORK, N ) CALL DLACPY( 'Full', N, N, DWORK, MINMN, B, LDB ) ELSE CALL MB01UY( 'Left', 'Upper', 'NoTran', N, N, ONE, B, $ LDB, Q, LDQ, DWORK, LDWORK, INFO ) END IF NM = N END IF END IF C _ C Perform the QR factorization of B to get the factor F. C _ _ C B = P ( F ), M >= N, B = P ( F Z ), M < N. C ( 0 ) C CALL DGEQRF( NM, N, B, LDB, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, IFAIL ) IF ( LBSCL .AND. .NOT.SCALB ) $ CALL DLASCL( 'Upper', 0, 0, MB, MBTO, NM, N, B, LDB, INFO ) C IF ( M.LT.N ) $ CALL DLASET( 'Upper', N-M, N-M, ZERO, ZERO, B(M+1,M+1), $ LDB ) C C Make the entries on the main diagonal of F non-negative. C DO 100 I = 1, MINMN IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( N+1-I, -ONE, B(I,I), LDB ) 100 CONTINUE C END IF IF ( MINMN.GT.1 ) $ CALL DLASET( 'Lower', MINMN-1, MINMN-1, ZERO, ZERO, B(2,1), $ LDB ) C C Solve for V the transformed Lyapunov equation C 2 C op(S)'*op(V)'*op(V) + op(V)'*op(V)*op(S) = -scale *op(F)'*op(F), C C or C 2 C op(S)'*op(V)'*op(V)*op(S) - op(V)'*op(V) = -scale *op(F)'*op(F). C C Workspace: need 4*N. C CALL SB03OT( .NOT.CONT, ISTRAN, N, A, LDA, B, LDB, SCALE, DWORK, $ INFO ) C C Form U := Q*V or U := V*Q' in the array B, if Q is not identity. C IF ( ISTRAN ) THEN C IF ( NUNITQ ) THEN C C Workspace: need N; C prefer larger. C CALL MB01UY( 'Right', 'Upper', 'NoTran', N, N, ONE, B, LDB, $ Q, LDQ, DWORK, LDWORK, INFO ) C C Overwrite U with the triangular matrix of its C RQ-factorization and make the entries on the main diagonal C non-negative. C C Workspace: need 2*N; C prefer N + N*NB. C CALL DGERQF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, $ IFAIL ) IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), $ LDB ) C DO 110 I = 1, N IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( I, -ONE, B(1,I), 1 ) 110 CONTINUE C END IF C ELSE C IF ( NUNITQ ) THEN C C Workspace: need N; C prefer larger. C CALL MB01UY( 'Right', 'Upper', 'Trans', N, N, ONE, B, LDB, $ Q, LDQ, DWORK, LDWORK, INFO ) C DO 120 I = 1, N CALL DSWAP( I, B(I,1), LDB, B(1,I), 1 ) 120 CONTINUE C C Overwrite U with the triangular matrix of its C QR-factorization and make the entries on the main diagonal C non-negative. C C Workspace: 2*N; C prefer N + N*NB. C CALL DGEQRF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, $ IFAIL ) IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) C DO 130 I = 1, N IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( N+1-I, -ONE, B(I,I), LDB ) 130 CONTINUE C END IF C END IF C C Undo the scaling of A and B and update SCALE. C TMP = ONE IF ( LASCL ) THEN CALL DLASCL( 'Hess', 0, 0, MATO, MA, N, N, A, LDA, INFO ) TMP = SQRT( MATO/MA ) END IF IF ( LBSCL ) THEN MX = DLANTR( 'Max', 'Upper', 'NoDiag', N, N, B, LDB, DWORK ) MN = MIN( TMP, MB ) T = MAX( TMP, MB ) IF ( T.GT.ONE ) THEN IF ( MN.GT.BIGNMS/T ) THEN SCALE = SCALE/T TMP = TMP/T END IF END IF TMP = TMP*MB IF ( TMP.GT.ONE ) THEN IF ( MX.GT.BIGNMS/TMP ) THEN SCALE = SCALE/MX TMP = TMP/MX END IF END IF END IF IF ( LASCL .OR. LBSCL ) $ CALL DLASCL( 'Upper', 0, 0, MBTO, TMP, N, N, B, LDB, INFO ) C C Set the optimal workspace. C DWORK(1) = WRKOPT C RETURN C *** Last line of SB03OD *** END control-4.1.2/src/slicot/src/PaxHeaders/FD01AD.f0000644000000000000000000000013215012430707016134 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/FD01AD.f0000644000175000017500000003064215012430707017335 0ustar00lilgelilge00000000000000 SUBROUTINE FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK, $ CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN, $ INFO ) C C PURPOSE C C To solve the least-squares filtering problem recursively in time. C Each subroutine call implements one time update of the solution. C The algorithm uses a fast QR-decomposition based approach. C C ARGUMENTS C C Mode Parameters C C JP CHARACTER*1 C Indicates whether the user wishes to apply both prediction C and filtering parts, as follows: C = 'B': Both prediction and filtering parts are to be C applied; C = 'P': Only the prediction section is to be applied. C C Input/Output Parameters C C L (input) INTEGER C The length of the impulse response of the equivalent C transversal filter model. L >= 1. C C LAMBDA (input) DOUBLE PRECISION C Square root of the forgetting factor. C For tracking capabilities and exponentially stable error C propagation, LAMBDA < 1.0 (strict inequality) should C be used. 0.0 < LAMBDA <= 1.0. C C XIN (input) DOUBLE PRECISION C The input sample at instant n. C (The situation just before and just after the call of C the routine are denoted by instant (n-1) and instant n, C respectively.) C C YIN (input) DOUBLE PRECISION C If JP = 'B', then YIN must contain the reference sample C at instant n. C Otherwise, YIN is not referenced. C C EFOR (input/output) DOUBLE PRECISION C On entry, this parameter must contain the square root of C exponentially weighted forward prediction error energy C at instant (n-1). EFOR >= 0.0. C On exit, this parameter contains the square root of the C exponentially weighted forward prediction error energy C at instant n. C C XF (input/output) DOUBLE PRECISION array, dimension (L) C On entry, this array must contain the transformed forward C prediction variables at instant (n-1). C On exit, this array contains the transformed forward C prediction variables at instant n. C C EPSBCK (input/output) DOUBLE PRECISION array, dimension (L+1) C On entry, the leading L elements of this array must C contain the normalized a posteriori backward prediction C error residuals of orders zero through L-1, respectively, C at instant (n-1), and EPSBCK(L+1) must contain the C square-root of the so-called "conversion factor" at C instant (n-1). C On exit, this array contains the normalized a posteriori C backward prediction error residuals, plus the square root C of the conversion factor at instant n. C C CTETA (input/output) DOUBLE PRECISION array, dimension (L) C On entry, this array must contain the cosines of the C rotation angles used in time updates, at instant (n-1). C On exit, this array contains the cosines of the rotation C angles at instant n. C C STETA (input/output) DOUBLE PRECISION array, dimension (L) C On entry, this array must contain the sines of the C rotation angles used in time updates, at instant (n-1). C On exit, this array contains the sines of the rotation C angles at instant n. C C YQ (input/output) DOUBLE PRECISION array, dimension (L) C On entry, if JP = 'B', then this array must contain the C orthogonally transformed reference vector at instant C (n-1). These elements are also the tap multipliers of an C equivalent normalized lattice least-squares filter. C Otherwise, YQ is not referenced and can be supplied as C a dummy array (i.e., declare this array to be YQ(1) in C the calling program). C On exit, if JP = 'B', then this array contains the C orthogonally transformed reference vector at instant n. C C EPOS (output) DOUBLE PRECISION C The a posteriori forward prediction error residual. C C EOUT (output) DOUBLE PRECISION C If JP = 'B', then EOUT contains the a posteriori output C error residual from the least-squares filter at instant n. C C SALPH (output) DOUBLE PRECISION array, dimension (L) C The element SALPH(i), i=1,...,L, contains the opposite of C the i-(th) reflection coefficient for the least-squares C normalized lattice predictor (whose value is -SALPH(i)). C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: an element to be annihilated by a rotation is less C than the machine precision (see LAPACK Library C routine DLAMCH). 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 output error EOUT at instant n, denoted by EOUT(n), is the C reference sample minus a linear combination of L successive input C samples: C C L-1 C EOUT(n) = YIN(n) - SUM h_i * XIN(n-i), C i=0 C C where YIN(n) and XIN(n) are the scalar samples at instant n. C A least-squares filter uses those h_0,...,h_{L-1} which minimize C an exponentially weighted sum of successive output errors squared: C C n C SUM [LAMBDA**(2(n-k)) * EOUT(k)**2]. C k=1 C C Each subroutine call performs a time update of the least-squares C filter using a fast least-squares algorithm derived from a C QR decomposition, as described in references [1] and [2] (the C notation from [2] is followed in the naming of the arrays). C The algorithm does not compute the parameters h_0,...,h_{L-1} from C the above formula, but instead furnishes the parameters of an C equivalent normalized least-squares lattice filter, which are C available from the arrays SALPH (reflection coefficients) and YQ C (tap multipliers), as well as the exponentially weighted input C signal energy C C n L C SUM [LAMBDA**(2(n-k)) * XIN(k)**2] = EFOR**2 + SUM XF(i)**2. C k=1 i=1 C C For more details on reflection coefficients and tap multipliers, C references [2] and [4] are recommended. C C REFERENCES C C [1] Proudler, I. K., McWhirter, J. G., and Shepherd, T. J. C Fast QRD based algorithms for least-squares linear C prediction. C Proceedings IMA Conf. Mathematics in Signal Processing C Warwick, UK, December 1988. C C [2] Regalia, P. A., and Bellanger, M. G. C On the duality between QR methods and lattice methods in C least-squares adaptive filtering. C IEEE Trans. Signal Processing, SP-39, pp. 879-891, C April 1991. C C [3] Regalia, P. A. C Numerical stability properties of a QR-based fast C least-squares algorithm. C IEEE Trans. Signal Processing, SP-41, June 1993. C C [4] Lev-Ari, H., Kailath, T., and Cioffi, J. C Least-squares adaptive lattice and transversal filters: C A unified geometric theory. C IEEE Trans. Information Theory, IT-30, pp. 222-236, C March 1984. C C NUMERICAL ASPECTS C C The algorithm requires O(L) operations for each subroutine call. C It is backward consistent for all input sequences XIN, and C backward stable for persistently exciting input sequences, C assuming LAMBDA < 1.0 (see [3]). C If the condition of the signal is very poor (IWARN = 1), then the C results are not guaranteed to be reliable. C C FURTHER COMMENTS C C 1. For tracking capabilities and exponentially stable error C propagation, LAMBDA < 1.0 should be used. LAMBDA is typically C chosen slightly less than 1.0 so that "past" data are C exponentially forgotten. C 2. Prior to the first subroutine call, the variables must be C initialized. The following initial values are recommended: C C XF(i) = 0.0, i=1,...,L C EPSBCK(i) = 0.0 i=1,...,L C EPSBCK(L+1) = 1.0 C CTETA(i) = 1.0 i=1,...,L C STETA(i) = 0.0 i=1,...,L C YQ(i) = 0.0 i=1,...,L C C EFOR = 0.0 (exact start) C EFOR = "small positive constant" (soft start). C C Soft starts are numerically more reliable, but result in a C biased least-squares solution during the first few iterations. C This bias decays exponentially fast provided LAMBDA < 1.0. C If sigma is the standard deviation of the input sequence C XIN, then initializing EFOR = sigma*1.0E-02 usually works C well. C C CONTRIBUTOR C C P. A. Regalia (October 1994). C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. C C REVISIONS C C - C C KEYWORDS C C Kalman filtering, least-squares estimator, optimal filtering, C orthogonal transformation, recursive estimation, QR decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER JP INTEGER INFO, IWARN, L DOUBLE PRECISION EFOR, EOUT, EPOS, LAMBDA, XIN, YIN C .. Array Arguments .. DOUBLE PRECISION CTETA(*), EPSBCK(*), SALPH(*), STETA(*), XF(*), $ YQ(*) C .. Local Scalars .. LOGICAL BOTH INTEGER I DOUBLE PRECISION CTEMP, EPS, FNODE, NORM, TEMP, XFI, YQI C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2, LSAME C .. External Subroutines .. EXTERNAL DLARTG, XERBLA C .. Intrinsic Functions INTRINSIC ABS, SQRT C .. Executable statements .. C C Test the input scalar arguments. C BOTH = LSAME( JP, 'B' ) IWARN = 0 INFO = 0 C IF( .NOT.BOTH .AND. .NOT.LSAME( JP, 'P' ) ) THEN INFO = -1 ELSE IF( L.LT.1 ) THEN INFO = -2 ELSE IF( ( LAMBDA.LE.ZERO ) .OR. ( LAMBDA.GT.ONE ) ) THEN INFO = -3 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'FD01AD', -INFO ) RETURN END IF C C Computation of the machine precision EPS. C EPS = DLAMCH( 'Epsilon' ) C C Forward prediction rotations. C FNODE = XIN C DO 10 I = 1, L XFI = XF(I) * LAMBDA XF(I) = STETA(I) * FNODE + CTETA(I) * XFI FNODE = CTETA(I) * FNODE - STETA(I) * XFI 10 CONTINUE C EPOS = FNODE * EPSBCK(L+1) C C Update the square root of the prediction energy. C EFOR = EFOR * LAMBDA TEMP = DLAPY2( FNODE, EFOR ) IF ( TEMP.LT.EPS ) THEN FNODE = ZERO IWARN = 1 ELSE FNODE = FNODE * EPSBCK(L+1)/TEMP END IF EFOR = TEMP C C Calculate the reflection coefficients and the backward prediction C errors. C DO 20 I = L, 1, -1 IF ( ABS( XF(I) ).LT.EPS ) $ IWARN = 1 CALL DLARTG( TEMP, XF(I), CTEMP, SALPH(I), NORM ) EPSBCK(I+1) = CTEMP * EPSBCK(I) - SALPH(I) * FNODE FNODE = CTEMP * FNODE + SALPH(I) * EPSBCK(I) TEMP = NORM 20 CONTINUE C EPSBCK(1) = FNODE C C Update to new rotation angles. C NORM = DNRM2( L, EPSBCK, 1 ) TEMP = SQRT( ( ONE + NORM )*( ONE - NORM ) ) EPSBCK(L+1) = TEMP C DO 30 I = L, 1, -1 IF ( ABS( EPSBCK(I) ).LT.EPS ) $ IWARN = 1 CALL DLARTG( TEMP, EPSBCK(I), CTETA(I), STETA(I), NORM ) TEMP = NORM 30 CONTINUE C C Joint process section. C IF ( BOTH) THEN FNODE = YIN C DO 40 I = 1, L YQI = YQ(I) * LAMBDA YQ(I) = STETA(I) * FNODE + CTETA(I) * YQI FNODE = CTETA(I) * FNODE - STETA(I) * YQI 40 CONTINUE C EOUT = FNODE * EPSBCK(L+1) END IF C RETURN C *** Last line of FD01AD *** END control-4.1.2/src/slicot/src/PaxHeaders/TF01MD.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TF01MD.f0000644000175000017500000001517515012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE TF01MD( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD, $ U, LDU, X, Y, LDY, DWORK, INFO ) C C PURPOSE C C To compute the output sequence of a linear time-invariant C open-loop system given by its discrete-time state-space model C (A,B,C,D), where A is an N-by-N general matrix. C C The initial state vector x(1) must be supplied by the user. 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 number of system inputs. M >= 0. C C P (input) INTEGER C The number of system outputs. P >= 0. C C NY (input) INTEGER C The number of output vectors y(k) to be computed. C NY >= 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 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 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 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 link matrix D of the system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C U (input) DOUBLE PRECISION array, dimension (LDU,NY) C The leading M-by-NY part of this array must contain the C input vector sequence u(k), for k = 1,2,...,NY. C Specifically, the k-th column of U must contain u(k). C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,M). C C X (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the initial state vector C x(1) which consists of the N initial states of the system. C On exit, this array contains the final state vector C x(NY+1) of the N states of the system at instant NY. C C Y (output) DOUBLE PRECISION array, dimension (LDY,NY) C The leading P-by-NY part of this array contains the output C vector sequence y(1),y(2),...,y(NY) such that the k-th C column of Y contains y(k) (the outputs at instant k), C for k = 1,2,...,NY. C C LDY INTEGER C The leading dimension of array Y. LDY >= MAX(1,P). 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 METHOD C C Given an initial state vector x(1), the output vector sequence C y(1), y(2),..., y(NY) is obtained via the formulae C C x(k+1) = A x(k) + B u(k) C y(k) = C x(k) + D u(k), C C where each element y(k) is a vector of length P containing the C outputs at instant k and k = 1,2,...,NY. C C REFERENCES C C [1] Luenberger, D.G. C Introduction to Dynamic Systems: Theory, Models and C Applications. C John Wiley & Sons, New York, 1979. C C NUMERICAL ASPECTS C C The algorithm requires approximately (N + M) x (N + P) x NY C multiplications and additions. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TF01AD by S. Van Huffel, Katholieke C Univ. Leuven, Belgium. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. C C KEYWORDS C C Discrete-time system, multivariable system, state-space model, C state-space representation, time response. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDY, M, N, NY, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) C .. Local Scalars .. INTEGER IK C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA C .. Intrinsic Functions .. INTRINSIC 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( P.LT.0 ) THEN INFO = -3 ELSE IF( NY.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( LDU.LT.MAX( 1, M ) ) THEN INFO = -14 ELSE IF( LDY.LT.MAX( 1, P ) ) THEN INFO = -17 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TF01MD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( P, NY ).EQ.0 ) THEN RETURN ELSE IF ( N.EQ.0 ) THEN C C Non-dynamic system: compute the output vectors. C IF ( M.EQ.0 ) THEN CALL DLASET( 'Full', P, NY, ZERO, ZERO, Y, LDY ) ELSE CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, $ D, LDD, U, LDU, ZERO, Y, LDY ) END IF RETURN END IF C DO 10 IK = 1, NY CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, X, 1, ZERO, $ Y(1,IK), 1 ) C CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, X, 1, ZERO, $ DWORK, 1 ) CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(1,IK), 1, ONE, $ DWORK, 1 ) C CALL DCOPY( N, DWORK, 1, X, 1 ) 10 CONTINUE C CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, D, LDD, $ U, LDU, ONE, Y, LDY ) C RETURN C *** Last line of TF01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03CD.f0000644000000000000000000000013215012430707016145 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03CD.f0000644000175000017500000005030315012430707017342 0ustar00lilgelilge00000000000000 SUBROUTINE MB03CD( UPLO, N1, N2, PREC, A, LDA, B, LDB, D, LDD, Q1, $ LDQ1, Q2, LDQ2, Q3, LDQ3, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute orthogonal matrices Q1, Q2, Q3 for a real 2-by-2, C 3-by-3, or 4-by-4 regular block upper triangular pencil C C ( A11 A12 ) ( B11 B12 ) ( D11 D12 ) C aAB - bD = a ( ) ( ) - b ( ), (1) C ( 0 A22 ) ( 0 B22 ) ( 0 D22 ) C C such that the pencil a(Q3' A Q2 )(Q2' B Q1 ) - b(Q3' D Q1) is C still in block upper triangular form, but the eigenvalues in C Spec(A11 B11, D11), Spec(A22 B22, D22) are exchanged, where C Spec(X,Y) denotes the spectrum of the matrix pencil (X,Y), and M' C denotes the transpose of the matrix M. C C Optionally, to upper triangularize the real regular pencil in C block lower triangular form C C ( A11 0 ) ( B11 0 ) ( D11 0 ) C aAB - bD = a ( ) ( ) - b ( ), (2) C ( A21 A22 ) ( B21 B22 ) ( D21 D22 ) C C while keeping the eigenvalues in the same diagonal position. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies if the pencil is in lower or upper block C triangular form on entry, as follows: C = 'U': Upper block triangular, eigenvalues are exchanged C on exit; C = 'L': Lower block triangular, eigenvalues are not C exchanged on exit. C C Input/Output Parameters C C N1 (input/output) INTEGER C Size of the upper left block, N1 <= 2. C If UPLO = 'U' and INFO = 0, or UPLO = 'L' and INFO <> 0, C N1 and N2 are exchanged on exit; otherwise, N1 is C unchanged on exit. C C N2 (input/output) INTEGER C Size of the lower right block, N2 <= 2. C If UPLO = 'U' and INFO = 0, or UPLO = 'L' and INFO <> 0, C N1 and N2 are exchanged on exit; otherwise, N2 is C unchanged on exit. C C PREC (input) DOUBLE PRECISION C The machine precision, (relative machine precision)*base. C See the LAPACK Library routine DLAMCH. C C A (input or input/output) DOUBLE PRECISION array, dimension C (LDA, N1+N2) C On entry, the leading (N1+N2)-by-(N1+N2) part of this C array must contain the matrix A of the pencil aAB - bD. C The (2,1) block, if UPLO = 'U', or the (1,2) block, if C UPLO = 'L', need not be set to zero. C On exit, if N1 = N2 = 1, this array contains the matrix C [ 0 1 ] C J' A J, where J = [ -1 0 ]; otherwise, this array is C unchanged on exit. C C LDA INTEGER C The leading dimension of the array A. LDA >= N1+N2. C C B (input or input/output) DOUBLE PRECISION array, dimension C (LDB, N1+N2) C On entry, the leading (N1+N2)-by-(N1+N2) part of this C array must contain the matrix B of the pencil aAB - bD. C The (2,1) block, if UPLO = 'U', or the (1,2) block, if C UPLO = 'L', need not be set to zero. C On exit, if N1 = N2 = 1, this array contains the matrix C J' B J; otherwise, this array is unchanged on exit. C C LDB INTEGER C The leading dimension of the array B. LDB >= N1+N2. C C D (input/output) DOUBLE PRECISION array, dimension C (LDD, N1+N2) C On entry, the leading (N1+N2)-by-(N1+N2) part of this C array must contain the matrix D of the pencil aAB - bD. C On exit, if N1 = 2 or N2 = 2, the leading C (N1+N2)-by-(N1+N2) part of this array contains the C transformed matrix D in real Schur form. If N1 = 1 and C N2 = 1, this array contains the matrix J' D J. C C LDD INTEGER C The leading dimension of the array D. LDD >= N1+N2. C C Q1 (output) DOUBLE PRECISION array, dimension (LDQ1, N1+N2) C The leading (N1+N2)-by-(N1+N2) part of this array contains C the first orthogonal transformation matrix. C C LDQ1 INTEGER C The leading dimension of the array Q1. LDQ1 >= N1+N2. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N1+N2) C The leading (N1+N2)-by-(N1+N2) part of this array contains C the second orthogonal transformation matrix. C C LDQ2 INTEGER C The leading dimension of the array Q2. LDQ2 >= N1+N2. C C Q3 (output) DOUBLE PRECISION array, dimension (LDQ3, N1+N2) C The leading (N1+N2)-by-(N1+N2) part of this array contains C the third orthogonal transformation matrix. C C LDQ3 INTEGER C The leading dimension of the array Q3. LDQ3 >= N1+N2. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C If N1+N2 = 2 then DWORK is not referenced. C C LDWORK INTEGER C The dimension of the array DWORK. C If N1+N2 = 2, then LDWORK = 0; otherwise, C LDWORK >= 16*N1 + 10*N2 + 23, UPLO = 'U'; C LDWORK >= 10*N1 + 16*N2 + 23, UPLO = 'L'. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: the QZ iteration failed in the LAPACK routine DGGEV; C = 2: another error occured while executing a routine in C DGGEV; C = 3: the QZ iteration failed in the LAPACK routine DGGES; C = 4: another error occured during execution of DGGES; C = 5: reordering of aA*B - bD in the LAPACK routine DTGSEN C failed because the transformed matrix pencil C aA*B - bD would be too far from generalized Schur C form; the problem is very ill-conditioned. C C METHOD C C The algorithm uses orthogonal transformations as described in [2] C (page 21). The QZ algorithm is used for N1 = 2 or N2 = 2, but it C always acts on an upper block triangular pencil. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical computation of deflating subspaces of skew- C Hamiltonian/Hamiltonian pencils. C SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002. C C [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 21, 2008. C C REVISIONS C C V. Sima, July 2009 (SLICOT version of the routine DBTFEX). C V. Sima, Nov. 2009, Oct. 2010, Nov. 2010. C M. Voigt, Jan. 2012. C C KEYWORDS C C Block triangular pencil, eigenvalue exchange. C C ****************************************************************** C DOUBLE PRECISION ZERO, ONE, TEN, HUND PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, $ HUND = 1.0D+2 ) C C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDB, LDD, LDQ1, LDQ2, LDQ3, LDWORK, $ N1, N2 DOUBLE PRECISION PREC C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( LDD, * ), $ DWORK( * ), Q1( LDQ1, * ), Q2( LDQ2, * ), $ Q3( LDQ3, * ) C C .. Local Scalars .. LOGICAL AEVINF, EVINF, LUPLO INTEGER CNT, EVSEL, I, IAEV, IDUM, IEVS, ITMP, J, M DOUBLE PRECISION ABSAEV, ABSEV, ADIF, CO1, CO2, CO3, E, G, SI1, $ SI2, SI3, TMP, TOL, TOLB C C .. Local Arrays .. LOGICAL BWORK( 1 ), OUT( 2 ), SLCT( 4 ) INTEGER IDM( 1 ) DOUBLE PRECISION DUM( 2 ) C C .. External Functions .. LOGICAL LSAME, SB02OW EXTERNAL LSAME, SB02OW C C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEQR2, DGGES, DGGEV, DLACPY, $ DLARTG, DLASET, DORG2R, DSWAP, DTGSEN C C .. Intrinsic Functions .. INTRINSIC ABS, MAX C C .. Executable Statements .. C C Decode the input arguments. C LUPLO = LSAME( UPLO, 'U' ) C C For efficiency, the input arguments are not tested. C INFO = 0 C C Computations. C M = N1 + N2 IF( M.GT.2 ) THEN C C Compute A*B, and, if UPLO = 'L', make the pencil upper block C triangular. Array Q2 is used as workspace. C IF( LUPLO ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N1, N1, N1, ONE, $ A, LDA, B, LDB, ZERO, Q2, LDQ2 ) CALL DLASET( 'Full', N2, N1, ZERO, ZERO, Q2( N1+1, 1 ), LDQ2 $ ) CALL DGEMM( 'No Transpose', 'No Transpose', N1, N2, M, ONE, $ A, LDA, B( 1, N1+1 ), LDB, ZERO, Q2( 1, N1+1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N2, N2, N2, ONE, $ A( N1+1, N1+1 ), LDA, B( N1+1, N1+1 ), LDB, $ ZERO, Q2( N1+1, N1+1 ), LDQ2 ) ELSE C CALL DGEMM( 'No Transpose', 'No Transpose', N2, N2, N2, ONE, $ A( N1+1, N1+1 ), LDA, B( N1+1, N1+1 ), LDB, $ ZERO, Q2, LDQ2 ) CALL DLASET( 'Full', N1, N2, ZERO, ZERO, Q2( N2+1, 1 ), LDQ2 $ ) CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, M, ONE, $ A( N1+1, 1 ), LDA, B, LDB, ZERO, Q2( 1, N2+1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N1, N1, N1, ONE, $ A, LDA, B, LDB, ZERO, Q2( N2+1, N2+1 ), LDQ2 ) IF( N1.EQ.1 ) THEN DUM( 1 ) = D( 1, 1 ) DUM( 2 ) = D( 2, 1 ) D( 1, 1 ) = D( 2, 2 ) D( 2, 1 ) = D( 3, 2 ) D( 1, 2 ) = D( 2, 3 ) D( 2, 2 ) = D( 3, 3 ) D( 1, 3 ) = DUM( 2 ) D( 2, 3 ) = D( 3, 1 ) D( 3, 3 ) = DUM( 1 ) D( 3, 1 ) = ZERO D( 3, 2 ) = ZERO ELSE IF( N2.EQ.1 ) THEN DUM( 1 ) = D( 3, 2 ) DUM( 2 ) = D( 3, 3 ) D( 2, 3 ) = D( 1, 2 ) D( 3, 3 ) = D( 2, 2 ) D( 2, 2 ) = D( 1, 1 ) D( 3, 2 ) = D( 2, 1 ) D( 1, 1 ) = DUM( 2 ) D( 1, 2 ) = D( 3, 1 ) D( 1, 3 ) = DUM( 1 ) D( 2, 1 ) = ZERO D( 3, 1 ) = ZERO ELSE C DO 10 J = 1, N1 CALL DSWAP( N1, D( 1, J ), 1, D( N1+1, N1+J ), 1 ) CALL DSWAP( N1, D( 1, N1+J ), 1, D( N1+1, J ), 1 ) 10 CONTINUE C END IF ITMP = N1 N1 = N2 N2 = ITMP END IF C C Apply the QZ algorithm and order the eigenvalues in C DWORK(1:3*N1) to the top. C C Workspace: need 11*N1. C Note that N1 and N2 are interchanged for UPLO = 'L'. C IEVS = 3*N1 + 1 IAEV = IEVS + 3*N1 CALL DLACPY( 'Full', M, M, D, LDD, Q1, LDQ1 ) CALL DLACPY( 'Full', M, M, Q2, LDQ2, Q3, LDQ3 ) CALL DGGEV( 'No Vector', 'No Vector', N1, Q1, LDQ1, Q3, LDQ3, $ DWORK, DWORK( N1+1 ), DWORK( 2*N1+1 ), DUM, 1, DUM, $ 1, DWORK( IEVS ), LDWORK-IEVS+1, INFO ) IF( INFO.GE.1 .AND. INFO.LE.N1 ) THEN INFO = 1 RETURN ELSE IF( INFO.GT.N1 ) THEN INFO = 2 RETURN END IF C C Workspace: need 16*N1 + 10*N2 + 23. C Note that N1 and N2 are interchanged for UPLO = 'L'. C ITMP = IAEV + 3*M CALL DCOPY( 3*N1, DWORK, 1, DWORK( IEVS ), 1 ) CALL DGGES( 'Vector Computation', 'Vector Computation', $ 'Not sorted', SB02OW, M, D, LDD, Q2, LDQ2, IDUM, $ DWORK( IAEV ), DWORK( IAEV+M ), DWORK( IAEV+2*M ), $ Q3, LDQ3, Q1, LDQ1, DWORK( ITMP ), LDWORK-ITMP+1, $ BWORK, INFO ) IF( INFO.NE.0 ) THEN IF( INFO.GE.1 .AND. INFO.LE.M ) THEN INFO = 3 RETURN ELSE IF( INFO.NE.M+2 ) THEN INFO = 4 RETURN ELSE INFO = 0 END IF END IF C TOL = PREC TOLB = TEN*PREC EVSEL = 0 DO 20 I = 1, M SLCT( I ) = .TRUE. 20 CONTINUE C C WHILE( EVSEL.EQ.0 ) DO C 30 CONTINUE IF( EVSEL.EQ.0 ) THEN CNT = 0 OUT( 1 ) = .FALSE. OUT( 2 ) = .FALSE. C DO 50 I = IAEV, IAEV + M - 1 AEVINF = ABS( DWORK( 2*M+I ) ).LT.PREC* $ ( ABS( DWORK( I ) ) + ABS( DWORK( M+I ) ) ) DO 40 J = 1, N1 C C Check if an eigenvalue is selected and check if it C is infinite. C EVINF = ABS( DWORK( 2*N1+J ) ).LT.PREC* $ ( ABS( DWORK( J ) ) + ABS( DWORK( N1+J ) ) ) IF( ( .NOT. EVINF .OR. AEVINF ) .AND. $ ( .NOT.AEVINF .OR. EVINF ) .AND. $ .NOT. OUT( J ) ) THEN IF( .NOT.EVINF .OR. .NOT.AEVINF ) THEN ADIF = ABS( DWORK( J )/DWORK( 2*N1+J ) - $ DWORK( I )/DWORK( 2*M+I ) ) + $ ABS( DWORK( N1+J )/DWORK( 2*N1+J ) - $ DWORK( M+I )/DWORK( 2*M+I ) ) ABSEV = ABS( DWORK( J )/DWORK( 2*N1+J ) ) + $ ABS( DWORK( N1+J )/DWORK( 2*N1+J ) ) ABSAEV = ABS( DWORK( I )/DWORK( 2*M+I ) ) + $ ABS( DWORK( M+I )/DWORK( 2*M+I ) ) IF( ADIF.LE.TOL*MAX( TOLB, ABSEV, ABSAEV ) ) $ THEN SLCT( I-IAEV+1 ) = .FALSE. OUT( J ) = .TRUE. CNT = CNT + 1 END IF ELSE SLCT( I-IAEV+1 ) = .FALSE. OUT( J ) = .TRUE. CNT = CNT + 1 END IF END IF 40 CONTINUE 50 CONTINUE C IF( CNT.EQ.N1 ) THEN EVSEL = 1 ELSE C C CNT < N1, too few eigenvalues selected. C TOL = TEN*TOL CALL DCOPY( 3*N1, DWORK( IEVS ), 1, DWORK, 1 ) END IF GO TO 30 END IF C END WHILE 30 C C Workspace: need 7*N1 + 7*N2 + 16. C ITMP = 3*M + 1 CALL DTGSEN( 0, .TRUE., .TRUE., SLCT, M, D, LDD, Q2, LDQ2, $ DWORK, DWORK( M+1 ), DWORK( 2*M+1 ), $ Q3, LDQ3, Q1, LDQ1, IDUM, TMP, TMP, DUM, $ DWORK( ITMP ), LDWORK-ITMP+1, IDM, 1, INFO ) IF( INFO.EQ.1 ) THEN INFO = 5 RETURN END IF C C Interchange N1 and N2. C ITMP = N1 N1 = N2 N2 = ITMP C IF( .NOT.LUPLO ) THEN C C Permute the rows of Q1 and Q3. C IF( N1.EQ.1 ) THEN C DO 60 J = 1, M TMP = Q1( 3, J ) Q1( 3, J ) = Q1( 2, J ) Q1( 2, J ) = Q1( 1, J ) Q1( 1, J ) = TMP TMP = Q3( 3, J ) Q3( 3, J ) = Q3( 2, J ) Q3( 2, J ) = Q3( 1, J ) Q3( 1, J ) = TMP 60 CONTINUE C ELSE IF( N2.EQ.1 ) THEN C DO 70 J = 1, M TMP = Q1( 1, J ) Q1( 1, J ) = Q1( 2, J ) Q1( 2, J ) = Q1( 3, J ) Q1( 3, J ) = TMP TMP = Q3( 1, J ) Q3( 1, J ) = Q3( 2, J ) Q3( 2, J ) = Q3( 3, J ) Q3( 3, J ) = TMP 70 CONTINUE C ELSE C DO 80 J = 1, M CALL DSWAP( N1, Q1( 1, J ), 1, Q1( N1+1, J ), 1 ) CALL DSWAP( N1, Q3( 1, J ), 1, Q3( N1+1, J ), 1 ) 80 CONTINUE C END IF END IF C C Workspace: need 2*N1 + 2*N2. C IF( LUPLO ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N2, M, M, ONE, $ B, LDB, Q1, LDQ1, ZERO, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N1, M, N1, ONE, $ B( N2+1, N2+1 ), LDB, Q1( N2+1, 1 ), LDQ1, ZERO, $ Q2( N2+1, 1 ), LDQ2 ) ELSE CALL DGEMM( 'No Transpose', 'No Transpose', N1, M, N1, ONE, $ B, LDB, Q1, LDQ1, ZERO, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N2, M, M, ONE, $ B ( N1+1, 1 ), LDB, Q1, LDQ1, ZERO, $ Q2( N1+1, 1 ), LDQ2 ) END IF CALL DGEQR2( M, M, Q2, LDQ2, DWORK, DWORK( M+1 ), INFO ) CALL DORG2R( M, M, M, Q2, LDQ2, DWORK, DWORK( M+1 ), INFO ) C ELSE C C 2-by-2 case. C IF( .NOT.LUPLO ) THEN TMP = A( 1, 1 ) A( 1, 1 ) = A( 2, 2 ) A( 2, 2 ) = TMP A( 1, 2 ) = -A( 2, 1 ) A( 2, 1 ) = ZERO TMP = B( 1, 1 ) B( 1, 1 ) = B( 2, 2 ) B( 2, 2 ) = TMP B( 1, 2 ) = -B( 2, 1 ) B( 2, 1 ) = ZERO TMP = D( 1, 1 ) D( 1, 1 ) = D( 2, 2 ) D( 2, 2 ) = TMP D( 1, 2 ) = -D( 2, 1 ) D( 2, 1 ) = ZERO END IF C TMP = A( 2, 2 )*B( 2, 2 )*D( 1, 1 ) G = A( 1, 1 )*B( 1, 1 )*D( 2, 2 ) - TMP IF( ABS( G ).LT.HUND*PREC*ABS( TMP ) ) THEN C C The eigenvalues might be too close to interchange them. C IF( LUPLO ) THEN CALL DLASET( 'Full', 2, 2, ZERO, ONE, Q1, LDQ1 ) CALL DLASET( 'Full', 2, 2, ZERO, ONE, Q2, LDQ2 ) CALL DLASET( 'Full', 2, 2, ZERO, ONE, Q3, LDQ3 ) ELSE Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = -ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = -ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO Q3( 1, 1 ) = ZERO Q3( 2, 1 ) = -ONE Q3( 1, 2 ) = ONE Q3( 2, 2 ) = ZERO END IF ELSE E = ( A( 1, 1 )*B( 1, 2 ) + A( 1, 2 )*B( 2, 2 ) )*D( 2, 2 ) $ - A( 2, 2 )*B( 2, 2 )*D( 1, 2 ) CALL DLARTG( E, G, CO1, SI1, TMP ) E = ( A( 1, 2 )*D( 2, 2 ) - A( 2, 2 )*D( 1, 2 ) )*B( 1, 1 ) $ + A( 2, 2 )*D( 1, 1 )*B( 1, 2 ) CALL DLARTG( E, G, CO2, SI2, TMP ) E = ( B( 1, 2 )*D( 1, 1 ) - B( 1, 1 )*D( 1, 2 ) )*A( 1, 1 ) $ + A( 1, 2 )*B( 2, 2 )*D( 1, 1 ) CALL DLARTG( E, G, CO3, SI3, TMP ) C IF( LUPLO ) THEN Q1( 1, 1 ) = CO1 Q1( 2, 1 ) = -SI1 Q1( 1, 2 ) = SI1 Q1( 2, 2 ) = CO1 Q2( 1, 1 ) = CO2 Q2( 2, 1 ) = -SI2 Q2( 1, 2 ) = SI2 Q2( 2, 2 ) = CO2 Q3( 1, 1 ) = CO3 Q3( 2, 1 ) = -SI3 Q3( 1, 2 ) = SI3 Q3( 2, 2 ) = CO3 ELSE Q1( 1, 1 ) = -SI1 Q1( 2, 1 ) = -CO1 Q1( 1, 2 ) = CO1 Q1( 2, 2 ) = -SI1 Q2( 1, 1 ) = -SI2 Q2( 2, 1 ) = -CO2 Q2( 1, 2 ) = CO2 Q2( 2, 2 ) = -SI2 Q3( 1, 1 ) = -SI3 Q3( 2, 1 ) = -CO3 Q3( 1, 2 ) = CO3 Q3( 2, 2 ) = -SI3 END IF END IF END IF C RETURN C *** Last line of MB03CD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03PY.f0000644000000000000000000000013215012430707016207 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03PY.f0000644000175000017500000003206115012430707017405 0ustar00lilgelilge00000000000000 SUBROUTINE MB03PY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, $ TAU, DWORK, INFO ) 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 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, Oct. 2001, C Jan. 2009. C V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. C V. Sima, Apr. 2017, Mar. 2019. 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 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 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 .. Local Scalars .. INTEGER I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI, $ PVT DOUBLE PRECISION AII, C1, C2, S1, S2, SMAX, SMAXPR, SMIN, $ SMINPR, TEMP, TEMP2, TOLZ C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL DLAMCH, DNRM2, IDAMAX C .. C .. External Subroutines .. EXTERNAL DCOPY, DLAIC1, DLARF, DLARFG, DSCAL, DSWAP, $ XERBLA C .. 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( 'MB03PY', -INFO ) RETURN END IF C C Quick return if possible. C K = MIN( M, N ) IF( K.EQ.0 ) THEN RANK = 0 SVAL( 1 ) = ZERO SVAL( 2 ) = ZERO SVAL( 3 ) = ZERO RETURN END IF C TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) ISMIN = M ISMAX = ISMIN + M JWORK = ISMAX + 1 C C Initialize partial row norms and pivoting vector. The first m C elements of DWORK store the exact row norms. The already used C trailing part is then overwritten by the condition estimator. C DO 10 I = 1, M DWORK( I ) = DNRM2( N, A( I, 1 ), LDA ) DWORK( M+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.K ) THEN I = K - RANK C C Determine ith pivot row and swap if necessary. C MKI = M - RANK NKI = N - RANK PVT = IDAMAX( MKI, DWORK, 1 ) C IF( PVT.NE.MKI ) THEN CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( MKI ) JPVT( MKI ) = ITEMP DWORK( PVT ) = DWORK( MKI ) DWORK( M+PVT ) = DWORK( M+MKI ) END IF C IF( NKI.GT.1 ) THEN C C Save A(m-k+i,n-k+i) and generate elementary reflector H(i) C to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n). C AII = A( MKI, NKI ) CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) $ ) END IF C IF( RANK.EQ.0 ) THEN C C Initialize; exit if the matrix is negligible (RANK = 0). C SMAX = ABS( A( M, N ) ) IF ( SMAX.LE.RCOND ) THEN SVAL( 1 ) = ZERO SVAL( 2 ) = ZERO SVAL( 3 ) = ZERO END IF SMIN = SMAX SMAXPR = SMAX SMINPR = SMIN C1 = ONE C2 = ONE ELSE C C One step of incremental condition estimation. C CALL DCOPY ( RANK, A( MKI, NKI+1 ), LDA, DWORK( JWORK ), 1 ) CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, $ DWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 ) CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, $ DWORK( JWORK ), A( MKI, NKI ), SMAXPR, S2, C2 ) END IF C IF( SVLMAX*RCOND.LE.SMAXPR ) THEN IF( SVLMAX*RCOND.LE.SMINPR ) THEN IF( SMAXPR*RCOND.LT.SMINPR ) THEN C IF( MKI.GT.1 ) THEN C C Continue factorization, as rank is at least RANK. C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. C AII = A( MKI, NKI ) A( MKI, NKI ) = ONE CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, $ TAU( I ), A, LDA, DWORK( JWORK ) ) A( MKI, NKI ) = AII C C Update partial row norms. C DO 30 J = 1, MKI - 1 IF( DWORK( J ).NE.ZERO ) THEN TEMP = ABS( A( J, NKI ) ) / DWORK( J ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), $ ZERO ) TEMP2 = TEMP*( DWORK( J ) / DWORK( M+J ) )**2 IF( TEMP2.LE.TOLZ ) THEN DWORK( J ) = DNRM2( NKI-1, A( J, 1 ), $ LDA ) DWORK( M+J ) = DWORK( J ) ELSE DWORK( J ) = DWORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE C END IF 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 IF( RANK.GT.0 ) THEN ISMIN = ISMIN - 1 ISMAX = ISMAX - 1 END IF DWORK( ISMIN ) = C1 DWORK( ISMAX ) = 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 (M-RANK)-th row and set SVAL. C IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN CALL DSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA ) A( MKI, NKI ) = AII END IF SVAL( 1 ) = SMAX SVAL( 2 ) = SMIN SVAL( 3 ) = SMINPR C RETURN C *** Last line of MB03PY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB16BD.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB16BD.f0000644000175000017500000005767015012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE SB16BD( DICO, JOBD, JOBMR, JOBCF, EQUIL, ORDSEL, $ N, M, P, NCR, A, LDA, B, LDB, C, LDC, D, LDD, $ F, LDF, G, LDG, DC, LDDC, HSV, TOL1, TOL2, $ IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute, for a given open-loop model (A,B,C,D), and for C given state feedback gain F and full observer gain G, C such that A+B*F and A+G*C are stable, a reduced order C controller model (Ac,Bc,Cc,Dc) using a coprime factorization C based controller reduction approach. For reduction, C either the square-root or the balancing-free square-root C versions of the Balance & Truncate (B&T) or Singular Perturbation C Approximation (SPA) model reduction methods are used in C conjunction with stable coprime factorization techniques. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of the open-loop system as follows: C = 'C': continuous-time system; C = 'D': discrete-time system. C C JOBD CHARACTER*1 C Specifies whether or not a non-zero matrix D appears C in the given state space model: C = 'D': D is present; C = 'Z': D is assumed a zero matrix. C C JOBMR CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root B&T method; C = 'F': use the balancing-free square-root B&T method; C = 'S': use the square-root SPA method; C = 'P': use the balancing-free square-root SPA method. C C JOBCF CHARACTER*1 C Specifies whether left or right coprime factorization is C to be used as follows: C = 'L': use left coprime factorization; C = 'R': use right coprime factorization. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to perform a C preliminary equilibration before performing C order reduction as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting controller order NCR is fixed; C = 'A': the resulting controller order NCR is C automatically determined on basis of the given C tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the open-loop state-space representation, C i.e., the order of the matrix A. N >= 0. C N also represents the order of the original state-feedback C controller. 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 NCR (input/output) INTEGER C On entry with ORDSEL = 'F', NCR is the desired order of C the resulting reduced order controller. 0 <= NCR <= N. C On exit, if INFO = 0, NCR is the order of the resulting C reduced order controller. NCR is set as follows: C if ORDSEL = 'F', NCR is equal to MIN(NCR,NMIN), where NCR C is the desired order on entry, and NMIN is the order of a C minimal realization of an extended system Ge (see METHOD); C NMIN is determined as the number of C Hankel singular values greater than N*EPS*HNORM(Ge), C where EPS is the machine precision (see LAPACK Library C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the C extended system (computed in HSV(1)); C if ORDSEL = 'A', NCR is equal to the number of Hankel C singular values greater than MAX(TOL1,N*EPS*HNORM(Ge)). 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 original state dynamics matrix A. C On exit, if INFO = 0, the leading NCR-by-NCR part of this C array contains the state dynamics matrix Ac of the reduced C controller. 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 C contain the original input/state matrix B. 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 C contain the original state/output matrix C. 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 If JOBD = 'D', the leading P-by-M part of this C array must contain the system direct input/output C 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 F (input/output) DOUBLE PRECISION array, dimension (LDF,N) C On entry, the leading M-by-N part of this array must C contain a stabilizing state feedback matrix. C On exit, if INFO = 0, the leading M-by-NCR part of this C array contains the state/output matrix Cc of the reduced C controller. C C LDF INTEGER C The leading dimension of array F. LDF >= MAX(1,M). C C G (input/output) DOUBLE PRECISION array, dimension (LDG,P) C On entry, the leading N-by-P part of this array must C contain a stabilizing observer gain matrix. C On exit, if INFO = 0, the leading NCR-by-P part of this C array contains the input/state matrix Bc of the reduced C controller. C C LDG INTEGER C The leading dimension of array G. LDG >= MAX(1,N). C C DC (output) DOUBLE PRECISION array, dimension (LDDC,P) C If INFO = 0, the leading M-by-P part of this array C contains the input/output matrix Dc of the reduced C controller. C C LDDC INTEGER C The leading dimension of array DC. LDDC >= MAX(1,M). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, it contains the N Hankel singular values C of the extended system ordered decreasingly (see METHOD). C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of the reduced extended system. C For model reduction, the recommended value is C TOL1 = c*HNORM(Ge), where c is a constant in the C interval [0.00001,0.001], and HNORM(Ge) is the C Hankel norm of the extended system (computed in HSV(1)). C The value TOL1 = N*EPS*HNORM(Ge) is used by default if C TOL1 <= 0 on entry, where EPS is the machine precision C (see LAPACK Library Routine DLAMCH). C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the coprime factorization controller C (see METHOD). The recommended value is C TOL2 = N*EPS*HNORM(Ge) (see METHOD). C This value is used by default if TOL2 <= 0 on entry. C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = 0, if ORDSEL = 'F' and NCR = N. C Otherwise, C LIWORK = MAX(PM,M), if JOBCF = 'L', C LIWORK = MAX(PM,P), if JOBCF = 'R', where C PM = 0, if JOBMR = 'B', C PM = N, if JOBMR = 'F', C PM = MAX(1,2*N), if JOBMR = 'S' or '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 >= P*N, if ORDSEL = 'F' and NCR = N. Otherwise, C LDWORK >= (N+M)*(M+P) + MAX(LWR,4*M), if JOBCF = 'L', C LDWORK >= (N+P)*(M+P) + MAX(LWR,4*P), if JOBCF = 'R', C where LWR = MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NCR is C greater than the order of a minimal C realization of the controller. 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+G*C to a real Schur form C failed; C = 2: the matrix A+G*C is not stable (if DICO = 'C'), C or not convergent (if DICO = 'D'); C = 3: the computation of Hankel singular values failed; C = 4: the reduction of A+B*F to a real Schur form C failed; C = 5: the matrix A+B*F is not stable (if DICO = 'C'), C or not convergent (if DICO = 'D'). C C METHOD C C Let be the linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t), (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system, and let Go(d) be the open-loop C transfer-function matrix C -1 C Go(d) = C*(d*I-A) *B + D . C C Let F and G be the state feedback and observer gain matrices, C respectively, chosen so that A+B*F and A+G*C are stable matrices. C The controller has a transfer-function matrix K(d) given by C -1 C K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G . C C The closed-loop transfer-function matrix is given by C -1 C Gcl(d) = Go(d)(I+K(d)Go(d)) . C C K(d) can be expressed as a left coprime factorization (LCF), C -1 C K(d) = M_left(d) *N_left(d) , C C or as a right coprime factorization (RCF), C -1 C K(d) = N_right(d)*M_right(d) , C C where M_left(d), N_left(d), N_right(d), and M_right(d) are C stable transfer-function matrices. C C The subroutine SB16BD determines the matrices of a reduced C controller C C d[z(t)] = Ac*z(t) + Bc*y(t) C u(t) = Cc*z(t) + Dc*y(t), (2) C C with the transfer-function matrix Kr as follows: C C (1) If JOBCF = 'L', the extended system C Ge(d) = [ N_left(d) M_left(d) ] is reduced to C Ger(d) = [ N_leftr(d) M_leftr(d) ] by using either the C B&T or SPA methods. The reduced order controller Kr(d) C is computed as C -1 C Kr(d) = M_leftr(d) *N_leftr(d) ; C C (2) If JOBCF = 'R', the extended system C Ge(d) = [ N_right(d) ] is reduced to C [ M_right(d) ] C Ger(d) = [ N_rightr(d) ] by using either the C [ M_rightr(d) ] C B&T or SPA methods. The reduced order controller Kr(d) C is computed as C -1 C Kr(d) = N_rightr(d)* M_rightr(d) . C C If ORDSEL = 'A', the order of the controller is determined by C computing the number of Hankel singular values greater than C the given tolerance TOL1. The Hankel singular values are C the square roots of the eigenvalues of the product of C the controllability and observability Grammians of the C extended system Ge. C C If JOBMR = 'B', the square-root B&T method of [1] is used. C C If JOBMR = 'F', the balancing-free square-root version of the C B&T method [1] is used. C C If JOBMR = 'S', the square-root version of the SPA method [2,3] C is used. C C If JOBMR = 'P', the balancing-free square-root version of the C SPA method [2,3] is used. C C REFERENCES C C [1] Tombs, M.S. and Postlethwaite, I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C [2] Varga, A. C Efficient minimal realization procedure based on balancing. C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, C pp. 42-46, 1991. C C [3] Varga, A. C Coprime factors model reduction method based on square-root C balancing-free techniques. C System Analysis, Modelling and Simulation, Vol. 11, C pp. 303-311, 1993. C C [4] Liu, Y., Anderson, B.D.O. and Ly, O.L. C Coprime factorization controller reduction with Bezout C identity induced frequency weighting. C Automatica, vol. 26, pp. 233-249, 1990. C C NUMERICAL ASPECTS C C The implemented methods rely on accuracy enhancing square-root or C balancing-free square-root techniques. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. C D. Sima, University of Bucharest, August 2000. C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. C C REVISIONS C C A. Varga, Australian National University, Canberra, November 2000. C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, C Aug. 2001. C C KEYWORDS C C Balancing, controller reduction, coprime factorization, C minimal realization, multivariable system, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, JOBCF, JOBD, JOBMR, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDDC, $ LDF, LDG, LDWORK, M, N, NCR, P DOUBLE PRECISION TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DC(LDDC,*), DWORK(*), F(LDF,*), G(LDG,*), HSV(*) C .. Local Scalars .. CHARACTER JOB LOGICAL BAL, BTA, DISCR, FIXORD, LEFT, LEQUIL, SPA, $ WITHD INTEGER KBE, KCE, KDE, KW, LDBE, LDCE, LDDE, LW1, LW2, $ LWR, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB09AD, AB09BD, DGEMM, DLACPY, DLASET, SB08GD, $ SB08HD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) WITHD = LSAME( JOBD, 'D' ) BTA = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'F' ) SPA = LSAME( JOBMR, 'S' ) .OR. LSAME( JOBMR, 'P' ) BAL = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'S' ) LEFT = LSAME( JOBCF, 'L' ) LEQUIL = LSAME( EQUIL, 'S' ) FIXORD = LSAME( ORDSEL, 'F' ) C LWR = MAX( 1, N*( 2*N + MAX( N, M+P ) + 5 ) + ( N*(N+1) )/2 ) LW1 = (N+M)*(M+P) + MAX( LWR, 4*M ) LW2 = (N+P)*(M+P) + MAX( LWR, 4*P ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN INFO = -3 ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN INFO = -4 ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN INFO = -5 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -6 ELSE IF( N.LT.0 ) THEN INFO = -7 ELSE IF( M.LT.0 ) THEN INFO = -8 ELSE IF( P.LT.0 ) THEN INFO = -9 ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN INFO = -10 ELSE IF( LDA.LT.MAX( 1, 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( LDF.LT.MAX( 1, M ) ) THEN INFO = -20 ELSE IF( LDG.LT.MAX( 1, N ) ) THEN INFO = -22 ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN INFO = -24 ELSE IF( .NOT.FIXORD .AND. TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN INFO = -27 ELSE IF( ( ( .NOT.FIXORD .OR. NCR.LT.N ) .AND. $ ( ( LEFT .AND. LDWORK.LT.LW1 ) ) .OR. $ ( .NOT.LEFT .AND. LDWORK.LT.LW2 ) ) .OR. $ ( FIXORD .AND. NCR.EQ.N .AND. LDWORK.LT.P*N ) ) THEN INFO = -30 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB16BD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 .OR. $ ( FIXORD .AND. BTA .AND. NCR.EQ.0 ) ) THEN NCR = 0 DWORK(1) = ONE RETURN END IF C IF( NCR.EQ.N ) THEN C C Form the controller state matrix, C Ac = A + B*F + G*C + G*D*F = A + B*F + G*(C+D*F) . C Real workspace: need P*N. C Integer workspace: need 0. C CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, $ ONE, D, LDD, F, LDF, ONE, $ DWORK, P ) CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G, $ LDG, DWORK, P, ONE, A, LDA ) CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, $ LDB, F, LDF, ONE, A, LDA ) C DWORK(1) = P*N RETURN END IF C IF( BAL ) THEN JOB = 'B' ELSE JOB = 'N' END IF C C Reduce the coprime factors. C IF( LEFT ) THEN C C Form Ge(d) = [ N_left(d) M_left(d) ] as C C ( A+G*C | G B+GD ) C (------------------) C ( F | 0 I ) C C Real workspace: need (N+M)*(M+P). C Integer workspace: need 0. C CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G, $ LDG, C, LDC, ONE, A, LDA ) KBE = 1 KDE = KBE + N*(P+M) LDBE = MAX( 1, N ) LDDE = M CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KBE), LDBE ) CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KBE+N*P), LDBE ) IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, P, $ ONE, G, LDG, D, LDD, ONE, $ DWORK(KBE+N*P), LDBE ) CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE ) CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK(KDE+M*P), LDDE ) C C Compute the reduced coprime factors, C Ger(d) = [ N_leftr(d) M_leftr(d) ] , C by using either the B&T or SPA methods. C C Real workspace: need (N+M)*(M+P) + C MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). C Integer workspace: need 0, if JOBMR = 'B', C N, if JOBMR = 'F', and C MAX(1,2*N) if JOBMR = 'S' or 'P'. C KW = KDE + M*(P+M) IF( BTA ) THEN CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A, $ LDA, DWORK(KBE), LDBE, F, LDF, HSV, TOL1, $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) ELSE CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A, $ LDA, DWORK(KBE), LDBE, F, LDF, DWORK(KDE), $ LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW), $ LDWORK-KW+1, IWARN, INFO ) END IF IF( INFO.NE.0 ) $ RETURN C WRKOPT = INT( DWORK(KW) ) + KW - 1 C C Compute the reduced order controller, C -1 C Kr(d) = M_leftr(d) *N_leftr(d). C C Real workspace: need (N+M)*(M+P) + MAX(1,4*M). C Integer workspace: need M. C CALL SB08GD( NCR, P, M, A, LDA, DWORK(KBE), LDBE, F, LDF, $ DWORK(KDE), LDDE, DWORK(KBE+N*P), LDBE, $ DWORK(KDE+M*P), LDDE, IWORK, DWORK(KW), INFO ) C C Copy the reduced system matrices Bc and Dc. C CALL DLACPY( 'Full', NCR, P, DWORK(KBE), LDBE, G, LDG ) CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC ) C ELSE C C Form Ge(d) = [ N_right(d) ] C [ M_right(d) ] as C C ( A+B*F | G ) C (-----------) C ( F | 0 ) C ( C+D*F | I ) C C Real workspace: need (N+P)*(M+P). C Integer workspace: need 0. C CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, $ LDB, F, LDF, ONE, A, LDA ) KCE = 1 KDE = KCE + N*(P+M) LDCE = M+P LDDE = LDCE CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KCE), LDCE ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KCE+M), LDCE ) IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, $ ONE, D, LDD, F, LDF, ONE, $ DWORK(KCE+M), LDCE ) CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE ) CALL DLASET( 'Full', P, P, ZERO, ONE, DWORK(KDE+M), LDDE ) C C Compute the reduced coprime factors, C Ger(d) = [ N_rightr(d) ] C [ M_rightr(d) ], C by using either the B&T or SPA methods. C C Real workspace: need (N+P)*(M+P) + C MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). C Integer workspace: need 0, if JOBMR = 'B', C N, if JOBMR = 'F', and C MAX(1,2*N) if JOBMR = 'S' or 'P'. C KW = KDE + P*(P+M) IF( BTA ) THEN CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A, $ LDA, G, LDG, DWORK(KCE), LDCE, HSV, TOL1, $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) ELSE CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A, $ LDA, G, LDG, DWORK(KCE), LDCE, DWORK(KDE), $ LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW), $ LDWORK-KW+1, IWARN, INFO ) END IF IF( INFO.NE.0 ) THEN IF( INFO.NE.3 ) INFO = INFO + 3 RETURN END IF C WRKOPT = INT( DWORK(KW) ) + KW - 1 C C Compute the reduced order controller, C -1 C Kr(d) = N_rightr(d)*M_rightr(d) . C C Real workspace: need (N+P)*(M+P) + MAX(1,4*P). C Integer workspace: need P. C CALL SB08HD( NCR, P, M, A, LDA, G, LDG, DWORK(KCE), LDCE, $ DWORK(KDE), LDDE, DWORK(KCE+M), LDCE, $ DWORK(KDE+M), LDDE, IWORK, DWORK(KW), INFO ) C C Copy the reduced system matrices Cc and Dc. C CALL DLACPY( 'Full', M, NCR, DWORK(KCE), LDCE, F, LDF ) CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC ) C END IF C DWORK(1) = WRKOPT C RETURN C *** Last line of SB16BD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01AZ.f0000644000000000000000000000013215012430707016203 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01AZ.f0000644000175000017500000003665615012430707017417 0ustar00lilgelilge00000000000000 SUBROUTINE TG01AZ( JOB, L, N, M, P, THRESH, A, LDA, E, LDE, $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO ) C C PURPOSE C C To balance the matrices of the system pencil C C S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, C ( C 0 ) ( 0 0 ) C C corresponding to the descriptor triple (A-lambda E,B,C), C by balancing. This involves diagonal similarity transformations C (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system C (A-lambda E,B,C) to make the rows and columns of system pencil C matrices C C diag(Dl,I) * S * diag(Dr,I) C C as close in norm as possible. Balancing may reduce the 1-norms C of the matrices of the system pencil S. C C The balancing can be performed optionally on the following C particular system pencils C C S = A-lambda E, C C S = ( A-lambda E B ), or C C S = ( A-lambda E ). C ( C ) C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Indicates which matrices are involved in balancing, as C follows: C = 'A': All matrices are involved in balancing; C = 'B': B, A and E matrices are involved in balancing; C = 'C': C, A and E matrices are involved in balancing; C = 'N': B and C matrices are not involved in balancing. C C Input/Output Parameters C C L (input) INTEGER C The number of rows of matrices A, B, and E. L >= 0. C C N (input) INTEGER C The number of columns of matrices A, E, and C. N >= 0. C C M (input) INTEGER C The number of columns of matrix B. M >= 0. C C P (input) INTEGER C The number of rows of matrix C. P >= 0. C C THRESH (input) DOUBLE PRECISION C Threshold value for magnitude of elements: C elements with magnitude less than or equal to C THRESH are ignored for balancing. THRESH >= 0. C The magnitude is computed as the sum of the absolute C values of the real and imaginary parts. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the state dynamics matrix A. C On exit, the leading L-by-N part of this array contains C the balanced matrix Dl*A*Dr. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,L). C C E (input/output) COMPLEX*16 array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the descriptor matrix E. C On exit, the leading L-by-N part of this array contains C the balanced matrix Dl*E*Dr. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,L). C C B (input/output) COMPLEX*16 array, dimension (LDB,M) C On entry, the leading L-by-M part of this array must C contain the input/state matrix B. C On exit, if M > 0, the leading L-by-M part of this array C contains the balanced matrix Dl*B. C The array B is not referenced if M = 0. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. C C C (input/output) COMPLEX*16 array, dimension (LDC,N) C On entry, the leading P-by-N part of this array must C contain the state/output matrix C. C On exit, if P > 0, the leading P-by-N part of this array C contains the balanced matrix C*Dr. C The array C is not referenced if P = 0. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C LSCALE (output) DOUBLE PRECISION array, dimension (L) C The scaling factors applied to S from left. If Dl(j) is C the scaling factor applied to row j, then C SCALE(j) = Dl(j), for j = 1,...,L. C C RSCALE (output) DOUBLE PRECISION array, dimension (N) C The scaling factors applied to S from right. If Dr(j) is C the scaling factor applied to column j, then C SCALE(j) = Dr(j), for j = 1,...,N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (3*(L+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 METHOD C C Balancing consists of applying a diagonal similarity C transformation C -1 C diag(Dl,I) * S * diag(Dr,I) C C to make the 1-norms of each row of the first L rows of S and its C corresponding N columns nearly equal. C C Information about the diagonal matrices Dl and Dr are returned in C the vectors LSCALE and RSCALE, respectively. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C [2] R.C. Ward, R. C. C Balancing the generalized eigenvalue problem. C SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C March 1999. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C - C C KEYWORDS C C Balancing, eigenvalue, matrix algebra, matrix operations, C similarity transformation. C C ********************************************************************* C C .. Parameters .. DOUBLE PRECISION HALF, ONE, ZERO PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) DOUBLE PRECISION SCLFAC, THREE PARAMETER ( SCLFAC = 1.0D+1, THREE = 3.0D+0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER INFO, L, LDA, LDB, LDC, LDE, M, N, P DOUBLE PRECISION THRESH C .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), $ E( LDE, * ) DOUBLE PRECISION DWORK( * ), LSCALE( * ), RSCALE( * ) C .. Local Scalars .. LOGICAL WITHB, WITHC INTEGER I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2, $ KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN, $ NRP2 DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, $ SFMIN, SUM, T, TA, TB, TC, TE COMPLEX*16 CDUM C .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) C .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL DDOT, DLAMCH, IZAMAX, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA, ZDSCAL C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN C .. C .. Statement Functions .. DOUBLE PRECISION CABS1 C .. C .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) C C .. Executable Statements .. C C Test the input parameters. C INFO = 0 WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) C IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) $ THEN INFO = -1 ELSE IF( L.LT.0 ) 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( THRESH.LT.ZERO ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, L ) ) THEN INFO = -8 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -10 ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN INFO = -12 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -14 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01AZ', -INFO ) RETURN END IF C C Quick return if possible. C IF( L.EQ.0 .OR. N.EQ.0 ) THEN DUM( 1 ) = ONE IF( L.GT.0 ) THEN CALL DCOPY( L, DUM, 0, LSCALE, 1 ) ELSE IF( N.GT.0 ) THEN CALL DCOPY( N, DUM, 0, RSCALE, 1 ) END IF RETURN END IF C C Initialize balancing and allocate work storage. C KW1 = N KW2 = KW1 + L KW3 = KW2 + L KW4 = KW3 + N KW5 = KW4 + L DUM( 1 ) = ZERO CALL DCOPY( L, DUM, 0, LSCALE, 1 ) CALL DCOPY( N, DUM, 0, RSCALE, 1 ) CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 ) C C Compute right side vector in resulting linear equations. C BASL = LOG10( SCLFAC ) DO 20 I = 1, L DO 10 J = 1, N TE = CABS1( E( I, J ) ) TA = CABS1( A( I, J ) ) IF( TA.GT.THRESH ) THEN TA = LOG10( TA ) / BASL ELSE TA = ZERO END IF IF( TE.GT.THRESH ) THEN TE = LOG10( TE ) / BASL ELSE TE = ZERO END IF DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE 10 CONTINUE 20 CONTINUE C IF( M.EQ.0 ) THEN WITHB = .FALSE. TB = ZERO END IF IF( P.EQ.0 ) THEN WITHC = .FALSE. TC = ZERO END IF C IF( WITHB ) THEN DO 30 I = 1, L J = IZAMAX( M, B( I, 1 ), LDB ) TB = CABS1( B( I, J ) ) IF( TB.GT.THRESH ) THEN TB = LOG10( TB ) / BASL DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB END IF 30 CONTINUE END IF C IF( WITHC ) THEN DO 40 J = 1, N I = IZAMAX( P, C( 1, J ), 1 ) TC = CABS1( C( I, J ) ) IF( TC.GT.THRESH ) THEN TC = LOG10( TC ) / BASL DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC END IF 40 CONTINUE END IF C COEF = ONE / DBLE( L+N ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = MAX( L, N ) + 2 BETA = ZERO IT = 1 C C Start generalized conjugate gradient iteration. C 50 CONTINUE C GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) + $ DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 ) C EW = ZERO DO 60 I = 1, L EW = EW + DWORK( I+KW4 ) 60 CONTINUE C EWC = ZERO DO 70 I = 1, N EWC = EWC + DWORK( I+KW5 ) 70 CONTINUE C GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - $ COEF5*( EW - EWC )**2 IF( GAMMA.EQ.ZERO ) $ GO TO 160 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = COEF5*( EWC - THREE*EW ) TC = COEF5*( EW - THREE*EWC ) C CALL DSCAL( N+L, BETA, DWORK, 1 ) C CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 ) CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 ) C DO 80 J = 1, N DWORK( J ) = DWORK( J ) + TC 80 CONTINUE C DO 90 I = 1, L DWORK( I+KW1 ) = DWORK( I+KW1 ) + T 90 CONTINUE C C Apply matrix to vector. C DO 110 I = 1, L KOUNT = 0 SUM = ZERO DO 100 J = 1, N IF( CABS1( A( I, J ) ).GT.THRESH ) THEN KOUNT = KOUNT + 1 SUM = SUM + DWORK( J ) END IF IF( CABS1( E( I, J ) ).GT.THRESH ) THEN KOUNT = KOUNT + 1 SUM = SUM + DWORK( J ) END IF 100 CONTINUE IF( WITHB ) THEN J = IZAMAX( M, B( I, 1 ), LDB ) IF( CABS1( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 END IF DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM 110 CONTINUE C DO 130 J = 1, N KOUNT = 0 SUM = ZERO DO 120 I = 1, L IF( CABS1( A( I, J ) ).GT.THRESH ) THEN KOUNT = KOUNT + 1 SUM = SUM + DWORK( I+KW1 ) END IF IF( CABS1( E( I, J ) ).GT.THRESH ) THEN KOUNT = KOUNT + 1 SUM = SUM + DWORK( I+KW1 ) END IF 120 CONTINUE IF( WITHC ) THEN I = IZAMAX( P, C( 1, J ), 1 ) IF( CABS1( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 END IF DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM 130 CONTINUE C SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) + $ DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 ) ALPHA = GAMMA / SUM C C Determine correction to current iteration. C CMAX = ZERO DO 140 I = 1, L COR = ALPHA*DWORK( I+KW1 ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE( I ) = LSCALE( I ) + COR 140 CONTINUE C DO 150 J = 1, N COR = ALPHA*DWORK( J ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE( J ) = RSCALE( J ) + COR 150 CONTINUE IF( CMAX.LT.HALF ) $ GO TO 160 C CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 ) CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 ) C PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 50 C C End generalized conjugate gradient iteration. C 160 CONTINUE SFMIN = DLAMCH( 'Safe minimum' ) SFMAX = ONE / SFMIN LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) C C Compute left diagonal scaling matrix. C DO 170 I = 1, L IRAB = IZAMAX( N, A( I, 1 ), LDA ) RAB = ABS( A( I, IRAB ) ) IRAB = IZAMAX( N, E( I, 1 ), LDE ) RAB = MAX( RAB, ABS( E( I, IRAB ) ) ) IF( WITHB ) THEN IRAB = IZAMAX( M, B( I, 1 ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB ) ) ) END IF LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE( I ) = SCLFAC**IR 170 CONTINUE C C Compute right diagonal scaling matrix. C DO 180 J = 1, N ICAB = IZAMAX( L, A( 1, J ), 1 ) CAB = ABS( A( ICAB, J ) ) ICAB = IZAMAX( L, E( 1, J ), 1 ) CAB = MAX( CAB, ABS( E( ICAB, J ) ) ) IF( WITHC ) THEN ICAB = IZAMAX( P, C( 1, J ), 1 ) CAB = MAX( CAB, ABS( C( ICAB, J ) ) ) END IF LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) ) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) RSCALE( J ) = SCLFAC**JC 180 CONTINUE C C Row scaling of matrices A, E and B. C DO 190 I = 1, L CALL ZDSCAL( N, LSCALE( I ), A( I, 1 ), LDA ) CALL ZDSCAL( N, LSCALE( I ), E( I, 1 ), LDE ) IF( WITHB ) $ CALL ZDSCAL( M, LSCALE( I ), B( I, 1 ), LDB ) 190 CONTINUE C C Column scaling of matrices A, E and C. C DO 200 J = 1, N CALL ZDSCAL( L, RSCALE( J ), A( 1, J ), 1 ) CALL ZDSCAL( L, RSCALE( J ), E( 1, J ), 1 ) IF( WITHC ) $ CALL ZDSCAL( P, RSCALE( J ), C( 1, J ), 1 ) 200 CONTINUE C RETURN C *** Last line of TG01AZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03LZ.f0000644000000000000000000000013215012430707016204 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03LZ.f0000644000175000017500000010306715012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE MB03LZ( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG, $ LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA, $ IWORK, DWORK, LDWORK, ZWORK, LZWORK, BWORK, $ INFO ) C C PURPOSE C C To compute the eigenvalues of a complex N-by-N skew-Hamiltonian/ C Hamiltonian pencil aS - bH, with C C ( A D ) ( B F ) C S = ( ) and H = ( ). (1) C ( E A' ) ( G -B' ) C C The structured Schur form of the embedded real skew-Hamiltonian/ C skew-Hamiltonian pencil aB_S - bB_T, defined as C C ( Re(A) -Im(A) | Re(D) -Im(D) ) C ( | ) C ( Im(A) Re(A) | Im(D) Re(D) ) C ( | ) C B_S = (-----------------+-----------------) , and C ( | ) C ( Re(E) -Im(E) | Re(A') Im(A') ) C ( | ) C ( Im(E) Re(E) | -Im(A') Re(A') ) C (2) C ( -Im(B) -Re(B) | -Im(F) -Re(F) ) C ( | ) C ( Re(B) -Im(B) | Re(F) -Im(F) ) C ( | ) C B_T = (-----------------+-----------------) , T = i*H, C ( | ) C ( -Im(G) -Re(G) | -Im(B') Re(B') ) C ( | ) C ( Re(G) -Im(G) | -Re(B') -Im(B') ) C C is determined and used to compute the eigenvalues. The notation M' C denotes the conjugate transpose of the matrix M. Optionally, C if COMPQ = 'C', an orthonormal basis of the right deflating C subspace of the pencil aS - bH, corresponding to the eigenvalues C with strictly negative real part, is computed. Namely, after C transforming aB_S - bB_H by unitary matrices, we have C C ( BA BD ) ( BB BF ) C B_Sout = ( ) and B_Hout = ( ), (3) C ( 0 BA' ) ( 0 -BB' ) C C and the eigenvalues with strictly negative real part of the C complex pencil aB_Sout - bB_Hout are moved to the top. The C embedding doubles the multiplicities of the eigenvalues of the C pencil aS - bH. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether to compute the deflating subspace C corresponding to the eigenvalues of aS - bH with strictly C negative real part. C = 'N': do not compute the deflating subspace; compute the C eigenvalues only; C = 'C': compute the deflating subspace and store it in the C leading subarray of Q. C C ORTH CHARACTER*1 C If COMPQ = 'C', specifies the technique for computing an C orthonormal basis of the deflating subspace, as follows: C = 'P': QR factorization with column pivoting; C = 'S': singular value decomposition. C If COMPQ = 'N', the ORTH value is not used. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) COMPLEX*16 array, dimension (LDA, N) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix A. C On exit, if COMPQ = 'C', the leading N-by-N part of this C array contains the upper triangular matrix BA in (3) (see C also METHOD). The strictly lower triangular part is not C zeroed; it is preserved in the leading N/2-by-N/2 part. C If COMPQ = 'N', this array is unchanged on exit. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N). C C DE (input/output) COMPLEX*16 array, dimension (LDDE, N) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C skew-Hermitian matrix E, and the N/2-by-N/2 upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array must contain the upper triangular part of C the skew-Hermitian matrix D. C On exit, if COMPQ = 'C', the leading N-by-N part of this C array contains the skew-Hermitian matrix BD in (3) (see C also METHOD). The strictly lower triangular part of the C input matrix is preserved. C If COMPQ = 'N', this array is unchanged on exit. C C LDDE INTEGER C The leading dimension of the array DE. LDDE >= MAX(1, N). C C B (input/output) COMPLEX*16 array, dimension (LDB, N) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C On exit, if COMPQ = 'C', the leading N-by-N part of this C array contains the upper triangular matrix BB in (3) (see C also METHOD). The strictly lower triangular part is not C zeroed; the elements below the first subdiagonal of the C input matrix are preserved. C If COMPQ = 'N', this array is unchanged on exit. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N). C C FG (input/output) COMPLEX*16 array, dimension (LDFG, N) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C Hermitian matrix G, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C Hermitian matrix F. C On exit, if COMPQ = 'C', the leading N-by-N part of this C array contains the Hermitian matrix BF in (3) (see also C METHOD). The strictly lower triangular part of the input C matrix is preserved. The diagonal elements might have tiny C imaginary parts. C If COMPQ = 'N', this array is unchanged on exit. C C LDFG INTEGER C The leading dimension of the array FG. LDFG >= MAX(1, N). C C NEIG (output) INTEGER C If COMPQ = 'C', the number of eigenvalues in aS - bH with C strictly negative real part. C C Q (output) COMPLEX*16 array, dimension (LDQ, 2*N) C On exit, if COMPQ = 'C', the leading N-by-NEIG part of C this array contains an orthonormal basis of the right C deflating subspace corresponding to the eigenvalues of the C pencil aS - bH with strictly negative real part. C The remaining entries are meaningless. C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, 2*N), if COMPQ = 'C'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C C Workspace C C IWORK INTEGER array, dimension (N+1) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -20, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= MAX( 4*N*N + 2*N + MAX(3,N) ), if COMPQ = 'N'; C LDWORK >= MAX( 1, 11*N*N + 2*N ), if COMPQ = 'C'. C For good performance LDWORK should be generally 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 ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal LZWORK. C On exit, if INFO = -22, ZWORK(1) returns the minimum value C of LZWORK. C C LZWORK INTEGER C The dimension of the array ZWORK. C LZWORK >= 1, if COMPQ = 'N'; C LZWORK >= 8*N + 4, if COMPQ = 'C'. C For good performance LZWORK should be generally larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK C is issued by XERBLA. C C BWORK LOGICAL array, dimension (LBWORK) C LBWORK >= 0, if COMPQ = 'N'; C LBWORK >= N - 1, if COMPQ = 'C'. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: QZ iteration failed in the SLICOT Library routine C MB04FD (QZ iteration did not converge or computation C of the shifts failed); C = 2: QZ iteration failed in the LAPACK routine ZHGEQZ when C trying to triangularize the 2-by-2 blocks; C = 3: the singular value decomposition failed in the LAPACK C routine ZGESVD (for ORTH = 'S'); C = 4: warning: the pencil is numerically singular. C C METHOD C C First, T = i*H is set. Then, the embeddings, B_S and B_T, of the C matrices S and T, are determined and, subsequently, the SLICOT C Library routine MB04FD is applied to compute the structured Schur C form, i.e., the factorizations C C ~ ( S11 S12 ) C B_S = J Q' J' B_S Q = ( ) and C ( 0 S11' ) C C ~ ( T11 T12 ) ( 0 I ) C B_T = J Q' J' B_T Q = ( ), with J = ( ), C ( 0 T11' ) ( -I 0 ) C C where Q is real orthogonal, S11 is upper triangular, and T11 is C upper quasi-triangular. C C Second, the SLICOT Library routine MB03JZ is applied, to compute a C ~ C unitary matrix Q, such that C C ~ ~ C ~ ~ ~ ( S11 S12 ) C J Q' J' B_S Q = ( ~ ) =: B_Sout, C ( 0 S11' ) C C ~ ~ ~ ( H11 H12 ) C J Q' J'(-i*B_T) Q = ( ) =: B_Hout, C ( 0 -H11' ) C ~ ~ ~ C with S11, H11 upper triangular, and such that Spec_-(B_S, -i*B_T) C is contained in the spectrum of the 2*NEIG-by-2*NEIG leading C ~ C principal subpencil aS11 - bH11. C C Finally, the right deflating subspace is computed. C See also page 22 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C complex floating point operations. C C FURTHER COMMENTS C C This routine does not perform any scaling of the matrices. Scaling C might sometimes be useful, and it should be done externally. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, April 20, 2009. C V. Sima, Aug. 2009 (SLICOT version of the routine ZHAUDF). C C REVISIONS C C V. Sima, Dec. 2010, Jan. 2011, Mar. 2011, Aug. 2011, Nov. 2011, C Aug. 2014, Jan. 2017, Apr. 2020. C M. Voigt, Jan. 2012. C C KEYWORDS C C Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian C pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) COMPLEX*16 CZERO, CONE, CIMAG PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ), $ CIMAG = ( 0.0D+0, 1.0D+0 ) ) C C .. Scalar Arguments .. CHARACTER COMPQ, ORTH INTEGER INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK, $ LZWORK, N, NEIG C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), DWORK( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ), DE( LDDE, * ), $ FG( LDFG, * ), Q( LDQ, * ), ZWORK( * ) C C .. Local Scalars .. LOGICAL LCMPQ, LQUERY, QR, QRP, SVD CHARACTER*14 CMPQ, JOB INTEGER I, I1, IA, IB, IDE, IEV, IFG, IQ, IQ2, IQB, IS, $ ITAU, IW, IW1, IWA, IWRK, J, J1, J2, JM1, JP2, $ M, MINDB, MINDW, MINZW, N2, NB, NC, NN, OPTDW, $ OPTZW DOUBLE PRECISION EPS, NRMB, TOL COMPLEX*16 TMP C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C C .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DSCAL, MB03JZ, MB04FD, XERBLA, $ ZAXPY, ZGEMM, ZGEQP3, ZGEQRF, ZGESVD, ZHGEQZ, $ ZLACPY, ZSCAL, ZUNGQR C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, $ SQRT C C .. Executable Statements .. C C Decode the input arguments. C Using ORTH = 'Q' is not safe, but sometimes gives better results. C M = N/2 NN = N*N N2 = 2*N NEIG = 0 LCMPQ = LSAME( COMPQ, 'C' ) IF( LCMPQ ) THEN QR = LSAME( ORTH, 'Q' ) QRP = LSAME( ORTH, 'P' ) SVD = LSAME( ORTH, 'S' ) ELSE QR = .FALSE. QRP = .FALSE. SVD = .FALSE. END IF C IF( N.EQ.0 ) THEN MINDW = 1 MINZW = 1 ELSE IF( LCMPQ ) THEN MINDB = 8*NN + N2 MINDW = 11*NN + N2 MINZW = 8*N + 4 ELSE MINDB = 4*NN + N2 MINDW = 4*NN + N2 + MAX( 3, N ) MINZW = 1 END IF LQUERY = LDWORK.EQ.-1 .OR. LZWORK.EQ.-1 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( LCMPQ ) THEN IF( .NOT.( QR .OR. QRP .OR. SVD ) ) $ INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDDE.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDFG.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N2 ) ) THEN INFO = -14 ELSE IF( .NOT. LQUERY ) THEN IF( LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -20 ELSE IF( LZWORK.LT.MINZW ) THEN ZWORK( 1 ) = MINZW INFO = -22 END IF END IF C IF( INFO.NE.0) THEN CALL XERBLA( 'MB03LZ', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN C C Compute optimal workspace. C IF( LCMPQ ) THEN JOB = 'Triangularize' CMPQ = 'Initialize' CALL ZGEQRF( N, N, Q, LDQ, ZWORK, ZWORK, -1, INFO ) I = INT( ZWORK( 1 ) ) NB = MAX( I/N, 2 ) ELSE JOB = 'Eigenvalues' CMPQ = 'No Computation' END IF C IF( LQUERY ) THEN CALL MB04FD( JOB, CMPQ, N2, DWORK, N, DWORK, N, DWORK, N, $ DWORK, N, DWORK, N2, ALPHAI, ALPHAR, BETA, $ IWORK, DWORK, -1, INFO ) OPTDW = MAX( MINDW, MINDB + INT( DWORK( 1 ) ) ) C IF( LCMPQ ) THEN IF( SVD ) THEN CALL ZGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, ZWORK, 1, $ ZWORK, 1, ZWORK, -1, DWORK, INFO ) J = INT( ZWORK( 1 ) ) ELSE IF( QR ) THEN J = M CALL ZGEQRF( N, J, Q, LDQ, ZWORK, ZWORK, -1, INFO ) ELSE J = N CALL ZGEQP3( N, J, Q, LDQ, IWORK, ZWORK, ZWORK, -1, $ DWORK, INFO ) END IF CALL ZUNGQR( N, J, J, Q, LDQ, ZWORK, ZWORK( 2 ), -1, $ INFO ) J = J + MAX( INT( ZWORK( 1 ) ), INT( ZWORK( 2 ) ) ) END IF OPTZW = MAX( MINZW, I, J ) ELSE OPTZW = MINZW END IF DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW RETURN ELSE OPTZW = MINZW END IF END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK( 1 ) = ONE ZWORK( 1 ) = CONE RETURN END IF C C Determine machine constants. C EPS = DLAMCH( 'Precision' ) TOL = SQRT( EPS ) C C Set up the embeddings of the matrices S and H. C C Set the pointers for the inputs and outputs of MB04FD. C Real workspace: need 4*N**2+2*N, if COMPQ = 'N'; C 8*N**2+2*N, if COMPQ = 'C'. C IQ = 1 IF( LCMPQ ) THEN IA = IQ + N2*N2 ELSE IA = 1 END IF C IDE = IA + NN IB = IDE + NN + N IFG = IB + NN IWRK = IFG + NN + N C C Build the embedding of A. C IW = IA IS = IW + N*M DO 30 J = 1, M IW1 = IW DO 10 I = 1, M DWORK( IW ) = DBLE( A( I, J ) ) IW = IW + 1 10 CONTINUE C DO 20 I = 1, M DWORK( IW ) = DIMAG( A( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 20 CONTINUE CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IS = IS + M 30 CONTINUE C C Build the embedding of D and E. C IW = IDE DO 60 J = 1, M + 1 DO 40 I = 1, M DWORK( IW ) = DBLE( DE( I, J ) ) IW = IW + 1 40 CONTINUE C IW = IW + J - 1 IS = IW DO 50 I = J, M DWORK( IW ) = DIMAG( DE( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 50 CONTINUE 60 CONTINUE C IW1 = IW I1 = IW DO 80 J = 2, M + 1 IS = I1 I1 = I1 + 1 DO 70 I = 1, J - 1 DWORK( IW ) = -DIMAG( DE( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 70 CONTINUE IW = IW + N - J + 1 80 CONTINUE CALL DLACPY( 'Full', M, M+1, DWORK( IDE ), N, DWORK( IW1-M ), N ) C C Build the embedding of B. C IW = IB IS = IW + N*M DO 110 J = 1, M IW1 = IW DO 90 I = 1, M DWORK( IW ) = -DIMAG( B( I, J ) ) IW = IW + 1 90 CONTINUE C DO 100 I = 1, M DWORK( IW ) = DBLE( B( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 100 CONTINUE CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IS = IS + M 110 CONTINUE C C Build the embedding of F and G. C IW = IFG DO 140 J = 1, M + 1 DO 120 I = 1, M DWORK( IW ) = -DIMAG( FG( I, J ) ) IW = IW + 1 120 CONTINUE C IW = IW + J - 1 IS = IW DO 130 I = J, M DWORK( IW ) = DBLE( FG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 130 CONTINUE 140 CONTINUE C IW1 = IW I1 = IW DO 160 J = 2, M + 1 IS = I1 I1 = I1 + 1 DO 150 I = 1, J - 1 DWORK( IW ) = -DBLE( FG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 150 CONTINUE IW = IW + N - J + 1 160 CONTINUE CALL DLACPY( 'Full', M, M+1, DWORK( IFG ), N, DWORK( IW1-M ), N ) C C STEP 1: Apply MB04FD to transform the extended pencil to real C skew-Hamiltonian/skew-Hamiltonian Schur form. C C Real workspace: C need 4*N*N + 2*N + MAX( 3, N ), if COMPQ = 'N'; C 8*N*N + 2*N + 3*N*N, if COMPQ = 'C'. C prefer larger. C CALL MB04FD( JOB, CMPQ, N2, DWORK( IA ), N, DWORK( IDE ), N, $ DWORK( IB ), N, DWORK( IFG ), N, DWORK( IQ ), N2, $ ALPHAI, ALPHAR, BETA, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) IF( INFO.EQ.2 ) THEN IWA = 4 ELSE IF( INFO.GT.0 ) THEN RETURN ELSE IWA = 0 END IF OPTDW = MAX( MINDW, MINDB + INT( DWORK( IWRK ) ) ) C C Scale the eigenvalues. C CALL DSCAL( N, -ONE, ALPHAI, 1 ) C C Return if only the eigenvalues are desired. C IF( .NOT.LCMPQ ) THEN DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW INFO = IWA RETURN END IF C C Convert the results to complex datatype. D and F start in the C first column of DE and FG, respectively. C IW = IA DO 180 J = 1, N DO 170 I = 1, J A( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 170 CONTINUE IF( J.GE.M .AND. J.LT.N ) $ A( J+1, J ) = CZERO IW = IW + N - J 180 CONTINUE C IW = IDE + N DO 200 J = 1, N DO 190 I = 1, J - 1 DE( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 190 CONTINUE DE( J, J ) = CZERO IF( J.GE.M .AND. J.LT.N ) $ DE( J+1, J ) = CZERO IW = IW + N - J + 1 200 CONTINUE C IW = IB DO 220 J = 1, N DO 210 I = 1, MIN( J + 1, N ) B( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 210 CONTINUE IW = IW + N - J - 1 220 CONTINUE C IW = IFG + N DO 240 J = 1, N DO 230 I = 1, J - 1 FG( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 230 CONTINUE FG( J, J ) = CZERO IF( J.GE.M .AND. J.LT.N ) $ FG( J+1, J ) = CZERO IW = IW + N - J + 1 240 CONTINUE C IW = IQ DO 260 J = 1, N2 DO 250 I = 1, N2 Q( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 250 CONTINUE 260 CONTINUE C C Triangularize the 2-by-2 diagonal blocks in B using the complex C version of the QZ algorithm. C C Set up pointers on the outputs of ZHGEQZ. C A block algorithm is used for large N. C IQ2 = 1 IEV = 5 IQ = 9 IWRK = IQ + 4*( N - 1 ) C J = 1 J1 = 1 J2 = MIN( N, J1 + NB - 1 ) C WHILE( J.LT.N ) DO 270 CONTINUE IF( J.LT.N ) THEN NRMB = ABS( B( J, J ) ) + ABS( B( J+1, J+1 ) ) IF( ABS( B( J+1, J ) ).GT.NRMB*EPS ) THEN C C Triangularization step. C Workspace: need 8*N + 4. C NC = MAX( J2-J-1, 0 ) JM1 = MAX( J-1, 1 ) JP2 = MIN( J+2, N ) TMP = A( J+1, J ) A( J+1, J ) = CZERO CALL ZHGEQZ( 'Schur Form', 'Initialize', 'Initialize', 2, 1, $ 2, B( J, J ), LDB, A( J, J ), LDA, $ ZWORK( IEV ), ZWORK( IEV+2 ), ZWORK( IQ ), 2, $ ZWORK( IQ2 ), 2, ZWORK( IWRK ), LZWORK-IWRK+1, $ DWORK, INFO ) A( J+1, J ) = TMP IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Update A. C CALL ZGEMM( 'No Transpose', 'No Transpose', J-1, 2, 2, $ CONE, A( 1, J ), LDA, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), JM1 ) CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, A( 1, J ), $ LDA ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, NC, $ 2, CONE, ZWORK( IQ ), 2, A( J, JP2 ), LDA, $ CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, A( J, JP2 ), $ LDA ) C C Update DE. C TMP = DE( J+1, J ) DE( J+1, J ) = -DE( J, J+1 ) CALL ZGEMM( 'No Transpose', 'No Transpose', J+1, 2, 2, $ CONE, DE( 1, J ), LDDE, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), J+1 ) CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, DE( 1, J ), $ LDDE ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ J2-J+1, 2, CONE, ZWORK( IQ ), 2, DE( J, J ), $ LDDE, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2, $ DE( J, J ), LDDE ) DE( J+1, J ) = TMP C C Update B. C CALL ZGEMM( 'No Transpose', 'No Transpose', J-1, 2, 2, $ CONE, B( 1, J ), LDB, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), JM1 ) CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, B( 1, J ), $ LDB ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, NC, $ 2, CONE, ZWORK( IQ ), 2, B( J, JP2 ), LDB, $ CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, B( J, JP2 ), $ LDB ) C C Update FG. C TMP = FG( J+1, J ) FG( J+1, J ) = -FG( J, J+1 ) CALL ZGEMM( 'No Transpose', 'No Transpose', J+1, 2, 2, $ CONE, FG( 1, J ), LDFG, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), J+1 ) CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, FG( 1, J ), $ LDFG ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ J2-J+1, 2, CONE, ZWORK( IQ ), 2, FG( J, J ), $ LDFG, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2, $ FG( J, J ), LDFG ) FG( J+1, J ) = TMP C C Update Q. C CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, CONE, $ Q( 1, J ), LDQ, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, Q( 1, J ), $ LDQ ) CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, CONE, $ Q( 1, N+J ), LDQ, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, Q( 1, N+J ), $ LDQ ) C BWORK( J ) = .TRUE. J = J + 2 IQ = IQ + 4 ELSE BWORK( J ) = .FALSE. B( J+1, J ) = CZERO J = J + 1 END IF C IF( J.GE.J2 ) THEN J1 = J2 + 1 J2 = MIN( N, J1 + NB - 1 ) NC = J2 - J1 + 1 C C Update the columns J1 to J2 of A, DE, B, and FG for previous C transformations. C I = 1 IQB = 9 C WHILE( I.LT.J ) DO 280 CONTINUE IF( I.LT.J ) THEN IF( BWORK( I ) ) THEN CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, A( I, J1 ), $ LDA, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ A( I, J1 ), LDA ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, $ DE( I, J1 ), LDDE, CZERO, ZWORK( IWRK ), $ 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ DE( I, J1 ), LDDE ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, B( I, J1 ), $ LDB, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ B( I, J1 ), LDB ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, $ FG( I, J1 ), LDFG, CZERO, ZWORK( IWRK ), $ 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ FG( I, J1 ), LDFG ) IQB = IQB + 4 C I = I + 2 ELSE I = I + 1 END IF GO TO 280 END IF C END WHILE 280 END IF GO TO 270 END IF C END WHILE 270 C C Scale B and FG by -i. C DO 290 I = 1, N CALL ZSCAL( I, -CIMAG, B( 1, I ), 1 ) 290 CONTINUE C DO 300 I = 1, N CALL ZSCAL( I, -CIMAG, FG( 1, I ), 1 ) 300 CONTINUE C C STEP 2: Apply MB03JZ to reorder the eigenvalues with strictly C negative real part to the top. C CMPQ = 'Update' CALL MB03JZ( CMPQ, N2, A, LDA, DE, LDDE, B, LDB, FG, LDFG, Q, LDQ, $ NEIG, TOL, INFO ) C IF( QR ) $ NEIG = NEIG/2 ITAU = 1 IWRK = NEIG + 1 C C STEP 3: Compute the right deflating subspace corresponding to C the eigenvalues with strictly negative real part. C IF( NEIG.LE.M ) THEN DO 310 I = 1, NEIG CALL ZAXPY( M, CIMAG, Q( M+1, I ), 1, Q( 1, I ), 1 ) 310 CONTINUE CALL ZLACPY( 'Full', M, NEIG, Q( N+1, 1 ), LDQ, Q( M+1, 1 ), $ LDQ ) DO 320 I = 1, NEIG CALL ZAXPY( M, CIMAG, Q( M+N+1, I ), 1, Q( M+1, I ), 1 ) 320 CONTINUE ELSE DO 330 I = 1, M CALL ZAXPY( M, CIMAG, Q( M+1, I ), 1, Q( 1, I ), 1 ) 330 CONTINUE CALL ZLACPY( 'Full', M, M, Q( N+1, 1 ), LDQ, Q( M+1, 1 ), LDQ ) DO 340 I = 1, M CALL ZAXPY( M, CIMAG, Q( M+N+1, I ), 1, Q( M+1, I ), 1 ) 340 CONTINUE C DO 350 I = 1, NEIG - M CALL ZAXPY( M, CIMAG, Q( M+1, M+I ), 1, Q( 1, M+I ), 1 ) 350 CONTINUE CALL ZLACPY( 'Full', M, NEIG-M, Q( N+1, M+1 ), LDQ, $ Q( M+1, M+1 ), LDQ ) DO 360 I = 1, NEIG - M CALL ZAXPY( M, CIMAG, Q( M+N+1, M+I ), 1, Q( M+1, M+I ), 1 ) 360 CONTINUE END IF C C Orthogonalize the basis given in Q(1:n,1:neig). C IF( SVD ) THEN C C Workspace: need 3*N; C prefer larger. C Real workspace: need 6*N. C CALL ZGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK, $ ZWORK, 1, ZWORK, 1, ZWORK, LZWORK, $ DWORK( IWRK ), INFO ) IF( INFO.GT.0 ) THEN INFO = 3 RETURN END IF OPTZW = MAX( OPTZW, INT( ZWORK( 1 ) ) ) NEIG = NEIG/2 C ELSE IF( QR ) THEN C C Workspace: need N; C prefer M+M*NB, where NB is the optimal C blocksize. C CALL ZGEQRF( N, NEIG, Q, LDQ, ZWORK( ITAU ), ZWORK( IWRK ), $ LZWORK-IWRK+1, INFO ) OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 ) ELSE C C Workspace: need 2*N+1; C prefer N+(N+1)*NB. C Real workspace: need 2*N. C DO 370 J = 1, NEIG IWORK( J ) = 0 370 CONTINUE CALL ZGEQP3( N, NEIG, Q, LDQ, IWORK, ZWORK, ZWORK( IWRK ), $ LZWORK-IWRK+1, DWORK, INFO ) OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 ) END IF C C Workspace: need 2*N; C prefer N+N*NB. C CALL ZUNGQR( N, NEIG, NEIG, Q, LDQ, ZWORK( ITAU ), $ ZWORK( IWRK ), LZWORK-IWRK+1, INFO ) OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 ) IF( QRP ) $ NEIG = NEIG/2 END IF C DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW INFO = IWA RETURN C *** Last line of MB03LZ *** END control-4.1.2/src/slicot/src/PaxHeaders/SB01DD.f0000644000000000000000000000013015012430707016150 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB01DD.f0000644000175000017500000005301015012430707017345 0ustar00lilgelilge00000000000000 SUBROUTINE SB01DD( N, M, INDCON, A, LDA, B, LDB, NBLK, WR, WI, $ Z, LDZ, Y, COUNT, G, LDG, TOL, IWORK, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To compute for a controllable matrix pair ( A, B ) a matrix G C such that the matrix A - B*G has the desired eigenstructure, C specified by desired eigenvalues and free eigenvector elements. C C The pair ( A, B ) should be given in orthogonal canonical form C as returned by the SLICOT Library routine AB01ND. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A and the number of rows of the C matrix B. N >= 0. C C M (input) INTEGER C The number of columns of the matrix B. M >= 0. C C INDCON (input) INTEGER C The controllability index of the pair ( A, B ). C 0 <= INDCON <= 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 N-by-N matrix A in orthogonal canonical form, C as returned by SLICOT Library routine AB01ND. C On exit, the leading N-by-N part of this array contains C the real Schur form of the matrix A - B*G. C The elements below the real Schur form of A are set to C zero. C C LDA INTEGER C The leading dimension of the 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 N-by-M matrix B in orthogonal canonical form, C as returned by SLICOT Library routine AB01ND. C On exit, the leading N-by-M part of this array contains C the transformed matrix B. C C LDB INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C NBLK (input) INTEGER array, dimension (N) C The leading INDCON elements of this array must contain the C orders of the diagonal blocks in the orthogonal canonical C form of A, as returned by SLICOT Library routine AB01ND. C The values of these elements must satisfy the following C conditions: C NBLK(1) >= NBLK(2) >= ... >= NBLK(INDCON), C NBLK(1) + NBLK(2) + ... + NBLK(INDCON) = N. C C WR (input) DOUBLE PRECISION array, dimension (N) C WI (input) DOUBLE PRECISION array, dimension (N) C These arrays must contain the real and imaginary parts, C respectively, of the desired poles of the closed-loop C system, i.e., the eigenvalues of A - B*G. The poles can be C unordered, except that complex conjugate pairs of poles C must appear consecutively. C The elements of WI for complex eigenvalues are modified C internally, but restored on exit. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C On entry, the leading N-by-N part of this array must C contain the orthogonal matrix Z generated by SLICOT C Library routine AB01ND in the reduction of ( A, B ) to C orthogonal canonical form. C On exit, the leading N-by-N part of this array contains C the orthogonal transformation matrix which reduces A - B*G C to real Schur form. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= max(1,N). C C Y (input) DOUBLE PRECISION array, dimension (M*N) C Y contains elements which are used as free parameters C in the eigenstructure design. The values of these C parameters are often set by an external optimization C procedure. C C COUNT (output) INTEGER C The actual number of elements in Y used as free C eigenvector and feedback matrix elements in the C eigenstructure design. C C G (output) DOUBLE PRECISION array, dimension (LDG,N) C The leading M-by-N part of this array contains the C feedback matrix which assigns the desired eigenstructure C of A - B*G. C C LDG INTEGER C The leading dimension of the array G. LDG >= max(1,M). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determination when C transforming (A, B). If the user sets TOL > 0, then C the given value of TOL is used as a lower bound for the C reciprocal condition number (see the description of the C argument RCOND in the SLICOT routine MB03OD); a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*N*EPS, is used instead, where C EPS is the machine precision (see LAPACK Library routine C DLAMCH). C C Workspace C C IWORK INTEGER array, dimension (M) 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(M*N,M*M+2*N+4*M+1). 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: if the pair ( A, B ) is not controllable or the free C parameters are not set appropriately. C C METHOD C C The routine implements the method proposed in [1], [2]. C C REFERENCES C C [1] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and C Postlethwaite, I. C Optimal pole assignment design of linear multi-input systems. C Report 96-11, Department of Engineering, Leicester University, C 1996. C C [2] Petkov, P.Hr., Christov, N.D. and Konstantinov, M.M. C A computational algorithm for pole assignment of linear multi C input systems. IEEE Trans. Automatic Control, vol. AC-31, C pp. 1044-1047, 1986. C C NUMERICAL ASPECTS C C The method implemented is backward stable. C C FURTHER COMMENTS C C The eigenvalues of the real Schur form matrix As, returned in the C array A, are very close to the desired eigenvalues WR+WI*i. C However, the eigenvalues of the closed-loop matrix A - B*G, C computed by the QR algorithm using the matrices A and B, given on C entry, may be far from WR+WI*i, although the relative error C norm( Z'*(A - B*G)*Z - As )/norm( As ) C is close to machine accuracy. This may happen when the eigenvalue C problem for the matrix A - B*G is ill-conditioned. C C CONTRIBUTORS C C P.Hr. Petkov, Technical University of Sofia, Oct. 1998. C V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library C version. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005, C Apr. 2017. C C KEYWORDS C C Closed loop spectrum, closed loop systems, eigenvalue assignment, C orthogonal canonical form, orthogonal transformation, pole C placement, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C C .. Scalar Arguments .. INTEGER COUNT, INDCON, INFO, LDA, LDB, LDG, LDWORK, $ LDZ, M, N DOUBLE PRECISION TOL C .. C .. Array Arguments .. INTEGER IWORK( * ), NBLK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), $ G( LDG, * ), WI( * ), WR( * ), Y( * ), $ Z( LDZ, * ) C .. C .. Local Scalars .. LOGICAL COMPLX INTEGER I, IA, INDCN1, INDCN2, INDCRT, IP, IRMX, IWRK, $ K, KK, KMR, L, LP1, M1, MAXWRK, MI, MP1, MR, $ MR1, NBLKCR, NC, NI, NJ, NP1, NR, NR1, RANK DOUBLE PRECISION P, Q, R, S, SVLMXA, SVLMXB, TOLDEF C .. C .. Local Arrays .. DOUBLE PRECISION SVAL( 3 ) C .. C .. External Functions .. DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DLAPY2 EXTERNAL DASUM, DLAMCH, DLANGE, DLAPY2 C .. C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, DLARF, $ DLARFG, DLARTG, DLASET, DROT, DSCAL, MB02QD, $ XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C C Test the input arguments. C INFO = 0 NR = 0 IWRK = MAX( M*N, M*M + 2*N + 4*M + 1 ) DO 10 I = 1, MIN( INDCON, N ) NR = NR + NBLK( I ) IF( I.GT.1 ) THEN IF( NBLK( I-1 ).LT.NBLK( I ) ) $ INFO = -8 END IF 10 CONTINUE IF( N.LT.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( INDCON.LT.0 .OR. INDCON.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( NR.NE.N ) THEN INFO = -8 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDG.LT.MAX( 1, M ) ) THEN INFO = -16 ELSE IF( LDWORK.LT.IWRK ) THEN INFO = -20 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB01DD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( M, N, INDCON ).EQ.0 ) THEN COUNT = 0 DWORK( 1 ) = ONE RETURN END IF C MAXWRK = IWRK TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance, based on machine precision. C TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) END IF C IRMX = 2*N + 1 IWRK = IRMX + M*M M1 = NBLK( 1 ) COUNT = 1 INDCRT = INDCON NBLKCR = NBLK( INDCRT ) C C Compute the Frobenius norm of [ B A ] (used for rank estimation), C taking into account the structure. C NR = M1 NC = 1 SVLMXB = DLANGE( 'Frobenius', M1, M, B, LDB, DWORK ) SVLMXA = ZERO C DO 20 I = 1, INDCRT - 1 NR = NR + NBLK( I+1 ) SVLMXA = DLAPY2( SVLMXA, $ DLANGE( 'Frobenius', NR, NBLK( I ), $ A( 1, NC ), LDA, DWORK ) ) NC = NC + NBLK( I ) 20 CONTINUE C SVLMXA = DLAPY2( SVLMXA, $ DLANGE( 'Frobenius', N, NBLKCR, A( 1, NC ), LDA, $ DWORK ) ) L = 1 MR = NBLKCR NR = N - MR + 1 30 CONTINUE C WHILE( INDCRT.GT.1 )LOOP IF( INDCRT.GT.1 ) THEN C C Assign next eigenvalue/eigenvector. C LP1 = L + M1 INDCN1 = INDCRT - 1 MR1 = NBLK( INDCN1 ) NR1 = NR - MR1 COMPLX = WI(L).NE.ZERO CALL DCOPY( MR, Y( COUNT ), 1, DWORK( NR ), 1 ) COUNT = COUNT + MR NC = 1 IF( COMPLX ) THEN CALL DCOPY( MR, Y( COUNT ), 1, DWORK( N+NR ), 1 ) COUNT = COUNT + MR WI( L+1 ) = WI( L )*WI( L+1 ) NC = 2 END IF C C Compute and transform eigenvector. C DO 50 IP = 1, INDCRT IF( IP.NE.INDCRT ) THEN CALL DLACPY( 'Full', MR, MR1, A( NR, NR1 ), LDA, $ DWORK( IRMX ), M ) IF( IP.EQ.1 ) THEN MP1 = MR NP1 = NR + MP1 ELSE MP1 = MR + 1 NP1 = NR + MP1 S = DASUM( MP1, DWORK( NR ), 1 ) IF( COMPLX ) S = S + DASUM( MP1, DWORK( N+NR ), 1 ) IF( S.NE.ZERO ) THEN C C Scale eigenvector elements. C CALL DSCAL( MP1, ONE/S, DWORK( NR ), 1 ) IF( COMPLX ) THEN CALL DSCAL( MP1, ONE/S, DWORK( N+NR ), 1 ) IF( NP1.LE.N ) $ DWORK( N+NP1 ) = DWORK( N+NP1 ) / S END IF END IF END IF C C Compute the right-hand side of the eigenvector equations. C CALL DCOPY( MR, DWORK( NR ), 1, DWORK( NR1 ), 1 ) CALL DSCAL( MR, WR( L ), DWORK( NR1 ), 1 ) CALL DGEMV( 'No transpose', MR, MP1, -ONE, A( NR, NR ), $ LDA, DWORK( NR ), 1, ONE, DWORK( NR1 ), 1 ) IF( COMPLX ) THEN CALL DAXPY( MR, WI( L+1 ), DWORK( N+NR ), 1, $ DWORK( NR1 ), 1 ) CALL DCOPY( MR, DWORK( NR ), 1, DWORK( N+NR1 ), 1 ) CALL DAXPY( MR, WR( L+1 ), DWORK( N+NR ), 1, $ DWORK( N+NR1 ), 1 ) CALL DGEMV( 'No transpose', MR, MP1, -ONE, $ A( NR, NR ), LDA, DWORK( N+NR ), 1, ONE, $ DWORK( N+NR1 ), 1 ) IF( NP1.LE.N ) $ CALL DAXPY( MR, -DWORK( N+NP1 ), A( NR, NP1 ), 1, $ DWORK( N+NR1 ), 1 ) END IF C C Solve linear equations for eigenvector elements. C CALL MB02QD( 'FreeElements', 'NoPermuting', MR, MR1, NC, $ TOLDEF, SVLMXA, DWORK( IRMX ), M, $ DWORK( NR1 ), N, Y( COUNT ), IWORK, RANK, $ SVAL, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) IF( RANK.LT.MR ) GO TO 80 C COUNT = COUNT + ( MR1 - MR )*NC NJ = NR1 ELSE NJ = NR END IF NI = NR + MR - 1 IF( IP.EQ.1 ) THEN KMR = MR - 1 ELSE KMR = MR IF( IP.EQ.2 ) THEN NI = NI + NBLKCR ELSE NI = NI + NBLK( INDCRT-IP+2 ) + 1 IF( COMPLX ) NI = MIN( NI+1, N ) END IF END IF C DO 40 KK = 1, KMR K = NR + MR - KK IF( IP.EQ.1 ) K = N - KK CALL DLARTG( DWORK( K ), DWORK( K+1 ), P, Q, R ) DWORK( K ) = R DWORK( K+1 ) = ZERO C C Transform A. C CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ), LDA, $ P, Q ) CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q ) C IF( K.LT.LP1 ) THEN C C Transform B. C CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB, P, Q ) END IF C C Accumulate transformations. C CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q ) C IF( COMPLX ) THEN CALL DROT( 1, DWORK( N+K ), 1, DWORK( N+K+1 ), 1, P, $ Q ) K = K + 1 IF( K.LT.N ) THEN CALL DLARTG( DWORK( N+K ), DWORK( N+K+1 ), P, Q, $ R ) DWORK( N+K ) = R DWORK( N+K+1 ) = ZERO C C Transform A. C CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ), $ LDA, P, Q ) CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q ) C IF( K.LE.LP1 ) THEN C C Transform B. C CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB, $ P, Q ) END IF C C Accumulate transformations. C CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q ) C END IF END IF 40 CONTINUE C IF( IP.NE.INDCRT ) THEN MR = MR1 NR = NR1 IF( IP.NE.INDCN1 ) THEN INDCN2 = INDCRT - IP - 1 MR1 = NBLK( INDCN2 ) NR1 = NR1 - MR1 END IF END IF 50 CONTINUE C IF( .NOT.COMPLX ) THEN C C Find one column of G. C CALL DLACPY( 'Full', M1, M, B( L+1, 1 ), LDB, DWORK( IRMX ), $ M ) CALL DCOPY( M1, A( L+1, L ), 1, G( 1, L ), 1 ) ELSE C C Find two columns of G. C IF( LP1.LT.N ) THEN LP1 = LP1 + 1 K = L + 2 ELSE K = L + 1 END IF CALL DLACPY( 'Full', M1, M, B( K, 1 ), LDB, DWORK( IRMX ), $ M ) CALL DLACPY( 'Full', M1, 2, A( K, L ), LDA, G( 1, L ), LDG ) IF( K.EQ.L+1 ) THEN G( 1, L ) = G( 1, L ) - $ ( DWORK( N+L+1 ) / DWORK( L ) )*WI( L+1 ) G( 1, L+1 ) = G( 1, L+1 ) - WR(L+1) + $ ( DWORK( N+L ) / DWORK( L ) )*WI( L+1 ) END IF END IF C CALL MB02QD( 'FreeElements', 'NoPermuting', M1, M, NC, TOLDEF, $ SVLMXB, DWORK( IRMX ), M, G( 1, L ), LDG, $ Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) IF( RANK.LT.M1 ) GO TO 80 C COUNT = COUNT + ( M - M1 )*NC CALL DGEMM( 'No transpose', 'No transpose', LP1, NC, M, -ONE, $ B, LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA ) L = L + 1 NBLKCR = NBLKCR - 1 IF( NBLKCR.EQ.0 ) THEN INDCRT = INDCRT - 1 NBLKCR = NBLK( INDCRT ) END IF IF( COMPLX ) THEN WI( L ) = -WI( L-1 ) L = L + 1 NBLKCR = NBLKCR - 1 IF( NBLKCR.EQ.0 ) THEN INDCRT = INDCRT - 1 IF( INDCRT.GT.0 ) NBLKCR = NBLK( INDCRT ) END IF END IF MR = NBLKCR NR = N - MR + 1 GO TO 30 END IF C END WHILE 30 C IF( L.LE.N ) THEN C C Find the remaining columns of G. C C QR decomposition of the free eigenvectors. C DO 60 I = 1, MR - 1 IA = L + I - 1 MI = MR - I + 1 CALL DCOPY( MI, Y( COUNT ), 1, DWORK( 1 ), 1 ) COUNT = COUNT + MI CALL DLARFG( MI, DWORK( 1 ), DWORK( 2 ), 1, R ) DWORK( 1 ) = ONE C C Transform A. C CALL DLARF( 'Left', MI, MR, DWORK( 1 ), 1, R, A( IA, L ), $ LDA, DWORK( N+1 ) ) CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, A( 1, IA ), $ LDA, DWORK( N+1 ) ) C C Transform B. C CALL DLARF( 'Left', MI, M, DWORK( 1 ), 1, R, B( IA, 1 ), $ LDB, DWORK( N+1 ) ) C C Accumulate transformations. C CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, Z( 1, IA ), $ LDZ, DWORK( N+1 ) ) 60 CONTINUE C I = 0 C REPEAT 70 CONTINUE I = I + 1 IA = L + I - 1 IF( WI( IA ).EQ.ZERO ) THEN CALL DCOPY( MR, A( IA, L ), LDA, G( I, L ), LDG ) CALL DAXPY( MR-I, -ONE, Y( COUNT ), 1, G( I, L+I ), LDG ) COUNT = COUNT + MR - I G( I, IA ) = G( I, IA ) - WR( IA ) ELSE CALL DLACPY( 'Full', 2, MR, A( IA, L ), LDA, G( I, L ), $ LDG ) CALL DAXPY( MR-I-1, -ONE, Y( COUNT ), 2, G( I, L+I+1 ), $ LDG ) CALL DAXPY( MR-I-1, -ONE, Y( COUNT+1 ), 2, $ G( I+1, L+I+1 ), LDG ) COUNT = COUNT + 2*( MR - I - 1 ) G( I, IA ) = G(I, IA ) - WR( IA ) G( I, IA+1 ) = G(I, IA+1 ) - WI( IA ) G( I+1, IA ) = G(I+1, IA ) - WI( IA+1 ) G( I+1, IA+1 ) = G(I+1, IA+1 ) - WR( IA+1 ) I = I + 1 END IF IF( I.LT.MR ) GO TO 70 C UNTIL I.GE.MR C CALL DLACPY( 'Full', MR, M, B( L, 1 ), LDB, DWORK( IRMX ), M ) CALL MB02QD( 'FreeElements', 'NoPermuting', MR, M, MR, TOLDEF, $ SVLMXB, DWORK( IRMX ), M, G( 1, L ), LDG, $ Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) IF( RANK.LT.MR ) GO TO 80 C COUNT = COUNT + ( M - MR )*MR CALL DGEMM( 'No transpose', 'No transpose', N, MR, M, -ONE, B, $ LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA ) END IF C C Transform G: C G := G * Z'. C CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, G, LDG, $ Z, LDZ, ZERO, DWORK( 1 ), M ) CALL DLACPY( 'Full', M, N, DWORK( 1 ), M, G, LDG ) COUNT = COUNT - 1 C IF( N.GT.2) THEN C C Set the elements of A below the Hessenberg part to zero. C CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA ) END IF DWORK( 1 ) = MAXWRK RETURN C C Exit with INFO = 1 if the pair ( A, B ) is not controllable or C the free parameters are not set appropriately. C 80 INFO = 1 RETURN C *** Last line of SB01DD *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BB.f0000644000000000000000000000013015012430707016143 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/NF01BB.f0000644000175000017500000001072115012430707017342 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BB( IFLAG, NFUN, LX, IPAR, LIPAR, U, LDU, Y, LDY, $ X, NFEVL, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) C C PURPOSE C C This is the FCN routine for optimizing all parameters of a Wiener C system using SLICOT Library routine MD03AD. See the argument FCN C in the routine MD03AD for the description of parameters. C C ****************************************************************** C C .. Parameters .. C .. CJTE is initialized to activate the calculation of J'*e .. C .. NOUT is the unit number for printing intermediate results .. CHARACTER CJTE PARAMETER ( CJTE = 'C' ) INTEGER NOUT PARAMETER ( NOUT = 6 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER IFLAG, INFO, LDJ, LDU, LDWORK, LDY, LIPAR, LX, $ NFEVL, NFUN C .. Array Arguments .. INTEGER IPAR(*) DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), U(LDU,*), $ X(*), Y(LDY,*) C .. Local Scalars .. INTEGER BSN, I, JWORK, L, M, N, NN, NSMP, ST DOUBLE PRECISION ERR C .. External Functions .. DOUBLE PRECISION DNRM2 EXTERNAL DNRM2 C .. External Subroutines .. EXTERNAL DAXPY, NF01AD, NF01BD C C .. Executable Statements .. C L = IPAR(2) M = IPAR(5) N = IPAR(6) IF ( L.EQ.0 ) THEN NSMP = NFUN ELSE NSMP = NFUN/L END IF C INFO = 0 IF ( IFLAG.EQ.1 ) THEN C C Call NF01AD to compute the output y of the Wiener system (in E) C and then the error functions (also in E). The array U must C contain the input to the linear part of the Wiener system, and C Y must contain the original output Y of the Wiener system. C IPAR(6) must contain the number of states of the linear part, n. C Workspace: need: NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + C MAX( N*(N + L), N + M + L ) ), C if M>0, C NFUN + MAX( 2*NN, (N + L)*N + 2*N + C MAX( N*(N + L), L ) ), if M=0, C where NN = IPAR(7) (number of neurons); C prefer: larger. C CALL NF01AD( NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, LDU, E, $ NSMP, DWORK, LDWORK, INFO ) C DO 10 I = 1, L CALL DAXPY( NSMP, -ONE, Y(1,I), 1, E((I-1)*NSMP+1), 1 ) 10 CONTINUE C DWORK(1) = NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + $ MAX( N*(N + L), N + M + L ) ) C ELSE IF ( IFLAG.EQ.2 ) THEN C C Call NF01BD to compute the Jacobian in a compressed form. C Workspace: need: 2*NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + C MAX( N*(N + L), N + M + L )), C if M > 0, C 2*NFUN + MAX( 2*NN, (N + L)*N + 2*N + C MAX( N*(N + L), L ) ), C if M = 0; C prefer: larger. C CALL NF01BD( CJTE, NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, $ LDU, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) NFEVL = IPAR(6)*( M + L + 1 ) + L*M DWORK(1) = 2*NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + $ MAX( N*(N + L), N + M + L ) ) C ELSE IF ( IFLAG.EQ.3 ) THEN C C Set the parameter LDJ, the length of the array J, and the sizes C of the workspace for FCN (IFLAG = 1 or 2), and JTJ. C ST = IPAR(1) BSN = IPAR(4) NN = IPAR(7) C LDJ = NFUN IPAR(1) = NFUN*( BSN + ST ) IF ( M.GT.0 ) THEN JWORK = MAX( N*( N + L ), N + M + L ) ELSE JWORK = MAX( N*( N + L ), L ) END IF IPAR(2) = LDJ + MAX( ( N + L )*( N + M ) + 2*N + JWORK, 2*NN ) IPAR(3) = LDJ + IPAR(2) IPAR(4) = 0 IPAR(5) = NFUN C ELSE IF ( IFLAG.EQ.0 ) THEN C C Special call for printing intermediate results. C ERR = DNRM2( NFUN, E, 1 ) WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR END IF RETURN C C *** Last line of NF01BB *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04TB.f0000644000000000000000000000013215012430707016165 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04TB.f0000644000175000017500000006767315012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE MB04TB( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG, $ Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute a symplectic URV (SURV) decomposition of a real C 2N-by-2N matrix H, C C [ op(A) G ] [ op(R11) R12 ] C H = [ ] = U R V' = U * [ ] * V' , C [ Q op(B) ] [ 0 op(R22) ] C C where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real C N-by-N upper triangular matrix, op(R22) is a real N-by-N lower C Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic C matrices. Blocked version. C C ARGUMENTS C C Mode Parameters C C TRANA CHARACTER*1 C Specifies the form of op( A ) as follows: C = 'N': op( A ) = A; C = 'T': op( A ) = A'; C = 'C': op( A ) = A'. C C TRANB CHARACTER*1 C Specifies the form of op( B ) as follows: C = 'N': op( B ) = B; C = 'T': op( B ) = B'; C = 'C': op( B ) = B'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C ILO (input) INTEGER C It is assumed that op(A) is already upper triangular, C op(B) is lower triangular and Q is zero in rows and C columns 1:ILO-1. ILO is normally set by a previous call C to MB04DD; otherwise it should be set to 1. C 1 <= ILO <= N+1, if N > 0; ILO = 1, if 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. C On exit, the leading N-by-N part of this array contains C the triangular matrix R11, and in the zero part C information about the elementary reflectors used to C compute the SURV decomposition. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) C On entry, the leading N-by-N part of this array must C contain the matrix B. C On exit, the leading N-by-N part of this array contains C the Hessenberg matrix R22, and in the zero part C information about the elementary reflectors used to C compute the SURV decomposition. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,N). C C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) C On entry, the leading N-by-N part of this array must C contain the matrix G. C On exit, the leading N-by-N part of this array contains C the matrix R12. C C LDG INTEGER C The leading dimension of the array G. LDG >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, the leading N-by-N part of this array must C contain the matrix Q. C On exit, the leading N-by-N part of this array contains C information about the elementary reflectors used to C compute the SURV decomposition. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= MAX(1,N). C C CSL (output) DOUBLE PRECISION array, dimension (2N) C On exit, the first 2N elements of this array contain the C cosines and sines of the symplectic Givens rotations C applied from the left-hand side used to compute the SURV C decomposition. C C CSR (output) DOUBLE PRECISION array, dimension (2N-2) C On exit, the first 2N-2 elements of this array contain the C cosines and sines of the symplectic Givens rotations C applied from the right-hand side used to compute the SURV C decomposition. C C TAUL (output) DOUBLE PRECISION array, dimension (N) C On exit, the first N elements of this array contain the C scalar factors of some of the elementary reflectors C applied form the left-hand side. C C TAUR (output) DOUBLE PRECISION array, dimension (N-1) C On exit, the first N-1 elements of this array contain the C scalar factors of some of the elementary reflectors C applied form the right-hand side. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK, (16*N + 5)*NB, where NB is the optimal C block size determined by the function UE01MD. C On exit, if INFO = -16, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,N). 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 matrices U and V are represented as products of symplectic C reflectors and Givens rotations C C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) C .... C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), C C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) C .... C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ). C C Each HU(i) has the form C C HU(i) = 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:n) is stored on exit in C Q(i+1:n,i), and tau in Q(i,i). C C Each FU(i) has the form C C FU(i) = I - nu * w * w' C C where nu is a real scalar, and w is a real vector with C w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in C A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The C scalar nu is stored in TAUL(i). C C Each GU(i) is a Givens rotation acting on rows i and n+i, C where the cosine is stored in CSL(2*i-1) and the sine in C CSL(2*i). C C Each HV(i) has the form C C HV(i) = I - tau * v * v' C C where tau is a real scalar, and v is a real vector with C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in C Q(i,i+2:n), and tau in Q(i,i+1). C C Each FV(i) has the form C C FV(i) = I - nu * w * w' C C where nu is a real scalar, and w is a real vector with C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in C B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise. C The scalar nu is stored in TAUR(i). C C Each GV(i) is a Givens rotation acting on columns i+1 and n+i+1, C where the cosine is stored in CSR(2*i-1) and the sine in C CSR(2*i). C C NUMERICAL ASPECTS C C The algorithm requires 80/3*N**3 + ( 64*NB + 77 )*N**2 + C ( -16*NB + 48 )*NB*N + O(N) floating point operations, where C NB is the used block size, and is numerically backward stable. C C REFERENCES C C [1] Benner, P., Mehrmann, V., and Xu, H. C A numerically stable, structure preserving method for C computing the eigenvalues of real Hamiltonian or symplectic C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. C C [2] Kressner, D. C Block algorithms for orthogonal symplectic factorizations. C BIT, 43 (4), pp. 775-790, 2003. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESUB). C V. Sima, Aug. 2011, Oct. 2011. C C KEYWORDS C C Elementary matrix operations, Matrix decompositions, Hamiltonian C matrix C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER TRANA, TRANB INTEGER ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*) C .. Local Scalars .. LOGICAL LQUERY, LTRA, LTRB INTEGER I, IB, IERR, MINWRK, NB, NBMIN, NH, NIB, NNB, $ NX, PDW, PXA, PXB, PXG, PXQ, PYA, PYB, PYG, PYQ, $ WRKOPT C .. External Functions .. LOGICAL LSAME INTEGER UE01MD EXTERNAL LSAME, UE01MD C .. External Subroutines .. EXTERNAL DGEQRF, DGEMM, MB03XU, MB04TS, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) C MINWRK = MAX( 1, N ) C IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN INFO = -1 ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) THEN INFO = -2 ELSE IF ( N.LT.0 ) THEN INFO = -3 ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN INFO = -4 ELSE IF ( LDA.LT.MINWRK ) THEN INFO = -6 ELSE IF ( LDB.LT.MINWRK ) THEN INFO = -8 ELSE IF ( LDG.LT.MINWRK ) THEN INFO = -10 ELSE IF ( LDQ.LT.MINWRK ) THEN INFO = -12 ELSE LQUERY = LDWORK.EQ.-1 IF ( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN DWORK(1) = DBLE( MINWRK ) INFO = -18 ELSE IF ( N.EQ.0 ) THEN WRKOPT = ONE ELSE CALL DGEQRF( N, ILO, DWORK, MINWRK, DWORK, DWORK, -1, $ INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) NB = INT( WRKOPT/ILO ) WRKOPT = MAX( WRKOPT, 16*N*NB + 5*NB ) END IF IF ( LQUERY ) THEN DWORK(1) = DBLE( WRKOPT ) RETURN END IF END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04TB', -INFO ) RETURN END IF C C Set elements 1:ILO-1 of CSL, CSR, TAUL and TAUR to their default C values. C DO 10 I = 1, ILO - 1 CSL(2*I-1) = ONE CSL(2*I) = ZERO CSR(2*I-1) = ONE CSR(2*I) = ZERO TAUL(I) = ZERO TAUR(I) = ZERO 10 CONTINUE C C Quick return if possible. C NH = N - ILO + 1 IF ( NH.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Determine the block size. C NBMIN = 2 IF ( NB.GT.1 .AND. NB.LT.NH ) THEN C C Determine when to cross over from blocked to unblocked code. C NX = MAX( NB, UE01MD( 3, 'MB04TB', TRANA // TRANB, N, ILO, -1 ) $ ) IF ( NX.LT.NH ) THEN C C Check whether workspace is large enough for blocked code. C IF ( LDWORK.LT.WRKOPT ) THEN C C Not enough workspace available. Determine minimum value C of NB, and reduce NB. C NBMIN = MAX( 2, UE01MD( 2, 'MB04TB', TRANA // TRANB, N, $ ILO, -1 ) ) NB = LDWORK / ( 16*N + 5 ) END IF END IF END IF C NNB = N*NB PYB = 1 PYQ = PYB + 2*NNB PYA = PYQ + 2*NNB PYG = PYA + 2*NNB PXQ = PYG + 2*NNB PXA = PXQ + 2*NNB PXG = PXA + 2*NNB PXB = PXG + 2*NNB PDW = PXB + 2*NNB C IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN C C Use unblocked code. C I = ILO C ELSE IF ( LTRA .AND. LTRB ) THEN DO 20 I = ILO, N-NX-1, NB IB = MIN( NB, N-I ) NIB = N*IB C C Reduce rows and columns i:i+nb-1 to symplectic URV form and C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which C are needed to update the unreduced parts of the matrices. C CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA, $ B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), $ TAUR(I), DWORK(PDW) ) C C Update the submatrix A(i+1+ib:n,1:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, $ IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ, $ ONE, A(I+IB+1,I+IB), LDA ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB, $ N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N, $ A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA ) CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, $ ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE, $ A(I+IB+1,1), LDA ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N, IB, $ ONE, B(I+IB+1,I), LDB, DWORK(PYA+NIB), N, ONE, $ A(I+IB+1,1), LDA ) C C Update the submatrix Q(i+ib:n,i+1+ib:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, $ ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N, $ ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, $ B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) C C Update the matrix G. C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, $ G(I+IB,1), LDG ) CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, $ ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE, $ G(I+IB,1), LDG ) CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, $ G(1,I+IB+1), LDG ) CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, $ ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE, $ G(1,I+IB+1), LDG ) C C Update the submatrix B(1:n,i+ib:n). C CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, $ IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ, $ ONE, B(1,I+IB), LDB ) CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB+1, IB, $ ONE, DWORK(PXB+NIB), N, A(I,I+IB), LDA, ONE, $ B(1,I+IB), LDB ) CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1, $ IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N, $ ONE, B(I+IB+1,I+IB), LDB ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, $ IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N, $ ONE, B(I+IB+1,I+IB), LDB ) 20 CONTINUE C ELSE IF ( LTRA ) THEN DO 30 I = ILO, N-NX-1, NB IB = MIN( NB, N-I ) NIB = N*IB C C Reduce rows and columns i:i+nb-1 to symplectic URV form and C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which C are needed to update the unreduced parts of the matrices. C CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA, $ B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), $ TAUR(I), DWORK(PDW) ) C C Update the submatrix A(i+1+ib:n,1:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, $ IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ, $ ONE, A(I+IB+1,I+IB), LDA ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB, $ N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N, $ A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA ) CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, $ ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE, $ A(I+IB+1,1), LDA ) CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, $ ONE, B(I,I+IB+1), LDB, DWORK(PYA+NIB), N, ONE, $ A(I+IB+1,1), LDA ) C C Update the submatrix Q(i+ib:n,i+1+ib:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, $ ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N, $ ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, $ B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) C C Update the matrix G. C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, $ G(I+IB,1), LDG ) CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, $ ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE, $ G(I+IB,1), LDG ) CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, $ G(1,I+IB+1), LDG ) CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, $ ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE, $ G(1,I+IB+1), LDG ) C C Update the submatrix B(i+ib:n,1:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N, $ ONE, B(I+IB,1), LDB ) CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, $ ONE, A(I,I+IB), LDA, DWORK(PXB+NIB), N, ONE, $ B(I+IB,1), LDB ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1), $ LDQ, ONE, B(I+IB,I+IB+1), LDB ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N, $ B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB ) 30 CONTINUE C ELSE IF ( LTRB ) THEN DO 40 I = ILO, N-NX-1, NB IB = MIN( NB, N-I ) NIB = N*IB C C Reduce rows and columns i:i+nb-1 to symplectic URV form and C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which C are needed to update the unreduced parts of the matrices. C CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA, $ B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), $ TAUR(I), DWORK(PDW) ) C C Update the submatrix A(1:n,i+1+ib:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N, $ ONE, A(I+IB,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N, $ ONE, A(I+IB,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, $ ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE, $ A(1,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, $ ONE, DWORK(PYA+NIB), N, B(I+IB+1,I), LDB, ONE, $ A(1,I+IB+1), LDA ) C C Update the submatrix Q(i+ib:n,i+1+ib:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, $ ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N, $ ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'No Transpose', 'Transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, $ B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) C C Update the matrix G. C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, $ G(I+IB,1), LDG ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, $ ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE, $ G(I+IB,1), LDG ) CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, $ G(1,I+IB+1), LDG ) CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, $ ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE, $ G(1,I+IB+1), LDG ) C C Update the submatrix B(1:n,i+ib:n). C CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, $ IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ, $ ONE, B(1,I+IB), LDB ) CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, IB, $ ONE, DWORK(PXB+NIB), N, A(I+IB,I), LDA, ONE, $ B(1,I+IB), LDB ) CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1, $ IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N, $ ONE, B(I+IB+1,I+IB), LDB ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, $ IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N, $ ONE, B(I+IB+1,I+IB), LDB ) 40 CONTINUE C ELSE DO 50 I = ILO, N-NX-1, NB IB = MIN( NB, N-I ) NIB = N*IB C C Reduce rows and columns i:i+nb-1 to symplectic URV form and C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which C are needed to update the unreduced parts of the matrices. C CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA, $ B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), $ TAUR(I), DWORK(PDW) ) C C Update the submatrix A(1:n,i+1+ib:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N, $ ONE, A(I+IB,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N, $ ONE, A(I+IB,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, $ ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE, $ A(1,I+IB+1), LDA ) CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, $ ONE, DWORK(PYA+NIB), N, B(I,I+IB+1), LDB, ONE, $ A(1,I+IB+1), LDA ) C C Update the submatrix Q(i+ib:n,i+1+ib:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, $ ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, $ IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N, $ ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, $ B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) C C Update the matrix G. C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, $ G(I+IB,1), LDG ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, $ ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE, $ G(I+IB,1), LDG ) CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, $ G(1,I+IB+1), LDG ) CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, $ ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE, $ G(1,I+IB+1), LDG ) C C Update the submatrix B(i+ib:n,1:n). C CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N, $ ONE, B(I+IB,1), LDB ) CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, $ ONE, A(I+IB,I), LDA, DWORK(PXB+NIB), N, ONE, $ B(I+IB,1), LDB ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1), $ LDQ, ONE, B(I+IB,I+IB+1), LDB ) CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, $ N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N, $ B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB ) 50 CONTINUE END IF C C Unblocked code to reduce the rest of the matrices. C CALL MB04TS( TRANA, TRANB, N, I, A, LDA, B, LDB, G, LDG, Q, LDQ, $ CSL, CSR, TAUL, TAUR, DWORK, LDWORK, IERR ) C DWORK(1) = DBLE( WRKOPT ) C RETURN C *** Last line of MB04TB *** END control-4.1.2/src/slicot/src/PaxHeaders/AB13MD.f0000644000000000000000000000013215012430707016144 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB13MD.f0000644000175000017500000016363315012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE AB13MD( FACT, N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D, $ G, IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO ) C C PURPOSE C C To compute an upper bound on the structured singular value for a C given square complex matrix and a given block structure of the C uncertainty. C C ARGUMENTS C C Mode Parameters C C FACT CHARACTER*1 C Specifies whether or not an information from the C previous call is supplied in the vector X. C = 'F': On entry, X contains information from the C previous call. C = 'N': On entry, X does not contain an information from C the previous call. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix Z. N >= 0. C C Z (input) COMPLEX*16 array, dimension (LDZ,N) C The leading N-by-N part of this array must contain the C complex matrix Z for which the upper bound on the C structured singular value is to be computed. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= max(1,N). C C M (input) INTEGER C The number of diagonal blocks in the block structure of C the uncertainty. M >= 1. C C NBLOCK (input) INTEGER array, dimension (M) C The vector of length M containing the block structure C of the uncertainty. NBLOCK(I), I = 1:M, is the size of C each block. C C ITYPE (input) INTEGER array, dimension (M) C The vector of length M indicating the type of each block. C For I = 1:M, C ITYPE(I) = 1 indicates that the corresponding block is a C real block, and C ITYPE(I) = 2 indicates that the corresponding block is a C complex block. C NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1. C C X (input/output) DOUBLE PRECISION array, dimension C ( M + MR - 1 ), where MR is the number of the real blocks. C On entry, if FACT = 'F' and NBLOCK(1) < N, this array C must contain information from the previous call to AB13MD. C If NBLOCK(1) = N, this array is not used. C On exit, if NBLOCK(1) < N, this array contains information C that can be used in the next call to AB13MD for a matrix C close to Z. C C BOUND (output) DOUBLE PRECISION C The upper bound on the structured singular value. C C D, G (output) DOUBLE PRECISION arrays, dimension (N) C The vectors of length N containing the diagonal entries C of the diagonal N-by-N matrices D and G, respectively, C such that the matrix C Z'*D^2*Z + sqrt(-1)*(G*Z-Z'*G) - BOUND^2*D^2 C is negative semidefinite. C C Workspace C C IWORK INTEGER array, dimension (MAX(4*M-2,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 >= 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11. C For best performance C LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 6*N + 33*M - 11 + C MAX( 5*N,2*N*NB ) C where NB is the optimal blocksize returned by ILAENV. C C ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) contains the optimal value C of LZWORK. C C LZWORK INTEGER C The dimension of the array ZWORK. C LZWORK >= 6*N*N*M + 12*N*N + 6*M + 6*N - 3. C For best performance C LZWORK >= 6*N*N*M + 12*N*N + 6*M + 3*N - 3 + C MAX( 3*N,N*NB ) C where NB is the optimal blocksize returned by ILAENV. 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 block sizes must be positive integers; C = 2: the sum of block sizes must be equal to N; C = 3: the size of a real block must be equal to 1; C = 4: the block type must be either 1 or 2; C = 5: errors in solving linear equations or in matrix C inversion; C = 6: errors in computing eigenvalues or singular values. C C METHOD C C The routine computes the upper bound proposed in [1]. C C REFERENCES C C [1] Fan, M.K.H., Tits, A.L., and Doyle, J.C. C Robustness in the presence of mixed parametric uncertainty C and unmodeled dynamics. C IEEE Trans. Automatic Control, vol. AC-36, 1991, pp. 25-38. C C NUMERICAL ASPECTS C C The accuracy and speed of computation depend on the value of C the internal threshold TOL. C C CONTRIBUTORS C C P.Hr. Petkov, F. Delebecque, D.W. Gu, M.M. Konstantinov and C S. Steer with the assistance of V. Sima, September 2000. C C REVISIONS C C V. Sima, Katholieke Universiteit Leuven, February 2001. C V. Sima, May 2022. C C KEYWORDS C C H-infinity optimal control, Robust control, Structured singular C value. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 CZERO, CONE, CIMAG PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ), $ CIMAG = ( 0.0D+0, 1.0D+0 ) ) DOUBLE PRECISION ZERO, ONE, TWO, FOUR, FIVE, EIGHT, TEN, FORTY, $ FIFTY PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, $ FOUR = 4.0D+0, FIVE = 5.0D+0, EIGHT = 8.0D+0, $ TEN = 1.0D+1, FORTY = 4.0D+1, FIFTY = 5.0D+1 $ ) DOUBLE PRECISION ALPHA, BETA, THETA PARAMETER ( ALPHA = 100.0D+0, BETA = 1.0D-2, $ THETA = 1.0D-2 ) DOUBLE PRECISION C1, C2, C3, C4, C5, C6, C7, C8, C9 PARAMETER ( C1 = 1.0D-3, C2 = 1.0D-2, C3 = 0.25D+0, $ C4 = 0.9D+0, C5 = 1.5D+0, C6 = 1.0D+1, $ C7 = 1.0D+2, C8 = 1.0D+3, C9 = 1.0D+4 ) C .. C .. Scalar Arguments .. CHARACTER FACT INTEGER INFO, LDWORK, LDZ, LZWORK, M, N DOUBLE PRECISION BOUND C .. C .. Array Arguments .. INTEGER ITYPE( * ), IWORK( * ), NBLOCK( * ) COMPLEX*16 Z( LDZ, * ), ZWORK( * ) DOUBLE PRECISION D( * ), DWORK( * ), G( * ), X( * ) C .. C .. Local Scalars .. INTEGER I, INFO2, ISUM, ITER, IW2, IW3, IW4, IW5, IW6, $ IW7, IW8, IW9, IW10, IW11, IW12, IW13, IW14, $ IW15, IW16, IW17, IW18, IW19, IW20, IW21, IW22, $ IW23, IW24, IW25, IW26, IW27, IW28, IW29, IW30, $ IW31, IW32, IW33, IWRK, IZ2, IZ3, IZ4, IZ5, $ IZ6, IZ7, IZ8, IZ9, IZ10, IZ11, IZ12, IZ13, $ IZ14, IZ15, IZ16, IZ17, IZ18, IZ19, IZ20, IZ21, $ IZ22, IZ23, IZ24, IZWRK, J, K, L, LWA, LWAMAX, $ LZA, LZAMAX, MINWRK, MINZRK, MR, MT, NSUM, SDIM COMPLEX*16 DETF, TEMPIJ, TEMPJI DOUBLE PRECISION C, COLSUM, DELTA, DLAMBD, E, EMAX, EMIN, EPS, $ HN, HNORM, HNORM1, PHI, PP, PROD, RAT, RCOND, $ REGPAR, ROWSUM, SCALE, SNORM, STSIZE, SVLAM, $ T1, T2, T3, TAU, TEMP, TOL, TOL2, TOL3, TOL4, $ TOL5, YNORM1, YNORM2, ZNORM, ZNORM2 LOGICAL GTEST, POS, XFACT C .. C .. Local Arrays .. LOGICAL BWORK( 1 ) C .. C .. External Functions DOUBLE PRECISION DDOT, DLAMCH, DLANGE, ZLANGE LOGICAL LSAME, SELECT EXTERNAL DDOT, DLAMCH, DLANGE, LSAME, SELECT, ZLANGE C .. C .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DLACPY, DLASET, DSCAL, DSYCON, $ DSYSV, DSYTRF, DSYTRS, XERBLA, ZCOPY, ZGEES, $ ZGEMM, ZGEMV, ZGESVD, ZGETRF, ZGETRI, ZLACPY, $ ZLASCL C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, DREAL, INT, $ LOG, MAX, SQRT C .. C .. Executable Statements .. C C Compute workspace. C MINWRK = 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11 MINZRK = 6*N*N*M + 12*N*N + 6*M + 6*N - 3 C C Decode and Test input parameters. C INFO = 0 XFACT = LSAME( FACT, 'F' ) IF( .NOT.XFACT .AND. .NOT.LSAME( FACT, 'N' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( M.LT.1 ) THEN INFO = -5 ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -14 ELSE IF( LZWORK.LT.MINZRK ) THEN INFO = -16 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'AB13MD', -INFO ) RETURN END IF C NSUM = 0 ISUM = 0 MR = 0 DO 10 I = 1, M IF( NBLOCK( I ).LT.1 ) THEN INFO = 1 RETURN END IF IF( ITYPE( I ).EQ.1 .AND. NBLOCK( I ).GT.1 ) THEN INFO = 3 RETURN END IF NSUM = NSUM + NBLOCK( I ) IF( ITYPE( I ).EQ.1 ) MR = MR + 1 IF( ITYPE( I ).EQ.1 .OR. ITYPE( I ).EQ.2 ) ISUM = ISUM + 1 10 CONTINUE IF( NSUM.NE.N ) THEN INFO = 2 RETURN END IF IF( ISUM.NE.M ) THEN INFO = 4 RETURN END IF MT = M + MR - 1 C LWAMAX = 0 LZAMAX = 0 C C Set D = In, G = 0. C CALL DLASET( 'Full', N, 1, ONE, ONE, D, N ) CALL DLASET( 'Full', N, 1, ZERO, ZERO, G, N ) C C Quick return if possible. C ZNORM = ZLANGE( 'F', N, N, Z, LDZ, DWORK ) IF( ZNORM.EQ.ZERO ) THEN BOUND = ZERO DWORK( 1 ) = ONE ZWORK( 1 ) = CONE RETURN END IF C C Copy Z into ZWORK. C CALL ZLACPY( 'Full', N, N, Z, LDZ, ZWORK, N ) C C Exact bound for the case NBLOCK( 1 ) = N. C IF( NBLOCK( 1 ).EQ.N ) THEN IF( ITYPE( 1 ).EQ.1 ) THEN C C 1-by-1 real block. C IF( DIMAG( Z( 1, 1 ) ).NE.ZERO ) THEN BOUND = ZERO ELSE BOUND = ABS( DBLE( Z( 1, 1 ) ) ) END IF DWORK( 1 ) = ONE ZWORK( 1 ) = CONE ELSE C C N-by-N complex block. C CALL ZGESVD( 'N', 'N', N, N, ZWORK, N, DWORK, ZWORK, 1, $ ZWORK, 1, ZWORK( N*N+1 ), LZWORK, $ DWORK( N+1 ), INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF BOUND = DWORK( 1 ) LZA = N*N + INT( ZWORK( N*N+1 ) ) DWORK( 1 ) = 5*N ZWORK( 1 ) = DCMPLX( LZA ) END IF RETURN END IF C C Get machine precision. C EPS = DLAMCH( 'P' ) C C Set tolerances. C TOL = C7*SQRT( EPS ) TOL2 = C9*EPS TOL3 = C6*EPS TOL4 = C1 TOL5 = C1 REGPAR = C8*EPS C C Real workspace usage. C IW2 = M*M IW3 = IW2 + M IW4 = IW3 + N IW5 = IW4 + M IW6 = IW5 + M IW7 = IW6 + N IW8 = IW7 + N IW9 = IW8 + N*( M - 1 ) IW10 = IW9 + N*N*MT IW11 = IW10 + MT IW12 = IW11 + MT*MT IW13 = IW12 + N IW14 = IW13 + MT + 1 IW15 = IW14 + MT + 1 IW16 = IW15 + MT + 1 IW17 = IW16 + MT + 1 IW18 = IW17 + MT + 1 IW19 = IW18 + MT IW20 = IW19 + MT IW21 = IW20 + MT IW22 = IW21 + N IW23 = IW22 + M - 1 IW24 = IW23 + MR IW25 = IW24 + N IW26 = IW25 + 2*MT IW27 = IW26 + MT IW28 = IW27 + MT IW29 = IW28 + M - 1 IW30 = IW29 + MR IW31 = IW30 + N + 2*MT IW32 = IW31 + MT*MT IW33 = IW32 + MT IWRK = IW33 + MT + 1 C C Double complex workspace usage. C IZ2 = N*N IZ3 = IZ2 + N*N IZ4 = IZ3 + N*N IZ5 = IZ4 + N*N IZ6 = IZ5 + N*N IZ7 = IZ6 + N*N*MT IZ8 = IZ7 + N*N IZ9 = IZ8 + N*N IZ10 = IZ9 + N*N IZ11 = IZ10 + MT IZ12 = IZ11 + N*N IZ13 = IZ12 + N IZ14 = IZ13 + N*N IZ15 = IZ14 + N IZ16 = IZ15 + N*N IZ17 = IZ16 + N IZ18 = IZ17 + N*N IZ19 = IZ18 + N*N*MT IZ20 = IZ19 + MT IZ21 = IZ20 + N*N*MT IZ22 = IZ21 + N*N IZ23 = IZ22 + N*N IZ24 = IZ23 + N*N IZWRK = IZ24 + MT C C Compute the cumulative sums of blocks dimensions. C IWORK( 1 ) = 0 DO 20 I = 2, M+1 IWORK( I ) = IWORK( I - 1 ) + NBLOCK( I - 1 ) 20 CONTINUE C C Find Osborne scaling if initial scaling is not given. C IF( .NOT.XFACT ) THEN CALL DLASET( 'Full', M, M, ZERO, ZERO, DWORK, M ) CALL DLASET( 'Full', M, 1, ONE, ONE, DWORK( IW2+1 ), M ) ZNORM = ZLANGE( 'F', N, N, ZWORK, N, DWORK ) DO 40 J = 1, M DO 30 I = 1, M IF( I.NE.J ) THEN CALL ZLACPY( 'Full', IWORK( I+1 )-IWORK( I ), $ IWORK( J+1 )-IWORK( J ), $ Z( IWORK( I )+1, IWORK( J )+1 ), LDZ, $ ZWORK( IZ2+1 ), N ) CALL ZGESVD( 'N', 'N', IWORK( I+1 )-IWORK( I ), $ IWORK( J+1 )-IWORK( J ), ZWORK( IZ2+1 ), $ N, DWORK( IW3+1 ), ZWORK, 1, ZWORK, 1, $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, $ DWORK( IWRK+1 ), INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) ZNORM2 = DWORK( IW3+1 ) DWORK( I+(J-1)*M ) = ZNORM2 + ZNORM*TOL2 END IF 30 CONTINUE 40 CONTINUE CALL DLASET( 'Full', M, 1, ZERO, ZERO, DWORK( IW4+1 ), M ) 50 DO 60 I = 1, M DWORK( IW5+I ) = DWORK( IW4+I ) - ONE 60 CONTINUE HNORM = DLANGE( 'F', M, 1, DWORK( IW5+1 ), M, DWORK ) IF( HNORM.LE.TOL2 ) GO TO 120 DO 110 K = 1, M COLSUM = ZERO DO 70 I = 1, M COLSUM = COLSUM + DWORK( I+(K-1)*M ) 70 CONTINUE ROWSUM = ZERO DO 80 J = 1, M ROWSUM = ROWSUM + DWORK( K+(J-1)*M ) 80 CONTINUE RAT = SQRT( COLSUM / ROWSUM ) DWORK( IW4+K ) = RAT DO 90 I = 1, M DWORK( I+(K-1)*M ) = DWORK( I+(K-1)*M ) / RAT 90 CONTINUE DO 100 J = 1, M DWORK( K+(J-1)*M ) = DWORK( K+(J-1)*M )*RAT 100 CONTINUE DWORK( IW2+K ) = DWORK( IW2+K )*RAT 110 CONTINUE GO TO 50 120 SCALE = ONE / DWORK( IW2+1 ) CALL DSCAL( M, SCALE, DWORK( IW2+1 ), 1 ) ELSE DWORK( IW2+1 ) = ONE DO 130 I = 2, M DWORK( IW2+I ) = SQRT( X( I-1 ) ) 130 CONTINUE END IF DO 150 J = 1, M DO 140 I = 1, M IF( I.NE.J ) THEN CALL ZLASCL( 'G', M, M, DWORK( IW2+J ), DWORK( IW2+I ), $ IWORK( I+1 )-IWORK( I ), $ IWORK( J+1 )-IWORK( J ), $ ZWORK( IWORK( I )+1+IWORK( J )*N ), N, $ INFO2 ) END IF 140 CONTINUE 150 CONTINUE C C Scale Z by its 2-norm. C CALL ZLACPY( 'Full', N, N, ZWORK, N, ZWORK( IZ2+1 ), N ) CALL ZGESVD( 'N', 'N', N, N, ZWORK( IZ2+1 ), N, DWORK( IW3+1 ), $ ZWORK, 1, ZWORK, 1, ZWORK( IZWRK+1 ), LZWORK-IZWRK, $ DWORK( IWRK+1 ), INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) ZNORM = DWORK( IW3+1 ) CALL ZLASCL( 'G', M, M, ZNORM, ONE, N, N, ZWORK, N, INFO2 ) C C Set BB. C CALL DLASET( 'Full', N*N, MT, ZERO, ZERO, DWORK( IW9+1 ), N*N ) C C Set P. C DO 160 I = 1, NBLOCK( 1 ) DWORK( IW6+I ) = ONE 160 CONTINUE DO 170 I = NBLOCK( 1 )+1, N DWORK( IW6+I ) = ZERO 170 CONTINUE C C Compute P*Z. C DO 190 J = 1, N DO 180 I = 1, N ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* $ ZWORK( I+(J-1)*N ) 180 CONTINUE 190 CONTINUE C C Compute Z'*P*Z. C CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), N, $ CZERO, ZWORK( IZ4+1 ), N ) C C Copy Z'*P*Z into A0. C CALL ZLACPY( 'Full', N, N, ZWORK( IZ4+1 ), N, ZWORK( IZ5+1 ), N ) C C Copy diag(P) into B0d. C CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW7+1 ), 1 ) C DO 270 K = 2, M C C Set P. C DO 200 I = 1, IWORK( K ) DWORK( IW6+I ) = ZERO 200 CONTINUE DO 210 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) DWORK( IW6+I ) = ONE 210 CONTINUE IF( K.LT.M ) THEN DO 220 I = IWORK( K+1 )+1, N DWORK( IW6+I ) = ZERO 220 CONTINUE END IF C C Compute P*Z. C DO 240 J = 1, N DO 230 I = 1, N ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* $ ZWORK( I+(J-1)*N ) 230 CONTINUE 240 CONTINUE C C Compute t = Z'*P*Z. C CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), $ N, CZERO, ZWORK( IZ4+1 ), N ) C C Copy t(:) into the (k-1)-th column of AA. C CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, ZWORK( IZ6+1+(K-2)*N*N ), $ 1 ) C C Copy diag(P) into the (k-1)-th column of BBd. C CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW8+1+(K-2)*N ), 1 ) C C Copy P(:) into the (k-1)-th column of BB. C DO 260 I = 1, N DWORK( IW9+I+(I-1)*N+(K-2)*N*N ) = DWORK( IW6+I ) 260 CONTINUE 270 CONTINUE C L = 0 C DO 350 K = 1, M IF( ITYPE( K ).EQ.1 ) THEN L = L + 1 C C Set P. C DO 280 I = 1, IWORK( K ) DWORK( IW6+I ) = ZERO 280 CONTINUE DO 290 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) DWORK( IW6+I ) = ONE 290 CONTINUE IF( K.LT.M ) THEN DO 300 I = IWORK( K+1 )+1, N DWORK( IW6+I ) = ZERO 300 CONTINUE END IF C C Compute P*Z. C DO 320 J = 1, N DO 310 I = 1, N ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* $ ZWORK( I+(J-1)*N ) 310 CONTINUE 320 CONTINUE C C Compute t = sqrt(-1)*( P*Z - Z'*P ). C DO 340 J = 1, N DO 330 I = 1, J TEMPIJ = ZWORK( IZ3+I+(J-1)*N ) TEMPJI = ZWORK( IZ3+J+(I-1)*N ) ZWORK( IZ4+I+(J-1)*N ) = CIMAG*( TEMPIJ - $ DCONJG( TEMPJI ) ) ZWORK( IZ4+J+(I-1)*N ) = CIMAG*( TEMPJI - $ DCONJG( TEMPIJ ) ) 330 CONTINUE 340 CONTINUE C C Copy t(:) into the (m-1+l)-th column of AA. C CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, $ ZWORK( IZ6+1+(M-2+L)*N*N ), 1 ) END IF 350 CONTINUE C C Set initial X. C DO 360 I = 1, M - 1 X( I ) = ONE 360 CONTINUE IF( MR.GT.0 ) THEN IF( .NOT.XFACT ) THEN DO 370 I = 1, MR X( M-1+I ) = ZERO 370 CONTINUE ELSE L = 0 DO 380 K = 1, M IF( ITYPE( K ).EQ.1 ) THEN L = L + 1 X( M-1+L ) = X( M-1+L ) / DWORK( IW2+K )**2 END IF 380 CONTINUE END IF END IF C C Set constants. C SVLAM = ONE / EPS C = ONE C C Set H. C CALL DLASET( 'Full', MT, MT, ZERO, ONE, DWORK( IW11+1 ), MT ) C ITER = -1 C C Main iteration loop. C 390 ITER = ITER + 1 C C Compute A(:) = A0 + AA*x. C DO 400 I = 1, MT ZWORK( IZ10+I ) = DCMPLX( X( I ) ) 400 CONTINUE CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) C C Compute diag( Binv ). C CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW12+1 ), 1 ) CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, $ DWORK( IW12+1 ), 1 ) DO 410 I = 1, N DWORK( IW12+I ) = ONE / DWORK( IW12+I ) 410 CONTINUE C C Compute Binv*A. C DO 430 J = 1, N DO 420 I = 1, N ZWORK( IZ11+I+(J-1)*N ) = DCMPLX( DWORK( IW12+I ) )* $ ZWORK( IZ7+I+(J-1)*N ) 420 CONTINUE 430 CONTINUE C C Compute eig( Binv*A ). C CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ11+1 ), N, SDIM, $ ZWORK( IZ12+1 ), ZWORK, N, ZWORK( IZWRK+1 ), $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) E = DREAL( ZWORK( IZ12+1 ) ) IF( N.GT.1 ) THEN DO 440 I = 2, N IF( DREAL( ZWORK( IZ12+I ) ).GT.E ) $ E = DREAL( ZWORK( IZ12+I ) ) 440 CONTINUE END IF C C Set tau. C IF( MR.GT.0 ) THEN SNORM = ABS( X( M ) ) IF( MR.GT.1 ) THEN DO 450 I = M+1, MT IF( ABS( X( I ) ).GT.SNORM ) SNORM = ABS( X( I ) ) 450 CONTINUE END IF IF( SNORM.GT.FORTY ) THEN TAU = C7 ELSE IF( SNORM.GT.EIGHT ) THEN TAU = FIFTY ELSE IF( SNORM.GT.FOUR ) THEN TAU = TEN ELSE IF( SNORM.GT.ONE ) THEN TAU = FIVE ELSE TAU = TWO END IF END IF IF( ITER.EQ.0 ) THEN DLAMBD = E + C1 ELSE DWORK( IW13+1 ) = E CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) DLAMBD = ( ONE - THETA )*DWORK( IW13+1 ) + $ THETA*DWORK( IW14+1 ) CALL DCOPY( MT, DWORK( IW13+2 ), 1, DWORK( IW18+1 ), 1 ) CALL DCOPY( MT, DWORK( IW14+2 ), 1, DWORK( IW19+1 ), 1 ) L = 0 460 DO 470 I = 1, MT X( I ) = ( ONE - THETA / TWO**L )*DWORK( IW18+I ) + $ ( THETA / TWO**L )*DWORK( IW19+I ) 470 CONTINUE C C Compute At(:) = A0 + AA*x. C DO 480 I = 1, MT ZWORK( IZ10+I ) = DCMPLX( X( I ) ) 480 CONTINUE CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ9+1 ), 1 ) CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ9+1 ), 1 ) C C Compute diag(Bt). C CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW21+1 ), 1 ) CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, $ DWORK( IW21+1 ), 1 ) C C Compute W. C DO 500 J = 1, N DO 490 I = 1, N IF( I.EQ.J ) THEN ZWORK( IZ13+I+(I-1)*N ) = DCMPLX( THETA*BETA* $ ( DWORK( IW14+1 ) - DWORK( IW13+1 ) ) /TWO - $ DLAMBD*DWORK( IW21+I ) ) + $ ZWORK( IZ9+I+(I-1)*N ) ELSE ZWORK( IZ13+I+(J-1)*N ) = ZWORK( IZ9+I+(J-1)*N ) END IF 490 CONTINUE 500 CONTINUE C C Compute eig( W ). C CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ13+1 ), N, SDIM, $ ZWORK( IZ14+1 ), ZWORK, N, ZWORK( IZWRK+1 ), $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) EMAX = DREAL( ZWORK( IZ14+1 ) ) IF( N.GT.1 ) THEN DO 510 I = 2, N IF( DREAL( ZWORK( IZ14+I ) ).GT.EMAX ) $ EMAX = DREAL( ZWORK( IZ14+I ) ) 510 CONTINUE END IF IF( EMAX.LE.ZERO ) THEN GO TO 515 ELSE L = L + 1 GO TO 460 END IF END IF C C Set y. C 515 DWORK( IW13+1 ) = DLAMBD CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) C IF( ( SVLAM - DLAMBD ).LT.TOL ) THEN BOUND = SQRT( MAX( E, ZERO ) )*ZNORM DO 520 I = 1, M - 1 X( I ) = X( I )*DWORK( IW2+I+1 )**2 520 CONTINUE C C Compute sqrt( x ). C DO 530 I = 1, M-1 DWORK( IW20+I ) = SQRT( X( I ) ) 530 CONTINUE C C Compute diag( D ). C CALL DCOPY( N, DWORK( IW7+1 ), 1, D, 1 ) CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, $ DWORK( IW20+1 ), 1, ONE, D, 1 ) C C Compute diag( G ). C J = 0 L = 0 DO 540 K = 1, M J = J + NBLOCK( K ) IF( ITYPE( K ).EQ.1 ) THEN L = L + 1 X( M-1+L ) = X( M-1+L )*DWORK( IW2+K )**2 G( J ) = X( M-1+L ) END IF 540 CONTINUE CALL DSCAL( N, ZNORM, G, 1 ) DWORK( 1 ) = DBLE( MINWRK - 5*N + LWAMAX ) ZWORK( 1 ) = DCMPLX( MINZRK - 3*N + LZAMAX ) RETURN END IF SVLAM = DLAMBD DO 800 K = 1, M C C Store xD. C CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) IF( MR.GT.0 ) THEN C C Store xG. C CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) END IF C C Compute A(:) = A0 + AA*x. C DO 550 I = 1, MT ZWORK( IZ10+I ) = DCMPLX( X( I ) ) 550 CONTINUE CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) C C Compute B = B0d + BBd*xD. C CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) C C Compute F. C DO 556 J = 1, N DO 555 I = 1, N IF( I.EQ.J ) THEN ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) ELSE ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) END IF 555 CONTINUE 556 CONTINUE CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, $ ZWORK( IZ17+1 ), N ) C C Compute det( F ). C CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) DETF = CONE DO 560 I = 1, N DETF = DETF*ZWORK( IZ16+I ) 560 CONTINUE C C Compute Finv. C CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 5 RETURN END IF CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), $ LDWORK-IWRK, INFO2 ) LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) C C Compute phi. C DO 570 I = 1, M-1 DWORK( IW25+I ) = DWORK( IW22+I ) - BETA DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) 570 CONTINUE IF( MR.GT.0 ) THEN DO 580 I = 1, MR DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) 580 CONTINUE END IF PROD = ONE DO 590 I = 1, 2*MT PROD = PROD*DWORK( IW25+I ) 590 CONTINUE TEMP = DREAL( DETF ) IF( TEMP.LT.EPS ) TEMP = EPS PHI = -LOG( TEMP ) - LOG( PROD ) C C Compute g. C DO 610 J = 1, MT DO 600 I = 1, N*N ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) 600 CONTINUE 610 CONTINUE CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) DO 620 I = 1, M-1 DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - $ ONE / ( ALPHA - DWORK( IW22+I ) ) 620 CONTINUE IF( MR.GT.0 ) THEN DO 630 I = 1, MR DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) $ -ONE / ( TAU - DWORK( IW23+I ) ) 630 CONTINUE END IF DO 640 I = 1, MT DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - $ DWORK( IW26+I ) 640 CONTINUE C C Compute h. C CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, $ DWORK( IW31+1 ), MT ) CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, $ DWORK( IW27+1 ), MT, DWORK( IWRK+1 ), $ LDWORK-IWRK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 5 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) LWAMAX = MAX( LWA, LWAMAX ) STSIZE = ONE C C Store hD. C CALL DCOPY( M-1, DWORK( IW27+1 ), 1, DWORK( IW28+1 ), 1 ) C C Determine stepsize. C L = 0 DO 650 I = 1, M-1 IF( DWORK( IW28+I ).GT.ZERO ) THEN L = L + 1 IF( L.EQ.1 ) THEN TEMP = ( DWORK( IW22+I ) - BETA ) / DWORK( IW28+I ) ELSE TEMP = MIN( TEMP, ( DWORK( IW22+I ) - BETA ) / $ DWORK( IW28+I ) ) END IF END IF 650 CONTINUE IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) L = 0 DO 660 I = 1, M-1 IF( DWORK( IW28+I ).LT.ZERO ) THEN L = L + 1 IF( L.EQ.1 ) THEN TEMP = ( ALPHA - DWORK( IW22+I ) ) / $ ( -DWORK( IW28+I ) ) ELSE TEMP = MIN( TEMP, ( ALPHA - DWORK( IW22+I ) ) / $ ( -DWORK( IW28+I ) ) ) END IF END IF 660 CONTINUE IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) IF( MR.GT.0 ) THEN C C Store hG. C CALL DCOPY( MR, DWORK( IW27+M ), 1, DWORK( IW29+1 ), 1 ) C C Determine stepsize. C L = 0 DO 670 I = 1, MR IF( DWORK( IW29+I ).GT.ZERO ) THEN L = L + 1 IF( L.EQ.1 ) THEN TEMP = ( DWORK( IW23+I ) + TAU ) / $ DWORK( IW29+I ) ELSE TEMP = MIN( TEMP, ( DWORK( IW23+I ) + TAU ) / $ DWORK( IW29+I ) ) END IF END IF 670 CONTINUE IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) L = 0 DO 680 I = 1, MR IF( DWORK( IW29+I ).LT.ZERO ) THEN L = L + 1 IF( L.EQ.1 ) THEN TEMP = ( TAU - DWORK( IW23+I ) ) / $ ( -DWORK( IW29+I ) ) ELSE TEMP = MIN( TEMP, ( TAU - DWORK( IW23+I ) ) / $ ( -DWORK( IW29+I ) ) ) END IF END IF 680 CONTINUE END IF IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) STSIZE = C4*STSIZE IF( STSIZE.GE.TOL4 ) THEN C C Compute x_new. C DO 700 I = 1, MT DWORK( IW20+I ) = X( I ) - STSIZE*DWORK( IW27+I ) 700 CONTINUE C C Store xD. C CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) IF( MR.GT.0 ) THEN C C Store xG. C CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), $ 1 ) END IF C C Compute A(:) = A0 + AA*x_new. C DO 710 I = 1, MT ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) 710 CONTINUE CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) C C Compute B = B0d + BBd*xD. C CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) C C Compute lambda*diag(B) - A. C DO 730 J = 1, N DO 720 I = 1, N IF( I.EQ.J ) THEN ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) ELSE ZWORK( IZ15+I+(J-1)*N ) = $ -ZWORK( IZ7+I+(J-1)*N ) END IF 720 CONTINUE 730 CONTINUE C C Compute eig( lambda*diag(B)-A ). C CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, $ SDIM, ZWORK( IZ16+1 ), ZWORK, N, $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, $ DWORK( IWRK+1 ), BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) EMIN = DREAL( ZWORK( IZ16+1 ) ) IF( N.GT.1 ) THEN DO 740 I = 2, N IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) $ EMIN = DREAL( ZWORK( IZ16+I ) ) 740 CONTINUE END IF DO 750 I = 1, N DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) 750 CONTINUE DO 760 I = 1, M-1 DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) 760 CONTINUE IF( MR.GT.0 ) THEN DO 770 I = 1, MR DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - $ DWORK( IW23+I ) 770 CONTINUE END IF PROD = ONE DO 780 I = 1, N+2*MT PROD = PROD*DWORK( IW30+I ) 780 CONTINUE IF( EMIN.LE.ZERO .OR. ( -LOG( PROD ) ).GE.PHI ) THEN STSIZE = STSIZE / TEN ELSE CALL DCOPY( MT, DWORK( IW20+1 ), 1, X, 1 ) END IF END IF IF( STSIZE.LT.TOL4 ) GO TO 810 800 CONTINUE C 810 CONTINUE C C Store xD. C CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) IF( MR.GT.0 ) THEN C C Store xG. C CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) END IF C C Compute A(:) = A0 + AA*x. C DO 820 I = 1, MT ZWORK( IZ10+I ) = DCMPLX( X( I ) ) 820 CONTINUE CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) C C Compute diag( B ) = B0d + BBd*xD. C CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) C C Compute F. C DO 840 J = 1, N DO 830 I = 1, N IF( I.EQ.J ) THEN ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) ELSE ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) END IF 830 CONTINUE 840 CONTINUE CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, $ ZWORK( IZ17+1 ), N ) C C Compute det( F ). C CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) DETF = CONE DO 850 I = 1, N DETF = DETF*ZWORK( IZ16+I ) 850 CONTINUE C C Compute Finv. C CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 5 RETURN END IF CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), $ LDWORK-IWRK, INFO2 ) LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) C C Compute the barrier function. C DO 860 I = 1, M-1 DWORK( IW25+I ) = DWORK( IW22+I ) - BETA DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) 860 CONTINUE IF( MR.GT.0 ) THEN DO 870 I = 1, MR DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) 870 CONTINUE END IF PROD = ONE DO 880 I = 1, 2*MT PROD = PROD*DWORK( IW25+I ) 880 CONTINUE TEMP = DREAL( DETF ) IF( TEMP.LT.EPS ) TEMP = EPS PHI = -LOG( TEMP ) - LOG( PROD ) C C Compute the gradient of the barrier function. C DO 900 J = 1, MT DO 890 I = 1, N*N ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) 890 CONTINUE 900 CONTINUE CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) DO 910 I = 1, M-1 DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - $ ONE / ( ALPHA - DWORK( IW22+I ) ) 910 CONTINUE IF( MR.GT.0 ) THEN DO 920 I = 1, MR DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) $ -ONE / ( TAU - DWORK( IW23+I ) ) 920 CONTINUE END IF DO 925 I = 1, MT DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - $ DWORK( IW26+I ) 925 CONTINUE C C Compute the Hessian of the barrier function. C CALL ZGEMM( 'N', 'N', N, N*MT, N, CONE, ZWORK( IZ17+1 ), N, $ ZWORK( IZ18+1 ), N, CZERO, ZWORK( IZ20+1 ), N ) CALL DLASET( 'Full', MT, MT, ZERO, ZERO, DWORK( IW11+1 ), $ MT ) DO 960 K = 1, MT CALL ZCOPY( N*N, ZWORK( IZ20+1+(K-1)*N*N ), 1, $ ZWORK( IZ22+1 ), 1 ) DO 940 J = 1, N DO 930 I = 1, N ZWORK( IZ23+I+(J-1)*N ) = $ DCONJG( ZWORK( IZ22+J+(I-1)*N ) ) 930 CONTINUE 940 CONTINUE CALL ZGEMV( 'C', N*N, K, CONE, ZWORK( IZ20+1 ), N*N, $ ZWORK( IZ23+1 ), 1, CZERO, ZWORK( IZ24+1 ), $ 1 ) DO 950 J = 1, K DWORK( IW11+K+(J-1)*MT ) = $ DREAL( DCONJG( ZWORK( IZ24+J ) ) ) 950 CONTINUE 960 CONTINUE DO 970 I = 1, M-1 DWORK( IW10+I ) = ONE / ( DWORK( IW22+I ) - BETA )**2 + $ ONE / ( ALPHA - DWORK( IW22+I ) )**2 970 CONTINUE IF( MR.GT.0 ) THEN DO 980 I = 1, MR DWORK( IW10+M-1+I ) = $ ONE / ( DWORK( IW23+I ) + TAU )**2 + $ ONE / ( TAU - DWORK( IW23+I ) )**2 980 CONTINUE END IF DO 990 I = 1, MT DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + $ DWORK( IW10+I ) 990 CONTINUE DO 1100 J = 1, MT DO 1000 I = 1, J IF( I.NE.J ) THEN T1 = DWORK( IW11+I+(J-1)*MT ) T2 = DWORK( IW11+J+(I-1)*MT ) DWORK( IW11+I+(J-1)*MT ) = T1 + T2 DWORK( IW11+J+(I-1)*MT ) = T1 + T2 END IF 1000 CONTINUE 1100 CONTINUE C C Compute norm( H ). C 1110 HNORM = DLANGE( 'F', MT, MT, DWORK( IW11+1 ), MT, DWORK ) C C Compute rcond( H ). C CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, $ DWORK( IW31+1 ), MT ) HNORM1 = DLANGE( '1', MT, MT, DWORK( IW31+1 ), MT, DWORK ) CALL DSYTRF( 'U', MT, DWORK( IW31+1 ), MT, IWORK, $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 5 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) LWAMAX = MAX( LWA, LWAMAX ) CALL DSYCON( 'U', MT, DWORK( IW31+1 ), MT, IWORK, HNORM1, $ RCOND, DWORK( IWRK+1 ), IWORK( MT+1 ), INFO2 ) IF( RCOND.LT.TOL3 ) THEN DO 1120 I = 1, MT DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + $ HNORM*REGPAR 1120 CONTINUE GO TO 1110 END IF C C Compute the tangent line to path of center. C CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) CALL DSYTRS( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, $ DWORK( IW27+1 ), MT, INFO2 ) C C Check if x-h satisfies the Goldstein test. C GTEST = .FALSE. DO 1130 I = 1, MT DWORK( IW20+I ) = X( I ) - DWORK( IW27+I ) 1130 CONTINUE C C Store xD. C CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) IF( MR.GT.0 ) THEN C C Store xG. C CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), 1 ) END IF C C Compute A(:) = A0 + AA*x_new. C DO 1140 I = 1, MT ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) 1140 CONTINUE CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) C C Compute diag( B ) = B0d + BBd*xD. C CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) C C Compute lambda*diag(B) - A. C DO 1160 J = 1, N DO 1150 I = 1, N IF( I.EQ.J ) THEN ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) ELSE ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) END IF 1150 CONTINUE 1160 CONTINUE C C Compute eig( lambda*diag(B)-A ). C CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) DO 1190 I = 1, N DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) 1190 CONTINUE DO 1200 I = 1, M-1 DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) 1200 CONTINUE IF( MR.GT.0 ) THEN DO 1210 I = 1, MR DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) 1210 CONTINUE END IF EMIN = DWORK( IW30+1 ) DO 1220 I = 1, N+2*MT IF( DWORK( IW30+I ).LT.EMIN ) EMIN = DWORK( IW30+I ) 1220 CONTINUE IF( EMIN.LE.ZERO ) THEN GTEST = .FALSE. ELSE PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) PROD = ONE DO 1230 I = 1, N+2*MT PROD = PROD*DWORK( IW30+I ) 1230 CONTINUE T1 = -LOG( PROD ) T2 = PHI - C2*PP T3 = PHI - C4*PP IF( T1.GE.T3 .AND. T1.LT.T2 ) GTEST = .TRUE. END IF C C Use x-h if Goldstein test is satisfied. Otherwise use C Nesterov-Nemirovsky's stepsize length. C PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) DELTA = SQRT( PP ) IF( GTEST .OR. DELTA.LE.C3 ) THEN DO 1240 I = 1, MT X( I ) = X( I ) - DWORK( IW27+I ) 1240 CONTINUE ELSE DO 1250 I = 1, MT X( I ) = X( I ) - DWORK( IW27+I ) / ( ONE + DELTA ) 1250 CONTINUE END IF C C Analytic center is found if delta is sufficiently small. C IF( DELTA.LT.TOL5 ) GO TO 1260 GO TO 810 C C Set yf. C 1260 DWORK( IW14+1 ) = DLAMBD CALL DCOPY( MT, X, 1, DWORK( IW14+2 ), 1 ) C C Set yw. C CALL DCOPY( MT+1, DWORK( IW14+1 ), 1, DWORK( IW15+1 ), 1 ) C C Compute Fb. C DO 1280 J = 1, N DO 1270 I = 1, N ZWORK( IZ21+I+(J-1)*N ) = DCMPLX( DWORK( IW24+I ) )* $ DCONJG( ZWORK( IZ17+J+(I-1)*N ) ) 1270 CONTINUE 1280 CONTINUE CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ20+1 ), N*N, $ ZWORK( IZ21+1 ), 1, CZERO, ZWORK( IZ24+1 ), 1 ) DO 1300 I = 1, MT DWORK( IW32+I ) = DREAL( ZWORK( IZ24+I ) ) 1300 CONTINUE C C Compute h1. C CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, $ DWORK( IW31+1 ), MT ) CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, $ DWORK( IW32+1 ), MT, DWORK( IWRK+1 ), $ LDWORK-IWRK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 5 RETURN END IF LWA = INT( DWORK( IWRK+1 ) ) LWAMAX = MAX( LWA, LWAMAX ) C C Compute hn. C HN = DLANGE( 'F', MT, 1, DWORK( IW32+1 ), MT, DWORK ) C C Compute y. C DWORK( IW13+1 ) = DLAMBD - C / HN DO 1310 I = 1, MT DWORK( IW13+1+I ) = X( I ) + C*DWORK( IW32+I ) / HN 1310 CONTINUE C C Store xD. C CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) IF( MR.GT.0 ) THEN C C Store xG. C CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, DWORK( IW23+1 ), 1 ) END IF C C Compute A(:) = A0 + AA*y(2:mt+1). C DO 1320 I = 1, MT ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) 1320 CONTINUE CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) C C Compute B = B0d + BBd*xD. C CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) C C Compute y(1)*diag(B) - A. C DO 1340 J = 1, N DO 1330 I = 1, N IF( I.EQ.J ) THEN ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) ELSE ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) END IF 1330 CONTINUE 1340 CONTINUE C C Compute eig( y(1)*diag(B)-A ). C CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) EMIN = DREAL( ZWORK( IZ16+1 ) ) IF( N.GT.1 ) THEN DO 1350 I = 2, N IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) $ EMIN = DREAL( ZWORK( IZ16+I ) ) 1350 CONTINUE END IF POS = .TRUE. DO 1360 I = 1, M-1 DWORK( IW25+I ) = DWORK( IW22+I ) - BETA DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) 1360 CONTINUE IF( MR.GT.0 ) THEN DO 1370 I = 1, MR DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) 1370 CONTINUE END IF TEMP = DWORK( IW25+1 ) DO 1380 I = 2, 2*MT IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) 1380 CONTINUE IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. 1390 IF( POS ) THEN C C Set y2 = y. C CALL DCOPY( MT+1, DWORK( IW13+1 ), 1, DWORK( IW17+1 ), 1 ) C C Compute y = y + 1.5*( y - yw ). C DO 1400 I = 1, MT+1 DWORK( IW13+I ) = DWORK( IW13+I ) + $ C5*( DWORK( IW13+I ) - DWORK( IW15+I ) ) 1400 CONTINUE C C Store xD. C CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) IF( MR.GT.0 ) THEN C C Store xG. C CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, $ DWORK( IW23+1 ), 1 ) END IF C C Compute A(:) = A0 + AA*y(2:mt+1). C DO 1420 I = 1, MT ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) 1420 CONTINUE CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) C C Compute diag( B ) = B0d + BBd*xD. C CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) C C Set yw = y2. C CALL DCOPY( MT+1, DWORK( IW17+1 ), 1, DWORK( IW15+1 ), 1 ) C C Compute y(1)*diag(B) - A. C DO 1440 J = 1, N DO 1430 I = 1, N IF( I.EQ.J ) THEN ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) ELSE ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) END IF 1430 CONTINUE 1440 CONTINUE C C Compute eig( y(1)*diag(B)-A ). C CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) EMIN = DREAL( ZWORK( IZ16+1 ) ) IF( N.GT.1 ) THEN DO 1450 I = 2, N IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) $ EMIN = DREAL( ZWORK( IZ16+I ) ) 1450 CONTINUE END IF POS = .TRUE. DO 1460 I = 1, M-1 DWORK( IW25+I ) = DWORK( IW22+I ) - BETA DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) 1460 CONTINUE IF( MR.GT.0 ) THEN DO 1470 I = 1, MR DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) 1470 CONTINUE END IF TEMP = DWORK( IW25+1 ) DO 1480 I = 2, 2*MT IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) 1480 CONTINUE IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. GO TO 1390 END IF 1490 CONTINUE C C Set y1 = ( y + yw ) / 2. C DO 1500 I = 1, MT+1 DWORK( IW16+I ) = ( DWORK( IW13+I ) + DWORK( IW15+I ) ) $ / TWO 1500 CONTINUE C C Store xD. C CALL DCOPY( M-1, DWORK( IW16+2 ), 1, DWORK( IW22+1 ), 1 ) IF( MR.GT.0 ) THEN C C Store xG. C CALL DCOPY( MR, DWORK( IW16+M+1 ), 1, DWORK( IW23+1 ), 1 ) END IF C C Compute A(:) = A0 + AA*y1(2:mt+1). C DO 1510 I = 1, MT ZWORK( IZ10+I ) = DCMPLX( DWORK( IW16+1+I ) ) 1510 CONTINUE CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) C C Compute diag( B ) = B0d + BBd*xD. C CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) C C Compute y1(1)*diag(B) - A. C DO 1530 J = 1, N DO 1520 I = 1, N IF( I.EQ.J ) THEN ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW16+1 )* $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) ELSE ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) END IF 1520 CONTINUE 1530 CONTINUE C C Compute eig( y1(1)*diag(B)-A ). C CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 6 RETURN END IF LZA = INT( ZWORK( IZWRK+1 ) ) LZAMAX = MAX( LZA, LZAMAX ) EMIN = DREAL( ZWORK( IZ16+1 ) ) IF( N.GT.1 ) THEN DO 1540 I = 2, N IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) $ EMIN = DREAL( ZWORK( IZ16+I ) ) 1540 CONTINUE END IF POS = .TRUE. DO 1550 I = 1, M-1 DWORK( IW25+I ) = DWORK( IW22+I ) - BETA DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) 1550 CONTINUE IF( MR.GT.0 ) THEN DO 1560 I = 1, MR DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) 1560 CONTINUE END IF TEMP = DWORK( IW25+1 ) DO 1570 I = 2, 2*MT IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) 1570 CONTINUE IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. IF( POS ) THEN C C Set yw = y1. C CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW15+1 ), 1 ) ELSE C C Set y = y1. C CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW13+1 ), 1 ) END IF DO 1580 I = 1, MT+1 DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW15+I ) 1580 CONTINUE YNORM1 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) DO 1590 I = 1, MT+1 DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW14+I ) 1590 CONTINUE YNORM2 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) IF( YNORM1.LT.YNORM2*THETA ) GO TO 1600 GO TO 1490 C C Compute c. C 1600 DO 1610 I = 1, MT+1 DWORK( IW33+I ) = DWORK( IW15+I ) - DWORK( IW14+I ) 1610 CONTINUE C = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) C C Set x = yw(2:mt+1). C CALL DCOPY( MT, DWORK( IW15+2 ), 1, X, 1 ) GO TO 390 C C *** Last line of AB13MD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01BD.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01BD.f0000644000175000017500000003650315012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE TG01BD( JOBE, COMPQ, COMPZ, N, M, P, ILO, IHI, A, LDA, $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To reduce the matrices A and E of the system pencil C C S = ( A B ) - lambda ( E 0 ) , C ( C 0 ) ( 0 0 ) C C corresponding to the descriptor triple (A-lambda E,B,C), C to generalized upper Hessenberg form using orthogonal C transformations, C C Q' * A * Z = H, Q' * E * Z = T, C C where H is upper Hessenberg, T is upper triangular, Q and Z C are orthogonal, and ' means transpose. The corresponding C transformations, written compactly as diag(Q',I) * S * diag(Z,I), C are also applied to B and C, getting Q' * B and C * Z. C C The orthogonal matrices Q and Z are determined as products of C Givens rotations. They may either be formed explicitly, or they C may be postmultiplied into input matrices Q1 and Z1, so that C C Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' C Q1 * E * Z1' = (Q1*Q) * T * (Z1*Z)'. C C ARGUMENTS C C Mode Parameters C C JOBE CHARACTER*1 C Specifies whether E is a general square or an upper C triangular matrix, as follows: C = 'G': E is a general square matrix; C = 'U': E is an upper triangular matrix. C C COMPQ CHARACTER*1 C Indicates what should be done with matrix Q, as follows: C = 'N': do not compute Q; C = 'I': Q is initialized to the unit matrix, and the C orthogonal matrix Q is returned; C = 'V': Q must contain an orthogonal matrix Q1 on entry, C and the product Q1*Q is returned. C C COMPZ CHARACTER*1 C Indicates what should be done with matrix Z, as follows: C = 'N': do not compute Z; C = 'I': Z is initialized to the unit matrix, and the C orthogonal matrix Z is returned; C = 'V': Z must contain an orthogonal matrix Z1 on entry, C and the product Z1*Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, E, and the number of rows of C the matrix B. N >= 0. C C M (input) INTEGER C The number of columns of the matrix B. M >= 0. C C P (input) INTEGER C The number of rows of the matrix C. P >= 0. C C ILO (input) INTEGER C IHI (input) INTEGER C It is assumed that A and E are already upper triangular in C rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI could C normally be set by a previous call to LAPACK Library C routine DGGBAL; otherwise they should be set to 1 and N, C respectively. C 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. C If JOBE = 'U', the matrix E is assumed upper triangular. 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 upper Hessenberg matrix H = Q' * A * Z. The elements C below the first subdiagonal are set to zero. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the descriptor matrix E. If JOBE = 'U', this C matrix is assumed upper triangular. C On exit, the leading N-by-N part of this array contains C the upper triangular matrix T = Q' * E * Z. The elements C below the diagonal are set to zero. C C LDE INTEGER C The leading dimension of array E. LDE >= 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 B. C On exit, if M > 0, the leading N-by-M part of this array C contains the transformed matrix Q' * B. C The array B is not referenced if M = 0. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,N) if M > 0; LDB >= 1 if M = 0. 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 C. C On exit, if P > 0, the leading P-by-N part of this array C contains the transformed matrix C * Z. C The array C is not referenced if P = 0. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C If COMPQ = 'N': Q is not referenced; C If COMPQ = 'I': on entry, Q need not be set, and on exit C it contains the orthogonal matrix Q, C where Q' is the product of the Givens C transformations which are applied to A, C E, and B on the left; C If COMPQ = 'V': on entry, Q must contain an orthogonal C matrix Q1, and on exit this is C overwritten by Q1*Q. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1,N), if COMPQ = 'I' or 'V'. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C If COMPZ = 'N': Z is not referenced; C If COMPZ = 'I': on entry, Z need not be set, and on exit C it contains the orthogonal matrix Z, C which is the product of the Givens C transformations applied to A, E, and C C on the right; C If COMPZ = 'V': on entry, Z must contain an orthogonal C matrix Z1, and on exit this is C overwritten by Z1*Z. C C LDZ INTEGER C The leading dimension of array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= MAX(1,N), if COMPZ = 'I' or 'V'. C C Workspace 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 >= 1, if JOBE = 'U'; C LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)), if JOBE = 'G', where C NI = N+1-ILO, if COMPQ = 'N', and NI = N, otherwise. C For good performance, if JOBE = 'G', LDWORK must generally C be larger, LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)*NB), where C NB is the optimal block size. 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 First, this routine computes the QR factorization of E and applies C the transformations to A, B, and possibly Q. Then, the routine C reduces A to upper Hessenberg form, preserving E triangular, by C an unblocked reduction [1], using two sequences of plane rotations C applied alternately from the left and from the right. The C corresponding transformations may be accumulated and/or applied C to the matrices B and C. If JOBE = 'U', the initial reduction of E C to upper triangular form is skipped. C C This routine is a modification and extension of the LAPACK Library C routine DGGHRD [2]. C C REFERENCES C C [1] Golub, G.H. and van Loan, C.F. C Matrix Computations. Third Edition. C M. D. Johns Hopkins University Press, Baltimore, 1996. C C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C CONTRIBUTOR C C D. Sima, University of Bucharest, May 2001. C V. Sima, Research Institute for Informatics, Bucharest, May 2001. C C REVISIONS C C - C C KEYWORDS C C Eigenvalue, matrix algebra, matrix operations, similarity C transformation. C C ********************************************************************* C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOBE INTEGER IHI, ILO, INFO, LDA, LDB, LDC, LDE, LDQ, $ LDWORK, LDZ, M, N, P C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), $ Z( LDZ, * ) C .. Local Scalars .. LOGICAL ILQ, ILZ, INQ, INZ, UPPER, WITHB, WITHC INTEGER IERR, ITAU, IWRK, JCOL, JROW, MAXWRK, MINWRK DOUBLE PRECISION CS, S, TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEQRF, DLARTG, DLASET, DORMQR, DROT, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C C .. Executable Statements .. C C Test the input scalar parameters. C UPPER = LSAME( JOBE, 'U' ) INQ = LSAME( COMPQ, 'I' ) ILQ = LSAME( COMPQ, 'V' ) .OR. INQ INZ = LSAME( COMPZ, 'I' ) ILZ = LSAME( COMPZ, 'V' ) .OR. INZ WITHB = M.GT.0 WITHC = P.GT.0 C INFO = 0 IF( .NOT.( UPPER .OR. LSAME( JOBE, 'G' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( ILQ .OR. LSAME( COMPQ, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( ILZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( ILO.LT.1 ) THEN INFO = -7 ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN INFO = -8 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( ( WITHB .AND. LDB.LT.N ) .OR. LDB.LT.1 ) THEN INFO = -14 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -16 ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -18 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -20 ELSE JROW = IHI + 1 - ILO JCOL = N + 1 - ILO IF( UPPER ) THEN MINWRK = 1 MAXWRK = 1 ELSE IF( ILQ ) THEN MINWRK = N ELSE MINWRK = JCOL END IF MINWRK = MAX( 1, JROW + MAX( MINWRK, M ) ) END IF IF( LDWORK.LT.MINWRK ) $ INFO = -22 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01BD', -INFO ) RETURN END IF C C Initialize Q and Z if desired. C IF( INQ ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) IF( INZ ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) C C Quick return if possible. C IF( N.LE.1 ) THEN DWORK( 1 ) = ONE RETURN END IF C IF( .NOT.UPPER ) THEN C C Reduce E to triangular form (QR decomposition of E). 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 C Workspace: need IHI+1-ILO+N+1-ILO; C prefer IHI+1-ILO+(N+1-ILO)*NB. C ITAU = 1 IWRK = ITAU + JROW CALL DGEQRF( JROW, JCOL, E( ILO, ILO ), LDE, DWORK( ITAU ), $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MINWRK ) C C Apply the orthogonal transformation to matrices A, B, and Q. C Workspace: need IHI+1-ILO+N+1-ILO; C prefer IHI+1-ILO+(N+1-ILO)*NB. C CALL DORMQR( 'Left', 'Transpose', JROW, JCOL, JROW, $ E( ILO, ILO ), LDE, DWORK( ITAU ), A( ILO, ILO ), $ LDA, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) C IF ( WITHB ) THEN C C Workspace: need IHI+1-ILO+M; C prefer IHI+1-ILO+M*NB. C CALL DORMQR( 'Left', 'Transpose', JROW, M, JROW, $ E( ILO, ILO ), LDE, DWORK( ITAU ), B( ILO, 1 ), $ LDB, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) END IF C IF( ILQ ) THEN C C Workspace: need IHI+1-ILO+N; C prefer IHI+1-ILO+N*NB. C CALL DORMQR( 'Right', 'No Transpose', N, JROW, JROW, $ E( ILO, ILO ), LDE, DWORK( ITAU ), Q( 1, ILO ), $ LDQ, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) END IF END IF C C Zero out lower triangle of E. C IF( JROW.GT.1 ) $ CALL DLASET( 'Lower', JROW-1, JROW-1, ZERO, ZERO, $ E( ILO+1, ILO ), LDE ) C C Reduce A and E and apply the transformations to B, C, Q and Z. C DO 20 JCOL = ILO, IHI - 2 C DO 10 JROW = IHI, JCOL + 2, -1 C C Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL). C TEMP = A( JROW-1, JCOL ) CALL DLARTG( TEMP, A( JROW, JCOL ), CS, S, $ A( JROW-1, JCOL ) ) A( JROW, JCOL ) = ZERO CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, $ A( JROW, JCOL+1 ), LDA, CS, S ) CALL DROT( N+2-JROW, E( JROW-1, JROW-1 ), LDE, $ E( JROW, JROW-1 ), LDE, CS, S ) IF( WITHB ) $ CALL DROT( M, B( JROW-1, 1 ), LDB, B( JROW, 1 ), LDB, $ CS, S ) IF( ILQ ) $ CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, CS, S ) C C Step 2: rotate columns JROW, JROW-1 to kill E(JROW,JROW-1). C TEMP = E( JROW, JROW ) CALL DLARTG( TEMP, E( JROW, JROW-1 ), CS, S, $ E( JROW, JROW ) ) E( JROW, JROW-1 ) = ZERO CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, CS, S ) CALL DROT( JROW-1, E( 1, JROW ), 1, E( 1, JROW-1 ), 1, CS, $ S ) IF( WITHC ) $ CALL DROT( P, C( 1, JROW ), 1, C( 1, JROW-1 ), 1, CS, S ) IF( ILZ ) $ CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, CS, S ) 10 CONTINUE C 20 CONTINUE C DWORK( 1 ) = MAXWRK RETURN C *** Last line of TG01BD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04FD.f0000644000000000000000000000013215012430707016151 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04FD.f0000644000175000017500000011237315012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE MB04FD( JOB, COMPQ, N, A, LDA, DE, LDDE, B, LDB, FG, $ LDFG, Q, LDQ, ALPHAR, ALPHAI, BETA, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the eigenvalues of a real N-by-N skew-Hamiltonian/ C skew-Hamiltonian pencil aS - bT with C C ( A D ) ( B F ) C S = ( ) and T = ( ). (1) C ( E A' ) ( G B' ) C C Optionally, if JOB = 'T', the pencil aS - bT will be transformed C to the structured Schur form: an orthogonal transformation matrix C Q is computed such that C C ( Aout Dout ) C J Q' J' S Q = ( ), and C ( 0 Aout' ) C (2) C ( Bout Fout ) ( 0 I ) C J Q' J' T Q = ( ), where J = ( ), C ( 0 Bout' ) ( -I 0 ) C C Aout is upper triangular, and Bout is upper quasi-triangular. The C notation M' denotes the transpose of the matrix M. C Optionally, if COMPQ = 'I' or COMPQ = 'U', the orthogonal C transformation matrix Q will be computed. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; S and T will not C necessarily be put into skew-Hamiltonian C triangular form (2); C = 'T': put S and T into skew-Hamiltonian triangular form C (2), and return the eigenvalues in ALPHAR, ALPHAI C and BETA. C C COMPQ CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q as follows: C = 'N': Q is not computed; C = 'I': the array Q is initialized internally to the unit C matrix, and the orthogonal matrix Q is returned; C = 'U': the array Q contains an orthogonal matrix Q0 on C entry, and the product Q0*Q is returned, where Q C is the product of the orthogonal transformations C that are applied to the pencil aS - bT to reduce C S and T to the forms in (2), for COMPQ = 'I'. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bT. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix A. C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix Aout; otherwise, it contains C meaningless elements, except for the diagonal blocks, C which are correctly set. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C DE (input/output) DOUBLE PRECISION array, dimension C (LDDE, N/2+1) C On entry, the leading N/2-by-N/2 strictly lower triangular C part of this array must contain the strictly lower C triangular part of the skew-symmetric matrix E, and the C N/2-by-N/2 strictly upper triangular part of the submatrix C in the columns 2 to N/2+1 of this array must contain the C strictly upper triangular part of the skew-symmetric C matrix D. C The entries on the diagonal and the first superdiagonal of C this array are not referenced, but are assumed to be zero. C On exit, if JOB = 'T', the leading N/2-by-N/2 strictly C upper triangular part of the submatrix in the columns C 2 to N/2+1 of this array contains the strictly upper C triangular part of the skew-symmetric matrix Dout. C If JOB = 'E', the leading N/2-by-N/2 strictly upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array contains the strictly upper triangular part C of the skew-symmetric matrix D just before the application C of the QZ algorithm. The remaining entries are C meaningless. C C LDDE INTEGER C The leading dimension of the array DE. C LDDE >= MAX(1, N/2). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix Bout; otherwise, it contains C meaningless elements, except for the diagonal 1-by-1 and C 2-by-2 blocks, which are correctly set. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C FG (input/output) DOUBLE PRECISION array, dimension C (LDFG, N/2+1) C On entry, the leading N/2-by-N/2 strictly lower triangular C part of this array must contain the strictly lower C triangular part of the skew-symmetric matrix G, and the C N/2-by-N/2 strictly upper triangular part of the submatrix C in the columns 2 to N/2+1 of this array must contain the C strictly upper triangular part of the skew-symmetric C matrix F. C The entries on the diagonal and the first superdiagonal of C this array are not referenced, but are assumed to be zero. C On exit, if JOB = 'T', the leading N/2-by-N/2 strictly C upper triangular part of the submatrix in the columns C 2 to N/2+1 of this array contains the strictly upper C triangular part of the skew-symmetric matrix Fout. C If JOB = 'E', the leading N/2-by-N/2 strictly upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array contains the strictly upper triangular part C of the skew-symmetric matrix F just before the application C of the QZ algorithm. The remaining entries are C meaningless. C C LDFG INTEGER C The leading dimension of the array FG. C LDFG >= MAX(1, N/2). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) C On entry, if COMPQ = 'U', then the leading N-by-N part of C this array must contain a given matrix Q0, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q0 and the transformation matrix Q C used to transform the matrices S and T. C On exit, if COMPQ = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q. C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bT. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bT. C If ALPHAI(j) is zero, then the j-th eigenvalue is real; if C positive, then the j-th and (j+1)-st eigenvalues are a C complex conjugate pair. C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta that define the eigenvalues of the pencil C aS - bT. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bT, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C Due to the skew-Hamiltonian/skew-Hamiltonian structure of C the pencil, every eigenvalue occurs twice and thus it has C only to be saved once in ALPHAR, ALPHAI and BETA. C C Workspace C C IWORK INTEGER array, dimension (N/2+1) C On exit, IWORK(1) contains the number of (pairs of) C possibly inaccurate eigenvalues, q <= N/2, and the C nonzero absolute values in IWORK(2), ..., IWORK(N/2+1) are C indices of the possibly inaccurate eigenvalues, as well as C of the corresponding 1-by-1 or 2-by-2 diagonal blocks in C the arrays A and B on exit. The 2-by-2 blocks correspond C to negative values in IWORK. One negative value is stored C for each such eigenvalue pair. Its modulus indicates the C starting index of a 2-by-2 block. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; C DWORK(2) and DWORK(3) contain the Frobenius norms of the C matrices S and T on entry. These norms are used in the C tests to decide that some eigenvalues are considered as C unreliable. C On exit, if INFO = -19, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= MAX(3,N/2), if JOB = 'E' and COMPQ = 'N'; C LDWORK >= MAX(3,N**2/4+N/2), if JOB = 'T' and COMPQ = 'N'; C LDWORK >= MAX(1,3*N**2/4), if COMPQ<> 'N'. C For good performance LDWORK should generally 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: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: QZ iteration failed in the LAPACK Library routine C DHGEQZ. (QZ iteration did not converge or computation C of the shifts failed.) C = 2: warning: the pencil is numerically singular. C C METHOD C C The algorithm uses Givens rotations and Householder reflections to C annihilate elements in S and T such that S is in skew-Hamiltonian C triangular form and T is in skew-Hamiltonian Hessenberg form: C C ( A1 D1 ) ( B1 F1 ) C S = ( ), T = ( ), C ( 0 A1' ) ( 0 B1' ) C C where A1 is upper triangular and B1 is upper Hessenberg. C Subsequently, the QZ algorithm is applied to the pencil aA1 - bB1 C to determine orthogonal matrices Q1 and Q2 such that C Q2' A1 Q1 is upper triangular and Q2' B1 Q1 is upper quasi- C triangular. C See also page 40 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C real floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, March 31, 2009. C V. Sima, Nov. 2009 (SLICOT version of the routine ZSHUTR). C C REVISIONS C C V. Sima, Dec. 2010, Jan. 2011, Aug. 2011, Aug. 2016, Sep. 2016, C Nov. 2016, Apr. 2020. C M. Voigt, Jan. 2012. C C KEYWORDS C C QZ algorithm, upper (quasi-)triangular matrix, C skew-Hamiltonian/skew-Hamiltonian pencil. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO, THREE, TEN PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, $ TWO = 2.0D+0, THREE = 3.0D+0, TEN = 1.0D+1 $ ) C C .. Scalar Arguments .. CHARACTER COMPQ, JOB INTEGER INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK, N C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), DE( LDDE, * ), $ DWORK( * ), FG( LDFG, * ), Q( LDQ, * ) INTEGER IWORK( * ) C C .. Local Scalars .. LOGICAL LCMPQ, LINIQ, LQUERY, LTRI, LUPDQ, PSNG, $ SING CHARACTER*16 CMPQ, CMPSC, CMPZ INTEGER IQ1, IQ2, IWRK, J, K, M, M1, MINDW, MJ1, MJ2, $ MJ3, MK2, MK3, MM, NBETA0, NINF, OPTDW, P DOUBLE PRECISION CO, MU, NRM, NRMS, NRMT, NU, SDET, SI, TMP1, $ TMP2, TOLS, TOLT, X1, X2, X3, X4 C C .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) C C .. External Functions .. LOGICAL LSAME INTEGER MA02OD DOUBLE PRECISION DDOT, DLAMCH, DLANGE, DLANTR, DLAPY2, MA02ID EXTERNAL DDOT, DLAMCH, DLANGE, DLANTR, DLAPY2, LSAME, $ MA02ID, MA02OD C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DHGEQZ, DLACPY, DLARF, $ DLARFG, DLARTG, DLAS2, DLASET, DLASSQ, DROT, $ MA02PD, MB01LD, MB01MD, MB01ND, XERBLA C C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, MOD, SIGN, SQRT C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 MM = M*M M1 = MAX( 1, M ) LTRI = LSAME( JOB, 'T' ) LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LCMPQ = LINIQ .OR. LUPDQ LQUERY = LDWORK.EQ.-1 C C Determine the mode of computations. C IQ1 = 1 IF( LCMPQ ) THEN CMPQ = 'Initialize' CMPZ = CMPQ IQ2 = IQ1 + MM IWRK = IQ2 + MM MINDW = MAX( 3, IWRK - 1 + MM ) ELSE IF( LTRI ) THEN CMPQ = 'Initialize' CMPZ = 'No Computation' IQ2 = 1 IWRK = IQ2 + MM MINDW = MAX( 3, IWRK - 1 + M ) ELSE CMPQ = 'No Computation' CMPZ = CMPQ IQ2 = 1 IWRK = 1 MINDW = MAX( 3, M ) END IF K = IWRK - 1 C IF( LTRI ) THEN CMPSC = 'Schur Form' ELSE CMPSC = 'Eigenvalues Only' END IF C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.M1 ) THEN INFO = -5 ELSE IF( LDDE.LT.M1 ) THEN INFO = -7 ELSE IF( LDB.LT.M1 ) THEN INFO = -9 ELSE IF( LDFG.LT.M1 ) THEN INFO = -11 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN INFO = -13 ELSE IF( LDWORK.LT.MINDW .AND. .NOT.LQUERY ) THEN DWORK( 1 ) = MINDW INFO = -19 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04FD', -INFO ) RETURN ELSE IF( N.GT.0 .AND. LQUERY ) THEN CALL DHGEQZ( CMPSC, CMPQ, CMPZ, M, 1, M, B, LDB, A, LDA, $ ALPHAR, ALPHAI, BETA, DWORK, M1, DWORK, M1, $ DWORK, -1, INFO ) C IF( LCMPQ ) THEN OPTDW = K + MAX( K, INT( DWORK( 1 ) ) ) ELSE IF( LTRI ) THEN OPTDW = K + MAX( K - M, INT( DWORK( 1 ) ) ) ELSE OPTDW = INT( DWORK( 1 ) ) END IF DWORK( 1 ) = MAX( OPTDW, MINDW ) RETURN ELSE IF( LQUERY ) THEN DWORK( 1 ) = MINDW RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IWORK( 1 ) = 0 DWORK( 1 ) = THREE DWORK( 2 ) = ZERO DWORK( 3 ) = ZERO RETURN END IF C C Find half of the number of infinite eigenvalues if S is diagonal. C Otherwise, find a lower bound of this number. C NINF = 0 IF( M.EQ.1 ) THEN NRM = ZERO ELSE NRM = DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, DE( 2, 1 ), $ LDDE, DWORK ) + $ DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, DE( 1, 2 ), $ LDDE, DWORK ) END IF IF( NRM.EQ.ZERO ) THEN IF( M.EQ.1 ) THEN NRMS = ABS( A( 1, 1 ) ) IF( NRMS.EQ.ZERO ) $ NINF = 1 ELSE IF( DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, A( 2, 1 ), $ LDA, DWORK ).EQ.ZERO .AND. $ DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, A( 1, 2 ), $ LDA, DWORK ).EQ.ZERO ) THEN TMP1 = ZERO TMP2 = ONE CALL DLASSQ( M, A, LDA+1, TMP1, TMP2 ) NRMS = TMP1*SQRT( TMP2 ) DO 10 J = 1, M IF( A( J, J ).EQ.ZERO ) $ NINF = NINF + 1 10 CONTINUE ELSE CALL MA02PD( M, M, A, LDA, J, K ) NINF = MAX( J, K ) NRMS = DLANGE( 'Frobenius', M, M, A, LDA, DWORK ) END IF END IF NRMS = NRMS*SQRT( TWO ) ELSE C C Incrementing NINF below is due to even multiplicity of C eigenvalues for real skew-Hamiltonian matrices. C NINF = MA02OD( 'Skew', M, A, LDA, DE, LDDE ) IF( MOD( NINF, 2 ).GT.0 ) $ NINF = NINF + 1 NINF = NINF/2 NRMS = MA02ID( 'Skew', 'Frobenius', M, A, LDA, DE, LDDE, $ DWORK ) END IF C NRMT = MA02ID( 'Skew', 'Frobenius', M, B, LDB, FG, LDFG, DWORK ) C C STEP 1: Reduce S to skew-Hamiltonian triangular form. C C Workspace: need N, if COMPQ <> 'N'; C M, if COMPQ = 'N'. C IF( LINIQ ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) C DUM( 1 ) = ZERO C DO 20 K = 1, M - 1 C C Generate elementary reflector H(k) = I - nu * v * v' to C annihilate E(k+2:m,k). C MK2 = MIN( K+2, M ) MK3 = MK2 + 1 TMP1 = DE( K+1, K ) CALL DLARFG( M-K, TMP1, DE( MK2, K ), 1, NU ) IF( NU.NE.ZERO ) THEN DE( K+1, K ) = ONE C C Apply H(k) from both sides to E(k+1:m,k+1:m). C Compute x := nu * E(k+1:m,k+1:m) * v. C CALL MB01MD( 'Lower', M-K, NU, DE( K+1, K+1 ), LDDE, $ DE( K+1, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v in x. C MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 ) CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C E := E + v * w' - w * v'. C CALL MB01ND( 'Lower', M-K, ONE, DE( K+1, K ), 1, DWORK, 1, $ DE( K+1, K+1 ), LDDE ) C C Apply H(k) to G(k+1:m,1:k) from the left (and implicitly to C G(1:k,k+1:m) from the right). C CALL DLARF( 'Left', M-K, K, DE( K+1, K ), 1, NU, $ FG( K+1, 1 ), LDFG, DWORK ) C C Apply H(k) from both sides to G(k+1:m,k+1:m). C Compute x := nu * G(k+1:m,k+1:m) * v. C CALL MB01MD( 'Lower', M-K, NU, FG( K+1, K+1 ), LDFG, $ DE( K+1, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 ) CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C G := G + v * w' - w * v'. C CALL MB01ND( 'Lower', M-K, ONE, DE( K+1, K ), 1, DWORK, 1, $ FG( K+1, K+1 ), LDFG ) C C Apply H(k) from the right hand side to A(1:m,k+1:m) and C B(1:m,k+1:m). C CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU, $ A( 1, K+1 ), LDA, DWORK ) CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU, $ B( 1, K+1 ), LDB, DWORK ) C IF( LCMPQ ) THEN C C Apply H(k) from the right hand side to Q(1:n,k+1:m). C CALL DLARF( 'Right', N, M-K, DE( K+1, K ), 1, NU, $ Q( 1, K+1 ), LDQ, DWORK ) END IF DE( K+1, K ) = TMP1 END IF C C Determine a Givens rotation to annihilate E(k+1,k) from the C left. C TMP2 = A( K+1, K ) CALL DLARTG( TMP2, TMP1, CO, SI, A( K+1, K ) ) C C Update A, D and E. C CALL DROT( M-K-1, DE( MK2, K+1 ), 1, A( K+1, MK2 ), LDA, CO, $ SI ) CALL DROT( K, A( 1, K+1 ), 1, DE( 1, K+2 ), 1, CO, SI ) CALL DROT( M-K-1, DE( K+1, MK3 ), LDDE, A( MK2, K+1 ), 1, CO, $ SI ) C C Update B, G and F. C CALL DROT( K, FG( K+1, 1 ), LDFG, B( K+1, 1 ), LDB, CO, -SI ) CALL DROT( M-K-1, FG( MK2, K+1 ), 1, B( K+1, MK2 ), LDB, CO, $ SI ) CALL DROT( K, B( 1, K+1 ), 1, FG( 1, K+2 ), 1, CO, SI ) CALL DROT( M-K-1, FG( K+1, MK3 ), LDFG, B( MK2, K+1 ), 1, CO, $ SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, M+K+1 ), 1, Q( 1, K+1 ), 1, CO, -SI ) END IF C C Generate elementary reflector P(k) to annihilate A(k+1:m,k). C TMP1 = A( K, K ) CALL DLARFG( M-K+1, TMP1, A( K+1, K ), 1, NU ) IF( NU.NE.ZERO ) THEN A( K, K ) = ONE C C Apply P(k) from the left hand side to A(k:m,k+1:m). C CALL DLARF( 'Left', M-K+1, M-K, A( K, K ), 1, NU, $ A( K, K+1 ), LDA, DWORK ) C C Apply P(k) to D(1:k-1,k:m) from the right (and implicitly to C D(k:m,1:k-1) from the left). C CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU, $ DE( 1, K+1 ), LDDE, DWORK ) C C Apply P(k) from both sides to D(k:m,k:m). C Compute x := nu * D(k:m,k:m) * v. C CALL MB01MD( 'Upper', M-K+1, NU, DE( K, K+1 ), LDDE, $ A( K, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v in x. C MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 ) CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C D := D + v * w' - w * v'. C CALL MB01ND( 'Upper', M-K+1, ONE, A( K, K ), 1, DWORK, 1, $ DE( K, K+1 ), LDDE ) C C Apply P(k) from the left hand side to B(k:m,1:m). C CALL DLARF( 'Left', M-K+1, M, A( K, K ), 1, NU, B( K, 1 ), $ LDB, DWORK ) C C Apply P(k) to F(1:k-1,k:m) from the right (and implicitly to C F(k:m,1:k-1) from the left). C CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU, $ FG( 1, K+1 ), LDFG, DWORK ) C C Apply P(k) from both sides to F(k:m,k:m). C Compute x := nu * F(k:m,k:m) * v. C CALL MB01MD( 'Upper', M-K+1, NU, FG( K, K+1 ), LDFG, $ A( K, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 ) CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C F := F + v * w' - w * v'. C CALL MB01ND( 'Upper', M-K+1, ONE, A( K, K ), 1, DWORK, 1, $ FG( K, K+1 ), LDFG ) C IF( LCMPQ ) THEN C C Apply P(k) from the right hand side to Q(1:n,m+k:n). C CALL DLARF( 'Right', N, M-K+1, A( K, K ), 1, NU, $ Q( 1, M+K ), LDQ, DWORK ) END IF A( K, K ) = TMP1 END IF C C Set A(k+1:m,k) to zero in order to be able to apply DHGEQZ. C CALL DCOPY( M-K, DUM, 0, A( K+1, K ), 1 ) 20 CONTINUE C C STEP 2: Reduce T to skew-Hamiltonian triangular form. C DO 50 K = 1, M - 1 C C I. Annihilate G(k+1:m-1,k). C DO 30 J = K + 1, M - 1 MJ2 = MIN( J+2, M ) MJ3 = MJ2 + 1 C C Determine a Givens rotation to annihilate G(j,k) from the C left. C CALL DLARTG( FG( J+1, K ), FG( J, K ), CO, SI, TMP1 ) C C Update B and G. C CALL DROT( M, B( 1, J+1 ), 1, B( 1, J ), 1, CO, SI ) FG( J+1, K ) = TMP1 CALL DROT( M-J-1, FG( MJ2, J+1 ), 1, FG( MJ2, J ), 1, CO, SI $ ) CALL DROT( J-K-1, FG( J+1, K+1 ), LDFG, FG( J, K+1 ), LDFG, $ CO, SI ) C C Update A. C CALL DROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO, SI ) TMP1 = -SI*A( J+1, J+1 ) A( J+1, J+1 ) = CO*A( J+1, J+1 ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate A(j+1,j) from the C left. C CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 ) C C Update A and D. C A( J, J ) = TMP2 CALL DROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO, SI $ ) CALL DROT( J-1, DE( 1, J+1 ), 1, DE( 1, J+2 ), 1, CO, SI ) CALL DROT( M-J-1, DE( J, MJ3 ), LDDE, DE( J+1, MJ3 ), LDDE, $ CO, SI ) C C Update B and F. C CALL DROT( M-K+1, B( J, K ), LDB, B( J+1, K ), LDB, CO, SI ) CALL DROT( J-1, FG( 1, J+1 ), 1, FG( 1, J+2 ), 1, CO, SI ) CALL DROT( M-J-1, FG( J, MJ3 ), LDFG, FG( J+1, MJ3 ), LDFG, $ CO, SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, M+J ), 1, Q( 1, M+J+1 ), 1, CO, SI ) END IF 30 CONTINUE C C II. Annihilate G(m,k). C C Determine a Givens rotation to annihilate G(m,k) from the C left. C CALL DLARTG( B( M, K ), -FG( M, K ), CO, SI, TMP1 ) C C Update B and G. C B( M, K ) = TMP1 FG( M, K ) = ZERO CALL DROT( M-1, FG( 1, M+1 ), 1, B( 1, M ), 1, CO, SI ) CALL DROT( M-K-1, FG( M, K+1 ), LDFG, B( M, K+1 ), LDB, CO, SI $ ) C C Update A and D. C CALL DROT( M-1, DE( 1, M+1 ), 1, A( 1, M ), 1, CO, SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO, SI ) END IF C C III. Annihilate B(k+2:m,k). C DO 40 J = M, K + 2, -1 MJ1 = MIN( J+1, M ) MJ2 = MJ1 + 1 C C Determine a Givens rotation to annihilate B(j,k) from the C left. C CALL DLARTG( B( J-1, K ), B( J, K ), CO, SI, TMP1 ) C C Update B and F. C B( J-1, K ) = TMP1 B( J, K ) = ZERO CALL DROT( J-2, FG( 1, J ), 1, FG( 1, J+1 ), 1, CO, SI ) CALL DROT( M-K, B( J-1, K+1 ), LDB, B( J, K+1 ), LDB, CO, SI $ ) CALL DROT( M-J, FG( J-1, MJ2 ), LDFG, FG( J, MJ2 ), LDFG, $ CO, SI ) C C Update A and D. C TMP1 = -SI*A( J-1, J-1 ) A( J-1, J-1 ) = CO*A( J-1, J-1 ) CALL DROT( M-J+1, A( J-1, J ), LDA, A( J, J ), LDA, CO, SI ) CALL DROT( J-2, DE( 1, J ), 1, DE( 1, J+1 ), 1, CO, SI ) CALL DROT( M-J, DE( J-1, MJ2 ), LDDE, DE( J, MJ2 ), LDDE, $ CO, SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, M+J-1 ), 1, Q( 1, M+J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate A(j,j-1) from the C right. C CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 ) C C Update A. C A( J, J ) = TMP2 CALL DROT( J-1, A( 1, J ), 1, A( 1, J-1 ), 1, CO, SI ) C C Update B and G. C CALL DROT( M, B( 1, J ), 1, B( 1, J-1 ), 1, CO, SI ) CALL DROT( J-K-1, FG( J, K ), LDFG, FG( J-1, K ), LDFG, CO, $ SI ) CALL DROT( M-J, FG( MJ1, J ), 1, FG( MJ1, J-1 ), 1, CO, SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, J ), 1, Q( 1, J-1 ), 1, CO, SI ) END IF 40 CONTINUE 50 CONTINUE C C ( A1 D1 ) ( B1 F1 ) C Now we have S = ( ) and T = ( ), C ( 0 A1' ) ( 0 B1' ) C C where A1 is upper triangular and B1 is upper Hessenberg. C C STEP 3: Apply the QZ algorithm to the pencil aA1 - bB1 to C determine orthogonal matrices Q1 and Q2 such that C Q2' A1 Q1 is upper triangular and Q2' B1 Q1 is upper C quasi-triangular. C C Workspace: need w + M, where C w = 2*M**2, if COMPQ <> 'N'; C w = M**2, if COMPQ = 'N' and JOB = 'T'; C w = 0, if COMPQ = 'N' and JOB = 'E'; C prefer larger. C CALL DHGEQZ( CMPSC, CMPQ, CMPZ, M, 1, M, B, LDB, A, LDA, ALPHAR, $ ALPHAI, BETA, DWORK( IQ1 ), M, DWORK( IQ2 ), M, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Enforce the needed equalities in complex eigenvalues. C Count the number of found infinite eigenvalues, if necessary. C J = 1 NBETA0 = 0 C WHILE( J.LT.M ) DO 60 CONTINUE IF( J.LT.M ) THEN IF( ALPHAI( J ).NE.ZERO ) THEN IF( BETA( J ).GE.BETA( J + 1 ) ) THEN TMP2 = BETA( J + 1 )/BETA( J ) TMP1 = ( ALPHAR( J )*TMP2 + ALPHAR( J+1 ) )/TWO TMP2 = ( ALPHAI( J )*TMP2 - ALPHAI( J+1 ) )/TWO BETA( J ) = BETA( J+1 ) ELSE TMP2 = BETA( J )/BETA( J + 1 ) TMP1 = ( ALPHAR( J+1 )*TMP2 + ALPHAR( J ) )/TWO TMP2 = ( ALPHAI( J+1 )*TMP2 - ALPHAI( J ) )/TWO BETA( J+1 ) = BETA( J ) END IF ALPHAR( J ) = TMP1 ALPHAR( J+1 ) = TMP1 ALPHAI( J ) = TMP2 ALPHAI( J+1 ) = -TMP2 J = J + 2 ELSE IF( NINF.GT.0 ) THEN IF( BETA( J ).EQ.ZERO ) $ NBETA0 = NBETA0 + 1 END IF J = J + 1 END IF GO TO 60 ELSE IF( J.EQ.M .AND. NINF.GT.0 ) THEN IF( BETA( J ).EQ.ZERO ) $ NBETA0 = NBETA0 + 1 END IF C END WHILE 60 C C Set to infinity the largest eigenvalues, if necessary. C IF( NINF.GT.0 ) THEN DO 80 J = 1, NINF - NBETA0 TMP1 = ZERO TMP2 = ONE P = 1 DO 70 K = 1, M IF( BETA( K ).GT.ZERO ) THEN IF( ABS( ALPHAR( K ) )*TMP2.GT.TMP1*BETA( K ) )THEN TMP1 = ABS( ALPHAR( K ) ) TMP2 = BETA( K ) P = K END IF END IF 70 CONTINUE BETA( P ) = ZERO 80 CONTINUE END IF C IF( LTRI ) THEN C C Skew-symmetric update of D. C C Workspace: need w + M; C prefer w + M*(M-1). C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, DE( 1, 2 ), $ LDDE, DWORK( IQ1 ), M, DE( 1, 2 ), LDDE, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) C C Skew-symmetric update of F. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, FG( 1, 2 ), $ LDFG, DWORK( IQ1 ), M, FG( 1, 2 ), LDFG, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) END IF C IF( LCMPQ ) THEN C C Update Q. C Workspace: need 3*M*M; C prefer 4*M*M. C IF( LDWORK.GE.N*N ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q, LDQ, DWORK( IQ2 ), M, ZERO, DWORK( IWRK ), $ N ) CALL DLACPY( 'Full', N, M, DWORK( IWRK ), N, Q, LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q( 1, M+1 ), LDQ, DWORK( IQ1 ), M, ZERO, $ DWORK( IWRK ), N ) CALL DLACPY( 'Full', N, M, DWORK( IWRK ), N, Q( 1, M+1 ), $ LDQ ) ELSE CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q, LDQ, DWORK( IQ2 ), M, ZERO, DWORK( IWRK ), $ M ) CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q, LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q( M+1, 1 ), LDQ, DWORK( IQ2 ), M, ZERO, $ DWORK( IWRK ), M ) CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q( M+1, 1 ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q( 1, M+1 ), LDQ, DWORK( IQ1 ), M, ZERO, $ DWORK( IWRK ), M ) CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q( 1, M+1 ), $ LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q( M+1, M+1 ), LDQ, DWORK( IQ1 ), M, ZERO, $ DWORK( IWRK ), M ) CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, Q( M+1, M+1 ), $ LDQ ) END IF END IF C C Mark as unreliable the numerically infinite eigenvalues and C numerically zero eigenvalues. Store their indices. C The pencil is assumed regular. C TOLS = TEN*DLAMCH( 'Precision' )*NRMS TOLT = TEN*DLAMCH( 'Precision' )*NRMT P = 0 K = 1 C WHILE( K.LE.M ) DO 90 CONTINUE IF( K.LE.M ) THEN IF( BETA( K ).NE.ZERO ) THEN IF( ALPHAI( K ).EQ.ZERO ) THEN SING = ABS( B( K, K ) ).LT.TOLT IF( SING ) THEN P = P + 1 IWORK( P+1 ) = K END IF IF( ABS( A( K, K ) ).LT.TOLS ) THEN IF( SING ) THEN INFO = 2 ELSE P = P + 1 IWORK( P+1 ) = K END IF END IF ELSE X1 = B( K, K ) X2 = B( K+1, K ) X3 = B( K, K+1 ) X4 = B( K+1, K+1 ) NRM = DLANGE( 'Frobenius', 2, 2, B( K, K ), LDB, DWORK ) SDET = ( MAX( ABS( X1 ), ABS( X4 ) )/NRM ) $ *MIN( ABS( X1 ), ABS( X4 ) )* $ SIGN( ONE, X1 )*SIGN( ONE, X4 ) - $ ( MAX( ABS( X2 ), ABS( X3 ) )/NRM ) $ *MIN( ABS( X2 ), ABS( X3 ) )* $ SIGN( ONE, X2 )*SIGN( ONE, X3 ) IF( NRM.GT.ONE ) THEN PSNG = ABS( SDET ).LT.TOLT/NRM ELSE PSNG = ABS( SDET )*NRM.LT.TOLT END IF IF( PSNG ) THEN C C Make a more accurate singularity test using SVD. C IF ( ABS( X1 ).GE.ABS( X4 ) ) THEN CALL DLARTG( X1, X2, CO, SI, TMP1 ) X1 = TMP1 TMP1 = CO*X3 + SI*X4 X4 = CO*X4 - SI*X3 X3 = TMP1 ELSE CALL DLARTG( X4, X2, CO, SI, TMP1 ) X4 = TMP1 TMP1 = CO*X3 + SI*X1 X1 = CO*X1 - SI*X3 X3 = TMP1 END IF CALL DLAS2( X1, X3, X4, TMP1, TMP2 ) SING = TMP1.LT.TOLT IF ( SING ) THEN P = P + 1 IWORK( P+1 ) = -K INFO = 2 END IF END IF X1 = A( K, K ) X4 = A( K+1, K+1 ) NRM = DLAPY2( X1, X4 ) SDET = ( MAX( X1, X4 )/NRM )*MIN( X1, X4 ) IF ( ABS( SDET ).LT.TOLS ) THEN IF( SING ) THEN INFO = 2 ELSE P = P + 1 IWORK( P+1 ) = -K END IF END IF K = K + 1 END IF ELSE IWORK( K+1 ) = 0 END IF K = K + 1 GO TO 90 END IF C END WHILE 90 IWORK( 1 ) = P C DWORK( 1 ) = OPTDW DWORK( 2 ) = NRMS DWORK( 3 ) = NRMT C RETURN C *** Last line of MB04FD *** END control-4.1.2/src/slicot/src/PaxHeaders/TF01MY.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TF01MY.f0000644000175000017500000002701515012430707017416 0ustar00lilgelilge00000000000000 SUBROUTINE TF01MY( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD, $ U, LDU, X, Y, LDY, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the output sequence of a linear time-invariant C open-loop system given by its discrete-time state-space model C (A,B,C,D), where A is an N-by-N general matrix. C C The initial state vector x(1) must be supplied by the user. C C This routine differs from SLICOT Library routine TF01MD in the C way the input and output trajectories are stored. 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 number of system inputs. M >= 0. C C P (input) INTEGER C The number of system outputs. P >= 0. C C NY (input) INTEGER C The number of output vectors y(k) to be computed. C NY >= 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 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 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 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 link matrix D of the system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C U (input) DOUBLE PRECISION array, dimension (LDU,M) C The leading NY-by-M part of this array must contain the C input vector sequence u(k), for k = 1,2,...,NY. C Specifically, the k-th row of U must contain u(k)'. C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,NY). C C X (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the initial state vector C x(1) which consists of the N initial states of the system. C On exit, this array contains the final state vector C x(NY+1) of the N states of the system at instant NY+1. C C Y (output) DOUBLE PRECISION array, dimension (LDY,P) C The leading NY-by-P part of this array contains the output C vector sequence y(1),y(2),...,y(NY) such that the k-th C row of Y contains y(k)' (the outputs at instant k), C for k = 1,2,...,NY. C C LDY INTEGER C The leading dimension of array Y. LDY >= MAX(1,NY). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,N). C For better 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 Given an initial state vector x(1), the output vector sequence C y(1), y(2),..., y(NY) is obtained via the formulae C C x(k+1) = A x(k) + B u(k) C y(k) = C x(k) + D u(k), C C where each element y(k) is a vector of length P containing the C outputs at instant k and k = 1,2,...,NY. C C REFERENCES C C [1] Luenberger, D.G. C Introduction to Dynamic Systems: Theory, Models and C Applications. C John Wiley & Sons, New York, 1979. C C NUMERICAL ASPECTS C C The algorithm requires approximately (N + M) x (N + P) x NY C multiplications and additions. C C FURTHER COMMENTS C C The implementation exploits data locality and uses BLAS 3 C operations as much as possible, given the workspace length. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2011, C June 2012. C C KEYWORDS C C Discrete-time system, multivariable system, state-space model, C state-space representation, time response. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDWORK, LDY, M, $ N, NY, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) C .. Local Scalars .. LOGICAL LQUERY INTEGER IK, IREM, IS, IYL, MAXN, NS, WRKOPT DOUBLE PRECISION UPD C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DLASET, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C MAXN = MAX( 1, N ) 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( NY.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAXN ) THEN INFO = -6 ELSE IF( LDB.LT.MAXN ) 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( LDU.LT.MAX( 1, NY ) ) THEN INFO = -14 ELSE IF( LDY.LT.MAX( 1, NY ) ) THEN INFO = -17 ELSE LQUERY = LDWORK.EQ.-1 IF( LQUERY ) THEN C C Determine the optimal workspace (taken as for LAPACK routine C DGEQRF). C CALL DGEQRF( NY, MAX( M, P ), Y, LDY, DWORK, DWORK, -1, $ INFO ) WRKOPT = MAX( INT( DWORK(1) ), 1, 2*N ) ELSE IF( MIN( NY, P ).EQ.0 ) THEN IK = 1 ELSE IK = MAXN END IF IF( LDWORK.LT.IK ) $ INFO = -19 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TF01MY', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF ( MIN( NY, P ).EQ.0 ) THEN DWORK(1) = ONE RETURN ELSE IF ( N.EQ.0 ) THEN C C Non-dynamic system: compute the output vectors. C IF ( M.EQ.0 ) THEN CALL DLASET( 'Full', NY, P, ZERO, ZERO, Y, LDY ) ELSE CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, $ U, LDU, D, LDD, ZERO, Y, LDY ) END IF DWORK(1) = ONE RETURN END IF C C Find the number of state vectors that can be accommodated in C the provided workspace and initialize. C NS = MIN( LDWORK/N, WRKOPT/N, NY ) C IF ( NS.LE.1 .OR. NY*MAX( M, P ).LE.WRKOPT ) THEN C C LDWORK < 2*N or small problem: C only BLAS 2 calculations are used in the loop C for computing the output corresponding to D = 0. C One row of the array Y is computed for each loop index value. C DO 10 IK = 1, NY CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, X, 1, ZERO, $ Y(IK,1), LDY ) C CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, X, 1, ZERO, $ DWORK, 1 ) CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(IK,1), LDU, $ ONE, DWORK, 1 ) C CALL DCOPY( N, DWORK, 1, X, 1 ) 10 CONTINUE C ELSE C C LDWORK >= 2*N and large problem: C some BLAS 3 calculations can also be used. C IYL = ( NY/NS )*NS IF ( M.EQ.0 ) THEN UPD = ZERO ELSE UPD = ONE END IF C CALL DCOPY( N, X, 1, DWORK, 1 ) C DO 30 IK = 1, IYL, NS C C Compute the current NS-1 state vectors in the workspace. C CALL DGEMM( 'No transpose', 'Transpose', N, NS-1, M, ONE, $ B, LDB, U(IK,1), LDU, ZERO, DWORK(N+1), MAXN ) C DO 20 IS = 1, NS - 1 CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, $ DWORK((IS-1)*N+1), 1, UPD, DWORK(IS*N+1), 1 ) 20 CONTINUE C C Initialize the current NS output vectors. C CALL DGEMM( 'Transpose', 'Transpose', NS, P, N, ONE, DWORK, $ MAXN, C, LDC, ZERO, Y(IK,1), LDY ) C C Prepare the next iteration. C CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, $ U(IK+NS-1,1), LDU, ZERO, DWORK, 1 ) CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, $ DWORK((NS-1)*N+1), 1, UPD, DWORK, 1 ) 30 CONTINUE C IREM = NY - IYL C IF ( IREM.GT.1 ) THEN C C Compute the last IREM output vectors. C First, compute the current IREM-1 state vectors. C IK = IYL + 1 CALL DGEMM( 'No transpose', 'Transpose', N, IREM-1, M, ONE, $ B, LDB, U(IK,1), LDU, ZERO, DWORK(N+1), MAXN ) C DO 40 IS = 1, IREM - 1 CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, $ DWORK((IS-1)*N+1), 1, UPD, DWORK(IS*N+1), 1 ) 40 CONTINUE C C Initialize the last IREM output vectors. C CALL DGEMM( 'Transpose', 'Transpose', IREM, P, N, ONE, $ DWORK, MAXN, C, LDC, ZERO, Y(IK,1), LDY ) C C Prepare the final state vector. C CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, $ U(IK+IREM-1,1), LDU, ZERO, DWORK, 1 ) CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, $ DWORK((IREM-1)*N+1), 1, UPD, DWORK, 1 ) C ELSE IF ( IREM.EQ.1 ) THEN C C Compute the last 1 output vectors. C CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, DWORK, 1, $ ZERO, Y(IK,1), LDY ) C C Prepare the final state vector. C CALL DCOPY( N, DWORK, 1, DWORK(N+1), 1 ) CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, $ U(IK,1), LDU, ZERO, DWORK, 1 ) CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, $ DWORK(N+1), 1, UPD, DWORK, 1 ) END IF C C Set the final state vector. C CALL DCOPY( N, DWORK, 1, X, 1 ) C END IF C C Add the direct contribution of the input to the output vectors. C CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, U, LDU, $ D, LDD, ONE, Y, LDY ) C DWORK(1) = WRKOPT RETURN C *** Last line of TF01MY *** END control-4.1.2/src/slicot/src/PaxHeaders/delctg.f0000644000000000000000000000013215012430707016537 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/delctg.f0000644000175000017500000000030615012430707017732 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION DELCTG( PAR1, PAR2, PAR3 ) C C PURPOSE C C Void logical function for DGGES. C DOUBLE PRECISION PAR1, PAR2, PAR3 C DELCTG = .TRUE. RETURN END control-4.1.2/src/slicot/src/PaxHeaders/AB05OD.f0000644000000000000000000000013215012430707016147 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB05OD.f0000644000175000017500000003125115012430707017345 0ustar00lilgelilge00000000000000 SUBROUTINE AB05OD( OVER, N1, M1, P1, N2, M2, ALPHA, A1, LDA1, B1, $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, $ C2, LDC2, D2, LDD2, N, M, A, LDA, B, LDB, C, $ LDC, D, LDD, INFO ) C C PURPOSE C C To obtain the state-space model (A,B,C,D) for rowwise C concatenation (parallel inter-connection on outputs, with separate C inputs) of two systems, each given in state-space form. C C ARGUMENTS C C Mode Parameters C C OVER CHARACTER*1 C Indicates whether the user wishes to overlap pairs of C arrays, as follows: C = 'N': Do not overlap; C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, C C1 and C, and D1 and D, i.e. the same name is C effectively used for each pair (for all pairs) C in the routine call. In this case, setting C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD C will give maximum efficiency. C C Input/Output Parameters C C N1 (input) INTEGER C The number of state variables in the first system, i.e. C the order of the matrix A1. N1 >= 0. C C M1 (input) INTEGER C The number of input variables for the first system. C M1 >= 0. C C P1 (input) INTEGER C The number of output variables from each system. P1 >= 0. C C N2 (input) INTEGER C The number of state variables in the second system, i.e. C the order of the matrix A2. N2 >= 0. C C M2 (input) INTEGER C The number of input variables for the second system. C M2 >= 0. C C ALPHA (input) DOUBLE PRECISION C A coefficient multiplying the transfer-function matrix C (or the output equation) of the second system. C C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) C The leading N1-by-N1 part of this array must contain the C state transition matrix A1 for the first system. C C LDA1 INTEGER C The leading dimension of array A1. LDA1 >= MAX(1,N1). C C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) C The leading N1-by-M1 part of this array must contain the C input/state matrix B1 for the first system. C C LDB1 INTEGER C The leading dimension of array B1. LDB1 >= MAX(1,N1). C C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) C The leading P1-by-N1 part of this array must contain the C state/output matrix C1 for the first system. C C LDC1 INTEGER C The leading dimension of array C1. C LDC1 >= MAX(1,P1) if N1 > 0. C LDC1 >= 1 if N1 = 0. C C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) C The leading P1-by-M1 part of this array must contain the C input/output matrix D1 for the first system. C C LDD1 INTEGER C The leading dimension of array D1. LDD1 >= MAX(1,P1). C C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) C The leading N2-by-N2 part of this array must contain the C state transition matrix A2 for the second system. C C LDA2 INTEGER C The leading dimension of array A2. LDA2 >= MAX(1,N2). C C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M2) C The leading N2-by-M2 part of this array must contain the C input/state matrix B2 for the second system. C C LDB2 INTEGER C The leading dimension of array B2. LDB2 >= MAX(1,N2). C C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) C The leading P1-by-N2 part of this array must contain the C state/output matrix C2 for the second system. C C LDC2 INTEGER C The leading dimension of array C2. C LDC2 >= MAX(1,P1) if N2 > 0. C LDC2 >= 1 if N2 = 0. C C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M2) C The leading P1-by-M2 part of this array must contain the C input/output matrix D2 for the second system. C C LDD2 INTEGER C The leading dimension of array D2. LDD2 >= MAX(1,P1). C C N (output) INTEGER C The number of state variables (N1 + N2) in the connected C system, i.e. the order of the matrix A, the number of rows C of B and the number of columns of C. C C M (output) INTEGER C The number of input variables (M1 + M2) for the connected C system, i.e. the number of columns of B and D. C C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) C The leading N-by-N part of this array contains the state C transition matrix A for the connected system. C The array A can overlap A1 if OVER = 'O'. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N1+N2). C C B (output) DOUBLE PRECISION array, dimension (LDB,M1+M2) C The leading N-by-M part of this array contains the C input/state matrix B for the connected system. C The array B can overlap B1 if OVER = 'O'. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N1+N2). C C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) C The leading P1-by-N part of this array contains the C state/output matrix C for the connected system. C The array C can overlap C1 if OVER = 'O'. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,P1) if N1+N2 > 0. C LDC >= 1 if N1+N2 = 0. C C D (output) DOUBLE PRECISION array, dimension (LDD,M1+M2) C The leading P1-by-M part of this array contains the C input/output matrix D for the connected system. C The array D can overlap D1 if OVER = 'O'. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P1). 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 After rowwise concatenation (parallel inter-connection with C separate inputs) of the two systems, C C X1' = A1*X1 + B1*U C Y1 = C1*X1 + D1*U C C X2' = A2*X2 + B2*V C Y2 = C2*X2 + D2*V C C (where ' denotes differentiation with respect to time), C C with the output equation for the second system multiplied by a C scalar alpha, the following state-space model will be obtained: C C X' = A*X + B*(U) C (V) C C Y = C*X + D*(U) C (V) C C where matrix A has the form ( A1 0 ), C ( 0 A2 ) C C matrix B has the form ( B1 0 ), C ( 0 B2 ) C C matrix C has the form ( C1 alpha*C2 ) and C C matrix D has the form ( D1 alpha*D2 ). C C REFERENCES C C None C C NUMERICAL ASPECTS C C None C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1996. C Supersedes Release 2.0 routine AB05CD by C.J.Benson, Kingston C Polytechnic, United Kingdom, January 1982. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 2003, C Feb. 2004. C C KEYWORDS C C Continuous-time system, multivariable system, state-space model, C state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER OVER INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, $ LDC1, LDC2, LDD, LDD1, LDD2, M, M1, M2, N, N1, $ N2, P1 DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) C .. Local Scalars .. LOGICAL LOVER INTEGER I, J C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLACPY, DLASCL, DLASET, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C LOVER = LSAME( OVER, 'O' ) N = N1 + N2 M = M1 + M2 INFO = 0 C C Test the input scalar arguments. C IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN INFO = -1 ELSE IF( N1.LT.0 ) THEN INFO = -2 ELSE IF( M1.LT.0 ) THEN INFO = -3 ELSE IF( P1.LT.0 ) THEN INFO = -4 ELSE IF( N2.LT.0 ) THEN INFO = -5 ELSE IF( M2.LT.0 ) THEN INFO = -6 ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN INFO = -9 ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN INFO = -11 ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN INFO = -13 ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN INFO = -15 ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN INFO = -17 ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN INFO = -19 ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P1 ) ) .OR. $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN INFO = -21 ELSE IF( LDD2.LT.MAX( 1, P1 ) ) THEN INFO = -23 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -27 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -29 ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P1 ) ) .OR. $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN INFO = -31 ELSE IF( LDD.LT.MAX( 1, P1 ) ) THEN INFO = -33 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB05OD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, MIN( M, P1 ) ).EQ.0 ) $ RETURN C C First form the matrix A. C IF ( LOVER .AND. LDA1.LE.LDA ) THEN IF ( LDA1.LT.LDA ) THEN C DO 20 J = N1, 1, -1 DO 10 I = N1, 1, -1 A(I,J) = A1(I,J) 10 CONTINUE 20 CONTINUE C END IF ELSE CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) END IF C IF ( N2.GT.0 ) THEN CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1+1), LDA ) CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1+1,1), LDA ) END IF C C Now form the matrix B. C IF ( LOVER .AND. LDB1.LE.LDB ) THEN IF ( LDB1.LT.LDB ) THEN C DO 40 J = M1, 1, -1 DO 30 I = N1, 1, -1 B(I,J) = B1(I,J) 30 CONTINUE 40 CONTINUE C END IF ELSE CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) END IF C IF ( M2.GT.0 ) THEN IF ( N2.GT.0 ) $ CALL DLACPY( 'F', N2, M2, B2, LDB2, B(N1+1,M1+1), LDB ) CALL DLASET( 'F', N1, M2, ZERO, ZERO, B(1,M1+1), LDB ) END IF IF ( N2.GT.0 ) $ CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) C C Now form the matrix C. C IF ( LOVER .AND. LDC1.LE.LDC ) THEN IF ( LDC1.LT.LDC ) THEN C DO 60 J = N1, 1, -1 DO 50 I = P1, 1, -1 C(I,J) = C1(I,J) 50 CONTINUE 60 CONTINUE C END IF ELSE CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) END IF C IF ( N2.GT.0 ) THEN CALL DLACPY( 'F', P1, N2, C2, LDC2, C(1,N1+1), LDC ) IF ( ALPHA.NE.ONE ) $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P1, N2, C(1,N1+1), LDC, $ INFO ) END IF C C Now form the matrix D. C IF ( LOVER .AND. LDD1.LE.LDD ) THEN IF ( LDD1.LT.LDD ) THEN C DO 80 J = M1, 1, -1 DO 70 I = P1, 1, -1 D(I,J) = D1(I,J) 70 CONTINUE 80 CONTINUE C END IF ELSE CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) END IF C IF ( M2.GT.0 ) THEN CALL DLACPY( 'F', P1, M2, D2, LDD2, D(1,M1+1), LDD ) IF ( ALPHA.NE.ONE ) $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P1, M2, D(1,M1+1), LDD, $ INFO ) END IF C RETURN C *** Last line of AB05OD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03AD.f0000644000000000000000000000013215012430707016143 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03AD.f0000644000175000017500000001604515012430707017345 0ustar00lilgelilge00000000000000 SUBROUTINE MB03AD( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, C1, $ S1, C2, S2 ) C C PURPOSE C C To compute two Givens rotations (C1,S1) and (C2,S2) such that the C orthogonal matrix C C [ Q 0 ] [ C1 S1 0 ] [ 1 0 0 ] C Z = [ ], Q := [ -S1 C1 0 ] * [ 0 C2 S2 ], C [ 0 I ] [ 0 0 1 ] [ 0 -S2 C2 ] C C makes the first column of the real Wilkinson double shift C polynomial of the product of matrices in periodic upper Hessenberg C form, stored in the array A, parallel to the first unit vector. C Only the rotation defined by C1 and S1 is used for the real C Wilkinson single shift polynomial (see SLICOT Library routine C MB03BE). C C ARGUMENTS C C Mode Parameters C C SHFT CHARACTER*1 C Specifies the number of shifts employed by the shift C polynomial, as follows: C = 'D': two shifts (assumes N > 2); C = 'S': one real shift. C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of the factors in the array A. C N >= 2, for a single shift polynomial; C N >= 3, for a double shift polynomial. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C AMAP(1) is the pointer to the Hessenberg matrix. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input) DOUBLE PRECISION array, dimension (LDA1,LDA2,K) C The leading N-by-N-by-K part of this array must contain C the product (implicitly represented by its K factors) C in periodic upper Hessenberg form. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= N. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= N. C C C1 (output) DOUBLE PRECISION C S1 (output) DOUBLE PRECISION C On exit, C1 and S1 contain the parameters for the first C Givens rotation. C C C2 (output) DOUBLE PRECISION C S2 (output) DOUBLE PRECISION C On exit, if SHFT = 'D' and N > 2, C2 and S2 contain the C parameters for the second Givens rotation. Otherwise, C C2 = 1, S2 = 0. C C METHOD C C Two Givens rotations are properly computed and applied. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLASHF. C V. Sima, Apr. 2018, Oct. 2019, Dec. 2019. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER SHFT INTEGER K, LDA1, LDA2, N, SINV DOUBLE PRECISION C1, C2, S1, S2 C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*) C .. Local Scalars .. LOGICAL SGLE INTEGER AI, I DOUBLE PRECISION ALPHA, BETA, C3, DELTA, GAMMA, S3, TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARTG C .. Intrinsic Functions .. INTRINSIC SQRT C C .. Executable Statements .. C SGLE = LSAME( SHFT, 'S' ) C1 = ONE S1 = ZERO C2 = 1/SQRT( TWO ) S2 = C2 C DO 10 I = K, 2, -1 AI = AMAP(I) IF ( S(AI).EQ.SINV ) THEN ALPHA = C2 * A(1,1,AI) GAMMA = S2 * A(N,N,AI) BETA = S2 * A(N-1,N,AI) BETA = C1 * BETA + S1 * A(N-1,N-1,AI) CALL DLARTG( ALPHA, GAMMA, C2, S2, TEMP ) TEMP = C1 * TEMP CALL DLARTG( TEMP, BETA, C1, S1, ALPHA ) ELSE TEMP = A(1,1,AI) BETA = S2 * TEMP TEMP = C2 * TEMP ALPHA = S1 * TEMP GAMMA = A(N,N,AI) DELTA = C2 * GAMMA GAMMA = S2 * GAMMA CALL DLARTG( DELTA, BETA, C2, S2, C3 ) DELTA = C1 * A(N-1,N,AI) - S1 * GAMMA ALPHA = C2 * ALPHA - S2 * DELTA GAMMA = C1 * A(N-1,N-1,AI) CALL DLARTG( GAMMA, ALPHA, C1, S1, TEMP ) END IF 10 CONTINUE C AI = AMAP(1) ALPHA = A(1,1,AI) * C2 - A(N,N,AI) * S2 BETA = C1 * ( C2 * A(2,1,AI) ) GAMMA = C1 * ( S2 * A(N-1,N,AI) ) + S1 * A(N-1,N-1,AI) ALPHA = ALPHA * C1 - A(N,N-1,AI) * S1 CALL DLARTG( ALPHA, BETA, C1, S1, TEMP ) C C This is sufficient for a single real shift. C IF ( SGLE ) THEN C2 = ONE S2 = ZERO C ELSE C CALL DLARTG( TEMP, GAMMA, C2, S2, ALPHA ) C C Rotation 1 is preserved. C ALPHA = C2 GAMMA = ( A(N-1,N-1,AI) * C1 ) * C2 + A(N,N-1,AI) * S2 DELTA = ( A(N-1,N-1,AI) * S1 ) * C2 CALL DLARTG( GAMMA, DELTA, C3, S3, TEMP ) CALL DLARTG( ALPHA, TEMP, C2, S2, ALPHA ) C C Rotation 3 is preserved throughout the following complete loop. C DO 20 I = K, 2, -1 AI = AMAP(I) IF ( S(AI).EQ.SINV ) THEN ALPHA = ( A(1,1,AI) * C1 + A(1,2,AI) * S1 ) * C2 BETA = ( A(2,2,AI) * S1 ) * C2 GAMMA = A(N-1,N-1,AI) * S2 CALL DLARTG( ALPHA, BETA, C1, S1, TEMP ) CALL DLARTG( TEMP, GAMMA, C2, S2, ALPHA ) ELSE ALPHA = C1 * A(1,1,AI) GAMMA = S1 * A(1,1,AI) BETA = C1 * A(1,2,AI) + S1 * A(2,2,AI) DELTA = -S1 * A(1,2,AI) + C1 * A(2,2,AI) CALL DLARTG( DELTA, GAMMA, C1, S1, TEMP ) ALPHA = -ALPHA * S2 BETA = -BETA * S2 ALPHA = C1 * ALPHA + S1 * BETA BETA = C2 * A(N-1,N-1,AI) CALL DLARTG( BETA, ALPHA, C2, S2, TEMP ) S2 = -S2 END IF 20 CONTINUE C C Last step: Let the rotations collap into A. C AI = AMAP(1) ALPHA = C1 * A(1,1,AI) + S1 * A(1,2,AI) BETA = C1 * A(2,1,AI) + S1 * A(2,2,AI) GAMMA = S1 * A(3,2,AI) ALPHA = C2 * ALPHA - S2 * C3 BETA = C2 * BETA - S2 * S3 GAMMA = C2 * GAMMA CALL DLARTG( BETA, GAMMA, C2, S2, TEMP ) CALL DLARTG( ALPHA, TEMP, C1, S1, BETA ) END IF RETURN C *** Last line of MB03AD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB08NY.f0000644000000000000000000000013215012430707016176 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.953099663 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AB08NY.f0000644000175000017500000004700115012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE AB08NY( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, NINFZ, $ NR, PR, DINFZ, NKRONL, INFZ, KRONL, TOL, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To extract from the (N+P)-by-(M+N) system pencil C ( B A-lambda*I ) C ( D C ) C an (NR+PR)-by-(M+NR) "reduced" system pencil, C ( Br Ar-lambda*I ), C ( Dr Cr ) C having the same transmission zeros, but with Dr of full row rank. C C ARGUMENTS C C Mode Parameters C C FIRST LOGICAL C Specifies if AB08NY is called first time, or it is called C for an already reduced system, with D of full column rank, C with the last M rows in upper triangular form: C FIRST = .TRUE. : first time called; C FIRST = .FALSE. : not first time called. C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix B, the number of columns C of the matrix C, and the order of the square matrix A. C N >= 0. C C M (input) INTEGER C The number of columns of the matrices B and D. M >= 0. C M <= P, if FIRST = .FALSE. C C P (input) INTEGER C The number of rows of the matrices C and D. P >= 0. C C SVLMAX (input) DOUBLE PRECISION C An estimate of the largest singular value of the original C matrix ABCD (for instance, the Frobenius norm of ABCD). 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 matrix C ( B A ), C ( D C ) C where A is an N-by-N matrix, B is an N-by-M matrix, C C is a P-by-N matrix, and D is a P-by-M matrix. C If FIRST = .FALSE., then D must be a full column rank C matrix, with the last M rows in an upper triangular form. C On exit, the leading (NR+PR)-by-(M+NR) part of this array C contains the reduced compound matrix C ( Br Ar ), C ( Dr Cr ) C where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix, C Cr is a PR-by-NR matrix, and Dr is a PR-by-M full row rank C left upper-trapezoidal matrix, with the first PR columns C in an upper triangular form. C C LDABCD INTEGER C The leading dimension of the 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 If FIRST = .FALSE., then NINFZ is not modified. C On exit, the number of infinite zeros. C C NR (output) INTEGER C The order of the reduced matrix Ar; also, the number of C rows of the reduced matrix Br and the number of columns of C the reduced matrix Cr. C If Dr is invertible, NR is also the number of finite Smith C zeros. C C PR (output) INTEGER C The normal rank of the transfer-function matrix of the C original system; also, the number of rows of the reduced C matrices Cr and Dr. C C DINFZ (output) INTEGER C The maximal multiplicity of infinite zeros. C DINFZ = 0 if FIRST = .FALSE. . C C NKRONL (output) INTEGER C The maximal dimension of left elementary Kronecker blocks. C C INFZ (output) INTEGER array, dimension (N) C INFZ(i) contains the number of infinite zeros of degree i, C where i = 1,2,...,DINFZ. C INFZ is not referenced if FIRST = .FALSE. . C C KRONL (output) INTEGER array, dimension (N+1) C KRONL(i) contains the number of left elementary Kronecker C blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL. 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 If the user sets TOL to be less than or equal to zero, C then the tolerance is taken as (N+P)*(N+M)*EPS, where EPS C is the machine precision (see LAPACK Library Routine C DLAMCH). TOL < 1. 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 >= 1, if MIN(P, MAX(N,M)) = 0; otherwise, C LDWORK >= MAX( MIN(P,M) + M + MAX(2*M,N) - 1, C MIN(P,N) + MAX(N + MAX( P, M), 3*P - 1 ) ). 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 the C 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 numerically backward stable and requires C 0( (P+N)*(M+N)*N ) floating point operations. C C FURTHER COMMENTS C C The number of infinite zeros is computed (if FIRST = .TRUE.) as C C DINFZ C NINFZ = Sum (INFZ(i)*i . C i=1 C C Note that each infinite zero of multiplicity k corresponds to an C infinite eigenvalue of multiplicity k+1. C The multiplicities of the infinite eigenvalues can be determined C from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows: C C DINFZ C - there are PR - Sum (INFZ(i)) simple infinite eigenvalues; C i=1 C C - there are INFZ(i) infinite eigenvalues with multiplicity i+1, C for i = 1, ..., DINFZ. C C The left Kronecker indices are: C C [ 0 0 ... 0 | 1 1 ... 1 | .... | NKRONL ... NKRONL ] C |<- KRONL(1) ->|<- KRONL(2) ->| |<- KRONL(NKRONL) ->| C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium. C A. Varga, DLR Oberpfaffenhofen, Germany, May 1999. C Supersedes Release 3.0 routine AB08BX. C C REVISIONS C C A. Varga, DLR Oberpfaffenhofen, Germany, March 2002. C V. Sima, Dec. 2016, Jan. 2017, Feb. 2018. 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 .. LOGICAL FIRST INTEGER DINFZ, INFO, LDABCD, LDWORK, M, N, NINFZ, $ NKRONL, NR, P, PR DOUBLE PRECISION SVLMAX, TOL C .. Array Arguments .. INTEGER INFZ(*), IWORK(*), KRONL(*) DOUBLE PRECISION ABCD(LDABCD,*), DWORK(*) C .. Local Scalars .. LOGICAL LQUERY INTEGER I, I1, ICOL, IRC, IROW, ITAU, JWORK, K, MN, MNR, $ MNTAU, MP1, MPM, MPN, MUI, MUIM1, NBLCKS, PN, $ RANK, RO, RO1, SIGMA, TAUI, WRKOPT DOUBLE PRECISION RCOND C .. Local Arrays .. DOUBLE PRECISION SVAL(3) C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. External Subroutines .. EXTERNAL DLAPMT, DLASET, DORMQR, DORMRQ, MB03OY, MB03PY, $ MB04ID, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C .. Executable Statements .. C INFO = 0 PN = P + N MN = M + N MPN = MIN( P, N ) MPM = MIN( P, M ) C C Test the input scalar arguments. C IF( N.LT.0 ) THEN INFO = -2 ELSE IF( M.LT.0 .OR. (.NOT.FIRST .AND. M.GT.P ) ) THEN INFO = -3 ELSE IF( P.LT.0 ) THEN INFO = -4 ELSE IF( SVLMAX.LT.ZERO ) THEN INFO = -5 ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN INFO = -7 ELSE IF( NINFZ.LT.0 .OR. ( FIRST .AND. NINFZ.GT.0 ) ) THEN INFO = -8 ELSE IF( TOL.GE.ONE ) THEN INFO = -15 ELSE LQUERY = ( LDWORK.EQ.-1 ) IF( MIN( P, MAX( N, M ) ).EQ.0 ) THEN JWORK = 1 ELSE JWORK = MAX( MPM + M + MAX( 2*M, N ) - 1, $ MPN + MAX( N + MAX( P, M) , 3*P - 1 ) ) END IF IF( LQUERY ) THEN IF( M.GT.0 ) THEN CALL MB04ID( P, MPM, M-1, N, ABCD, LDABCD, ABCD, LDABCD, $ DWORK, DWORK, -1, INFO ) WRKOPT = MAX( JWORK, MPM + INT( DWORK(1) ) ) CALL DORMQR( 'Left', 'Transpose', P, N, MPM, ABCD, $ LDABCD, DWORK, ABCD, LDABCD, DWORK, -1, $ INFO ) WRKOPT = MAX( WRKOPT, MPM + INT( DWORK(1) ) ) ELSE WRKOPT = JWORK END IF CALL DORMRQ( 'Right', 'Transpose', PN, N, MPN, ABCD, LDABCD, $ DWORK, ABCD, LDABCD, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, MPN + INT( DWORK(1) ) ) CALL DORMRQ( 'Left', 'NoTranspose', N, MN, MPN, ABCD, $ LDABCD, DWORK, ABCD, LDABCD, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, MPN + INT( DWORK(1) ) ) 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( 'AB08NY', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Initialize output variables. C PR = P NR = N C DINFZ = 0 NKRONL = 0 C C Quick return if possible. C IF( P.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C IF( MAX( N, M ).EQ.0 ) THEN PR = 0 NKRONL = 1 KRONL(1) = P DWORK(1) = ONE RETURN END IF C WRKOPT = 1 RCOND = TOL IF( RCOND.LE.ZERO ) THEN C C Use the default tolerance in rank determination. C RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' ) END IF C C The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and C SIGMA = 0, for FIRST = .TRUE., and SIGMA = M, for FIRST = .FALSE.. C The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column C rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular. C IF( FIRST ) THEN SIGMA = 0 ELSE SIGMA = M END IF RO = P - SIGMA MP1 = M + 1 MUI = 0 C NBLCKS = 0 ITAU = 1 C 10 CONTINUE C C Main reduction loop: C C M NR M NR C NR [ B A ] NR [ B A ] C PR [ D C ] --> SIGMA [ RD C1 ] (SIGMA = rank(D) = C TAU [ 0 C2 ] row size of RD) C C M NR-MUI MUI C NR-MUI [ B1 A11 A12 ] C --> MUI [ B2 A21 A22 ] (MUI = rank(C2) = C SIGMA [ RD C11 C12 ] col size of LC) C TAU [ 0 0 LC ] C C M NR-MUI C NR-MUI [ B1 A11 ] NR := NR - MUI C [----------] PR := MUI + SIGMA C --> MUI [ B2 A21 ] D := [B2;RD] C SIGMA [ RD C11 ] C := [A21;C11] C IF ( PR.EQ.0 ) $ GO TO 20 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 MNR = M + NR C IF ( M.GT.0 ) THEN C C Compress columns of D; first, exploit the trapezoidal shape of C the (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D; C compress the first SIGMA columns without column pivoting: C C ( x x x x x ) ( x x x x x ) C ( x x x x x ) ( 0 x x x x ) C ( x x x x x ) - > ( 0 0 x x x ) C ( 0 x x x x ) ( 0 0 0 x x ) C ( 0 0 x x x ) ( 0 0 0 x x ) C C where SIGMA = 3 and RO = 2. C IROW = NR + 1 IF ( SIGMA.GT.0 ) THEN JWORK = ITAU + SIGMA C C Compress rows of D. First, exploit the triangular shape. C Workspace: need min(P,M) + M+N-1; C prefer larger. C CALL MB04ID( RO+SIGMA, SIGMA, SIGMA-1, MNR-SIGMA, $ ABCD(IROW,1), LDABCD, ABCD(IROW,SIGMA+1), $ LDABCD, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) CALL DLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO, $ ABCD(IROW+1,1), LDABCD ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) END IF C IF( FIRST ) THEN C C Continue with Householder with column pivoting. C C ( x x x x x ) ( x x x x x ) C ( 0 x x x x ) ( 0 x x x x ) C ( 0 0 x x x ) -> ( 0 0 x x x ) C ( 0 0 0 x x ) ( 0 0 0 x x ) C ( 0 0 0 x x ) ( 0 0 0 0 0 ) C C Workspace: need min(P,M) + 3*M-1. C Int.work. need M. C JWORK = ITAU + MIN( RO1, M-SIGMA ) C IROW = MIN( NR+SIGMA+1, PN ) ICOL = MIN( SIGMA+1,M ) CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, RCOND, $ SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU), $ DWORK(JWORK), INFO ) WRKOPT = MAX( WRKOPT, JWORK + 3*( M-SIGMA ) - 1 ) C C Apply the column permutations to B and part of D. C CALL DLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL), $ LDABCD, IWORK ) C IF ( RANK.GT.0 ) THEN C C Apply the Householder transformations to the submatrix C. C Workspace: need min(P,M) + N. C prefer min(P,M) + N*NB. C CALL DORMQR( 'Left', 'Transpose', RO1, NR, RANK, $ ABCD(IROW,ICOL), LDABCD, DWORK(ITAU), $ ABCD(IROW,MP1), LDABCD, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, $ ZERO, ABCD(MIN( PN, IROW+1 ),ICOL), LDABCD ) RO1 = RO1 - RANK END IF END IF C C Terminate if Dr has maximal row rank. C IF( RO1.EQ.0 ) $ GO TO 30 C END IF C C Update SIGMA. C SIGMA = PR - RO1 C NBLCKS = NBLCKS + 1 TAUI = RO1 C IF ( NR.LE.0 ) THEN PR = SIGMA RANK = 0 ELSE C C Compress the columns of C using RQ factorization with row C pivoting, P * C = R * Q. C The current C is the TAUI-by-NR matrix delimited by rows C IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD. C The rank of the current C is computed in MUI. C Workspace: need min(P,N) + 3*P-1. C Int.work. need P. C IRC = NR + SIGMA I1 = IRC + 1 MNTAU = MIN( TAUI, NR ) JWORK = ITAU + MNTAU C CALL MB03PY( TAUI, NR, ABCD(I1,MP1), LDABCD, RCOND, SVLMAX, $ RANK, SVAL, IWORK, DWORK(ITAU), DWORK(JWORK), $ INFO ) WRKOPT = MAX( WRKOPT, JWORK + 3*TAUI - 1 ) C IF ( RANK.GT.0 ) THEN IROW = I1 + TAUI - RANK C C Apply Q' to the first NR columns of [A; C1] from the right. C Workspace: need min(P,N) + N + SIGMA; SIGMA <= P; C prefer min(P,N) + (N + SIGMA)*NB. C CALL DORMRQ( 'Right', 'Transpose', IRC, NR, RANK, $ ABCD(IROW,MP1), LDABCD, DWORK(MNTAU-RANK+1), $ ABCD(1,MP1), LDABCD, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Apply Q to the first NR rows and M + NR columns of [ B A ] C from the left. C Workspace: need min(P,N) + M + N; C prefer min(P,N) + (M + N)*NB. C CALL DORMRQ( 'Left', 'NoTranspose', NR, MNR, RANK, $ ABCD(IROW,MP1), 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, NR-RANK, ZERO, ZERO, $ ABCD(IROW,MP1), LDABCD ) IF ( RANK.GT.1 ) $ CALL DLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO, $ ABCD(IROW+1,MP1+NR-RANK), LDABCD ) END IF END IF C 20 CONTINUE MUI = RANK NR = NR - MUI PR = SIGMA + MUI C C Set number of left Kronecker blocks of order (i-1)-by-i. C KRONL(NBLCKS) = TAUI - MUI C C Set number of infinite divisors of order i-1. C IF( FIRST .AND. NBLCKS.GT.1 ) $ INFZ(NBLCKS-1) = MUIM1 - TAUI MUIM1 = MUI RO = MUI C C Continue reduction if rank of current C is positive. C IF( MUI.GT.0 ) $ GO TO 10 C C Determine the maximal degree of infinite zeros and the number of C infinite zeros. C 30 CONTINUE IF( FIRST ) THEN IF( MUI.EQ.0 ) THEN DINFZ = MAX( 0, NBLCKS - 1 ) ELSE DINFZ = NBLCKS INFZ(NBLCKS) = MUI END IF K = DINFZ C DO 40 I = K, 1, -1 IF( INFZ(I).NE.0 ) $ GO TO 50 DINFZ = DINFZ - 1 40 CONTINUE C 50 CONTINUE C DO 60 I = 1, DINFZ NINFZ = NINFZ + INFZ(I)*I 60 CONTINUE C END IF C C Determine the maximal order of left elementary Kronecker blocks. C NKRONL = NBLCKS C DO 70 I = NBLCKS, 1, -1 IF( KRONL(I).NE.0 ) $ GO TO 80 NKRONL = NKRONL - 1 70 CONTINUE C 80 CONTINUE C DWORK(1) = WRKOPT RETURN C *** Last line of AB08NY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02MW.f0000644000000000000000000000013015012430707016205 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB02MW.f0000644000175000017500000000253615012430707017411 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION SB02MW( REIG, IEIG ) C C PURPOSE C C To select the stable eigenvalues for solving the discrete-time C algebraic Riccati equation. C C ARGUMENTS C C Input/Output Parameters C C REIG (input) DOUBLE PRECISION C The real part of the current eigenvalue considered. C C IEIG (input) DOUBLE PRECISION C The imaginary part of the current eigenvalue considered. C C METHOD C C The function value SB02MW is set to .TRUE. for a stable C eigenvalue (i.e., with modulus less than one) and to .FALSE., C otherwise. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C C REVISIONS C C - C C KEYWORDS C C Algebraic Riccati equation, closed loop system, discrete-time C system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION IEIG, REIG C .. External Functions .. DOUBLE PRECISION DLAPY2 EXTERNAL DLAPY2 C .. Executable Statements .. C SB02MW = DLAPY2( REIG, IEIG ).LT.ONE C RETURN C *** Last line of SB02MW *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02QD.f0000644000000000000000000000013015012430707016166 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB02QD.f0000644000175000017500000007023415012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE SB02QD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T, $ LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEP, $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To estimate the conditioning and compute an error bound on the C solution of the real continuous-time matrix algebraic Riccati C equation C C op(A)'*X + X*op(A) + Q - X*G*X = 0, (1) C C where op(A) = A or A' (A**T) and Q, G are symmetric (Q = Q**T, C G = G**T). The matrices A, Q and G are N-by-N and the solution X C is N-by-N. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'C': Compute the reciprocal condition number only; C = 'E': Compute the error bound only; C = 'B': Compute both the reciprocal condition number and C the error bound. C C FACT CHARACTER*1 C Specifies whether or not the real Schur factorization of C the matrix Ac = A - G*X (if TRANA = 'N') or Ac = A - X*G C (if TRANA = 'T' or 'C') is supplied on entry, as follows: C = 'F': On entry, T and U (if LYAPUN = 'O') contain the C factors from the real Schur factorization of the C matrix Ac; C = 'N': The Schur factorization of Ac will be computed C and the factors will be stored in T and U (if C LYAPUN = 'O'). 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 UPLO CHARACTER*1 C Specifies which part of the symmetric matrices Q and G is C to be used, as follows: C = 'U': Upper triangular part; C = 'L': Lower triangular part. C C LYAPUN CHARACTER*1 C Specifies whether or not the original Lyapunov equations C should be solved in the iterative estimation process, C as follows: C = 'O': Solve the original Lyapunov equations, updating C the right-hand sides and solutions with the C matrix U, e.g., RHS <-- U'*RHS*U; C = 'R': Solve reduced Lyapunov equations only, without C updating the right-hand sides and solutions. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, X, Q, and G. N >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of C this array must contain the matrix A. C If FACT = 'F' and LYAPUN = 'R', A is not referenced. C C LDA INTEGER C The leading dimension of the array A. C LDA >= max(1,N), if FACT = 'N' or LYAPUN = 'O'; C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. C C T (input or output) DOUBLE PRECISION array, dimension C (LDT,N) C If FACT = 'F', then T is an input argument and on entry, C the leading N-by-N upper Hessenberg part of this array C must contain the upper quasi-triangular matrix T in Schur C canonical form from a Schur factorization of Ac (see C argument FACT). C If FACT = 'N', then T is an output argument and on exit, C if INFO = 0 or INFO = N+1, the leading N-by-N upper C Hessenberg part of this array contains the upper quasi- C triangular matrix T in Schur canonical form from a Schur C factorization of Ac (see argument FACT). C C LDT INTEGER C The leading dimension of the array T. LDT >= max(1,N). C C U (input or output) DOUBLE PRECISION array, dimension C (LDU,N) C If LYAPUN = 'O' and FACT = 'F', then U is an input C argument and on entry, the leading N-by-N part of this C array must contain the orthogonal matrix U from a real C Schur factorization of Ac (see argument FACT). C If LYAPUN = 'O' and FACT = 'N', then U is an output C argument and on exit, if INFO = 0 or INFO = N+1, it C contains the orthogonal N-by-N matrix from a real Schur C factorization of Ac (see argument FACT). C If LYAPUN = 'R', the array U is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= 1, if LYAPUN = 'R'; C LDU >= MAX(1,N), if LYAPUN = 'O'. C C G (input) DOUBLE PRECISION array, dimension (LDG,N) C If UPLO = 'U', the leading N-by-N upper triangular part of C this array must contain the upper triangular part of the C matrix G. C If UPLO = 'L', the leading N-by-N lower triangular part of C this array must contain the lower triangular part of the C matrix G. _ C Matrix G should correspond to G in the "reduced" Riccati C equation (with matrix T, instead of A), if LYAPUN = 'R'. C See METHOD. C C LDG INTEGER C The leading dimension of the array G. LDG >= max(1,N). C C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) C If UPLO = 'U', the leading N-by-N upper triangular part of C this array must contain the upper triangular part of the C matrix Q. C If UPLO = 'L', the leading N-by-N lower triangular part of C this array must contain the lower triangular part of the C matrix Q. _ C Matrix Q should correspond to Q in the "reduced" Riccati C equation (with matrix T, instead of A), if LYAPUN = 'R'. C See METHOD. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= max(1,N). C C X (input) DOUBLE PRECISION array, dimension (LDX,N) C The leading N-by-N part of this array must contain the C symmetric solution matrix of the original Riccati C equation (with matrix A), if LYAPUN = 'O', or of the C "reduced" Riccati equation (with matrix T), if C LYAPUN = 'R'. See METHOD. C C LDX INTEGER C The leading dimension of the array X. LDX >= max(1,N). C C SEP (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'B', the estimated quantity C sep(op(Ac),-op(Ac)'). C If N = 0, or X = 0, or JOB = 'E', SEP is not referenced. C C RCOND (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal C condition number of the continuous-time Riccati equation. C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. C If JOB = 'E', RCOND is not referenced. C C FERR (output) DOUBLE PRECISION C If JOB = 'E' or JOB = 'B', an estimated forward error C bound for the solution X. If XTRUE is the true solution, C FERR bounds the magnitude of the largest entry in C (X - XTRUE) divided by the magnitude of the largest entry C in X. C If N = 0 or X = 0, FERR is set to 0. C If JOB = 'C', FERR is not referenced. C C Workspace C C IWORK INTEGER array, dimension (N*N) 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 dimension of the array DWORK. C Let LWA = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B'; C LWA = 0, otherwise. C If FACT = 'N', then C LDWORK = MAX(1, 5*N, 2*N*N), if JOB = 'C'; C LDWORK = MAX(1, LWA + 5*N, 4*N*N ), if JOB = 'E', 'B'. C If FACT = 'F', then C LDWORK = MAX(1, 2*N*N), if JOB = 'C'; C LDWORK = MAX(1, 4*N*N ), if JOB = 'E' or 'B'. C For good performance, LDWORK must generally 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 > 0: if INFO = i, i <= N, the QR algorithm failed to C complete the reduction of the matrix Ac to Schur C canonical form (see LAPACK Library routine DGEES); C on exit, the matrix T(i+1:N,i+1:N) contains the C partially converged Schur form, and DWORK(i+1:N) and C DWORK(N+i+1:2*N) contain the real and imaginary C parts, respectively, of the converged eigenvalues; C this error is unlikely to appear; C = N+1: if the matrices T and -T' have common or very C close eigenvalues; perturbed values were used to C solve Lyapunov equations, but the matrix T, if given C (for FACT = 'F'), is unchanged. C C METHOD C C The condition number of the Riccati equation is estimated as C C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + C norm(Pi)*norm(G) ) / norm(X), C C where Omega, Theta and Pi are linear operators defined by C C Omega(W) = op(Ac)'*W + W*op(Ac), C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), C Pi(W) = inv(Omega(X*W*X)), C C and Ac = A - G*X (if TRANA = 'N') or Ac = A - X*G (if TRANA = 'T' C or 'C'). Note that the Riccati equation (1) is equivalent to C _ _ _ _ _ _ C op(T)'*X + X*op(T) + Q + X*G*X = 0, (2) C _ _ _ C where X = U'*X*U, Q = U'*Q*U, and G = U'*G*U, with U the C orthogonal matrix reducing Ac to a real Schur form, T = U'*Ac*U. C C The routine estimates the quantities C C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), C C norm(Theta) and norm(Pi) using 1-norm condition estimator. C C The forward error bound is estimated using a practical error bound C similar to the one proposed in [2]. C C REFERENCES C C [1] Ghavimi, A.R. and Laub, A.J. C Backward error, sensitivity, and refinement of computed C solutions of algebraic Riccati equations. C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, C 1995. C C [2] Higham, N.J. C Perturbation theory and backward error for AX-XB=C. C BIT, vol. 33, pp. 124-136, 1993. C C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. C DGRSVX and DMSRIC: Fortran 77 subroutines for solving C continuous-time matrix algebraic Riccati equations with C condition and accuracy estimates. C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. C Chemnitz, May 1998. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C The accuracy of the estimates obtained depends on the solution C accuracy and on the properties of the 1-norm estimator. C C FURTHER COMMENTS C C The option LYAPUN = 'R' may occasionally produce slightly worse C or better estimates, and it is much faster than the option 'O'. C When SEP is computed and it is zero, the routine returns C immediately, with RCOND and FERR (if requested) set to 0 and 1, C respectively. In this case, the equation is singular. C C CONTRIBUTOR C C P.Hr. Petkov, Technical University of Sofia, December 1998. C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004, C Apr. 2011, May 2020. C C KEYWORDS C C Conditioning, error estimates, orthogonal transformation, C real Schur form, Riccati equation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, FOUR, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, FOUR = 4.0D+0, $ HALF = 0.5D+0 ) C .. C .. Scalar Arguments .. CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO INTEGER INFO, LDA, LDG, LDQ, LDT, LDU, LDWORK, LDX, N DOUBLE PRECISION FERR, RCOND, SEP C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), $ Q( LDQ, * ), T( LDT, * ), U( LDU, * ), $ X( LDX, * ) C .. C .. Local Scalars .. LOGICAL JOBB, JOBC, JOBE, LOWER, LQUERY, NEEDAC, $ NOFACT, NOTRNA, UPDATE CHARACTER LOUP, SJOB, TRANAT INTEGER I, IABS, INFO2, IRES, ITMP, IXBS, J, JJ, JX, $ KASE, LDW, LWA, NN, SDIM, WRKOPT DOUBLE PRECISION ANORM, BIGNUM, DENOM, EPS, EPSN, EST, GNORM, $ PINORM, QNORM, SCALE, SIG, TEMP, THNORM, TMAX, $ XANORM, XNORM C .. C .. Local Arrays .. LOGICAL BWORK( 1 ) INTEGER ISAVE( 3 ) C .. C .. External Functions .. LOGICAL LSAME, SELECT DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT C .. C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEES, DLACN2, DLACPY, DSCAL, $ DSYMM, DSYR2K, MA02ED, MB01RU, MB01UD, SB03MY, $ SB03QX, SB03QY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C C Decode and Test input parameters. C JOBC = LSAME( JOB, 'C' ) JOBE = LSAME( JOB, 'E' ) JOBB = LSAME( JOB, 'B' ) NOFACT = LSAME( FACT, 'N' ) NOTRNA = LSAME( TRANA, 'N' ) LOWER = LSAME( UPLO, 'L' ) UPDATE = LSAME( LYAPUN, 'O' ) C NEEDAC = UPDATE .AND. .NOT.JOBC C NN = N*N IF( NEEDAC ) THEN LWA = NN ELSE LWA = 0 END IF C IF( NOFACT ) THEN IF( JOBC ) THEN LDW = MAX( 5*N, 2*NN ) ELSE LDW = MAX( LWA + 5*N, 4*NN ) END IF ELSE IF( JOBC ) THEN LDW = 2*NN ELSE LDW = 4*NN END IF END IF C INFO = 0 IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN INFO = -1 ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. $ LSAME( TRANA, 'C' ) ) ) THEN INFO = -3 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -4 ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.1 .OR. $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN INFO = -8 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN INFO = -12 ELSE IF( LDG.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE LQUERY = LDWORK.EQ.-1 IF( UPDATE ) THEN SJOB = 'V' ELSE SJOB = 'N' END IF IF( LQUERY .AND. NOFACT ) THEN CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK, DWORK, U, LDU, DWORK, -1, BWORK, INFO ) WRKOPT = MAX( 1, LDW, INT( DWORK( 1 ) ) + LWA + 2*N ) END IF IF( LDWORK.LT.MAX( 1, LDW ) .AND. .NOT. LQUERY ) $ INFO = -24 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB02QD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK( 1 ) = WRKOPT RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IF( .NOT.JOBE ) $ RCOND = ONE IF( .NOT.JOBC ) $ FERR = ZERO DWORK( 1 ) = ONE RETURN END IF C C Compute the 1-norm of the matrix X. C XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) IF( XNORM.EQ.ZERO ) THEN C C The solution is zero. C IF( .NOT.JOBE ) $ RCOND = ZERO IF( .NOT.JOBC ) $ FERR = ZERO DWORK( 1 ) = DBLE( N ) RETURN END IF C C Workspace usage. C IXBS = 0 ITMP = IXBS + NN IABS = ITMP + NN IRES = IABS + NN C C Workspace: LWR, where C LWR = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B', or C FACT = 'N', C LWR = 0, otherwise. C IF( NEEDAC .OR. NOFACT ) THEN C CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) IF( NOTRNA ) THEN C C Compute Ac = A - G*X. C CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, $ DWORK, N ) ELSE C C Compute Ac = A - X*G. C CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, $ DWORK, N ) END IF C WRKOPT = DBLE( NN ) IF( NOFACT ) $ CALL DLACPY( 'Full', N, N, DWORK, N, T, LDT ) ELSE WRKOPT = DBLE( N ) END IF C IF( NOFACT ) THEN C C Compute the Schur factorization of Ac, Ac = U*T*U'. C Workspace: need LWA + 5*N; C prefer larger; C LWA = N*N, if LYAPUN = 'O' and JOB = 'E' or 'B'; C LWA = 0, otherwise. 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 CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK( LWA+1 ), DWORK( LWA+N+1 ), U, LDU, $ DWORK( LWA+2*N+1 ), LDWORK-LWA-2*N, BWORK, INFO ) IF( INFO.GT.0 ) THEN IF( LWA.GT.0 ) $ CALL DCOPY( 2*N, DWORK( LWA+1 ), 1, DWORK, 1 ) RETURN END IF C WRKOPT = MAX( WRKOPT, INT( DWORK( LWA+2*N+1 ) ) + LWA + 2*N ) END IF IF( NEEDAC ) $ CALL DLACPY( 'Full', N, N, DWORK, N, DWORK( IABS+1 ), N ) C IF( NOTRNA ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF C IF( .NOT.JOBE ) THEN C C Estimate sep(op(Ac),-op(Ac)') = sep(op(T),-op(T)') and C norm(Theta). C Workspace LWA + 2*N*N. C CALL SB03QY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) C WRKOPT = MAX( WRKOPT, LWA + 2*NN ) C C Return if the equation is singular. C IF( SEP.EQ.ZERO ) THEN RCOND = ZERO IF( JOBB ) $ FERR = ONE DWORK( 1 ) = DBLE( WRKOPT ) RETURN END IF C C Estimate norm(Pi). C Workspace LWA + 2*N*N. C KASE = 0 C C REPEAT 10 CONTINUE CALL DLACN2( NN, DWORK( ITMP+1 ), DWORK, IWORK, EST, KASE, $ ISAVE ) IF( KASE.NE.0 ) THEN C C Select the triangular part of symmetric matrix to be used. C IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP+1 )) $ .GE. $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP+1 )) $ ) THEN LOUP = 'U' ELSE LOUP = 'L' END IF C C Compute RHS = X*W*X. C CALL MB01RU( LOUP, 'No Transpose', N, N, ZERO, ONE, DWORK, $ N, X, LDX, DWORK, N, DWORK( ITMP+1 ), NN, $ INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) C IF( UPDATE ) THEN C C Transform the right-hand side: RHS := U'*RHS*U. C CALL MB01RU( LOUP, 'Transpose', N, N, ZERO, ONE, DWORK, $ N, U, LDU, DWORK, N, DWORK( ITMP+1 ), NN, $ INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) END IF C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( LOUP, N, DWORK, N ) C IF( KASE.EQ.1 ) THEN C C Solve op(T)'*Y + Y*op(T) = scale*RHS. C CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) ELSE C C Solve op(T)*W + W*op(T)' = scale*RHS. C CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) END IF C IF( UPDATE ) THEN C C Transform back to obtain the solution: Z := U*Z*U', with C Z = Y or Z = W. C CALL MB01RU( LOUP, 'No transpose', N, N, ZERO, ONE, $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP+1 ), $ NN, INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( LOUP, N, DWORK, N ) END IF GO TO 10 END IF C UNTIL KASE = 0 C IF( EST.LT.SCALE ) THEN PINORM = EST / SCALE ELSE BIGNUM = ONE / DLAMCH( 'Safe minimum' ) IF( EST.LT.SCALE*BIGNUM ) THEN PINORM = EST / SCALE ELSE PINORM = BIGNUM END IF END IF C C Compute the 1-norm of A or T. C IF( UPDATE ) THEN ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) ELSE ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) END IF C C Compute the 1-norms of the matrices Q and G. C QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) C C Estimate the reciprocal condition number. C TMAX = MAX( SEP, XNORM, ANORM, GNORM ) IF( TMAX.LE.ONE ) THEN TEMP = SEP*XNORM DENOM = QNORM + ( SEP*ANORM )*THNORM + $ ( SEP*GNORM )*PINORM ELSE TEMP = ( SEP / TMAX )*( XNORM / TMAX ) DENOM = ( ( ONE / TMAX )*( QNORM / TMAX ) ) + $ ( ( SEP / TMAX )*( ANORM / TMAX ) )*THNORM + $ ( ( SEP / TMAX )*( GNORM / TMAX ) )*PINORM END IF IF( TEMP.GE.DENOM ) THEN RCOND = ONE ELSE RCOND = TEMP / DENOM END IF END IF C IF( .NOT.JOBC ) THEN C C Form a triangle of the residual matrix C R = op(A)'*X + X*op(A) + Q - X*G*X, C or _ _ _ _ _ _ C R = op(T)'*X + X*op(T) + Q + X*G*X, C exploiting the symmetry. C Workspace 4*N*N. C IF( UPDATE ) THEN CALL DLACPY( UPLO, N, N, Q, LDQ, DWORK( IRES+1 ), N ) CALL DSYR2K( UPLO, TRANAT, N, N, ONE, A, LDA, X, LDX, ONE, $ DWORK( IRES+1 ), N ) SIG = -ONE ELSE CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, $ DWORK( IRES+1 ), N, INFO2 ) JJ = IRES + 1 IF( LOWER ) THEN DO 20 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK( JJ ), N, DWORK( JJ ), $ 1 ) CALL DAXPY( N-J+1, ONE, Q( J, J ), 1, DWORK( JJ ), 1 ) JJ = JJ + N + 1 20 CONTINUE ELSE DO 30 J = 1, N CALL DAXPY( J, ONE, DWORK( IRES+J ), N, DWORK( JJ ), $ 1 ) CALL DAXPY( J, ONE, Q( 1, J ), 1, DWORK( JJ ), 1 ) JJ = JJ + N 30 CONTINUE END IF SIG = ONE END IF CALL MB01RU( UPLO, TRANAT, N, N, ONE, SIG, DWORK( IRES+1 ), $ N, X, LDX, G, LDG, DWORK( ITMP+1 ), NN, INFO2 ) C C Get the machine precision. C EPS = DLAMCH( 'Epsilon' ) EPSN = EPS*DBLE( N + 4 ) TEMP = EPS*FOUR C C Add to abs(R) a term that takes account of rounding errors in C forming R: C abs(R) := abs(R) + EPS*(4*abs(Q) + (n+4)*(abs(op(Ac))'*abs(X) C + abs(X)*abs(op(Ac))) + 2*(n+1)*abs(X)*abs(G)*abs(X)), C or _ _ C abs(R) := abs(R) + EPS*(4*abs(Q) + (n+4)*(abs(op(T))'*abs(X) C _ _ _ _ C + abs(X)*abs(op(T))) + 2*(n+1)*abs(X)*abs(G)*abs(X)), C where EPS is the machine precision. C DO 50 J = 1, N DO 40 I = 1, N DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) 40 CONTINUE 50 CONTINUE C IF( LOWER ) THEN DO 70 J = 1, N DO 60 I = J, N DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( Q( I, J ) ) + $ ABS( DWORK( IRES+(J-1)*N+I ) ) 60 CONTINUE 70 CONTINUE ELSE DO 90 J = 1, N DO 80 I = 1, J DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( Q( I, J ) ) + $ ABS( DWORK( IRES+(J-1)*N+I ) ) 80 CONTINUE 90 CONTINUE END IF C IF( UPDATE ) THEN C DO 110 J = 1, N DO 100 I = 1, N DWORK( IABS+(J-1)*N+I ) = $ ABS( DWORK( IABS+(J-1)*N+I ) ) 100 CONTINUE 110 CONTINUE C CALL DSYR2K( UPLO, TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, $ DWORK( IXBS+1 ), N, ONE, DWORK( IRES+1 ), N ) ELSE C DO 130 J = 1, N DO 120 I = 1, MIN( J+1, N ) DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) 120 CONTINUE 130 CONTINUE C CALL MB01UD( 'Left', TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, $ DWORK( IXBS+1), N, DWORK( ITMP+1 ), N, INFO2 ) JJ = IRES + 1 JX = ITMP + 1 IF( LOWER ) THEN DO 140 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK( JX ), N, DWORK( JX ), $ 1 ) CALL DAXPY( N-J+1, ONE, DWORK( JX ), 1, DWORK( JJ ), $ 1 ) JJ = JJ + N + 1 JX = JX + N + 1 140 CONTINUE ELSE DO 150 J = 1, N CALL DAXPY( J, ONE, DWORK( ITMP+J ), N, DWORK( JX ), $ 1 ) CALL DAXPY( J, ONE, DWORK( JX ), 1, DWORK( JJ ), 1 ) JJ = JJ + N JX = JX + N 150 CONTINUE END IF END IF C IF( LOWER ) THEN DO 170 J = 1, N DO 160 I = J, N DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) 160 CONTINUE 170 CONTINUE ELSE DO 190 J = 1, N DO 180 I = 1, J DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) 180 CONTINUE 190 CONTINUE END IF C CALL MB01RU( UPLO, TRANA, N, N, ONE, EPS*DBLE( 2*( N + 1 ) ), $ DWORK( IRES+1 ), N, DWORK( IXBS+1), N, $ DWORK( IABS+1 ), N, DWORK( ITMP+1 ), NN, INFO2 ) C WRKOPT = MAX( WRKOPT, 4*NN ) C C Compute forward error bound, using matrix norm estimator. C Workspace 4*N*N. C XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) C CALL SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, $ INFO ) END IF C DWORK( 1 ) = DBLE( WRKOPT ) RETURN C C *** Last line of SB02QD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04CD.f0000644000000000000000000000013215012430707016146 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04CD.f0000644000175000017500000043030015012430707017342 0ustar00lilgelilge00000000000000 SUBROUTINE MB04CD( COMPQ1, COMPQ2, COMPQ3, N, A, LDA, B, LDB, D, $ LDD, Q1, LDQ1, Q2, LDQ2, Q3, LDQ3, IWORK, $ LIWORK, DWORK, LDWORK, BWORK, INFO ) C C PURPOSE C C To compute the transformed matrices A, B and D, using orthogonal C matrices Q1, Q2 and Q3 for a real N-by-N regular pencil C C ( A11 0 ) ( B11 0 ) ( 0 D12 ) C aA*B - bD = a ( ) ( ) - b ( ), (1) C ( 0 A22 ) ( 0 B22 ) ( D21 0 ) C C where A11, A22, B11, B22 and D12 are upper triangular, D21 is C upper quasi-triangular and the generalized matrix product C -1 -1 -1 -1 C A11 D12 B22 A22 D21 B11 is upper quasi-triangular, such C that Q3' A Q2, Q2' B Q1 are upper triangular, Q3' D Q1 is upper C quasi-triangular and the transformed pencil C a(Q3' A B Q1) - b(Q3' D Q1) is in generalized Schur form. The C notation M' denotes the transpose of the matrix M. C C ARGUMENTS C C Mode Parameters C C COMPQ1 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q1, as follows: C = 'N': Q1 is not computed; C = 'I': the array Q1 is initialized internally to the unit C matrix, and the orthogonal matrix Q1 is returned; C = 'U': the array Q1 contains an orthogonal matrix Q01 on C entry, and the matrix Q01*Q1 is returned, where Q1 C is the product of the orthogonal transformations C that are applied on the right to the pencil C aA*B - bD in (1). C C COMPQ2 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q2, as follows: C = 'N': Q2 is not computed; C = 'I': the array Q2 is initialized internally to the unit C matrix, and the orthogonal matrix Q2 is returned; C = 'U': the array Q2 contains an orthogonal matrix Q02 on C entry, and the matrix Q02*Q2 is returned, where Q2 C is the product of the orthogonal transformations C that are applied on the left to the pencil C aA*B - bD in (1). C C COMPQ3 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q3, as follows: C = 'N': Q3 is not computed; C = 'I': the array Q3 is initialized internally to the unit C matrix, and the orthogonal matrix Q3 is returned; C = 'U': the array Q3 contains an orthogonal matrix Q01 on C entry, and the matrix Q03*Q3 is returned, where Q3 C is the product of the orthogonal transformations C that are applied on the right to the pencil C aA*B - bD in (1). C C Input/Output Parameters C C N (input) INTEGER C Order of the pencil aA*B - bD. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension (LDA, N) C On entry, the leading N-by-N block diagonal part of this C array must contain the matrix A in (1). The off-diagonal C blocks need not be set to zero. C On exit, the leading N-by-N part of this array contains C the transformed upper triangular matrix. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB, N) C On entry, the leading N-by-N block diagonal part of this C array must contain the matrix B in (1). The off-diagonal C blocks need not be set to zero. C On exit, the leading N-by-N part of this array contains C the transformed upper triangular matrix. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N). C C D (input/output) DOUBLE PRECISION array, dimension (LDD, N) C On entry, the leading N-by-N block anti-diagonal part of C this array must contain the matrix D in (1). The diagonal C blocks need not be set to zero. C On exit, the leading N-by-N part of this array contains C the transformed upper quasi-triangular matrix. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1, N). C C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1, N) C On entry, if COMPQ1 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q01, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q01 and the transformation matrix Q1 C used to transform the matrices A, B, and D. C On exit, if COMPQ1 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q1. C If COMPQ1 = 'N' this array is not referenced. C C LDQ1 INTEGER C LDQ1 >= 1, if COMPQ1 = 'N'; C LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'. C C Q2 (input/output) DOUBLE PRECISION array, dimension (LDQ2, N) C On entry, if COMPQ2 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q02, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q02 and the transformation matrix Q2 C used to transform the matrices A, B, and D. C On exit, if COMPQ2 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q2. C If COMPQ2 = 'N' this array is not referenced. C C LDQ2 INTEGER C The leading dimension of the array Q2. C LDQ2 >= 1, if COMPQ2 = 'N'; C LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'. C C Q3 (input/output) DOUBLE PRECISION array, dimension (LDQ3, N) C On entry, if COMPQ3 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q03, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q03 and the transformation matrix Q3 C used to transform the matrices A, B and D. C On exit, if COMPQ3 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q3. C If COMPQ3 = 'N' this array is not referenced. C C LDQ3 INTEGER C The leading dimension of the array Q3. C LDQ3 >= 1, if COMPQ3 = 'N'; C LDQ3 >= MAX(1, N), if COMPQ3 = 'I' or COMPQ3 = 'U'. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= MAX( N/2+1, 48 ). C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -20, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= 3*N*N + MAX( N/2 + 252, 432 ). C For good performance LDWORK should be generally larger. C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C BWORK LOGICAL array, dimension (N/2) C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: the periodic QZ algorithm failed to reorder the C eigenvalues (the problem is very ill-conditioned) in C the SLICOT Library routine MB03KD; C = 2: the standard QZ algorithm failed in the LAPACK C routine DGGEV, called by the SLICOT routine MB03CD; C = 3: the standard QZ algorithm failed in the LAPACK C routines DGGES, called by the SLICOT routines MB03CD C or MB03ED; C = 4: the standard QZ algorithm failed to reorder the C eigenvalues in the LAPACK routine DTGSEN, called by C the SLICOT routine MB03CD. C C METHOD C C First, the periodic QZ algorithm (see also [2] and [3]) is applied C -1 -1 -1 -1 C to the formal matrix product A11 D12 B22 A22 D21 B11 to C reorder the eigenvalues, i.e., orthogonal matrices V1, V2, V3, V4, C V5 and V6 are computed such that V2' A11 V1, V2' D12 V3, C V4' B22 V3, V5' A22 V4, V5' D21 V6 and V1' B11 V6 keep the C triangular form, but they can be partitioned into 2-by-2 block C forms and the last diagonal blocks correspond to all nonpositive C real eigenvalues of the formal product, and the first diagonal C blocks correspond to the remaining eigenvalues. C C Second, Q1 = diag(V6, V3), Q2 = diag(V1, V4), Q3 = diag(V2, V5) C and C C ( AA11 AA12 0 0 ) C ( ) C ( 0 AA22 0 0 ) C A := Q3' A Q2 =: ( ), C ( 0 0 AA33 AA34 ) C ( ) C ( 0 0 0 AA44 ) C C ( BB11 BB12 0 0 ) C ( ) C ( 0 BB22 0 0 ) C B := Q2' B Q1 =: ( ), C ( 0 0 BB33 BB34 ) C ( ) C ( 0 0 0 BB44 ) C C ( 0 0 DD13 DD14 ) C ( ) C ( 0 0 0 DD24 ) C D := Q3' D Q1 =: ( ), C ( DD31 DD32 0 0 ) C ( ) C ( 0 DD42 0 0 ) C C -1 -1 -1 -1 C are set, such that AA22 DD24 BB44 AA44 DD42 BB22 has only C nonpositive real eigenvalues. C C Third, the permutation matrix C C ( I 0 0 0 ) C ( ) C ( 0 0 I 0 ) C P = ( ), C ( 0 I 0 0 ) C ( ) C ( 0 0 0 I ) C C where I denotes the identity matrix of appropriate size is used to C transform aA*B - bD to block upper triangular form C C ( AA11 0 | AA12 0 ) C ( | ) C ( 0 AA33 | 0 AA34 ) ( AA1 * ) C A := P' A P = (-----------+-----------) = ( ), C ( 0 0 | AA22 0 ) ( 0 AA2 ) C ( | ) C ( 0 0 | 0 AA44 ) C C ( BB11 0 | BB12 0 ) C ( | ) C ( 0 BB33 | 0 BB34 ) ( BB1 * ) C B := P' B P = (-----------+-----------) = ( ), C ( 0 0 | BB22 0 ) ( 0 BB2 ) C ( | ) C ( 0 0 | 0 BB44 ) C C ( 0 DD13 | 0 DD14 ) C ( | ) C ( DD31 0 | DD32 0 ) ( DD1 * ) C D := P' D P = (-----------+-----------) = ( ). C ( 0 0 | 0 DD24 ) ( 0 DD2 ) C ( | ) C ( 0 0 | DD42 0 ) C C Then, further orthogonal transformations that are provided by the C SLICOT Library routines MB03ED and MB03CD are used to C triangularize the subpencil aAA1 BB1 - bDD1. C C Finally, the subpencil aAA2 BB2 - bDD2 is triangularized by C applying a special permutation matrix. C C See also page 22 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C [2] Bojanczyk, A., Golub, G. H. and Van Dooren, P. C The periodic Schur decomposition: algorithms and applications. C In F.T. Luk (editor), Advanced Signal Processing Algorithms, C Architectures, and Implementations III, Proc. SPIE Conference, C vol. 1770, pp. 31-42, 1992. C C [3] Hench, J. J. and Laub, A. J. C Numerical Solution of the discrete-time periodic Riccati C equation. IEEE Trans. Automat. Control, 39, 1197-1210, 1994. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, January 21, 2009. C V. Sima, Aug. 2009 (SLICOT version of the routine DBTFMT). C C REVISIONS C C V. Sima, Jan. 2011, Aug. 2011, July 2014. C M. Voigt, Jan. 2012, July 2013. C C KEYWORDS C C Eigenvalue reordering, matrix pencil, periodic QZ algorithm, C upper (quasi-)triangular matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HUND2 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HUND2 = 2.0D+2 ) C C .. Scalar Arguments .. CHARACTER COMPQ1, COMPQ2, COMPQ3 INTEGER INFO, LDA, LDB, LDD, LDQ1, LDQ2, LDQ3, LDWORK, $ LIWORK, N C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( LDD, * ), $ DWORK( * ), Q1( LDQ1, * ), Q2( LDQ2, * ), $ Q3( LDQ3, * ) C C .. Local Scalars .. LOGICAL LCMPQ1, LCMPQ2, LCMPQ3, LINIQ1, LINIQ2, LINIQ3, $ LQUERY, LUPDQ1, LUPDQ2, LUPDQ3 INTEGER DIM1, DIM2, I, I1, I1LOLE, I1LORI, I1UPLE, $ I1UPRI, I2, I2LOLE, I2LORI, I2UPLE, I2UPRI, $ I3, I3LOLE, I3LORI, I3UPLE, I3UPRI, IA, IA11, $ IA22, IALOLE, IALORI, IAUPLE, IAUPRI, IB, IB1, $ IB11, IB2, IB22, IBLOLE, IBLORI, IBUPLE, $ IBUPRI, ID12, ID21, IDLOLE, IDLORI, IDUPLE, $ IDUPRI, IJ1, IJ2, ITMP, ITMP2, ITMP3, IV1, IV2, $ IV3, IV4, IV5, IV6, IWRK, J, K, KSCHUR, M, M1, $ M2, M4, MINWRK, MM, MP1, NR, NROW, OPTWRK, R, $ SDIM DOUBLE PRECISION BASE, LGBAS, TMP2, TMP3, ULP C C .. Local Arrays .. LOGICAL BW( 4 ) INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 1 ) C C .. External Functions .. LOGICAL LSAME, SB02OW DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME, SB02OW C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGGES, DGGEV, $ DLACPY, DLASET, DSCAL, DTGSEN, MA01BD, MB03BA, $ MB03CD, MB03ED, MB03KD, XERBLA C C .. Intrinsic Functions .. INTRINSIC INT, LOG, MAX, MIN, MOD C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 MM = M*M LINIQ1 = LSAME( COMPQ1, 'I' ) LUPDQ1 = LSAME( COMPQ1, 'U' ) LINIQ2 = LSAME( COMPQ2, 'I' ) LUPDQ2 = LSAME( COMPQ2, 'U' ) LINIQ3 = LSAME( COMPQ3, 'I' ) LUPDQ3 = LSAME( COMPQ3, 'U' ) LCMPQ1 = LINIQ1 .OR. LUPDQ1 LCMPQ2 = LINIQ2 .OR. LUPDQ2 LCMPQ3 = LINIQ3 .OR. LUPDQ3 LQUERY = LDWORK.EQ.-1 MINWRK = 12*MM + MAX( M + 252, 432 ) C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ1, 'N' ) .OR. LCMPQ1 ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ2, 'N' ) .OR. LCMPQ2 ) ) THEN INFO = -2 ELSE IF( .NOT.( LSAME( COMPQ3, 'N' ) .OR. LCMPQ3 ) ) THEN INFO = -3 IF( N.LT.0 .OR. MOD( N, 2 ).NE.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( LDD.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDQ1.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDQ3.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LIWORK.LT.MAX( M + 1, 48 ) ) THEN INFO = -18 ELSE IF( .NOT. LQUERY .AND. LDWORK.LT.MINWRK ) THEN DWORK( 1 ) = MINWRK INFO = -20 END IF C END IF IF( INFO.NE.0) THEN CALL XERBLA( 'MB04CD', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN C C Compute optimal workspace. C I = MIN( 4, N ) DO 5 J = 1, I BW( I ) = .TRUE. 5 CONTINUE CALL DGGES( 'Vectors', 'Vectors', 'Sorted', SB02OW, I, A, LDA, $ B, LDB, IDUM( 1 ), DWORK, DWORK, DWORK, Q1, I, Q2, $ I, DWORK, -1, BW, INFO ) CALL DGGES( 'Vectors', 'Vectors', 'Not sorted', SB02OW, I, A, $ LDA, B, LDB, IDUM( 1 ), DWORK, DWORK, DWORK, Q1, $ I, Q2, I, DWORK( 2 ), -1, BW, INFO ) CALL DGGEV( 'No Vector', 'No Vector', 2, A, LDA, B, LDB, $ DWORK, DWORK, DWORK, DUM, 1, DUM, 1, DWORK( 3 ), $ -1, INFO ) CALL DTGSEN( 0, .TRUE., .TRUE., BW, I, A, LDA, B, LDB, DWORK, $ DWORK, DWORK, Q1, I, Q2, I, IDUM( 1 ), TMP2, $ TMP2, DUM, DWORK( 4 ), -1, IDUM, 1, INFO ) C OPTWRK = MAX( 96 + MAX( 28 + INT( DWORK( 1 ) ), 4*M + 8, 4*N, $ 24 + INT( DWORK( 2 ) ), $ 6 + INT( DWORK( 3 ) ), $ 12 + INT( DWORK( 4 ) ), 4*N ), MINWRK ) IF( LQUERY ) THEN DWORK( 1 ) = OPTWRK RETURN END IF END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK( 1 ) = ONE RETURN END IF C C Computations. Note that MB03KD needs reverse ordering of the C factors in the formal matrix product, compared to MA01BD, MB03BA. C In addition, V6 is interchanged with V2, and V5 with V3, compared C to the notation used in section METHOD. C IA11 = 1 ID12 = IA11 + MM IB22 = ID12 + MM IA22 = IB22 + MM ID21 = IA22 + MM IB11 = ID21 + MM IV1 = IB11 + MM IV2 = IV1 + MM IV3 = IV2 + MM IV4 = IV3 + MM IV5 = IV4 + MM IV6 = IV5 + MM MP1 = M + 1 C C Get the machine parameters. C ULP = DLAMCH( 'Precision' ) BASE = DLAMCH( 'Base' ) LGBAS = LOG( BASE ) C C Compute maps to access the factors of the formal matrix product. C K = 6 KSCHUR = 5 IWORK( 2*K+1 ) = -1 IWORK( 2*K+2 ) = 1 IWORK( 2*K+3 ) = -1 IWORK( 2*K+4 ) = -1 IWORK( 2*K+5 ) = 1 IWORK( 2*K+6 ) = -1 CALL MB03BA( K, KSCHUR, IWORK( 2*K+1 ), I, IWORK, IWORK( K+1 ) ) C C Store the factors of the formal matrix product. C DUM( 1 ) = ZERO CALL DCOPY( MM*K, DUM, 0, DWORK, 1 ) CALL DLACPY( 'Upper', M, M, A, LDA, DWORK, M ) CALL DLACPY( 'Upper', M, M, A( MP1, MP1 ), LDA, DWORK( IA22 ), M ) CALL DLACPY( 'Upper', M, M, B, LDB, DWORK( IB11 ), M ) CALL DLACPY( 'Upper', M, M, B( MP1, MP1 ), LDB, DWORK( IB22 ), M ) CALL DLACPY( 'Upper', M, M, D( 1, MP1 ), LDD, DWORK( ID12 ), M ) CALL DLACPY( 'Upper', M, M, D( MP1, 1 ), LDD, DWORK( ID21 ), M ) IF( M.GT.1 ) $ CALL DCOPY( M-1, D( M+2, 1 ), LDD+1, DWORK( ID21+1 ), MP1 ) C C Set BWORK according to the eigenvalues of the formal matrix C product in Schur-triangular form. C Workspace: need 6*M*M + 2. C J = 1 IA = IV1 IB = IA + 1 C C WHILE( J.LE.M ) DO 10 CONTINUE IF( J.LT.M ) THEN IF( DWORK( ID21+J+(J-1)*M ).EQ.ZERO ) THEN CALL MA01BD( BASE, LGBAS, K, IWORK( 2*K+1 ), $ DWORK( (J-1)*M+J ), MM, DWORK( IA ), $ DWORK( IB ), IWORK( 3*K+1 ) ) BWORK( J ) = DWORK( IA ).GT.ZERO .OR. DWORK( IB ).EQ.ZERO J = J + 1 GO TO 10 ELSE BWORK( J ) = .TRUE. BWORK( J+1 ) = .TRUE. J = J + 2 GO TO 10 END IF ELSE IF ( J.EQ.M ) THEN CALL MA01BD( BASE, LGBAS, K, IWORK( 2*K+1 ), DWORK( MM ), MM, $ DWORK( IA ), DWORK( IB ), IWORK( 3*K+1 ) ) BWORK( J ) = DWORK( IA ).GT.ZERO .OR. DWORK( IB ).EQ.ZERO END IF C END WHILE 10 C C Check if BWORK(J) = .TRUE. for all J. C J = 1 C WHILE( J.LE.M and BWORK(J) ) DO 20 CONTINUE IF( J.LE.M .AND. BWORK(J) ) THEN J = J + 1 GO TO 20 END IF C END WHILE 20 C IF( J.NE.MP1 ) THEN C C Apply periodic QZ algorithm for reordering the eigenvalues. C Workspace: need 12*M*M + MAX(42*K + M, 80*K - 48), K = 6, C if there is at least a pair of adjacent blocks C of order 2 involved in reordering, and M > 10. C Otherwise, the MAX term is slightly smaller. C IWRK = 2*IV1 - 1 IB11 = 1 ID21 = IB11 + MM IA22 = ID21 + MM IB22 = IA22 + MM ID12 = IB22 + MM IA11 = ID12 + MM C KSCHUR = 2 C DO 30 I = 1, K IWORK( I ) = M IWORK( K+I ) = 0 IWORK( 3*K+I ) = 1 + ( I - 1 )*MM 30 CONTINUE C CALL DCOPY( MM*K, DUM, 0, DWORK( IB11 ), 1 ) CALL DLACPY( 'Upper', M, M, D( MP1, 1 ), LDD, DWORK( ID21 ), $ M ) CALL DLACPY( 'Upper', M, M, D( 1, MP1 ), LDD, DWORK( ID12 ), $ M ) CALL DLACPY( 'Upper', M, M, A, LDA, DWORK( IA11 ), M ) CALL DLACPY( 'Upper', M, M, A( MP1, MP1 ), LDA, DWORK( IA22 ), $ M ) CALL DLACPY( 'Upper', M, M, B, LDB, DWORK( IB11 ), M ) CALL DLACPY( 'Upper', M, M, B( MP1, MP1 ), LDB, DWORK( IB22 ), $ M ) IF( M.GT.1 ) $ CALL DCOPY( M-1, D( M+2, 1 ), LDD+1, DWORK( ID21+1 ), MP1 ) C CALL MB03KD( 'Initialize', IDUM, 'NotStrong', K, M, KSCHUR, $ IWORK, IWORK( K+1 ), IWORK( 2*K+1 ), BWORK, $ DWORK, IWORK, IWORK( 3*K+1 ), DWORK( IV1 ), $ IWORK, IWORK( 3*K+1 ), M1, HUND2, IWORK( 4*K+1 ), $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) $ RETURN C M2 = M - M1 I1 = M1 + 1 I2 = I1 + M1 I3 = I2 + M2 M4 = 2*M2 C C If Q1, Q2 and/or Q3 are user-initialized, update them. C The (2,1) block of A is used as workspace. C IF( LUPDQ1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1, LDQ1, DWORK( IV2 ), M, ZERO, A( MP1, 1 ), $ LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1, LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1( MP1, 1 ), LDQ1, DWORK( IV2 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1( MP1, 1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1( 1, MP1 ), LDQ1, DWORK( IV5 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1( 1, MP1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q1( MP1, MP1 ), LDQ1, DWORK( IV5 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q1( MP1, MP1 ), $ LDQ1 ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M, Q1( 1, I1 ), LDQ1, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q1( 1, I1 ), LDQ1 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q1( 1, I2 ), LDQ1 ) CALL DLACPY( 'Full', M, M, Q1( MP1, I1 ), LDQ1, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q1( MP1, I1 ), LDQ1 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q1( MP1, I2 ), LDQ1 ) END IF END IF C IF( LUPDQ2 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2, LDQ2, DWORK( IV1 ), M, ZERO, A( MP1, 1 ), $ LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2( MP1, 1 ), LDQ2, DWORK( IV1 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2( MP1, 1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2( 1, MP1 ), LDQ2, DWORK( IV4 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2( 1, MP1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q2( MP1, MP1 ), LDQ2, DWORK( IV4 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q2( MP1, MP1 ), $ LDQ2 ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M, Q2( 1, I1 ), LDQ2, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q2( 1, I1 ), LDQ2 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q2( 1, I2 ), LDQ2 ) CALL DLACPY( 'Full', M, M, Q2( MP1, I1 ), LDQ2, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q2( MP1, I1 ), LDQ2 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q2( MP1, I2 ), LDQ2 ) END IF END IF C IF( LUPDQ3 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q3, LDQ3, DWORK( IV6 ), M, ZERO, A( MP1, 1 ), $ LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q3, LDQ3 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q3( MP1, 1 ), LDQ3, DWORK( IV6 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q3( MP1, 1 ), $ LDQ3 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q3( 1, MP1 ), LDQ3, DWORK( IV3 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q3( 1, MP1 ), $ LDQ3 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q3( MP1, MP1 ), LDQ3, DWORK( IV3 ), M, ZERO, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M, A( MP1, 1 ), LDA, Q3( MP1, MP1 ), $ LDQ3 ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M, Q3( 1, I1 ), LDQ3, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q3( 1, I1 ), LDQ3 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q3( 1, I2 ), LDQ3 ) CALL DLACPY( 'Full', M, M, Q3( MP1, I1 ), LDQ3, $ A( MP1, 1 ), LDA ) CALL DLACPY( 'Full', M, M1, A( MP1, M2+1 ), LDA, $ Q3( MP1, I1 ), LDQ3 ) CALL DLACPY( 'Full', M, M2, A( MP1, 1 ), LDA, $ Q3( MP1, I2 ), LDQ3 ) END IF END IF C C Make permutations of the corresponding matrices. C IF( M2.GT.0 ) THEN CALL DLASET( 'Full', M, M, ZERO, ZERO, A( MP1, 1 ), LDA ) CALL DLACPY( 'Upper', M1, M1, DWORK( IA11 ), M, A, LDA ) CALL DLASET( 'Full', M1, M1, ZERO, ZERO, A( 1, I1 ), LDA ) CALL DLACPY( 'Upper', M1, M1, DWORK( IA22 ), M, A( I1, I1 ), $ LDA ) CALL DLACPY( 'Full', M1, M2, DWORK( IA11+M*M1 ), M, $ A( 1, I2 ), LDA ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, A( I1, I2 ), LDA ) CALL DLACPY( 'Upper', M2, M2, DWORK( IA11+M*M1+M1 ), M, $ A( I2, I2 ), LDA ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, A( 1, I3 ), LDA ) CALL DLACPY( 'Full', M1, M2, DWORK( IA22+M*M1 ), M, $ A( I1, I3 ), LDA ) CALL DLASET( 'Full', M2, M2, ZERO, ZERO, A( I2, I3 ), LDA ) CALL DLACPY( 'Upper', M2, M2, DWORK( IA22+M*M1+M1 ), M, $ A( I3, I3 ), LDA ) C CALL DLASET( 'Full', M, M, ZERO, ZERO, B( MP1, 1 ), LDB ) CALL DLACPY( 'Upper', M1, M1, DWORK( IB11 ), M, B, LDB ) CALL DLASET( 'Full', M1, M1, ZERO, ZERO, B( 1, I1 ), LDB ) CALL DLACPY( 'Upper', M1, M1, DWORK( IB22 ), M, B( I1, I1 ), $ LDB ) CALL DLACPY( 'Full', M1, M2, DWORK( IB11+M*M1 ), M, $ B( 1, I2 ), LDB ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, B( I1, I2 ), LDB ) CALL DLACPY( 'Upper', M2, M2, DWORK( IB11+M*M1+M1 ), M, $ B( I2, I2 ), LDB ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, B( 1, I3 ), LDB ) CALL DLACPY( 'Full', M1, M2, DWORK( IB22+M*M1 ), M, $ B( I1, I3 ), LDB ) CALL DLASET( 'Full', M2, M2, ZERO, ZERO, B( I2, I3 ), LDB ) CALL DLACPY( 'Upper', M2, M2, DWORK( IB22+M*M1+M1 ), M, $ B( I3, I3 ), LDB ) C CALL DLASET( 'Full', M1, M1, ZERO, ZERO, D, LDD ) CALL DLACPY( 'Upper', M1, M1, DWORK( ID21 ), M, D( I1, 1 ), $ LDD ) CALL DCOPY( M1-1, DWORK( ID21+1 ), MP1, D( I1+1, 1 ), $ LDD+1 ) IF( M1.GT.2 ) $ CALL DLASET( 'Lower', M1-2, M1-2, ZERO, ZERO, $ D( I1+2, 1 ), LDD ) CALL DLASET( 'Full', M4, M1, ZERO, ZERO, D( I2, 1 ), LDD ) CALL DLACPY( 'Upper', M1, M1, DWORK( ID12 ), M, D( 1, I1 ), $ LDD ) IF( M1.GT.1 ) $ CALL DLASET( 'Lower', M1-1, M1-1, ZERO, ZERO, D( 2, I1 ), $ LDD ) CALL DLASET( 'Full', N-M1, M1, ZERO, ZERO, D( I1, I1 ), $ LDD ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, D( 1, I2 ), LDD ) CALL DLACPY( 'Full', M1, M2, DWORK( ID21+M*M1 ), M, $ D( I1, I2 ), LDD ) CALL DLASET( 'Full', M2, M2, ZERO, ZERO, D( I2, I2 ), LDD ) CALL DLACPY( 'Upper', M2, M2, DWORK( ID21+M*M1+M1 ), M, $ D( I3, I2 ), LDD ) IF( I3.LT.N ) $ CALL DCOPY( M2-1, DWORK( ID21+M*M1+I1 ), MP1, $ D( I3+1, I2 ), LDD+1 ) IF( M2.GT.2 ) $ CALL DLASET( 'Lower', M2-2, M2-2, ZERO, ZERO, $ D( I3+2, I2 ), LDD ) CALL DLACPY( 'Full', M1, M2, DWORK( ID12+M*M1 ), M, $ D( 1, I3 ), LDD ) CALL DLASET( 'Full', M1, M2, ZERO, ZERO, D( I1, I3 ), LDD ) CALL DLACPY( 'Full', M2, M2, DWORK( ID12+M*M1+M1 ), M, $ D( I2, I3 ), LDD ) CALL DLASET( 'Full', M2, M2, ZERO, ZERO, D( I3, I3 ), LDD ) ELSE CALL DLASET( 'Full', M, M, ZERO, ZERO, A( MP1, 1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, A( 1, MP1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B( MP1, 1 ), LDB ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B( 1, MP1 ), LDB ) CALL DLASET( 'Full', M, M, ZERO, ZERO, D, LDD ) CALL DLASET( 'Full', M, M, ZERO, ZERO, D( MP1, MP1 ), LDD ) END IF C IF( LINIQ1 ) THEN CALL DLACPY( 'Full', M, M1, DWORK( IV2 ), M, Q1, LDQ1 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q1( MP1, 1 ), LDQ1 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q1( 1, I1 ), LDQ1 ) CALL DLACPY( 'Full', M, M1, DWORK( IV5 ), M, Q1( MP1, I1 ), $ LDQ1 ) IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M2, DWORK( IV2+M*M1 ), M, $ Q1( 1, I2 ), LDQ1 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q1( MP1, I2 ), $ LDQ1 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q1( 1, I3 ), $ LDQ1 ) CALL DLACPY( 'Full', M, M2, DWORK( IV5+M*M1 ), M, $ Q1( MP1, I3 ), LDQ1 ) END IF END IF C IF( LINIQ2 ) THEN CALL DLACPY( 'Full', M, M1, DWORK( IV1 ), M, Q2, LDQ2 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q2( MP1, 1 ), LDQ2 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q2( 1, I1 ), LDQ2 ) CALL DLACPY( 'Full', M, M1, DWORK( IV4 ), M, Q2( MP1, I1 ), $ LDQ2 ) IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M2, DWORK( IV1+M*M1 ), M, $ Q2( 1, I2 ), LDQ2 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q2( MP1, I2 ), $ LDQ2 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q2( 1, I3 ), $ LDQ2 ) CALL DLACPY( 'Full', M, M2, DWORK( IV4+M*M1 ), M, $ Q2( MP1, I3 ), LDQ2 ) END IF END IF C IF( LINIQ3 ) THEN CALL DLACPY( 'Full', M, M1, DWORK( IV6 ), M, Q3, LDQ3 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q3( MP1, 1 ), LDQ3 ) CALL DLASET( 'Full', M, M1, ZERO, ZERO, Q3( 1, I1 ), LDQ3 ) CALL DLACPY( 'Full', M, M1, DWORK( IV3 ), M, Q3( MP1, I1 ), $ LDQ3 ) IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', M, M2, DWORK( IV6+M*M1 ), M, $ Q3( 1, I2 ), LDQ3 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q3( MP1, I2 ), $ LDQ3 ) CALL DLASET( 'Full', M, M2, ZERO, ZERO, Q3( 1, I3 ), $ LDQ3 ) CALL DLACPY( 'Full', M, M2, DWORK( IV3+M*M1 ), M, $ Q3( MP1, I3 ), LDQ3 ) END IF END IF C ELSE M1 = M M2 = 0 I1 = M1 + 1 I2 = I1 + M1 I3 = I2 M4 = 2*M2 CALL DLASET( 'Full', M, M, ZERO, ZERO, A( MP1, 1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, A( 1, MP1 ), LDA ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B( MP1, 1 ), LDB ) CALL DLASET( 'Full', M, M, ZERO, ZERO, B( 1, MP1 ), LDB ) CALL DLASET( 'Full', M, M, ZERO, ZERO, D, LDD ) CALL DLASET( 'Full', M, M, ZERO, ZERO, D( MP1, MP1 ), LDD ) IF( LINIQ1 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 ) IF( LINIQ2 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q2, LDQ2 ) IF( LINIQ3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q3, LDQ3 ) END IF C C Count the number of blocks in DD31. C R = 0 J = 1 C WHILE( J.LE.M1 ) DO 40 CONTINUE IF( J.LT.M1 ) THEN R = R + 1 IWORK( R ) = J IF( D( M1+J+1, J ).EQ.ZERO ) THEN J = J + 1 ELSE J = J + 2 END IF GO TO 40 ELSE IF ( J.EQ.M1 ) THEN R = R + 1 IWORK( R ) = J J = J + 1 END IF C END WHILE 40 IWORK( R+1 ) = J C C Triangularize the upper left subpencil aAA1 BB1 - bDD1. C DO 60 K = 1, R C C Calculate position of submatrices in DWORK. C IB1 and IB2 are pointers to 2 consecutive blocks. C IB1 = IWORK( K ) IB2 = IWORK( K+1 ) DIM1 = IB2 - IB1 SDIM = 2*DIM1 C IAUPLE = 1 IALOLE = IAUPLE + DIM1 IAUPRI = DIM1*SDIM + 1 IALORI = IAUPRI + DIM1 IBUPLE = SDIM*SDIM + 1 IBLOLE = IBUPLE + DIM1 IBUPRI = 3*DIM1*SDIM + 1 IBLORI = IBUPRI + DIM1 IDUPLE = 2*SDIM*SDIM + 1 IDLOLE = IDUPLE + DIM1 IDUPRI = 5*DIM1*SDIM + 1 IDLORI = IDUPRI + DIM1 I1UPLE = 3*SDIM*SDIM + 1 I1LOLE = I1UPLE + DIM1 I1UPRI = 7*DIM1*SDIM + 1 I1LORI = I1UPRI + DIM1 I2UPLE = 4*SDIM*SDIM + 1 I2LOLE = I2UPLE + DIM1 I2UPRI = 9*DIM1*SDIM + 1 I2LORI = I2UPRI + DIM1 I3UPLE = 5*SDIM*SDIM + 1 I3LOLE = I3UPLE + DIM1 I3UPRI = 11*DIM1*SDIM + 1 I3LORI = I3UPRI + DIM1 C C Generate input matrices for MB03ED built of submatrices of A, B C and D. C Workspace: need 48. C IF( DIM1.EQ.1 ) THEN CALL DCOPY( SDIM, A( IB1, IB1 ), ( LDA+1 )*M1, $ DWORK( IAUPLE ), SDIM+1 ) CALL DCOPY( SDIM, B( IB1, IB1 ), ( LDB+1 )*M1, $ DWORK( IBUPLE ), SDIM+1 ) CALL DCOPY( SDIM, D( M1+IB1, IB1 ), ( LDD-1 )*M1, $ DWORK( IDLOLE ), 1 ) ELSE CALL DLACPY( 'Full', DIM1, DIM1, A( IB1, IB1 ), LDA, $ DWORK( IAUPLE ), SDIM ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IALOLE ), SDIM ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IAUPRI ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, A( M1+IB1, M1+IB1 ), LDA, $ DWORK( IALORI ), SDIM ) C CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, IB1 ), LDB, $ DWORK( IBUPLE ), SDIM ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IBLOLE ), SDIM ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IBUPRI ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, B( M1+IB1, M1+IB1 ), LDB, $ DWORK( IBLORI ), SDIM ) C CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IDUPLE ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, D( M1+IB1, IB1 ), LDD, $ DWORK( IDLOLE ), SDIM ) CALL DLACPY( 'Full', DIM1, DIM1, D( IB1, M1+IB1 ), LDD, $ DWORK( IDUPRI ), SDIM ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ DWORK( IDLORI ), SDIM ) END IF C C Perform eigenvalue exchange. C Workspace: need 96 + max( 79, 4*N ). C IWRK = 6*SDIM*SDIM + 1 ITMP = IWRK + DIM1*M ITMP2 = ITMP + DIM1*M ITMP3 = ITMP2 + DIM1*DIM1 C CALL MB03ED( SDIM, ULP, DWORK( IAUPLE ), SDIM, DWORK( IBUPLE ), $ SDIM, DWORK( IDUPLE ), SDIM, DWORK( I1UPLE ), $ SDIM, DWORK( I2UPLE ), SDIM, DWORK( I3UPLE ), $ SDIM, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 3 RETURN END IF C NR = IB2 - 1 C IF( DIM1.EQ.2 ) THEN C C Update A. C CALL DLACPY( 'Full', NR, DIM1, A( 1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I2UPLE ), SDIM, $ ZERO, A( 1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, A( 1, M1+IB1 ), LDA, DWORK( I2LOLE ), $ SDIM, ONE, A( 1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I2UPRI ), SDIM, $ ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, A( 1, M1+IB1 ), LDA, DWORK( I2LORI ), $ SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ A( 1, M1+IB1 ), LDA ) C CALL DLACPY( 'Full', NR, DIM1, A( I1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I2UPLE ), SDIM, $ ZERO, A( I1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, A( I1, M1+IB1 ), LDA, DWORK( I2LOLE ), $ SDIM, ONE, A( I1, IB1 ), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I2UPRI ), SDIM, $ ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, A( I1, M1+IB1 ), LDA, DWORK( I2LORI ), $ SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ A( I1, M1+IB1 ), LDA ) C CALL DLACPY( 'Full', DIM1, DIM1, A( M1+IB1, IB1 ), LDA, $ DWORK( ITMP2 ), DIM1 ) CALL DLACPY( 'Full', DIM1, DIM1, A( IB1, M1+IB1 ), LDA, $ DWORK( ITMP3 ), DIM1 ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ A( M1+IB1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB2+1, $ DIM1, ONE, DWORK( I3UPRI ), SDIM, $ A( IB1, IB2 ), LDA, ZERO, A( M1+IB1, IB2 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ A( IB1, IB1 ), LDA, ZERO, DWORK( ITMP ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I3LOLE ), SDIM, DWORK( ITMP2 ), $ DIM1, ONE, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ A( IB1, IB1 ), LDA ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I3LOLE ), SDIM, $ A( M1+IB1, M1+IB1 ), LDA, ZERO, $ A( IB1, M1+IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I3UPLE ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, A( IB1, M1+IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I3LORI ), SDIM, $ A( M1+IB1, M1+IB1 ), LDA, ZERO, DWORK( ITMP ), $ DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I3UPRI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ A( M1+IB1, M1+IB1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I3UPRI ), SDIM, A( IB1, I2 ), $ LDA, ZERO, A( M1+IB1, I2), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I3UPLE ), SDIM, A( IB1, I2 ), $ LDA, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ A( IB1, I2 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I3LOLE ), SDIM, A( M1+IB1, I3 ), $ LDA, ZERO, A( IB1, I3 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I3LORI ), SDIM, A( M1+IB1, I3 ), $ LDA, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ A( M1+IB1, I3 ), LDA ) END IF C C Update B. C CALL DLACPY( 'Full', NR, DIM1, B( 1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), SDIM, $ ZERO, B( 1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, B( 1, M1+IB1 ), LDB, DWORK( I1LOLE ), $ SDIM, ONE, B( 1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), SDIM, $ ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, B( 1, M1+IB1 ), LDB, DWORK( I1LORI ), $ SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ B( 1, M1+IB1 ), LDB ) C CALL DLACPY( 'Full', NR, DIM1, B( I1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), SDIM, $ ZERO, B( I1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, B( I1, M1+IB1 ), LDB, DWORK( I1LOLE ), $ SDIM, ONE, B( I1, IB1 ), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), SDIM, $ ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, B( I1, M1+IB1 ), LDB, DWORK( I1LORI ), $ SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ B( I1, M1+IB1 ), LDB ) C CALL DLACPY( 'Full', DIM1, DIM1, B( M1+IB1, IB1 ), LDB, $ DWORK( ITMP2 ), DIM1 ) CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, M1+IB1 ), LDB, $ DWORK( ITMP3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB2+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ B( IB1, IB2 ), LDB, ZERO, B( M1+IB1, IB2 ), $ LDB ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ B( M1+IB1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ B( IB1, IB1 ), LDB, ZERO, DWORK( ITMP ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2LOLE ), SDIM, DWORK( ITMP2 ), $ DIM1, ONE, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ B( IB1, IB1 ), LDB ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IB1, M1+IB1 ), LDB, ZERO, $ B( IB1, M1+IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2UPLE ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, B( IB1, M1+IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IB1, M1+IB1 ), LDB, ZERO, DWORK( ITMP ), $ DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I2UPRI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ B( M1+IB1, M1+IB1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2UPRI ), SDIM, B( IB1, I2 ), $ LDB, ZERO, B( M1+IB1, I2), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2UPLE ), SDIM, B( IB1, I2 ), $ LDB, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ B( IB1, I2 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2LOLE ), SDIM, B( M1+IB1, I3 ), $ LDB, ZERO, B( IB1, I3 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I2LORI ), SDIM, B( M1+IB1, I3 ), $ LDB, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ B( M1+IB1, I3 ), LDB ) END IF C C Update D. C CALL DLACPY( 'Full', NR, DIM1, D( 1, IB1 ), LDD, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), SDIM, $ ZERO, D( 1, IB1 ), LDD ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, D( 1, M1+IB1 ), LDD, DWORK( I1LOLE ), $ SDIM, ONE, D( 1, IB1 ), LDD ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), SDIM, $ ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, D( 1, M1+IB1 ), LDD, DWORK( I1LORI ), $ SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ D( 1, M1+IB1 ), LDD ) C CALL DLACPY( 'Full', NR, DIM1, D( I1, IB1 ), LDD, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I1UPLE ), SDIM, $ ZERO, D( I1, IB1 ), LDD ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, D( I1, M1+IB1 ), LDD, DWORK( I1LOLE ), $ SDIM, ONE, D( I1, IB1 ), LDD ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, DWORK( IWRK ), NR, DWORK( I1UPRI ), SDIM, $ ZERO, DWORK( ITMP ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, DIM1, $ ONE, D( I1, M1+IB1 ), LDD, DWORK( I1LORI ), $ SDIM, ONE, DWORK( ITMP ), NR ) CALL DLACPY( 'Full', NR, DIM1, DWORK( ITMP ), NR, $ D( I1, M1+IB1 ), LDD ) C CALL DLACPY( 'Full', DIM1, DIM1, D( IB1, IB1 ), LDD, $ DWORK( ITMP2 ), DIM1 ) CALL DLACPY( 'Full', DIM1, DIM1, D( M1+IB1, M1+IB1 ), LDD, $ DWORK( ITMP3 ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I3LOLE ), SDIM, $ D( M1+IB1, IB1 ), LDD, ZERO, D( IB1, IB1 ), $ LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I3UPLE ), SDIM, DWORK( ITMP2 ), $ DIM1, ONE, D( IB1, IB1 ), LDD ) CALL DLASET( 'Full', DIM1, DIM1, ZERO, ZERO, $ D( M1+IB1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I3LORI ), SDIM, $ D( M1+IB1, IB1+1 ), LDD, ZERO, DWORK( ITMP ), $ DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ D( M1+IB1, IB1+1 ), LDD ) C CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I3UPRI ), SDIM, $ D( IB1, M1+IB1 ), LDD, ZERO, $ D( M1+IB1, M1+IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I3LORI ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, D( M1+IB1, M1+IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ D( IB1, M1+IB1 ), LDD, ZERO, DWORK( ITMP ), $ DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1, $ ONE, DWORK( I3LOLE ), SDIM, DWORK( ITMP3 ), $ DIM1, ONE, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M1-IB1+1, DWORK( ITMP ), DIM1, $ D( IB1, M1+IB1 ), LDD ) C IF( M2.GT.0 ) THEN CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I3LOLE ), SDIM, D( M1+IB1, I2 ), $ LDD, ZERO, D( IB1, I2), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I3LORI ), SDIM, D( M1+IB1, I2 ), $ LDD, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ D( M1+IB1, I2 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I3UPRI ), SDIM, D( IB1, I3 ), $ LDD, ZERO, D( M1+IB1, I3), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M2, DIM1, $ ONE, DWORK( I3UPLE ), SDIM, D( IB1, I3 ), $ LDD, ZERO, DWORK( ITMP ), DIM1 ) CALL DLACPY( 'Full', DIM1, M2, DWORK( ITMP ), DIM1, $ D( IB1, I3 ), LDD ) END IF C ITMP = IWRK + N*DIM1 C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DLACPY( 'Full', N, DIM1, Q1( 1, IB1 ), LDQ1, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPLE ), SDIM, ZERO, Q1( 1, IB1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q1( 1, M1+IB1 ), LDQ1, $ DWORK( I1LOLE ), SDIM, ONE, Q1( 1, IB1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q1( 1, M1+IB1 ), LDQ1, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( ITMP ), N, $ Q1( 1, M1+IB1 ), LDQ1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DLACPY( 'Full', N, DIM1, Q2( 1, IB1 ), LDQ2, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPLE ), SDIM, ZERO, Q2( 1, IB1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q2( 1, M1+IB1 ), LDQ2, $ DWORK( I2LOLE ), SDIM, ONE, Q2( 1, IB1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPRI ), SDIM, ZERO, DWORK( ITMP ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q2( 1, M1+IB1 ), LDQ2, $ DWORK( I2LORI ), SDIM, ONE, DWORK( ITMP ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( ITMP ), N, $ Q2( 1, M1+IB1 ), LDQ2 ) END IF C IF( LCMPQ3 ) THEN C C Update Q3. C CALL DLACPY( 'Full', N, DIM1, Q3( 1, IB1 ), LDQ3, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I3UPLE ), SDIM, ZERO, Q3( 1, IB1 ), $ LDQ3 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q3( 1, M1+IB1 ), LDQ3, $ DWORK( I3LOLE ), SDIM, ONE, Q3( 1, IB1 ), $ LDQ3 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I3UPRI ), SDIM, ZERO, DWORK( ITMP ), $ N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, Q3( 1, M1+IB1 ), LDQ3, $ DWORK( I3LORI ), SDIM, ONE, DWORK( ITMP ), $ N ) CALL DLACPY( 'Full', N, DIM1, DWORK( ITMP ), N, $ Q3( 1, M1+IB1 ), LDQ3 ) END IF C ELSE C C Update A. C CALL DCOPY( NR, A( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I2UPLE ), A( 1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I2LOLE ), A( 1, M1+IB1 ), 1, $ A( 1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I2LORI ), A( 1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ A( 1, M1+IB1 ), 1 ) C CALL DCOPY( NR, A( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I2UPLE ), A( I1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I2LOLE ), A( I1, M1+IB1 ), 1, $ A( I1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I2LORI ), A( I1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ A( I1, M1+IB1 ), 1 ) C TMP2 = A( M1+IB1, IB1 ) TMP3 = A( IB1, M1+IB1 ) IF( M1.GT.IB1 ) THEN CALL DCOPY( M1-IB1, A( IB1, IB1+1 ), LDA, $ A( M1+IB1, IB1+1 ), LDA ) CALL DSCAL( M1-IB1, DWORK( I3UPRI ), A( M1+IB1, IB1+1 ), $ LDA ) END IF A( M1+IB1, IB1 ) = ZERO CALL DSCAL( M1-IB1+1, DWORK( I3UPLE ), A( IB1, IB1 ), LDA ) A( IB1, IB1 ) = A( IB1, IB1 ) + DWORK( I3LOLE )*TMP2 C CALL DCOPY( M1-IB1+1, A( M1+IB1, M1+IB1 ), LDA, $ A( IB1, M1+IB1 ), LDA ) CALL DSCAL( M1-IB1+1, DWORK( I3LOLE ), A( IB1, M1+IB1 ), $ LDA ) A( IB1, M1+IB1 ) = A( IB1, M1+IB1 ) + DWORK( I3UPLE )*TMP3 CALL DSCAL( M1-IB1+1, DWORK( I3LORI ), A( M1+IB1, M1+IB1 ), $ LDA ) A( M1+IB1, M1+IB1 ) = A( M1+IB1, M1+IB1 ) + $ DWORK( I3UPRI )*TMP3 C IF( M2.GT.0 ) THEN CALL DCOPY( M2, A( IB1, I2 ), LDA, A( M1+IB1, I2 ), LDA ) CALL DSCAL( M2, DWORK( I3UPRI ), A( M1+IB1, I2 ), LDA ) CALL DSCAL( M2, DWORK( I3UPLE ), A( IB1, I2 ), LDA ) CALL DCOPY( M2, A( M1+IB1, I3 ), LDA, A( IB1, I3 ), LDA ) CALL DSCAL( M2, DWORK( I3LOLE ), A( IB1, I3 ), LDA ) CALL DSCAL( M2, DWORK( I3LORI ), A( M1+IB1, I3 ), LDA ) END IF C C Update B. C CALL DCOPY( NR, B( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), B( 1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), B( 1, M1+IB1 ), 1, $ B( 1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), B( 1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( 1, M1+IB1 ), 1 ) C CALL DCOPY( NR, B( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), B( I1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), B( I1, M1+IB1 ), 1, $ B( I1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), B( I1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( I1, M1+IB1 ), 1 ) C TMP2 = B( M1+IB1, IB1 ) TMP3 = B( IB1, M1+IB1 ) IF( M1.GT.IB1 ) THEN CALL DCOPY( M1-IB1, B( IB1, IB1+1 ), LDB, $ B( M1+IB1, IB1+1 ), LDB ) CALL DSCAL( M1-IB1, DWORK( I2UPRI ), B( M1+IB1, IB1+1 ), $ LDB ) END IF B( M1+IB1, IB1 ) = ZERO CALL DSCAL( M1-IB1+1, DWORK( I2UPLE ), B( IB1, IB1 ), LDB ) B( IB1, IB1 ) = B( IB1, IB1 ) + DWORK( I2LOLE )*TMP2 C CALL DCOPY( M1-IB1+1, B( M1+IB1, M1+IB1 ), LDB, $ B( IB1, M1+IB1 ), LDB ) CALL DSCAL( M1-IB1+1, DWORK( I2LOLE ), B( IB1, M1+IB1 ), $ LDB ) B( IB1, M1+IB1 ) = B( IB1, M1+IB1 ) + DWORK( I2UPLE )*TMP3 CALL DSCAL( M1-IB1+1, DWORK( I2LORI ), B( M1+IB1, M1+IB1 ), $ LDB ) B( M1+IB1, M1+IB1 ) = B( M1+IB1, M1+IB1 ) + $ DWORK( I2UPRI )*TMP3 C IF( M2.GT.0 ) THEN CALL DCOPY( M2, B( IB1, I2 ), LDB, B( M1+IB1, I2 ), LDB ) CALL DSCAL( M2, DWORK( I2UPRI ), B( M1+IB1, I2 ), LDB ) CALL DSCAL( M2, DWORK( I2UPLE ), B( IB1, I2 ), LDB ) CALL DCOPY( M2, B( M1+IB1, I3 ), LDB, B( IB1, I3 ), LDB ) CALL DSCAL( M2, DWORK( I2LOLE ), B( IB1, I3 ), LDB ) CALL DSCAL( M2, DWORK( I2LORI ), B( M1+IB1, I3 ), LDB ) END IF C C Update D. C CALL DCOPY( NR, D( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), D( 1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), D( 1, M1+IB1 ), 1, $ D( 1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), D( 1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ D( 1, M1+IB1 ), 1 ) C CALL DCOPY( NR, D( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), D( I1, IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1LOLE ), D( I1, M1+IB1 ), 1, $ D( I1, IB1 ), 1 ) CALL DSCAL( NR, DWORK( I1LORI ), D( I1, M1+IB1 ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ D( I1, M1+IB1 ), 1 ) C TMP2 = D( IB1, IB1 ) TMP3 = D( M1+IB1, M1+IB1 ) CALL DCOPY( M1-IB1+1, D( M1+IB1, IB1 ), LDD, D( IB1, IB1 ), $ LDD ) CALL DSCAL( M1-IB1+1, DWORK( I3LOLE ), D( IB1, IB1 ), LDD ) D( IB1, IB1 ) = D( IB1, IB1 ) + DWORK( I3UPLE )*TMP2 D( M1+IB1, IB1 ) = ZERO CALL DSCAL( M1-IB1+1, DWORK( I3LORI ), D( M1+IB1, IB1+1 ), $ LDD ) C CALL DCOPY( M1-IB1+1, D( IB1, M1+IB1 ), LDD, $ D( M1+IB1, M1+IB1 ), LDD ) CALL DSCAL( M1-IB1+1, DWORK( I3UPRI ), D( M1+IB1, M1+IB1 ), $ LDD ) D( M1+IB1, M1+IB1 ) = D( M1+IB1, M1+IB1 ) + $ DWORK( I3LORI )*TMP3 CALL DSCAL( M1-IB1+1, DWORK( I3UPLE ), D( IB1, M1+IB1 ), $ LDD ) D( IB1, M1+IB1 ) = D( IB1, M1+IB1 ) + DWORK( I3LOLE )*TMP3 C IF( M2.GT.0 ) THEN CALL DCOPY( M2, D( M1+IB1, I2 ), LDD, D( IB1, I2 ), LDD ) CALL DSCAL( M2, DWORK( I3LOLE ), D( IB1, I2 ), LDD ) CALL DSCAL( M2, DWORK( I3LORI ), D( M1+IB1, I2 ), LDD ) CALL DCOPY( M2, D( IB1, I3 ), LDD, D( M1+IB1, I3 ), LDD ) CALL DSCAL( M2, DWORK( I3UPRI ), D( M1+IB1, I3 ), LDD ) CALL DSCAL( M2, DWORK( I3UPLE ), D( IB1, I3 ), LDD ) END IF C ITMP = IWRK + N C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DCOPY( N, Q1( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I1UPLE ), Q1( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I1LOLE ), Q1( 1, M1+IB1 ), 1, $ Q1( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I1LORI ), Q1( 1, M1+IB1 ), 1 ) CALL DAXPY( N, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ Q1( 1, M1+IB1 ), 1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DCOPY( N, Q2( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I2UPLE ), Q2( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I2LOLE ), Q2( 1, M1+IB1 ), 1, $ Q2( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I2LORI ), Q2( 1, M1+IB1 ), 1 ) CALL DAXPY( N, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ Q2( 1, M1+IB1 ), 1 ) END IF C IF( LCMPQ3 ) THEN C C Update Q3. C CALL DCOPY( N, Q3( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I3UPLE ), Q3( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I3LOLE ), Q3( 1, M1+IB1 ), 1, $ Q3( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I3LORI ), Q3( 1, M1+IB1 ), 1 ) CALL DAXPY( N, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ Q3( 1, M1+IB1 ), 1 ) END IF C END IF C DO 50 J = K - 1, 1, -1 C C Calculate position of submatrices in DWORK. C IJ1 = IWORK( J ) IJ2 = IWORK( J+1 ) DIM1 = IWORK( K+1 ) - IWORK( K ) DIM2 = IJ2 - IJ1 SDIM = DIM1 + DIM2 C IAUPLE = 1 IALOLE = IAUPLE + DIM1 IAUPRI = DIM1*SDIM + 1 IALORI = IAUPRI + DIM1 IBUPLE = SDIM*SDIM + 1 IBLOLE = IBUPLE + DIM1 IBUPRI = SDIM*SDIM + DIM1*SDIM + 1 IBLORI = IBUPRI + DIM1 IDUPLE = 2*SDIM*SDIM + 1 IDLOLE = IDUPLE + DIM1 IDUPRI = 2*SDIM*SDIM + DIM1*SDIM + 1 IDLORI = IDUPRI + DIM1 I1UPLE = 3*SDIM*SDIM + 1 I1LOLE = I1UPLE + DIM1 I1UPRI = 3*SDIM*SDIM + DIM1*SDIM + 1 I1LORI = I1UPRI + DIM1 I2UPLE = 4*SDIM*SDIM + 1 I2LOLE = I2UPLE + DIM1 I2UPRI = 4*SDIM*SDIM + DIM1*SDIM + 1 I2LORI = I2UPRI + DIM1 I3UPLE = 5*SDIM*SDIM + 1 I3LOLE = I3UPLE + DIM1 I3UPRI = 5*SDIM*SDIM + DIM1*SDIM + 1 I3LORI = I3UPRI + DIM1 C C Generate input matrices for MB03CD built of submatrices of A, C B and D. C Workspace: need 48. C IF( DIM1.EQ.2 .AND. DIM2.EQ.2 ) THEN CALL DLACPY( 'Full', DIM1, DIM1, A( IB1, IB1 ), LDA, $ DWORK( IAUPLE ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM1, A( M1+IJ1, IB1 ), LDA, $ DWORK( IALOLE ), SDIM ) CALL DLASET( 'Full', DIM1, DIM2, ZERO, ZERO, $ DWORK( IAUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, A( M1+IJ1, M1+IJ1 ), $ LDA, DWORK( IALORI ), SDIM ) C CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, IB1 ), LDB, $ DWORK( IBUPLE ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM1, B( M1+IJ1, IB1 ), LDB, $ DWORK( IBLOLE ), SDIM ) CALL DLASET( 'Full', DIM1, DIM2, ZERO, ZERO, $ DWORK( IBUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, B( M1+IJ1, M1+IJ1 ), $ LDB, DWORK( IBLORI ), SDIM ) C CALL DLACPY( 'Full', DIM1, DIM1, D( IB1, IB1 ), LDD, $ DWORK( IDUPLE ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM1, D( M1+IJ1, IB1 ), LDD, $ DWORK( IDLOLE ), SDIM ) CALL DLASET( 'Full', DIM1, DIM2, ZERO, ZERO, $ DWORK( IDUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, D( M1+IJ1, M1+IJ1 ), $ LDD, DWORK( IDLORI ), SDIM ) C ELSE IF( DIM1.EQ.1 .AND. DIM2.EQ.2 ) THEN DWORK( IAUPLE ) = A( IB1, IB1 ) CALL DCOPY( DIM2, A( M1+IJ1, IB1 ), 1, DWORK( IALOLE ), $ 1 ) CALL DCOPY( DIM2, DUM, 0, DWORK( IAUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, A( M1+IJ1, M1+IJ1 ), $ LDA, DWORK( IALORI ), SDIM ) C DWORK( IBUPLE ) = B( IB1, IB1 ) CALL DCOPY( DIM2, B( M1+IJ1, IB1 ), 1, DWORK( IBLOLE ), $ 1 ) CALL DCOPY( DIM2, DUM, 0, DWORK( IBUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, B( M1+IJ1, M1+IJ1 ), $ LDB, DWORK( IBLORI ), SDIM ) C DWORK( IDUPLE ) = D( IB1, IB1 ) CALL DCOPY( DIM2, D( M1+IJ1, IB1 ), 1, DWORK( IDLOLE ), $ 1 ) CALL DCOPY( DIM2, DUM, 0, DWORK( IDUPRI ), SDIM ) CALL DLACPY( 'Full', DIM2, DIM2, D( M1+IJ1, M1+IJ1 ), $ LDD, DWORK( IDLORI ), SDIM ) C ELSE IF( DIM1.EQ.2 .AND. DIM2.EQ.1 ) THEN CALL DLACPY( 'Full', DIM1, DIM1, A( IB1, IB1 ), LDA, $ DWORK( IAUPLE ), SDIM ) CALL DCOPY( DIM1, A( M1+IJ1, IB1 ), LDA, DWORK( IALOLE ), $ SDIM ) CALL DCOPY( DIM1, DUM, 0, DWORK( IAUPRI ), 1 ) DWORK( IALORI ) = A( M1+IJ1, M1+IJ1 ) C CALL DLACPY( 'Full', DIM1, DIM1, B( IB1, IB1 ), LDB, $ DWORK( IBUPLE ), SDIM ) CALL DCOPY( DIM1, B( M1+IJ1, IB1 ), LDB, DWORK( IBLOLE ), $ SDIM ) CALL DCOPY( DIM1, DUM, 0, DWORK( IBUPRI ), 1 ) DWORK( IBLORI ) = B( M1+IJ1, M1+IJ1 ) C CALL DLACPY( 'Full', DIM1, DIM1, D( IB1, IB1 ), LDD, $ DWORK( IDUPLE ), SDIM ) CALL DCOPY( DIM1, D( M1+IJ1, IB1 ), LDD, DWORK( IDLOLE ), $ SDIM ) CALL DCOPY( DIM1, DUM, 0, DWORK( IDUPRI ), 1 ) DWORK( IDLORI ) = D( M1+IJ1, M1+IJ1 ) C ELSE DWORK( IAUPLE ) = A( IB1, IB1 ) DWORK( IALOLE ) = A( M1+IJ1, IB1 ) DWORK( IAUPRI ) = ZERO DWORK( IALORI ) = A( M1+IJ1, M1+IJ1 ) C DWORK( IBUPLE ) = B( IB1, IB1 ) DWORK( IBLOLE ) = B( M1+IJ1, IB1 ) DWORK( IBUPRI ) = ZERO DWORK( IBLORI ) = B( M1+IJ1, M1+IJ1 ) C DWORK( IDUPLE ) = D( IB1, IB1 ) DWORK( IDLOLE ) = D( M1+IJ1, IB1 ) DWORK( IDUPRI ) = ZERO DWORK( IDLORI ) = D( M1+IJ1, M1+IJ1 ) C END IF C C Perform upper triangularization. C Workspace: need 96 + max( 75, 4*N ). C IWRK = 6*SDIM*SDIM + 1 ITMP = IWRK + 2*N C CALL MB03CD( 'Lower', DIM1, DIM2, ULP, DWORK( IAUPLE ), $ SDIM, DWORK( IBUPLE ), SDIM, DWORK( IDUPLE ), $ SDIM, DWORK( I1UPLE ), SDIM, DWORK( I2UPLE ), $ SDIM, DWORK( I3UPLE ), SDIM, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN IF( INFO.LE.2 ) THEN INFO = 2 ELSE IF( INFO.LE.4 ) THEN INFO = 3 ELSE INFO = 4 END IF RETURN END IF C NROW = IJ2 - 1 C IF( DIM1.EQ.2 .AND. DIM2.EQ.2 ) THEN C C Update A. C CALL DLACPY( 'Full', NR, DIM1, A( 1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I2UPLE ), SDIM, ZERO, A( 1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM1, DIM2, ONE, A( 1, M1+IJ1 ), LDA, $ DWORK( I2LOLE ), SDIM, ONE, A( 1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM2, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I2UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM2, DIM2, ONE, A( 1, M1+IJ1 ), LDA, $ DWORK( I2LORI ), SDIM, ONE, DWORK( ITMP ), $ NR ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ A( 1, M1+IJ1 ), LDA ) C CALL DLACPY( 'Full', NROW, DIM1, A( I1, IB1 ), LDA, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I2UPLE ), SDIM, ZERO, A( I1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM2, ONE, A( I1, M1+IJ1 ), LDA, $ DWORK( I2LOLE ), SDIM, ONE, A( I1, IB1 ), $ LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I2UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, A( I1, M1+IJ1 ), LDA, $ DWORK( I2LORI ), SDIM, ONE, DWORK( ITMP ), $ NROW ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ A( I1, M1+IJ1 ), LDA ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, A( IB1, IB1 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, IB1 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM2, ONE, DWORK( I3LOLE ), SDIM, $ A( M1+IJ1, IB1 ), LDA, ONE, A( IB1, IB1 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM1, ONE, DWORK( I3UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ A( M1+IJ1, IB1 ), LDA, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, IB1 ), LDA ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, A( IB1, M1+IJ1 ), $ LDA, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, M1+IJ1 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM2, ONE, DWORK( I3LOLE ), SDIM, $ A( M1+IJ1, M1+IJ1 ), LDA, ONE, $ A( IB1, M1+IJ1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM1, ONE, DWORK( I3UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ A( M1+IJ1, M1+IJ1 ), LDA, ONE, $ DWORK( ITMP ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, A( IB1, I2 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, I2 ), $ LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM2, ONE, DWORK( I3LOLE ), SDIM, $ A( M1+IJ1, I2 ), LDA, ONE, $ A( IB1, I2 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM1, ONE, DWORK( I3UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ A( M1+IJ1, I2 ), LDA, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DLACPY( 'Full', NR, DIM1, B( 1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, B( 1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM1, DIM2, ONE, B( 1, M1+IJ1 ), LDB, $ DWORK( I1LOLE ), SDIM, ONE, B( 1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM2, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM2, DIM2, ONE, B( 1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NR ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ B( 1, M1+IJ1 ), LDB ) C CALL DLACPY( 'Full', NROW, DIM1, B( I1, IB1 ), LDB, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, B( I1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM2, ONE, B( I1, M1+IJ1 ), LDB, $ DWORK( I1LOLE ), SDIM, ONE, B( I1, IB1 ), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, B( I1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NROW ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ B( I1, M1+IJ1 ), LDB ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, B( IB1, IB1 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, IB1 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IJ1, IB1 ), LDB, ONE, B( IB1, IB1 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, IB1 ), LDB, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, IB1 ), LDB ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, B( IB1, M1+IJ1 ), $ LDB, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, M1+IJ1 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IJ1, M1+IJ1 ), LDB, ONE, $ B( IB1, M1+IJ1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, M1+IJ1 ), LDB, ONE, $ DWORK( ITMP ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, B( IB1, I2 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, I2 ), $ LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM2, ONE, DWORK( I2LOLE ), SDIM, $ B( M1+IJ1, I2 ), LDB, ONE, $ B( IB1, I2 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM1, ONE, DWORK( I2UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, I2 ), LDB, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ B( M1+IJ1, I2 ), LDB ) END IF C C Update D. C CALL DLACPY( 'Full', NR, DIM1, D( 1, IB1 ), LDD, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, D( 1, IB1 ), $ LDD ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM1, DIM2, ONE, D( 1, M1+IJ1 ), LDD, $ DWORK( I1LOLE ), SDIM, ONE, D( 1, IB1 ), $ LDD ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM2, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-DIM1, $ DIM2, DIM2, ONE, D( 1, M1+IJ1 ), LDD, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NR ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ D( 1, M1+IJ1 ), LDD ) C CALL DLACPY( 'Full', NROW, DIM1, D( I1, IB1 ), LDD, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, D( I1, IB1 ), $ LDD ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM2, ONE, D( I1, M1+IJ1 ), LDD, $ DWORK( I1LOLE ), SDIM, ONE, D( I1, IB1 ), $ LDD ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPRI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, D( I1, M1+IJ1 ), LDD, $ DWORK( I1LORI ), SDIM, ONE, DWORK( ITMP ), $ NROW ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ D( I1, M1+IJ1 ), LDD ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, D( IB1, IB1 ), LDD, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, D( IB1, IB1 ), $ LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM2, ONE, DWORK( I3LOLE ), SDIM, $ D( M1+IJ1, IB1 ), LDD, ONE, D( IB1, IB1 ), $ LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM1, ONE, DWORK( I3UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ D( M1+IJ1, IB1 ), LDD, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ D( M1+IJ1, IB1 ), LDD ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, D( IB1, M1+IJ1 ), $ LDD, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, D( IB1, M1+IJ1 ), $ LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM2, ONE, DWORK( I3LOLE ), SDIM, $ D( M1+IJ1, M1+IJ1 ), LDD, ONE, $ D( IB1, M1+IJ1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM1, ONE, DWORK( I3UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ D( M1+IJ1, M1+IJ1 ), LDD, ONE, $ DWORK( ITMP ),DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ D( M1+IJ1, M1+IJ1 ), LDD ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, D( IB1, I2 ), LDD, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, D( IB1, I2 ), $ LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM2, ONE, DWORK( I3LOLE ), SDIM, $ D( M1+IJ1, I2 ), LDD, ONE, $ D( IB1, I2 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM1, ONE, DWORK( I3UPRI ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ D( M1+IJ1, I2 ), LDD, ONE, DWORK( ITMP ), $ DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ D( M1+IJ1, I2 ), LDD ) END IF C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DLACPY( 'Full', N, DIM1, Q1( 1, IB1 ), LDQ1, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPLE ), SDIM, ZERO, $ Q1( 1, IB1 ), LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM2, ONE, Q1( 1, M1+IJ1 ), LDQ1, $ DWORK( I1LOLE ), SDIM, ONE, Q1( 1, IB1 ), $ LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPRI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q1( 1, M1+IJ1 ), LDQ1, $ DWORK( I1LORI ), SDIM, ONE, $ DWORK( ITMP ), N ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q1( 1, M1+IJ1 ), LDQ1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DLACPY( 'Full', N, DIM1, Q2( 1, IB1 ), LDQ2, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPLE ), SDIM, ZERO, $ Q2( 1, IB1 ), LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM2, ONE, Q2( 1, M1+IJ1 ), LDQ2, $ DWORK( I2LOLE ), SDIM, ONE, Q2( 1, IB1 ), $ LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPRI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q2( 1, M1+IJ1 ), LDQ2, $ DWORK( I2LORI ), SDIM, ONE, $ DWORK( ITMP ), N ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q2( 1, M1+IJ1 ), LDQ2 ) END IF C IF( LCMPQ3 ) THEN C C Update Q3. C CALL DLACPY( 'Full', N, DIM1, Q3( 1, IB1 ), LDQ3, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I3UPLE ), SDIM, ZERO, $ Q3( 1, IB1 ), LDQ3 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM2, ONE, Q3( 1, M1+IJ1 ), LDQ3, $ DWORK( I3LOLE ), SDIM, ONE, Q3( 1, IB1 ), $ LDQ3 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I3UPRI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q3( 1, M1+IJ1 ), LDQ3, $ DWORK( I3LORI ), SDIM, ONE, $ DWORK( ITMP ), N ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q3( 1, M1+IJ1 ), LDQ3 ) END IF C ELSE IF( DIM1.EQ.1 .AND. DIM2.EQ.2 ) THEN C C Update A. C CALL DCOPY( NR, A( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NR-1, DIM2, ONE, $ A( 1, M1+IJ1 ), LDA, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), A( 1, IB1 ), 1 ) A( NR, IB1 ) = DWORK( I2UPLE )*A( NR, IB1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-1, DIM2, $ DIM2, ONE, A( 1, M1+IJ1 ), LDA, $ DWORK( I2LORI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) DWORK( ITMP+ NR-1 ) = ZERO DWORK( ITMP+2*NR-1 ) = ZERO CALL DAXPY( NR, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NR, DWORK( I2UPRI+SDIM ), DWORK( IWRK ), 1, $ DWORK( ITMP+NR ), 1 ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ A( 1, M1+IJ1 ), LDA ) C CALL DCOPY( NROW, A( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM2, ONE, $ A( I1, M1+IJ1 ), LDA, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), A( I1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, A( I1, M1+IJ1 ), LDA, $ DWORK( I2LORI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DAXPY( NROW, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NROW, DWORK( I2UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+NROW ), 1 ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ A( I1, M1+IJ1 ), LDA ) C CALL DCOPY( M1-IB1+1, A( IB1, IB1 ), LDA, DWORK( IWRK ), $ 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IB1+1, ONE, $ A( M1+IJ1, IB1 ), LDA, DWORK( I3LOLE ), 1, $ DWORK( I3UPLE ), A( IB1, IB1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ A( M1+IJ1, IB1 ), LDA, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I3UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, IB1 ), LDA ) C CALL DCOPY( M1-IJ1+1, A( IB1, M1+IJ1 ), LDA, $ DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IJ1+1, ONE, $ A( M1+IJ1, M1+IJ1 ), LDA, DWORK( I3LOLE ), $ 1, DWORK( I3UPLE ), A( IB1, M1+IJ1 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ A( M1+IJ1, M1+IJ1 ), LDA, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I3UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, A( IB1, I2 ), LDA, DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M4, ONE, $ A( M1+IJ1, I2 ), LDA, DWORK( I3LOLE ), 1, $ DWORK( I3UPLE ), A( IB1, I2 ), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ A( M1+IJ1, I2 ), LDA, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I3UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DCOPY( NR, B( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NR-1, DIM2, ONE, $ B( 1, M1+IJ1 ), LDB, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), B( 1, IB1 ), 1 ) B( NR, IB1 ) = DWORK( I1UPLE )*B( NR, IB1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-1, DIM2, $ DIM2, ONE, B( 1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) DWORK( ITMP+ NR-1 ) = ZERO DWORK( ITMP+2*NR-1 ) = ZERO CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), 1, $ DWORK( ITMP+NR ), 1 ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ B( 1, M1+IJ1 ), LDB ) C CALL DCOPY( NROW, B( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM2, ONE, $ B( I1, M1+IJ1 ), LDB, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), B( I1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, B( I1, M1+IJ1 ), LDB, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+NROW ), 1 ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ B( I1, M1+IJ1 ), LDB ) C CALL DCOPY( M1-IB1+1, B( IB1, IB1 ), LDB, DWORK( IWRK ), $ 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IB1+1, ONE, $ B( M1+IJ1, IB1 ), LDB, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), B( IB1, IB1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, IB1 ), LDB, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, IB1 ), LDB ) C CALL DCOPY( M1-IJ1+1, B( IB1, M1+IJ1 ), LDB, $ DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IJ1+1, ONE, $ B( M1+IJ1, M1+IJ1 ), LDB, DWORK( I2LOLE ), $ 1, DWORK( I2UPLE ), B( IB1, M1+IJ1 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, M1+IJ1 ), LDB, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, B( IB1, I2 ), LDB, DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M4, ONE, $ B( M1+IJ1, I2 ), LDB, DWORK( I2LOLE ), 1, $ DWORK( I2UPLE ), B( IB1, I2 ), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I2LORI ), SDIM, $ B( M1+IJ1, I2 ), LDB, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I2UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ B( M1+IJ1, I2 ), LDB ) END IF C C Update D. C CALL DCOPY( NR, D( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NR-1, DIM2, ONE, $ D( 1, M1+IJ1 ), LDD, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), D( 1, IB1 ), 1 ) D( NR, IB1 ) = DWORK( I1UPLE )*D( NR, IB1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NR-1, DIM2, $ DIM2, ONE, D( 1, M1+IJ1 ), LDD, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NR ) DWORK( ITMP+ NR-1 ) = ZERO DWORK( ITMP+2*NR-1 ) = ZERO CALL DAXPY( NR, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NR, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), 1, $ DWORK( ITMP+NR ), 1 ) CALL DLACPY( 'Full', NR, DIM2, DWORK( ITMP ), NR, $ D( 1, M1+IJ1 ), LDD ) C CALL DCOPY( NROW, D( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM2, ONE, $ D( I1, M1+IJ1 ), LDD, DWORK( I1LOLE ), 1, $ DWORK( I1UPLE ), D( I1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM2, $ DIM2, ONE, D( I1, M1+IJ1 ), LDD, $ DWORK( I1LORI ), SDIM, ZERO, DWORK( ITMP ), $ NROW ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+NROW ), 1 ) CALL DLACPY( 'Full', NROW, DIM2, DWORK( ITMP ), NROW, $ D( I1, M1+IJ1 ), LDD ) C CALL DCOPY( M1-IB1+1, D( IB1, IB1 ), LDD, DWORK( IWRK ), $ 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IB1+1, ONE, $ D( M1+IJ1, IB1 ), LDD, DWORK( I3LOLE ), 1, $ DWORK( I3UPLE ), D( IB1, IB1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IB1+1, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ D( M1+IJ1, IB1 ), LDD, ZERO, DWORK( ITMP ), $ DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IB1+1, DWORK( I3UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IB1+1, DWORK( ITMP ), DIM2, $ D( M1+IJ1, IB1 ), LDD ) C CALL DCOPY( M1-IJ1+1, D( IB1, M1+IJ1 ), LDD, $ DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M1-IJ1+1, ONE, $ D( M1+IJ1, M1+IJ1 ), LDD, DWORK( I3LOLE ), $ 1, DWORK( I3UPLE ), D( IB1, M1+IJ1 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M1-IJ1+1, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ D( M1+IJ1, M1+IJ1 ), LDD, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M1-IJ1+1, DWORK( I3UPRI+SDIM ), $ DWORK( IWRK ), 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M1-IJ1+1, DWORK( ITMP ), DIM2, $ D( M1+IJ1, M1+IJ1 ), LDD ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, D( IB1, I2 ), LDD, DWORK( IWRK ), 1 ) CALL DGEMV( 'Transpose', DIM2, M4, ONE, $ D( M1+IJ1, I2 ), LDD, DWORK( I3LOLE ), 1, $ DWORK( I3UPLE ), D( IB1, I2 ), LDD ) CALL DGEMM( 'Transpose', 'No Transpose', DIM2, M4, $ DIM2, ONE, DWORK( I3LORI ), SDIM, $ D( M1+IJ1, I2 ), LDD, ZERO, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), DIM2 ) CALL DAXPY( M4, DWORK( I3UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+1 ), DIM2 ) CALL DLACPY( 'Full', DIM2, M4, DWORK( ITMP ), DIM2, $ D( M1+IJ1, I2 ), LDD ) END IF C C Update Q1. C IF( LCMPQ1 ) THEN CALL DCOPY( N, Q1( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', N, DIM2, ONE, $ Q1( 1, M1+IJ1 ), LDQ1, DWORK( I1LOLE ), $ 1, DWORK( I1UPLE ), Q1( 1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q1( 1, M1+IJ1 ), LDQ1, $ DWORK( I1LORI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DAXPY( N, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( N, DWORK( I1UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+N ), 1 ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q1( 1, M1+IJ1 ), LDQ1 ) END IF C C Update Q2. C IF( LCMPQ2 ) THEN CALL DCOPY( N, Q2( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', N, DIM2, ONE, $ Q2( 1, M1+IJ1 ), LDQ2, DWORK( I2LOLE ), $ 1, DWORK( I2UPLE ), Q2( 1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q2( 1, M1+IJ1 ), LDQ2, $ DWORK( I2LORI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DAXPY( N, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( N, DWORK( I2UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+N ), 1 ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q2( 1, M1+IJ1 ), LDQ2 ) END IF C C Update Q3. C IF( LCMPQ3 ) THEN CALL DCOPY( N, Q3( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DGEMV( 'No Transpose', N, DIM2, ONE, $ Q3( 1, M1+IJ1 ), LDQ3, DWORK( I3LOLE ), $ 1, DWORK( I3UPLE ), Q3( 1, IB1 ), 1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM2, $ DIM2, ONE, Q3( 1, M1+IJ1 ), LDQ3, $ DWORK( I3LORI ), SDIM, ZERO, $ DWORK( ITMP ), N ) CALL DAXPY( N, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ DWORK( ITMP ), 1 ) CALL DAXPY( N, DWORK( I3UPRI+SDIM ), DWORK( IWRK ), $ 1, DWORK( ITMP+N ), 1 ) CALL DLACPY( 'Full', N, DIM2, DWORK( ITMP ), N, $ Q3( 1, M1+IJ1 ), LDQ3 ) END IF C ELSE IF( DIM1.EQ.2 .AND. DIM2.EQ.1 ) THEN C C Update A. C CALL DLACPY( 'Full', NR, DIM1, A( 1, IB1 ), LDA, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I2UPLE ), SDIM, ZERO, A( 1, IB1 ), $ LDA ) CALL DAXPY( NR-1, DWORK( I2LOLE ), A( 1, M1+IJ1 ), 1, $ A( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I2LOLE+SDIM ), A( 1, M1+IJ1 ), $ 1, A( 1, IB1+1 ), 1 ) A( NR, M1+IJ1 ) = ZERO CALL DGEMV( 'No Transpose', NR, DIM1, ONE, $ DWORK( IWRK ), NR, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), A( 1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', NROW, DIM1, A( I1, IB1 ), LDA, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I2UPLE ), SDIM, ZERO, A( I1, IB1 ), $ LDA ) CALL DAXPY( NROW, DWORK( I2LOLE ), A( I1, M1+IJ1 ), 1, $ A( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I2LOLE+SDIM ), A( I1, M1+IJ1 ), $ 1, A( I1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM1, ONE, $ DWORK( IWRK ), NROW, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), A( I1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, A( IB1, IB1 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, IB1 ), $ LDA ) CALL DAXPY( M1-IB1+1, DWORK( I3LOLE ), A( M1+IJ1, IB1 ), $ LDA, A( IB1, IB1 ), LDA ) CALL DAXPY( M1-IB1+1, DWORK( I3LOLE+SDIM ), $ A( M1+IJ1, IB1 ), LDA, A( IB1+1, IB1 ), $ LDA ) CALL DGEMV( 'Transpose', DIM1, M1-IB1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I3UPRI ), 1, $ DWORK( I3LORI ), A( M1+IJ1, IB1 ), LDA ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, A( IB1, M1+IJ1 ), $ LDA, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, M1+IJ1 ), $ LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I3LOLE ), $ A( M1+IJ1, M1+IJ1 ), LDA, A( IB1, M1+IJ1 ), $ LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I3LOLE+SDIM ), $ A( M1+IJ1, M1+IJ1 ), LDA, $ A( IB1+1, M1+IJ1 ), LDA ) CALL DGEMV( 'Transpose', DIM1, M1-IJ1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I3UPRI ), 1, $ DWORK( I3LORI ), A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, A( IB1, I2 ), LDA, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, A( IB1, I2 ), $ LDA ) CALL DAXPY( M4, DWORK( I3LOLE ), A( M1+IJ1, I2 ), $ LDA, A( IB1, I2 ), LDA ) CALL DAXPY( M4, DWORK( I3LOLE+SDIM ), $ A( M1+IJ1, I2 ), LDA, A( IB1+1, I2 ), $ LDA ) CALL DGEMV( 'Transpose', DIM1, M4, ONE, $ DWORK( IWRK ), DIM1, DWORK( I3UPRI ), 1, $ DWORK( I3LORI ), A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DLACPY( 'Full', NR, DIM1, B( 1, IB1 ), LDB, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, B( 1, IB1 ), $ LDB ) CALL DAXPY( NR-1, DWORK( I1LOLE ), B( 1, M1+IJ1 ), 1, $ B( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE+SDIM ), B( 1, M1+IJ1 ), $ 1, B( 1, IB1+1 ), 1 ) B( NR, M1+IJ1 ) = ZERO CALL DGEMV( 'No Transpose', NR, DIM1, ONE, $ DWORK( IWRK ), NR, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), B( 1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', NROW, DIM1, B( I1, IB1 ), LDB, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, B( I1, IB1 ), $ LDB ) CALL DAXPY( NROW, DWORK( I1LOLE ), B( I1, M1+IJ1 ), 1, $ B( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE+SDIM ), B( I1, M1+IJ1 ), $ 1, B( I1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM1, ONE, $ DWORK( IWRK ), NROW, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), B( I1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, B( IB1, IB1 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, IB1 ), $ LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE ), B( M1+IJ1, IB1 ), $ LDB, B( IB1, IB1 ), LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE+SDIM ), $ B( M1+IJ1, IB1 ), LDB, B( IB1+1, IB1 ), $ LDB ) CALL DGEMV( 'Transpose', DIM1, M1-IB1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), B( M1+IJ1, IB1 ), LDB ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, B( IB1, M1+IJ1 ), $ LDB, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, M1+IJ1 ), $ LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE ), $ B( M1+IJ1, M1+IJ1 ), LDB, B( IB1, M1+IJ1 ), $ LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE+SDIM ), $ B( M1+IJ1, M1+IJ1 ), LDB, $ B( IB1+1, M1+IJ1 ), LDB ) CALL DGEMV( 'Transpose', DIM1, M1-IJ1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, B( IB1, I2 ), LDB, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I2UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, B( IB1, I2 ), $ LDB ) CALL DAXPY( M4, DWORK( I2LOLE ), B( M1+IJ1, I2 ), $ LDB, B( IB1, I2 ), LDB ) CALL DAXPY( M4, DWORK( I2LOLE+SDIM ), $ B( M1+IJ1, I2 ), LDB, B( IB1+1, I2 ), $ LDB ) CALL DGEMV( 'Transpose', DIM1, M4, ONE, $ DWORK( IWRK ), DIM1, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), B( M1+IJ1, I2 ), LDB ) END IF C C Update D. C CALL DLACPY( 'Full', NR, DIM1, D( 1, IB1 ), LDD, $ DWORK( IWRK ), NR ) CALL DGEMM( 'No Transpose', 'No Transpose', NR, DIM1, $ DIM1, ONE, DWORK( IWRK ), NR, $ DWORK( I1UPLE ), SDIM, ZERO, D( 1, IB1 ), $ LDD ) CALL DAXPY( NR-1, DWORK( I1LOLE ), D( 1, M1+IJ1 ), 1, $ D( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE+SDIM ), D( 1, M1+IJ1 ), $ 1, D( 1, IB1+1 ), 1 ) D( NR, M1+IJ1 ) = ZERO CALL DGEMV( 'No Transpose', NR, DIM1, ONE, $ DWORK( IWRK ), NR, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), D( 1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', NROW, DIM1, D( I1, IB1 ), LDD, $ DWORK( IWRK ), NROW ) CALL DGEMM( 'No Transpose', 'No Transpose', NROW, DIM1, $ DIM1, ONE, DWORK( IWRK ), NROW, $ DWORK( I1UPLE ), SDIM, ZERO, D( I1, IB1 ), $ LDD ) CALL DAXPY( NROW, DWORK( I1LOLE ), D( I1, M1+IJ1 ), 1, $ D( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE+SDIM ), D( I1, M1+IJ1 ), $ 1, D( I1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', NROW, DIM1, ONE, $ DWORK( IWRK ), NROW, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), D( I1, M1+IJ1 ), 1 ) C CALL DLACPY( 'Full', DIM1, M1-IB1+1, D( IB1, IB1 ), LDD, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IB1+1, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, D( IB1, IB1 ), $ LDD ) CALL DAXPY( M1-IB1+1, DWORK( I3LOLE ), D( M1+IJ1, IB1 ), $ LDD, D( IB1, IB1 ), LDD ) CALL DAXPY( M1-IB1+1, DWORK( I3LOLE+SDIM ), $ D( M1+IJ1, IB1 ), LDD, D( IB1+1, IB1 ), $ LDD ) CALL DGEMV( 'Transpose', DIM1, M1-IB1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I3UPRI ), 1, $ DWORK( I3LORI ), D( M1+IJ1, IB1 ), LDD ) C CALL DLACPY( 'Full', DIM1, M1-IJ1+1, D( IB1, M1+IJ1 ), $ LDD, DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M1-IJ1+1, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, D( IB1, M1+IJ1 ), $ LDD ) CALL DAXPY( M1-IJ1+1, DWORK( I3LOLE ), $ D( M1+IJ1, M1+IJ1 ), LDD, D( IB1, M1+IJ1 ), $ LDD ) CALL DAXPY( M1-IJ1+1, DWORK( I3LOLE+SDIM ), $ D( M1+IJ1, M1+IJ1 ), LDD, $ D( IB1+1, M1+IJ1 ), LDD ) CALL DGEMV( 'Transpose', DIM1, M1-IJ1+1, ONE, $ DWORK( IWRK ), DIM1, DWORK( I3UPRI ), 1, $ DWORK( I3LORI ), D( M1+IJ1, M1+IJ1 ), LDD ) C IF( M2.GT.0 ) THEN CALL DLACPY( 'Full', DIM1, M4, D( IB1, I2 ), LDD, $ DWORK( IWRK ), DIM1 ) CALL DGEMM( 'Transpose', 'No Transpose', DIM1, M4, $ DIM1, ONE, DWORK( I3UPLE ), SDIM, $ DWORK( IWRK ), DIM1, ZERO, D( IB1, I2 ), $ LDD ) CALL DAXPY( M4, DWORK( I3LOLE ), D( M1+IJ1, I2 ), $ LDD, D( IB1, I2 ), LDD ) CALL DAXPY( M4, DWORK( I3LOLE+SDIM ), $ D( M1+IJ1, I2 ), LDD, D( IB1+1, I2 ), $ LDD ) CALL DGEMV( 'Transpose', DIM1, M4, ONE, $ DWORK( IWRK ), DIM1, DWORK( I3UPRI ), 1, $ DWORK( I3LORI ), D( M1+IJ1, I2 ), LDD ) END IF C C Update Q1. C IF( LCMPQ1 ) THEN CALL DLACPY( 'Full', N, DIM1, Q1( 1, IB1 ), LDQ1, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I1UPLE ), SDIM, ZERO, $ Q1( 1, IB1 ), LDQ1 ) CALL DAXPY( N, DWORK( I1LOLE ), Q1( 1, M1+IJ1 ), 1, $ Q1( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I1LOLE+SDIM ), Q1( 1, M1+IJ1 ), $ 1, Q1( 1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', N, DIM1, ONE, $ DWORK( IWRK ), N, DWORK( I1UPRI ), 1, $ DWORK( I1LORI ), Q1( 1, M1+IJ1 ), 1 ) END IF C C Update Q2. C IF( LCMPQ2 ) THEN CALL DLACPY( 'Full', N, DIM1, Q2( 1, IB1 ), LDQ2, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I2UPLE ), SDIM, ZERO, $ Q2( 1, IB1 ), LDQ2 ) CALL DAXPY( N, DWORK( I2LOLE ), Q2( 1, M1+IJ1 ), 1, $ Q2( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I2LOLE+SDIM ), Q2( 1, M1+IJ1 ), $ 1, Q2( 1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', N, DIM1, ONE, $ DWORK( IWRK ), N, DWORK( I2UPRI ), 1, $ DWORK( I2LORI ), Q2( 1, M1+IJ1 ), 1 ) END IF C C Update Q3. C IF( LCMPQ3 ) THEN CALL DLACPY( 'Full', N, DIM1, Q3( 1, IB1 ), LDQ3, $ DWORK( IWRK ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', N, DIM1, $ DIM1, ONE, DWORK( IWRK ), N, $ DWORK( I3UPLE ), SDIM, ZERO, $ Q3( 1, IB1 ), LDQ3 ) CALL DAXPY( N, DWORK( I3LOLE ), Q3( 1, M1+IJ1 ), 1, $ Q3( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I3LOLE+SDIM ), Q3( 1, M1+IJ1 ), $ 1, Q3( 1, IB1+1 ), 1 ) CALL DGEMV( 'No Transpose', N, DIM1, ONE, $ DWORK( IWRK ), N, DWORK( I3UPRI ), 1, $ DWORK( I3LORI ), Q3( 1, M1+IJ1 ), 1 ) END IF C ELSE C C Update A. C CALL DCOPY( NR, A( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I2UPLE ), A( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I2LOLE ), A( 1, M1+IJ1 ), 1, $ A( 1, IB1 ), 1 ) CALL DSCAL( NR-1, DWORK( I2LORI ), A( 1, M1+IJ1 ), 1 ) CALL DAXPY( NR-1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ A( 1, M1+IJ1 ), 1 ) A( NR, M1+IJ1 ) = DWORK( I2UPRI )*DWORK( IWRK+NR-1 ) C CALL DCOPY( NROW, A( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NROW, DWORK( I2UPLE ), A( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I2LOLE ), A( I1, M1+IJ1 ), 1, $ A( I1, IB1 ), 1 ) CALL DSCAL( NROW, DWORK( I2LORI ), A( I1, M1+IJ1 ), 1 ) CALL DAXPY( NROW, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ A( I1, M1+IJ1 ), 1 ) C CALL DCOPY( M1-IB1+1, A( IB1, IB1 ), LDA, DWORK( IWRK ), $ 1 ) CALL DSCAL( M1-IB1+1, DWORK( I3UPLE ), A( IB1, IB1 ), $ LDA ) CALL DAXPY( M1-IB1+1, DWORK( I3LOLE ), A( M1+IJ1, IB1 ), $ LDA, A( IB1, IB1 ), LDA ) CALL DSCAL( M1-IB1+1, DWORK( I3LORI ), A( M1+IJ1, IB1 ), $ LDA ) CALL DAXPY( M1-IB1+1, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ A( M1+IJ1, IB1 ), LDA ) C CALL DCOPY( M1-IJ1+1, A( IB1, M1+IJ1 ), LDA, $ DWORK( IWRK ), 1 ) CALL DSCAL( M1-IJ1+1, DWORK( I3UPLE ), A( IB1, M1+IJ1 ), $ LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I3LOLE ), $ A( M1+IJ1, M1+IJ1 ), LDA, A( IB1, M1+IJ1 ), $ LDA ) CALL DSCAL( M1-IJ1+1, DWORK( I3LORI ), $ A( M1+IJ1, M1+IJ1 ), LDA ) CALL DAXPY( M1-IJ1+1, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ A( M1+IJ1, M1+IJ1 ), LDA ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, A( IB1, I2 ), LDA, DWORK( IWRK ), 1 ) CALL DSCAL( M4, DWORK( I3UPLE ), A( IB1, I2 ), LDA ) CALL DAXPY( M4, DWORK( I3LOLE ), A( M1+IJ1, I2 ), LDA, $ A( IB1, I2 ), LDA ) CALL DSCAL( M4, DWORK( I3LORI ), A( M1+IJ1, I2 ), $ LDA ) CALL DAXPY( M4, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ A( M1+IJ1, I2 ), LDA ) END IF C C Update B. C CALL DCOPY( NR, B( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), B( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE ), B( 1, M1+IJ1 ), 1, $ B( 1, IB1 ), 1 ) CALL DSCAL( NR-1, DWORK( I1LORI ), B( 1, M1+IJ1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( 1, M1+IJ1 ), 1 ) B( NR, M1+IJ1 ) = DWORK( I1UPRI )*DWORK( IWRK+NR-1 ) C CALL DCOPY( NROW, B( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NROW, DWORK( I1UPLE ), B( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE ), B( I1, M1+IJ1 ), 1, $ B( I1, IB1 ), 1 ) CALL DSCAL( NROW, DWORK( I1LORI ), B( I1, M1+IJ1 ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ B( I1, M1+IJ1 ), 1 ) C CALL DCOPY( M1-IB1+1, B( IB1, IB1 ), LDB, DWORK( IWRK ), $ 1 ) CALL DSCAL( M1-IB1+1, DWORK( I2UPLE ), B( IB1, IB1 ), $ LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2LOLE ), B( M1+IJ1, IB1 ), $ LDB, B( IB1, IB1 ), LDB ) CALL DSCAL( M1-IB1+1, DWORK( I2LORI ), B( M1+IJ1, IB1 ), $ LDB ) CALL DAXPY( M1-IB1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ B( M1+IJ1, IB1 ), LDB ) C CALL DCOPY( M1-IJ1+1, B( IB1, M1+IJ1 ), LDB, $ DWORK( IWRK ), 1 ) CALL DSCAL( M1-IJ1+1, DWORK( I2UPLE ), B( IB1, M1+IJ1 ), $ LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2LOLE ), $ B( M1+IJ1, M1+IJ1 ), LDB, B( IB1, M1+IJ1 ), $ LDB ) CALL DSCAL( M1-IJ1+1, DWORK( I2LORI ), $ B( M1+IJ1, M1+IJ1 ), LDB ) CALL DAXPY( M1-IJ1+1, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ B( M1+IJ1, M1+IJ1 ), LDB ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, B( IB1, I2 ), LDB, DWORK( IWRK ), 1 ) CALL DSCAL( M4, DWORK( I2UPLE ), B( IB1, I2 ), LDB ) CALL DAXPY( M4, DWORK( I2LOLE ), B( M1+IJ1, I2 ), LDB, $ B( IB1, I2 ), LDB ) CALL DSCAL( M4, DWORK( I2LORI ), B( M1+IJ1, I2 ), $ LDB ) CALL DAXPY( M4, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ B( M1+IJ1, I2 ), LDB ) END IF C C Update D. C CALL DCOPY( NR, D( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NR, DWORK( I1UPLE ), D( 1, IB1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1LOLE ), D( 1, M1+IJ1 ), 1, $ D( 1, IB1 ), 1 ) CALL DSCAL( NR-1, DWORK( I1LORI ), D( 1, M1+IJ1 ), 1 ) CALL DAXPY( NR-1, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ D( 1, M1+IJ1 ), 1 ) D( NR, M1+IJ1 ) = DWORK( I1UPRI )*DWORK( IWRK+NR-1 ) C CALL DCOPY( NROW, D( I1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( NROW, DWORK( I1UPLE ), D( I1, IB1 ), 1 ) CALL DAXPY( NROW, DWORK( I1LOLE ), D( I1, M1+IJ1 ), 1, $ D( I1, IB1 ), 1 ) CALL DSCAL( NROW, DWORK( I1LORI ), D( I1, M1+IJ1 ), 1 ) CALL DAXPY( NROW, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ D( I1, M1+IJ1 ), 1 ) C CALL DCOPY( M1-IB1+1, D( IB1, IB1 ), LDD, DWORK( IWRK ), $ 1 ) CALL DSCAL( M1-IB1+1, DWORK( I3UPLE ), D( IB1, IB1 ), $ LDD ) CALL DAXPY( M1-IB1+1, DWORK( I3LOLE ), D( M1+IJ1, IB1 ), $ LDD, D( IB1, IB1 ), LDD ) CALL DSCAL( M1-IB1+1, DWORK( I3LORI ), D( M1+IJ1, IB1 ), $ LDD ) CALL DAXPY( M1-IB1+1, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ D( M1+IJ1, IB1 ), LDD ) C CALL DCOPY( M1-IJ1+1, D( IB1, M1+IJ1 ), LDD, $ DWORK( IWRK ), 1 ) CALL DSCAL( M1-IJ1+1, DWORK( I3UPLE ), D( IB1, M1+IJ1 ), $ LDD ) CALL DAXPY( M1-IJ1+1, DWORK( I3LOLE ), $ D( M1+IJ1, M1+IJ1 ), LDD, D( IB1, M1+IJ1 ), $ LDD ) CALL DSCAL( M1-IJ1+1, DWORK( I3LORI ), $ D( M1+IJ1, M1+IJ1 ), LDD ) CALL DAXPY( M1-IJ1+1, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ D( M1+IJ1, M1+IJ1 ), LDD ) C IF( M2.GT.0 ) THEN CALL DCOPY( M4, D( IB1, I2 ), LDD, DWORK( IWRK ), 1 ) CALL DSCAL( M4, DWORK( I3UPLE ), D( IB1, I2 ), LDD ) CALL DAXPY( M4, DWORK( I3LOLE ), D( M1+IJ1, I2 ), LDD, $ D( IB1, I2 ), LDD ) CALL DSCAL( M4, DWORK( I3LORI ), D( M1+IJ1, I2 ), $ LDD ) CALL DAXPY( M4, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ D( M1+IJ1, I2 ), LDD ) END IF C C Update Q1. C IF( LCMPQ1 ) THEN CALL DCOPY( N, Q1( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I1UPLE ), Q1( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I1LOLE ), Q1( 1, M1+IJ1 ), 1, $ Q1( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I1LORI ), Q1( 1, M1+IJ1 ), 1 ) CALL DAXPY( N, DWORK( I1UPRI ), DWORK( IWRK ), 1, $ Q1( 1, M1+IJ1 ), 1 ) END IF C C Update Q2. C IF( LCMPQ2 ) THEN CALL DCOPY( N, Q2( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I2UPLE ), Q2( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I2LOLE ), Q2( 1, M1+IJ1 ), 1, $ Q2( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I2LORI ), Q2( 1, M1+IJ1 ), 1 ) CALL DAXPY( N, DWORK( I2UPRI ), DWORK( IWRK ), 1, $ Q2( 1, M1+IJ1 ), 1 ) END IF C C Update Q3. C IF( LCMPQ3 ) THEN CALL DCOPY( N, Q3( 1, IB1 ), 1, DWORK( IWRK ), 1 ) CALL DSCAL( N, DWORK( I3UPLE ), Q3( 1, IB1 ), 1 ) CALL DAXPY( N, DWORK( I3LOLE ), Q3( 1, M1+IJ1 ), 1, $ Q3( 1, IB1 ), 1 ) CALL DSCAL( N, DWORK( I3LORI ), Q3( 1, M1+IJ1 ), 1 ) CALL DAXPY( N, DWORK( I3UPRI ), DWORK( IWRK ), 1, $ Q3( 1, M1+IJ1 ), 1 ) END IF END IF 50 CONTINUE 60 CONTINUE C C Triangularize the lower right subpencil aAA2 BB2 - bDD2. C IF( M2.GT.1 ) THEN CALL DLACPY( 'Full', N, M4-2, A( 1, I2+1 ), LDA, DWORK, N ) DO 70 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ A( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ A( 1, 2*( M1+I ) ), 1 ) 70 CONTINUE C CALL DLACPY( 'Full', M4-2, M4, A( I2+1, I2 ), LDA, DWORK, $ M4-2 ) DO 80 I = 1, M2 - 1 CALL DCOPY( M4, DWORK( I ), M4-2, A( 2*( M1+I )+1, I2 ), $ LDA ) CALL DCOPY( M4, DWORK( M2+I-1 ), M4-2, A( 2*( M1+I ), I2 ), $ LDA ) 80 CONTINUE C CALL DLACPY( 'Full', N, M4-2, B( 1, I2+1 ), LDB, DWORK, N ) DO 90 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ B( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ B( 1, 2*( M1+I ) ), 1 ) 90 CONTINUE C CALL DLACPY( 'Full', M4-2, M4, B( I2+1, I2 ), LDB, DWORK, $ M4-2 ) DO 100 I = 1, M2 - 1 CALL DCOPY( M4, DWORK( I ), M4-2, B( 2*( M1+I )+1, I2 ), $ LDB ) CALL DCOPY( M4, DWORK( M2+I-1 ), M4-2, B( 2*( M1+I ), I2 ), $ LDB ) 100 CONTINUE C CALL DLACPY( 'Full', N, M4-2, D( 1, I2+1 ), LDD, DWORK, N ) DO 110 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ D( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ D( 1, 2*( M1+I ) ), 1 ) 110 CONTINUE C CALL DLACPY( 'Full', M4-2, M4, D( I2+1, I2 ), LDD, DWORK, $ M4-2 ) DO 120 I = 1, M2 - 1 CALL DCOPY( M4, DWORK( I ), M4-2, D( 2*( M1+I )+1, I2 ), $ LDD ) CALL DCOPY( M4, DWORK( M2+I-1 ), M4-2, D( 2*( M1+I ), I2 ), $ LDD ) 120 CONTINUE C IF( LCMPQ1 ) THEN CALL DLACPY( 'Full', N, M4-2, Q1( 1, I2+1 ), LDQ1, DWORK, $ N ) DO 130 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ Q1( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ Q1( 1, 2*( M1+I ) ), 1 ) 130 CONTINUE END IF C IF( LCMPQ2 ) THEN CALL DLACPY( 'Full', N, M4-2, Q2( 1, I2+1 ), LDQ2, DWORK, $ N ) DO 140 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ Q2( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ Q2( 1, 2*( M1+I ) ), 1 ) 140 CONTINUE END IF C IF( LCMPQ3 ) THEN CALL DLACPY( 'Full', N, M4-2, Q3( 1, I2+1 ), LDQ3, DWORK, $ N ) DO 150 I = 1, M2 - 1 CALL DCOPY( N, DWORK( N*( I-1 )+1 ), 1, $ Q3( 1, 2*( M1+I )+1 ), 1 ) CALL DCOPY( N, DWORK( N*( M2+I-2 )+1 ), 1, $ Q3( 1, 2*( M1+I ) ), 1 ) 150 CONTINUE END IF END IF C RETURN C *** Last line of MB04CD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01UX.f0000644000000000000000000000013215012430707016220 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01UX.f0000644000175000017500000002421615012430707017421 0ustar00lilgelilge00000000000000 SUBROUTINE TB01UX( COMPZ, N, M, P, A, LDA, B, LDB, C, LDC, Z, LDZ, $ NOBSV, NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) C C PURPOSE C C To compute an orthogonal transformation matrix Z which reduces the C N-th order system (A,B,C) to the form C C ( Ano * ) ( Bno ) C Z'*A*Z = ( ) , Z'*B = ( ) , C ( 0 Ao ) ( Bo ) C C C*Z = ( 0 Co ) , C C where the NOBSV-th order system (Ao,Bo,Co) is observable. C The matrix Ano of order N-NOBSV contains the unobservable C eigenvalues of A. C C The pencil ( Ao-lambda*I ) has full column rank NOBSV for all C ( Co ) C lambda, and is in a staircase form, with C _ _ _ _ C ( Ak,k Ak,k-1 ... Ak,2 Ak,1 ) C ( _ _ _ _ ) C ( Ao ) = ( Ak-1,k Ak-1,k-1 ... Ak-1,2 Ak-1,1 ) , (1) C ( Co ) ( : : ... _ : _ : ) C ( 0 0 ... A1,2 A1,1 ) C ( _ ) C ( 0 0 ... 0 A0,1 ) C _ C where Ai-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix C (with CTAU(0) = P). C C The orthogonal transformation Z, performed to reduce the system C matrices, can be optionally accumulated. C C The reduced order system (Ao,Bo,Co) has the same transfer-function C matrix as the original system (A,B,C). C C ARGUMENTS C C Mode Parameters C C COMPZ CHARACTER*1 C = 'N': do not compute Z; C = 'I': Z is initialized to the unit matrix, and the C orthogonal matrix Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the system state vector; also the order C of the square matrix A, the number of rows of the matrix B C and the number of columns of the matrix C. N >= 0. C C M (input) INTEGER C The dimension of system input vector; also the number of C columns of the matrix B. M >= 0. C C P (input) INTEGER C The dimension of system output vector; also the number of C rows of the matrix C. 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 N-by-N state matrix A. C On exit, the leading N-by-N part of this array contains C the transformed state matrix Z'*A*Z, C C ( Ano * ) C Z'*A*Z = ( ) , C ( 0 Ao ) C C where Ao is NOBSV-by-NOBSV and Ano is C (N-NOBSV)-by-(N-NOBSV). C The matrix ( Ao ) is in the observability staircase C ( Co ) C form (1). C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,MAX(M,P)) C On entry, the leading N-by-M part of this array must C contain the N-by-M input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix Z'*B. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N) if M > 0 or P > 0; C LDB >= 1 if M = 0 and P = 0. 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C C C*Z = ( 0 Co ) , C C where Co is P-by-NOBSV. C The matrix ( Ao ) is in the observability staircase C ( Co ) C form (1). C C LDC INTEGER C The leading dimension of the array C. C LDC >= MAX(1,M,P) if N > 0; C LDC >= 1 if N = 0. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) C If COMPZ = 'N': Z is not referenced. C If COMPZ = 'I': on entry, Z need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Z, C i.e., the product of the transformations C applied to A and C on the right. C C LDZ INTEGER C The leading dimension of the array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= MAX(1,N), if COMPZ = 'I'. C C NOBSV (output) INTEGER C The order of the reduced matrix Ao, and the number of C columns of the reduced matrix Co; also, the order of the C observable part of the pair (C, A-lambda*I). C C NLBLCK (output) INTEGER _ C The number k, of full column rank blocks Ai-1,i in the C staircase form of the pencil (Ao-lambda*I) (see (1)). C ( Co ) C C CTAU (output) INTEGER array, dimension (N) C CTAU(i), for i = 1, ..., NLBLCK, is the column dimension C _ C of the full column rank block Ai-1,i in the staircase C form (1). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determinations when C transforming the pair (A,C). If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C reciprocal condition numbers in rank determinations; a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*N*EPS, is used instead, where EPS C is the machine precision (see LAPACK Library routine C DLAMCH). TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (P) C C DWORK DOUBLE PRECISION array, dimension (N+MAX(1, N, 3*P, M)) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK. 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 subroutine is based on the dual of the reduction C algorithms of [1]. C C REFERENCES C C [1] Varga, A. C Computation of Irreducible Generalized State-Space C Realizations. C Kybernetika, vol. 26, pp. 89-106, 1990. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N**3 ) floating point operations. C C FURTHER COMMENTS C C If the system matrices A and C are badly scaled, it is C generally recommendable to scale them with the SLICOT routine C TB01ID, before calling TG01UX. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C March 2002. C C REVISIONS C C V. Sima, Dec. 2016. C C KEYWORDS C C Observability, minimal realization, orthogonal canonical form, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, LDA, LDB, LDC, LDZ, M, N, NLBLCK, NOBSV, $ P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER CTAU( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), Z( LDZ, * ) C .. Local Scalars .. LOGICAL ILZ INTEGER LBA, LDWORK C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB07MD, MA02BD, TB01UD, TB01XD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C C Decode COMPZ. C ILZ = LSAME( COMPZ, 'I' ) C C Test the input scalar parameters. C INFO = 0 IF( .NOT.ILZ .AND. .NOT.LSAME( COMPZ, '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.1 .OR. ( MAX( M, P ).GT.0 .AND. LDB.LT.N ) ) THEN INFO = -8 ELSE IF( LDC.LT.1 .OR. ( LDC.LT.MAX( M, P ) .AND. N.GT.0 ) ) THEN INFO = -10 ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN INFO = -12 ELSE IF( TOL.GE.ONE ) THEN INFO = -16 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TB01UX', -INFO ) RETURN END IF C C Build the dual system. C CALL AB07MD( 'Zero D', N, M, P, A, LDA, B, LDB, C, LDC, DUM, 1, $ INFO ) C LDWORK = MAX( 1, N, 3*P, M ) CALL TB01UD( COMPZ, N, P, M, A, LDA, B, LDB, C, LDC, NOBSV, $ NLBLCK, CTAU, Z, LDZ, DWORK, TOL, IWORK, DWORK(N+1), $ LDWORK, INFO ) IF( NLBLCK.GT.1 ) THEN LBA = CTAU(1) + CTAU(2) - 1 ELSE IF( NLBLCK.EQ.1 ) THEN LBA = CTAU(1) - 1 ELSE LBA = 0 END IF C C Compute the pertransposed dual system exploiting matrix shapes. C LBA = MAX( LBA, N-NOBSV-1 ) CALL TB01XD( 'Zero D', N, P, M, LBA, MAX( 0, N-1 ), A, LDA, B, $ LDB, C, LDC, DUM, 1, INFO ) IF( ILZ ) $ CALL MA02BD( 'Right', N, N, Z, LDZ ) DWORK(1) = DWORK(N+1) RETURN C *** Last line of TB01UX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01MD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01MD.f0000644000175000017500000001762415012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE MB01MD( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, $ INCY ) C C PURPOSE C C To perform the matrix-vector operation C C y := alpha*A*x + beta*y, C C where alpha and beta are scalars, x and y are vectors of length C n and A is an n-by-n skew-symmetric matrix. C C This is a modified version of the vanilla implemented BLAS C routine DSYMV written by Jack Dongarra, Jeremy Du Croz, C Sven Hammarling, and Richard Hanson. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies whether the upper or lower triangular part of C the array A is to be referenced as follows: C = 'U': only the strictly upper triangular part of A is to C be referenced; C = 'L': only the strictly lower triangular part of A is to C be referenced. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C ALPHA (input) DOUBLE PRECISION C The scalar alpha. If alpha is zero the array A is not C referenced. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C On entry with UPLO = 'U', the leading N-by-N part of this C array must contain the strictly upper triangular part of C the matrix A. The lower triangular part of this array is C not referenced. C On entry with UPLO = 'L', the leading N-by-N part of this C array must contain the strictly lower triangular part of C the matrix A. The upper triangular part of this array is C not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N) C C X (input) DOUBLE PRECISION array, dimension C ( 1 + ( N - 1 )*abs( INCX ) ). C On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of C this array must contain the elements of the vector X. C C INCX (input) INTEGER C The increment for the elements of X. IF INCX < 0 then the C elements of X are accessed in reversed order. INCX <> 0. C C BETA (input) DOUBLE PRECISION C The scalar beta. If beta is zero then Y need not be set on C input. C C Y (input/output) DOUBLE PRECISION array, dimension C ( 1 + ( N - 1 )*abs( INCY ) ). C On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of C this array must contain the elements of the vector Y. C On exit, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of C this array contain the updated elements of the vector Y. C C INCY (input) INTEGER C The increment for the elements of Y. IF INCY < 0 then the C elements of Y are accessed in reversed order. INCY <> 0. C C NUMERICAL ASPECTS C C Though being almost identical with the vanilla implementation C of the BLAS routine DSYMV the performance of this routine could C be significantly lower in the case of vendor supplied, highly C optimized BLAS. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, May 2008 (SLICOT version of the HAPACK routine DSKMV). C C KEYWORDS C C Elementary matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER INCX, INCY, LDA, N CHARACTER UPLO C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), X(*), Y(*) C .. Local Scalars .. DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = 1 ELSE IF ( N.LT.0 )THEN INFO = 2 ELSE IF ( LDA.LT.MAX( 1, N ) )THEN INFO = 5 ELSE IF ( INCX.EQ.0 )THEN INFO = 7 ELSE IF ( INCY.EQ.0 )THEN INFO = 10 END IF IF ( INFO.NE.0 )THEN CALL XERBLA( 'MB01MD', INFO ) RETURN END IF C C Quick return if possible. C IF ( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN C C Set up the start points in X and Y. C IF ( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX END IF IF ( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY END IF C C Start the operations. In this version the elements of A are C accessed sequentially with one pass through the triangular part C of A. C C First form y := beta*y. C IF ( BETA.NE.ONE )THEN IF ( INCY.EQ.1 )THEN IF ( BETA.EQ.ZERO )THEN DO 10 I = 1, N Y(I) = ZERO 10 CONTINUE ELSE DO 20 I = 1, N Y(I) = BETA*Y(I) 20 CONTINUE END IF ELSE IY = KY IF ( BETA.EQ.ZERO )THEN DO 30 I = 1, N Y(IY) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40 I = 1, N Y(IY) = BETA*Y(IY) IY = IY + INCY 40 CONTINUE END IF END IF END IF C C Quick return if possible. C IF ( ALPHA.EQ.ZERO ) $ RETURN IF ( LSAME( UPLO, 'U' ) )THEN C C Form y when A is stored in upper triangle. C IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN DO 60 J = 2, N TEMP1 = ALPHA*X(J) TEMP2 = ZERO DO 50, I = 1, J - 1 Y(I) = Y(I) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(I) 50 CONTINUE Y(J) = Y(J) - ALPHA*TEMP2 60 CONTINUE ELSE JX = KX + INCX JY = KY + INCY DO 80 J = 2, N TEMP1 = ALPHA*X(JX) TEMP2 = ZERO IX = KX IY = KY DO 70 I = 1, J - 1 Y(IY) = Y(IY) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(IX) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y(JY) = Y(JY) - ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 80 CONTINUE END IF ELSE C C Form y when A is stored in lower triangle. C IF ( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) )THEN DO 100 J = 1, N - 1 TEMP1 = ALPHA*X(J) TEMP2 = ZERO DO 90 I = J + 1, N Y(I) = Y(I) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(I) 90 CONTINUE Y(J) = Y(J) - ALPHA*TEMP2 100 CONTINUE ELSE JX = KX JY = KY DO 120 J = 1, N - 1 TEMP1 = ALPHA*X(JX) TEMP2 = ZERO IX = JX IY = JY DO 110 I = J + 1, N IX = IX + INCX IY = IY + INCY Y(IY ) = Y(IY) + TEMP1*A(I,J) TEMP2 = TEMP2 + A(I,J)*X(IX) 110 CONTINUE Y(JY) = Y(JY) - ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE END IF END IF C *** Last line of MB01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/FB01VD.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/FB01VD.f0000644000175000017500000003136215012430707017360 0ustar00lilgelilge00000000000000 SUBROUTINE FB01VD( N, M, L, P, LDP, A, LDA, B, LDB, C, LDC, Q, $ LDQ, R, LDR, K, LDK, TOL, IWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute one recursion of the conventional Kalman filter C equations. This is one update of the Riccati difference equation C and the Kalman filter gain. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The actual state dimension, i.e., the order of the C matrices P and A . N >= 0. C i|i-1 i C C M (input) INTEGER C The actual input dimension, i.e., the order of the matrix C Q . M >= 0. C i C C L (input) INTEGER C The actual output dimension, i.e., the order of the matrix C R . L >= 0. C i C C P (input/output) DOUBLE PRECISION array, dimension (LDP,N) C On entry, the leading N-by-N part of this array must C contain P , the state covariance matrix at instant C i|i-1 C (i-1). The upper triangular part only is needed. C On exit, if INFO = 0, the leading N-by-N part of this C array contains P , the state covariance matrix at C i+1|i C instant i. The strictly lower triangular part is not set. C Otherwise, the leading N-by-N part of this array contains C P , its input value. C i|i-1 C C LDP INTEGER C The leading dimension of array P. LDP >= MAX(1,N). C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must contain A , C i C the state transition matrix of the discrete system at C instant i. 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 B , C i C the input weight matrix of the discrete system at C instant i. 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 L-by-N part of this array must contain C , C i C the output weight matrix of the discrete system at C instant i. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,L). C C Q (input) DOUBLE PRECISION array, dimension (LDQ,M) C The leading M-by-M part of this array must contain Q , C i C the input (process) noise covariance matrix at instant i. C The diagonal elements of this array are modified by the C routine, but are restored on exit. C C LDQ INTEGER C The leading dimension of array Q. LDQ >= MAX(1,M). C C R (input/output) DOUBLE PRECISION array, dimension (LDR,L) C On entry, the leading L-by-L part of this array must C contain R , the output (measurement) noise covariance C i C matrix at instant i. C On exit, if INFO = 0, or INFO = L+1, the leading L-by-L C 1/2 C upper triangular part of this array contains (RINOV ) , C i C the square root (left Cholesky factor) of the covariance C matrix of the innovations at instant i. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,L). C C K (output) DOUBLE PRECISION array, dimension (LDK,L) C If INFO = 0, the leading N-by-L part of this array C contains K , the Kalman filter gain matrix at instant i. C i C If INFO > 0, the leading N-by-L part of this array C contains the matrix product P C'. C i|i-1 i C C LDK INTEGER C The leading dimension of array K. LDK >= MAX(1,N). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used to test for near singularity of C the matrix RINOV . If the user sets TOL > 0, then the C i C given value of TOL is used as a lower bound for the C reciprocal condition number of that matrix; a matrix whose C estimated condition number is less than 1/TOL is C considered to be nonsingular. If the user sets TOL <= 0, C then an implicitly computed, default tolerance, defined by C TOLDEF = L*L*EPS, is used instead, where EPS is the C machine precision (see LAPACK Library routine DLAMCH). C C Workspace C C IWORK INTEGER array, dimension (L) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, or INFO = L+1, DWORK(1) returns an C estimate of the reciprocal of the condition number (in the C 1-norm) of the matrix RINOV . C i C C LDWORK The length of the array DWORK. C LDWORK >= MAX(1,L*N+3*L,N*N,N*M). 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 = k: if INFO = k, 1 <= k <= L, the leading minor of order C k of the matrix RINOV is not positive-definite, and C i C its Cholesky factorization could not be completed; C = L+1: the matrix RINOV is singular, i.e., the condition C i C number estimate of RINOV (in the 1-norm) exceeds C i C 1/TOL. C C METHOD C C The conventional Kalman filter gain used at the i-th recursion C step is of the form C C -1 C K = P C' RINOV , C i i|i-1 i i C C where RINOV = C P C' + R , and the state covariance matrix C i i i|i-1 i i C C P is updated by the discrete-time difference Riccati equation C i|i-1 C C P = A (P - K C P ) A' + B Q B'. C i+1|i i i|i-1 i i i|i-1 i i i i C C Using these two updates, the combined time and measurement update C of the state X is given by C i|i-1 C C X = A X + A K (Y - C X ), C i+1|i i i|i-1 i i i i i|i-1 C C where Y is the new observation at step i. C i C C REFERENCES C C [1] Anderson, B.D.O. and Moore, J.B. C Optimal Filtering, C Prentice Hall, Englewood Cliffs, New Jersey, 1979. C C [2] Verhaegen, M.H.G. and Van Dooren, P. C Numerical Aspects of Different Kalman Filter Implementations. C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, 1986. C C NUMERICAL ASPECTS C C The algorithm requires approximately C C 3 2 C 3/2 x N + N x (3 x L + M/2) C C operations. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C Supersedes Release 2.0 routine FB01JD by M.H.G. Verhaegen, C M. Vanbegin, and P. Van Dooren. C C REVISIONS C C February 20, 1998, November 20, 2003, April 20, 2004. C C KEYWORDS C C Kalman filtering, optimal filtering, recursive estimation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. INTEGER INFO, L, LDA, LDB, LDC, LDK, LDP, LDQ, LDR, $ LDWORK, M, N DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), $ K(LDK,*), P(LDP,*), Q(LDQ,*), R(LDR,*) C .. Local Scalars .. INTEGER J, JWORK, LDW, N1 DOUBLE PRECISION RCOND, RNORM, TOLDEF C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL DLAMCH, DLANSY C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLACPY, DLASET, DPOCON, $ DPOTRF, DSCAL, DTRMM, DTRSM, MB01RD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 N1 = MAX( 1, N ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( L.LT.0 ) THEN INFO = -3 ELSE IF( LDP.LT.N1 ) THEN INFO = -5 ELSE IF( LDA.LT.N1 ) THEN INFO = -7 ELSE IF( LDB.LT.N1 ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, L ) ) THEN INFO = -11 ELSE IF( LDQ.LT.MAX( 1, M ) ) THEN INFO = -13 ELSE IF( LDR.LT.MAX( 1, L ) ) THEN INFO = -15 ELSE IF( LDK.LT.N1 ) THEN INFO = -17 ELSE IF( LDWORK.LT.MAX( 1, L*N + 3*L, N*N, N*M ) ) THEN INFO = -21 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'FB01VD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, L ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Efficiently compute RINOV = CPC' + R in R and put CP in DWORK and C PC' in K. (The content of DWORK on exit from MB01RD is used.) C Workspace: need L*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 CALL MB01RD( 'Upper', 'No transpose', L, N, ONE, ONE, R, LDR, C, $ LDC, P, LDP, DWORK, LDWORK, INFO ) LDW = MAX( 1, L ) C DO 10 J = 1, L CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 ) 10 CONTINUE C CALL DLACPY( 'Full', L, N, C, LDC, DWORK, LDW ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', L, N, ONE, $ P, LDP, DWORK, LDW ) CALL DSCAL( N, TWO, P, LDP+1 ) C DO 20 J = 1, L CALL DAXPY( N, ONE, K(1,J), 1, DWORK(J), LDW ) CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 ) 20 CONTINUE C C Calculate the Cholesky decomposition U'U of the innovation C covariance matrix RINOV, and its reciprocal condition number. C Workspace: need L*N + 3*L. C JWORK = L*N + 1 RNORM = DLANSY( '1-norm', 'Upper', L, R, LDR, DWORK(JWORK) ) C TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) $ TOLDEF = DBLE( L*L )*DLAMCH( 'Epsilon' ) CALL DPOTRF( 'Upper', L, R, LDR, INFO ) IF ( INFO.NE.0 ) $ RETURN C CALL DPOCON( 'Upper', L, R, LDR, RNORM, RCOND, DWORK(JWORK), $ IWORK, INFO ) C IF ( RCOND.LT.TOLDEF ) THEN C C Error return: RINOV is numerically singular. C INFO = L+1 DWORK(1) = RCOND RETURN END IF C IF ( L.GT.1 ) $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, R(2,1),LDR ) C -1 C Calculate the Kalman filter gain matrix K = PC'RINOV . C Workspace: need L*N. C CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, $ ONE, R, LDR, K, LDK ) CALL DTRSM( 'Right', 'Upper', 'Transpose', 'Non-unit', N, L, $ ONE, R, LDR, K, LDK ) C C First part of the Riccati equation update: compute A(P-KCP)A'. C The upper triangular part of the symmetric matrix P-KCP is formed. C Workspace: need max(L*N,N*N). C JWORK = 1 C DO 30 J = 1, N CALL DGEMV( 'No transpose', J, L, -ONE, K, LDK, DWORK(JWORK), $ 1, ONE, P(1,J), 1 ) JWORK = JWORK + L 30 CONTINUE C CALL MB01RD( 'Upper', 'No transpose', N, N, ZERO, ONE, P, LDP, A, $ LDA, P, LDP, DWORK, LDWORK, INFO ) C C Second part of the Riccati equation update: add BQB'. C Workspace: need N*M. C CALL MB01RD( 'Upper', 'No transpose', N, M, ONE, ONE, P, LDP, B, $ LDB, Q, LDQ, DWORK, LDWORK, INFO ) CALL DSCAL( M, TWO, Q, LDQ+1 ) C C Set the reciprocal of the condition number estimate. C DWORK(1) = RCOND C RETURN C *** Last line of FB01VD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02ED.f0000644000000000000000000000013215012430707016146 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02ED.f0000644000175000017500000003677315012430707017362 0ustar00lilgelilge00000000000000 SUBROUTINE MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To solve a system of linear equations T*X = B or X*T = B with C a symmetric positive definite (s.p.d.) block Toeplitz matrix T. C T is defined either by its first block row or its first block C column, depending on the parameter TYPET. C C ARGUMENTS C C Mode Parameters C C TYPET CHARACTER*1 C Specifies the type of T, as follows: C = 'R': T contains the first block row of an s.p.d. block C Toeplitz matrix, and the system X*T = B is solved; C = 'C': T contains the first block column of an s.p.d. C block Toeplitz matrix, and the system T*X = B is C solved. C Note: in the sequel, the notation x / y means that C x corresponds to TYPET = 'R' and y corresponds to C TYPET = 'C'. C C Input/Output Parameters C C K (input) INTEGER C The number of rows / columns in T, which should be equal C to the blocksize. K >= 0. C C N (input) INTEGER C The number of blocks in T. N >= 0. C C NRHS (input) INTEGER C The number of right hand sides. NRHS >= 0. C C T (input/output) DOUBLE PRECISION array, dimension C (LDT,N*K) / (LDT,K) C On entry, the leading K-by-N*K / N*K-by-K part of this C array must contain the first block row / column of an C s.p.d. block Toeplitz matrix. C On exit, if INFO = 0 and NRHS > 0, then the leading C K-by-N*K / N*K-by-K part of this array contains the last C row / column of the Cholesky factor of inv(T). C C LDT INTEGER C The leading dimension of the array T. C LDT >= MAX(1,K), if TYPET = 'R'; C LDT >= MAX(1,N*K), if TYPET = 'C'. C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,N*K) / (LDB,NRHS) C On entry, the leading NRHS-by-N*K / N*K-by-NRHS part of C this array must contain the right hand side matrix B. C On exit, the leading NRHS-by-N*K / N*K-by-NRHS part of C this array contains the solution matrix X. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,NRHS), if TYPET = 'R'; C LDB >= MAX(1,N*K), if TYPET = 'C'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -10, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1,N*K*K+(N+2)*K). 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: the reduction algorithm failed. The Toeplitz matrix C associated with T is not (numerically) positive C definite. C C METHOD C C Householder transformations, modified hyperbolic rotations and C block Gaussian eliminations are used in the Schur algorithm [1], C [2]. C C REFERENCES C C [1] Kailath, T. and Sayed, A. C Fast Reliable Algorithms for Matrices with Structure. C SIAM Publications, Philadelphia, 1999. C C [2] Kressner, D. and Van Dooren, P. C Factorizations and linear system solvers for matrices with C Toeplitz structure. C SLICOT Working Note 2000-2, 2000. C C NUMERICAL ASPECTS C C The implemented method is numerically equivalent with forming C the Cholesky factor R and the inverse Cholesky factor of T, using C the generalized Schur algorithm, and solving the systems of C equations R*X = L*B or X*R = B*L by a blocked backward C substitution algorithm. C 3 2 2 2 C The algorithm requires 0(K N + K N NRHS) floating point C operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Chemnitz, Germany, December 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, C February 2004. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER TYPET INTEGER INFO, K, LDB, LDT, LDWORK, N, NRHS C .. Array Arguments .. DOUBLE PRECISION B(LDB,*), DWORK(*), T(LDT,*) C .. Local Scalars .. INTEGER I, IERR, MAXWRK, STARTH, STARTI, STARTN, $ STARTR, STARTT LOGICAL ISROW C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, DPOTRF, DTRMM, DTRSM, $ MB02CX, MB02CY, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 ISROW = LSAME( TYPET, 'R' ) C C Check the scalar input parameters. C IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN INFO = -1 ELSE IF ( K.LT.0 ) THEN INFO = -2 ELSE IF ( N.LT.0 ) THEN INFO = -3 ELSE IF ( NRHS.LT.0 ) THEN INFO = -4 ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN INFO = -6 ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.NRHS ) .OR. $ ( .NOT.ISROW .AND. LDB.LT.N*K ) ) THEN INFO = -8 ELSE IF ( LDWORK.LT.MAX( 1, N*K*K + ( N + 2 )*K ) ) THEN DWORK(1) = MAX( 1, N*K*K + ( N + 2 )*K ) INFO = -10 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02ED', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( K, N, NRHS ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C MAXWRK = 0 STARTN = 1 STARTT = N*K*K + 1 STARTH = STARTT + 3*K C IF ( ISROW ) THEN C C T is the first block row of a block Toeplitz matrix. C Bring T to proper form by triangularizing its first block. C CALL DPOTRF( 'Upper', K, T, LDT, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C IF ( N.GT.1 ) $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) C C Initialize the generator, do the first Schur step and set C B = -B. C T contains the nonzero blocks of the positive parts in the C generator and the inverse generator. C DWORK(STARTN) contains the nonzero blocks of the negative parts C in the generator and the inverse generator. C CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit', NRHS, $ K, ONE, T, LDT, B, LDB ) IF ( N.GT.1 ) $ CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (N-1)*K, $ K, ONE, B, LDB, T(1,K+1), LDT, -ONE, B(1,K+1), $ LDB ) C CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), K ) CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, K, $ ONE, T, LDT, DWORK(STARTN), K ) IF ( N.GT.1 ) $ CALL DLACPY( 'All', K, (N-1)*K, T(1,K+1), LDT, $ DWORK(STARTN+K*K), K ) CALL DLACPY( 'All', K, K, DWORK(STARTN), K, T(1,(N-1)*K+1), $ LDT ) C CALL DTRMM ( 'Right', 'Lower', 'NonTranspose', 'NonUnit', NRHS, $ K, ONE, T(1,(N-1)*K+1), LDT, B, LDB ) C C Processing the generator. C DO 10 I = 2, N STARTR = ( I - 1 )*K + 1 STARTI = ( N - I )*K + 1 C C Transform the generator of T to proper form. C CALL MB02CX( 'Row', K, K, K, T, LDT, $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K, $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) C IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, $ T(1,K+1), LDT, DWORK(STARTN+I*K*K), K, $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) C C Block Gaussian eliminates the i-th block in B. C CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit', $ NRHS, K, -ONE, T, LDT, B(1,STARTR), LDB ) IF ( N.GT.I ) $ CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, $ (N-I)*K, K, ONE, B(1,STARTR), LDB, T(1,K+1), $ LDT, ONE, B(1,STARTR+K), LDB ) C C Apply hyperbolic transformations on the negative generator. C CALL DLASET( 'All', K, K, ZERO, ZERO, T(1,STARTI), LDT ) CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K, $ T(1,STARTI), LDT, DWORK(STARTN), K, $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K, $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) C C Note that DWORK(STARTN+(I-1)*K*K) serves simultaneously C as the transformation container as well as the new block in C the negative generator. C CALL MB02CY( 'Row', 'Triangular', K, K, K, K, $ T(1,(N-1)*K+1), LDT, DWORK(STARTN+(I-1)*K*K), $ K, DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) C C Finally the Gaussian elimination is applied on the inverse C generator. C CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (I-1)*K, $ K, ONE, B(1,STARTR), LDB, T(1,STARTI), LDT, ONE, $ B, LDB ) CALL DTRMM( 'Right', 'Lower', 'NonTranspose', 'NonUnit', $ NRHS, K, ONE, T(1,(N-1)*K+1), LDT, B(1,STARTR), $ LDB ) 10 CONTINUE C ELSE C C T is the first block column of a block Toeplitz matrix. C Bring T to proper form by triangularizing its first block. C CALL DPOTRF( 'Lower', K, T, LDT, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C IF ( N.GT.1 ) $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) C C Initialize the generator, do the first Schur step and set C B = -B. C T contains the nonzero blocks of the positive parts in the C generator and the inverse generator. C DWORK(STARTN) contains the nonzero blocks of the negative parts C in the generator and the inverse generator. C CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K, $ NRHS, ONE, T, LDT, B, LDB ) IF ( N.GT.1 ) $ CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-1)*K, NRHS, $ K, ONE, T(K+1,1), LDT, B, LDB, -ONE, B(K+1,1), $ LDB ) C CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), N*K ) CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', K, K, $ ONE, T, LDT, DWORK(STARTN), N*K ) IF ( N.GT.1 ) $ CALL DLACPY( 'All', (N-1)*K, K, T(K+1,1), LDT, $ DWORK(STARTN+K), N*K ) CALL DLACPY( 'All', K, K, DWORK(STARTN), N*K, T((N-1)*K+1,1), $ LDT ) C CALL DTRMM ( 'Left', 'Upper', 'NonTranspose', 'NonUnit', K, $ NRHS, ONE, T((N-1)*K+1,1), LDT, B, LDB ) C C Processing the generator. C DO 20 I = 2, N STARTR = ( I - 1 )*K + 1 STARTI = ( N - I )*K + 1 C C Transform the generator of T to proper form. C CALL MB02CX( 'Column', K, K, K, T, LDT, $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K, $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) C IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, K, $ T(K+1,1), LDT, DWORK(STARTN+I*K), N*K, $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) C C Block Gaussian eliminates the i-th block in B. C CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K, $ NRHS, -ONE, T, LDT, B(STARTR,1), LDB ) IF ( N.GT.I ) $ CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-I)*K, $ NRHS, K, ONE, T(K+1,1), LDT, B(STARTR,1), $ LDB, ONE, B(STARTR+K,1), LDB ) C C Apply hyperbolic transformations on the negative generator. C CALL DLASET( 'All', K, K, ZERO, ZERO, T(STARTI,1), LDT ) CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K, $ T(STARTI,1), LDT, DWORK(STARTN), N*K, $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K, $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) C C Note that DWORK(STARTN+(I-1)*K) serves simultaneously C as the transformation container as well as the new block in C the negative generator. C CALL MB02CY( 'Column', 'Triangular', K, K, K, K, $ T((N-1)*K+1,1), LDT, DWORK(STARTN+(I-1)*K), $ N*K, DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) C C Finally the Gaussian elimination is applied on the inverse C generator. C CALL DGEMM( 'NonTranspose', 'NonTranspose', (I-1)*K, NRHS, $ K, ONE, T(STARTI,1), LDT, B(STARTR,1), LDB, ONE, $ B, LDB ) CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', $ K, NRHS, ONE, T((N-1)*K+1,1), LDT, B(STARTR,1), $ LDB ) C 20 CONTINUE C END IF C DWORK(1) = MAX( 1, STARTH - 1 + MAXWRK ) C RETURN C C *** Last line of MB02ED *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01WD.f0000644000000000000000000000013215012430707016176 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TB01WD.f0000644000175000017500000001763015012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU, $ WR, WI, DWORK, LDWORK, INFO ) C C PURPOSE C C To reduce the system state matrix A to an upper real Schur form C by using an orthogonal similarity transformation A <-- U'*A*U and C to apply the transformation to the matrices B and C: B <-- U'*B C and C <-- C*U. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e. the order of the matrix A. N >= 0. C C M (input) INTEGER C The number of system inputs, or of columns of B. M >= 0. C C P (input) INTEGER C The number of system outputs, or of rows of C. 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 original state dynamics matrix A. C On exit, the leading N-by-N part of this array contains C the matrix U' * A * U in real Schur form. The elements C below the first subdiagonal are set to zero. C Note: A matrix is in real Schur form if it is upper C quasi-triangular with 1-by-1 and 2-by-2 blocks. C 2-by-2 blocks are standardized in the form C [ a b ] C [ c a ] C where b*c < 0. The eigenvalues of such a block C are a +- sqrt(bc). 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 matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix U' * B. 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 output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed output matrix C * U. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C U (output) DOUBLE PRECISION array, dimension (LDU,N) C The leading N-by-N part of this array contains the C orthogonal transformation matrix used to reduce A to the C real Schur form. The columns of U are the Schur vectors of C matrix A. C C LDU INTEGER C The leading dimension of array U. LDU >= max(1,N). C C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) C WR and WI contain the real and imaginary parts, C respectively, of the computed eigenvalues of A. The C eigenvalues will be in the same order that they appear on C the diagonal of the output real Schur form of A. Complex C conjugate pairs of eigenvalues will appear consecutively C with the eigenvalue having the positive imaginary part C first. 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. LWORK >= 3*N. 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 C all the eigenvalues; elements i+1:N of WR and WI C contain those eigenvalues which have converged; C U contains the matrix which reduces A to its C partially converged Schur form. C C METHOD C C Matrix A is reduced to a real Schur form using an orthogonal C similarity transformation A <- U'*A*U. Then, the transformation C is applied to the matrices B and C: B <-- U'*B and C <-- C*U. C C NUMERICAL ASPECTS C 3 C The algorithm requires about 10N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, March 1998. C Based on the RASP routine SRSFDC. C C REVISIONS C C - C C KEYWORDS C C Orthogonal transformation, real Schur form, similarity C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), $ WI(*), WR(*) C .. Local Scalars .. INTEGER I, LDWP, SDIM DOUBLE PRECISION WRKOPT C .. Local Arrays .. LOGICAL BWORK( 1 ) C .. External Functions .. LOGICAL LSAME, SELECT EXTERNAL LSAME, SELECT C .. External Subroutines .. EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C C .. Executable Statements .. C INFO = 0 C C Check input parameters. 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -9 ELSE IF( LDU.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDWORK.LT.3*N ) THEN INFO = -15 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01WD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C C Reduce A to real Schur form using an orthogonal similarity C transformation A <- U'*A*U, accumulate the transformation in U C and compute the eigenvalues of A in (WR,WI). C C Workspace: need 3*N; C prefer larger. C CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) WRKOPT = DWORK( 1 ) IF( INFO.NE.0 ) $ RETURN C C Apply the transformation: B <-- U'*B. C IF( LDWORK.LT.N*M ) THEN C C Not enough working space for using DGEMM. C DO 10 I = 1, M CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, $ B(1,I), 1 ) 10 CONTINUE C ELSE CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU, $ DWORK, N, ZERO, B, LDB ) WRKOPT = MAX( WRKOPT, DBLE( N*M ) ) END IF C C Apply the transformation: C <-- C*U. C IF( LDWORK.LT.N*P ) THEN C C Not enough working space for using DGEMM. C DO 20 I = 1, P CALL DCOPY( N, C(I,1), LDC, DWORK, 1 ) CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, $ C(I,1), LDC ) 20 CONTINUE C ELSE LDWP = MAX( 1, P ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP ) CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, $ DWORK, LDWP, U, LDU, ZERO, C, LDC ) WRKOPT = MAX( WRKOPT, DBLE( N*P ) ) END IF C DWORK( 1 ) = WRKOPT C RETURN C *** Last line of TB01WD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01RX.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB01RX.f0000644000175000017500000002454215012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE MB01RX( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, $ A, LDA, B, LDB, INFO ) 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 control-4.1.2/src/slicot/src/PaxHeaders/TG01FZ.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/TG01FZ.f0000644000175000017500000006313415012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE TG01FZ( COMPQ, COMPZ, JOBA, L, N, M, P, A, LDA, E, LDE, $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) C C PURPOSE C C To compute for the descriptor system (A-lambda E,B,C) C the unitary transformation matrices Q and Z such that the C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is C in a SVD-like coordinate form with C C ( A11 A12 ) ( Er 0 ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) , C ( A21 A22 ) ( 0 0 ) C C where Er is an upper triangular invertible matrix, and ' denotes C the conjugate transpose. Optionally, the A22 matrix can be further C reduced to the form C C ( Ar X ) C A22 = ( ) , C ( 0 0 ) C C with Ar an upper triangular invertible matrix, and X either a full C or a zero matrix. C The left and/or right unitary transformations performed C to reduce E and A22 can be optionally accumulated. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C = 'N': do not compute Q; C = 'I': Q is initialized to the unit matrix, and the C unitary matrix Q is returned; C = 'U': Q must contain a unitary matrix Q1 on entry, C and the product Q1*Q is returned. C C COMPZ CHARACTER*1 C = 'N': do not compute Z; C = 'I': Z is initialized to the unit matrix, and the C unitary matrix Z is returned; C = 'U': Z must contain a unitary matrix Z1 on entry, C and the product Z1*Z is returned. C C JOBA CHARACTER*1 C = 'N': do not reduce A22; C = 'R': reduce A22 to a SVD-like upper triangular form. C = 'T': reduce A22 to an upper trapezoidal form. C C Input/Output Parameters C C L (input) INTEGER C The number of rows of matrices A, B, and E. L >= 0. C C N (input) INTEGER C The number of columns of matrices A, E, and C. N >= 0. C C M (input) INTEGER C The number of columns of matrix B. M >= 0. C C P (input) INTEGER C The number of rows of matrix C. P >= 0. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the state dynamics matrix A. C On exit, the leading L-by-N part of this array contains C the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix C is in the form C C ( A11 * * ) C Q'*A*Z = ( * Ar X ) , C ( * 0 0 ) C C where A11 is a RANKE-by-RANKE matrix and Ar is a C RNKA22-by-RNKA22 invertible upper triangular matrix. C If JOBA = 'R' then A has the above form with X = 0. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,L). C C E (input/output) COMPLEX*16 array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the descriptor matrix E. C On exit, the leading L-by-N part of this array contains C the transformed matrix Q'*E*Z. C C ( Er 0 ) C Q'*E*Z = ( ) , C ( 0 0 ) C C where Er is a RANKE-by-RANKE upper triangular invertible C matrix. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,L). C C B (input/output) COMPLEX*16 array, dimension (LDB,M) C On entry, the leading L-by-M part of this array must C contain the input/state matrix B. C On exit, the leading L-by-M part of this array contains C the transformed matrix Q'*B. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. C C C (input/output) COMPLEX*16 array, dimension (LDC,N) C On entry, the leading P-by-N part of this array must C contain the state/output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Z. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C Q (input/output) COMPLEX*16 array, dimension (LDQ,L) C If COMPQ = 'N': Q is not referenced. C If COMPQ = 'I': on entry, Q need not be set; C on exit, the leading L-by-L part of this C array contains the unitary matrix Q, C where Q' is the product of Householder C transformations which are applied to A, C E, and B on the left. C If COMPQ = 'U': on entry, the leading L-by-L part of this C array must contain a unitary matrix Q1; C on exit, the leading L-by-L part of this C array contains the unitary matrix Q1*Q. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. C C Z (input/output) COMPLEX*16 array, dimension (LDZ,N) C If COMPZ = 'N': Z is not referenced. C If COMPZ = 'I': on entry, Z need not be set; C on exit, the leading N-by-N part of this C array contains the unitary matrix Z, C which is the product of Householder C transformations applied to A, E, and C C on the right. C If COMPZ = 'U': on entry, the leading N-by-N part of this C array must contain a unitary matrix Z1; C on exit, the leading N-by-N part of this C array contains the unitary matrix Z1*Z. C C LDZ INTEGER C The leading dimension of array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. C C RANKE (output) INTEGER C The estimated rank of matrix E, and thus also the order C of the invertible upper triangular submatrix Er. C C RNKA22 (output) INTEGER C If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of C matrix A22, and thus also the order of the invertible C upper triangular submatrix Ar. C If JOBA = 'N', then RNKA22 is not referenced. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in determining the rank of E C and of A22. If the user sets TOL > 0, then the given C value of TOL is used as a lower bound for the C reciprocal condition numbers of leading submatrices C of R or R22 in the QR decompositions E * P = Q * R of E C or A22 * P22 = Q22 * R22 of A22. C A submatrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = L*N*EPS, is used instead, where C EPS is the machine precision (see LAPACK Library routine C DLAMCH). TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (N) C C DWORK DOUBLE PRECISION array, dimension (2*N) C C ZWORK DOUBLE PRECISION array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal value C of LZWORK. C C LZWORK INTEGER C The length of the array ZWORK. C LZWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ). C For optimal performance, LZWORK should be larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK 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 computes a truncated QR factorization with column C pivoting of E, in the form C C ( E11 E12 ) C E * P = Q * ( ) C ( 0 E22 ) C C and finds the largest RANKE-by-RANKE leading submatrix E11 whose C estimated condition number is less than 1/TOL. RANKE defines thus C the rank of matrix E. Further E22, being negligible, is set to C zero, and a unitary matrix Y is determined such that C C ( E11 E12 ) = ( Er 0 ) * Y . C C The overal transformation matrix Z results as Z = P * Y' and the C resulting transformed matrices Q'*A*Z and Q'*E*Z have the form C C ( Er 0 ) ( A11 A12 ) C E <- Q'* E * Z = ( ) , A <- Q' * A * Z = ( ) , C ( 0 0 ) ( A21 A22 ) C C where Er is an upper triangular invertible matrix. C If JOBA = 'R' the same reduction is performed on A22 to obtain it C in the form C C ( Ar 0 ) C A22 = ( ) , C ( 0 0 ) C C with Ar an upper triangular invertible matrix. C If JOBA = 'T' then A22 is row compressed using the QR C factorization with column pivoting to the form C C ( Ar X ) C A22 = ( ) C ( 0 0 ) C C with Ar an upper triangular invertible matrix. C C The transformations are also applied to the rest of system C matrices C C B <- Q' * B, C <- C * Z. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( L*L*N ) floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C March 1999. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2011, C Feb. 2017. C C KEYWORDS C C Descriptor system, matrix algebra, matrix operations, unitary C transformation. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) DOUBLE PRECISION DONE, DZERO PARAMETER ( DONE = 1.0D+0, DZERO = 0.0D+0 ) C .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, JOBA INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDZ, LZWORK, $ M, N, P, RANKE, RNKA22 DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), $ E( LDE, * ), Q( LDQ, * ), Z( LDZ, * ), $ ZWORK( * ) DOUBLE PRECISION DWORK( * ) C .. Local Scalars .. LOGICAL ILQ, ILZ, LQUERY, REDA, REDTR, WITHB, WITHC INTEGER I, ICOMPQ, ICOMPZ, IR1, IRE1, J, K, KW, LA22, $ LH, LN, LWR, NA22, WRKOPT DOUBLE PRECISION SVLMAX, TOLDEF C .. Local Arrays .. DOUBLE PRECISION SVAL(3) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL DLAMCH, LSAME, ZLANGE C .. External Subroutines .. EXTERNAL MB3OYZ, XERBLA, ZLASET, ZSWAP, ZTZRZF, ZUNMQR, $ ZUNMRZ C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C C .. Executable Statements .. C C Decode COMPQ. C IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'U' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF C C Decode COMPZ. C IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'U' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF REDA = LSAME( JOBA, 'R' ) REDTR = LSAME( JOBA, 'T' ) WITHB = M.GT.0 WITHC = P.GT.0 LQUERY = ( LZWORK.EQ.-1 ) C C Test the input parameters. C LN = MIN( L, N ) INFO = 0 WRKOPT = MAX( 1, N+P, LN + MAX( 3*N-1, M, L ) ) IF( ICOMPQ.LE.0 ) THEN INFO = -1 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -2 ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA .AND. $ .NOT.REDTR ) THEN INFO = -3 ELSE IF( L.LT.0 ) 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( LDA.LT.MAX( 1, L ) ) THEN INFO = -9 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -11 ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.L ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN INFO = -17 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -19 ELSE IF( TOL.GE.DONE ) THEN INFO = -22 ELSE IF( LQUERY ) THEN CALL ZUNMQR( 'Left', 'ConjTranspose', L, N, LN, E, LDE, $ ZWORK, A, LDA, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(1) ) ) IF( WITHB ) THEN CALL ZUNMQR( 'Left', 'ConjTranspose', L, M, LN, E, LDE, $ ZWORK, B, LDB, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(1) ) ) END IF IF( ILQ ) THEN CALL ZUNMQR( 'Right', 'No Transpose', L, L, LN, E, LDE, $ ZWORK, Q, LDQ, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(1) ) ) END IF K = MIN( L, N-1 ) CALL ZTZRZF( K, N, E, LDE, ZWORK, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(1) ) ) CALL ZUNMRZ( 'Right', 'Conjugate transpose', L, N, K, N, E, $ LDE, ZWORK, A, LDA, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, N + INT( ZWORK(1) ) ) IF( WITHC ) THEN CALL ZUNMRZ( 'Right', 'Conjugate transpose', P, N, K, N, $ E, LDE, ZWORK, C, LDC, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, N + INT( ZWORK(1) ) ) END IF IF( ILZ ) THEN CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N, K, N, $ E, LDE, ZWORK, Z, LDZ, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, N + INT( ZWORK(1) ) ) END IF ELSE IF( LZWORK.LT.WRKOPT ) THEN INFO = -26 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01FZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN ZWORK(1) = WRKOPT RETURN END IF C C Initialize Q and Z if necessary. C IF( ICOMPQ.EQ.3 ) $ CALL ZLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL ZLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) C C Quick return if possible. C IF( L.EQ.0 .OR. N.EQ.0 ) THEN ZWORK(1) = ONE RANKE = 0 IF( REDA .OR. REDTR ) RNKA22 = 0 RETURN END IF C TOLDEF = TOL IF( TOLDEF.LE.DZERO ) THEN C C Use the default tolerance for rank determination. C TOLDEF = DBLE( L*N )*DLAMCH( 'EPSILON' ) END IF C SVLMAX = ZERO C C Compute the rank-revealing QR decomposition of E, C C ( E11 E12 ) C E * P = Qr * ( ) , C ( 0 E22 ) C C and determine the rank of E using incremental condition C estimation. C Complex Workspace: MIN(L,N) + 3*N - 1. C Real Workspace: 2*N. C LWR = LZWORK - LN KW = LN + 1 C CALL MB3OYZ( L, N, E, LDE, TOLDEF, SVLMAX, RANKE, SVAL, IWORK, $ ZWORK, DWORK, ZWORK(KW), INFO ) C C Apply transformation on the rest of matrices. C IF( RANKE.GT.0 ) THEN C C A <-- Qr' * A. C Complex Workspace: need MIN(L,N) + N; C prefer MIN(L,N) + N*NB. C CALL ZUNMQR( 'Left', 'ConjTranspose', L, N, RANKE, E, LDE, $ ZWORK, A, LDA, ZWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) C C B <-- Qr' * B. C Complex Workspace: need MIN(L,N) + M; C prefer MIN(L,N) + M*NB. C IF( WITHB ) THEN CALL ZUNMQR( 'Left', 'ConjTranspose', L, M, RANKE, E, LDE, $ ZWORK, B, LDB, ZWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) END IF C C Q <-- Q * Qr. C Complex Workspace: need MIN(L,N) + L; C prefer MIN(L,N) + L*NB. C IF( ILQ ) THEN CALL ZUNMQR( 'Right', 'No Transpose', L, L, RANKE, E, LDE, $ ZWORK, Q, LDQ, ZWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) END IF C C Set lower triangle of E to zero. C IF( L.GE.2 ) $ CALL ZLASET( 'Lower', L-1, RANKE, ZERO, ZERO, E(2,1), LDE ) C C Compute A*P, C*P and Z*P by forward permuting the columns of C A, C and Z based on information in IWORK. C DO 10 J = 1, N IWORK(J) = -IWORK(J) 10 CONTINUE DO 30 I = 1, N IF( IWORK(I).LT.0 ) THEN J = I IWORK(J) = -IWORK(J) 20 CONTINUE K = IWORK(J) IF( IWORK(K).LT.0 ) THEN CALL ZSWAP( L, A(1,J), 1, A(1,K), 1 ) IF( WITHC ) $ CALL ZSWAP( P, C(1,J), 1, C(1,K), 1 ) IF( ILZ ) $ CALL ZSWAP( N, Z(1,J), 1, Z(1,K), 1 ) IWORK(K) = -IWORK(K) J = K GO TO 20 END IF END IF 30 CONTINUE C C Determine a unitary matrix Y such that C C ( E11 E12 ) = ( Er 0 ) * Y . C C Compute E <-- E*Y', A <-- A*Y', C <-- C*Y', Z <-- Z*Y'. C IF( RANKE.LT.N ) THEN C C Complex Workspace: need 2*N; C prefer N + N*NB. C KW = RANKE + 1 CALL ZTZRZF( RANKE, N, E, LDE, ZWORK, ZWORK(KW), $ LZWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) C C Complex Workspace: need N + MAX(L,P,N); C prefer N + MAX(L,P,N)*NB. C LH = N - RANKE CALL ZUNMRZ( 'Right', 'Conjugate transpose', L, N, RANKE, $ LH, E, LDE, ZWORK, A, LDA, ZWORK(KW), $ LZWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) IF( WITHC ) THEN CALL ZUNMRZ( 'Right', 'Conjugate transpose', P, N, RANKE, $ LH, E, LDE, ZWORK, C, LDC, ZWORK(KW), $ LZWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) END IF IF( ILZ ) THEN CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N, RANKE, $ LH, E, LDE, ZWORK, Z, LDZ, ZWORK(KW), $ LZWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) END IF C C Set E12 and E22 to zero. C CALL ZLASET( 'Full', L, LH, ZERO, ZERO, E(1,KW), LDE ) END IF ELSE CALL ZLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) END IF C C Reduce A22 if necessary. C IF( REDA .OR. REDTR ) THEN LA22 = L - RANKE NA22 = N - RANKE IF( MIN( LA22, NA22 ).EQ.0 ) THEN RNKA22 = 0 ELSE C C Compute the rank-revealing QR decomposition of A22, C C ( R11 R12 ) C A22 * P2 = Q2 * ( ) , C ( 0 R22 ) C C and determine the rank of A22 using incremental C condition estimation. C Complex Workspace: MIN(L,N) + 3*N - 1. C Real Workspace: 2*N. C C Set the estimate of maximum singular value of A to detect C a negligible A matrix. C SVLMAX = ZLANGE( 'Frobenius', L, N, A, LDA, DWORK ) IR1 = RANKE + 1 CALL MB3OYZ( LA22, NA22, A(IR1,IR1), LDA, TOLDEF, $ SVLMAX, RNKA22, SVAL, IWORK, ZWORK, $ DWORK, ZWORK(KW), INFO ) C C Apply transformation on the rest of matrices. C IF( RNKA22.GT.0 ) THEN C C A <-- diag(I, Q2') * A C Complex Workspace: need MIN(L,N) + N; C prefer MIN(L,N) + N*NB. C CALL ZUNMQR( 'Left', 'ConjTranspose', LA22, RANKE, $ RNKA22, A(IR1,IR1), LDA, ZWORK, A(IR1,1), $ LDA, ZWORK(KW), LWR, INFO ) C C B <-- diag(I, Q2') * B C Complex Workspace: need MIN(L,N) + M; C prefer MIN(L,N) + M*NB. C IF ( WITHB ) $ CALL ZUNMQR( 'Left', 'ConjTranspose', LA22, M, RNKA22, $ A(IR1,IR1), LDA, ZWORK, B(IR1,1), LDB, $ ZWORK(KW), LWR, INFO ) C C Q <-- Q * diag(I, Q2) C Complex Workspace: need MIN(L,N) + L; C prefer MIN(L,N) + L*NB. C IF( ILQ ) $ CALL ZUNMQR( 'Right', 'No transpose', L, LA22, RNKA22, $ A(IR1,IR1), LDA, ZWORK, Q(1,IR1), LDQ, $ ZWORK(KW), LWR, INFO ) C C Set lower triangle of A22 to zero. C IF( LA22.GE.2 ) $ CALL ZLASET( 'Lower', LA22-1, RNKA22, ZERO, ZERO, $ A(IR1+1,IR1), LDA ) C C Compute A*diag(I,P2), C*diag(I,P2) and Z*diag(I,P2) C by forward permuting the columns of A, C and Z based C on information in IWORK. C DO 40 J = 1, NA22 IWORK(J) = -IWORK(J) 40 CONTINUE DO 60 I = 1, NA22 IF( IWORK(I).LT.0 ) THEN J = I IWORK(J) = -IWORK(J) 50 CONTINUE K = IWORK(J) IF( IWORK(K).LT.0 ) THEN CALL ZSWAP( RANKE, A(1,RANKE+J), 1, $ A(1,RANKE+K), 1 ) IF( WITHC ) $ CALL ZSWAP( P, C(1,RANKE+J), 1, $ C(1,RANKE+K), 1 ) IF( ILZ ) $ CALL ZSWAP( N, Z(1,RANKE+J), 1, $ Z(1,RANKE+K), 1 ) IWORK(K) = -IWORK(K) J = K GO TO 50 END IF END IF 60 CONTINUE C IF( REDA .AND. RNKA22.LT.NA22 ) THEN C C Determine a unitary matrix Y2 such that C C ( R11 R12 ) = ( Ar 0 ) * Y2 . C C Compute A <-- A*diag(I, Y2'), C <-- C*diag(I, Y2'), C Z <-- Z*diag(I, Y2'). C C Complex Workspace: need 2*N; C prefer N + N*NB. C KW = RANKE + 1 CALL ZTZRZF( RNKA22, NA22, A(IR1,IR1), LDA, ZWORK, $ ZWORK(KW), LZWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) C C Complex Workspace: need N + MAX(P,N); C prefer N + MAX(P,N)*NB. C LH = NA22 - RNKA22 IF( WITHC ) THEN CALL ZUNMRZ( 'Right', 'Conjugate transpose', P, N, $ RNKA22, LH, A(IR1,IR1), LDA, ZWORK, C, $ LDC, ZWORK(KW), LZWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) END IF IF( ILZ ) THEN CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N, $ RNKA22, LH, A(IR1,IR1), LDA, ZWORK, Z, $ LDZ, ZWORK(KW), LZWORK-KW+1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) END IF IRE1 = RANKE + RNKA22 + 1 C C Set R12 and R22 to zero. C CALL ZLASET( 'Full', LA22, LH, ZERO, ZERO, $ A(IR1,IRE1), LDA ) END IF ELSE CALL ZLASET( 'Full', LA22, NA22, ZERO, ZERO, $ A(IR1,IR1), LDA) END IF END IF END IF C ZWORK(1) = WRKOPT C RETURN C *** Last line of TG01FZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03MD.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03MD.f0000644000175000017500000002723515012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE MB03MD( N, L, THETA, Q, E, Q2, E2, PIVMIN, TOL, RELTOL, $ IWARN, INFO ) C C PURPOSE C C To compute an upper bound THETA using a bisection method such that C the bidiagonal matrix C C |q(1) e(1) 0 ... 0 | C | 0 q(2) e(2) . | C J = | . . | C | . e(N-1)| C | 0 ... ... q(N) | C C has precisely L singular values less than or equal to THETA plus C a given tolerance TOL. C C This routine is mainly intended to be called only by other SLICOT C routines. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the bidiagonal matrix J. N >= 0. C C L (input/output) INTEGER C On entry, L must contain the number of singular values C of J which must be less than or equal to the upper bound C computed by the routine. 0 <= L <= N. C On exit, L may be increased if the L-th smallest singular C value of J has multiplicity greater than 1. In this case, C L is increased by the number of singular values of J which C are larger than its L-th smallest one and approach the C L-th smallest singular value of J within a distance less C than TOL. C If L has been increased, then the routine returns with C IWARN set to 1. C C THETA (input/output) DOUBLE PRECISION C On entry, THETA must contain an initial estimate for the C upper bound to be computed. If THETA < 0.0 on entry, then C one of the following default values is used. C If L = 0, THETA is set to 0.0 irrespective of the input C value of THETA; if L = 1, then THETA is taken as C MIN(ABS(Q(i))), for i = 1,2,...,N; otherwise, THETA is C taken as ABS(Q(N-L+1)). C On exit, THETA contains the computed upper bound such that C the bidiagonal matrix J has precisely L singular values C less than or equal to THETA + TOL. C C Q (input) DOUBLE PRECISION array, dimension (N) C This array must contain the diagonal elements q(1), C q(2),...,q(N) of the bidiagonal matrix J. That is, C Q(i) = J(i,i) for i = 1,2,...,N. C C E (input) DOUBLE PRECISION array, dimension (N-1) C This array must contain the superdiagonal elements C e(1),e(2),...,e(N-1) of the bidiagonal matrix J. That is, C E(k) = J(k,k+1) for k = 1,2,...,N-1. C C Q2 (input) DOUBLE PRECISION array, dimension (N) C This array must contain the squares of the diagonal C elements q(1),q(2),...,q(N) of the bidiagonal matrix J. C That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N. C C E2 (input) DOUBLE PRECISION array, dimension (N-1) C This array must contain the squares of the superdiagonal C elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J. C That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1. C C PIVMIN (input) DOUBLE PRECISION C The minimum absolute value of a "pivot" in the Sturm C sequence loop. C PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ), C where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at C least the smallest number that can divide one without C overflow (see LAPACK Library routine DLAMCH). C Note that this condition is not checked by the routine. C C Tolerances C C TOL DOUBLE PRECISION C This parameter defines the multiplicity of singular values C by considering all singular values within an interval of C length TOL as coinciding. TOL is used in checking how many C singular values are less than or equal to THETA. Also in C computing an appropriate upper bound THETA by a bisection C method, TOL is used as a stopping criterion defining the C minimum (absolute) subinterval width. TOL >= 0. C C RELTOL DOUBLE PRECISION C This parameter specifies the minimum relative width of an C interval. When an interval is narrower than TOL, or than C RELTOL times the larger (in magnitude) endpoint, then it C is considered to be sufficiently small and bisection has C converged. C RELTOL >= BASE * EPS, where BASE is machine radix and EPS C is machine precision (see LAPACK Library routine DLAMCH). C C Warning Indicator C C IWARN INTEGER C = 0: no warnings; C = 1: if the value of L has been increased as the L-th C smallest singular value of J coincides with the C (L+1)-th smallest one. 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 s(i), i = 1,2,...,N, be the N non-negative singular values of C the bidiagonal matrix J arranged so that s(1) >= ... >= s(N) >= 0. C The routine then computes an upper bound T such that s(N-L) > T >= C s(N-L+1) as follows (see [2]). C First, if the initial estimate of THETA is not specified by the C user then the routine initialises THETA to be an estimate which C is close to the requested value of THETA if s(N-L) >> s(N-L+1). C Second, a bisection method (see [1, 8.5]) is used which generates C a sequence of shrinking intervals [Y,Z] such that either THETA in C [Y,Z] was found (so that J has L singular values less than or C equal to THETA), or C C (number of s(i) <= Y) < L < (number of s(i) <= Z). C C This bisection method is applied to an associated 2N-by-2N C symmetric tridiagonal matrix T" whose eigenvalues (see [1]) are C given by s(1),s(2),...,s(N),-s(1),-s(2),...,-s(N). One of the C starting values for the bisection method is the initial value of C THETA. If this value is an upper bound, then the initial lower C bound is set to zero, else the initial upper bound is computed C from the Gershgorin Circle Theorem [1, Theorem 7.2-1], applied to C T". The computation of the "number of s(i) <= Y (or Z)" is C achieved by calling SLICOT Library routine MB03ND, which applies C Sylvester's Law of Inertia or equivalently Sturm sequences C [1, 8.5] to the associated matrix T". If C C Z - Y <= MAX( TOL, PIVMIN, RELTOL*MAX( ABS( Y ), ABS( Z ) ) ) C C at some stage of the bisection method, then at least two singular C values of J lie in the interval [Y,Z] within a distance less than C TOL from each other. In this case, s(N-L) and s(N-L+1) are assumed C to coincide, the upper bound T is set to the value of Z, the value C of L is increased and IWARN is set to 1. C C REFERENCES C C [1] Golub, G.H. and Van Loan, C.F. C Matrix Computations. C The Johns Hopkins University Press, Baltimore, Maryland, 1983. C C [2] Van Huffel, S. and Vandewalle, J. C The Partial Total Least Squares Algorithm. C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. C Supersedes Release 2.0 routine MB03AD by S. Van Huffel, Katholieke C University, Leuven, Belgium. C C REVISIONS C C June 16, 1997, Oct. 26, 2003. C C KEYWORDS C C Bidiagonal matrix, singular values. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, TWO PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0 ) DOUBLE PRECISION FUDGE PARAMETER ( FUDGE = TWO ) C .. Scalar Arguments .. INTEGER INFO, IWARN, L, N DOUBLE PRECISION PIVMIN, RELTOL, THETA, TOL C .. Array Arguments .. DOUBLE PRECISION E(*), E2(*), Q(*), Q2(*) C .. Local Scalars .. INTEGER I, NUM, NUMZ DOUBLE PRECISION H, TH, Y, Z C .. External Functions .. INTEGER MB03ND DOUBLE PRECISION DLAMCH, MB03MY EXTERNAL DLAMCH, MB03MY, MB03ND C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX C .. Executable Statements .. C C Test some input scalar arguments. C IWARN = 0 INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( L.LT.0 .OR. L.GT.N ) THEN INFO = -2 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB03MD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C C Step 1: initialisation of THETA. C ----------------------- IF ( L.EQ.0 ) THETA = ZERO IF ( THETA.LT.ZERO ) THEN IF ( L.EQ.1 ) THEN C C An upper bound which is close if S(N-1) >> S(N): C THETA = MB03MY( N, Q, 1 ) IF ( N.EQ.1 ) $ RETURN ELSE C C An experimentally established estimate which is good if C S(N-L) >> S(N-L+1): C THETA = ABS( Q(N-L+1) ) END IF END IF C C Step 2: Check quality of initial estimate THETA. C --------------------------------------- NUM = MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) IF ( NUM.EQ.L ) $ RETURN C C Step 3: initialisation starting values for bisection method. C --------------------------------------------------- C Let S(i), i=1,...,N, be the singular values of J in decreasing C order. Then, the computed Y and Z will be such that C (number of S(i) <= Y) < L < (number of S(i) <= Z). C IF ( NUM.LT.L ) THEN TH = ABS( Q(1) ) Z = ZERO Y = THETA NUMZ = N C DO 20 I = 1, N - 1 H = ABS( Q(I+1) ) Z = MAX( MAX( TH, H ) + ABS( E(I) ), Z ) TH = H 20 CONTINUE C C Widen the Gershgorin interval a bit for machines with sloppy C arithmetic. C Z = Z + FUDGE*ABS( Z )*DLAMCH( 'Epsilon' )*DBLE( N ) $ + FUDGE*PIVMIN ELSE Z = THETA Y = ZERO NUMZ = NUM END IF C C Step 4: Bisection method for finding the upper bound on the L C smallest singular values of the bidiagonal. C ------------------------------------------ C A sequence of subintervals [Y,Z] is produced such that C (number of S(i) <= Y) < L < (number of S(i) <= Z). C NUM : number of S(i) <= TH, C NUMZ: number of S(i) <= Z. C C WHILE ( ( NUM .NE. L ) .AND. C ( ( Z-Y ) .GT. MAX( TOL, PIVMIN, RELTOL*ABS( Z ) ) ) ) DO 40 IF ( ( NUM.NE.L ) .AND. $ ( ABS( Z-Y ).GT.MAX( TOL, PIVMIN, $ RELTOL*MAX( ABS( Y ), ABS( Z ) ) ) ) ) $ THEN TH = ( Y + Z )/TWO NUM = MB03ND( N, TH, Q2, E2, PIVMIN, INFO ) IF ( NUM.LT.L ) THEN Y = TH ELSE Z = TH NUMZ = NUM END IF GO TO 40 END IF C END WHILE 40 C C If NUM <> L and ( Z - Y ) <= TOL, then at least two singular C values of J lie in the interval [Y,Z] within a distance less than C TOL from each other. S(N-L) and S(N-L+1) are then assumed to C coincide. L is increased, and a warning is given. C IF ( NUM.NE.L ) THEN L = NUMZ THETA = Z IWARN = 1 ELSE THETA = TH END IF C RETURN C *** Last line of MB03MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02QD.f0000644000000000000000000000013215012430707016162 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB02QD.f0000644000175000017500000004271215012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE MB02QD( JOB, INIPER, M, N, NRHS, RCOND, SVLMAX, A, LDA, $ B, LDB, Y, JPVT, RANK, SVAL, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute a solution, optionally corresponding to specified free C elements, to a real linear least squares problem: C C minimize || A * X - B || C C using a complete orthogonal factorization of the M-by-N matrix A, C which may be rank-deficient. C C Several right hand side vectors b and solution vectors x can be C handled in a single call; they are stored as the columns of the C M-by-NRHS right hand side matrix B and the N-by-NRHS solution C matrix X. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies whether or not a standard least squares solution C must be computed, as follows: C = 'L': Compute a standard least squares solution (Y = 0); C = 'F': Compute a solution with specified free elements C (given in Y). C C INIPER CHARACTER*1 C Specifies whether an initial column permutation, defined C by JPVT, must be performed, as follows: C = 'P': Perform an initial column permutation; C = 'N': Do not perform an initial column permutation. 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 NRHS (input) INTEGER C The number of right hand sides, i.e., the number of C columns of the matrices B and X. NRHS >= 0. 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 C SVLMAX (input) DOUBLE PRECISION C If A is a submatrix of another matrix C, and the rank C decision should be related to that matrix, then SVLMAX C should be an estimate of the largest singular value of C C (for instance, the Frobenius norm of C). If this is not C the case, the input value SVLMAX = 0 should work. C SVLMAX >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (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 M-by-N part of this array contains C details of its complete orthogonal factorization: C the leading RANK-by-RANK upper triangular part contains C the upper triangular factor T11 (see METHOD); C the elements below the diagonal, with the entries 2 to C min(M,N)+1 of the array DWORK, represent the orthogonal C matrix Q as a product of min(M,N) elementary reflectors C (see METHOD); C the elements of the subarray A(1:RANK,RANK+1:N), with the C next RANK entries of the array DWORK, represent the C orthogonal matrix Z as a product of RANK elementary C reflectors (see METHOD). C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,NRHS) C On entry, the leading M-by-NRHS part of this array must C contain the right hand side matrix B. C On exit, the leading N-by-NRHS part of this array contains C the solution matrix X. C If M >= N and RANK = N, the residual sum-of-squares for C the solution in the i-th column is given by the sum of C squares of elements N+1:M in that column. C If NRHS = 0, this array is not referenced, and the routine C returns the effective rank of A, and its QR factorization. C C LDB INTEGER C The leading dimension of the array B. LDB >= max(1,M,N). C C Y (input) DOUBLE PRECISION array, dimension ( N*NRHS ) C If JOB = 'F', the elements Y(1:(N-RANK)*NRHS) are used as C free elements in computing the solution (see METHOD). C The remaining elements are not referenced. C If JOB = 'L', or NRHS = 0, this array is not referenced. C C JPVT (input/output) INTEGER array, dimension (N) C On entry with INIPER = 'P', if JPVT(i) <> 0, the i-th C column of A is an initial column, otherwise it is a free C column. Before the QR factorization of A, all initial C columns are permuted to the leading positions; only the C remaining free columns are moved as a result of column C pivoting during the factorization. C If INIPER = 'N', JPVT need not be set on entry. C On exit, if JPVT(i) = k, then the i-th column of A*P C was the k-th column of A. C C RANK (output) INTEGER C The effective rank of A, i.e., the order of the submatrix C R11. This is the same as the order of the submatrix T11 C in the complete orthogonal factorization of A. C C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) C The estimates of some of the singular values of the C triangular factor R11: 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 Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK, and the entries 2 to min(M,N) + RANK + 1 C contain the scalar factors of the elementary reflectors C used in the complete orthogonal factorization of A. C Among the entries 2 to min(M,N) + 1, only the first RANK C elements are useful, if INIPER = 'N'. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= max( min(M,N)+3*N+1, 2*min(M,N)+NRHS ) 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 C METHOD C C If INIPER = 'P', the routine first computes a QR factorization C with column pivoting: C A * P = Q * [ R11 R12 ] C [ 0 R22 ] C with R11 defined as the largest leading submatrix whose estimated C condition number is less than 1/RCOND. The order of R11, RANK, C is the effective rank of A. C If INIPER = 'N', the effective rank is estimated during a C truncated QR factorization (with column pivoting) process, and C the submatrix R22 is not upper triangular, but full and of small C norm. (See SLICOT Library routines MB03OD or MB03OY, respectively, C for further details.) C C Then, R22 is considered to be negligible, and R12 is annihilated C by orthogonal transformations from the right, arriving at the C complete orthogonal factorization: C A * P = Q * [ T11 0 ] * Z C [ 0 0 ] C The solution is then C X = P * Z' [ inv(T11)*Q1'*B ] C [ Y ] C where Q1 consists of the first RANK columns of Q, and Y contains C free elements (if JOB = 'F'), or is zero (if JOB = 'L'). C C NUMERICAL ASPECTS C C The algorithm is backward stable. C C FURTHER COMMENTS C C Significant gain in efficiency is possible for small-rank problems C using truncated QR factorization (option INIPER = 'N'). C C CONTRIBUTORS C C P.Hr. Petkov, Technical University of Sofia, Oct. 1998, C modification of the LAPACK routine DGELSX. C V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library C version. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. C C KEYWORDS C C Least squares problems, QR factorization. C C ****************************************************************** C DOUBLE PRECISION ZERO, ONE, DONE, NTDONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO, $ NTDONE = ONE ) C .. C .. Scalar Arguments .. CHARACTER INIPER, JOB INTEGER INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK DOUBLE PRECISION RCOND, SVLMAX C .. C .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), $ SVAL( 3 ), Y ( * ) C .. C .. Local Scalars .. LOGICAL LEASTS, PERMUT INTEGER I, IASCL, IBSCL, J, K, MAXWRK, MINWRK, MN DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM, T1, T2 C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. C .. External Subroutines .. EXTERNAL DLABAD, DLACPY, DLASCL, DLASET, DORMQR, DORMRZ, $ DTRSM, DTZRZF, MB03OD, MB03OY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. C .. Executable Statements .. C MN = MIN( M, N ) LEASTS = LSAME( JOB, 'L' ) PERMUT = LSAME( INIPER, 'P' ) C C Test the input scalar arguments. C INFO = 0 MINWRK = MAX( MN + 3*N + 1, 2*MN + NRHS ) IF( .NOT. ( LEASTS .OR. LSAME( JOB, 'F' ) ) ) THEN INFO = -1 ELSE IF( .NOT. ( PERMUT .OR. LSAME( INIPER, 'N' ) ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN INFO = -6 ELSE IF( SVLMAX.LT.ZERO ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN INFO = -11 ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -17 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02QD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MN.EQ.0 ) THEN RANK = 0 DWORK( 1 ) = ONE RETURN END IF C C Get machine parameters. C SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) C C Scale A, B if max entries outside range [SMLNUM,BIGNUM]. C ANRM = DLANGE( 'M', M, N, A, LDA, DWORK ) IASCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN C C Scale matrix norm up to SMLNUM. C CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) IASCL = 1 ELSE IF( ANRM.GT.BIGNUM ) THEN C C Scale matrix norm down to BIGNUM. C CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) IASCL = 2 ELSE IF( ANRM.EQ.ZERO ) THEN C C Matrix all zero. Return zero solution. C IF( NRHS.GT.0 ) $ CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) RANK = 0 DWORK( 1 ) = ONE RETURN END IF C IF( NRHS.GT.0 ) THEN BNRM = DLANGE( 'M', M, NRHS, B, LDB, DWORK ) IBSCL = 0 IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN C C Scale matrix norm up to SMLNUM. C CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, $ INFO ) IBSCL = 1 ELSE IF( BNRM.GT.BIGNUM ) THEN C C Scale matrix norm down to BIGNUM. C CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, $ INFO ) IBSCL = 2 END IF END IF C C Compute a rank-revealing QR factorization of A and estimate its C effective rank using incremental condition estimation: C A * P = Q * R. C Workspace need min(M,N)+3*N+1; C prefer min(M,N)+2*N+N*NB. C Details of Householder transformations stored in DWORK(1:MN). C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 MAXWRK = MINWRK IF( PERMUT ) THEN CALL MB03OD( 'Q', M, N, A, LDA, JPVT, RCOND, SVLMAX, $ DWORK( 1 ), RANK, SVAL, DWORK( MN+1 ), LDWORK-MN, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( MN+1 ) ) + MN ) ELSE CALL MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, $ DWORK( 1 ), DWORK( MN+1 ), INFO ) END IF C C Logically partition R = [ R11 R12 ] C [ 0 R22 ], C where R11 = R(1:RANK,1:RANK). C C [R11,R12] = [ T11, 0 ] * Z. C C Details of Householder transformations stored in DWORK(MN+1:2*MN). C Workspace need 3*min(M,N); C prefer 2*min(M,N)+min(M,N)*NB. C IF( RANK.LT.N ) THEN CALL DTZRZF( RANK, N, A, LDA, DWORK( MN+1 ), DWORK( 2*MN+1 ), $ LDWORK-2*MN, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) END IF C IF( NRHS.GT.0 ) THEN C C B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS). C C Workspace: need 2*min(M,N)+NRHS; C prefer min(M,N)+NRHS*NB. C CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, $ DWORK( 1 ), B, LDB, DWORK( 2*MN+1 ), LDWORK-2*MN, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) C C B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS). C CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, $ NRHS, ONE, A, LDA, B, LDB ) C IF( RANK.LT.N ) THEN C C Set B(RANK+1:N,1:NRHS). C IF( LEASTS ) THEN CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, $ B(RANK+1,1), LDB ) ELSE CALL DLACPY( 'Full', N-RANK, NRHS, Y, N-RANK, $ B(RANK+1,1), LDB ) END IF C C B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS). C C Workspace need 2*min(M,N)+NRHS; C prefer 2*min(M,N)+NRHS*NB. C CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, $ LDA, DWORK( MN+1 ), B, LDB, DWORK( 2*MN+1 ), $ LDWORK-2*MN, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) END IF C C Additional workspace: NRHS. C C B(1:N,1:NRHS) := P * B(1:N,1:NRHS). C DO 50 J = 1, NRHS DO 20 I = 1, N DWORK( 2*MN+I ) = NTDONE 20 CONTINUE DO 40 I = 1, N IF( DWORK( 2*MN+I ).EQ.NTDONE ) THEN IF( JPVT( I ).NE.I ) THEN K = I T1 = B( K, J ) T2 = B( JPVT( K ), J ) 30 CONTINUE B( JPVT( K ), J ) = T1 DWORK( 2*MN+K ) = DONE T1 = T2 K = JPVT( K ) T2 = B( JPVT( K ), J ) IF( JPVT( K ).NE.I ) $ GO TO 30 B( I, J ) = T1 DWORK( 2*MN+K ) = DONE END IF END IF 40 CONTINUE 50 CONTINUE C C Undo scaling for B. C IF( IBSCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, $ INFO ) ELSE IF( IBSCL.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, $ INFO ) END IF END IF C C Undo scaling for A. C IF( IASCL.EQ.1 ) THEN IF( NRHS.GT.0 ) $ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, $ INFO ) CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, $ INFO ) ELSE IF( IASCL.EQ.2 ) THEN IF( NRHS.GT.0 ) $ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, $ INFO ) CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, $ INFO ) END IF C DO 60 I = MN + RANK, 1, -1 DWORK( I+1 ) = DWORK( I ) 60 CONTINUE C DWORK( 1 ) = MAXWRK RETURN C *** Last line of MB02QD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02SD.f0000644000000000000000000000013015012430707016170 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB02SD.f0000644000175000017500000007665315012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE SB02SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T, $ LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEPD, $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To estimate the conditioning and compute an error bound on the C solution of the real discrete-time matrix algebraic Riccati C equation (see FURTHER COMMENTS) C -1 C X = op(A)'*X*(I_n + G*X) *op(A) + Q, (1) C C where op(A) = A or A' (A**T) and Q, G are symmetric (Q = Q**T, C G = G**T). The matrices A, Q and G are N-by-N and the solution X C is N-by-N. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'C': Compute the reciprocal condition number only; C = 'E': Compute the error bound only; C = 'B': Compute both the reciprocal condition number and C the error bound. C C FACT CHARACTER*1 C Specifies whether or not the real Schur factorization of C the matrix Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or C Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C'), is supplied C on entry, as follows: C = 'F': On entry, T and U (if LYAPUN = 'O') contain the C factors from the real Schur factorization of the C matrix Ac; C = 'N': The Schur factorization of Ac will be computed C and the factors will be stored in T and U (if C LYAPUN = 'O'). 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 UPLO CHARACTER*1 C Specifies which part of the symmetric matrices Q and G is C to be used, as follows: C = 'U': Upper triangular part; C = 'L': Lower triangular part. C C LYAPUN CHARACTER*1 C Specifies whether or not the original Lyapunov equations C should be solved in the iterative estimation process, C as follows: C = 'O': Solve the original Lyapunov equations, updating C the right-hand sides and solutions with the C matrix U, e.g., RHS <-- U'*RHS*U; C = 'R': Solve reduced Lyapunov equations only, without C updating the right-hand sides and solutions. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, X, Q, and G. N >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of C this array must contain the matrix A. C If FACT = 'F' and LYAPUN = 'R', A is not referenced. C C LDA INTEGER C The leading dimension of the array A. C LDA >= max(1,N), if FACT = 'N' or LYAPUN = 'O'; C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. C C T (input or output) DOUBLE PRECISION array, dimension C (LDT,N) C If FACT = 'F', then T is an input argument and on entry, C the leading N-by-N upper Hessenberg part of this array C must contain the upper quasi-triangular matrix T in Schur C canonical form from a Schur factorization of Ac (see C argument FACT). C If FACT = 'N', then T is an output argument and on exit, C if INFO = 0 or INFO = N+1, the leading N-by-N upper C Hessenberg part of this array contains the upper quasi- C triangular matrix T in Schur canonical form from a Schur C factorization of Ac (see argument FACT). C C LDT INTEGER C The leading dimension of the array T. LDT >= max(1,N). C C U (input or output) DOUBLE PRECISION array, dimension C (LDU,N) C If LYAPUN = 'O' and FACT = 'F', then U is an input C argument and on entry, the leading N-by-N part of this C array must contain the orthogonal matrix U from a real C Schur factorization of Ac (see argument FACT). C If LYAPUN = 'O' and FACT = 'N', then U is an output C argument and on exit, if INFO = 0 or INFO = N+1, it C contains the orthogonal N-by-N matrix from a real Schur C factorization of Ac (see argument FACT). C If LYAPUN = 'R', the array U is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= 1, if LYAPUN = 'R'; C LDU >= MAX(1,N), if LYAPUN = 'O'. C C G (input) DOUBLE PRECISION array, dimension (LDG,N) C If UPLO = 'U', the leading N-by-N upper triangular part of C this array must contain the upper triangular part of the C matrix G. C If UPLO = 'L', the leading N-by-N lower triangular part of C this array must contain the lower triangular part of the C matrix G. _ C Matrix G should correspond to G in the "reduced" Riccati C equation (with matrix T, instead of A), if LYAPUN = 'R'. C See METHOD. C C LDG INTEGER C The leading dimension of the array G. LDG >= max(1,N). C C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) C If UPLO = 'U', the leading N-by-N upper triangular part of C this array must contain the upper triangular part of the C matrix Q. C If UPLO = 'L', the leading N-by-N lower triangular part of C this array must contain the lower triangular part of the C matrix Q. _ C Matrix Q should correspond to Q in the "reduced" Riccati C equation (with matrix T, instead of A), if LYAPUN = 'R'. C See METHOD. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= max(1,N). C C X (input) DOUBLE PRECISION array, dimension (LDX,N) C The leading N-by-N part of this array must contain the C symmetric solution matrix of the original Riccati C equation (with matrix A), if LYAPUN = 'O', or of the C "reduced" Riccati equation (with matrix T), if C LYAPUN = 'R'. See METHOD. C C LDX INTEGER C The leading dimension of the array X. LDX >= max(1,N). C C SEPD (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'B', the estimated quantity C sepd(op(Ac),op(Ac)'). C If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced. C C RCOND (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal C condition number of the discrete-time Riccati equation. C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. C If JOB = 'E', RCOND is not referenced. C C FERR (output) DOUBLE PRECISION C If JOB = 'E' or JOB = 'B', an estimated forward error C bound for the solution X. If XTRUE is the true solution, C FERR bounds the magnitude of the largest entry in C (X - XTRUE) divided by the magnitude of the largest entry C in X. C If N = 0 or X = 0, FERR is set to 0. C If JOB = 'C', FERR is not referenced. C C Workspace C C IWORK INTEGER array, dimension (N*N) 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 dimension of the array DWORK. C Let LWA = N*N, if LYAPUN = 'O'; C LWA = 0, otherwise, C and LWN = N, if LYAPUN = 'R' and JOB = 'E' or 'B'; C LWN = 0, otherwise. C If FACT = 'N', then C LDWORK = MAX(LWA + 5*N, MAX(3,2*N*N) + N*N), C if JOB = 'C'; C LDWORK = MAX(LWA + 5*N, MAX(3,2*N*N) + 2*N*N + LWN), C if JOB = 'E' or 'B'. C If FACT = 'F', then C LDWORK = MAX(3,2*N*N) + N*N, if JOB = 'C'; C LDWORK = MAX(3,2*N*N) + 2*N*N + LWN, C if JOB = 'E' or 'B'. C For good performance, LDWORK must generally 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 > 0: if INFO = i, i <= N, the QR algorithm failed to C complete the reduction of the matrix Ac to Schur C canonical form (see LAPACK Library routine DGEES); C on exit, the matrix T(i+1:N,i+1:N) contains the C partially converged Schur form, and DWORK(i+1:N) and C DWORK(N+i+1:2*N) contain the real and imaginary C parts, respectively, of the converged eigenvalues; C this error is unlikely to appear; C = N+1: if T has almost reciprocal eigenvalues; perturbed C values were used to solve Lyapunov equations, but C the matrix T, if given (for FACT = 'F'), is C unchanged. C C METHOD C C The condition number of the Riccati equation is estimated as C C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + C norm(Pi)*norm(G) ) / norm(X), C C where Omega, Theta and Pi are linear operators defined by C C Omega(W) = op(Ac)'*W*op(Ac) - W, C Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))), C Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))), C C and Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or C Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C'). C C Note that the Riccati equation (1) is equivalent to C C X = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q, (2) C C and to C _ _ _ _ _ _ C X = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q, (3) C _ _ _ C where X = U'*X*U, Q = U'*Q*U, and G = U'*G*U, with U the C orthogonal matrix reducing Ac to a real Schur form, T = U'*Ac*U. C C The routine estimates the quantities C C sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)), C C norm(Theta) and norm(Pi) using 1-norm condition estimator. C C The forward error bound is estimated using a practical error bound C similar to the one proposed in [2]. C C REFERENCES C C [1] Ghavimi, A.R. and Laub, A.J. C Backward error, sensitivity, and refinement of computed C solutions of algebraic Riccati equations. C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, C 1995. C C [2] Higham, N.J. C Perturbation theory and backward error for AX-XB=C. C BIT, vol. 33, pp. 124-136, 1993. C C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. C DGRSVX and DMSRIC: Fortran 77 subroutines for solving C continuous-time matrix algebraic Riccati equations with C condition and accuracy estimates. C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. C Chemnitz, May 1998. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C The accuracy of the estimates obtained depends on the solution C accuracy and on the properties of the 1-norm estimator. C C FURTHER COMMENTS C C The option LYAPUN = 'R' may occasionally produce slightly worse C or better estimates, and it is much faster than the option 'O'. C When SEPD is computed and it is zero, the routine returns C immediately, with RCOND and FERR (if requested) set to 0 and 1, C respectively. In this case, the equation is singular. C C Let B be an N-by-M matrix (if TRANA = 'N') or an M-by-N matrix C (if TRANA = 'T' or 'C'), let R be an M-by-M symmetric positive C definite matrix (R = R**T), and denote G = op(B)*inv(R)*op(B)'. C Then, the Riccati equation (1) is equivalent to the standard C discrete-time matrix algebraic Riccati equation C C X = op(A)'*X*op(A) - (4) C -1 C op(A)'*X*op(B)*(R + op(B)'*X*op(B)) *op(B)'*X*op(A) + Q. C C By symmetry, the equation (1) is also equivalent to C -1 C X = op(A)'*(I_n + X*G) *X*op(A) + Q. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, and C P.Hr. Petkov, Technical University of Sofia, March 1999. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004, C July 2012, May 2020. C C KEYWORDS C C Conditioning, error estimates, orthogonal transformation, C real Schur form, Riccati equation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, FOUR, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, FOUR = 4.0D+0, $ HALF = 0.5D+0 ) C .. C .. Scalar Arguments .. CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO INTEGER INFO, LDA, LDG, LDQ, LDT, LDU, LDWORK, LDX, N DOUBLE PRECISION FERR, RCOND, SEPD C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), $ Q( LDQ, * ), T( LDT, * ), U( LDU, * ), $ X( LDX, * ) C .. C .. Local Scalars .. LOGICAL JOBB, JOBC, JOBE, LOWER, LQUERY, NEEDAC, $ NOFACT, NOTRNA, UPDATE CHARACTER LOUP, SJOB, TRANAT INTEGER I, IABS, INFO2, IRES, IWRK, IXBS, IXMA, J, JJ, $ KASE, LDW, LWA, LWR, NN, SDIM, WRKOPT DOUBLE PRECISION ANORM, BIGNUM, DENOM, EPS, EPSN, EPST, EST, $ GNORM, PINORM, QNORM, SCALE, TEMP, THNORM, $ TMAX, XANORM, XNORM C .. C .. Local Arrays .. LOGICAL BWORK( 1 ) INTEGER ISAVE( 3 ) C .. C .. External Functions .. LOGICAL LSAME, SELECT DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT C .. C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEES, DGEMM, DGESV, DLACN2, $ DLACPY, DLASET, DSCAL, DSWAP, DSYMM, MA02ED, $ MB01RU, MB01RX, MB01RY, MB01UD, SB03MX, SB03SX, $ SB03SY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C C Decode and Test input parameters. C JOBC = LSAME( JOB, 'C' ) JOBE = LSAME( JOB, 'E' ) JOBB = LSAME( JOB, 'B' ) NOFACT = LSAME( FACT, 'N' ) NOTRNA = LSAME( TRANA, 'N' ) LOWER = LSAME( UPLO, 'L' ) UPDATE = LSAME( LYAPUN, 'O' ) C NEEDAC = UPDATE .AND. .NOT.JOBC C NN = N*N IF( UPDATE ) THEN LWA = NN ELSE LWA = 0 END IF C IF( JOBC ) THEN LDW = MAX( 3, 2*NN ) + NN ELSE LDW = MAX( 3, 2*NN ) + 2*NN IF( .NOT.UPDATE ) $ LDW = LDW + N END IF IF( NOFACT ) $ LDW = MAX( LWA + 5*N, LDW ) C INFO = 0 IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN INFO = -1 ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. $ LSAME( TRANA, 'C' ) ) ) THEN INFO = -3 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -4 ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.1 .OR. $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN INFO = -8 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN INFO = -12 ELSE IF( LDG.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE LQUERY = LDWORK.EQ.-1 IF( NOFACT ) THEN IF( UPDATE ) THEN SJOB = 'V' ELSE SJOB = 'N' END IF END IF IF( LQUERY ) THEN IF( NOFACT ) THEN CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK, DWORK, U, LDU, DWORK, -1, BWORK, $ INFO ) WRKOPT = MAX( LDW, INT( DWORK( 1 ) ) + LWA + 2*N ) ELSE WRKOPT = LDW END IF END IF IF( LDWORK.LT.LDW .AND. .NOT. LQUERY ) $ INFO = -24 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB02SD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK( 1 ) = WRKOPT RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IF( .NOT.JOBE ) $ RCOND = ONE IF( .NOT.JOBC ) $ FERR = ZERO DWORK( 1 ) = ONE RETURN END IF C C Compute the 1-norm of the matrix X. C XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK ) IF( XNORM.EQ.ZERO ) THEN C C The solution is zero. C IF( .NOT.JOBE ) $ RCOND = ZERO IF( .NOT.JOBC ) $ FERR = ZERO DWORK( 1 ) = DBLE( N ) RETURN END IF C C Workspace usage. C IRES = 0 IXBS = IRES + NN IXMA = MAX( 3, 2*NN ) IABS = IXMA + NN IWRK = IABS + NN C C Workspace: LWK, where C LWK = 2*N*N, if LYAPUN = 'O', or FACT = 'N', C LWK = N, otherwise. C IF( UPDATE .OR. NOFACT ) THEN C CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK( IXBS+1 ), N ) CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX, ONE, $ DWORK( IXBS+1 ), N ) IF( NOTRNA ) THEN C -1 C Compute Ac = (I_n + G*X) *A. C CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) CALL DGESV( N, N, DWORK( IXBS+1 ), N, IWORK, DWORK, N, $ INFO2 ) ELSE C -1 C Compute Ac = A*(I_n + X*G) . C DO 10 J = 1, N CALL DCOPY( N, A( 1, J ), 1, DWORK( J ), N ) 10 CONTINUE CALL DGESV( N, N, DWORK( IXBS+1 ), N, IWORK, DWORK, N, $ INFO2 ) DO 20 J = 2, N CALL DSWAP( J-1, DWORK( (J-1)*N+1 ), 1, DWORK( J ), N ) 20 CONTINUE END IF C WRKOPT = DBLE( 2*NN ) IF( NOFACT ) $ CALL DLACPY( 'Full', N, N, DWORK, N, T, LDT ) ELSE WRKOPT = DBLE( N ) END IF C IF( NOFACT ) THEN C C Compute the Schur factorization of Ac, Ac = U*T*U'. C Workspace: need LWA + 5*N; C prefer larger; C LWA = N*N, if LYAPUN = 'O'; C LWA = 0, otherwise. 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 CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, $ DWORK( LWA+1 ), DWORK( LWA+N+1 ), U, LDU, $ DWORK( LWA+2*N+1 ), LDWORK-LWA-2*N, BWORK, INFO ) IF( INFO.GT.0 ) THEN IF( LWA.GT.0 ) $ CALL DCOPY( 2*N, DWORK( LWA+1 ), 1, DWORK, 1 ) RETURN END IF C WRKOPT = MAX( WRKOPT, INT( DWORK( LWA+2*N+1 ) ) + LWA + 2*N ) END IF IF( NEEDAC ) THEN CALL DLACPY( 'Full', N, N, DWORK, N, DWORK( IABS+1 ), N ) LWR = NN ELSE LWR = 0 END IF C IF( NOTRNA ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF C _ C Compute X*op(Ac) or X*op(T). C IF( UPDATE ) THEN CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, X, LDX, DWORK, $ N, ZERO, DWORK( IXMA+1 ), N ) ELSE CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, $ DWORK( IXMA+1 ), N, INFO2 ) END IF C IF( .NOT.JOBE ) THEN C C Estimate sepd(op(Ac),op(Ac)') = sepd(op(T),op(T)') and C norm(Theta). C Workspace LWR + MAX(3,2*N*N) + N*N, where C LWR = N*N, if LYAPUN = 'O' and JOB = 'B', C LWR = 0, otherwise. C CALL SB03SY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, $ DWORK( IXMA+1 ), N, SEPD, THNORM, IWORK, DWORK, $ IXMA, INFO ) C WRKOPT = MAX( WRKOPT, LWR + MAX( 3, 2*NN ) + NN ) C C Return if the equation is singular. C IF( SEPD.EQ.ZERO ) THEN RCOND = ZERO IF( JOBB ) $ FERR = ONE DWORK( 1 ) = DBLE( WRKOPT ) RETURN END IF C C Estimate norm(Pi). C Workspace LWR + MAX(3,2*N*N) + N*N. C KASE = 0 C C REPEAT 30 CONTINUE CALL DLACN2( NN, DWORK( IXBS+1 ), DWORK, IWORK, EST, KASE, $ ISAVE ) IF( KASE.NE.0 ) THEN C C Select the triangular part of symmetric matrix to be used. C IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( IXBS+1 )) $ .GE. $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( IXBS+1 )) $ ) THEN LOUP = 'U' ELSE LOUP = 'L' END IF C _ _ C Compute RHS = op(Ac)'*X*W*X*op(Ac) or op(T)'*X*W*X*op(T). C CALL MB01RU( LOUP, TRANAT, N, N, ZERO, ONE, DWORK, N, $ DWORK( IXMA+1 ), N, DWORK, N, DWORK( IXBS+1 ), $ NN, INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) C IF( UPDATE ) THEN C C Transform the right-hand side: RHS := U'*RHS*U. C CALL MB01RU( LOUP, 'Transpose', N, N, ZERO, ONE, DWORK, $ N, U, LDU, DWORK, N, DWORK( IXBS+1 ), NN, $ INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) END IF C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( LOUP, N, DWORK, N ) C IF( KASE.EQ.1 ) THEN C C Solve op(T)'*Y*op(T) - Y = scale*RHS. C CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, $ DWORK( IXBS+1 ), INFO2 ) ELSE C C Solve op(T)*W*op(T)' - W = scale*RHS. C CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, $ DWORK( IXBS+1 ), INFO2 ) END IF C IF( UPDATE ) THEN C C Transform back to obtain the solution: Z := U*Z*U', with C Z = Y or Z = W. C CALL MB01RU( LOUP, 'No transpose', N, N, ZERO, ONE, $ DWORK, N, U, LDU, DWORK, N, DWORK( IXBS+1 ), $ NN, INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( LOUP, N, DWORK, N ) END IF GO TO 30 END IF C UNTIL KASE = 0 C IF( EST.LT.SCALE ) THEN PINORM = EST / SCALE ELSE BIGNUM = ONE / DLAMCH( 'Safe minimum' ) IF( EST.LT.SCALE*BIGNUM ) THEN PINORM = EST / SCALE ELSE PINORM = BIGNUM END IF END IF C C Compute the 1-norm of A or T. C IF( UPDATE ) THEN ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) ELSE ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) END IF C C Compute the 1-norms of the matrices Q and G. C QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) C C Estimate the reciprocal condition number. C TMAX = MAX( SEPD, XNORM, ANORM, GNORM ) IF( TMAX.LE.ONE ) THEN TEMP = SEPD*XNORM DENOM = QNORM + ( SEPD*ANORM )*THNORM + $ ( SEPD*GNORM )*PINORM ELSE TEMP = ( SEPD / TMAX )*( XNORM / TMAX ) DENOM = ( ( ONE / TMAX )*( QNORM / TMAX ) ) + $ ( ( SEPD / TMAX )*( ANORM / TMAX ) )*THNORM + $ ( ( SEPD / TMAX )*( GNORM / TMAX ) )*PINORM END IF IF( TEMP.GE.DENOM ) THEN RCOND = ONE ELSE RCOND = TEMP / DENOM END IF END IF C IF( .NOT.JOBC ) THEN C C Form a triangle of the residual matrix C R = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q - X, C or _ _ _ _ _ _ C R = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q - X, C exploiting the symmetry. Actually, the equivalent formula C R = op(A)'*X*op(Ac) + Q - X C is used in the first case. C Workspace MAX(3,2*N*N) + 2*N*N, if LYAPUN = 'O'; C MAX(3,2*N*N) + 2*N*N + N, if LYAPUN = 'R'. C CALL DLACPY( UPLO, N, N, Q, LDQ, DWORK( IRES+1 ), N ) JJ = IRES + 1 IF( LOWER ) THEN DO 40 J = 1, N CALL DAXPY( N-J+1, -ONE, X( J, J ), 1, DWORK( JJ ), 1 ) JJ = JJ + N + 1 40 CONTINUE ELSE DO 50 J = 1, N CALL DAXPY( J, -ONE, X( 1, J ), 1, DWORK( JJ ), 1 ) JJ = JJ + N 50 CONTINUE END IF C IF( UPDATE ) THEN CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, ONE, $ DWORK( IRES+1 ), N, A, LDA, DWORK( IXMA+1 ), N, $ INFO2 ) ELSE CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, ONE, $ DWORK( IRES+1 ), N, T, LDT, DWORK( IXMA+1 ), N, $ DWORK( IWRK+1 ), INFO2 ) CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, $ DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N ) CALL MB01RX( 'Left', UPLO, 'Transpose', N, N, ONE, ONE, $ DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N, $ DWORK( IXBS+1 ), N, INFO2 ) END IF C C Get the machine precision. C EPS = DLAMCH( 'Epsilon' ) EPSN = EPS*DBLE( N + 4 ) EPST = EPS*DBLE( 2*( N + 1 ) ) TEMP = EPS*FOUR C C Add to abs(R) a term that takes account of rounding errors in C forming R: C abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) + C (n+4)*abs(op(Ac))'*abs(X)*abs(op(Ac)) + 2*(n+1)* C abs(op(Ac))'*abs(X)*abs(G)*abs(X)*abs(op(Ac))), C or _ _ C abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) + C _ C (n+4)*abs(op(T))'*abs(X)*abs(op(T)) + C _ _ _ C 2*(n+1)*abs(op(T))'*abs(X)*abs(G)*abs(X)*abs(op(T))), C where EPS is the machine precision. C DO 70 J = 1, N DO 60 I = 1, N DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) 60 CONTINUE 70 CONTINUE C IF( LOWER ) THEN DO 90 J = 1, N DO 80 I = J, N DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) + $ ABS( X( I, J ) ) ) + $ ABS( DWORK( IRES+(J-1)*N+I ) ) 80 CONTINUE 90 CONTINUE ELSE DO 110 J = 1, N DO 100 I = 1, J DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) + $ ABS( X( I, J ) ) ) + $ ABS( DWORK( IRES+(J-1)*N+I ) ) 100 CONTINUE 110 CONTINUE END IF C IF( UPDATE ) THEN C DO 130 J = 1, N DO 120 I = 1, N DWORK( IABS+(J-1)*N+I ) = $ ABS( DWORK( IABS+(J-1)*N+I ) ) 120 CONTINUE 130 CONTINUE C CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, $ DWORK( IXBS+1 ), N, DWORK( IABS+1 ), N, ZERO, $ DWORK( IXMA+1 ), N ) CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, EPSN, $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, $ DWORK( IXMA+1 ), N, INFO2 ) ELSE C DO 150 J = 1, N DO 140 I = 1, MIN( J+1, N ) DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) 140 CONTINUE 150 CONTINUE C CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N, $ DWORK( IXBS+1 ), N, DWORK( IXMA+1 ), N, INFO2 ) CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN, $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, $ DWORK( IXMA+1 ), N, DWORK( IWRK+1 ), INFO2 ) END IF C IF( LOWER ) THEN DO 170 J = 1, N DO 160 I = J, N DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) 160 CONTINUE 170 CONTINUE ELSE DO 190 J = 1, N DO 180 I = 1, J DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) ) 180 CONTINUE 190 CONTINUE END IF C IF( UPDATE ) THEN CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPST, DWORK( IRES+1 ), $ N, DWORK( IXMA+1 ), N, DWORK( IABS+1 ), N, $ DWORK( IXBS+1 ), NN, INFO2 ) WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN ) ELSE CALL DSYMM( 'Left', UPLO, N, N, ONE, DWORK( IABS+1 ), N, $ DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N ) CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPST, $ DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N, $ DWORK( IXBS+1 ), N, DWORK( IWRK+1 ), INFO2 ) WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN + N ) END IF C C Compute forward error bound, using matrix norm estimator. C Workspace MAX(3,2*N*N) + N*N. C XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) C CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK( IXBS+1 ), $ IXMA, INFO ) END IF C DWORK( 1 ) = DBLE( WRKOPT ) RETURN C C *** Last line of SB02SD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10ZD.f0000644000000000000000000000013215012430707016200 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/SB10ZD.f0000644000175000017500000007244215012430707017405 0ustar00lilgelilge00000000000000 SUBROUTINE SB10ZD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, $ FACTOR, AK, LDAK, BK, LDBK, CK, LDCK, DK, $ LDDK, RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, $ INFO ) C C PURPOSE C C To compute the matrices of the positive feedback controller C C | Ak | Bk | C K = |----|----| C | Ck | Dk | C C for the shaped plant C C | A | B | C G = |---|---| C | C | D | C C in the Discrete-Time Loop Shaping Design Procedure. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the plant. 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 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 of the shaped plant. 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 of the shaped plant. 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 of the shaped plant. 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 of the shaped plant. C C LDD INTEGER C The leading dimension of the array D. LDD >= max(1,NP). C C FACTOR (input) DOUBLE PRECISION C = 1 implies that an optimal controller is required C (not recommended); C > 1 implies that a suboptimal controller is required C achieving a performance FACTOR less than optimal. C FACTOR >= 1. 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,NP) C The leading N-by-NP 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 M-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. LDCK >= max(1,M). C C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) C The leading M-by-NP part of this array contains the C controller matrix Dk. C C LDDK INTEGER C The leading dimension of the array DK. LDDK >= max(1,M). C C RCOND (output) DOUBLE PRECISION array, dimension (6) C RCOND(1) contains an estimate of the reciprocal condition C number of the linear system of equations from C which the solution of the P-Riccati equation is C obtained; C RCOND(2) contains an estimate of the reciprocal condition C number of the linear system of equations from C which the solution of the Q-Riccati equation is C obtained; C RCOND(3) contains an estimate of the reciprocal condition C number of the matrix (gamma^2-1)*In - P*Q; C RCOND(4) contains an estimate of the reciprocal condition C number of the matrix Rx + Bx'*X*Bx; C RCOND(5) contains an estimate of the reciprocal condition C ^ C number of the matrix Ip + D*Dk; C RCOND(6) contains an estimate of the reciprocal condition C ^ C number of the matrix Im + Dk*D. C C Tolerances C C TOL DOUBLE PRECISION C Tolerance used for checking the nonsingularity of the C matrices to be inverted. If TOL <= 0, then a default value C equal to sqrt(EPS) is used, where EPS is the relative C machine precision. TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (2*max(N,M+NP)) 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 >= 16*N*N + 5*M*M + 7*NP*NP + 6*M*N + 7*M*NP + C 7*N*NP + 6*N + 2*(M + NP) + C max(14*N+23,16*N,2*M-1,2*NP-1). C For good performance, LDWORK must generally be larger. C C BWORK LOGICAL array, dimension (2*N) C C Error Indicator C C INFO (output) INTEGER C = 0: successful exit; C < 0: if INFO = -i, the i-th argument had an illegal C value; C = 1: the P-Riccati equation is not solved successfully; C = 2: the Q-Riccati equation is not solved successfully; C = 3: the iteration to compute eigenvalues or singular C values failed to converge; C = 4: the matrix (gamma^2-1)*In - P*Q is singular; C = 5: the matrix Rx + Bx'*X*Bx is singular; C ^ C = 6: the matrix Ip + D*Dk is singular; C ^ C = 7: the matrix Im + Dk*D is singular; C = 8: the matrix Ip - D*Dk is singular; C = 9: the matrix Im - Dk*D is singular; C = 10: the closed-loop system is unstable. C C METHOD C C The routine implements the formulas given in [1]. C C REFERENCES C C [1] Gu, D.-W., Petkov, P.H., and Konstantinov, M.M. C On discrete H-infinity loop shaping design procedure routines. C Technical Report 00-6, Dept. of Engineering, Univ. of C Leicester, UK, 2000. C C NUMERICAL ASPECTS C C The accuracy of the results depends on the conditioning of the C two Riccati equations solved in the controller design. For C better conditioning it is advised to take FACTOR > 1. C C CONTRIBUTORS C C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 2001. C C KEYWORDS C C H_infinity control, Loop-shaping design, Robust 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, NP DOUBLE PRECISION FACTOR, TOL C .. C .. Array Arguments .. INTEGER IWORK( * ) LOGICAL BWORK( * ) DOUBLE PRECISION A ( LDA, * ), AK( LDAK, * ), B ( LDB, * ), $ BK( LDBK, * ), C ( LDC, * ), CK( LDCK, * ), $ D ( LDD, * ), DK( LDDK, * ), DWORK( * ), $ RCOND( 6 ) C .. C .. Local Scalars .. INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, $ I11, I12, I13, I14, I15, I16, I17, I18, I19, $ I20, I21, I22, I23, I24, I25, I26, INFO2, IWRK, $ J, LWAMAX, MINWRK, N2, NS, SDIM DOUBLE PRECISION ANORM, GAMMA, TOLL C .. C .. External Functions .. LOGICAL SELECT DOUBLE PRECISION DLAMCH, DLANGE, DLANSY, DLAPY2 EXTERNAL DLAMCH, DLANGE, DLANSY, DLAPY2, SELECT C .. C .. External Subroutines .. EXTERNAL DCOPY, DGECON, DGEES, DGEMM, DGETRF, DGETRS, $ DLACPY, DLASCL, DLASET, DPOTRF, DPOTRS, DSWAP, $ DSYCON, DSYEV, DSYRK, DSYTRF, DSYTRS, DTRSM, $ DTRTRS, MA02AD, MB01RX, MB02VD, SB02OD, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC INT, MAX, SQRT C .. C .. Executable Statements .. C C Decode and Test input parameters. 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -9 ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN INFO = -11 ELSE IF( FACTOR.LT.ONE ) THEN INFO = -12 ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN INFO = -18 ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN INFO = -20 ELSE IF( TOL.GE.ONE ) THEN INFO = -22 END IF C C Compute workspace. C MINWRK = 16*N*N + 5*M*M + 7*NP*NP + 6*M*N + 7*M*NP + 7*N*NP + $ 6*N + 2*(M + NP) + MAX( 14*N+23, 16*N, 2*M-1, 2*NP-1 ) IF( LDWORK.LT.MINWRK ) THEN INFO = -25 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10ZD', -INFO ) RETURN END IF C C Quick return if possible. C Note that some computation could be made if one or two of the C dimension parameters N, M, and P are zero, but the results are C not so meaningful. C IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN RCOND( 1 ) = ONE RCOND( 2 ) = ONE RCOND( 3 ) = ONE RCOND( 4 ) = ONE RCOND( 5 ) = ONE RCOND( 6 ) = ONE DWORK( 1 ) = ONE RETURN END IF C C Set the default tolerance, if needed. C IF( TOL.LE.ZERO ) THEN TOLL = SQRT( DLAMCH( 'Epsilon' ) ) ELSE TOLL = TOL END IF C C Workspace usage. C N2 = 2*N I1 = 1 + N*N I2 = I1 + N*N I3 = I2 + NP*NP I4 = I3 + M*M I5 = I4 + NP*NP I6 = I5 + M*M I7 = I6 + M*N I8 = I7 + M*N I9 = I8 + N*N I10 = I9 + N*N I11 = I10 + N2 I12 = I11 + N2 I13 = I12 + N2 I14 = I13 + N2*N2 I15 = I14 + N2*N2 C IWRK = I15 + N2*N2 LWAMAX = 0 C C Compute R1 = Ip + D*D' . C CALL DLASET( 'U', NP, NP, ZERO, ONE, DWORK( I2 ), NP ) CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ONE, DWORK( I2 ), NP ) CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I4 ), NP ) C C Factorize R1 = R'*R . C CALL DPOTRF( 'U', NP, DWORK( I4 ), NP, INFO2 ) C -1 C Compute C'*R in BK . C CALL MA02AD( 'F', NP, N, C, LDC, BK, LDBK ) CALL DTRSM( 'R', 'U', 'N', 'N', N, NP, ONE, DWORK( I4 ), NP, BK, $ LDBK ) C C Compute R2 = Im + D'*D . C CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I3 ), M ) CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ONE, DWORK( I3 ), M ) CALL DLACPY( 'U', M, M, DWORK( I3 ), M, DWORK( I5 ), M ) C C Factorize R2 = U'*U . C CALL DPOTRF( 'U', M, DWORK( I5 ), M, INFO2 ) C -1 C Compute (U )'*B' . C CALL MA02AD( 'F', N, M, B, LDB, DWORK( I6 ), M ) CALL DTRTRS( 'U', 'T', 'N', M, N, DWORK( I5 ), M, DWORK( I6 ), M, $ INFO2 ) C C Compute D'*C . C CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, $ DWORK( I7 ), M ) C -1 C Compute (U )'*D'*C . C CALL DTRTRS( 'U', 'T', 'N', M, N, DWORK( I5 ), M, DWORK( I7 ), M, $ INFO2 ) C -1 C Compute Ar = A - B*R2 D'*C . C CALL DLACPY( 'F', N, N, A, LDA, DWORK( I8 ), N ) CALL DGEMM( 'T', 'N', N, N, M, -ONE, DWORK( I6 ), M, DWORK( I7 ), $ M, ONE, DWORK( I8 ), N ) C -1 C Compute Cr = C'*R1 *C . C CALL DSYRK( 'U', 'N', N, NP, ONE, BK, LDBK, ZERO, DWORK( I9 ), N ) C -1 C Compute Dr = B*R2 B' in AK . C CALL DSYRK( 'U', 'T', N, M, ONE, DWORK( I6 ), M, ZERO, AK, LDAK ) C -1 C Solution of the Riccati equation Ar'*P*(In + Dr*P) Ar - P + C Cr = 0 . CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, DWORK( I8 ), $ N, AK, LDAK, DWORK( I9 ), N, DWORK, M, DWORK, N, $ RCOND( 1 ), DWORK, N, DWORK( I10 ), DWORK( I11 ), $ DWORK( I12 ), DWORK( I13 ), N2, DWORK( I14 ), N2, $ DWORK( I15 ), N2, -ONE, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 1 RETURN END IF LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Transpose Ar . C DO 10 J = 1, N - 1 CALL DSWAP( J, DWORK( I8+J ), N, DWORK( I8+J*N ), 1 ) 10 CONTINUE C -1 C Solution of the Riccati equation Ar*Q*(In + Cr*Q) *Ar' - Q + C Dr = 0 . CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, DWORK( I8 ), $ N, DWORK( I9 ), N, AK, LDAK, DWORK, M, DWORK, N, $ RCOND( 2 ), DWORK( I1 ), N, DWORK( I10 ), $ DWORK( I11 ), DWORK( I12 ), DWORK( I13 ), N2, $ DWORK( I14 ), N2, DWORK( I15 ), N2, -ONE, IWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 2 RETURN END IF LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Compute gamma. C CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1 ), N, DWORK, N, $ ZERO, DWORK( I8 ), N ) CALL DGEES( 'N', 'N', SELECT, N, DWORK( I8 ), N, SDIM, $ DWORK( I10 ), DWORK( I11 ), DWORK( IWRK ), N, $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) GAMMA = ZERO C DO 20 I = 0, N - 1 GAMMA = MAX( GAMMA, DWORK( I10+I ) ) 20 CONTINUE C GAMMA = FACTOR*SQRT( ONE + GAMMA ) C C Workspace usage. C I5 = I4 + NP*NP I6 = I5 + M*M I7 = I6 + NP*NP I8 = I7 + NP*NP I9 = I8 + NP*NP I10 = I9 + NP I11 = I10 + NP*NP I12 = I11 + M*M I13 = I12 + M C IWRK = I13 + M*M C C Compute the eigenvalues and eigenvectors of R1 . C CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I8 ), NP ) CALL DSYEV( 'V', 'U', NP, DWORK( I8 ), NP, DWORK( I9 ), $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) C -1/2 C Compute R1 . C DO 40 J = 1, NP DO 30 I = 1, NP DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP ) / $ SQRT( DWORK( I9+I-1 ) ) 30 CONTINUE 40 CONTINUE C CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, $ DWORK( I10 ), NP, ZERO, DWORK( I4 ), NP ) C C Compute the eigenvalues and eigenvectors of R2 . C CALL DLACPY( 'U', M, M, DWORK( I3 ), M, DWORK( I11 ), M ) CALL DSYEV( 'V', 'U', M, DWORK( I11 ), M, DWORK( I12 ), $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) C -1/2 C Compute R2 . C DO 60 J = 1, M DO 50 I = 1, M DWORK( I13-1+I+(J-1)*M ) = DWORK( I11-1+J+(I-1)*M ) / $ SQRT( DWORK( I12+I-1 ) ) 50 CONTINUE 60 CONTINUE C CALL DGEMM( 'N', 'N', M, M, M, ONE, DWORK( I11 ), M, DWORK( I13 ), $ M, ZERO, DWORK( I5 ), M ) C C Compute R1 + C*Q*C' . C CALL DGEMM( 'N', 'T', N, NP, N, ONE, DWORK( I1 ), N, C, LDC, $ ZERO, BK, LDBK ) CALL MB01RX( 'L', 'U', 'N', NP, N, ONE, ONE, DWORK( I2 ), NP, $ C, LDC, BK, LDBK, INFO2 ) CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I8 ), NP ) C C Compute the eigenvalues and eigenvectors of R1 + C*Q*C' . C CALL DSYEV( 'V', 'U', NP, DWORK( I8 ), NP, DWORK( I9 ), $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) C -1 C Compute ( R1 + C*Q*C' ) . C DO 80 J = 1, NP DO 70 I = 1, NP DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP ) / $ DWORK( I9+I-1 ) 70 CONTINUE 80 CONTINUE C CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, $ DWORK( I10 ), NP, ZERO, DWORK( I6 ), NP ) C -1 C Compute Z2 . C DO 100 J = 1, NP DO 90 I = 1, NP DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP )* $ SQRT( DWORK( I9+I-1 ) ) 90 CONTINUE 100 CONTINUE C CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, $ DWORK( I10 ), NP, ZERO, DWORK( I7 ), NP ) C C Workspace usage. C I9 = I8 + N*NP I10 = I9 + N*NP I11 = I10 + NP*M I12 = I11 + ( NP + M )*( NP + M ) I13 = I12 + N*( NP + M ) I14 = I13 + N*( NP + M ) I15 = I14 + N*N I16 = I15 + N*N I17 = I16 + ( NP + M )*N I18 = I17 + ( NP + M )*( NP + M ) I19 = I18 + ( NP + M )*N I20 = I19 + M*N I21 = I20 + M*NP I22 = I21 + NP*N I23 = I22 + N*N I24 = I23 + N*NP I25 = I24 + NP*NP I26 = I25 + M*M C IWRK = I26 + N*M C C Compute A*Q*C' + B*D' . C CALL DGEMM( 'N', 'T', N, NP, M, ONE, B, LDB, D, LDD, ZERO, $ DWORK( I8 ), N ) CALL DGEMM( 'N', 'N', N, NP, N, ONE, A, LDA, BK, LDBK, $ ONE, DWORK( I8 ), N ) C -1 C Compute H = -( A*Q*C'+B*D' )*( R1 + C*Q*C' ) . C CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I8 ), N, $ DWORK( I6 ), NP, ZERO, DWORK( I9 ), N ) C -1/2 C Compute R1 D . C CALL DGEMM( 'N', 'N', NP, M, NP, ONE, DWORK( I4 ), NP, D, LDD, $ ZERO, DWORK( I10 ), NP ) C C Compute Rx . C DO 110 J = 1, NP CALL DCOPY( J, DWORK( I2+(J-1)*NP ), 1, $ DWORK( I11+(J-1)*(NP+M) ), 1 ) DWORK( I11-1+J+(J-1)*(NP+M) ) = DWORK( I2-1+J+(J-1)*NP ) - $ GAMMA*GAMMA 110 CONTINUE C CALL DGEMM( 'N', 'N', NP, M, NP, ONE, DWORK( I7 ), NP, $ DWORK( I10 ), NP, ZERO, DWORK( I11+(NP+M)*NP ), $ NP+M ) CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I11+(NP+M)*NP+NP ), $ NP+M ) C C Compute Bx . C CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I9 ), N, $ DWORK( I7 ), NP, ZERO, DWORK( I12 ), N ) CALL DGEMM( 'N', 'N', N, M, M, ONE, B, LDB, DWORK( I5 ), M, $ ZERO, DWORK( I12+N*NP ), N ) C C Compute Sx . C CALL DGEMM( 'T', 'N', N, NP, NP, ONE, C, LDC, DWORK( I7 ), NP, $ ZERO, DWORK( I13 ), N ) CALL DGEMM( 'T', 'N', N, M, NP, ONE, C, LDC, DWORK( I10 ), NP, $ ZERO, DWORK( I13+N*NP ), N ) C C Compute (gamma^2 - 1)*In - P*Q . C CALL DLASET( 'F', N, N, ZERO, GAMMA*GAMMA-ONE, DWORK( I14 ), N ) CALL DGEMM( 'N', 'N', N, N, N, -ONE, DWORK, N, DWORK( I1 ), N, $ ONE, DWORK( I14 ), N ) C -1 C Compute X = ((gamma^2 - 1)*In - P*Q) *gamma^2*P . C CALL DLACPY( 'F', N, N, DWORK, N, DWORK( I15 ), N ) CALL DLASCL( 'G', 0, 0, ONE, GAMMA*GAMMA, N, N, DWORK( I15 ), N, $ INFO ) ANORM = DLANGE( '1', N, N, DWORK( I14 ), N, DWORK( IWRK ) ) CALL DGETRF( N, N, DWORK( I14 ), N, IWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 4 RETURN END IF CALL DGECON( '1', N, DWORK( I14 ), N, ANORM, RCOND( 3 ), $ DWORK( IWRK ), IWORK( N+1 ), INFO2 ) C C Return if the matrix is singular to working precision. C IF( RCOND( 3 ).LT.TOLL ) THEN INFO = 4 RETURN END IF CALL DGETRS( 'N', N, N, DWORK( I14 ), N, IWORK, DWORK( I15 ), $ N, INFO2 ) C C Compute Bx'*X . C CALL DGEMM( 'T', 'N', NP+M, N, N, ONE, DWORK( I12 ), N, $ DWORK( I15 ), N, ZERO, DWORK( I16 ), NP+M ) C C Compute Rx + Bx'*X*Bx . C CALL DLACPY( 'U', NP+M, NP+M, DWORK( I11 ), NP+M, DWORK( I17 ), $ NP+M ) CALL MB01RX( 'L', 'U', 'N', NP+M, N, ONE, ONE, DWORK( I17 ), NP+M, $ DWORK( I16 ), NP+M, DWORK( I12 ), N, INFO2 ) C C Compute -( Sx' + Bx'*X*A ) . C CALL MA02AD( 'F', N, NP+M, DWORK( I13 ), N, DWORK( I18 ), NP+M ) CALL DGEMM( 'N', 'N', NP+M, N, N, -ONE, DWORK( I16 ), NP+M, $ A, LDA, -ONE, DWORK( I18 ), NP+M ) C C Factorize Rx + Bx'*X*Bx . C ANORM = DLANSY( '1', 'U', NP+M, DWORK( I17 ), NP+M, $ DWORK( IWRK ) ) CALL DSYTRF( 'U', NP+M, DWORK( I17 ), NP+M, IWORK, $ DWORK( IWRK ), LDWORK-IWRK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 5 RETURN END IF CALL DSYCON( 'U', NP+M, DWORK( I17 ), NP+M, IWORK, ANORM, $ RCOND( 4 ), DWORK( IWRK ), IWORK( NP+M+1), 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 -1 C Compute F = -( Rx + Bx'*X*Bx ) ( Sx' + Bx'*X*A ) . C CALL DSYTRS( 'U', NP+M, N, DWORK( I17 ), NP+M, IWORK, $ DWORK( I18 ), NP+M, INFO2 ) C C Compute B'*X . C CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK( I15 ), N, $ ZERO, DWORK( I19 ), M ) C C Compute -( D' - B'*X*H ) . C DO 130 J = 1, NP DO 120 I = 1, M DWORK( I20-1+I+(J-1)*M ) = -D( J, I ) 120 CONTINUE 130 CONTINUE C CALL DGEMM( 'N', 'N', M, NP, N, ONE, DWORK( I19 ), M, $ DWORK( I9 ), N, ONE, DWORK( I20 ), M ) C -1 C Compute C + Z2 *F1 . C CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I21 ), NP ) CALL DGEMM( 'N', 'N', NP, N, NP, ONE, DWORK( I7 ), NP, $ DWORK( I18 ), NP+M, ONE, DWORK( I21 ), NP ) C C Compute R2 + B'*X*B . C CALL MB01RX( 'L', 'U', 'N', M, N, ONE, ONE, DWORK( I3 ), M, $ DWORK( I19 ), M, B, LDB, INFO2 ) C C Factorize R2 + B'*X*B . C CALL DPOTRF( 'U', M, DWORK( I3 ), M, INFO2 ) C ^ -1 C Compute Dk = -( R2 + B'*X*B ) (D' - B'*X*H) . C CALL DLACPY( 'F', M, NP, DWORK( I20 ), M, DK, LDDK ) CALL DPOTRS( 'U', M, NP, DWORK( I3 ), M, DK, LDDK, INFO2 ) C ^ ^ C Compute Bk = -H + B*Dk . C CALL DLACPY( 'F', N, NP, DWORK( I9 ), N, DWORK( I23 ), N ) CALL DGEMM( 'N', 'N', N, NP, M, ONE, B, LDB, DK, LDDK, $ -ONE, DWORK( I23 ), N ) C -1/2 C Compute R2 *F2 . C CALL DGEMM( 'N', 'N', M, N, M, ONE, DWORK( I5 ), M, $ DWORK( I18+NP ), NP+M, ZERO, CK, LDCK ) C ^ -1/2 ^ -1 C Compute Ck = R2 *F2 - Dk*( C + Z2 *F1 ) . C CALL DGEMM( 'N', 'N', M, N, NP, -ONE, DK, LDDK, $ DWORK( I21 ), NP, ONE, CK, LDCK ) C ^ ^ C Compute Ak = A + H*C + B*Ck . C CALL DLACPY( 'F', N, N, A, LDA, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I9 ), N, C, LDC, $ ONE, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, $ ONE, AK, LDAK ) C ^ C Compute Ip + D*Dk . C CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK( I24 ), NP ) CALL DGEMM( 'N', 'N', NP, NP, M, ONE, D, LDD, DK, LDDK, $ ONE, DWORK( I24 ), NP ) C ^ C Compute Im + Dk*D . C CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I25 ), M ) CALL DGEMM( 'N', 'N', M, M, NP, ONE, DK, LDDK, D, LDD, $ ONE, DWORK( I25 ), M ) C ^ ^ ^ ^ -1 C Compute Ck = M*Ck, M = (Im + Dk*D) . C ANORM = DLANGE( '1', M, M, DWORK( I25 ), M, DWORK( IWRK ) ) CALL DGETRF( M, M, DWORK( I25 ), M, IWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 7 RETURN END IF CALL DGECON( '1', M, DWORK( I25 ), M, ANORM, RCOND( 6 ), $ DWORK( IWRK ), IWORK( M+1 ), INFO2 ) C C Return if the matrix is singular to working precision. C IF( RCOND( 6 ).LT.TOLL ) THEN INFO = 7 RETURN END IF CALL DGETRS( 'N', M, N, DWORK( I25 ), M, IWORK, CK, LDCK, INFO2 ) C ^ ^ C Compute Dk = M*Dk . C CALL DGETRS( 'N', M, NP, DWORK( I25 ), M, IWORK, DK, LDDK, INFO2 ) C ^ C Compute Bk*D . C CALL DGEMM( 'N', 'N', N, M, NP, ONE, DWORK( I23 ), N, D, LDD, $ ZERO, DWORK( I26 ), N ) C ^ ^ C Compute Ak = Ak - Bk*D*Ck. C CALL DGEMM( 'N', 'N', N, N, M, -ONE, DWORK( I26 ), N, CK, LDCK, $ ONE, AK, LDAK ) C ^ ^ -1 C Compute Bk = Bk*(Ip + D*Dk) . C ANORM = DLANGE( '1', NP, NP, DWORK( I24 ), NP, DWORK( IWRK ) ) CALL DLACPY( 'Full', N, NP, DWORK( I23 ), N, BK, LDBK ) CALL MB02VD( 'N', N, NP, DWORK( I24 ), NP, IWORK, BK, LDBK, $ INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 6 RETURN END IF CALL DGECON( '1', NP, DWORK( I24 ), NP, ANORM, RCOND( 5 ), $ DWORK( IWRK ), IWORK( NP+1 ), INFO2 ) C C Return if the matrix is singular to working precision. C IF( RCOND( 5 ).LT.TOLL ) THEN INFO = 6 RETURN END IF C C Workspace usage. C I2 = 1 + NP*NP I3 = I2 + N*NP I4 = I3 + M*M I5 = I4 + N*M I6 = I5 + NP*N I7 = I6 + M*N I8 = I7 + N2*N2 I9 = I8 + N2 C IWRK = I9 + N2 C C Compute Ip - D*Dk . C CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK, NP ) CALL DGEMM( 'N', 'N', NP, NP, M, -ONE, D, LDD, DK, LDDK, ONE, $ DWORK, NP ) C -1 C Compute Bk*(Ip-D*Dk) . C CALL DLACPY( 'Full', N, NP, BK, LDBK, DWORK( I2 ), N ) CALL MB02VD( 'N', N, NP, DWORK, NP, IWORK, DWORK( I2 ), N, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 8 RETURN END IF C C Compute Im - Dk*D . C CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I3 ), M ) CALL DGEMM( 'N', 'N', M, M, NP, -ONE, DK, LDDK, D, LDD, ONE, $ DWORK( I3 ), M ) C -1 C Compute B*(Im-Dk*D) . C CALL DLACPY( 'Full', N, M, B, LDB, DWORK( I4 ), N ) CALL MB02VD( 'N', N, M, DWORK( I3 ), M, IWORK, DWORK( I4 ), N, $ INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 9 RETURN END IF C C Compute D*Ck . C CALL DGEMM( 'N', 'N', NP, N, M, ONE, D, LDD, CK, LDCK, ZERO, $ DWORK( I5 ), NP ) C C Compute Dk*C . C CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, $ DWORK( I6 ), M ) C C Compute the closed-loop state matrix. C CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7 ), N2 ) CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4 ), N, $ DWORK( I6 ), M, ONE, DWORK( I7 ), N2 ) CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4 ), N, CK, LDCK, $ ZERO, DWORK( I7+N2*N ), N2 ) CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I2 ), N, C, LDC, $ ZERO, DWORK( I7+N ), N2 ) CALL DLACPY( 'F', N, N, AK, LDAK, DWORK( I7+N2*N+N ), N2 ) CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I2 ), N, $ DWORK( I5 ), NP, ONE, DWORK( I7+N2*N+N ), N2 ) C C Compute the closed-loop poles. C CALL DGEES( 'N', 'N', SELECT, N2, DWORK( I7 ), N2, SDIM, $ DWORK( I8 ), DWORK( I9 ), DWORK( IWRK ), N, $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Check the stability of the closed-loop system. C NS = 0 C DO 140 I = 0, N2 - 1 IF( DLAPY2( DWORK( I8+I ), DWORK( I9+I ) ).GT.ONE ) $ NS = NS + 1 140 CONTINUE C IF( NS.GT.0 ) THEN INFO = 10 RETURN END IF C DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10ZD *** END control-4.1.2/src/slicot/src/PaxHeaders/AG07BD.f0000644000000000000000000000013215012430707016141 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/AG07BD.f0000644000175000017500000002050515012430707017337 0ustar00lilgelilge00000000000000 SUBROUTINE AG07BD( JOBE, N, M, A, LDA, E, LDE, B, LDB, C, LDC, $ D, LDD, AI, LDAI, EI, LDEI, BI, LDBI, CI, LDCI, $ DI, LDDI, INFO ) C C PURPOSE C C To compute the inverse (Ai-lambda*Ei,Bi,Ci,Di) of a given C descriptor system (A-lambda*E,B,C,D). C C ARGUMENTS C C Mode Parameters 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 Input/Output Parameters C C N (input) INTEGER C The order of the square matrices A and E; C also the number of rows of matrix B and the number of C columns of matrix C. N >= 0. C C M (input) INTEGER C The number of system inputs and outputs, i.e., the number C of columns of matrices B and D and the number of rows of C matrices C and D. M >= 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 matrix A of the original system. 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 original 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 input matrix B of the original system. 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 M-by-N part of this array must contain the C output matrix C of the original system. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,M). C C D (input) DOUBLE PRECISION array, dimension (LDD,M) C The leading M-by-M part of this array must contain the C feedthrough matrix D of the original system. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1,M). C C AI (output) DOUBLE PRECISION array, dimension (LDAI,N+M) C The leading (N+M)-by-(N+M) part of this array contains C the state matrix Ai of the inverse system. C If LDAI = LDA >= N+M, then AI and A can share the same C storage locations. C C LDAI INTEGER C The leading dimension of the array AI. C LDAI >= MAX(1,N+M). C C EI (output) DOUBLE PRECISION array, dimension (LDEI,N+M) C The leading (N+M)-by-(N+M) part of this array contains C the descriptor matrix Ei of the inverse system. C If LDEI = LDE >= N+M, then EI and E can share the same C storage locations. C C LDEI INTEGER C The leading dimension of the array EI. C LDEI >= MAX(1,N+M). C C BI (output) DOUBLE PRECISION array, dimension (LDBI,M) C The leading (N+M)-by-M part of this array contains C the input matrix Bi of the inverse system. C If LDBI = LDB >= N+M, then BI and B can share the same C storage locations. C C LDBI INTEGER C The leading dimension of the array BI. C LDBI >= MAX(1,N+M). C C CI (output) DOUBLE PRECISION array, dimension (LDCI,N+M) C The leading M-by-(N+M) part of this array contains C the output matrix Ci of the inverse system. C If LDCI = LDC, CI and C can share the same storage C locations. C C LDCI INTEGER C The leading dimension of the array CI. LDCI >= MAX(1,M). C C DI (output) DOUBLE PRECISION array, dimension (LDDI,M) C The leading M-by-M part of this array contains C the feedthrough matrix Di = 0 of the inverse system. C DI and D can share the same storage locations. C C LDDI INTEGER C The leading dimension of the array DI. LDDI >= 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 matrices of the inverse system are computed with the formulas C C ( E 0 ) ( A B ) ( 0 ) C Ei = ( ) , Ai = ( ) , Bi = ( ), C ( 0 0 ) ( C D ) ( -I ) C C Ci = ( 0 I ), Di = 0. C C FURTHER COMMENTS C C The routine does not perform an invertibility test. This check can C be performed by using the SLICOT routines AB08NX or AG08BY. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. C C KEYWORDS C C Descriptor system, inverse system, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBE INTEGER INFO, LDA, LDAI, LDB, LDBI, LDC, LDCI, $ LDD, LDDI, LDE, LDEI, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), AI(LDAI,*), B(LDB,*), BI(LDBI,*), $ C(LDC,*), CI(LDCI,*), D(LDD,*), DI(LDDI,*), $ E(LDE,*), EI(LDEI,*) C .. Local Scalars .. LOGICAL UNITE C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLACPY, DLASET, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C UNITE = LSAME( JOBE, 'I' ) IF( .NOT. ( LSAME( JOBE, 'G' ) .OR. UNITE ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDE.LT.1 .OR. ( .NOT.UNITE .AND. LDE.LT.N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -13 ELSE IF( LDAI.LT.MAX( 1, N+M ) ) THEN INFO = -15 ELSE IF( LDEI.LT.MAX( 1, N+M ) ) THEN INFO = -17 ELSE IF( LDBI.LT.MAX( 1, N+M ) ) THEN INFO = -19 ELSE IF( LDCI.LT.MAX( 1, M ) ) THEN INFO = -21 ELSE IF( LDDI.LT.MAX( 1, M ) ) THEN INFO = -23 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AG07BD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( M.EQ.0 ) $ RETURN C C Form Ai. C CALL DLACPY( 'Full', N, N, A, LDA, AI, LDAI ) CALL DLACPY( 'Full', M, N, C, LDC, AI(N+1,1), LDAI ) CALL DLACPY( 'Full', N, M, B, LDB, AI(1,N+1), LDAI ) CALL DLACPY( 'Full', M, M, D, LDD, AI(N+1,N+1), LDAI ) C C Form Ei. C IF( UNITE ) THEN CALL DLASET( 'Full', N+M, N, ZERO, ONE, EI, LDEI ) ELSE CALL DLACPY( 'Full', N, N, E, LDE, EI, LDEI ) CALL DLASET( 'Full', M, N, ZERO, ZERO, EI(N+1,1), LDEI ) END IF CALL DLASET( 'Full', N+M, M, ZERO, ZERO, EI(1,N+1), LDEI ) C C Form Bi. C CALL DLASET( 'Full', N, M, ZERO, ZERO, BI, LDBI ) CALL DLASET( 'Full', M, M, ZERO, -ONE, BI(N+1,1), LDBI ) C C Form Ci. C CALL DLASET( 'Full', M, N, ZERO, ZERO, CI, LDCI ) CALL DLASET( 'Full', M, M, ZERO, ONE, CI(1,N+1), LDCI ) C C Set Di. C CALL DLASET( 'Full', M, M, ZERO, ZERO, DI, LDDI ) C RETURN C *** Last line of AG07BD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04OY.f0000644000000000000000000000013215012430707016207 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB04OY.f0000644000175000017500000002305515012430707017410 0ustar00lilgelilge00000000000000 SUBROUTINE MB04OY( M, N, V, TAU, A, LDA, B, LDB, DWORK ) C C PURPOSE C C To apply a real elementary reflector H to a real (m+1)-by-n C matrix C = [ A ], from the left, where A has one row. H is C [ B ] 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 m-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 matrix B. M >= 0. C C N (input) INTEGER C The number of columns of the matrices A and B. N >= 0. C C V (input) DOUBLE PRECISION array, dimension (M) C The vector v in the representation of H. 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,N) C On entry, the leading 1-by-N part of this array must C contain the matrix A. C On exit, the leading 1-by-N part of this array contains C the updated matrix A (the first row of H * C). C C LDA INTEGER C The leading dimension of array A. LDA >= 1. 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 m rows of H * C). 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 (N) 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, Feb. 1997. C Based on LAPACK routines DLARFX and DLATZM. C C REVISIONS C C Dec. 1997. 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 LDA, LDB, M, N DOUBLE PRECISION TAU C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) C .. Local Scalars .. INTEGER 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 H * C, where H has order m+1. C GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 ) M+1 C C Code for general M. Compute C C w := C'*u, C := C - tau * u * w'. C CALL DCOPY( N, A, LDA, DWORK, 1 ) CALL DGEMV( 'Transpose', M, N, ONE, B, LDB, V, 1, ONE, DWORK, 1 ) CALL DAXPY( N, -TAU, DWORK, 1, A, LDA ) CALL DGER( M, N, -TAU, V, 1, DWORK, 1, B, LDB ) GO TO 210 10 CONTINUE C C Special code for 1 x 1 Householder C T1 = ONE - TAU DO 20 J = 1, N A( 1, J ) = T1*A( 1, J ) 20 CONTINUE GO TO 210 30 CONTINUE C C Special code for 2 x 2 Householder C V1 = V( 1 ) T1 = TAU*V1 DO 40 J = 1, N SUM = A( 1, J ) + V1*B( 1, J ) A( 1, J ) = A( 1, J ) - SUM*TAU B( 1, J ) = B( 1, J ) - SUM*T1 40 CONTINUE GO TO 210 50 CONTINUE C C Special code for 3 x 3 Householder C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 60 J = 1, N SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) A( 1, J ) = A( 1, J ) - SUM*TAU B( 1, J ) = B( 1, J ) - SUM*T1 B( 2, J ) = B( 2, J ) - SUM*T2 60 CONTINUE GO TO 210 70 CONTINUE C C Special code for 4 x 4 Householder C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 80 J = 1, N SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) A( 1, J ) = A( 1, J ) - SUM*TAU B( 1, J ) = B( 1, J ) - SUM*T1 B( 2, J ) = B( 2, J ) - SUM*T2 B( 3, J ) = B( 3, J ) - SUM*T3 80 CONTINUE GO TO 210 90 CONTINUE C C Special code for 5 x 5 Householder C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 100 J = 1, N SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + $ V4*B( 4, J ) A( 1, J ) = A( 1, J ) - SUM*TAU B( 1, J ) = B( 1, J ) - SUM*T1 B( 2, J ) = B( 2, J ) - SUM*T2 B( 3, J ) = B( 3, J ) - SUM*T3 B( 4, J ) = B( 4, J ) - SUM*T4 100 CONTINUE GO TO 210 110 CONTINUE C C Special code for 6 x 6 Householder C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 120 J = 1, N SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + $ V4*B( 4, J ) + V5*B( 5, J ) A( 1, J ) = A( 1, J ) - SUM*TAU B( 1, J ) = B( 1, J ) - SUM*T1 B( 2, J ) = B( 2, J ) - SUM*T2 B( 3, J ) = B( 3, J ) - SUM*T3 B( 4, J ) = B( 4, J ) - SUM*T4 B( 5, J ) = B( 5, J ) - SUM*T5 120 CONTINUE GO TO 210 130 CONTINUE C C Special code for 7 x 7 Householder C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 140 J = 1, N SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) A( 1, J ) = A( 1, J ) - SUM*TAU B( 1, J ) = B( 1, J ) - SUM*T1 B( 2, J ) = B( 2, J ) - SUM*T2 B( 3, J ) = B( 3, J ) - SUM*T3 B( 4, J ) = B( 4, J ) - SUM*T4 B( 5, J ) = B( 5, J ) - SUM*T5 B( 6, J ) = B( 6, J ) - SUM*T6 140 CONTINUE GO TO 210 150 CONTINUE C C Special code for 8 x 8 Householder C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 160 J = 1, N SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + $ V7*B( 7, J ) A( 1, J ) = A( 1, J ) - SUM*TAU B( 1, J ) = B( 1, J ) - SUM*T1 B( 2, J ) = B( 2, J ) - SUM*T2 B( 3, J ) = B( 3, J ) - SUM*T3 B( 4, J ) = B( 4, J ) - SUM*T4 B( 5, J ) = B( 5, J ) - SUM*T5 B( 6, J ) = B( 6, J ) - SUM*T6 B( 7, J ) = B( 7, J ) - SUM*T7 160 CONTINUE GO TO 210 170 CONTINUE C C Special code for 9 x 9 Householder C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 180 J = 1, N SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + $ V7*B( 7, J ) + V8*B( 8, J ) A( 1, J ) = A( 1, J ) - SUM*TAU B( 1, J ) = B( 1, J ) - SUM*T1 B( 2, J ) = B( 2, J ) - SUM*T2 B( 3, J ) = B( 3, J ) - SUM*T3 B( 4, J ) = B( 4, J ) - SUM*T4 B( 5, J ) = B( 5, J ) - SUM*T5 B( 6, J ) = B( 6, J ) - SUM*T6 B( 7, J ) = B( 7, J ) - SUM*T7 B( 8, J ) = B( 8, J ) - SUM*T8 180 CONTINUE GO TO 210 190 CONTINUE C C Special code for 10 x 10 Householder C V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 200 J = 1, N SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + $ V7*B( 7, J ) + V8*B( 8, J ) + V9*B( 9, J ) A( 1, J ) = A( 1, J ) - SUM*TAU B( 1, J ) = B( 1, J ) - SUM*T1 B( 2, J ) = B( 2, J ) - SUM*T2 B( 3, J ) = B( 3, J ) - SUM*T3 B( 4, J ) = B( 4, J ) - SUM*T4 B( 5, J ) = B( 5, J ) - SUM*T5 B( 6, J ) = B( 6, J ) - SUM*T6 B( 7, J ) = B( 7, J ) - SUM*T7 B( 8, J ) = B( 8, J ) - SUM*T8 B( 9, J ) = B( 9, J ) - SUM*T9 200 CONTINUE 210 CONTINUE RETURN C *** Last line of MB04OY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03ZA.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB03ZA.f0000644000175000017500000015660215012430707017377 0ustar00lilgelilge00000000000000 SUBROUTINE MB03ZA( COMPC, COMPU, COMPV, COMPW, WHICH, SELECT, N, $ A, LDA, B, LDB, C, LDC, U1, LDU1, U2, LDU2, V1, $ LDV1, V2, LDV2, W, LDW, WR, WI, M, DWORK, $ LDWORK, INFO ) C C PURPOSE C C 1. To compute, for a given matrix pair (A,B) in periodic Schur C form, orthogonal matrices Ur and Vr so that C C T [ A11 A12 ] T [ B11 B12 ] C Vr * A * Ur = [ ], Ur * B * Vr = [ ], (1) C [ 0 A22 ] [ 0 B22 ] C C is in periodic Schur form, and the eigenvalues of A11*B11 C form a selected cluster of eigenvalues. C C 2. To compute an orthogonal matrix W so that C C T [ 0 -A11 ] [ R11 R12 ] C W * [ ] * W = [ ], (2) C [ B11 0 ] [ 0 R22 ] C C where the eigenvalues of R11 and -R22 coincide and have C positive real part. C C Optionally, the matrix C is overwritten by Ur'*C*Vr. C C All eigenvalues of A11*B11 must either be complex or real and C negative. C C ARGUMENTS C C Mode Parameters C C COMPC CHARACTER*1 C = 'U': update the matrix C; C = 'N': do not update C. C C COMPU CHARACTER*1 C = 'U': update the matrices U1 and U2; C = 'N': do not update U1 and U2. C See the description of U1 and U2. C C COMPV CHARACTER*1 C = 'U': update the matrices V1 and V2; C = 'N': do not update V1 and V2. C See the description of V1 and V2. C C COMPW CHARACTER*1 C Indicates whether or not the user wishes to accumulate C the matrix W as follows: C = 'N': the matrix W is not required; C = 'I': W is initialized to the unit matrix and the C orthogonal transformation matrix W is returned; C = 'V': W must contain an orthogonal matrix Q on entry, C and the product Q*W is returned. C C WHICH CHARACTER*1 C = 'A': select all eigenvalues, this effectively means C that Ur and Vr are identity matrices and A11 = A, C B11 = B; C = 'S': select a cluster of eigenvalues specified by C SELECT. C C SELECT LOGICAL array, dimension (N) C If WHICH = 'S', then SELECT specifies the eigenvalues of C A*B in the selected cluster. To select a real eigenvalue C w(j), SELECT(j) must be set to .TRUE.. To select a complex C conjugate pair of eigenvalues w(j) and w(j+1), C corresponding to a 2-by-2 diagonal block in A, both C SELECT(j) and SELECT(j+1) must be set to .TRUE.; a complex C conjugate pair of eigenvalues must be either both included C in the cluster or both excluded. 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 part of this array must C contain the upper quasi-triangular matrix A of the matrix C pair (A,B) in periodic Schur form. C On exit, the leading M-by-M part of this array contains C the matrix R22 in (2). C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) C On entry, the leading N-by-N part of this array must C contain the upper triangular matrix B of the matrix pair C (A,B) in periodic Schur form. C On exit, the leading N-by-N part of this array is C overwritten. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,N). C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) C On entry, if COMPC = 'U', the leading N-by-N part of this C array must contain a general matrix C. C On exit, if COMPC = 'U', the leading N-by-N part of this C array contains the updated matrix Ur'*C*Vr. C If COMPC = 'N' or WHICH = 'A', this array is not C referenced. C C LDC INTEGER C The leading dimension of the array C. LDC >= 1. C LDC >= N, if COMPC = 'U' and WHICH = 'S'. C C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) C On entry, if COMPU = 'U' and WHICH = 'S', the leading C N-by-N part of this array must contain U1, the (1,1) C block of an orthogonal symplectic matrix C U = [ U1, U2; -U2, U1 ]. C On exit, if COMPU = 'U' and WHICH = 'S', the leading C N-by-N part of this array contains U1*Ur. C If COMPU = 'N' or WHICH = 'A', this array is not C referenced. C C LDU1 INTEGER C The leading dimension of the array U1. LDU1 >= 1. C LDU1 >= N, if COMPU = 'U' and WHICH = 'S'. C C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) C On entry, if COMPU = 'U' and WHICH = 'S', the leading C N-by-N part of this array must contain U2, the (1,2) C block of an orthogonal symplectic matrix C U = [ U1, U2; -U2, U1 ]. C On exit, if COMPU = 'U' and WHICH = 'S', the leading C N-by-N part of this array contains U2*Ur. C If COMPU = 'N' or WHICH = 'A', this array is not C referenced. C C LDU2 INTEGER C The leading dimension of the array U2. LDU2 >= 1. C LDU2 >= N, if COMPU = 'U' and WHICH = 'S'. C C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) C On entry, if COMPV = 'U' and WHICH = 'S', the leading C N-by-N part of this array must contain V1, the (1,1) C block of an orthogonal symplectic matrix C V = [ V1, V2; -V2, V1 ]. C On exit, if COMPV = 'U' and WHICH = 'S', the leading C N-by-N part of this array contains V1*Vr. C If COMPV = 'N' or WHICH = 'A', this array is not C referenced. C C LDV1 INTEGER C The leading dimension of the array V1. LDV1 >= 1. C LDV1 >= N, if COMPV = 'U' and WHICH = 'S'. C C V2 (input/output) DOUBLE PRECISION array, dimension (LDV2,N) C On entry, if COMPV = 'U' and WHICH = 'S', the leading C N-by-N part of this array must contain V2, the (1,2) C block of an orthogonal symplectic matrix C V = [ V1, V2; -V2, V1 ]. C On exit, if COMPV = 'U' and WHICH = 'S', the leading C N-by-N part of this array contains V2*Vr. C If COMPV = 'N' or WHICH = 'A', this array is not C referenced. C C LDV2 INTEGER C The leading dimension of the array V2. LDV2 >= 1. C LDV2 >= N, if COMPV = 'U' and WHICH = 'S'. C C W (input/output) DOUBLE PRECISION array, dimension (LDW,2*M) C On entry, if COMPW = 'V', then the leading 2*M-by-2*M part C of this array must contain a matrix W. C If COMPW = 'I', then W need not be set on entry, W is set C to the identity matrix. C On exit, if COMPW = 'I' or 'V' the leading 2*M-by-2*M part C of this array is post-multiplied by the transformation C matrix that produced (2). C If COMPW = 'N', this array is not referenced. C C LDW INTEGER C The leading dimension of the array W. LDW >= 1. C LDW >= 2*M, if COMPW = 'I' or COMPW = 'V'. C C WR (output) DOUBLE PRECISION array, dimension (M) C WI (output) DOUBLE PRECISION array, dimension (M) C The real and imaginary parts, respectively, of the C eigenvalues of R11. The eigenvalues are stored in the same C order as on the diagonal of R22, with C WR(i) = -R22(i,i) and, if R22(i:i+1,i:i+1) is a 2-by-2 C diagonal block, WI(i) > 0 and WI(i+1) = -WI(i). C In exact arithmetic, these eigenvalue are the positive C square roots of the selected eigenvalues of the product C A*B. However, if an eigenvalue is sufficiently C ill-conditioned, then its value may differ significantly. C C M (output) INTEGER C The number of selected eigenvalues. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = -28, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( 1, 4*N, 8*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 = 1: reordering of the product A*B in Step 1 failed C because some eigenvalues are too close to separate; C = 2: reordering of some submatrix in Step 2 failed C because some eigenvalues are too close to separate; C = 3: the QR algorithm failed to compute the Schur form C of some submatrix in Step 2; C = 4: the condition that all eigenvalues of A11*B11 must C either be complex or real and negative is C numerically violated. C C METHOD C C Step 1 is performed using a reordering technique analogous to the C LAPACK routine DTGSEN for reordering matrix pencils [1,2]. Step 2 C is an implementation of Algorithm 2 in [3]. It requires O(M*N*N) C floating point operations. C C REFERENCES C C [1] Kagstrom, B. C A direct method for reordering eigenvalues in the generalized C real Schur form of a regular matrix pair (A,B), in M.S. Moonen C et al (eds), Linear Algebra for Large Scale and Real-Time C Applications, Kluwer Academic Publ., 1993, pp. 195-218. C C [2] Kagstrom, B. and Poromaa P.: C Computing eigenspaces with specified eigenvalues of a regular C matrix pair (A, B) and condition estimation: Theory, C algorithms and software, Numer. Algorithms, 1996, vol. 12, C pp. 369-407. C C [3] Benner, P., Mehrmann, V., and Xu, H. C A new method for computing the stable invariant subspace of a C real Hamiltonian matrix, J. Comput. Appl. Math., 86, C pp. 17-43, 1997. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLABMX). C V. Sima, June 2015. C C KEYWORDS C C Hamiltonian matrix, invariant subspace. C C ****************************************************************** C C .. Parameters .. INTEGER LDQZ PARAMETER ( LDQZ = 4 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER COMPC, COMPU, COMPV, COMPW, WHICH INTEGER INFO, LDA, LDB, LDC, LDU1, LDU2, LDV1, LDV2, $ LDW, LDWORK, M, N C .. Array Arguments .. LOGICAL SELECT(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), $ U1(LDU1,*), U2(LDU2,*), V1(LDV1,*), V2(LDV2,*), $ W(LDW,*), WI(*), WR(*) C .. Local Scalars .. LOGICAL CMPALL, INITW, PAIR, SWAP, WANTC, WANTU, WANTV, $ WANTW INTEGER HERE, I, IERR, IFST, ILST, K, KS, L, LEN, MM, $ NB, NBF, NBL, NBNEXT, POS, PW, PWC, PWCK, PWD, $ PWDL, WRKMIN DOUBLE PRECISION TEMP C .. Local Arrays .. LOGICAL LDUM(1), SELNEW(4) DOUBLE PRECISION DW12(12), Q(LDQZ,LDQZ), T(LDQZ,LDQZ), WINEW(4), $ WRNEW(4), Z(LDQZ,LDQZ) INTEGER IDUM(1) C .. External Functions .. LOGICAL LFDUM, LSAME EXTERNAL LFDUM, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEES, DGEMM, DLACPY, DLASET, DSCAL, $ DTRSEN, MB03WA, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C C .. Executable Statements .. C C Decode and check input parameters C WANTC = LSAME( COMPC, 'U' ) WANTU = LSAME( COMPU, 'U' ) WANTV = LSAME( COMPV, 'U' ) INITW = LSAME( COMPW, 'I' ) WANTW = INITW .OR. LSAME( COMPW, 'V' ) CMPALL = LSAME( WHICH, 'A' ) WRKMIN = MAX( 1, 4*N ) C INFO = 0 IF ( .NOT.WANTC .AND. .NOT.LSAME( COMPC, 'N' ) ) THEN INFO = -1 ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN INFO = -2 ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( COMPV, 'N' ) ) THEN INFO = -3 ELSE IF ( .NOT.WANTW .AND. .NOT.LSAME( COMPW, 'N' ) ) THEN INFO = -4 ELSE IF ( .NOT.CMPALL .AND. .NOT.LSAME( WHICH, 'S' ) ) THEN INFO = -5 ELSE IF ( CMPALL ) THEN M = N ELSE C C Set M to the dimension of the specified invariant subspace. C M = 0 PAIR = .FALSE. DO 10 K = 1, N IF ( PAIR ) THEN PAIR = .FALSE. ELSE IF ( K.LT.N ) THEN IF ( A(K+1,K).EQ.ZERO ) THEN IF ( SELECT(K) ) $ M = M + 1 ELSE PAIR = .TRUE. IF ( SELECT(K) .OR. SELECT(K+1) ) $ M = M + 2 END IF ELSE IF ( SELECT(N) ) $ M = M + 1 END IF END IF 10 CONTINUE END IF C C Compute workspace requirements. C WRKMIN = MAX( WRKMIN, 8*M ) C IF ( N.LT.0 ) THEN INFO = -7 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF ( LDC.LT.1 .OR. ( WANTC .AND. .NOT.CMPALL .AND. $ LDC.LT.N ) ) THEN INFO = -13 ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND. $ LDU1.LT.N ) ) THEN INFO = -15 ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND. $ LDU2.LT.N ) ) THEN INFO = -17 ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND. $ LDV1.LT.N ) ) THEN INFO = -19 ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND. $ LDV2.LT.N ) ) THEN INFO = -21 ELSE IF ( LDW.LT.1 .OR. ( WANTW .AND. LDW.LT.2*M ) ) THEN INFO = -23 ELSE IF ( LDWORK.LT.WRKMIN ) THEN INFO = -28 DWORK(1) = DBLE( WRKMIN ) END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03ZA', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Jump immediately to Step 2, if all eigenvalues are requested. C IF ( CMPALL ) $ GO TO 50 C C Step 1: Collect the selected blocks at the top-left corner of A*B. C KS = 0 PAIR = .FALSE. DO 40 K = 1, N IF ( PAIR ) THEN PAIR = .FALSE. ELSE SWAP = SELECT(K) IF ( K.LT.N ) THEN IF ( A(K+1,K).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP .OR. SELECT(K+1) END IF END IF C IF ( PAIR ) THEN NBF = 2 ELSE NBF = 1 END IF C IF ( SWAP ) THEN KS = KS + 1 IFST = K C C Swap the K-th block to position KS. C ILST = KS NBL = 1 IF ( ILST.GT.1 ) THEN IF ( A(ILST,ILST-1).NE.ZERO ) THEN ILST = ILST - 1 NBL = 2 END IF END IF C IF ( ILST.EQ.IFST ) $ GO TO 30 C HERE = IFST 20 CONTINUE C C Swap block with next one above. C IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN C C Current block either 1-by-1 or 2-by-2. C NBNEXT = 1 IF ( HERE.GE.3 ) THEN IF ( A(HERE-1,HERE-2).NE.ZERO ) $ NBNEXT = 2 END IF POS = HERE - NBNEXT NB = NBNEXT + NBF CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) C CALL MB03WA( .TRUE., .TRUE., NBNEXT, NBF, A(POS,POS), $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ, $ IERR ) C IF ( IERR.NE.0 ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = 1 RETURN END IF C C Update rest of A. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, $ NB, NB, ONE, A(1,POS), LDA, Z, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS), $ LDA ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Q, LDQZ, $ A(POS,POS+NB), LDA, ZERO, DWORK, NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, $ A(POS,POS+NB), LDA ) END IF C C Update rest of B. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, $ NB, NB, ONE, B(1,POS), LDB, Q, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS), $ LDB ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Z, LDQZ, $ B(POS,POS+NB), LDB, ZERO, DWORK, NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, $ B(POS,POS+NB), LDB ) END IF C C Update C. C IF ( WANTC ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), $ LDC ) CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, $ ZERO, DWORK, NB ) CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), $ LDC ) END IF C C Update U. C IF ( WANTU ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), $ LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), $ LDU2 ) END IF C C Update V. C IF ( WANTV ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), $ LDV1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), $ LDV2 ) END IF C HERE = HERE - NBNEXT C C Test if 2-by-2 block breaks into two 1-by-1 blocks. C IF ( NBF.EQ.2 ) THEN IF ( A(HERE+1,HERE).EQ.ZERO ) $ NBF = 3 END IF C ELSE C C Current block consists of two 1 by 1 blocks each of C which must be swapped individually. C NBNEXT = 1 IF ( HERE.GE.3 ) THEN IF ( A(HERE-1,HERE-2).NE.ZERO ) $ NBNEXT = 2 END IF POS = HERE - NBNEXT NB = NBNEXT + 1 CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) C CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS), $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ, $ IERR ) C IF ( IERR.NE.0 ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = 1 RETURN END IF C C Update rest of A. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, $ NB, NB, ONE, A(1,POS), LDA, Z, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS), $ LDA ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Q, LDQZ, $ A(POS,POS+NB), LDA, ZERO, DWORK, NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, $ A(POS,POS+NB), LDA ) END IF C C Update rest of B. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, $ NB, NB, ONE, B(1,POS), LDB, Q, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS), $ LDB ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Z, LDQZ, $ B(POS,POS+NB), LDB, ZERO, DWORK, NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, $ B(POS,POS+NB), LDB ) END IF C C Update C. C IF ( WANTC ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), $ LDC ) CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, $ ZERO, DWORK, NB ) CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), $ LDC ) END IF C C Update U. C IF ( WANTU ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), $ LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), $ LDU2 ) END IF C C Update V. C IF ( WANTV ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), $ LDV1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), $ LDV2 ) END IF C IF ( NBNEXT.EQ.1 ) THEN C C Swap two 1-by-1 blocks. C POS = HERE NB = NBNEXT + 1 CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) C CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS), $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, $ LDQZ, IERR ) C IF ( IERR.NE.0 ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = 1 RETURN END IF C C Update rest of A. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ POS-1, NB, NB, ONE, A(1,POS), LDA, $ Z, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, $ A(1,POS), LDA ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Q, LDQZ, $ A(POS,POS+NB), LDA, ZERO, DWORK, $ NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, $ A(POS,POS+NB), LDA ) END IF C C Update rest of B. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ POS-1, NB, NB, ONE, B(1,POS), LDB, $ Q, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, $ B(1,POS), LDB ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Z, LDQZ, $ B(POS,POS+NB), LDB, ZERO, DWORK, $ NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, $ B(POS,POS+NB), LDB ) END IF C C Update C. C IF ( WANTC ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, $ ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), $ LDC ) CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, $ ZERO, DWORK, NB ) CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), $ LDC ) END IF C C Update U. C IF ( WANTU ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, U1(1,POS), LDU1, Z, $ LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), $ LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, U2(1,POS), LDU2, Z, $ LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), $ LDU2 ) END IF C C Update V. C IF ( WANTV ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, V1(1,POS), LDV1, Q, $ LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), $ LDV1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, $ NB, NB, ONE, V2(1,POS), LDV2, Q, $ LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), $ LDV2 ) END IF C HERE = HERE - 1 ELSE C C Recompute NBNEXT in case 2-by-2 split. C IF ( A(HERE,HERE-1).EQ.ZERO ) $ NBNEXT = 1 C IF ( NBNEXT.EQ.2 ) THEN C C 2-by-2 block did not split. C POS = HERE - 1 NB = 3 CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) C CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, $ LDQZ, IERR ) C IF ( IERR.NE.0 ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = 1 RETURN END IF C C Update rest of A. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ POS-1, NB, NB, ONE, A(1,POS), $ LDA, Z, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, $ A(1,POS), LDA ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Q, LDQZ, $ A(POS,POS+NB), LDA, ZERO, DWORK, $ NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, $ NB, A(POS,POS+NB), LDA ) END IF C C Update rest of B. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ POS-1, NB, NB, ONE, B(1,POS), $ LDB, Q, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, $ B(1,POS), LDB ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Z, LDQZ, $ B(POS,POS+NB), LDB, ZERO, DWORK, $ NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, $ NB, B(POS,POS+NB), LDB ) END IF C C Update C. C IF ( WANTC ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, C(1,POS), LDC, Q, $ LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ C(1,POS), LDC ) CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N, NB, ONE, Z, LDQZ, C(POS,1), $ LDC, ZERO, DWORK, NB ) CALL DLACPY( 'All', NB, N, DWORK, NB, $ C(POS,1), LDC ) END IF C C Update U. C IF ( WANTU ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, U1(1,POS), LDU1, $ Z, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ U1(1,POS), LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, U2(1,POS), LDU2, $ Z, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ U2(1,POS), LDU2 ) END IF C C Update V. C IF ( WANTV ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, V1(1,POS), LDV1, $ Q, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ V1(1,POS), LDV1 ) CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, V2(1,POS), LDV2, $ Q, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ V2(1,POS), LDV2 ) END IF C HERE = HERE - 2 ELSE C C 2-by-2 block did split. C POS = HERE NB = 2 CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) C CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, $ LDQZ, IERR ) C IF ( IERR.NE.0 ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = 1 RETURN END IF C C Update rest of A. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ POS-1, NB, NB, ONE, A(1,POS), $ LDA, Z, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, $ A(1,POS), LDA ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Q, LDQZ, $ A(POS,POS+NB), LDA, ZERO, DWORK, $ NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, $ NB, A(POS,POS+NB), LDA ) END IF C C Update rest of B. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ POS-1, NB, NB, ONE, B(1,POS), $ LDB, Q, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, $ B(1,POS), LDB ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Z, LDQZ, $ B(POS,POS+NB), LDB, ZERO, DWORK, $ NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, $ NB, B(POS,POS+NB), LDB ) END IF C C Update C. C IF ( WANTC ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, C(1,POS), LDC, Q, $ LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ C(1,POS), LDC ) CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N, NB, ONE, Z, LDQZ, C(POS,1), $ LDC, ZERO, DWORK, NB ) CALL DLACPY( 'All', NB, N, DWORK, NB, $ C(POS,1), LDC ) END IF C C Update U. C IF ( WANTU ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, U1(1,POS), LDU1, $ Z, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ U1(1,POS), LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, U2(1,POS), LDU2, $ Z, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ U2(1,POS), LDU2 ) END IF C C Update V. C IF ( WANTV ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, V1(1,POS), LDV1, $ Q, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ V1(1,POS), LDV1 ) CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, V2(1,POS), LDV2, $ Q, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ V2(1,POS), LDV2 ) END IF C POS = HERE - 1 NB = 2 CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) C CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, $ LDQZ, IERR ) C IF ( IERR.NE.0 ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = 1 RETURN END IF C C Update rest of A. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ POS-1, NB, NB, ONE, A(1,POS), $ LDA, Z, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, $ A(1,POS), LDA ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Q, LDQZ, $ A(POS,POS+NB), LDA, ZERO, DWORK, $ NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, $ NB, A(POS,POS+NB), LDA ) END IF C C Update rest of B. C IF ( POS.GT.1 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ POS-1, NB, NB, ONE, B(1,POS), $ LDB, Q, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', POS-1, NB, DWORK, N, $ B(1,POS), LDB ) END IF IF ( POS+NB.LE.N ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N-POS-NB+1, NB, ONE, Z, LDQZ, $ B(POS,POS+NB), LDB, ZERO, DWORK, $ NB ) CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, $ NB, B(POS,POS+NB), LDB ) END IF C C Update C. C IF ( WANTC ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, C(1,POS), LDC, Q, $ LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ C(1,POS), LDC ) CALL DGEMM( 'Transpose', 'No Transpose', NB, $ N, NB, ONE, Z, LDQZ, C(POS,1), $ LDC, ZERO, DWORK, NB ) CALL DLACPY( 'All', NB, N, DWORK, NB, $ C(POS,1), LDC ) END IF C C Update U. C IF ( WANTU ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, U1(1,POS), LDU1, $ Z, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ U1(1,POS), LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, U2(1,POS), LDU2, $ Z, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ U2(1,POS), LDU2 ) END IF C C Update V. C IF ( WANTV ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, V1(1,POS), LDV1, $ Q, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ V1(1,POS), LDV1 ) CALL DGEMM( 'No Transpose', 'No Transpose', $ N, NB, NB, ONE, V2(1,POS), LDV2, $ Q, LDQZ, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NB, DWORK, N, $ V2(1,POS), LDV2 ) END IF C HERE = HERE - 2 END IF END IF END IF C IF ( HERE.GT.ILST ) $ GO TO 20 C 30 CONTINUE IF ( PAIR ) $ KS = KS + 1 END IF END IF 40 CONTINUE C 50 CONTINUE C C Step 2: Compute an ordered Schur decomposition of C [ 0, -A11; B11, 0 ]. C IF ( INITW ) $ CALL DLASET( 'All', 2*M, 2*M, ZERO, ONE, W, LDW ) PWC = 1 PWD = PWC + 2*M PW = PWD + 2*M PAIR = .FALSE. NB = 1 C DO 80 K = 1, M IF ( PAIR ) THEN PAIR = .FALSE. NB = 1 ELSE IF ( K.LT.N ) THEN IF ( A(K+1,K).NE.ZERO ) THEN PAIR = .TRUE. NB = 2 END IF END IF PWCK = PWC + 2*( K - 1 ) PWDL = PWD + 2*( K - 1 ) CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, DWORK(PWCK), 2 ) CALL DLACPY( 'All', NB, M-K+1, A(K,K), LDA, DWORK(PWDL), 2 ) CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, A(K,K), LDA ) C L = K C C WHILE L >= 1 DO C 60 CONTINUE C IF ( K.EQ.L ) THEN C C Annihilate B(k,k). C NBL = NB CALL DLASET( 'All', NB+NBL, NB+NBL, ZERO, ZERO, T, $ LDQZ ) CALL DLACPY( 'Upper', NBL, NBL, B(L,L), LDB, $ T(NB+1,1), LDQZ ) IF ( NB.EQ.1 ) THEN DWORK(PWDL) = -DWORK(PWDL) ELSE CALL DSCAL( 2*NB, -ONE, DWORK(PWDL), 1 ) END IF CALL DLACPY( 'All', NB, NB, DWORK(PWDL), 2, T(1,NB+1), $ LDQZ ) ELSE C C Annihilate B(l,k). C CALL DLASET( 'All', NBL+NB, NBL+NB, ZERO, ZERO, T, $ LDQZ ) CALL DLACPY( 'All', NBL, NBL, A(L,L), LDA, T, LDQZ ) CALL DLACPY( 'All', NBL, NB, B(L,K), LDB, T(1,NBL+1), $ LDQZ ) CALL DLACPY( 'All', NB, NB, DWORK(PWCK), 2, $ T(NBL+1,NBL+1), LDQZ ) PWDL = PWD + 2*( L - 1 ) END IF C CALL DGEES( 'V', 'Not Sorted', LFDUM, NB+NBL, T, LDQZ, $ MM, WRNEW, WINEW, Q, LDQZ, DW12, 12, LDUM, $ IERR ) IF ( IERR.NE.0 ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = 3 RETURN END IF C C Reorder Schur form. C MM = 0 DO 70 I = 1, NB+NBL IF ( WRNEW(I).GT.0 ) THEN MM = MM + 1 SELNEW(I) = .TRUE. ELSE SELNEW(I) = .FALSE. END IF 70 CONTINUE IF ( MM.LT.NB ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = 4 RETURN END IF CALL DTRSEN( 'None', 'V', SELNEW, NB+NBL, T, LDQZ, Q, $ LDQZ, WRNEW, WINEW, MM, TEMP, TEMP, DW12, $ 4, IDUM, 1, IERR ) IF ( IERR.NE.0 ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = 2 RETURN END IF C C Permute Q if necessary. C IF ( K.NE.L ) THEN CALL DLACPY( 'All', NBL, NB+NBL, Q, LDQZ, Z(NB+1,1), $ LDQZ ) CALL DLACPY( 'All', NB, NB+NBL, Q(NBL+1,1), LDQZ, $ Z, LDQZ ) CALL DLACPY( 'All', NB+NBL, NB+NBL, Z, LDQZ, Q, LDQZ ) END IF C C Update "diagonal" blocks. C CALL DLACPY( 'All', NB, NB, T, LDQZ, DWORK(PWCK), 2 ) CALL DLACPY( 'All', NB, NBL, T(1,NB+1), LDQZ, $ DWORK(PWDL), 2 ) IF ( NB.EQ.1 ) THEN CALL DSCAL( NBL, -ONE, DWORK(PWDL), 2 ) ELSE CALL DSCAL( 2*NBL, -ONE, DWORK(PWDL), 1 ) END IF CALL DLACPY( 'All', NBL, NBL, T(NB+1,NB+1), LDQZ, $ A(L,L), LDA ) C C Update block columns of A and B. C LEN = L - 1 IF ( LEN.GT.0 ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, $ NB, ONE, B(1,K), LDB, Q, LDQZ, ZERO, $ DWORK(PW), M ) CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, $ NB, ONE, B(1,K), LDB, Q(1,NB+1), LDQZ, $ ZERO, DWORK(PW+2*M), M ) CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, $ NBL, ONE, A(1,L), LDA, Q(NB+1,1), LDQZ, $ ONE, DWORK(PW), M ) CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, B(1,K), $ LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, $ NBL, ONE, A(1,L), LDA, Q(NB+1,NB+1), $ LDQZ, ONE, DWORK(PW+2*M), M ) CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, $ A(1,L), LDA ) END IF C C Update block column of A. C LEN = M - L - NBL + 1 IF ( LEN.GT.0 ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB, $ ONE, Q, LDQZ, DWORK(PWDL+2*NBL), 2, ZERO, $ DWORK(PW), 2 ) CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB, $ -ONE, Q(1,NB+1), LDQZ, DWORK(PWDL+2*NBL), $ 2, ZERO, DWORK(PW+2*M), 2 ) CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL, $ -ONE, Q(NB+1,1), LDQZ, A(L,L+NBL), LDA, $ ONE, DWORK(PW), 2 ) CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2, $ DWORK(PWDL+2*NBL), 2 ) CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, $ NBL, ONE, Q(NB+1,NB+1), LDQZ, A(L,L+NBL), $ LDA, ONE, DWORK(PW+2*M), 2 ) CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2, $ A(L,L+NBL), LDA ) END IF C C Update block row of B. C LEN = M - K - NB + 1 IF ( LEN.GT.0 ) THEN CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB, $ ONE, Q, LDQZ, DWORK(PWCK+2*NB), 2, ZERO, $ DWORK(PW), 2 ) CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB, $ ONE, Q(1,NB+1), LDQZ, DWORK(PWCK+2*NB), 2, $ ZERO, DWORK(PW+2*M), 2 ) CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL, $ ONE, Q(NB+1,1), LDQZ, B(L,K+NB), LDB, ONE, $ DWORK(PW), 2 ) CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2, $ DWORK(PWCK+2*NB), 2 ) CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, $ NBL, ONE, Q(NB+1,NB+1), LDQZ, B(L,K+NB), $ LDB, ONE, DWORK(PW+2*M), 2 ) CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2, $ B(L,K+NB), LDB ) END IF C C Update W. C IF ( WANTW ) THEN IF ( INITW ) THEN POS = L LEN = K + NB - L ELSE POS = 1 LEN = M END IF CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, $ NB, ONE, W(POS,K), LDW, Q, LDQZ, ZERO, $ DWORK(PW), M ) CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, $ NB, ONE, W(POS,K), LDW, Q(1,NB+1), LDQZ, $ ZERO, DWORK(PW+2*M), M ) CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, $ NBL, ONE, W(POS,M+L), LDW, Q(NB+1,1), $ LDQZ, ONE, DWORK(PW), M ) CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(POS,K), $ LDW ) CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, $ NBL, ONE, W(POS,M+L), LDW, Q(NB+1,NB+1), $ LDQZ, ONE, DWORK(PW+2*M), M ) CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, $ W(POS,M+L), LDW ) C CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, $ NB, ONE, W(M+POS,K), LDW, Q, LDQZ, ZERO, $ DWORK(PW), M ) CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, $ NB, ONE, W(M+POS,K), LDW, Q(1,NB+1), LDQZ, $ ZERO, DWORK(PW+2*M), M ) CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, $ NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,1), $ LDQZ, ONE, DWORK(PW), M ) CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(M+POS,K), $ LDW ) CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, $ NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,NB+1), $ LDQZ, ONE, DWORK(PW+2*M), M ) CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, $ W(M+POS,M+L), LDW ) END IF C L = L - 1 NBL = 1 IF ( L.GT.1 ) THEN IF ( A(L,L-1).NE.ZERO ) THEN NBL = 2 L = L - 1 END IF END IF C C END WHILE L >= 1 DO C IF ( L.GE.1 ) $ GO TO 60 C C Copy recomputed eigenvalues. C CALL DCOPY( NB, WRNEW, 1, WR(K), 1 ) CALL DCOPY( NB, WINEW, 1, WI(K), 1 ) END IF 80 CONTINUE DWORK(1) = DBLE( WRKMIN ) RETURN C *** Last line of MB03ZA *** END C LOGICAL FUNCTION LFDUM( X, Y ) C C Void logical function for DGEES. C DOUBLE PRECISION X, Y LFDUM = .FALSE. RETURN C *** Last line of LFDUM *** END control-4.1.2/src/slicot/src/PaxHeaders/MB3OYZ.f0000644000000000000000000000013215012430707016260 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.869132739 control-4.1.2/src/slicot/src/MB3OYZ.f0000644000175000017500000003161615012430707017463 0ustar00lilgelilge00000000000000 SUBROUTINE MB3OYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, $ TAU, DWORK, ZWORK, INFO ) C C PURPOSE C C To compute a rank-revealing QR factorization of a complex 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 MB3OYZ 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) COMPLEX*16 array, dimension ( 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 unitary 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) COMPLEX*16 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 ( 2*N ) C C ZWORK COMPLEX*16 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 complex scalar, and v is a complex 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 Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. C C KEYWORDS C C Eigenvalue problem, matrix operations, unitary transformation, C singular values. C C ****************************************************************** C C .. Parameters .. INTEGER IMAX, IMIN PARAMETER ( IMAX = 1, IMIN = 2 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. INTEGER INFO, LDA, M, N, RANK DOUBLE PRECISION RCOND, SVLMAX C .. Array Arguments .. INTEGER JPVT( * ) COMPLEX*16 A( LDA, * ), TAU( * ), ZWORK( * ) DOUBLE PRECISION DWORK( * ), SVAL( 3 ) C .. C .. Local Scalars .. INTEGER I, ISMAX, ISMIN, ITEMP, J, MN, PVT COMPLEX*16 AII, C1, C2, S1, S2 DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2, TOLZ C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL DLAMCH, DZNRM2, IDAMAX C .. External Subroutines .. EXTERNAL XERBLA, ZLAIC1, ZLARF, ZLARFG, ZSCAL, ZSWAP C .. Intrinsic Functions .. INTRINSIC ABS, DCONJG, 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( 'MB3OYZ', -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 TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) 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. C DO 10 I = 1, N DWORK( I ) = DZNRM2( 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 ZSWAP( 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 such that H(i)'*[A(i,i);*] = [*;0]. C IF( I.LT.M ) THEN AII = A( I, I ) CALL ZLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) ELSE TAU( M ) = CZERO 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 = CONE C2 = CONE ELSE C C One step of incremental condition estimation. C CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN, A( 1, I ), $ A( I, I ), SMINPR, S1, C1 ) CALL ZLAIC1( IMAX, RANK, ZWORK( 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 ) = CONE CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, $ ZWORK( 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 = ABS( A( I, J ) ) / DWORK( J ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO) TEMP2 = TEMP*( DWORK( J ) / DWORK( N+J ) )**2 IF( TEMP2.LE.TOLZ ) THEN IF( M-I.GT.0 ) THEN DWORK( J ) = DZNRM2( 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 ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 ) ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 ) 40 CONTINUE C ZWORK( ISMIN+RANK ) = C1 ZWORK( 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 ZSCAL( 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 MB3OYZ *** END control-4.1.2/src/slicot/src/PaxHeaders/AB04MD.f0000644000000000000000000000013215012430707016144 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB04MD.f0000644000175000017500000002463315012430707017350 0ustar00lilgelilge00000000000000 SUBROUTINE AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, C, $ LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To perform a transformation on the parameters (A,B,C,D) of a C system, which is equivalent to a bilinear transformation of the C corresponding transfer function matrix. C C ARGUMENTS C C Mode Parameters C C TYPE CHARACTER*1 C Indicates the type of the original system and the C transformation to be performed as follows: C = 'D': discrete-time -> continuous-time; C = 'C': continuous-time -> discrete-time. C C Input/Output Parameters C C N (input) INTEGER C The order of the state 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 ALPHA, (input) DOUBLE PRECISION C BETA Parameters specifying the bilinear transformation. C Recommended values for stable systems: ALPHA = 1, C BETA = 1. ALPHA <> 0, BETA <> 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 matrix A of the original system. C On exit, the leading N-by-N part of this array contains C _ C the state matrix A of the transformed system. 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 matrix B of the original system. C On exit, the leading N-by-M part of this array contains C _ C the input matrix B of the transformed system. 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 output matrix C of the original system. C On exit, the leading P-by-N part of this array contains C _ C the output matrix C of the transformed system. 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 D for the original system. C On exit, the leading P-by-M part of this array contains C _ C the input/output matrix D of the transformed system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). 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) returns the optimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,N). C For optimum performance LDWORK >= MAX(1,N*NB), where NB C is the optimal blocksize. 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 (ALPHA*I + A) is exactly singular; C = 2: if the matrix (BETA*I - A) is exactly singular. C C METHOD C C The parameters of the discrete-time system are transformed into C the parameters of the continuous-time system (TYPE = 'D'), or C vice-versa (TYPE = 'C') by the transformation: C C 1. Discrete -> continuous C _ -1 C A = beta*(alpha*I + A) * (A - alpha*I) C _ -1 C B = sqrt(2*alpha*beta) * (alpha*I + A) * B C _ -1 C C = sqrt(2*alpha*beta) * C * (alpha*I + A) C _ -1 C D = D - C * (alpha*I + A) * B C C which is equivalent to the bilinear transformation C C z - alpha C z -> s = beta --------- . C z + alpha C C of one transfer matrix onto the other. C C 2. Continuous -> discrete C _ -1 C A = alpha*(beta*I - A) * (beta*I + A) C _ -1 C B = sqrt(2*alpha*beta) * (beta*I - A) * B C _ -1 C C = sqrt(2*alpha*beta) * C * (beta*I - A) C _ -1 C D = D + C * (beta*I - A) * B C C which is equivalent to the bilinear transformation C C beta + s C s -> z = alpha -------- . C beta - s C C of one transfer matrix onto the other. C C REFERENCES C C [1] Al-Saggaf, U.M. and Franklin, G.F. C Model reduction via balanced realizations: a extension and C frequency weighting techniques. C IEEE Trans. Autom. Contr., AC-33, pp. 687-692, 1988. C C NUMERICAL ASPECTS C 3 C The time taken is approximately proportional to N . C The accuracy depends mainly on the condition number of the matrix C to be inverted. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and C A. Varga, German Aerospace Research Establishment, C Oberpfaffenhofen, Germany, Nov. 1996. C Supersedes Release 2.0 routine AB04AD by W. van der Linden, and C A.J. Geurts, Technische Hogeschool Eindhoven, Holland. C C REVISIONS C C - C C KEYWORDS C C Bilinear transformation, continuous-time system, discrete-time C system, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO=0.0D0, ONE=1.0D0, TWO=2.0D0 ) C .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P DOUBLE PRECISION ALPHA, BETA C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) C .. Local Scalars .. LOGICAL LTYPE INTEGER I, IP DOUBLE PRECISION AB2, PALPHA, PBETA, SQRAB2 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEMM, DGETRF, DGETRS, DGETRI, DLASCL, DSCAL, $ DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT C .. Executable Statements .. C INFO = 0 LTYPE = LSAME( TYPE, 'D' ) C C Test the input scalar arguments. C IF( .NOT.LTYPE .AND. .NOT.LSAME( TYPE, 'C' ) ) 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( ALPHA.EQ.ZERO ) THEN INFO = -5 ELSE IF( BETA.EQ.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, P ) ) THEN INFO = -12 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -14 ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN INFO = -17 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB04MD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, M, P ).EQ.0 ) $ RETURN 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 IF (LTYPE) THEN C C Discrete-time to continuous-time with (ALPHA, BETA). C PALPHA = ALPHA PBETA = BETA ELSE C C Continuous-time to discrete-time with (ALPHA, BETA) is C equivalent with discrete-time to continuous-time with C (-BETA, -ALPHA), if B and C change the sign. C PALPHA = -BETA PBETA = -ALPHA END IF C AB2 = PALPHA*PBETA*TWO SQRAB2 = SIGN( SQRT( ABS( AB2 ) ), PALPHA ) C -1 C Compute (alpha*I + A) . C DO 10 I = 1, N A(I,I) = A(I,I) + PALPHA 10 CONTINUE C CALL DGETRF( N, N, A, LDA, IWORK, INFO ) C IF (INFO.NE.0) THEN C C Error return. C IF (LTYPE) THEN INFO = 1 ELSE INFO = 2 END IF RETURN END IF C -1 C Compute (alpha*I+A) *B. C CALL DGETRS( 'No transpose', N, M, A, LDA, IWORK, B, LDB, INFO ) C -1 C Compute D - C*(alpha*I+A) *B. C CALL DGEMM( 'No transpose', 'No transpose', P, M, N, -ONE, C, $ LDC, B, LDB, ONE, D, LDD ) C C Scale B by sqrt(2*alpha*beta). C CALL DLASCL( 'General', 0, 0, ONE, SQRAB2, N, M, B, LDB, INFO ) C -1 C Compute sqrt(2*alpha*beta)*C*(alpha*I + A) . C CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', P, N, $ SQRAB2, A, LDA, C, LDC ) C CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', P, N, ONE, $ A, LDA, C, LDC ) C C Apply column interchanges to the solution matrix. C DO 20 I = N-1, 1, -1 IP = IWORK(I) IF ( IP.NE.I ) $ CALL DSWAP( P, C(1,I), 1, C(1,IP), 1 ) 20 CONTINUE C -1 C Compute beta*(alpha*I + A) *(A - alpha*I) as C -1 C beta*I - 2*alpha*beta*(alpha*I + A) . C C Workspace: need N; prefer N*NB. C CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) C DO 30 I = 1, N CALL DSCAL(N, -AB2, A(1,I), 1) A(I,I) = A(I,I) + PBETA 30 CONTINUE C RETURN C *** Last line of AB04MD *** END control-4.1.2/src/slicot/src/PaxHeaders/AG08BZ.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AG08BZ.f0000644000175000017500000005267115012430707017377 0ustar00lilgelilge00000000000000 SUBROUTINE AG08BZ( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB, $ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, $ NINFE, NKROL, INFZ, KRONR, INFE, KRONL, $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) C C PURPOSE C C To extract from the system pencil C C ( A-lambda*E B ) C S(lambda) = ( ) C ( C D ) C C a regular pencil Af-lambda*Ef which has the finite Smith zeros of C S(lambda) as generalized eigenvalues. The routine also computes C the orders of the infinite Smith zeros and determines the singular C and infinite Kronecker structure of system pencil, i.e., the right C and left Kronecker indices, and the multiplicities of infinite C eigenvalues. C C ARGUMENTS C C Mode Parameters C C EQUIL CHARACTER*1 C Specifies whether the user wishes to balance the system C matrix as follows: C = 'S': Perform balancing (scaling); C = 'N': Do not perform balancing. C C Input/Output Parameters C C L (input) INTEGER C The number of rows of matrices A, B, and E. L >= 0. C C N (input) INTEGER C The number of columns of matrices A, E, and C. N >= 0. C C M (input) INTEGER C The number of columns of matrix B. M >= 0. C C P (input) INTEGER C The number of rows of matrix C. P >= 0. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the state dynamics matrix A of the system. C On exit, the leading NFZ-by-NFZ part of this array C contains the matrix Af of the reduced pencil. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,L). C C E (input/output) COMPLEX*16 array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the descriptor matrix E of the system. C On exit, the leading NFZ-by-NFZ part of this array C contains the matrix Ef of the reduced pencil. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,L). C C B (input/output) COMPLEX*16 array, dimension (LDB,M) C On entry, the leading L-by-M part of this array must C contain the input/state matrix B of the system. C On exit, this matrix does not contain useful information. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,L) if M > 0; C LDB >= 1 if M = 0. C C C (input/output) COMPLEX*16 array, dimension (LDC,N) C On entry, the leading P-by-N part of this array must C contain the state/output matrix C of the system. C On exit, this matrix does not contain useful information. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C D (input) COMPLEX*16 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 NFZ (output) INTEGER C The number of finite zeros. C C NRANK (output) INTEGER C The normal rank of the system pencil. C C NIZ (output) INTEGER C The number of infinite zeros. C C DINFZ (output) INTEGER C The maximal multiplicity of infinite Smith zeros. C C NKROR (output) INTEGER C The number of right Kronecker indices. C C NINFE (output) INTEGER C The number of elementary infinite blocks. C C NKROL (output) INTEGER C The number of left Kronecker indices. C C INFZ (output) INTEGER array, dimension (N+1) 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 of C degree i in the Smith form, where i = 1,2,...,DINFZ. C C KRONR (output) INTEGER array, dimension (N+M+1) C The leading NKROR elements of this array contain the C right Kronecker (column) indices. C C INFE (output) INTEGER array, dimension (1+MIN(L+P,N+M)) C The leading NINFE elements of INFE contain the C multiplicities of infinite eigenvalues. C C KRONL (output) INTEGER array, dimension (L+P+1) C The leading NKROL elements of this array contain the C left Kronecker (row) 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 If the user sets TOL <= 0, then default tolerances are C used instead, as follows: TOLDEF = L*N*EPS in TG01FZ C (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS C in the rest, where EPS is the machine precision C (see LAPACK Library routine DLAMCH). TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (N+max(1,M)) C On output, IWORK(1) contains the normal rank of the C transfer function matrix. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C LDWORK >= max(4*(L+N), 2*max(L+P,M+N))), if EQUIL = 'S', C LDWORK >= 2*max(L+P,M+N)), if EQUIL = 'N'. C C ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal value C of LZWORK. C C LZWORK INTEGER C The length of the array ZWORK. C LZWORK >= max( max(L+P,M+N)*(M+N) + C max(min(L+P,M+N) + max(min(L,N),3*(M+N)-1), C 3*(L+P), 1)) C For optimum performance LZWORK should be larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK 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 descriptor C system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which C has the finite zeros of the system as generalized eigenvalues. C The procedure has the following main computational steps: C C (a) construct the (L+P)-by-(N+M) system pencil C C S(lambda) = ( B A )-lambda*( 0 E ); C ( D C ) ( 0 0 ) C C (b) reduce S(lambda) to S1(lambda) with the same finite C zeros and right Kronecker structure but with E C upper triangular and nonsingular; C C (c) reduce S1(lambda) to S2(lambda) with the same finite C zeros and right Kronecker structure but with D of C full row rank; C C (d) reduce S2(lambda) to S3(lambda) with the same finite zeros C and with D square invertible; C C (e) perform a unitary transformation on the columns of C C S3(lambda) = (A-lambda*E B) in order to reduce it to C ( C D) C C (Af-lambda*Ef X), with Y and Ef square invertible; C ( 0 Y) C C (f) compute the right and left Kronecker indices of the system C matrix, which together with the multiplicities of the C finite and infinite eigenvalues constitute the C complete set of structural invariants under strict C equivalence transformations of a linear system. C C REFERENCES C C [1] P. Misra, P. Van Dooren and A. Varga. C Computation of structural invariants of generalized C state-space systems. C Automatica, 30, pp. 1921-1936, 1994. C C NUMERICAL ASPECTS C C The algorithm is backward stable (see [1]). C C FURTHER COMMENTS C C In order to compute the finite Smith zeros of the system C explicitly, a call to this routine may be followed by a C call to the LAPACK Library routines ZGEGV or ZGGEV. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C May 1999. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, C Apr. 2009, Apr. 2011, Feb. 2017. C C KEYWORDS C C Generalized eigenvalue problem, Kronecker indices, multivariable C system, unitary transformation, structural invariant. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. CHARACTER EQUIL INTEGER DINFZ, INFO, L, LDA, LDB, LDC, LDD, LDE, LZWORK, $ M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*) DOUBLE PRECISION DWORK(*) COMPLEX*16 A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ E(LDE,*), ZWORK(*) C .. Local Scalars .. LOGICAL LEQUIL, LQUERY INTEGER I, I0, I1, II, IPD, ITAU, J, JWORK, KABCD, $ LABCD2, LDABCD, LZW, MM, MU, N2, NN, NSINFE, NU, $ NUMU, PP, WRKOPT DOUBLE PRECISION SVLMAX, TOLER C .. Local Arrays .. COMPLEX*16 DUM(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL DLAMCH, LSAME, ZLANGE C .. External Subroutines .. EXTERNAL AG8BYZ, MA02BZ, MA02CZ, TB01XZ, TG01AZ, TG01FZ, $ XERBLA, ZLACPY, ZLASET, ZTZRZF, ZUNMRZ C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C .. Executable Statements .. C INFO = 0 LDABCD = MAX( L+P, N+M ) LABCD2 = LDABCD*( N+M ) LEQUIL = LSAME( EQUIL, 'S' ) LQUERY = ( LZWORK.EQ.-1 ) C C Test the input scalar arguments. C IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN INFO = -1 ELSE IF( L.LT.0 ) 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, L ) ) THEN INFO = -7 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -9 ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( TOL.GE.ONE ) THEN INFO = -27 ELSE I0 = MIN( L+P, M+N ) I1 = MIN( L, N ) II = MIN( M, P ) LZW = MAX( 1, LABCD2 + MAX( I0 + MAX( I1, 3*( M+N ) - 1 ), $ 3*( L+P ) ) ) IF( LQUERY ) THEN I = MAX( 1, LDABCD+I1 ) J = MAX( 1, LDABCD ) CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, $ LDB, C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, $ IWORK, DWORK, ZWORK, -1, INFO ) WRKOPT = MAX( LZW, INT( ZWORK(1) ) ) SVLMAX = ZERO CALL AG8BYZ( .TRUE., I1, M+N, P+L, SVLMAX, ZWORK, I, E, LDE, $ NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, TOL, $ IWORK, DWORK, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) ) CALL AG8BYZ( .FALSE., I1, II, M+N, SVLMAX, ZWORK, I, E, LDE, $ NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, TOL, $ IWORK, DWORK, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) ) CALL ZTZRZF( II, I1+II, ZWORK, J, ZWORK, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LABCD2 + II + INT( ZWORK(1) ) ) CALL ZUNMRZ( 'Right', 'Conjugate transpose', I1, I1+II, II, $ I1, ZWORK, J, ZWORK, ZWORK, J, ZWORK, -1, $ INFO ) WRKOPT = MAX( WRKOPT, LABCD2 + II + INT( ZWORK(1) ) ) ELSE IF( LZWORK.LT.LZW ) THEN INFO = -31 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AG08BZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN ZWORK(1) = WRKOPT RETURN END IF C NIZ = 0 NKROL = 0 NKROR = 0 C C Quick return if possible. C IF( MAX( L, N, M, P ).EQ.0 ) THEN NFZ = 0 DINFZ = 0 NINFE = 0 NRANK = 0 IWORK(1) = 0 ZWORK(1) = ONE RETURN END IF C C (Note: Comments in the code beginning "CWorkspace:", "RWorkspace:" C and "IWorkspace:" describe the minimal amount of complex, real and C integer workspace, respectively, needed at that point in the code, C as well as the preferred amount for good performance.) C WRKOPT = 1 KABCD = 1 JWORK = KABCD + LABCD2 C C If required, balance the system pencil. C RWorkspace: need 4*(L+N). C IF( LEQUIL ) THEN CALL TG01AZ( 'A', L, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, $ C, LDC, DWORK, DWORK(L+1), DWORK(L+N+1), INFO ) END IF C C Reduce the system matrix to QR form, C C ( A11-lambda*E11 A12 B1 ) C ( A21 A22 B2 ) , C ( C1 C2 D ) C C with E11 invertible and upper triangular. C IWorkspace: need N. C RWorkspace: need 2*N. C CWorkspace: need max( 1, N+P, min(L,N)+max(3*N-1,M,L) ); C prefer larger. C CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, LDB, $ C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, IWORK, DWORK, $ ZWORK, LZWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) C C Construct the system pencil C C MM NN C ( B1 A12 A11-lambda*E11 ) NN C S1(lambda) = ( B2 A22 A21 ) L-NN C ( D C2 C1 ) P C C of dimension (L+P)-by-(M+N). C CWorkspace: need LABCD2 = max( L+P, N+M )*( N+M ). C N2 = N - NN MM = M + N2 PP = P + ( L - NN ) CALL ZLACPY( 'Full', L, M, B, LDB, ZWORK(KABCD), LDABCD ) CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(KABCD+L), LDABCD ) CALL ZLACPY( 'Full', L, N2, A(1,NN+1), LDA, $ ZWORK(KABCD+LDABCD*M), LDABCD ) CALL ZLACPY( 'Full', P, N2, C(1,NN+1), LDC, $ ZWORK(KABCD+LDABCD*M+L), LDABCD ) CALL ZLACPY( 'Full', L, NN, A, LDA, $ ZWORK(KABCD+LDABCD*MM), LDABCD ) CALL ZLACPY( 'Full', P, NN, C, LDC, $ ZWORK(KABCD+LDABCD*MM+L), LDABCD ) C C If required, set tolerance. C TOLER = TOL IF( TOLER.LE.ZERO ) THEN TOLER = DBLE( ( L + P )*( M + N ) ) * DLAMCH( 'Precision' ) END IF SVLMAX = ZLANGE( 'Frobenius', NN+PP, NN+MM, ZWORK(KABCD), LDABCD, $ DWORK ) C C Extract the reduced pencil S2(lambda) C C ( Bc Ac-lambda*Ec ) C ( Dc Cc ) C C having the same finite Smith zeros as the system pencil C S(lambda) but with Dc, a MU-by-MM full row rank C left upper trapezoidal matrix, and Ec, an NU-by-NU C upper triangular nonsingular matrix. C C IWorkspace: need MM, MM <= M+N; C RWorkspace: need 2*max(MM,PP); PP <= P+L; C CWorkspace: need max( min(P+L,M+N)+max(min(L,N),3*(M+N)-1), C 3*(P+L), 1 ) + LABCD2; C prefer larger. C CALL AG8BYZ( .TRUE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD, $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, $ TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1, $ INFO ) C WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) C C Set the number of simple (nondynamic) infinite eigenvalues C and the normal rank of the system pencil. C NSINFE = MU NRANK = NN + MU C C Pertranspose the system. C CALL TB01XZ( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ), $ ZWORK(KABCD+LDABCD*MM), LDABCD, $ ZWORK(KABCD), LDABCD, $ ZWORK(KABCD+LDABCD*MM+NU), LDABCD, $ ZWORK(KABCD+NU), LDABCD, INFO ) CALL MA02BZ( 'Right', NU+MM, MM, ZWORK(KABCD), LDABCD ) CALL MA02BZ( 'Left', MM, NU+MM, ZWORK(KABCD+NU), LDABCD ) CALL MA02CZ( NU, 0, MAX( 0, NU-1 ), E, LDE ) C IF( MU.NE.MM ) THEN NN = NU PP = MM MM = MU KABCD = KABCD + ( PP - MM )*LDABCD C C Extract the reduced pencil S3(lambda), C C ( Br Ar-lambda*Er ) , C ( Dr Cr ) C C having the same finite Smith zeros as the pencil S(lambda), C but with Dr, an MU-by-MU invertible upper triangular matrix, C and Er, an NU-by-NU upper triangular nonsingular matrix. C C IWorkspace: need 0; C RWorkspace: need 2*(M+N); C CWorkspace: need max( 1, 3*(M+N) ) + LABCD2. C prefer larger. C CALL AG8BYZ( .FALSE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD, $ E, LDE, NU, MU, I0, I1, NKROR, IWORK, KRONR, $ TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1, $ INFO ) C WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) END IF C IF( NU.NE.0 ) THEN C C Perform a unitary transformation on the columns of C ( Br Ar-lambda*Er ) C ( Dr Cr ) C in order to reduce it to C ( * Af-lambda*Ef ) C ( Y 0 ) C with Y and Ef square invertible. C C Compute Af by reducing ( Br Ar ) to ( * Af ) . C ( Dr Cr ) ( Y 0 ) C NUMU = NU + MU IPD = KABCD + NU ITAU = JWORK JWORK = ITAU + MU C C CWorkspace: need LABCD2 + 2*min(M,P); C prefer LABCD2 + min(M,P) + min(M,P)*NB. C CALL ZTZRZF( MU, NUMU, ZWORK(IPD), LDABCD, ZWORK(ITAU), $ ZWORK(JWORK), LZWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) C C CWorkspace: need LABCD2 + min(M,P) + min(L,N); C prefer LABCD2 + min(M,P) + min(L,N)*NB. C CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU, $ ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD), $ LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) C C Save Af. C CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, A, $ LDA ) C C Compute Ef by applying the saved transformations from previous C reduction to ( 0 Er ) . C CALL ZLASET( 'Full', NU, MU, CZERO, CZERO, ZWORK(KABCD), $ LDABCD ) CALL ZLACPY( 'Full', NU, NU, E, LDE, ZWORK(KABCD+LDABCD*MU), $ LDABCD ) C CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU, $ ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD), $ LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO ) C C Save Ef. C CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, E, $ LDE ) END IF C NFZ = NU C C Set right Kronecker indices (column indices). C DO 10 I = 1, NKROR IWORK(I) = KRONR(I) 10 CONTINUE C J = 0 DO 30 I = 1, NKROR DO 20 II = J + 1, J + IWORK(I) KRONR(II) = I - 1 20 CONTINUE J = J + IWORK(I) 30 CONTINUE C NKROR = J C C Set left Kronecker indices (row indices). C DO 40 I = 1, NKROL IWORK(I) = KRONL(I) 40 CONTINUE C J = 0 DO 60 I = 1, NKROL DO 50 II = J + 1, J + IWORK(I) KRONL(II) = I - 1 50 CONTINUE J = J + IWORK(I) 60 CONTINUE C NKROL = J C C Determine the number of simple infinite blocks C as the difference between the number of infinite blocks C of order greater than one and the order of Dr. C NINFE = 0 DO 70 I = 1, DINFZ NINFE = NINFE + INFZ(I) 70 CONTINUE NINFE = NSINFE - NINFE DO 80 I = 1, NINFE INFE(I) = 1 80 CONTINUE C C Set the structure of infinite eigenvalues. C DO 100 I = 1, DINFZ DO 90 II = NINFE + 1, NINFE + INFZ(I) INFE(II) = I + 1 90 CONTINUE NINFE = NINFE + INFZ(I) 100 CONTINUE C IWORK(1) = NSINFE ZWORK(1) = WRKOPT RETURN C *** Last line of AG08BZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04ED.f0000644000000000000000000000013215012430707016150 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04ED.f0000644000175000017500000012537515012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE MB04ED( JOB, COMPQ, COMPU, N, Z, LDZ, B, LDB, FG, LDFG, $ Q, LDQ, U1, LDU1, U2, LDU2, ALPHAR, ALPHAI, $ BETA, IWORK, LIWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the eigenvalues of a real N-by-N skew-Hamiltonian/ C skew-Hamiltonian pencil aS - bT with C C ( B F ) ( 0 I ) C S = J Z' J' Z and T = ( ), where J = ( ). (1) C ( G B' ) ( -I 0 ) C C Optionally, if JOB = 'T', the pencil aS - bT will be transformed C to the structured Schur form: an orthogonal transformation matrix C Q and an orthogonal symplectic transformation matrix U are C computed, such that C C ( Z11 Z12 ) C U' Z Q = ( ) = Zout, and C ( 0 Z22 ) C (2) C ( Bout Fout ) C J Q' J' T Q = ( ), C ( 0 Bout' ) C C where Z11 and Z22' are upper triangular and Bout is upper quasi- C triangular. The notation M' denotes the transpose of the matrix M. C Optionally, if COMPQ = 'I', the orthogonal transformation matrix Q C will be computed. C Optionally, if COMPU = 'I' or COMPU = 'U', the orthogonal C symplectic transformation matrix C C ( U1 U2 ) C U = ( ) C ( -U2 U1 ) C C will be computed. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; Z and T will not C necessarily be put into the forms in (2); C = 'T': put Z and T into the forms in (2), and return the C eigenvalues in ALPHAR, ALPHAI and BETA. C C COMPQ CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q as follows: C = 'N': Q is not computed; C = 'I': the array Q is initialized internally to the unit C matrix, and the orthogonal matrix Q is returned. C C COMPU CHARACTER*1 C Specifies whether to compute the orthogonal symplectic C transformation matrix U as follows: C = 'N': U is not computed; C = 'I': the array U is initialized internally to the unit C matrix, and the orthogonal matrix U is returned; C = 'U': the arrays U1 and U2 contain the corresponding C submatrices of an orthogonal symplectic matrix U0 C on entry, and the updated submatrices U1 and U2 C of the matrix product U0*U are returned, where U C is the product of the orthogonal symplectic C transformations that are applied to the pencil C aS - bT to reduce Z and T to the forms in (2), for C COMPU = 'I'. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bT. N >= 0, even. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) C On entry, the leading N-by-N part of this array must C contain the matrix Z. C On exit, if JOB = 'T', the leading N-by-N part of this C array contains the matrix Zout; otherwise, it contains the C matrix Z just before the application of the periodic QZ C algorithm. The entries in the rows N/2+1 to N and the C first N/2 columns are unchanged. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1, N). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix Bout; otherwise, it contains the C matrix B just before the application of the periodic QZ C algorithm. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C FG (input/output) DOUBLE PRECISION array, dimension C (LDFG, N/2+1) C On entry, the leading N/2-by-N/2 strictly lower triangular C part of this array must contain the strictly lower C triangular part of the skew-symmetric matrix G, and the C N/2-by-N/2 strictly upper triangular part of the submatrix C in the columns 2 to N/2+1 of this array must contain the C strictly upper triangular part of the skew-symmetric C matrix F. C On exit, if JOB = 'T', the leading N/2-by-N/2 strictly C upper triangular part of the submatrix in the columns 2 to C N/2+1 of this array contains the strictly upper triangular C part of the skew-symmetric matrix Fout. C If JOB = 'E', the leading N/2-by-N/2 strictly upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array contains the strictly upper triangular part C of the skew-symmetric matrix F just before the application C of the QZ algorithm. C The entries on the diagonal and the first superdiagonal of C this array are not referenced, but are assumed to be zero. C Moreover, the diagonal and the first subdiagonal of this C array on exit coincide to the corresponding diagonals of C this array on entry. C C LDFG INTEGER C The leading dimension of the array FG. C LDFG >= MAX(1, N/2). C C Q (output) DOUBLE PRECISION array, dimension (LDQ, N) C On exit, if COMPQ = 'I', the leading N-by-N part of this C array contains the orthogonal transformation matrix Q. C On exit, if COMPQ = 'N', the leading N-by-N part of this C array contains the orthogonal matrix Q1, such that C C ( Z11 Z12 ) C Z*Q1 = ( ), C ( 0 Z22 ) C C where Z11 and Z22' are upper triangular (the first step C of the algorithm). C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= MAX(1, N). C C U1 (input/output) DOUBLE PRECISION array, dimension C (LDU1, N/2) C On entry, if COMPU = 'U', then the leading N/2-by-N/2 part C of this array must contain the upper left block of a C given matrix U0, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper left block U1 of C the product of the input matrix U0 and the transformation C matrix U used to transform the matrices Z and T. C On exit, if COMPU = 'I', then the leading N/2-by-N/2 part C of this array contains the upper left block U1 of the C orthogonal symplectic transformation matrix U. C If COMPU = 'N' this array is not referenced. C C LDU1 INTEGER C The leading dimension of the array U1. C LDU1 >= 1, if COMPU = 'N'; C LDU1 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'. C C U2 (input/output) DOUBLE PRECISION array, dimension C (LDU2, N/2) C On entry, if COMPU = 'U', then the leading N/2-by-N/2 part C of this array must contain the upper right block of a C given matrix U0, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper right block U2 of C the product of the input matrix U0 and the transformation C matrix U used to transform the matrices Z and T. C On exit, if COMPU = 'I', then the leading N/2-by-N/2 part C of this array contains the upper right block U2 of the C orthogonal symplectic transformation matrix U. C If COMPU = 'N' this array is not referenced. C C LDU2 INTEGER C The leading dimension of the array U2. C LDU2 >= 1, if COMPU = 'N'; C LDU2 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bT. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bT. C If ALPHAI(j) is zero, then the j-th eigenvalue is real; if C positive, then the j-th and (j+1)-st eigenvalues are a C complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta that define the eigenvalues of the pencil C aS - bT. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bT, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C Due to the skew-Hamiltonian/skew-Hamiltonian structure of C the pencil, every eigenvalue occurs twice and thus it has C only to be saved once in ALPHAR, ALPHAI and BETA. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = 3, IWORK(1) contains the number of C (pairs of) possibly inaccurate eigenvalues, q <= N/2, and C IWORK(2), ..., IWORK(q+1) indicate their indices. C Specifically, a positive value is an index of a real or C purely imaginary eigenvalue, corresponding to a 1-by-1 C block, while the absolute value of a negative entry in C IWORK is an index to the first eigenvalue in a pair of C consecutively stored eigenvalues, corresponding to a C 2-by-2 block. A 2-by-2 block may have two complex, two C real, two purely imaginary, or one real and one purely C imaginary eigenvalue. C For i = q+2, ..., 2*q+1, IWORK(i) contains a pointer to C the starting location in DWORK of the i-th triplet of C 1-by-1 blocks, if IWORK(i-q) > 0, or 2-by-2 blocks, C if IWORK(i-q) < 0, defining unreliable eigenvalues. C IWORK(2*q+2) contains the number of the 1-by-1 blocks, and C IWORK(2*q+3) contains the number of the 2-by-2 blocks, C corresponding to unreliable eigenvalues. IWORK(2*q+4) C contains the total number t of the 2-by-2 blocks. C If INFO = 0, then q = 0, therefore IWORK(1) = 0. C C LIWORK INTEGER C The dimension of the array IWORK. LIWORK >= N+9. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or INFO = 3, DWORK(1) returns the C optimal LDWORK, and DWORK(2), ..., DWORK(4) contain the C Frobenius norms of the factors of the formal matrix C product used by the algorithm. In addition, DWORK(5), ..., C DWORK(4+3*s) contain the s triplet values corresponding C to the 1-by-1 blocks. Their eigenvalues are real or purely C imaginary. Such an eigenvalue is obtained as a1/a2/a3, C where a1, ..., a3 are the corresponding triplet values. C Moreover, DWORK(5+3*s), ..., DWORK(4+3*s+12*t) contain the C t groups of triplet 2-by-2 matrices corresponding to the C 2-by-2 blocks. Their eigenvalue pairs are either complex, C or placed on the real and imaginary axes. Such an C eigenvalue pair is the spectrum of the matrix product C A1*inv(A2)*inv(A3), where A1, ..., A3 define the C corresponding 2-by-2 matrix triplet. C On exit, if INFO = -23, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C If JOB = 'E' and COMPQ = 'N' and COMPU = 'N', C LDWORK >= 3/4*N**2+MAX(3*N, 27); C else, LDWORK >= 3/2*N**2+MAX(3*N, 27). C For good performance LDWORK should generally be larger. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C XERBLA. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: problem during computation of the eigenvalues; C = 2: periodic QZ algorithm did not converge in the SLICOT C Library subroutine MB03BD; C = 3: some eigenvalues might be inaccurate, and details can C be found in IWORK and DWORK. This is a warning. C C METHOD C C The algorithm uses Givens rotations and Householder reflections to C annihilate elements in Z and T such that Z is in a special block C triangular form and T is in skew-Hamiltonian Hessenberg form: C C ( Z11 Z12 ) ( B1 F1 ) C Z = ( ), T = ( ), C ( 0 Z22 ) ( 0 B1' ) C C with Z11 and Z22' upper triangular and B1 upper Hessenberg. C Subsequently, the periodic QZ algorithm is applied to the pencil C aZ22' Z11 - bB1 to determine orthogonal matrices Q1, Q2 and U such C that U' Z11 Q1, Q2' Z22' U are upper triangular and Q2' B1 Q1 is C upper quasi-triangular. See also page 35 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, April 22, 2009. C V. Sima, Aug. 2009 (SLICOT version of the routine ZSHFTR). C C REVISIONS C C V. Sima, Dec. 2010, Jan. 2011, Aug. 2011, Nov. 2011, July 2012, C July 2013, Jan. 2017, Mar. 2020, Apr. 2020. C M. Voigt, Jan. 2012. C C KEYWORDS C C Periodic QZ algorithm, upper (quasi-)triangular matrix, C skew-Hamiltonian/skew-Hamiltonian pencil. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, FOUR PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, FOUR = 4.0D+0 ) C C .. Scalar Arguments .. CHARACTER COMPQ, COMPU, JOB INTEGER INFO, LDB, LDFG, LDQ, LDU1, LDU2, LDWORK, LDZ, $ LIWORK, N C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), B( LDB, * ), $ BETA( * ), DWORK( * ), FG( LDFG, * ), $ Q( LDQ, * ), U1( LDU1, * ), U2( LDU2, * ), $ Z( LDZ, * ) C C .. Local Scalars .. LOGICAL LCMPQ, LCMPU, LINIU, LQUERY, LTRI, LUPDU, UNREL CHARACTER*16 CMPQ, CMPSC INTEGER EMAX, EMIN, I, I11, I22, I2X2, IB1, ICF, ICG, $ IQ1, IQ2, ITAU, IU, IW, IWARN, IWRK, IZ11, $ IZ22, J, K, L, M, MINDW, MJ1, MJ2, MJ3, MM, $ NBETA0, NINF, OPTDW, P DOUBLE PRECISION BASE, CO, SI, TEMP, TMP1, TMP2 C C .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 4 ) C C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLANTR, DLAPY2 EXTERNAL DLAMCH, DLANTR, DLAPY2, IDAMAX, LSAME C C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEQRF, DGERQF, DLACPY, DLARTG, $ DLASET, DORMQR, DORMRQ, DROT, DSWAP, MA02AD, $ MB01KD, MB01LD, MB01MD, MB03BD, XERBLA C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 MM = M*M LTRI = LSAME( JOB, 'T' ) LCMPQ = LSAME( COMPQ, 'I' ) LINIU = LSAME( COMPU, 'I' ) LUPDU = LSAME( COMPU, 'U' ) LCMPU = LINIU .OR. LUPDU IF( N.EQ.0 ) THEN MINDW = 4 ELSE IF( LTRI .OR. LCMPQ .OR. LCMPU ) THEN MINDW = 6*MM + MAX( 3*N, 27 ) ELSE MINDW = 3*MM + MAX( 3*N, 27 ) END IF LQUERY = LDWORK.EQ.-1 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -2 ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -4 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDFG.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDU1.LT.1 .OR. ( LCMPU .AND. LDU1.LT.M ) ) THEN INFO = -14 ELSE IF( LDU2.LT.1 .OR. ( LCMPU .AND. LDU2.LT.M ) ) THEN INFO = -16 ELSE IF( LIWORK.LT.N+9 ) THEN INFO = -21 ELSE IF( .NOT. LQUERY .AND. LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -23 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04ED', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN IF( LQUERY ) THEN C C Compute optimal workspace. C CALL DGEQRF( N, M, DWORK, N, DWORK, DUM, -1, INFO ) CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N, $ DWORK, Q, LDQ, DUM( 2 ), -1, INFO ) CALL DGERQF( M, M, Z, LDZ, DWORK, DUM( 3 ), -1, INFO ) CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z, LDZ, DWORK, $ Q, LDQ, DUM( 4 ), -1, INFO ) J = MAX( MAX( N*M + MAX( INT( DUM( 1 ) ), INT( DUM( 2 ) ) ), $ INT( DUM( 3 ) ), INT( DUM( 4 ) ) ) + M, 3*MM ) DWORK( 1 ) = MAX( MINDW, J ) RETURN END IF END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IWORK( 1 ) = 0 DWORK( 1 ) = FOUR DWORK( 2 ) = ZERO DWORK( 3 ) = ZERO DWORK( 4 ) = ZERO RETURN END IF C C Determine machine constants. C BASE = DLAMCH( 'Base' ) EMIN = INT( DLAMCH( 'Minimum Exponent' ) ) EMAX = INT( DLAMCH( 'Largest Exponent' ) ) C C Find half of the number of infinite eigenvalues if Z is diagonal. C Otherwise, find a lower bound of this number. C NINF = 0 IF( N.EQ.1 ) THEN IF( Z( 1, 1 ).EQ.ZERO ) $ NINF = 1 ELSE IF( DLANTR( 'Max', 'Lower', 'No-diag', N-1, N-1, Z( 2, 1 ), $ LDZ, DWORK ).EQ.ZERO .AND. $ DLANTR( 'Max', 'Upper', 'No-diag', N-1, N-1, Z( 1, 2 ), $ LDZ, DWORK ).EQ.ZERO ) THEN DO 10 J = 1, M IF( Z( J, J ).EQ.ZERO .OR. Z( J+M, J+M ).EQ.ZERO ) $ NINF = NINF + 1 10 CONTINUE ELSE DO 20 J = 1, M I = IDAMAX( N, Z( 1, J ), 1 ) K = IDAMAX( N, Z( 1, M+J ), 1 ) L = IDAMAX( N, Z( J, 1 ), LDZ ) P = IDAMAX( N, Z( M+J, 1 ), LDZ ) IF( Z( I, J ).EQ.ZERO .OR. Z( K, M+J ).EQ.ZERO .OR. $ Z( J, L ).EQ.ZERO .OR. Z( M+J, P ).EQ.ZERO ) $ NINF = NINF + 1 20 CONTINUE END IF END IF C C Initializations. C CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) C IF( LINIU ) THEN CALL DLASET( 'Full', M, M, ZERO, ONE, U1, LDU1 ) CALL DLASET( 'Full', M, M, ZERO, ZERO, U2, LDU2 ) END IF C C STEP 1: By changing the elimination order in the classical RQ C decomposition, determine an orthogonal matrix Q1 such that C C ( Z11 Z12 ) C Z = ( ) Q1', C ( 0 Z22 ) C C where Z11 and Z22' are upper triangular. C Update Q and T subsequently. 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 ITAU = N*M + 1 IWRK = ITAU + M CALL MA02AD( 'Full', M, N, Z( M+1, 1 ), LDZ, DWORK, N ) C C Perform a QR decomposition ( Z21 Z22 )' = Q1*R1, and C update ( Z11 Z12 ). C C Workspace: need N*M+N; C prefer N*M+M+M*NB, where NB is the optimal C blocksize. C CALL DGEQRF( N, M, DWORK, N, DWORK( ITAU ), DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) CALL DORMQR( 'Right', 'No Transpose', M, N, M, DWORK, N, $ DWORK( ITAU ), Z, LDZ, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) C C Copy R1' to Z22 and set the strictly upper triangular part of Z22 C to zero. C CALL MA02AD( 'Upper', M, M, DWORK, N, Z( M+1, M+1 ), LDZ ) IF( M.GT.1 ) $ CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, Z( M+1, M+2 ), $ LDZ ) C C Update Q. C CALL DORMQR( 'Right', 'No Transpose', N, N, M, DWORK, N, $ DWORK( ITAU ), Q, LDQ, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C DO 30 I = 1, M CALL DSWAP( N, Q( 1, I ), 1, Q( 1, M+I ), 1 ) 30 CONTINUE C ITAU = 1 IWRK = ITAU + M C C Perform an RQ decomposition Z12 = R2*Q2. C C Workspace: need N; C prefer M+M*NB, where NB is the optimal blocksize. C CALL DGERQF( M, M, Z( 1, M+1 ), LDZ, DWORK( ITAU ), DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Update Q. C CALL DORMRQ( 'Right', 'Transpose', N, M, M, Z( 1, M+1 ), LDZ, $ DWORK( ITAU ), Q, LDQ, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Exchange Z11 and Z12 and set the strictly lower triangular part C of Z11 to zero. C DUM( 1 ) = ZERO DO 40 J = 1, M - 1 CALL DSWAP( M, Z( 1, J ), 1, Z( 1, M+J ), 1 ) CALL DCOPY( M-J, DUM( 1 ), 0, Z( J+1, J ), 1 ) 40 CONTINUE C CALL DSWAP( M, Z( 1, M ), 1, Z( 1, N ), 1 ) C C Apply the transformations to B and FG. C C Workspace: need 3*M*M. C C Copy the strictly upper triangular part of F and the transpose of C the strictly lower triangular part of G to appropriate locations C in DWORK. C ICF = 1 ICG = ICF + MM IWRK = ICG + MM IF( M.GT.1 ) THEN CALL DLACPY( 'Upper', M-1, M-1, FG( 1, 3 ), LDFG, $ DWORK( ICF+M ), M ) CALL MA02AD( 'Lower', M-1, M-1, FG( 2, 1 ), LDFG, $ DWORK( ICG+M ), M ) END IF C C Skew-symmetric updates to determine the new F. C C Fnew := Q(m+1:n,m+1:n)'*B *Q(1:m,m+1:n) C - Q(1:m,m+1:n)' *B'*Q(m+1:n,m+1:n) C + Q(m+1:n,m+1:n)'*F *Q(m+1:n,m+1:n) C - Q(1:m,m+1:n)' *G *Q(1:m,m+1:n). C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, DWORK( ICF ), $ M, Q( M+1, M+1 ), LDQ, DWORK( ICF ), M, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) CALL MB01LD( 'Upper', 'Transpose', M, M, ONE, ONE, DWORK( ICF ), $ M, Q( 1, M+1 ), LDQ, DWORK( ICG ), M, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, B, LDB, $ Q( 1, M+1 ), LDQ, ZERO, DWORK( IWRK ), M ) CALL MB01KD( 'Upper', 'Transpose', M, M, ONE, Q( M+1, M+1 ), LDQ, $ DWORK( IWRK ), M, ONE, DWORK( ICF ), M, INFO ) C C Copy the strictly lower triangular part of G and the transpose of C the strictly upper triangular part of F to appropriate locations C in DWORK. C IF( M.GT.1 ) THEN CALL DLACPY( 'Lower', M-1, M-1, FG( 2, 1 ), LDFG, $ DWORK( ICG+1 ), M ) CALL MA02AD( 'Upper', M-1, M-1, FG( 1, 3 ), LDFG, $ DWORK( ICF+1 ), M ) END IF C C Skew-symmetric updates to determine the new G. C C Gnew := Q(1:m,1:m)' *B'*Q(m+1:n,1:m) C - Q(m+1:n,1:m)'*B *Q(1:m,1:m) C + Q(1:m,1:m)' *G *Q(1:m,1:m) C - Q(m+1:n,1:m)'*F *Q(m+1:n,1:m). C CALL MB01LD( 'Lower', 'Transpose', M, M, ZERO, ONE, DWORK( ICG ), $ M, Q, LDQ, DWORK( ICG ), M, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) CALL MB01LD( 'Lower', 'Transpose', M, M, ONE, ONE, DWORK( ICG ), $ M, Q( M+1, 1 ), LDQ, DWORK( ICF ), M, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, B, LDB, $ Q( M+1, 1 ), LDQ, ZERO, DWORK( IWRK ), M ) CALL MB01KD( 'Lower', 'Transpose', M, M, ONE, Q, LDQ, $ DWORK( IWRK ), M, ONE, DWORK( ICG ), M, INFO ) C C Determine the new B. C C Bnew := Q(m+1:n,m+1:n)'*B *Q(1:m,1:m) C - Q(1:m,m+1:n)' *B'*Q(m+1:n,1:m) C + Q(m+1:n,m+1:n)'*F *Q(m+1:n,1:m) C - Q(1:m,m+1:n)' *G *Q(1:m,1:m). C DO 50 I = 1, M CALL MB01MD( 'Upper', M, ONE, FG( 1, 2 ), LDFG, Q( M+1, I ), 1, $ ZERO, DWORK( IWRK+( I-1 )*M ), 1 ) 50 CONTINUE IF( M.GT.1 ) $ CALL DLACPY( 'Upper', M-1, M-1, DWORK( ICF+M ), M, FG( 1, 3 ), $ LDFG ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, B, LDB, $ Q, LDQ, ONE, DWORK( IWRK ), M ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ Q( M+1, M+1 ), LDQ, DWORK( IWRK ), M, ZERO, $ DWORK( ICF ), M ) DO 60 I = 1, M CALL MB01MD( 'Lower', M, ONE, FG, LDFG, Q( 1, I ), 1, ZERO, $ DWORK( IWRK+( I-1 )*M ), 1 ) 60 CONTINUE CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, B, LDB, $ Q( M+1, 1 ), LDQ, ONE, DWORK( IWRK ), M ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, -ONE, $ Q( 1, M+1 ), LDQ, DWORK( IWRK ), M, ONE, $ DWORK( ICF ), M ) IF( M.GT.1 ) $ CALL DLACPY( 'Lower', M-1, M-1, DWORK( ICG+1 ), M, FG( 2, 1 ), $ LDFG ) CALL DLACPY( 'Full', M, M, DWORK( ICF ), M, B, LDB ) C C STEP 2: Reduce T to skew-Hamiltonian Hessenberg form. C DO 90 K = 1, M - 1 C C I. Annihilate T(m+k, k+1:m-1) as well as T(m+k+1:n-1, k), C i.e., G(k+1:m-1, k). C DO 70 J = K + 1, M - 1 MJ2 = MIN( J+2, M ) MJ3 = MJ2 + 1 C C Determine a Givens rotation to annihilate G(j,k) from the C left. C CALL DLARTG( FG( J+1, K ), FG( J, K ), CO, SI, TMP1 ) C C Update B and G. C CALL DROT( M, B( 1, J+1 ), 1, B( 1, J ), 1, CO, SI ) CALL DROT( M-J-1, FG( MJ2, J+1 ), 1, FG( MJ2, J ), 1, CO, SI $ ) FG( J+1, K ) = TMP1 CALL DROT( J-K-1, FG( J+1, K+1 ), LDFG, FG( J, K+1 ), LDFG, $ CO, SI ) C C Update Z. C CALL DROT( J, Z( 1, J+1 ), 1, Z( 1, J ), 1, CO, SI ) TMP1 = -SI*Z( J+1, J+1 ) Z( J+1, J+1 ) = CO*Z( J+1, J+1 ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(j+1,j) from the C left. C CALL DLARTG( Z( J, J ), TMP1, CO, SI, TMP2 ) C C Update Z. C Z( J, J ) = TMP2 Z( J+1, J ) = ZERO CALL DROT( N-J, Z( J, J+1 ), LDZ, Z( J+1, J+1 ), LDZ, CO, $ SI ) CALL DROT( J, Z( M+J, M+1 ), LDZ, Z( M+J+1, M+1 ), LDZ, $ CO, SI ) TMP1 = SI*Z( M+J+1, M+J+1 ) Z( M+J+1, M+J+1 ) = CO*Z( M+J+1, M+J+1 ) C IF( LCMPU ) THEN C C Update U1 and U2. C CALL DROT( M, U1( 1, J ), 1, U1( 1, J+1 ), 1, CO, SI ) CALL DROT( M, U2( 1, J ), 1, U2( 1, J+1 ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(m+j,m+j+1) from C the right. C CALL DLARTG( Z( M+J, M+J ), TMP1, CO, SI, TMP2 ) C C Update Z. C CALL DROT( M, Z( 1, M+J ), 1, Z( 1, M+J+1 ), 1, CO, SI ) Z( M+J, M+J ) = TMP2 CALL DROT( M-J, Z( M+J+1, M+J ), 1, Z( M+J+1, M+J+1 ), 1, $ CO, SI ) C C Update B and F. C CALL DROT( M-K+1, B( J, K ), LDB, B( J+1, K ), LDB, CO, SI ) CALL DROT( J-1, FG( 1, J+1 ), 1, FG( 1, J+2 ), 1, CO, SI ) CALL DROT( M-J-1, FG( J, MJ3 ), LDFG, FG( J+1, MJ3 ), LDFG, $ CO, SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, M+J ), 1, Q( 1, M+J+1 ), 1, CO, SI ) END IF 70 CONTINUE C C II. Annihilate G(k,m) (and also G(m,k)). C C Determine a Givens rotation to annihilate G(m,k) from the C left. C CALL DLARTG( B( M, K ), -FG( M, K ), CO, SI, TMP1 ) C C Update B, F and G. C CALL DROT( M-1, FG( 1, M+1 ), 1, B( 1, M ), 1, CO, SI ) B( M, K ) = TMP1 CALL DROT( M-K-1, FG( M, K+1 ), LDFG, B( M, K+1 ), LDB, CO, $ SI ) C C Update Z. C CALL DROT( M, Z( 1, N ), 1, Z( 1, M ), 1, CO, SI ) TMP1 = -SI*Z( N, N ) Z( N, N ) = CO*Z( N, N ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(n,m) from the left. C CALL DLARTG( Z( M, M ), TMP1, CO, SI, TMP2 ) C C Update Z. C Z( M, M ) = TMP2 CALL DROT( M, Z( M, M+1 ), LDZ, Z( N, M+1 ), LDZ, CO, SI ) C IF( LCMPU ) THEN C C Update U1 and U2. C CALL DROT( M, U1( 1, M ), 1, U2( 1, M ), 1, CO, SI ) END IF C C III. Annihilate B(k+2:m,k). C DO 80 J = M, K + 2, -1 MJ1 = MIN( J+1, M ) MJ2 = MJ1 + 1 C C Determine a Givens rotation to annihilate B(j,k) from the C left. C CALL DLARTG( B( J-1, K ), B( J, K ), CO, SI, TMP1 ) C C Update B and F. C CALL DROT( J-2, FG( 1, J ), 1, FG( 1, J+1 ), 1, CO, SI ) B( J-1, K ) = TMP1 B( J, K ) = ZERO CALL DROT( M-K, B( J-1, K+1 ), LDB, B( J, K+1 ), LDB, CO, $ SI ) CALL DROT( M-J, FG( J-1, MJ2 ), LDFG, FG( J, MJ2 ), LDFG, $ CO, SI ) C C Update Z. C CALL DROT( M, Z( 1, M+J-1 ), 1, Z( 1, M+J ), 1, CO, SI ) TMP1 = -SI*Z( M+J-1, M+J-1 ) Z( M+J-1, M+J-1 ) = CO*Z( M+J-1, M+J-1 ) CALL DROT( M-J+1, Z( M+J, M+J-1 ), 1, Z( M+J, M+J ), 1, CO, $ SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, M+J-1 ), 1, Q( 1, M+J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(m+j-1,m+j) from C the left. C CALL DLARTG( Z( M+J, M+J ), TMP1, CO, SI, TMP2 ) C C Update Z. C TMP1 = SI*Z( J-1, J-1 ) Z( J-1, J-1 ) = CO*Z( J-1, J-1 ) CALL DROT( N-J+1, Z( J, J ), LDZ, Z( J-1, J ), LDZ, CO, SI ) CALL DROT( J-1, Z( M+J, M+1 ), LDZ, Z( M+J-1, M+1 ), LDZ, $ CO, SI ) Z( M+J, M+J ) = TMP2 C IF( LCMPU ) THEN C C Update U1 and U2. C CALL DROT( M, U1( 1, J ), 1, U1( 1, J-1 ), 1, CO, SI ) CALL DROT( M, U2( 1, J ), 1, U2( 1, J-1 ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate Z(j,j-1) from the C right. C CALL DLARTG( Z( J, J ), TMP1, CO, SI, TMP2 ) C C Update Z. C Z( J, J ) = TMP2 CALL DROT( J-1, Z( 1, J ), 1, Z( 1, J-1 ), 1, CO, SI ) C C Update B and G. C CALL DROT( M, B( 1, J ), 1, B( 1, J-1 ), 1, CO, SI ) CALL DROT( J-K-1, FG( J, K ), LDFG, FG( J-1, K ), LDFG, CO, $ SI ) CALL DROT( M-J, FG( MJ1, J ), 1, FG( MJ1, J-1 ), 1, CO, SI ) C IF( LCMPQ ) THEN C C Update Q. C CALL DROT( N, Q( 1, J ), 1, Q( 1, J-1 ), 1, CO, SI ) END IF 80 CONTINUE 90 CONTINUE C C ( Z11 Z12 ) ( B1 F1 ) C Now Z = ( ), T = ( ), C ( 0 Z22 ) ( 0 B1' ) C C where Z11 and Z22' are upper triangular and B1 upper Hessenberg. C C STEP 3: Apply the periodic QZ algorithm to the pencil C aZ22' Z11 - bB1 to determine orthogonal matrices C Q1, Q2 and U such that U' Z11 Q1 and Q2' Z22' U are upper C triangular, and Q2' B1 Q1 is upper quasi-triangular. C C Determine the mode of computations. C IQ2 = 1 IF( LTRI .OR. LCMPQ .OR. LCMPU ) THEN CMPQ = 'Initialize' IQ1 = IQ2 + MM IU = IQ1 + MM IB1 = IU + MM ELSE CMPQ = 'No Computation' IB1 = 1 END IF IZ11 = IB1 + MM IZ22 = IZ11 + MM IWRK = IZ22 + MM C IF( LTRI ) THEN CMPSC = 'Schur Form' ELSE CMPSC = 'Eigenvalues Only' END IF C IWORK( 1 ) = 1 IWORK( 2 ) = -1 IWORK( 3 ) = -1 C CALL DLACPY( 'Full', M, M, B, LDB, DWORK( IB1 ), M ) CALL DLACPY( 'Full', M, M, Z, LDZ, DWORK( IZ11 ), M ) CALL MA02AD( 'Full', M, M, Z( M+1, M+1 ), LDZ, DWORK( IZ22 ), M ) C C Periodic QZ iteration. C C Real workspace: need w1 + MAX( N,24 ) + 3, where C w1 = 6*M**2, if JOB = 'T', or C COMPQ = 'I' or COMPU <>'N'; C w1 = 3*M**2, otherwise. C Integer workspace: need N + 9. C CALL MB03BD( CMPSC, 'Careful', CMPQ, IDUM, 3, M, 1, 1, M, IWORK, $ DWORK( IB1 ), M, M, DWORK( IQ2 ), M, M, ALPHAR, $ ALPHAI, BETA, IWORK( 4 ), IWORK( M+4 ), $ LIWORK-( M+3 ), DWORK( IWRK ), LDWORK-IWRK+1, IWARN, $ INFO ) IF( IWARN.GT.0 .AND. IWARN.LT.M ) THEN INFO = 1 RETURN ELSE IF( IWARN.EQ.M+1 ) THEN INFO = 3 ELSE IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Compute the eigenvalues of the pencil aS - bT. C NBETA0 = 0 I11 = 0 I22 = 0 I2X2 = 0 C C Compute the eigenvalues with nonnegative imaginary parts of the C pencil aS - bH. Also, count the number of 2-by-2 diagonal blocks, C I2X2, and the number of 1-by-1 and 2-by-2 blocks with unreliable C eigenvalues, I11 and I22, respectively. C I = 1 C WHILE( I.LE.M ) DO 100 CONTINUE IF( I.LE.M ) THEN IF( NINF.GT.0 ) THEN IF( BETA( I ).EQ.ZERO ) $ NBETA0 = NBETA0 + 1 END IF IF( IWORK( I+3 ).GE.EMIN .AND. IWORK( I+3 ).LE.EMAX ) THEN C C b = BASE**IWORK(i+3) is between underflow and overflow C threshold, BETA(i) is divided by b. C BETA( I ) = BETA( I )/BASE**IWORK( I+3 ) IF( BETA( I ).NE.ZERO ) THEN IF( IWORK( M+I+4 ).LT.0 ) THEN I22 = I22 + 1 ELSE IF( IWORK( M+I+4 ).GT.0 ) THEN I11 = I11 + 1 END IF IF( ALPHAI( I ).LT.ZERO ) $ ALPHAI( I ) = -ALPHAI( I ) IF( ALPHAR( I ).NE.ZERO .AND. ALPHAI( I ).NE.ZERO ) THEN ALPHAI( I+1 ) = -ALPHAI( I ) BETA( I+1 ) = BETA( I ) I2X2 = I2X2 + 1 I = I + 1 END IF END IF ELSE IF( IWORK( I+3 ).LT.EMIN ) THEN C C Set to zero the numerator part of the eigenvalue. C ALPHAR( I ) = ZERO ALPHAI( I ) = ZERO I11 = I11 + 1 ELSE C C Set an infinite eigenvalue. C IF( NINF.GT.0 ) $ NBETA0 = NBETA0 + 1 BETA( I ) = ZERO I11 = I11 + 1 END IF I = I + 1 GO TO 100 END IF C END WHILE 100 C IWORK( 1 ) = I11 + I22 C C Set to infinity the largest eigenvalues, if necessary. C L = 0 IF( NINF.GT.0 ) THEN DO 120 J = 1, NINF - NBETA0 TMP1 = ZERO TMP2 = ONE P = 1 DO 110 I = 1, M IF( BETA( I ).GT.ZERO ) THEN TEMP = DLAPY2( ALPHAR( I ), ALPHAI( I ) ) IF( TEMP.GT.TMP1 .AND. TMP2.GE.BETA( I ) ) THEN TMP1 = TEMP TMP2 = BETA( I ) P = I END IF END IF 110 CONTINUE L = L + 1 BETA( P ) = ZERO 120 CONTINUE C IF( L.EQ.IWORK( 1 ) ) THEN C C All unreliable eigenvalues found have been set to infinity. C INFO = 0 I11 = 0 I22 = 0 IWORK( 1 ) = 0 END IF END IF C C Save the norms of the factors. C CALL DCOPY( 3, DWORK( IWRK+1 ), 1, DUM, 1 ) C C Save the triplets of the 1-by-1 and 2-by-2 diagonal blocks. C All 1-by-1 diagonal blocks come first. C Save also information about blocks with possible loss of accuracy. C C Workspace: IWRK+w-1, where w = 3 if M = 1, or w = 3*N, otherwise. C K = IWRK P = IWRK IW = IWORK( 1 ) I = 1 J = 1 L = 3*( M - 2*I2X2 ) + K C C WHILE( I.LE.N ) DO UNREL = .FALSE. 130 CONTINUE IF( I.LE.M ) THEN IF( J.LE.IW ) $ UNREL = I.EQ.ABS( IWORK( M+I+4 ) ) IF( ALPHAR( I ).NE.ZERO .AND. BETA( I ).NE.ZERO .AND. $ ALPHAI( I ).NE.ZERO ) THEN IF( UNREL ) THEN J = J + 1 IWORK( J ) = IWORK( M+I+4 ) IWORK( IW+J ) = L - IWRK + 1 UNREL = .FALSE. END IF CALL DLACPY( 'Full', 2, 2, DWORK( IB1+(M+1)*(I-1) ), M, $ DWORK( L ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IB1+(M+1)*(I-1)+MM ), $ M, DWORK( L+4 ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IB1+(M+1)*(I-1)+2*MM ), $ M, DWORK( L+8 ), 2 ) L = L + 12 I = I + 2 ELSE IF ( UNREL ) THEN J = J + 1 IWORK( J ) = I IWORK( IW+J ) = K - IWRK + 1 UNREL = .FALSE. END IF CALL DCOPY( 3, DWORK( IB1+(M+1)*(I-1) ), MM, DWORK( K ), $ 1 ) K = K + 3 I = I + 1 END IF GO TO 130 END IF C END WHILE 130 C IWORK( 2*IW+2 ) = I11 IWORK( 2*IW+3 ) = I22 IWORK( 2*IW+4 ) = I2X2 C IF( LTRI ) THEN C C Update Z. C C Workspace: need w2 = 5*M**2, if JOB = 'T'; C w2 = 2*M**2, otherwise. C IWRK = IZ11 CALL DLACPY( 'Upper', M, M, DWORK( IZ11 ), M, Z, LDZ ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IU ), M, Z( 1, M+1 ), LDZ, ZERO, $ DWORK( IWRK ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IWRK ), M, DWORK( IQ2 ), M, ZERO, $ Z( 1, M+1 ), LDZ ) CALL MA02AD( 'Upper', M, M, DWORK( IZ22 ), M, Z( M+1, M+1 ), $ LDZ ) C C Update B. C CALL DLACPY( 'Full', M, M, DWORK( IB1 ), M, B, LDB ) IWRK = IB1 C C Skew-symmetric update of F. C C Workspace: need w3 + M, where C w3 = 3*M**2, if JOB = 'T', or C COMPQ = 'I' or COMPU <>'N'; C w3 = 0, otherwise; C prefer w3 + M*(M-1). C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, FG( 1, 2 ), $ LDFG, DWORK( IQ2 ), M, FG( 1, 2 ), LDFG, $ DWORK( IWRK ), LDWORK-IWRK+1, ITAU ) C IF( LCMPQ ) THEN C C Update Q. C C Workspace: need w3 + N*M. C CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q, LDQ, DWORK( IQ1 ), M, ZERO, DWORK( IWRK ), $ N ) CALL DLACPY( 'Full', N, M, DWORK( IWRK ), N, Q, LDQ ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q( 1, M+1 ), LDQ, DWORK( IQ2 ), M, ZERO, $ DWORK( IWRK ), N ) CALL DLACPY( 'Full', N, M, DWORK( IWRK ), N, Q( 1, M+1 ), $ LDQ ) END IF C IF( LCMPU ) THEN C C Update U. C CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U1, LDU1, DWORK( IU ), M, ZERO, DWORK( IWRK ), $ M ) CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, U1, LDU1 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U2, LDU2, DWORK( IU ), M, ZERO, DWORK( IWRK ), $ M ) CALL DLACPY( 'Full', M, M, DWORK( IWRK ), M, U2, LDU2 ) END IF END IF C C Move the norms, and the triplets of 1-by-1 and 2-by-2 blocks in C front. C K = 3*( M - 2*I2X2 ) + 12*I2X2 CALL DCOPY( K, DWORK( P ), 1, DWORK( 5 ), 1 ) CALL DCOPY( 3, DUM, 1, DWORK( 2 ), 1 ) C DWORK( 1 ) = OPTDW RETURN C *** Last line of MB04ED *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02RU.f0000644000000000000000000000013015012430707016210 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB02RU.f0000644000175000017500000004020715012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q, $ LDQ, S, LDS, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To construct the 2n-by-2n Hamiltonian or symplectic matrix S C associated to the linear-quadratic optimization problem, used to C solve the continuous- or discrete-time algebraic Riccati equation, C respectively. C C For a continuous-time problem, S is defined by C C ( op(A) -G ) C S = ( ), (1) C ( -Q -op(A)' ) C C and for a discrete-time problem by C C -1 -1 C ( op(A) op(A) *G ) C S = ( -1 -1 ), (2) C ( Q*op(A) op(A)' + Q*op(A) *G ) C C or C -T -T C ( op(A) + G*op(A) *Q -G*op(A) ) C S = ( -T -T ), (3) C ( -op(A) *Q op(A) ) C C where op(A) = A or A' (A**T), A, G, and Q are n-by-n matrices, C with G and Q symmetric. Matrix A must be nonsingular in the C discrete-time case. 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 HINV CHARACTER*1 C If DICO = 'D', specifies which of the matrices (2) or (3) C is constructed, as follows: C = 'D': The matrix S in (2) is constructed; C = 'I': The (inverse) matrix S in (3) is constructed. C HINV is not referenced if DICO = 'C'. 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 UPLO CHARACTER*1 C Specifies which triangle of the matrices G and Q is C stored, as follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, G, and Q. N >= 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 matrix A. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) C On entry, the leading N-by-N upper triangular part (if C UPLO = 'U') or lower triangular part (if UPLO = 'L') of C this array must contain the upper triangular part or lower C triangular part, respectively, of the symmetric matrix G. C On exit, if DICO = 'D', the leading N-by-N part of this C array contains the symmetric matrix G fully stored. C If DICO = 'C', this array is not modified on exit, and the C strictly lower triangular part (if UPLO = 'U') or strictly C upper triangular part (if UPLO = 'L') is not referenced. C C LDG INTEGER C The leading dimension of the array G. LDG >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, the leading N-by-N upper triangular part (if C UPLO = 'U') or lower triangular part (if UPLO = 'L') of C this array must contain the upper triangular part or lower C triangular part, respectively, of the symmetric matrix Q. C On exit, if DICO = 'D', the leading N-by-N part of this C array contains the symmetric matrix Q fully stored. C If DICO = 'C', this array is not modified on exit, and the C strictly lower triangular part (if UPLO = 'U') or strictly C upper triangular part (if UPLO = 'L') is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= MAX(1,N). C C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) C If INFO = 0, the leading 2N-by-2N part of this array C contains the Hamiltonian or symplectic matrix of the C problem. C C LDS INTEGER C The leading dimension of the array S. LDS >= MAX(1,2*N). C C Workspace C C IWORK INTEGER array, dimension (LIWORK), where C LIWORK >= 0, if DICO = 'C'; C LIWORK >= 2*N, if DICO = 'D'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if DICO = 'D', DWORK(1) returns the reciprocal C condition number RCOND of the given matrix A, and C DWORK(2) returns the reciprocal pivot growth factor C norm(A)/norm(U) (see SLICOT Library routine MB02PD). C If DWORK(2) is much less than 1, then the computed S C and RCOND could be unreliable. If 0 < INFO <= N, then C DWORK(2) contains the reciprocal pivot growth factor for C the leading INFO columns of A. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 0, if DICO = 'C'; C LDWORK >= MAX(2,6*N), if DICO = 'D'. 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 = i: if the leading i-by-i (1 <= i <= N) upper triangular C submatrix of A is singular in discrete-time case; C = N+1: if matrix A is numerically singular in discrete- C time case. C C METHOD C C For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1) C is constructed. C For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or C (3) - the inverse of the matrix in (2) - is constructed. C C NUMERICAL ASPECTS C C The discrete-time case needs the inverse of the matrix A, hence C the routine should not be used when A is ill-conditioned. C 3 C The algorithm requires 0(n ) floating point operations in the C discrete-time case. C C FURTHER COMMENTS C C This routine is a functionally extended and with improved accuracy C version of the SLICOT Library routine SB02MU. Transposed problems C can be dealt with as well. The LU factorization of op(A) (with C no equilibration) and iterative refinement are used for solving C the various linear algebraic systems involved. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. C C REVISIONS C C - C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, discrete-time system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, HINV, TRANA, UPLO INTEGER INFO, LDA, LDG, LDQ, LDS, LDWORK, N C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), $ S(LDS,*) C .. Local Scalars .. CHARACTER EQUED, TRANAT LOGICAL DISCR, LHINV, LUPLO, NOTRNA INTEGER I, J, N2, NJ, NP1 DOUBLE PRECISION PIVOTG, RCOND, RCONDA, TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DLACPY, DLASET, DSWAP, MA02AD, $ MA02ED, MB02PD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C N2 = N + N INFO = 0 DISCR = LSAME( DICO, 'D' ) LUPLO = LSAME( UPLO, 'U' ) NOTRNA = LSAME( TRANA, 'N' ) IF( DISCR ) $ LHINV = LSAME( HINV, 'D' ) C C Test the input scalar arguments. C IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN INFO = -1 ELSE IF( DISCR ) THEN IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) $ INFO = -2 ELSE IF( INFO.EQ.0 ) THEN IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) $ .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -3 ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDG.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN INFO = -13 ELSE IF( ( LDWORK.LT.0 ) .OR. $ ( DISCR .AND. LDWORK.LT.MAX( 2, 6*N ) ) ) THEN INFO = -16 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB02RU', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN IF ( DISCR ) THEN DWORK(1) = ONE DWORK(2) = ONE END IF RETURN END IF C C The code tries to exploit data locality as much as possible, C assuming that LDS is greater than LDA, LDQ, and/or LDG. C IF ( .NOT.DISCR ) THEN C C Continuous-time case: Construct Hamiltonian matrix column-wise. C C Copy op(A) in S(1:N,1:N), and construct full Q C in S(N+1:2*N,1:N) and change the sign. C DO 100 J = 1, N IF ( NOTRNA ) THEN CALL DCOPY( N, A(1,J), 1, S(1,J), 1 ) ELSE CALL DCOPY( N, A(J,1), LDA, S(1,J), 1 ) END IF C IF ( LUPLO ) THEN C DO 20 I = 1, J S(N+I,J) = -Q(I,J) 20 CONTINUE C DO 40 I = J + 1, N S(N+I,J) = -Q(J,I) 40 CONTINUE C ELSE C DO 60 I = 1, J - 1 S(N+I,J) = -Q(J,I) 60 CONTINUE C DO 80 I = J, N S(N+I,J) = -Q(I,J) 80 CONTINUE C END IF 100 CONTINUE C C Construct full G in S(1:N,N+1:2*N) and change the sign, and C construct -op(A)' in S(N+1:2*N,N+1:2*N). C DO 240 J = 1, N NJ = N + J IF ( LUPLO ) THEN C DO 120 I = 1, J S(I,NJ) = -G(I,J) 120 CONTINUE C DO 140 I = J + 1, N S(I,NJ) = -G(J,I) 140 CONTINUE C ELSE C DO 160 I = 1, J - 1 S(I,NJ) = -G(J,I) 160 CONTINUE C DO 180 I = J, N S(I,NJ) = -G(I,J) 180 CONTINUE C END IF C IF ( NOTRNA ) THEN C DO 200 I = 1, N S(N+I,NJ) = -A(J,I) 200 CONTINUE C ELSE C DO 220 I = 1, N S(N+I,NJ) = -A(I,J) 220 CONTINUE C END IF 240 CONTINUE C ELSE C C Discrete-time case: Construct the symplectic matrix (2) or (3). C C Fill in the remaining triangles of the symmetric matrices Q C and G. C CALL MA02ED( UPLO, N, Q, LDQ ) CALL MA02ED( UPLO, N, G, LDG ) C C Prepare the construction of S in (2) or (3). C NP1 = N + 1 IF ( NOTRNA ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF C C Solve op(A)'*X = Q in S(N+1:2*N,1:N), using the LU C factorization of op(A), obtained in S(1:N,1:N), and C iterative refinement. No equilibration of A is used. C Workspace: 6*N. C CALL MB02PD( 'No equilibration', TRANAT, N, N, A, LDA, S, $ LDS, IWORK, EQUED, DWORK, DWORK, Q, LDQ, $ S(NP1,1), LDS, RCOND, DWORK, DWORK(NP1), $ IWORK(NP1), DWORK(N2+1), INFO ) C C Return if the matrix is exactly singular or singular to C working precision. C IF( INFO.GT.0 ) THEN DWORK(1) = RCOND DWORK(2) = DWORK(N2+1) RETURN END IF C RCONDA = RCOND PIVOTG = DWORK(N2+1) C IF ( LHINV ) THEN C C Complete the construction of S in (2). C C Transpose X in-situ. C DO 260 J = 1, N - 1 CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS ) 260 CONTINUE C C Solve op(A)*X = I_n in S(N+1:2*N,N+1:2*N), using the LU C factorization of op(A), computed in S(1:N,1:N), and C iterative refinement. C CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS ) CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, $ EQUED, DWORK, DWORK, S(1,NP1), LDS, S(NP1,NP1), $ LDS, RCOND, DWORK, DWORK(NP1), IWORK(NP1), $ DWORK(N2+1), INFO ) C C Solve op(A)*X = G in S(1:N,N+1:2*N), using the LU C factorization of op(A), computed in S(1:N,1:N), and C iterative refinement. C CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, $ EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS, $ RCOND, DWORK, DWORK(NP1), IWORK(NP1), $ DWORK(N2+1), INFO ) C C -1 C Copy op(A) from S(N+1:2*N,N+1:2*N) in S(1:N,1:N). C CALL DLACPY( 'Full', N, N, S(NP1,NP1), LDS, S, LDS ) C C -1 C Compute op(A)' + Q*op(A) *G in S(N+1:2*N,N+1:2*N). C IF ( NOTRNA ) THEN CALL MA02AD( 'Full', N, N, A, LDA, S(NP1,NP1), LDS ) ELSE CALL DLACPY( 'Full', N, N, A, LDA, S(NP1,NP1), LDS ) END IF CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, $ Q, LDQ, S(1,NP1), LDS, ONE, S(NP1,NP1), LDS ) C ELSE C C Complete the construction of S in (3). C C Change the sign of X. C DO 300 J = 1, N C DO 280 I = NP1, N2 S(I,J) = -S(I,J) 280 CONTINUE C 300 CONTINUE C C Solve op(A)'*X = I_n in S(N+1:2*N,N+1:2*N), using the LU C factorization of op(A), computed in S(1:N,1:N), and C iterative refinement. C CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS ) CALL MB02PD( 'Factored', TRANAT, N, N, A, LDA, S, LDS, $ IWORK, EQUED, DWORK, DWORK, S(1,NP1), LDS, $ S(NP1,NP1), LDS, RCOND, DWORK, DWORK(NP1), $ IWORK(NP1), DWORK(N2+1), INFO ) C C Solve op(A)*X' = -G in S(1:N,N+1:2*N), using the LU C factorization of op(A), obtained in S(1:N,1:N), and C iterative refinement. C CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK, $ EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS, $ RCOND, DWORK, DWORK(NP1), IWORK(NP1), $ DWORK(N2+1), INFO ) C C Change the sign of X and transpose it in-situ. C DO 340 J = NP1, N2 C DO 320 I = 1, N TEMP = -S(I,J) S(I,J) = -S(J-N,I+N) S(J-N,I+N) = TEMP 320 CONTINUE C 340 CONTINUE C -T C Compute op(A) + G*op(A) *Q in S(1:N,1:N). C IF ( NOTRNA ) THEN CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) ELSE CALL MA02AD( 'Full', N, N, A, LDA, S, LDS ) END IF CALL DGEMM( 'No transpose', 'No transpose', N, N, N, -ONE, $ G, LDG, S(NP1,1), LDS, ONE, S, LDS ) C END IF DWORK(1) = RCONDA DWORK(2) = PIVOTG END IF RETURN C C *** Last line of SB02RU *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01XZ.f0000644000000000000000000000013215012430707016225 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB01XZ.f0000644000175000017500000001730615012430707017430 0ustar00lilgelilge00000000000000 SUBROUTINE TB01XZ( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC, $ D, LDD, INFO ) C C PURPOSE C C To apply a special transformation to a system given as a triple C (A,B,C), C C A <-- P * A' * P, B <-- P * C', C <-- B' * P, C C where P is a matrix with 1 on the secondary diagonal, and with 0 C in the other entries. Matrix A can be specified as a band matrix. C Optionally, matrix D of the system can be transposed. This C transformation is actually a special similarity transformation of C the dual system. C C ARGUMENTS C C Mode Parameters 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 matrix A, the number of rows of matrix B C and the number of columns of matrix C. C N represents the dimension of the state vector. N >= 0. C C M (input) INTEGER. C The number of columns of matrix B. C M represents the dimension of input vector. M >= 0. C C P (input) INTEGER. C The number of rows of matrix C. C P represents the dimension of output vector. P >= 0. C C KL (input) INTEGER C The number of subdiagonals of A to be transformed. C MAX( 0, N-1 ) >= KL >= 0. C C KU (input) INTEGER C The number of superdiagonals of A to be transformed. C MAX( 0, N-1 ) >= KU >= 0. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the system state matrix A. C On exit, the leading N-by-N part of this array contains C the transformed (pertransposed) matrix P*A'*P. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) COMPLEX*16 array, dimension (LDB,MAX(M,P)) C On entry, the leading N-by-M part of this array must C contain the original input/state matrix B. C On exit, the leading N-by-P part of this array contains C the dual input/state matrix P*C'. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N) if M > 0 or P > 0. C LDB >= 1 if M = 0 and P = 0. C C C (input/output) COMPLEX*16 array, dimension (LDC,N) C On entry, the leading P-by-N part of this array must C contain the original state/output matrix C. C On exit, the leading M-by-N part of this array contains C the dual state/output matrix B'*P. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,M,P) if N > 0. C LDC >= 1 if N = 0. C C D (input/output) COMPLEX*16 array, dimension (LDD,MAX(M,P)) C On entry, if JOBD = 'D', the leading P-by-M part of this C array must contain the original direct transmission C matrix D. C On exit, if JOBD = 'D', the leading M-by-P part of this C array contains the transposed direct transmission matrix C D'. The array D is not referenced if JOBD = 'Z'. C C LDD INTEGER C The leading dimension of array D. C LDD >= MAX(1,M,P) if JOBD = 'D'. C LDD >= 1 if JOBD = 'Z'. 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 rows and/or columns of the matrices of the triplet (A,B,C) C and, optionally, of the matrix D are swapped in a special way. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C - C C KEYWORDS C C Matrix algebra, matrix operations, similarity transformation. C C ********************************************************************* C C .. C .. Scalar Arguments .. CHARACTER JOBD INTEGER INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P C .. C .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ) C .. C .. Local Scalars .. LOGICAL LJOBD INTEGER J, J1, LDA1, MAXMP, MINMP, NM1 C .. C .. External functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL XERBLA, ZCOPY, ZSWAP C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the scalar input arguments. C INFO = 0 LJOBD = LSAME( JOBD, 'D' ) MAXMP = MAX( M, P ) MINMP = MIN( M, P ) NM1 = N - 1 C IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) 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( KL.LT.0 .OR. KL.GT.MAX( 0, NM1 ) ) THEN INFO = -5 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( 0, NM1 ) ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( ( MAXMP.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. $ ( MINMP.EQ.0 .AND. LDB.LT.1 ) ) THEN INFO = -10 ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN INFO = -12 ELSE IF( LDD.LT.1 .OR. ( LJOBD .AND. LDD.LT.MAXMP ) ) THEN INFO = -14 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01XZ', -INFO ) RETURN END IF C C Quick return if possible. C IF ( LJOBD ) THEN C C Replace D by D', if non-scalar. C DO 5 J = 1, MAXMP IF ( J.LT.MINMP ) THEN CALL ZSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) ELSE IF ( J.GT.P ) THEN CALL ZCOPY( P, D(1,J), 1, D(J,1), LDD ) ELSE IF ( J.GT.M ) THEN CALL ZCOPY( M, D(J,1), LDD, D(1,J), 1 ) END IF 5 CONTINUE C END IF C IF( N.EQ.0 ) $ RETURN C C Replace matrix A by P*A'*P. C IF ( KL.EQ.NM1 .AND. KU.EQ.NM1 ) THEN C C Full matrix A. C DO 10 J = 1, NM1 CALL ZSWAP( N-J, A( 1, J ), 1, A( N-J+1, J+1 ), -LDA ) 10 CONTINUE C ELSE C C Band matrix A. C LDA1 = LDA + 1 C C Pertranspose the KL subdiagonals. C DO 20 J = 1, MIN( KL, N-2 ) J1 = ( N - J )/2 CALL ZSWAP( J1, A(J+1,1), LDA1, A(N-J1+1,N-J1+1-J), -LDA1 ) 20 CONTINUE C C Pertranspose the KU superdiagonals. C DO 30 J = 1, MIN( KU, N-2 ) J1 = ( N - J )/2 CALL ZSWAP( J1, A(1,J+1), LDA1, A(N-J1+1-J,N-J1+1), -LDA1 ) 30 CONTINUE C C Pertranspose the diagonal. C J1 = N/2 CALL ZSWAP( J1, A(1,1), LDA1, A(N-J1+1,N-J1+1), -LDA1 ) C END IF C C Replace matrix B by P*C' and matrix C by B'*P. C DO 40 J = 1, MAXMP IF ( J.LE.MINMP ) THEN CALL ZSWAP( N, B(1,J), 1, C(J,1), -LDC ) ELSE IF ( J.GT.P ) THEN CALL ZCOPY( N, B(1,J), 1, C(J,1), -LDC ) ELSE CALL ZCOPY( N, C(J,1), -LDC, B(1,J), 1 ) END IF 40 CONTINUE C RETURN C *** Last line of TB01XZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02HD.f0000644000000000000000000000013215012430707016150 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02HD.f0000644000175000017500000001033715012430707017350 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION MA02HD( JOB, M, N, DIAG, A, LDA ) C C PURPOSE C C To check if A = DIAG*I, where I is an M-by-N matrix with ones on C the diagonal and zeros elsewhere. C C FUNCTION VALUE C C MA02HD LOGICAL C The function value is set to .TRUE. if A = DIAG*I, and to C .FALSE., otherwise. If min(M,N) = 0, the value is .FALSE. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the part of the matrix A to be checked out, C as follows: C = 'U': Upper triangular/trapezoidal part; C = 'L': Lower triangular/trapezoidal part. C Otherwise: All of the matrix A. 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 DIAG (input) DOUBLE PRECISION C The scalar DIAG. 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. If JOB = 'U', only the upper triangle or C trapezoid is accessed; if JOB = 'L', only the lower C triangle or trapezoid is accessed. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C METHOD C C The routine returns immediately after detecting a diagonal element C which differs from DIAG, or a nonzero off-diagonal element in the C searched part of A. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, May 2001. C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003, C Jan. 2016. C C KEYWORDS C C Elementary operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER LDA, M, N DOUBLE PRECISION DIAG C .. Array Arguments .. DOUBLE PRECISION A(LDA,*) C .. Local Scalars .. INTEGER I, J C .. External Functions LOGICAL LSAME EXTERNAL LSAME C .. Intrinsic Functions .. INTRINSIC MIN C C .. Executable Statements .. C C Do not check parameters, for efficiency. C Quick return if possible. C IF( MIN( M, N ).EQ.0 ) THEN MA02HD = .FALSE. RETURN END IF C IF( LSAME( JOB, 'U' ) ) THEN C DO 20 J = 1, N C DO 10 I = 1, MIN( J-1, M ) IF( A(I,J).NE.ZERO ) THEN MA02HD = .FALSE. RETURN END IF 10 CONTINUE C IF( J.LE.M ) THEN IF( A(J,J).NE.DIAG ) THEN MA02HD = .FALSE. RETURN END IF END IF 20 CONTINUE C ELSE IF( LSAME( JOB, 'L' ) ) THEN C DO 40 J = 1, MIN( M, N ) IF( A(J,J).NE.DIAG ) THEN MA02HD = .FALSE. RETURN END IF C IF ( J.LT.M ) THEN C DO 30 I = J+1, M IF( A(I,J).NE.ZERO ) THEN MA02HD = .FALSE. RETURN END IF 30 CONTINUE C END IF 40 CONTINUE C ELSE C DO 70 J = 1, N C DO 50 I = 1, MIN( J-1, M ) IF( A(I,J).NE.ZERO ) THEN MA02HD = .FALSE. RETURN END IF 50 CONTINUE C IF( J.LE.M ) THEN IF( A(J,J).NE.DIAG ) THEN MA02HD = .FALSE. RETURN END IF END IF C IF ( J.LT.M ) THEN C DO 60 I = J+1, M IF( A(I,J).NE.ZERO ) THEN MA02HD = .FALSE. RETURN END IF 60 CONTINUE C END IF 70 CONTINUE C END IF C MA02HD = .TRUE. C RETURN C *** Last line of MA02HD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB06ND.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB06ND.f0000644000175000017500000002456615012430707017402 0ustar00lilgelilge00000000000000 SUBROUTINE SB06ND( N, M, KMAX, A, LDA, B, LDB, KSTAIR, U, LDU, F, $ LDF, DWORK, INFO ) C C PURPOSE C C To construct the minimum norm feedback matrix F to perform C "deadbeat control" on a (A,B)-pair of a state-space model (which C must be preliminarily reduced to upper "staircase" form using C SLICOT Library routine AB01OD) such that the matrix R = A + BFU' C is nilpotent. C (The transformation matrix U reduces R to upper Schur form with C zero blocks on its diagonal (of dimension KSTAIR(i)) and C therefore contains bases for the i-th controllable subspaces, C where i = 1,...,KMAX). C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The actual state dimension, i.e. the order of the C matrix A. N >= 0. C C M (input) INTEGER C The actual input dimension. M >= 0. C C KMAX (input) INTEGER C The number of "stairs" in the staircase form as produced C by SLICOT Library routine AB01OD. 0 <= KMAX <= 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 transformed state-space matrix of the C (A,B)-pair with triangular stairs, as produced by SLICOT C Library routine AB01OD (with option STAGES = 'A'). C On exit, the leading N-by-N part of this array contains C the matrix U'AU + U'BF. 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 transformed triangular input matrix of the C (A,B)-pair as produced by SLICOT Library routine AB01OD C (with option STAGES = 'A'). C On exit, the leading N-by-M part of this array contains C the matrix U'B. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C KSTAIR (input) INTEGER array, dimension (KMAX) C The leading KMAX elements of this array must contain the C dimensions of each "stair" as produced by SLICOT Library C routine AB01OD. 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 either a transformation matrix (e.g. from a C previous call to other SLICOT routine) or be initialised C as the identity matrix. C On exit, the leading N-by-N part of this array contains C the product of the input matrix U and the state-space C transformation matrix which reduces A + BFU' to real C Schur form. C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,N). C C F (output) DOUBLE PRECISION array, dimension (LDF,N) C The leading M-by-N part of this array contains the C deadbeat feedback matrix F. C C LDF INTEGER C The leading dimension of array F. LDF >= MAX(1,M). C C Workspace C C DWORK DOUBLE PRECISION 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 C METHOD C C Starting from the (A,B)-pair in "staircase form" with "triangular" C stairs, dimensions KSTAIR(i+1) x KSTAIR(i), (described by the C vector KSTAIR): C C | B | A * . . . * | C | 1| 11 . . | C | | A A . . | C | | 21 22 . . | C | | . . . | C [ B | A ] = | | . . * | C | | . . | C | 0 | 0 | C | | A A | C | | r,r-1 rr | C C where the i-th diagonal block of A has dimension KSTAIR(i), for C i = 1,2,...,r, the feedback matrix F is constructed recursively in C r steps (where the number of "stairs" r is given by KMAX). In each C step a unitary state-space transformation U and a part of F are C updated in order to achieve the final form: C C | 0 A * . . . * | C | 12 . . | C | . . | C | 0 A . . | C | 23 . . | C | . . | C [ U'AU + U'BF ] = | . . * | . C | . . | C | | C | A | C | r-1,r| C | | C | 0 | C C C REFERENCES C C [1] Van Dooren, P. C Deadbeat control: a special inverse eigenvalue problem. C BIT, 24, pp. 681-699, 1984. C C NUMERICAL ASPECTS C C The algorithm requires O((N + M) * N**2) operations and is mixed C numerical stable (see [1]). C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. C Supersedes Release 2.0 routine SB06BD by M. Vanbegin, and C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. C C REVISIONS C C 1997, December 10; 2003, September 27. C C KEYWORDS C C Canonical form, deadbeat control, eigenvalue assignment, feedback C control, orthogonal transformation, real Schur form, staircase C form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, KMAX, LDA, LDB, LDF, LDU, M, N C .. Array Arguments .. INTEGER KSTAIR(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), U(LDU,*) C .. Local Scalars .. INTEGER J, J0, JCUR, JKCUR, JMKCUR, KCUR, KK, KMIN, $ KSTEP, MKCUR, NCONT C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DLACPY, DLARFG, DLASET, DLATZM, $ DTRSM, XERBLA 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( KMAX.LT.0 .OR. KMAX.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDU.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE NCONT = 0 C DO 10 KK = 1, KMAX NCONT = NCONT + KSTAIR(KK) 10 CONTINUE C IF( NCONT.GT.N ) $ INFO = -8 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB06ND', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 ) $ RETURN C DO 120 KMIN = 1, KMAX JCUR = NCONT KSTEP = KMAX - KMIN C C Triangularize bottom part of A (if KSTEP > 0). C DO 40 KK = KMAX, KMAX - KSTEP + 1, -1 KCUR = KSTAIR(KK) C C Construct Ukk and store in Fkk. C DO 20 J = 1, KCUR JMKCUR = JCUR - KCUR CALL DCOPY( KCUR, A(JCUR,JMKCUR), LDA, F(1,JCUR), 1 ) CALL DLARFG( KCUR+1, A(JCUR,JCUR), F(1,JCUR), 1, $ DWORK(JCUR) ) CALL DLASET( 'Full', 1, KCUR, ZERO, ZERO, A(JCUR,JMKCUR), $ LDA ) C C Backmultiply A and U with Ukk. C CALL DLATZM( 'Right', JCUR-1, KCUR+1, F(1,JCUR), 1, $ DWORK(JCUR), A(1,JCUR), A(1,JMKCUR), LDA, $ DWORK ) C CALL DLATZM( 'Right', N, KCUR+1, F(1,JCUR), 1, $ DWORK(JCUR), U(1,JCUR), U(1,JMKCUR), LDU, $ DWORK(N+1) ) JCUR = JCUR - 1 20 CONTINUE C 40 CONTINUE C C Eliminate diagonal block Aii by feedback Fi. C KCUR = KSTAIR(KMIN) J0 = JCUR - KCUR + 1 MKCUR = M - KCUR + 1 C C Solve for Fi and add B x Fi to A. C CALL DLACPY( 'Full', KCUR, KCUR, A(J0,J0), LDA, F(MKCUR,J0), $ LDF ) CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', KCUR, $ KCUR, -ONE, B(J0,MKCUR), LDB, F(MKCUR,J0), LDF ) IF ( J0.GT.1 ) $ CALL DGEMM( 'No transpose', 'No transpose', J0-1, KCUR, $ KCUR, ONE, B(1,MKCUR), LDB, F(MKCUR,J0), LDF, $ ONE, A(1,J0), LDA ) CALL DLASET( 'Full', KCUR, KCUR, ZERO, ZERO, A(J0,J0), LDA ) CALL DLASET( 'Full', M-KCUR, KCUR, ZERO, ZERO, F(1,J0), LDF ) C IF ( KSTEP.NE.0 ) THEN JKCUR = NCONT C C Premultiply A with Ukk. C DO 80 KK = KMAX, KMAX - KSTEP + 1, -1 KCUR = KSTAIR(KK) JCUR = JKCUR - KCUR C DO 60 J = 1, KCUR CALL DLATZM( 'Left', KCUR+1, N-JCUR+1, F(1,JKCUR), 1, $ DWORK(JKCUR), A(JKCUR,JCUR), $ A(JCUR,JCUR), LDA, DWORK(N+1) ) JCUR = JCUR - 1 JKCUR = JKCUR - 1 60 CONTINUE C 80 CONTINUE C C Premultiply B with Ukk. C JCUR = JCUR + KCUR JKCUR = JCUR + KCUR C DO 100 J = M, M - KCUR + 1, -1 CALL DLATZM( 'Left', KCUR+1, M-J+1, F(1,JKCUR), 1, $ DWORK(JKCUR), B(JKCUR,J), B(JCUR,J), LDB, $ DWORK(N+1) ) JCUR = JCUR - 1 JKCUR = JKCUR - 1 100 CONTINUE C END IF 120 CONTINUE C IF ( NCONT.NE.N ) $ CALL DLASET( 'Full', M, N-NCONT, ZERO, ZERO, F(1,NCONT+1), $ LDF ) C RETURN C *** Last line of SB06ND *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02EZ.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02EZ.f0000644000175000017500000001267515012430707017402 0ustar00lilgelilge00000000000000 SUBROUTINE MA02EZ( UPLO, TRANS, SKEW, N, A, LDA ) C C PURPOSE C C To store by (skew-)symmetry the upper or lower triangle of a C (skew-)symmetric/Hermitian complex matrix, given the other C triangle. The option SKEW = 'G' allows to suitably deal with the C diagonal of a general square triangular matrix. 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 TRANS CHARACTER*1 C Specifies whether to use transposition or conjugate C transposition as follows: C = 'T': Use transposition; C = 'C': Use conjugate transposition. C C SKEW CHARACTER*1 C Specifies whether the matrix is symmetric/Hermitian or C skew-symmetric/Hermitian as follows: C = 'G': The matrix is not symmetric/Hermitian (general); C = 'N': The matrix is symmetric/Hermitian; C = 'S': The matrix is skew-symmetric/Hermitian. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C A (input/output) COMPLEX*16 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 (skew-)symmetric/Hermitian matrix A. C On exit, the leading N-by-N part of this array contains C the (skew-)symmetric/Hermitian matrix A with all elements C stored. If the resulted matrix should be Hermitian, the C imaginary parts of the diagonal entries are set to zero. C If the resulted matrix should be skew-Hermitian, the real C parts of the diagonal entries are set to zero. 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 Sep. 2012. Based on SLICOT Library routine MA02ED. C C REVISIONS C C V. Sima, Jan. 2016, July 2021. C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER SKEW, TRANS, UPLO INTEGER LDA, N C .. Array Arguments .. COMPLEX*16 A(LDA,*) C .. Local Scalars .. INTEGER I, J C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C ..Intrinsic Functions.. INTRINSIC DBLE, DCONJG, DIMAG 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 IF( LSAME( TRANS, 'T' ) ) THEN C IF( LSAME( SKEW, 'S' ) ) THEN C DO 20 I = 1, N DO 10 J = I+1, N A(I,J) = -A(J,I) 10 CONTINUE 20 CONTINUE C ELSE C DO 40 I = 1, N DO 30 J = I+1, N A(I,J) = A(J,I) 30 CONTINUE 40 CONTINUE C END IF C ELSE C IF( LSAME( SKEW, 'G' ) ) THEN C DO 60 I = 1, N DO 50 J = I, N A(I,J) = DCONJG( A(J,I) ) 50 CONTINUE 60 CONTINUE C ELSE IF( LSAME( SKEW, 'N' ) ) THEN C DO 80 I = 1, N A(I,I) = DBLE( A(I,I) ) DO 70 J = I+1, N A(I,J) = DCONJG( A(J,I) ) 70 CONTINUE 80 CONTINUE C ELSE C DO 100 I = 1, N A(I,I) = DIMAG( A(I,I) ) DO 90 J = I+1, N A(I,J) = -DCONJG( A(J,I) ) 90 CONTINUE 100 CONTINUE C END IF C END IF C ELSE IF( LSAME( UPLO, 'U' ) ) THEN C C Construct the lower triangle of A. C IF( LSAME( TRANS, 'T' ) ) THEN C IF( LSAME( SKEW, 'S' ) ) THEN C DO 120 I = 1, N DO 110 J = I+1, N A(J,I) = -A(I,J) 110 CONTINUE 120 CONTINUE C ELSE C DO 140 I = 1, N DO 130 J = I+1, N A(J,I) = A(I,J) 130 CONTINUE 140 CONTINUE C END IF C ELSE C IF( LSAME( SKEW, 'G' ) ) THEN C DO 160 I = 1, N DO 150 J = I, N A(J,I) = DCONJG( A(I,J) ) 150 CONTINUE 160 CONTINUE C ELSE IF( LSAME( SKEW, 'N' ) ) THEN C DO 180 I = 1, N A(I,I) = DBLE( A(I,I) ) DO 170 J = I+1, N A(J,I) = DCONJG( A(I,J) ) 170 CONTINUE 180 CONTINUE C ELSE C DO 200 I = 1, N A(I,I) = DIMAG( A(I,I) ) DO 190 J = I+1, N A(J,I) = -DCONJG( A(I,J) ) 190 CONTINUE 200 CONTINUE C END IF C END IF C END IF RETURN C *** Last line of MA02EZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01OT.f0000644000000000000000000000013215012430707016177 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01OT.f0000644000175000017500000001707715012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE MB01OT( UPLO, TRANS, N, ALPHA, BETA, R, LDR, E, LDE, T, $ LDT ) C C PURPOSE C C To compute one of the symmetric rank 2k operations C C R := alpha*R + beta*E*T' + beta*T*E', C C or C C R := alpha*R + beta*E'*T + beta*T'*E, C C where alpha and beta are scalars, R, T, and E are N-by-N matrices, C with T and E upper triangular. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies which triangle of the symmetric matrix R is C 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 E to be used in the matrix C multiplication as follows: C = 'N': R := alpha*R + beta*E*T' + beta*T*E'; C = 'T': R := alpha*R + beta*E'*T + beta*T'*E; C = 'C': R := alpha*R + beta*E'*T + beta*T'*E. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices R, T, and E. 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 T and E are not C referenced. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) C On entry with 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 R. C On entry with 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 R. C In both cases, the other strictly triangular part is not C referenced. C On exit, the leading N-by-N 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 the computed matrix R. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C E (input) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the upper triangular matrix E. C The remaining part of this array is not referenced. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). C C T (input) DOUBLE PRECISION array, dimension (LDT,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the upper triangular matrix T. C The remaining part of this array is not referenced. C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,N). C C METHOD C C A particularization of the algorithm used in the BLAS 3 routine C DSYR2K is used. C C NUMERICAL ASPECTS C C The algorithm requires approximately N**3/3 operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2019. 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 .. C .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER LDE, LDR, LDT, N CHARACTER TRANS, UPLO C .. C .. Array Arguments .. DOUBLE PRECISION E(LDE,*), R(LDR,*), T(LDT,*) C .. C .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, J LOGICAL LTRANS, UPPER C .. C .. Local Arrays .. DOUBLE PRECISION TMP(1) C .. C .. External Functions .. DOUBLE PRECISION DDOT LOGICAL LSAME EXTERNAL DDOT, LSAME C .. C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input parameters. C UPPER = LSAME( UPLO, 'U' ) LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) C INFO = 0 IF ( .NOT.UPPER .AND. .NOT. LSAME( UPLO, 'L' ) ) THEN INFO = 1 ELSE IF ( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LTRANS ) THEN INFO = 2 ELSE IF ( N.LT.0 ) THEN INFO = 3 ELSE IF ( LDR.LT.MAX( 1,N ) ) THEN INFO = 7 ELSE IF ( LDT.LT.MAX( 1,N ) ) THEN INFO = 9 ELSE IF ( LDE.LT.MAX( 1, N ) ) THEN INFO = 11 END IF IF ( INFO.NE.0) THEN CALL XERBLA( 'MB01OT', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. ( BETA.EQ.ZERO .AND. ALPHA.EQ.ONE ) ) $ RETURN C IF ( BETA.EQ.ZERO ) THEN IF ( ALPHA.EQ.ZERO ) THEN C C Special case alpha = 0. C CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) ELSE C C Special case beta = 0. C IF ( ALPHA.NE.ONE ) $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, N, N, R, LDR, INFO ) END IF RETURN END IF C C Start the operations. C IF ( .NOT.LTRANS ) THEN C C Form R := alpha*R + beta*E*T' + beta*T*E'. C IF ( UPPER ) THEN C DO 20 J = 1, N IF ( ALPHA.EQ.ZERO ) THEN TMP(1) = ZERO CALL DCOPY( J, TMP, 0, R(1,J), 1 ) ELSE IF ( ALPHA.NE.ONE ) THEN CALL DSCAL( J, ALPHA, R(1,J), 1 ) END IF C DO 10 I = J, N CALL DAXPY( J, BETA*T(J,I), E(1,I), 1, R(1,J), 1 ) CALL DAXPY( J, BETA*E(J,I), T(1,I), 1, R(1,J), 1 ) 10 CONTINUE C 20 CONTINUE C ELSE C DO 40 J = 1, N IF ( ALPHA.EQ.ZERO ) THEN TMP(1) = ZERO CALL DCOPY( J, TMP, 0, R(J,1), LDR ) ELSE IF ( ALPHA.NE.ONE ) THEN CALL DSCAL( J, ALPHA, R(J,1), LDR ) END IF C DO 30 I = 1, J CALL DAXPY( I, BETA*T(I,J), E(1,J), 1, R(I,1), LDR ) CALL DAXPY( I, BETA*E(I,J), T(1,J), 1, R(I,1), LDR ) 30 CONTINUE C 40 CONTINUE C END IF C ELSE C C Form R := alpha*R + beta*E'*T + beta*T'*E. C IF ( UPPER ) THEN C DO 60 J = 1, N C DO 50 I = 1, J TEMP = BETA*( DDOT( I, E(1,I), 1, T(1,J), 1 ) + $ DDOT( I, T(1,I), 1, E(1,J), 1 ) ) IF ( ALPHA.EQ.ZERO ) THEN R(I,J) = TEMP ELSE R(I,J) = ALPHA*R(I,J) + TEMP END IF 50 CONTINUE C 60 CONTINUE C ELSE C DO 80 J = 1, N C DO 70 I = J, N TEMP = BETA*( DDOT( J, E(1,I), 1, T(1,J), 1 ) + $ DDOT( J, T(1,I), 1, E(1,J), 1 ) ) IF ( ALPHA.EQ.ZERO ) THEN R(I,J) = TEMP ELSE R(I,J) = ALPHA*R(I,J) + TEMP END IF 70 CONTINUE C 80 CONTINUE C END IF C END IF C RETURN C *** Last line of MB01OT *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03SD.f0000644000000000000000000000013215012430707016165 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03SD.f0000644000175000017500000002601315012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE MB03SD( JOBSCL, N, A, LDA, QG, LDQG, WR, WI, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To compute the eigenvalues of an N-by-N square-reduced Hamiltonian C matrix C C ( A' G' ) C H' = ( T ). (1) C ( Q' -A' ) C C Here, A' is an N-by-N matrix, and G' and Q' are symmetric N-by-N C matrices. It is assumed without a check that H' is square- C reduced, i.e., that C C 2 ( A'' G'' ) C H' = ( T ) with A'' upper Hessenberg. (2) C ( 0 A'' ) C C T 2 C (Equivalently, Q'A'- A' Q' = 0, A'' = A' + G'Q', and for i > j+1, C A''(i,j) = 0.) Ordinarily, H' is the output from SLICOT Library C routine MB04ZD. The eigenvalues of H' are computed as the square C roots of the eigenvalues of A''. C C ARGUMENTS C C Mode Parameters C C JOBSCL CHARACTER*1 C Specifies whether or not balancing operations should C be performed by the LAPACK subroutine DGEBAL on the C Hessenberg matrix A'' in (2), as follows: C = 'N': do not use balancing; C = 'S': do scaling in order to equilibrate the rows C and columns of A''. C See LAPACK subroutine DGEBAL and Section METHOD below. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, G, and Q. N >= 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 upper left block A' of the square-reduced Hamiltonian C matrix H' in (1), as produced by SLICOT Library routine C MB04ZD. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input) DOUBLE PRECISION array, dimension (LDQG,N+1) C The leading N-by-N lower triangular part of this array C must contain the lower triangle of the lower left C symmetric block Q' of the square-reduced Hamiltonian C matrix H' in (1), and the N-by-N upper triangular part of C the submatrix in the columns 2 to N+1 of this array must C contain the upper triangle of the upper right symmetric C block G' of the square-reduced Hamiltonian matrix H' C in (1), as produced by SLICOT Library routine MB04ZD. C So, if i >= j, then Q'(i,j) is stored in QG(i,j) and C G'(i,j) is stored in QG(j,i+1). C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C WR (output) DOUBLE PRECISION array, dimension (N) C WI (output) DOUBLE PRECISION array, dimension (N) C The arrays WR and WI contain the real and imaginary parts, C respectively, of the N eigenvalues of H' with non-negative C real part. The remaining N eigenvalues are the negatives C of these eigenvalues. C Eigenvalues are stored in WR and WI in decreasing order of C magnitude of the real parts, i.e., WR(I) >= WR(I+1). C (In particular, an eigenvalue closest to the imaginary C axis is WR(N)+WI(N)i.) C In addition, eigenvalues with zero real part are sorted in C decreasing order of magnitude of imaginary parts. Note C that non-real eigenvalues with non-zero real part appear C in complex conjugate pairs, but eigenvalues with zero real C part do not, in general, appear in complex conjugate C pairs. 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 the array DWORK. C LDWORK >= MAX(1,N*(N+1)). C For good performance, LDWORK should be larger. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C < 0: if INFO = -i, then the i-th argument had an illegal C value; C > 0: if INFO = i, i <= N, then LAPACK subroutine DHSEQR C failed to converge while computing the i-th C eigenvalue. C C METHOD C C The routine forms the upper Hessenberg matrix A'' in (2) and calls C LAPACK subroutines to calculate its eigenvalues. The eigenvalues C of H' are the square roots of the eigenvalues of A''. C C REFERENCES C C [1] Van Loan, C. F. C A Symplectic Method for Approximating All the Eigenvalues of C a Hamiltonian Matrix. C Linear Algebra and its Applications, 61, pp. 233-251, 1984. C C [2] Byers, R. C Hamiltonian and Symplectic Algorithms for the Algebraic C Riccati Equation. C Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983. C C [3] Benner, P., Byers, R., and Barth, E. C Fortran 77 Subroutines for Computing the Eigenvalues of C Hamiltonian Matrices. I: The Square-Reduced Method. C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. C C NUMERICAL ASPECTS C C The algorithm requires (32/3)*N**3 + O(N**2) floating point C operations. C Eigenvalues computed by this subroutine are exact eigenvalues C of a perturbed Hamiltonian matrix H' + E where C C || E || <= c sqrt(eps) || H' ||, C C c is a modest constant depending on the dimension N and eps is the C machine precision. Moreover, if the norm of H' and an eigenvalue C are of roughly the same magnitude, the computed eigenvalue is C essentially as accurate as the computed eigenvalue obtained by C traditional methods. See [1] or [2]. C C CONTRIBUTOR C C P. Benner, Universitaet Bremen, Germany, and C R. Byers, University of Kansas, Lawrence, USA. C Aug. 1998, routine DHAEVS. C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Oct. 1998, SLICOT Library version. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2002, C May 2009. C C KEYWORDS C C Eigenvalues, (square-reduced) Hamiltonian matrix, symplectic C similarity transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. C .. Scalar Arguments .. INTEGER INFO, LDA, LDQG, LDWORK, N CHARACTER JOBSCL C .. C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), WI(*), WR(*) C .. C .. Local Scalars .. DOUBLE PRECISION SWAP, X, Y INTEGER BL, CHUNK, I, IGNORE, IHI, ILO, J, JW, JWORK, M, $ N2 LOGICAL BLAS3, BLOCK, SCALE, SORTED C .. C .. Local Arrays .. DOUBLE PRECISION DUMMY(1) C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DLASET, $ DSYMM, DSYMV, MA01AD, MA02ED, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C INFO = 0 N2 = N*N SCALE = LSAME( JOBSCL, 'S' ) IF ( .NOT. ( SCALE .OR. LSAME( JOBSCL, 'N' ) ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDQG.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDWORK.LT.MAX( 1, N2 + N ) ) THEN INFO = -10 END IF C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03SD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C CHUNK = ( LDWORK - N2 ) / N BLOCK = MIN( CHUNK, N ).GT.1 BLAS3 = CHUNK.GE.N C IF ( BLAS3 ) THEN JWORK = N2 + 1 ELSE JWORK = 1 END IF C 2 C Form the matrix A'' = A' + G'Q'. C CALL DLACPY( 'Lower', N, N, QG, LDQG, DWORK(JWORK), N ) CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) C IF ( BLAS3 ) THEN C C Use BLAS 3 calculation. C CALL DSYMM( 'Left', 'Upper', N, N, ONE, QG(1, 2), LDQG, $ DWORK(JWORK), N, ZERO, DWORK, N ) C ELSE IF ( BLOCK ) THEN JW = N2 + 1 C C Use BLAS 3 for as many columns of Q' as possible. C DO 10 J = 1, N, CHUNK BL = MIN( N-J+1, CHUNK ) CALL DSYMM( 'Left', 'Upper', N, BL, ONE, QG(1, 2), LDQG, $ DWORK(1+N*(J-1)), N, ZERO, DWORK(JW), N ) CALL DLACPY( 'Full', N, BL, DWORK(JW), N, DWORK(1+N*(J-1)), $ N ) 10 CONTINUE C ELSE C C Use BLAS 2 calculation. C DO 20 J = 1, N CALL DSYMV( 'Upper', N, ONE, QG(1, 2), LDQG, $ DWORK(1+N*(J-1)), 1, ZERO, WR, 1 ) CALL DCOPY( N, WR, 1, DWORK(1+N*(J-1)), 1 ) 20 CONTINUE C END IF C CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, A, LDA, A, $ LDA, ONE, DWORK, N ) IF ( SCALE .AND. N.GT.2 ) $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK(3), N ) C 2 C Find the eigenvalues of A' + G'Q'. C CALL DGEBAL( JOBSCL, N, DWORK, N, ILO, IHI, DWORK(1+N2), IGNORE ) CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, DWORK, $ N, WR, WI, DUMMY, 1, DWORK(1+N2), N, INFO ) IF ( INFO.EQ.0 ) THEN C C Eigenvalues of H' are the square roots of those computed above. C DO 30 I = 1, N X = WR(I) Y = WI(I) CALL MA01AD( X, Y, WR(I), WI(I) ) 30 CONTINUE C C Sort eigenvalues into decreasing order by real part and, for C eigenvalues with zero real part only, decreasing order of C imaginary part. (This simple bubble sort preserves the C relative order of eigenvalues with equal but nonzero real part. C This ensures that complex conjugate pairs remain C together.) C SORTED = .FALSE. C DO 50 M = N, 1, -1 IF ( SORTED ) GO TO 60 SORTED = .TRUE. C DO 40 I = 1, M - 1 IF ( ( ( WR(I).LT.WR(I+1) ) .OR. $ ( ( WR(I).EQ.ZERO ) .AND. ( WR(I+1).EQ.ZERO ) .AND. $ ( WI(I).LT.WI(I+1) ) ) ) ) THEN SWAP = WR(I) WR(I) = WR(I+1) WR(I+1) = SWAP SWAP = WI(I) WI(I) = WI(I+1) WI(I+1) = SWAP C SORTED = .FALSE. C END IF 40 CONTINUE C 50 CONTINUE C 60 CONTINUE C END IF C DWORK(1) = 2*N2 RETURN C *** Last line of MB03SD *** END control-4.1.2/src/slicot/src/PaxHeaders/DE01OD.f0000644000000000000000000000013215012430707016151 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/DE01OD.f0000644000175000017500000001113215012430707017343 0ustar00lilgelilge00000000000000 SUBROUTINE DE01OD( CONV, N, A, B, INFO ) C C PURPOSE C C To compute the convolution or deconvolution of two real signals C A and B. C C ARGUMENTS C C Mode Parameters C C CONV CHARACTER*1 C Indicates whether convolution or deconvolution is to be C performed as follows: C = 'C': Convolution; C = 'D': Deconvolution. C C Input/Output Parameters C C N (input) INTEGER C The number of samples. N must be a power of 2. N >= 2. C C A (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the first signal. C On exit, this array contains the convolution (if C CONV = 'C') or deconvolution (if CONV = 'D') of the two C signals. C C B (input) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the second signal. C NOTE that this array is overwritten. 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 This routine computes the convolution or deconvolution of two real C signals A and B using an FFT algorithm (SLICOT Library routine C DG01MD). C C REFERENCES C C [1] Rabiner, L.R. and Rader, C.M. C Digital Signal Processing. C IEEE Press, 1972. C C NUMERICAL ASPECTS C C The algorithm requires 0( N*log(N) ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C Supersedes Release 2.0 routine DE01CD by R. Dekeyser, State C University of Gent, Belgium. C C REVISIONS C C - C C KEYWORDS C C Convolution, deconvolution, digital signal processing, fast C Fourier transform, real signals. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF=0.5D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER CONV INTEGER INFO, N C .. Array Arguments .. DOUBLE PRECISION A(*), B(*) C .. Local Scalars .. LOGICAL LCONV INTEGER J, KJ, ND2P1 DOUBLE PRECISION AC, AS, AST, BC, BS, CI, CR C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DG01MD, DLADIV, DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MOD C .. Executable Statements .. C INFO = 0 LCONV = LSAME( CONV, 'C' ) C C Test the input scalar arguments. C IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN INFO = -1 ELSE J = 0 IF( N.GE.2 ) THEN J = N C WHILE ( MOD( J, 2 ).EQ.0 ) DO 10 CONTINUE IF ( MOD( J, 2 ).EQ.0 ) THEN J = J/2 GO TO 10 END IF C END WHILE 10 END IF IF ( J.NE.1 ) INFO = -2 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'DE01OD', -INFO ) RETURN END IF C C Fourier transform. C CALL DG01MD( 'Direct', N, A, B, INFO ) C IF ( LCONV ) THEN AST = A(1)*B(1) ELSE IF ( B(1).EQ.ZERO ) THEN AST = ZERO ELSE AST = A(1)/B(1) END IF END IF C ND2P1 = N/2 + 1 J = ND2P1 C DO 20 KJ = ND2P1, N C C Components of the transform of function A. C AC = HALF*( A(J) + A(KJ) ) AS = HALF*( B(J) - B(KJ) ) C C Components of the transform of function B. C BC = HALF*( B(KJ) + B(J) ) BS = HALF*( A(KJ) - A(J) ) C C Deconvolution by complex division if CONV = 'D'; C Convolution by complex multiplication if CONV = 'C'. C IF ( LCONV ) THEN CR = AC*BC - AS*BS CI = AS*BC + AC*BS ELSE IF ( MAX( ABS( BC ), ABS( BS ) ).EQ.ZERO ) THEN CR = ZERO CI = ZERO ELSE CALL DLADIV( AC, AS, BC, BS, CR, CI ) END IF END IF C A(J) = CR B(J) = CI A(KJ) = CR B(KJ) = -CI J = J - 1 20 CONTINUE A(1) = AST B(1) = ZERO C C Inverse Fourier transform. C CALL DG01MD( 'Inverse', N, A, B, INFO ) C CALL DSCAL( N, ONE/DBLE( N ), A, 1 ) C RETURN C *** Last line of DE01OD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04GD.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04GD.f0000644000175000017500000001636015012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE MB04GD( M, N, A, LDA, JPVT, TAU, DWORK, INFO ) C C PURPOSE C C To compute an RQ factorization with row pivoting of a C real m-by-n matrix A: P*A = R*Q. 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 (LDA,N) C On entry, the m-by-n matrix A. C On exit, C if m <= n, the upper triangle of the subarray C A(1:m,n-m+1:n) contains the m-by-m upper triangular C matrix R; C if m >= n, the elements on and above the (m-n)-th C subdiagonal contain the m-by-n upper trapezoidal matrix R; C the remaining elements, with the array TAU, represent the C orthogonal matrix Q as a product of min(m,n) elementary C reflectors (see METHOD). C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C JPVT (input/output) INTEGER array, dimension (M) C On entry, if JPVT(i) .ne. 0, the i-th row of A is permuted C to the bottom of P*A (a trailing row); if JPVT(i) = 0, C the i-th row of A is a free row. C On exit, if JPVT(i) = k, then the i-th row of P*A C was the k-th row of A. C C TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) C The scalar factors of the elementary reflectors. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (3*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 matrix Q is represented as a product of elementary reflectors C C Q = H(1) H(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] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C The algorithm is backward stable. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. C Based on LAPACK Library routines DGEQPF and DGERQ2. C C REVISIONS C C V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. C C KEYWORDS C C Factorization, matrix algebra, matrix operations, orthogonal C transformation, triangular form. 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, M, N C .. C .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), DWORK( * ), TAU( * ) C .. C .. Local Scalars .. INTEGER I, ITEMP, J, K, MA, MKI, NFREE, NKI, PVT DOUBLE PRECISION AII, TEMP, TEMP2, TOLZ C .. C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL DLAMCH, DNRM2, IDAMAX C .. C .. External Subroutines .. EXTERNAL DGERQ2, DLARF, DLARFG, DORMR2, DSWAP, XERBLA C .. 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 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04GD', -INFO ) RETURN END IF C K = MIN( M, N ) C C Move non-free rows bottom. C ITEMP = M DO 10 I = M, 1, -1 IF( JPVT( I ).NE.0 ) THEN IF( I.NE.ITEMP ) THEN CALL DSWAP( N, A( I, 1 ), LDA, A( ITEMP, 1 ), LDA ) JPVT( I ) = JPVT( ITEMP ) JPVT( ITEMP ) = I ELSE JPVT( I ) = I END IF ITEMP = ITEMP - 1 ELSE JPVT( I ) = I END IF 10 CONTINUE NFREE = M - ITEMP TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) C C Compute the RQ factorization and update remaining rows. C IF( NFREE.GT.0 ) THEN MA = MIN( NFREE, N ) CALL DGERQ2( MA, N, A(M-MA+1,1), LDA, TAU(K-MA+1), DWORK, $ INFO ) CALL DORMR2( 'Right', 'Transpose', M-MA, N, MA, A(M-MA+1,1), $ LDA, TAU(K-MA+1), A, LDA, DWORK, INFO ) END IF C IF( NFREE.LT.K ) THEN C C Initialize partial row norms. The first ITEMP elements of C DWORK store the exact row norms. (Here, ITEMP is the number of C free rows, which have been permuted to be the first ones.) C DO 20 I = 1, ITEMP DWORK( I ) = DNRM2( N-NFREE, A( I, 1 ), LDA ) DWORK( M+I ) = DWORK( I ) 20 CONTINUE C C Compute factorization. C DO 40 I = K-NFREE, 1, -1 C C Determine ith pivot row and swap if necessary. C MKI = M - K + I NKI = N - K + I PVT = IDAMAX( MKI, DWORK, 1 ) C IF( PVT.NE.MKI ) THEN CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) ITEMP = JPVT( PVT ) JPVT( PVT ) = JPVT( MKI ) JPVT( MKI ) = ITEMP DWORK( PVT ) = DWORK( MKI ) DWORK( M+PVT ) = DWORK( M+MKI ) END IF C C Generate elementary reflector H(i) to annihilate C A(m-k+i,1:n-k+i-1), k = min(m,n). C CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) $ ) C C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. C AII = A( MKI, NKI ) A( MKI, NKI ) = ONE CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, $ TAU( I ), A, LDA, DWORK( 2*M+1 ) ) A( MKI, NKI ) = AII C C Update partial row norms. C DO 30 J = 1, MKI - 1 IF( DWORK( J ).NE.ZERO ) THEN TEMP = ABS( A( J, NKI ) ) / DWORK( J ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO ) TEMP2 = TEMP*( DWORK( J ) / DWORK( M+J ) )**2 IF( TEMP2.LE.TOLZ ) THEN DWORK( J ) = DNRM2( NKI-1, A( J, 1 ), LDA ) DWORK( M+J ) = DWORK( J ) ELSE DWORK( J ) = DWORK( J )*SQRT( TEMP ) END IF END IF 30 CONTINUE C 40 CONTINUE END IF C RETURN C *** Last line of MB04GD *** END control-4.1.2/src/slicot/src/PaxHeaders/DG01MD.f0000644000000000000000000000013215012430707016151 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/DG01MD.f0000644000175000017500000001364615012430707017357 0ustar00lilgelilge00000000000000 SUBROUTINE DG01MD( INDI, N, XR, XI, INFO ) C C PURPOSE C C To compute the discrete Fourier transform, or inverse transform, C of a complex signal. C C ARGUMENTS C C Mode Parameters C C INDI CHARACTER*1 C Indicates whether a Fourier transform or inverse Fourier C transform is to be performed as follows: C = 'D': (Direct) Fourier transform; C = 'I': Inverse Fourier transform. C C Input/Output Parameters C C N (input) INTEGER C The number of complex samples. N must be a power of 2. C N >= 2. C C XR (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the real part of either C the complex signal z if INDI = 'D', or f(z) if INDI = 'I'. C On exit, this array contains either the real part of the C computed Fourier transform f(z) if INDI = 'D', or the C inverse Fourier transform z of f(z) if INDI = 'I'. C C XI (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the imaginary part of C either z if INDI = 'D', or f(z) if INDI = 'I'. C On exit, this array contains either the imaginary part of C f(z) if INDI = 'D', or z if INDI = '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 METHOD C C If INDI = 'D', then the routine performs a discrete Fourier C transform on the complex signal Z(i), i = 1,2,...,N. If the result C is denoted by FZ(k), k = 1,2,...,N, then the relationship between C Z and FZ is given by the formula: C C N ((k-1)*(i-1)) C FZ(k) = SUM ( Z(i) * V ), C i=1 C 2 C where V = exp( -2*pi*j/N ) and j = -1. C C If INDI = 'I', then the routine performs an inverse discrete C Fourier transform on the complex signal FZ(k), k = 1,2,...,N. If C the result is denoted by Z(i), i = 1,2,...,N, then the C relationship between Z and FZ is given by the formula: C C N ((k-1)*(i-1)) C Z(i) = SUM ( FZ(k) * W ), C k=1 C C where W = exp( 2*pi*j/N ). C C Note that a discrete Fourier transform, followed by an inverse C discrete Fourier transform, will result in a signal which is a C factor N larger than the original input signal. C C REFERENCES C C [1] Rabiner, L.R. and Rader, C.M. C Digital Signal Processing. C IEEE Press, 1972. C C NUMERICAL ASPECTS C C The algorithm requires 0( N*log(N) ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C Supersedes Release 2.0 routine DG01AD by R. Dekeyser, State C University of Gent, Belgium. C C REVISIONS C C - C C KEYWORDS C C Complex signals, digital signal processing, fast Fourier C transform. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO, EIGHT PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, $ TWO = 2.0D0, EIGHT = 8.0D0 ) C .. Scalar Arguments .. CHARACTER INDI INTEGER INFO, N C .. Array Arguments .. DOUBLE PRECISION XI(*), XR(*) C .. Local Scalars .. LOGICAL LINDI INTEGER I, J, K, L, M DOUBLE PRECISION PI2, TI, TR, WHELP, WI, WR, WSTPI, WSTPR C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC ATAN, DBLE, MOD, SIN C .. Executable Statements .. C INFO = 0 LINDI = LSAME( INDI, 'D' ) C C Test the input scalar arguments. C IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN INFO = -1 ELSE J = 0 IF( N.GE.2 ) THEN J = N C WHILE ( MOD( J, 2 ).EQ.0 ) DO 10 CONTINUE IF ( MOD( J, 2 ).EQ.0 ) THEN J = J/2 GO TO 10 END IF C END WHILE 10 END IF IF ( J.NE.1 ) INFO = -2 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'DG01MD', -INFO ) RETURN END IF C C Inplace shuffling of data. C J = 1 C DO 30 I = 1, N IF ( J.GT.I ) THEN TR = XR(I) TI = XI(I) XR(I) = XR(J) XI(I) = XI(J) XR(J) = TR XI(J) = TI END IF K = N/2 C REPEAT 20 IF ( J.GT.K ) THEN J = J - K K = K/2 IF ( K.GE.2 ) GO TO 20 END IF C UNTIL ( K.LT.2 ) J = J + K 30 CONTINUE C C Transform by decimation in time. C PI2 = EIGHT*ATAN( ONE ) IF ( LINDI ) PI2 = -PI2 C I = 1 C C WHILE ( I.LT.N ) DO C 40 IF ( I.LT.N ) THEN L = 2*I WHELP = PI2/DBLE( L ) WSTPI = SIN( WHELP ) WHELP = SIN( HALF*WHELP ) WSTPR = -TWO*WHELP*WHELP WR = ONE WI = ZERO C DO 60 J = 1, I C DO 50 K = J, N, L M = K + I TR = WR*XR(M) - WI*XI(M) TI = WR*XI(M) + WI*XR(M) XR(M) = XR(K) - TR XI(M) = XI(K) - TI XR(K) = XR(K) + TR XI(K) = XI(K) + TI 50 CONTINUE C WHELP = WR WR = WR + WR*WSTPR - WI*WSTPI WI = WI + WHELP*WSTPI + WI*WSTPR 60 CONTINUE C I = L GO TO 40 C END WHILE 40 END IF C RETURN C *** Last line of DG01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03HZ.f0000644000000000000000000000013215012430707016200 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03HZ.f0000644000175000017500000000532015012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE MB03HZ( S11, S12, H11, H12, CO, SI ) C C PURPOSE C C To compute a unitary matrix Q for a complex regular 2-by-2 C skew-Hamiltonian/Hamiltonian pencil aS - bH with C C ( S11 S12 ) ( H11 H12 ) C S = ( ), H = ( ), C ( 0 S11' ) ( 0 -H11' ) C C such that J Q' J' (aS - bH) Q is upper triangular but the C eigenvalues are in reversed order. The matrix Q is represented by C C ( CO SI ) C Q = ( ). C ( -SI' CO ) C C The notation M' denotes the conjugate transpose of the matrix M. C C ARGUMENTS C C Input/Output Parameters C C S11 (input) COMPLEX*16 C Upper left element of the skew-Hamiltonian matrix S. C C S12 (input) COMPLEX*16 C Upper right element of the skew-Hamiltonian matrix S. C C H11 (input) COMPLEX*16 C Upper left element of the Hamiltonian matrix H. C C H12 (input) COMPLEX*16 C Upper right element of the Hamiltonian matrix H. C C CO (output) DOUBLE PRECISION C Upper left element of Q. C C SI (output) COMPLEX*16 C Upper right element of Q. C C METHOD C C The algorithm uses unitary transformations as described on page 43 C in [1]. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, January 28, 2009. C C REVISIONS C C V. Sima, Aug. 2009 (SLICOT version of the routine ZHAUEX). C V. Sima, Jan. 2010. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue exchange, skew-Hamiltonian/Hamiltonian pencil, upper C triangular matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D+0 ) C C .. Scalar Arguments .. DOUBLE PRECISION CO COMPLEX*16 H11, H12, S11, S12, SI C C .. Local Scalars .. COMPLEX*16 G, TMP C C .. External Subroutines .. EXTERNAL ZLARTG C C .. Intrinsic Functions .. INTRINSIC DBLE, DCONJG C C .. Executable Statements .. C G = TWO*DBLE( H11*DCONJG( S11 ) ) CALL ZLARTG( DCONJG( S11 )*H12 + S12*DCONJG( H11 ), G, CO, SI, $ TMP ) C RETURN C *** Last line of MB03HZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02MZ.f0000644000000000000000000000013215012430707016203 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02MZ.f0000644000175000017500000001365515012430707017411 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION MA02MZ( NORM, UPLO, N, A, LDA, DWORK ) C C PURPOSE C C To compute the value of the one norm, or the Frobenius norm, or C the infinity norm, or the element of largest absolute value C of a complex skew-Hermitian matrix. C C Note that for this kind of matrices the infinity norm is equal C to the one norm. C C FUNCTION VALUE C C MA02MZ DOUBLE PRECISION C The computed norm. C C ARGUMENTS C C Mode Parameters C C NORM CHARACTER*1 C Specifies the value to be returned in MA02MZ: C = '1' or 'O': one norm of A; C = 'F' or 'E': Frobenius norm of A; C = 'I': infinity norm of A; C = 'M': max(abs(A(i,j)). C C UPLO CHARACTER*1 C Specifies whether the upper or lower triangular part of C the skew-Hermitian matrix A is to be referenced. C = 'U': Upper triangular part of A is referenced; C = 'L': Lower triangular part of A is referenced. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. When N = 0, MA02MZ is C set to zero. C C A (input) COMPLEX*16 array, dimension (LDA,N) C The skew-Hermitian matrix A. If UPLO = 'U', the leading C N-by-N upper triangular part of A contains the upper C triangular part of the matrix A, and the strictly lower C triangular part of A is not referenced. If UPLO = 'L', the C leading N-by-N lower triangular part of A contains the C lower triangular part of the matrix A, and the strictly C upper triangular part of A is not referenced. C The real parts of the diagonal elements of A need not be C set and are assumed to be zero. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)), C where LDWORK >= N when NORM = 'I' or '1' or 'O'; C otherwise, DWORK is not referenced. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2015. C Based on LAPACK reference routine DLANSY. C C REVISIONS C C V. Sima, Jan. 2016. C C KEYWORDS C C Elementary matrix operations, skew-Hermitian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO, ZERO PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N C .. C .. Array Arguments .. DOUBLE PRECISION DWORK( * ) COMPLEX*16 A( LDA, * ) C .. C .. Local Scalars .. INTEGER I, J DOUBLE PRECISION ABSA, SCALE, SUM, VALUE C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL ZLASSQ C .. C .. Intrinsic Functions .. INTRINSIC ABS, DIMAG, MAX, SQRT C .. C .. Executable Statements .. C IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN C C Find max(abs(A(i,j))). C VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, J-1 VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE VALUE = MAX( VALUE, ABS( DIMAG( A( J, J ) ) ) ) 20 CONTINUE ELSE DO 40 J = 1, N VALUE = MAX( VALUE, ABS( DIMAG( A( J, J ) ) ) ) DO 30 I = J+1, N VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 30 CONTINUE 40 CONTINUE END IF C ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN C C Find normI(A) ( = norm1(A), since A is skew-Hermitian). C VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N SUM = ZERO DO 50 I = 1, J-1 ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA DWORK( I ) = DWORK( I ) + ABSA 50 CONTINUE DWORK( J ) = SUM + ABS( DIMAG( A( J, J ) ) ) 60 CONTINUE DO 70 I = 1, N VALUE = MAX( VALUE, DWORK( I ) ) 70 CONTINUE ELSE DO 80 I = 1, N DWORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N SUM = DWORK( J ) + ABS( DIMAG( A( J, J ) ) ) DO 90 I = J+1, N ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA DWORK( I ) = DWORK( I ) + ABSA 90 CONTINUE VALUE = MAX( VALUE, SUM ) 100 CONTINUE VALUE = MAX( VALUE, DWORK( N ) ) END IF C ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN C C Find normF(A). C SCALE = ZERO SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N-1 CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF SUM = TWO*SUM DO 130 I = 1, N IF( DIMAG( A( I, I ) ).NE.ZERO ) THEN ABSA = ABS( DIMAG( A( I, I ) ) ) IF( SCALE.LT.ABSA ) THEN SUM = ONE + SUM*( SCALE / ABSA )**2 SCALE = ABSA ELSE SUM = SUM + ( ABSA / SCALE )**2 END IF END IF 130 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF C MA02MZ = VALUE RETURN C C *** Last line of MA02MZ *** END control-4.1.2/src/slicot/src/PaxHeaders/UD01DD.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/UD01DD.f0000644000175000017500000000577215012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE UD01DD( M, N, NIN, A, LDA, INFO ) C C PURPOSE C C To read the elements of a sparse matrix. 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 NIN (input) INTEGER C The input channel from which the elements of A are read. C NIN >= 0. C C A (output) DOUBLE PRECISION array, dimension (LDA,N) C The leading M-by-N part of this array contains the sparse C matrix A. The not assigned elements are set to zero. C C LDA INTEGER C The leading dimension of array A. LDA >= 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 = 1 : if a row index i is read with i < 1 or i > M or C a column index j is read with j < 1 or j > N. C This is a warning. C C METHOD C C First, the elements A(i,j) with 1 <= i <= M and 1 <= j <= N are C set to zero. Next the nonzero elements are read from the input C file NIN. Each line of NIN must contain consecutively the values C i, j, A(i,j). The routine terminates after the last line has been C read. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. C Based on routine RDSPAR by A.J. Geurts, Eindhoven University of C Technology, Holland. C C REVISIONS C C - C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, M, N, NIN C .. Array Arguments .. DOUBLE PRECISION A(LDA,*) C .. Local Scalars .. INTEGER I, J DOUBLE PRECISION AIJ C .. External Subroutines .. EXTERNAL DLASET, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable statements .. C INFO = 0 C C Check the input scalar arguments. C IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NIN.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'UD01DD', -INFO ) RETURN END IF C CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) C C Read (i, j, A(i,j)) of the nonzero elements one by one. C 10 READ( NIN, FMT = *, END = 20 ) I, J, AIJ IF ( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN INFO = 1 ELSE A(I,J) = AIJ END IF GO TO 10 20 CONTINUE C RETURN C *** Last line of UD01DD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB16CY.f0000644000000000000000000000013215012430707016204 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB16CY.f0000644000175000017500000003105315012430707017402 0ustar00lilgelilge00000000000000 SUBROUTINE SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC, $ F, LDF, G, LDG, SCALEC, SCALEO, S, LDS, R, LDR, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute, for a given open-loop model (A,B,C,0), and for C given state feedback gain F and full observer gain G, C such that A+B*F and A+G*C are stable, the Cholesky factors C Su and Ru of a controllability Grammian P = Su*Su' and of C an observability Grammian Q = Ru'*Ru corresponding to a C frequency-weighted model reduction of the left or right coprime C factors of the state-feedback controller. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of the open-loop system as follows: C = 'C': continuous-time system; C = 'D': discrete-time system. C C JOBCF CHARACTER*1 C Specifies whether a left or right coprime factorization C of the state-feedback controller is to be used as follows: C = 'L': use a left coprime factorization; C = 'R': use a right coprime factorization. C C Input/Output Parameters C C N (input) INTEGER C The order of the open-loop state-space representation, C i.e., the order of the 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 matrix A of the open-loop 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 open-loop 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 open-loop system. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C F (input) DOUBLE PRECISION array, dimension (LDF,N) C The leading M-by-N part of this array must contain a C stabilizing state feedback matrix. C C LDF INTEGER C The leading dimension of array F. LDF >= MAX(1,M). C C G (input) DOUBLE PRECISION array, dimension (LDG,P) C The leading N-by-P part of this array must contain a C stabilizing observer gain matrix. C C LDG INTEGER C The leading dimension of array G. LDG >= MAX(1,N). C C SCALEC (output) DOUBLE PRECISION C Scaling factor for the controllability Grammian. C See METHOD. C C SCALEO (output) DOUBLE PRECISION C Scaling factor for the observability Grammian. C See METHOD. C C S (output) DOUBLE PRECISION array, dimension (LDS,N) C The leading N-by-N upper triangular part of this array C contains the Cholesky factor Su of frequency-weighted C cotrollability Grammian P = Su*Su'. See METHOD. C C LDS INTEGER C The leading dimension of the array S. LDS >= MAX(1,N). C C R (output) DOUBLE PRECISION array, dimension (LDR,N) C The leading N-by-N upper triangular part of this array C contains the Cholesky factor Ru of the frequency-weighted C observability Grammian Q = Ru'*Ru. See METHOD. C C LDR INTEGER C The leading dimension of the array R. LDR >= MAX(1,N). 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 length of the array DWORK. C LDWORK >= MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)), C if JOBCF = 'L'; C LDWORK >= MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)), C if JOBCF = 'R'. C For optimum performance LDWORK should be larger. C An upper bound for both cases is C LDWORK >= MAX(1, N*(N + MAX(N,M,P) + 7)). 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: eigenvalue computation failure; C = 2: the matrix A+G*C is not stable; C = 3: the matrix A+B*F is not stable; C = 4: the Lyapunov equation for computing the C observability Grammian is (nearly) singular; C = 5: the Lyapunov equation for computing the C controllability Grammian is (nearly) singular. C C METHOD C C In accordance with the type of the coprime factorization C of the controller (left or right), the Cholesky factors Su and Ru C of the frequency-weighted controllability Grammian P = Su*Su' and C of the frequency-weighted observability Grammian Q = Ru'*Ru are C computed by solving appropriate Lyapunov or Stein equations [1]. C C If JOBCF = 'L' and DICO = 'C', P and Q are computed as the C solutions of the following Lyapunov equations: C C (A+B*F)*P + P*(A+B*F)' + scalec^2*B*B' = 0, (1) C C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*F'*F = 0. (2) C C If JOBCF = 'L' and DICO = 'D', P and Q are computed as the C solutions of the following Stein equations: C C (A+B*F)*P*(A+B*F)' - P + scalec^2*B*B' = 0, (3) C C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*F'*F = 0. (4) C C If JOBCF = 'R' and DICO = 'C', P and Q are computed as the C solutions of the following Lyapunov equations: C C (A+B*F)*P + P*(A+B*F)' + scalec^2*G*G' = 0, (5) C C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*C'*C = 0. (6) C C If JOBCF = 'R' and DICO = 'D', P and Q are computed as the C solutions of the following Stein equations: C C (A+B*F)*P*(A+B*F)' - P + scalec^2*G*G' = 0, (7) C C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*C'*C = 0. (8) C C REFERENCES C C [1] Liu, Y., Anderson, B.D.O. and Ly, O.L. C Coprime factorization controller reduction with Bezout C identity induced frequency weighting. C Automatica, vol. 26, pp. 233-249, 1990. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000. C D. Sima, University of Bucharest, October 2000. C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000. C C REVISIONS C C A. Varga, Australian National University, Canberra, November 2000. C C KEYWORDS C C Controller reduction, frequency weighting, multivariable system, C state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOBCF INTEGER INFO, LDA, LDB, LDC, LDF, LDG, LDR, LDS, LDWORK, $ M, N, P DOUBLE PRECISION SCALEC, SCALEO C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), $ F(LDF,*), G(LDG,*), R(LDR,*), S(LDS,*) C .. Local Scalars .. LOGICAL DISCR, LEFTW INTEGER IERR, KAW, KU, KW, KWI, KWR, LDU, LW, ME, MP, $ WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, SB03OD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C DISCR = LSAME( DICO, 'D' ) LEFTW = LSAME( JOBCF, 'L' ) C INFO = 0 IF( LEFTW ) THEN MP = M ELSE MP = P END IF LW = N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 ) C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT.( LEFTW .OR. LSAME( JOBCF, 'R' ) ) ) 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( LDF.LT.MAX( 1, M ) ) THEN INFO = -13 ELSE IF( LDG.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -19 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -21 ELSE IF( LDWORK.LT.MAX( 1, LW ) ) THEN INFO = -23 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB16CY', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN SCALEC = ONE SCALEO = ONE DWORK(1) = ONE RETURN END IF C C Allocate storage for work arrays. C KAW = 1 KU = KAW + N*N KWR = KU + N*MAX( N, MP ) KWI = KWR + N KW = KWI + N C C Form A+G*C. C CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N ) CALL DGEMM( 'No-transpose', 'No-transpose', N, N, P, ONE, $ G, LDG, C, LDC, ONE, DWORK(KAW), N ) C C Form the factor H of the free term. C IF( LEFTW ) THEN C C H = F. C LDU = MAX( N, M ) ME = M CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KU), LDU ) ELSE C C H = C. C LDU = MAX( N, P ) ME = P CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), LDU ) END IF C C Solve for the Cholesky factor Ru of Q, Q = Ru'*Ru, C the continuous-time Lyapunov equation (if DICO = 'C') C C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*H'*H = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*H'*H = 0. C C Workspace: need N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L'; C N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'. C prefer larger. C CALL SB03OD( DICO, 'NoFact', 'NoTransp', N, ME, DWORK(KAW), N, $ R, LDR, DWORK(KU), LDU, SCALEO, DWORK(KWR), $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.2 ) THEN INFO = 2 ELSE IF( IERR.EQ.1 ) THEN INFO = 4 ELSE IF( IERR.EQ.6 ) THEN INFO = 1 END IF RETURN END IF C WRKOPT = INT( DWORK(KW) ) + KW - 1 CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, R, LDR ) C C Form A+B*F. C CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N ) CALL DGEMM( 'No-transpose', 'No-transpose', N, N, M, ONE, $ B, LDB, F, LDF, ONE, DWORK(KAW), N ) C C Form the factor K of the free term. C LDU = N IF( LEFTW ) THEN C C K = B. C ME = M CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), LDU ) ELSE C C K = G. C ME = P CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KU), LDU ) END IF C C Solve for the Cholesky factor Su of P, P = Su*Su', C the continuous-time Lyapunov equation (if DICO = 'C') C C (A+B*F)*P + P*(A+B*F)' + scalec^2*K*K' = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C C (A+B*F)*P*(A+B*F)' - P + scalec^2*K*K' = 0. C C Workspace: need N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L'; C N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'. C prefer larger. C CALL SB03OD( DICO, 'NoFact', 'Transp', N, ME, DWORK(KAW), N, $ S, LDS, DWORK(KU), LDU, SCALEC, DWORK(KWR), $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.2 ) THEN INFO = 3 ELSE IF( IERR.EQ.1 ) THEN INFO = 5 ELSE IF( IERR.EQ.6 ) THEN INFO = 1 END IF RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, S, LDS ) C C Save the optimal workspace. C DWORK(1) = WRKOPT C RETURN C *** Last line of SB16CY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02SD.f0000644000000000000000000000013215012430707016164 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02SD.f0000644000175000017500000000752115012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE MB02SD( N, H, LDH, IPIV, INFO ) C C PURPOSE C C To compute an LU factorization of an n-by-n upper Hessenberg C matrix H using partial pivoting with row interchanges. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix H. N >= 0. C C H (input/output) DOUBLE PRECISION array, dimension (LDH,N) C On entry, the n-by-n upper Hessenberg matrix to be C factored. C On exit, the factors L and U from the factorization C H = P*L*U; the unit diagonal elements of L are not stored, C and L is lower bidiagonal. C C LDH INTEGER C The leading dimension of the array H. LDH >= max(1,N). C C IPIV (output) INTEGER array, dimension (N) C The pivot indices; for 1 <= i <= N, row i of the matrix C was interchanged with row IPIV(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 > 0: if INFO = i, U(i,i) is exactly zero. The C factorization has been completed, but the factor U C is exactly singular, and division by zero will occur C if it is used to solve a system of equations. C C METHOD C C The factorization has the form C H = P * L * U C where P is a permutation matrix, L is lower triangular with unit C diagonal elements (and one nonzero subdiagonal), and U is upper C triangular. C C This is the right-looking Level 1 BLAS version of the algorithm C (adapted after DGETF2). C C REFERENCES C C - C C NUMERICAL ASPECTS C 2 C The algorithm requires 0( N ) operations. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, C Jan. 2005. C C KEYWORDS C C Hessenberg form, matrix algebra. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. Scalar Arguments .. INTEGER INFO, LDH, N C .. Array Arguments .. INTEGER IPIV(*) DOUBLE PRECISION H(LDH,*) C .. Local Scalars .. INTEGER J, JP C .. External Subroutines .. EXTERNAL DAXPY, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02SD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C DO 10 J = 1, N C C Find pivot and test for singularity. C JP = J IF ( J.LT.N ) THEN IF ( ABS( H( J+1, J ) ).GT.ABS( H( J, J ) ) ) $ JP = J + 1 END IF IPIV( J ) = JP IF( H( JP, J ).NE.ZERO ) THEN C C Apply the interchange to columns J:N. C IF( JP.NE.J ) $ CALL DSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH ) C C Compute element J+1 of J-th column. C IF( J.LT.N ) $ H( J+1, J ) = H( J+1, J )/H( J, J ) C ELSE IF( INFO.EQ.0 ) THEN C INFO = J END IF C IF( J.LT.N ) THEN C C Update trailing submatrix. C CALL DAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH, $ H( J+1, J+1 ), LDH ) END IF 10 CONTINUE RETURN C *** Last line of MB02SD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03PD.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB03PD.f0000644000175000017500000003226015012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE SB03PD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, $ SCALE, SEPD, FERR, WR, WI, IWORK, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To solve the real discrete Lyapunov matrix equation C C op(A)'*X*op(A) - X = scale*C C C and/or estimate the quantity, called separation, C C sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X) C 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 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 On exit, if INFO = 0 or INFO = N+1, the leading N-by-N C part of this array contains the upper quasi-triangular C matrix in Schur canonical form from the Shur factorization C of A. The contents of array A is not modified if C 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 it must contain the orthogonal matrix U from the real C 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 SEPD (output) DOUBLE PRECISION C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, C SEPD contains the estimate in the 1-norm of C sepd(op(A),op(A)'). C If JOB = 'X' or N = 0, SEPD is not referenced. C C FERR (output) DOUBLE PRECISION C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains C an 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 the C 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 >= MAX(N*N,2*N); C If FACT = 'N', LDWORK >= MAX(N*N,3*N). C If JOB = 'S' or JOB = 'B' then C LDWORK >= 2*N*N + 2*N. 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 matrix A has almost reciprocal eigenvalues; C perturbed values were used to solve the equation C (but the matrix A is unchanged). C C METHOD C C After reducing matrix A to real Schur canonical form (if needed), C a discrete-time version of the Bartels-Stewart algorithm is used. C A set of equivalent linear algebraic systems of equations of order C at most four are formed and solved using Gaussian elimination with C complete pivoting. 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 NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C FURTHER COMMENTS C C SEPD is defined as C C sepd( 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( op(A)', op(A)' ) - I(N**2). C C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the C Kronecker product. The program estimates sigma_min(T) by the C reciprocal of an estimate of the 1-norm of inverse(T). The true C reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by C more than a factor of N. C C When SEPD 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)**2 / SEPD C C where EPS is the machine precision. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. C Supersedes Release 2.0 routine MB03AD by Control Systems Research C Group, Kingston Polytechnic, United Kingdom, October 1982. C Based on DGELPD by P. Petkov, Tech. University of Sofia, September C 1993. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, May 2020. 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.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER FACT, JOB, TRANA INTEGER INFO, LDA, LDC, LDU, LDWORK, N DOUBLE PRECISION FERR, SCALE, SEPD C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), $ U( LDU, * ), WI( * ), WR( * ) C .. C .. Local Scalars .. LOGICAL NOFACT, NOTA, WANTBH, WANTSP, WANTX CHARACTER NOTRA, UPLO INTEGER I, IERR, KASE, LWA, MINWRK, SDIM DOUBLE PRECISION EST, SCALEF C .. C .. Local Arrays .. LOGICAL BWORK( 1 ) INTEGER ISAVE( 3 ) C .. C .. External Functions .. LOGICAL LSAME, SELECT DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS, LSAME, SELECT C .. C .. External Subroutines .. EXTERNAL DCOPY, DGEES, DLACN2, MB01RD, SB03MX, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX C .. C .. Executable Statements .. C C Decode and Test input parameters. C WANTX = LSAME( JOB, 'X' ) WANTSP = LSAME( JOB, 'S' ) WANTBH = LSAME( JOB, 'B' ) NOFACT = LSAME( FACT, 'N' ) NOTA = LSAME( TRANA, 'N' ) C INFO = 0 IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN INFO = -1 ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN INFO = -2 ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. $ .NOT.LSAME( TRANA, 'C' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDU.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( WANTSP .AND. LDC.LT.1 .OR. $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN INFO = -10 END IF C C Compute workspace. C IF( WANTX ) THEN IF( NOFACT ) THEN MINWRK = MAX( N*N, 3*N ) ELSE MINWRK = MAX( N*N, 2*N ) END IF ELSE MINWRK = 2*N*N + 2*N END IF IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN INFO = -18 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03PD', -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 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: need N*N. C UPLO = 'U' CALL MB01RD( UPLO, 'Transpose', 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 C Solve the transformed equation. C Workspace: 2*N. C CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) IF( INFO.GT.0 ) $ INFO = N + 1 C C Transform back the solution. C CALL MB01RD( UPLO, 'No transpose', N, N, ZERO, ONE, C, LDC, U, $ LDU, C, LDC, DWORK, LDWORK, INFO ) 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 sepd(op(A),op(A)'). C Workspace: 2*N*N + 2*N. C IF( NOTA ) THEN NOTRA = 'T' ELSE NOTRA = 'N' END IF C EST = ZERO KASE = 0 C REPEAT 30 CONTINUE CALL DLACN2( N*N, DWORK( N*N+1 ), DWORK, IWORK, EST, KASE, $ ISAVE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF, $ DWORK( 2*N*N + 1 ), IERR ) ELSE CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF, $ DWORK( 2*N*N + 1 ), IERR ) END IF GO TO 30 END IF C UNTIL KASE = 0 C SEPD = SCALEF / EST C IF( WANTBH ) THEN C C Compute the estimate of the relative error. C FERR = DLAMCH( 'Precision' )* $ DLANHS( 'Frobenius', N, A, LDA, DWORK )**2 / SEPD END IF END IF C DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) C RETURN C *** Last line of SB03PD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01ZD.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01ZD.f0000644000175000017500000003360215012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE MB01ZD( SIDE, UPLO, TRANST, DIAG, M, N, L, ALPHA, T, $ LDT, H, LDH, INFO ) C C PURPOSE C C To compute the matrix product C C H := alpha*op( T )*H, or H := alpha*H*op( T ), C C where alpha is a scalar, H is an m-by-n upper or lower C Hessenberg-like matrix (with l nonzero subdiagonals or C superdiagonals, respectively), T is a unit, or non-unit, C upper or lower triangular matrix, and op( T ) is one of C C op( T ) = T or op( T ) = T'. C C ARGUMENTS C C Mode Parameters C C SIDE CHARACTER*1 C Specifies whether the triangular matrix T appears on the C left or right in the matrix product, as follows: C = 'L': the product alpha*op( T )*H is computed; C = 'R': the product alpha*H*op( T ) is computed. C C UPLO CHARACTER*1 C Specifies the form of the matrices T and H, as follows: C = 'U': the matrix T is upper triangular and the matrix H C is upper Hessenberg-like; C = 'L': the matrix T is lower triangular and the matrix H C is lower Hessenberg-like. C C TRANST CHARACTER*1 C Specifies the form of op( T ) to be used, as follows: C = 'N': op( T ) = T; C = 'T': op( T ) = T'; C = 'C': op( T ) = T'. C C DIAG CHARACTER*1. C Specifies whether or not T is unit triangular, as follows: C = 'U': the matrix T is assumed to be unit triangular; C = 'N': the matrix T is not assumed to be unit triangular. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of H. M >= 0. C C N (input) INTEGER C The number of columns of H. N >= 0. C C L (input) INTEGER C If UPLO = 'U', matrix H has L nonzero subdiagonals. C If UPLO = 'L', matrix H has L nonzero superdiagonals. C MAX(0,M-1) >= L >= 0, if UPLO = 'U'; C MAX(0,N-1) >= L >= 0, if UPLO = 'L'. C C ALPHA (input) DOUBLE PRECISION C The scalar alpha. When alpha is zero then T is not C referenced and H need not be set before entry. C C T (input) DOUBLE PRECISION array, dimension (LDT,k), where C k is m when SIDE = 'L' and is n when SIDE = 'R'. C If UPLO = 'U', the leading k-by-k upper triangular part C of this array must contain the upper triangular matrix T C and the strictly lower triangular part is not referenced. C If UPLO = 'L', the leading k-by-k lower triangular part C of this array must contain the lower triangular matrix T C and the strictly upper triangular part is not referenced. C Note that when DIAG = 'U', the diagonal elements of T are C not referenced either, but are assumed to be unity. C C LDT INTEGER C The leading dimension of array T. C LDT >= MAX(1,M), if SIDE = 'L'; C LDT >= MAX(1,N), if SIDE = 'R'. C C H (input/output) DOUBLE PRECISION array, dimension (LDH,N) C On entry, if UPLO = 'U', the leading M-by-N upper C Hessenberg part of this array must contain the upper C Hessenberg-like matrix H. C On entry, if UPLO = 'L', the leading M-by-N lower C Hessenberg part of this array must contain the lower C Hessenberg-like matrix H. C On exit, the leading M-by-N part of this array contains C the matrix product alpha*op( T )*H, if SIDE = 'L', C or alpha*H*op( T ), if SIDE = 'R'. If TRANST = 'N', this C product has the same pattern as the given matrix H; C the elements below the L-th subdiagonal (if UPLO = 'U'), C or above the L-th superdiagonal (if UPLO = 'L'), are not C referenced in this case. If TRANST = 'T', the elements C below the (N+L)-th row (if UPLO = 'U', SIDE = 'R', and C M > N+L), or at the right of the (M+L)-th column C (if UPLO = 'L', SIDE = 'L', and N > M+L), are not set to C zero nor referenced. C C LDH INTEGER C The leading dimension of array H. LDH >= 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 calculations are efficiently performed taking the problem C structure into account. C C FURTHER COMMENTS C C The matrix H may have the following patterns, when m = 7, n = 6, C and l = 2 are used for illustration: C C UPLO = 'U' UPLO = 'L' C C [ x x x x x x ] [ x x x 0 0 0 ] C [ x x x x x x ] [ x x x x 0 0 ] C [ x x x x x x ] [ x x x x x 0 ] C H = [ 0 x x x x x ], H = [ x x x x x x ]. C [ 0 0 x x x x ] [ x x x x x x ] C [ 0 0 0 x x x ] [ x x x x x x ] C [ 0 0 0 0 x x ] [ x x x x x x ] C C The products T*H or H*T have the same pattern as H, but the C products T'*H or H*T' may be full matrices. C C If m = n, the matrix H is upper or lower triangular, for l = 0, C and upper or lower Hessenberg, for l = 1. C C This routine is a specialization of the BLAS 3 routine DTRMM. C BLAS 1 calls are used when appropriate, instead of in-line code, C in order to increase the efficiency. If the matrix H is full, or C its zero triangle has small order, an optimized DTRMM code could C be faster than MB01ZD. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. C .. Scalar Arguments .. CHARACTER DIAG, SIDE, TRANST, UPLO INTEGER INFO, L, LDH, LDT, M, N DOUBLE PRECISION ALPHA C .. C .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), T( LDT, * ) C .. C .. Local Scalars .. LOGICAL LSIDE, NOUNIT, TRANS, UPPER INTEGER I, I1, I2, J, K, M2, NROWT DOUBLE PRECISION TEMP C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL DDOT, LSAME C .. C .. External Subroutines .. EXTERNAL DAXPY, DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the input scalar arguments. C LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) TRANS = LSAME( TRANST, 'T' ) .OR. LSAME( TRANST, 'C' ) NOUNIT = LSAME( DIAG, 'N' ) IF( LSIDE )THEN NROWT = M ELSE NROWT = N END IF C IF( UPPER )THEN M2 = M ELSE M2 = N END IF C INFO = 0 IF( .NOT.( LSIDE .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( TRANS .OR. LSAME( TRANST, 'N' ) ) ) THEN INFO = -3 ELSE IF( .NOT.( NOUNIT .OR. LSAME( DIAG, 'U' ) ) ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( L.LT.0 .OR. L.GT.MAX( 0, M2-1 ) ) THEN INFO = -7 ELSE IF( LDT.LT.MAX( 1, NROWT ) ) THEN INFO = -10 ELSE IF( LDH.LT.MAX( 1, M ) )THEN INFO = -12 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01ZD', -INFO ) RETURN END IF C C Quick return, if possible. C IF( MIN( M, N ).EQ.0 ) $ RETURN C C Also, when alpha = 0. C IF( ALPHA.EQ.ZERO ) THEN C DO 20, J = 1, N IF( UPPER ) THEN I1 = 1 I2 = MIN( J+L, M ) ELSE I1 = MAX( 1, J-L ) I2 = M END IF C DO 10, I = I1, I2 H( I, J ) = ZERO 10 CONTINUE C 20 CONTINUE C RETURN END IF C C Start the operations. C IF( LSIDE )THEN IF( .NOT.TRANS ) THEN C C Form H := alpha*T*H. C IF( UPPER ) THEN C DO 40, J = 1, N C DO 30, K = 1, MIN( J+L, M ) IF( H( K, J ).NE.ZERO ) THEN TEMP = ALPHA*H( K, J ) CALL DAXPY ( K-1, TEMP, T( 1, K ), 1, H( 1, J ), $ 1 ) IF( NOUNIT ) $ TEMP = TEMP*T( K, K ) H( K, J ) = TEMP END IF 30 CONTINUE C 40 CONTINUE C ELSE C DO 60, J = 1, N C DO 50 K = M, MAX( 1, J-L ), -1 IF( H( K, J ).NE.ZERO ) THEN TEMP = ALPHA*H( K, J ) H( K, J ) = TEMP IF( NOUNIT ) $ H( K, J ) = H( K, J )*T( K, K ) CALL DAXPY ( M-K, TEMP, T( K+1, K ), 1, $ H( K+1, J ), 1 ) END IF 50 CONTINUE C 60 CONTINUE C END IF C ELSE C C Form H := alpha*T'*H. C IF( UPPER ) THEN C DO 80, J = 1, N I1 = J + L C DO 70, I = M, 1, -1 IF( I.GT.I1 ) THEN TEMP = DDOT( I1, T( 1, I ), 1, H( 1, J ), 1 ) ELSE TEMP = H( I, J ) IF( NOUNIT ) $ TEMP = TEMP*T( I, I ) TEMP = TEMP + DDOT( I-1, T( 1, I ), 1, $ H( 1, J ), 1 ) END IF H( I, J ) = ALPHA*TEMP 70 CONTINUE C 80 CONTINUE C ELSE C DO 100, J = 1, MIN( M+L, N ) I1 = J - L C DO 90, I = 1, M IF( I.LT.I1 ) THEN TEMP = DDOT( M-I1+1, T( I1, I ), 1, H( I1, J ), $ 1 ) ELSE TEMP = H( I, J ) IF( NOUNIT ) $ TEMP = TEMP*T( I, I ) TEMP = TEMP + DDOT( M-I, T( I+1, I ), 1, $ H( I+1, J ), 1 ) END IF H( I, J ) = ALPHA*TEMP 90 CONTINUE C 100 CONTINUE C END IF C END IF C ELSE C IF( .NOT.TRANS ) THEN C C Form H := alpha*H*T. C IF( UPPER ) THEN C DO 120, J = N, 1, -1 I2 = MIN( J+L, M ) TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*T( J, J ) CALL DSCAL ( I2, TEMP, H( 1, J ), 1 ) C DO 110, K = 1, J - 1 CALL DAXPY ( I2, ALPHA*T( K, J ), H( 1, K ), 1, $ H( 1, J ), 1 ) 110 CONTINUE C 120 CONTINUE C ELSE C DO 140, J = 1, N I1 = MAX( 1, J-L ) TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*T( J, J ) CALL DSCAL ( M-I1+1, TEMP, H( I1, J ), 1 ) C DO 130, K = J + 1, N CALL DAXPY ( M-I1+1, ALPHA*T( K, J ), H( I1, K ), $ 1, H( I1, J ), 1 ) 130 CONTINUE C 140 CONTINUE C END IF C ELSE C C Form H := alpha*H*T'. C IF( UPPER ) THEN M2 = MIN( N+L, M ) C DO 170, K = 1, N I1 = MIN( K+L, M ) I2 = MIN( K+L, M2 ) C DO 160, J = 1, K - 1 IF( T( J, K ).NE.ZERO ) THEN TEMP = ALPHA*T( J, K ) CALL DAXPY ( I1, TEMP, H( 1, K ), 1, H( 1, J ), $ 1 ) C DO 150, I = I1 + 1, I2 H( I, J ) = TEMP*H( I, K ) 150 CONTINUE C END IF 160 CONTINUE C TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*T( K, K ) IF( TEMP.NE.ONE ) $ CALL DSCAL( I2, TEMP, H( 1, K ), 1 ) 170 CONTINUE C ELSE C DO 200, K = N, 1, -1 I1 = MAX( 1, K-L ) I2 = MAX( 1, K-L+1 ) M2 = MIN( M, I2-1 ) C DO 190, J = K + 1, N IF( T( J, K ).NE.ZERO ) THEN TEMP = ALPHA*T( J, K ) CALL DAXPY ( M-I2+1, TEMP, H( I2, K ), 1, $ H( I2, J ), 1 ) C DO 180, I = I1, M2 H( I, J ) = TEMP*H( I, K ) 180 CONTINUE C END IF 190 CONTINUE C TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*T( K, K ) IF( TEMP.NE.ONE ) $ CALL DSCAL( M-I1+1, TEMP, H( I1, K ), 1 ) 200 CONTINUE C END IF C END IF C END IF C RETURN C C *** Last line of MB01ZD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03OT.f0000644000000000000000000000013215012430707016207 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB03OT.f0000644000175000017500000010603315012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE SB03OT( DISCR, LTRANS, N, S, LDS, R, LDR, SCALE, DWORK, $ INFO ) C C PURPOSE C C To solve for X = op(U)'*op(U) either the stable non-negative C definite continuous-time Lyapunov equation C 2 C op(S)'*X + X*op(S) = -scale *op(R)'*op(R) (1) C C or the convergent non-negative definite discrete-time Lyapunov C equation C 2 C op(S)'*X*op(S) - X = -scale *op(R)'*op(R) (2) C C where op(K) = K or K' (i.e., the transpose of the matrix K), S is C an N-by-N block upper triangular matrix with one-by-one or C two-by-two blocks on the diagonal, R is an N-by-N upper triangular C matrix, and scale is an output scale factor, set less than or C equal to 1 to avoid overflow in X. C C In the case of equation (1) the matrix S must be stable (that C is, all the eigenvalues of S must have negative real parts), C and for equation (2) the matrix S must be convergent (that is, C all the eigenvalues of S must lie inside the unit circle). C C ARGUMENTS C C Mode Parameters C C DISCR LOGICAL C Specifies the type of Lyapunov equation to be solved as C follows: C = .TRUE. : Equation (2), discrete-time case; C = .FALSE.: Equation (1), continuous-time case. C C LTRANS LOGICAL C Specifies the form of op(K) to be used, as follows: C = .FALSE.: op(K) = K (No transpose); C = .TRUE. : op(K) = K**T (Transpose). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices S and R. N >= 0. C C S (input) DOUBLE PRECISION array of dimension (LDS,N) C The leading N-by-N upper Hessenberg part of this array C must contain the block upper triangular matrix. C The elements below the upper Hessenberg part of the array C S are not referenced. The 2-by-2 blocks must only C correspond to complex conjugate pairs of eigenvalues (not C to real eigenvalues). C C LDS INTEGER C The leading dimension of array S. LDS >= MAX(1,N). C C R (input/output) DOUBLE PRECISION array of 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 array contains the upper triangular matrix U. C The strict lower triangle of R is not referenced. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). 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 Workspace C C DWORK DOUBLE PRECISION array, dimension (4*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 Lyapunov equation is (nearly) singular C (warning indicator); C if DISCR = .FALSE., this means that while the C matrix S has computed eigenvalues with negative real C parts, it is only just stable in the sense that C small perturbations in S can make one or more of the C eigenvalues have a non-negative real part; C if DISCR = .TRUE., this means that while the C matrix S has computed eigenvalues inside the unit C circle, it is nevertheless only just convergent, in C the sense that small perturbations in S can make one C or more of the eigenvalues lie outside the unit C circle; C perturbed values were used to solve the equation C (but the matrix S is unchanged); C = 2: if the matrix S is not stable (that is, one or more C of the eigenvalues of S has a non-negative real C part), if DISCR = .FALSE., or not convergent (that C is, one or more of the eigenvalues of S lies outside C the unit circle), if DISCR = .TRUE.; C = 3: if the matrix S has two or more consecutive non-zero C elements on the first sub-diagonal, so that there is C a block larger than 2-by-2 on the diagonal; C = 4: if the matrix S has a 2-by-2 diagonal block with C real eigenvalues instead of a complex conjugate C pair. C C METHOD C C The method used by the routine is based on a variant of the C Bartels and Stewart backward substitution method [1], that finds C the Cholesky factor op(U) directly without first finding X and C without the need to form the normal matrix op(R)'*op(R) [2]. C C The continuous-time Lyapunov equation in the canonical form C 2 C op(S)'*op(U)'*op(U) + op(U)'*op(U)*op(S) = -scale *op(R)'*op(R), C C or the discrete-time Lyapunov equation in the canonical form C 2 C op(S)'*op(U)'*op(U)*op(S) - op(U)'*op(U) = -scale *op(R)'*op(R), C C where U and R are upper triangular, is solved for U. C C REFERENCES C C [1] Bartels, R.H. and Stewart, G.W. C Solution of the matrix equation A'X + XB = C. C Comm. A.C.M., 15, pp. 820-826, 1972. C C [2] 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 The Lyapunov equation may be very ill-conditioned. In particular C if S is only just stable (or convergent) then the Lyapunov C equation will be ill-conditioned. "Large" elements in U relative C to those of S and R, or a "small" value for scale, is a symptom C of ill-conditioning. A condition estimate can be computed using C SLICOT Library routine SB03MD. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. C Supersedes Release 2.0 routine SB03CZ by Sven Hammarling, C NAG Ltd, United Kingdom, Oct. 1986. C Partly based on SB03CZ and PLYAP1 by A. Varga, University of C Bochum, May 1992. C C REVISIONS C C Dec. 1997, April 1998, May 1999, Feb. 2004, Jan. - Feb. 2022. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. LOGICAL DISCR, LTRANS INTEGER INFO, LDR, LDS, N DOUBLE PRECISION SCALE C .. Array Arguments .. DOUBLE PRECISION DWORK(*), R(LDR,*), S(LDS,*) C .. Local Scalars .. LOGICAL CONT, TBYT INTEGER INFOM, ISGN, J, J1, J2, J3, K, K1, K2, K3, $ KOUNT, KSIZE DOUBLE PRECISION ABSSKK, ALPHA, BIGNUM, D1, D2, DR, EPS, SCALOC, $ SMIN, SMLNUM, SUM, T1, T2, T3, T4, TAU1, TAU2, $ TEMP, V1, V2, V3, V4 C .. Local Arrays .. DOUBLE PRECISION A(2,2), B(2,2), U(2,2) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLABAD, DLARFG, DSCAL, DSWAP, $ DTRMM, DTRMV, MB04ND, MB04OD, SB03OR, SB03OY, $ XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -7 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB03OT', -INFO ) RETURN END IF C SCALE = ONE C C Quick return if possible. C IF (N.EQ.0) $ RETURN C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*DBLE( N*N ) / EPS BIGNUM = ONE / SMLNUM C SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, S, LDS, DWORK ) ) INFOM = 0 C C Start the solution. Most of the comments refer to notation and C equations in sections 5 and 10 of the second reference above. C C Determine whether or not the current block is two-by-two. C K gives the position of the start of the current block and C TBYT is true if the block is two-by-two. C CONT = .NOT.DISCR ISGN = 1 IF ( .NOT.LTRANS ) THEN C C Case op(M) = M. C KOUNT = 1 C 10 CONTINUE C WHILE( KOUNT.LE.N )LOOP IF ( KOUNT.LE.N ) THEN K = KOUNT IF ( KOUNT.GE.N ) THEN TBYT = .FALSE. KOUNT = KOUNT + 1 ELSE IF ( S(K+1,K).EQ.ZERO ) THEN TBYT = .FALSE. KOUNT = KOUNT + 1 ELSE TBYT = .TRUE. IF ( (K+1).LT.N ) THEN IF ( S(K+2,K+1).NE.ZERO ) THEN INFO = 3 RETURN END IF END IF KOUNT = KOUNT + 2 END IF IF ( TBYT ) THEN C C Solve the two-by-two Lyapunov equation (6.1) or (10.19), C using the routine SB03OY. C B(1,1) = S(K,K) B(2,1) = S(K+1,K) B(1,2) = S(K,K+1) B(2,2) = S(K+1,K+1) U(1,1) = R(K,K) U(1,2) = R(K,K+1) U(2,2) = R(K+1,K+1) C CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2, $ SCALOC, INFO ) IF ( INFO.GT.1 ) $ RETURN INFOM = MAX( INFO, INFOM ) IF( SCALOC.NE.ONE ) THEN C DO 20 J = 1, N CALL DSCAL( J, SCALOC, R(1,J), 1 ) 20 CONTINUE C SCALE = SCALE*SCALOC END IF R(K,K) = U(1,1) R(K,K+1) = U(1,2) R(K+1,K+1) = U(2,2) C C If we are not at the end of S then set up and solve C equation (6.2) or (10.20). C C Note that SB03OY returns ( u11*s11*inv( u11 ) ) in B C and returns scaled alpha in A. ksize is the order of C the remainder of S. k1, k2 and k3 point to the start C of vectors in DWORK. C IF ( KOUNT.LE.N ) THEN KSIZE = N - K - 1 K1 = KSIZE + 1 K2 = KSIZE + K1 K3 = KSIZE + K2 C C Form the right-hand side of (6.2) or (10.20), the C first column in DWORK( 1 ) ,..., DWORK( n - k - 1 ) C the second in DWORK( n - k ) ,..., C DWORK( 2*( n - k - 1 ) ). C CALL DCOPY( KSIZE, R(K,K+2), LDR, DWORK, 1 ) CALL DCOPY( KSIZE, R(K+1,K+2), LDR, DWORK(K1), 1 ) CALL DTRMM( 'Right', 'Upper', 'No transpose', $ 'Non-unit', KSIZE, 2, -ONE, A, 2, DWORK, $ KSIZE ) IF ( CONT ) THEN CALL DAXPY( KSIZE, -R(K,K), S(K,K+2), LDS, DWORK, $ 1 ) CALL DAXPY( KSIZE, -R(K,K+1), S(K+1,K+2), LDS, $ DWORK, 1) CALL DAXPY( KSIZE, -R(K+1,K+1), S(K+1,K+2), LDS, $ DWORK(K1), 1 ) ELSE CALL DAXPY( KSIZE, -R(K,K)*B(1,1), S(K,K+2), LDS, $ DWORK, 1 ) CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,1) + R(K+1,K+1) $ *B(2,1) ), S(K+1,K+2), LDS, DWORK, 1 ) CALL DAXPY( KSIZE, -R(K,K)*B(1,2), S(K,K+2), LDS, $ DWORK(K1), 1 ) CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,2) + R(K+1,K+1) $ *B(2,2) ), S(K+1,K+2), LDS, DWORK(K1), $ 1 ) END IF C C SB03OR solves the Sylvester equations. The solution C is overwritten on DWORK. C CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S(K+2,K+2), LDS, $ B, 2, DWORK, KSIZE, SCALOC, INFO ) INFOM = MAX( INFO, INFOM ) IF( SCALOC.NE.ONE ) THEN C DO 30 J = 1, N CALL DSCAL( J, SCALOC, R(1,J), 1 ) 30 CONTINUE C SCALE = SCALE*SCALOC END IF C C Copy the solution into the next 2*( n - k - 1 ) C elements of DWORK. C CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 ) C C Now form the matrix Rhat of equation (6.4) or C (10.22). Note that (10.22) is incorrect, so here we C implement a corrected version of (10.22). C IF ( CONT ) THEN C C Swap the two rows of R with DWORK. C CALL DSWAP( KSIZE, DWORK, 1, R(K,K+2), LDR ) CALL DSWAP( KSIZE, DWORK(K1), 1, R(K+1,K+2), LDR ) C C 1st column: C CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK, $ 1 ) CALL DAXPY( KSIZE, -A(1,2), DWORK(K3), 1, DWORK, $ 1 ) C C 2nd column: C CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1, $ DWORK(K1), 1 ) ELSE C C Form v = S1'*u + s*u11', overwriting v on DWORK. C C Compute S1'*u, first multiplying by the C triangular part of S1. C CALL DTRMM( 'Left', 'Upper', 'Transpose', $ 'Non-unit', KSIZE, 2, ONE, S(K+2,K+2), $ LDS, DWORK, KSIZE ) C C Then multiply by the subdiagonal of S1 and add in C to the above result. C J1 = K1 J2 = K + 2 C DO 40 J = 1, KSIZE-1 IF ( S(J2+1,J2).NE.ZERO ) THEN DWORK(J) = S(J2+1,J2)*DWORK(K2+J) + DWORK(J) DWORK(J1) = S(J2+1,J2)*DWORK(K3+J) + $ DWORK(J1) END IF J1 = J1 + 1 J2 = J2 + 1 40 CONTINUE C C Add in s*u11'. C CALL DAXPY( KSIZE, R(K,K), S(K,K+2), LDS, DWORK, $ 1 ) CALL DAXPY( KSIZE, R(K,K+1), S(K+1,K+2), LDS, $ DWORK, 1 ) CALL DAXPY( KSIZE, R(K+1,K+1), S(K+1,K+2), LDS, $ DWORK(K1), 1 ) C C Next recover r from R, swapping r with u. C CALL DSWAP( KSIZE, DWORK(K2), 1, R(K,K+2), LDR ) CALL DSWAP( KSIZE, DWORK(K3), 1, R(K+1,K+2), LDR ) C C Now we perform the QR factorization. C C ( a ) = Q*( t ), C ( b ) C C and form C C ( p' ) = Q'*( r' ). C ( y' ) ( v' ) C C y is then the correct vector to use in (10.22). C Note that a is upper triangular and that t and C p are not required. C CALL DLARFG( 3, A(1,1), B(1,1), 1, TAU1 ) V1 = B(1,1) T1 = TAU1*V1 V2 = B(2,1) T2 = TAU1*V2 SUM = A(1,2) + V1*B(1,2) + V2*B(2,2) B(1,2) = B(1,2) - SUM*T1 B(2,2) = B(2,2) - SUM*T2 CALL DLARFG( 3, A(2,2), B(1,2), 1, TAU2 ) V3 = B(1,2) T3 = TAU2*V3 V4 = B(2,2) T4 = TAU2*V4 J1 = K1 J2 = K2 J3 = K3 C DO 50 J = 1, KSIZE SUM = DWORK(J2) + V1*DWORK(J) + V2*DWORK(J1) D1 = DWORK(J) - SUM*T1 D2 = DWORK(J1) - SUM*T2 SUM = DWORK(J3) + V3*D1 + V4*D2 DWORK(J) = D1 - SUM*T3 DWORK(J1) = D2 - SUM*T4 J1 = J1 + 1 J2 = J2 + 1 J3 = J3 + 1 50 CONTINUE C END IF C C Now update R1 to give Rhat. C CALL DCOPY( KSIZE, DWORK, 1, DWORK(K2), 1 ) CALL DCOPY( KSIZE, DWORK(K1), 1, DWORK(K3), 1 ) CALL DCOPY( KSIZE, DWORK(K3), 1, DWORK(2), 2 ) CALL DCOPY( KSIZE, DWORK(K2), 1, DWORK(1), 2 ) CALL MB04OD( 'Full', KSIZE, 0, 2, R(K+2,K+2), LDR, $ DWORK, 2, DWORK, 1, DWORK, 1, DWORK(K2), $ DWORK(K3) ) END IF ELSE C C 1-by-1 block. C C Make sure S is stable or convergent and find u11 in C equation (5.13) or (10.15). C IF ( DISCR ) THEN ABSSKK = ABS( S(K,K) ) IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN INFO = 2 RETURN END IF TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) ELSE IF ( S(K,K).GE.ZERO ) THEN INFO = 2 RETURN END IF TEMP = SQRT( ABS( TWO*S(K,K) ) ) END IF C SCALOC = ONE DR = ABS( R(K,K) ) IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN IF( DR.GT.BIGNUM*TEMP ) $ SCALOC = ONE / DR END IF ALPHA = SIGN( TEMP, R(K,K) ) R(K,K) = R(K,K)/ALPHA IF( SCALOC.NE.ONE ) THEN C DO 60 J = 1, N CALL DSCAL( J, SCALOC, R(1,J), 1 ) 60 CONTINUE C SCALE = SCALE*SCALOC END IF C C If we are not at the end of S then set up and solve C equation (5.14) or (10.16). ksize is the order of the C remainder of S. k1 and k2 point to the start of vectors C in DWORK. C IF ( KOUNT.LE.N ) THEN KSIZE = N - K K1 = KSIZE + 1 K2 = KSIZE + K1 C C Form the right-hand side in DWORK( 1 ),..., C DWORK( n - k ). C CALL DCOPY( KSIZE, R(K,K+1), LDR, DWORK, 1 ) CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) IF ( CONT ) THEN CALL DAXPY( KSIZE, -R(K,K), S(K,K+1), LDS, DWORK, $ 1 ) ELSE CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(K,K+1), LDS, $ DWORK, 1 ) END IF C C SB03OR solves the Sylvester equations. The solution is C overwritten on DWORK. C CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S(K+1,K+1), LDS, $ S(K,K), 1, DWORK, KSIZE, SCALOC, INFO ) INFOM = MAX( INFO, INFOM ) IF( SCALOC.NE.ONE ) THEN C DO 70 J = 1, N CALL DSCAL( J, SCALOC, R(1,J), 1 ) 70 CONTINUE C SCALE = SCALE*SCALOC END IF C C Copy the solution into the next ( n - k ) elements C of DWORK, copy the solution back into R and copy C the row of R back into DWORK. C CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) CALL DSWAP( KSIZE, DWORK, 1, R(K,K+1), LDR ) C C Now form the matrix Rhat of equation (5.15) or C (10.17), first computing y in DWORK, and then C updating R1. C IF ( CONT ) THEN CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) ELSE C C First form lambda( 1 )*r and then add in C alpha*u11*s. C CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) CALL DAXPY( KSIZE, ALPHA*R(K,K), S(K,K+1), LDS, $ DWORK, 1 ) C C Now form alpha*S1'*u, first multiplying by the C sub-diagonal of S1 and then the triangular part C of S1, and add the result in DWORK. C J1 = K + 1 C DO 80 J = 1, KSIZE-1 IF ( S(J1+1,J1).NE.ZERO ) DWORK(J) $ = ALPHA*S(J1+1,J1)*DWORK(K1+J) + DWORK(J) J1 = J1 + 1 80 CONTINUE C CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', $ KSIZE, S(K+1,K+1), LDS, DWORK(K1), 1 ) CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) END IF CALL MB04OD( 'Full', KSIZE, 0, 1, R(K+1,K+1), LDR, $ DWORK, 1, DWORK, 1, DWORK, 1, DWORK(K2), $ DWORK(K1) ) END IF END IF GO TO 10 END IF C END WHILE 10 C ELSE C C Case op(M) = M'. C KOUNT = N C 90 CONTINUE C WHILE( KOUNT.GE.1 )LOOP IF ( KOUNT.GE.1 ) THEN K = KOUNT IF ( KOUNT.EQ.1 ) THEN TBYT = .FALSE. KOUNT = KOUNT - 1 ELSE IF ( S(K,K-1).EQ.ZERO ) THEN TBYT = .FALSE. KOUNT = KOUNT - 1 ELSE TBYT = .TRUE. K = K - 1 IF ( K.GT.1 ) THEN IF ( S(K,K-1).NE.ZERO ) THEN INFO = 3 RETURN END IF END IF KOUNT = KOUNT - 2 END IF IF ( TBYT ) THEN C C Solve the two-by-two Lyapunov equation corresponding to C (6.1) or (10.19), using the routine SB03OY. C B(1,1) = S(K,K) B(2,1) = S(K+1,K) B(1,2) = S(K,K+1) B(2,2) = S(K+1,K+1) U(1,1) = R(K,K) U(1,2) = R(K,K+1) U(2,2) = R(K+1,K+1) C CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2, $ SCALOC, INFO ) IF ( INFO.GT.1 ) $ RETURN INFOM = MAX( INFO, INFOM ) IF( SCALOC.NE.ONE ) THEN C DO 100 J = 1, N CALL DSCAL( J, SCALOC, R(1,J), 1 ) 100 CONTINUE C SCALE = SCALE*SCALOC END IF R(K,K) = U(1,1) R(K,K+1) = U(1,2) R(K+1,K+1) = U(2,2) C C If we are not at the front of S then set up and solve C equation corresponding to (6.2) or (10.20). C C Note that SB03OY returns ( inv( u11 )*s11*u11 ) in B C and returns scaled alpha, alpha = inv( u11 )*r11, in A. C ksize is the order of the remainder leading part of S. C k1, k2 and k3 point to the start of vectors in DWORK. C IF ( KOUNT.GE.1 ) THEN KSIZE = K - 1 K1 = KSIZE + 1 K2 = KSIZE + K1 K3 = KSIZE + K2 C C Form the right-hand side of equations corresponding to C (6.2) or (10.20), the first column in DWORK( 1 ) ,..., C DWORK( k - 1 ) the second in DWORK( k ) ,..., C DWORK( 2*( k - 1 ) ). C CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) CALL DCOPY( KSIZE, R(1,K+1), 1, DWORK(K1), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', $ KSIZE, 2, -ONE, A, 2, DWORK, KSIZE ) IF ( CONT ) THEN CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) CALL DAXPY( KSIZE, -R(K,K+1), S(1,K), 1, DWORK(K1), $ 1 ) CALL DAXPY( KSIZE, -R(K+1,K+1), S(1,K+1), 1, $ DWORK(K1), 1 ) ELSE CALL DAXPY( KSIZE, -( R(K,K)*B(1,1) + R(K,K+1) $ *B(1,2) ), S(1,K), 1, DWORK, 1 ) CALL DAXPY( KSIZE, -R(K+1,K+1)*B(1,2), S(1,K+1), 1, $ DWORK, 1 ) CALL DAXPY( KSIZE, -( R(K,K)*B(2,1) + R(K,K+1) $ *B(2,2) ), S(1,K), 1, DWORK(K1), 1 ) CALL DAXPY( KSIZE, -R(K+1,K+1)*B(2,2), S(1,K+1), 1, $ DWORK(K1), 1 ) END IF C C SB03OR solves the Sylvester equations. The solution C is overwritten on DWORK. C CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S, LDS, B, 2, $ DWORK, KSIZE, SCALOC, INFO ) INFOM = MAX( INFO, INFOM ) IF( SCALOC.NE.ONE ) THEN C DO 110 J = 1, N CALL DSCAL( J, SCALOC, R(1,J), 1 ) 110 CONTINUE C SCALE = SCALE*SCALOC END IF C C Copy the solution into the next 2*( k - 1 ) elements C of DWORK. C CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 ) C C Now form the matrix Rhat of equation corresponding C to (6.4) or (10.22) (corrected version). C IF ( CONT ) THEN C C Swap the two columns of R with DWORK. C CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) CALL DSWAP( KSIZE, DWORK(K1), 1, R(1,K+1), 1 ) C C 1st column: C CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK, $ 1 ) C C 2nd column: C CALL DAXPY( KSIZE, -A(1,2), DWORK(K2), 1, $ DWORK(K1), 1 ) CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1, $ DWORK(K1), 1 ) ELSE C C Form v = S1*u + s*u11, overwriting v on DWORK. C C Compute S1*u, first multiplying by the triangular C part of S1. C CALL DTRMM( 'Left', 'Upper', 'No transpose', $ 'Non-unit', KSIZE, 2, ONE, S, LDS, $ DWORK, KSIZE ) C C Then multiply by the subdiagonal of S1 and add in C to the above result. C J1 = K1 C DO 120 J = 2, KSIZE J1 = J1 + 1 IF ( S(J,J-1).NE.ZERO ) THEN DWORK(J) = S(J,J-1)*DWORK(K2+J-2) + DWORK(J) DWORK(J1) = S(J,J-1)*DWORK(K3+J-2) + $ DWORK(J1) END IF 120 CONTINUE C C Add in s*u11. C CALL DAXPY( KSIZE, R(K,K), S(1,K), 1, DWORK, 1 ) CALL DAXPY( KSIZE, R(K,K+1), S(1,K), 1, DWORK(K1), $ 1 ) CALL DAXPY( KSIZE, R(K+1,K+1), S(1,K+1), 1, $ DWORK(K1), 1 ) C C Next recover r from R, swapping r with u. C CALL DSWAP( KSIZE, DWORK(K2), 1, R(1,K), 1 ) CALL DSWAP( KSIZE, DWORK(K3), 1, R(1,K+1), 1 ) C C Now we perform the QL factorization. C C ( a' ) = Q*( t ), C ( b' ) C C and form C C ( p' ) = Q'*( r' ). C ( y' ) ( v' ) C C y is then the correct vector to use in the C relation corresponding to (10.22). C Note that a is upper triangular and that t and C p are not required. C CALL DLARFG( 3, A(2,2), B(2,1), 2, TAU1 ) V1 = B(2,1) T1 = TAU1*V1 V2 = B(2,2) T2 = TAU1*V2 SUM = A(1,2) + V1*B(1,1) + V2*B(1,2) B(1,1) = B(1,1) - SUM*T1 B(1,2) = B(1,2) - SUM*T2 CALL DLARFG( 3, A(1,1), B(1,1), 2, TAU2 ) V3 = B(1,1) T3 = TAU2*V3 V4 = B(1,2) T4 = TAU2*V4 J1 = K1 J2 = K2 J3 = K3 C DO 130 J = 1, KSIZE SUM = DWORK(J3) + V1*DWORK(J) + V2*DWORK(J1) D1 = DWORK(J) - SUM*T1 D2 = DWORK(J1) - SUM*T2 SUM = DWORK(J2) + V3*D1 + V4*D2 DWORK(J) = D1 - SUM*T3 DWORK(J1) = D2 - SUM*T4 J1 = J1 + 1 J2 = J2 + 1 J3 = J3 + 1 130 CONTINUE C END IF C C Now update R1 to give Rhat. C CALL MB04ND( 'Full', KSIZE, 0, 2, R, LDR, DWORK, $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), $ DWORK(K3) ) END IF ELSE C C 1-by-1 block. C C Make sure S is stable or convergent and find u11 in C equation corresponding to (5.13) or (10.15). C IF ( DISCR ) THEN ABSSKK = ABS( S(K,K) ) IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN INFO = 2 RETURN END IF TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) ELSE IF ( S(K,K).GE.ZERO ) THEN INFO = 2 RETURN END IF TEMP = SQRT( ABS( TWO*S(K,K) ) ) END IF C SCALOC = ONE IF( TEMP.LT.SMIN ) THEN TEMP = SMIN INFOM = 1 END IF DR = ABS( R(K,K) ) IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN IF( DR.GT.BIGNUM*TEMP ) $ SCALOC = ONE / DR END IF ALPHA = SIGN( TEMP, R(K,K) ) R(K,K) = R(K,K)/ALPHA IF( SCALOC.NE.ONE ) THEN C DO 140 J = 1, N CALL DSCAL( J, SCALOC, R(1,J), 1 ) 140 CONTINUE C SCALE = SCALE*SCALOC END IF C C If we are not at the front of S then set up and solve C equation corresponding to (5.14) or (10.16). ksize is C the order of the remainder leading part of S. k1 and k2 C point to the start of vectors in DWORK. C IF ( KOUNT.GE.1 ) THEN KSIZE = K - 1 K1 = KSIZE + 1 K2 = KSIZE + K1 C C Form the right-hand side in DWORK( 1 ),..., C DWORK( k - 1 ). C CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) IF ( CONT ) THEN CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) ELSE CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(1,K), 1, $ DWORK, 1 ) END IF C C SB03OR solves the Sylvester equations. The solution is C overwritten on DWORK. C CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S, LDS, S(K,K), $ 1, DWORK, KSIZE, SCALOC, INFO ) INFOM = MAX( INFO, INFOM ) IF( SCALOC.NE.ONE ) THEN C DO 150 J = 1, N CALL DSCAL( J, SCALOC, R(1,J), 1 ) 150 CONTINUE C SCALE = SCALE*SCALOC END IF C C Copy the solution into the next ( k - 1 ) elements C of DWORK, copy the solution back into R and copy C the column of R back into DWORK. C CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) C C Now form the matrix Rhat of equation corresponding C to (5.15) or (10.17), first computing y in DWORK, C and then updating R1. C IF ( CONT ) THEN CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) ELSE C C First form lambda( 1 )*r and then add in C alpha*u11*s. C CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) CALL DAXPY( KSIZE, ALPHA*R(K,K), S(1,K), 1, DWORK, $ 1 ) C C Now form alpha*S1*u, first multiplying by the C sub-diagonal of S1 and then the triangular part C of S1, and add the result in DWORK. C DO 160 J = 2, KSIZE IF ( S(J,J-1).NE.ZERO ) DWORK(J) $ = ALPHA*S(J,J-1)*DWORK(K1+J-2) + DWORK(J) 160 CONTINUE C CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', $ KSIZE, S, LDS, DWORK(K1), 1 ) CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) END IF CALL MB04ND( 'Full', KSIZE, 0, 1, R, LDR, DWORK, $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), $ DWORK(K1) ) END IF END IF GO TO 90 END IF C END WHILE 90 C END IF INFO = INFOM RETURN C *** Last line of SB03OT *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01OD.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01OD.f0000644000175000017500000002620315012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE TG01OD( JOBE, N, DCBA, LDDCBA, E, LDE, NZ, G, TOL, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute for a single-input single-output descriptor system, C given by the system matrix C C [ D C ] C [ B A - s*E ], C C with E nonsingular, a reduced system matrix, C C [ d c ] C [ b a - s*e ], C C such that d has a "sufficiently" large magnitude. C C ARGUMENTS C C Mode Parameters C C JOBE CHARACTER*1 C Specifies whether E is a general or an identity matrix, C as follows: C = 'G': The matrix E is a general matrix; C = 'I': The matrix E is assumed identity and is not given. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the descriptor state vector; also the C order of square matrices A and E, the number of rows of C matrix B, and the number of columns of matrix C. N >= 0. C C DCBA (input/output) DOUBLE PRECISION array, dimension C (LDDCBA,N+1) C On entry, the leading (N+1)-by-(N+1) part of this array C must contain the original system matrices A, B, C, and D, C stored as follows C C [ D C ] C [ B A ]. C C On exit, the leading (NZ+1)-by-(NZ+1) part of this array C contains the reduced system matrices a, b, c, and d. C C LDDCBA INTEGER C The leading dimension of the array DCBA. LDDCBA >= N+1. C C E (input/output) DOUBLE PRECISION array, dimension (LDE,*) C On entry, if JOBE = 'G', the leading N-by-N part of this C array must contain the nonsingular descriptor matrix E. C On exit, if JOBE = 'G', the leading NZ-by-NZ part of this C array contains the reduced descriptor matrix e. C If JOBE = 'I', this array 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 NZ (output) INTEGER C The order of the reduced system. C C G (output) DOUBLE PRECISION C The gain of the reduced system. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in determining if the transformed C d has a "sufficiently" large magnitude. If the user sets C TOL > 0, then the given value of TOL is used. If the user C sets TOL <= 0, then an implicitly computed, default C tolerance, defined by TOLDEF = EPS**(3/4), is used C instead, where EPS is the machine precision (see LAPACK C Library routine DLAMCH). 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 On exit, if INFO = -11, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 2*N+1, if JOBE = 'G'; C LDWORK >= N+1, if JOBE = 'I'. C For good performance when JOBE = 'G', LDWORK should be C larger. Specifically, C LDWORK >= MAX( N*NB(DGEQRF), (N+1)*NB(DORMQR) ), C where NB(X) is the optimal block sizes for the LAPACK C Library routine X. 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 Householder transformations and Givens rotations are used to C process the matrices. If E is a general matrix, it is first C triangularized using the QR decomposition, and the triangular form C is preserved during the remaining computations. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C V. Sima, May 2021. C C REVISIONS C C V. Sima, June 2021, Nov. 2021. C C KEYWORDS C C Givens rotation, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, THREE, FOUR, ZERO PARAMETER ( ONE = 1.0D0, THREE = 3.0D0, FOUR = 4.0D0, $ ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER JOBE INTEGER INFO, LDDCBA, LDWORK, LDE, N, NZ DOUBLE PRECISION G, TOL C .. Array Arguments .. DOUBLE PRECISION DCBA(LDDCBA,*), DWORK(*), E(LDE,*) C .. Local Scalars .. CHARACTER JOBT LOGICAL DESCR, LQUERY INTEGER I, IMAX, ITAU, IWRK, J, JF, MAXWRK, MINWRK, N1, $ NC DOUBLE PRECISION ABSD, MAXA, NRMB, NRMC, TAU, TOLDEF C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLANGE, DNRM2 EXTERNAL DLAMCH, DLANGE, DNRM2, IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEQRF, DLARF, DLARFG, DLASET, DORMQR, $ DSWAP, TG01OA, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN C .. Executable Statements .. C DESCR = LSAME( JOBE, 'G' ) INFO = 0 N1 = N + 1 C C Test the input scalar arguments. C IF ( .NOT.DESCR .AND. .NOT.LSAME( JOBE, 'I' ) ) THEN INFO = -1 ELSE IF ( N.LT.0 ) THEN INFO = -2 ELSE IF ( LDDCBA.LT.N1 ) THEN INFO = -4 ELSE IF ( LDE.LT.1 .OR. ( DESCR .AND. LDE.LT.MAX( 1, N ) ) ) THEN INFO = -6 ELSE IF( DESCR ) THEN MINWRK = 2*N + 1 ELSE IF( N.EQ.0 ) THEN MINWRK = 1 ELSE MINWRK = N1 END IF MAXWRK = MINWRK LQUERY = LDWORK.EQ.-1 IF ( LQUERY ) THEN IF ( DESCR ) THEN CALL DGEQRF( N, N, E, LDE, DCBA, DWORK, -1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) CALL DORMQR( 'Left', 'Transpose', N, N1, N, E, LDE, DCBA, $ DCBA, LDDCBA, DWORK, -1, INFO ) DWORK(1) = DBLE( MAX( MAXWRK, INT( DWORK(1) ) ) ) ELSE DWORK(1) = DBLE( MAXWRK ) END IF RETURN ELSE IF( LDWORK.LT.MINWRK ) THEN DWORK(1) = DBLE( MINWRK ) INFO = -11 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01OD', -INFO ) RETURN END IF C C Quick return if possible. C NZ = N IF( N.EQ.0 ) THEN G = DCBA(1,1) DWORK(1) = ONE RETURN END IF C TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance. C TOLDEF = DLAMCH( 'Precision' )**( THREE/FOUR ) END IF C C Check if the reduction is needed. C G = ONE MAXA = DLANGE( 'MAX', N, N, DCBA(2,2), LDDCBA, DWORK ) NRMB = DNRM2 ( N, DCBA(2,1), 1 ) NRMC = DNRM2 ( N, DCBA(1,2), N1 ) C IF( ABS( DCBA(1,1) )*( ONE + MAXA ).LE.TOLDEF*NRMB*NRMC ) THEN IF( DESCR ) THEN C C Triangularize E. C Workspace: need 2*N + 1; C prefer MAX( N*NB(DGEQRF), (N+1)*NB(DORMQR) ). C ITAU = 1 IWRK = ITAU + N CALL DGEQRF( N, N, E, LDE, DWORK(ITAU), DWORK(IWRK), $ LDWORK-N, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(IWRK) ) ) CALL DORMQR( 'Left', 'Transpose', N, N1, N, E, LDE, $ DWORK(ITAU), DCBA(2,1), LDDCBA, DWORK(IWRK), $ LDWORK-N, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(IWRK) ) ) IF( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, E(2,1), LDE ) JOBT = 'Upper' ELSE JOBT = JOBE END IF C DO 10 I = 1, N C C Perform one-step deflation of [ D C; B A-s*E ] with D = 0. C NC = NZ + 1 IF( .NOT.DESCR ) THEN C C Ensure that the currently first entry of B is nonzero, C to maximize the identity portion of the Householder C transformation. C IF( DCBA(I+1,I).EQ.ZERO ) THEN C C Bring the largest entry of B in the first position. C IMAX = IDAMAX( NZ, DCBA(I+1,I), 1 ) + I CALL DSWAP( NC, DCBA(I+1,I), LDDCBA, DCBA(IMAX,I), $ LDDCBA ) CALL DSWAP( NC, DCBA(I,I+1), 1, DCBA(I,IMAX), 1 ) END IF C C Find and apply the Householder transformation setting C to zero all entries of the current B, but the first. C CALL DLARFG( NZ, DCBA(I+1,I), DCBA(MIN(I+2,N1),I), 1, $ TAU ) G = G*DCBA(I+1,I) DCBA(I+1,I) = ONE CALL DLARF( 'Left', NZ, NZ, DCBA(I+1,I), 1, TAU, $ DCBA(I+1,I+1), LDDCBA, DWORK ) CALL DLARF( 'Right', NC, NZ, DCBA(I+1,I), 1, TAU, $ DCBA(I,I+1), LDDCBA, DWORK ) ELSE CALL TG01OA( JOBT, NZ, DCBA(I,I), LDDCBA, E(I,I), LDE, $ INFO ) G = G*DCBA(I+1,I)/E(I,I) END IF C C Reduce DCBA (delete the second row and first column of the C current DCBA matrix). Actually, the first row is copied over C the second, and then the first row and column are removed. C CALL DCOPY( NZ, DCBA(I,I+1), LDDCBA, DCBA(I+1,I+1), LDDCBA ) C C Terminate when [ D; B ] = 0, [ D C ] = 0, or D is large C enough. C NZ = NZ - 1 ABSD = ABS( DCBA(I+1,I+1) ) NRMB = DNRM2( NZ, DCBA(I+2,I+1), 1 ) NRMC = DNRM2( NZ, DCBA(I+1,I+2), N1 ) IF( ABSD.EQ.ZERO .AND. ( NRMB.EQ.ZERO .OR. NRMC.EQ.ZERO ) ) $ THEN NZ = 0 GO TO 20 END IF MAXA = DLANGE( 'MAX', NZ, NZ, DCBA(I+2,I+2), LDDCBA, DWORK ) IF( ABSD*( ONE + MAXA ).GT.TOLDEF*NRMB*NRMC ) THEN GO TO 20 END IF 10 CONTINUE C I = N C 20 CONTINUE C C Move the results in the leading positions. C JF = 1 C DO 30 J = I + 1, N1 CALL DCOPY( NZ+1, DCBA(I+1,J), 1, DCBA(1,JF), 1 ) JF = JF + 1 30 CONTINUE C IF( DESCR ) THEN JF = 1 C DO 40 J = I + 1, N CALL DCOPY( NZ, E(I+1,J), 1, E(1,JF), 1 ) JF = JF + 1 40 CONTINUE C END IF C END IF C G = G*DCBA(1,1) DWORK(1) = DBLE( MAXWRK ) C RETURN C *** Last line of TG01OD *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BE.f0000644000000000000000000000013015012430707016146 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/NF01BE.f0000644000175000017500000000616015012430707017347 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BE( IFLAG, NSMP, N, IPAR, LIPAR, Z, LDZ, Y, LDY, X, $ NFEVL, E, J, LDJ, DWORK, LDWORK, INFO ) C C PURPOSE C C This is the FCN routine for optimizing the parameters of the C nonlinear part of a Wiener system (initialization phase), using C SLICOT Library routine MD03BD. See the argument FCN in the C routine MD03BD for the description of parameters. Note that C NF01BE is called for each output of the Wiener system. C C ****************************************************************** C C .. Parameters .. C .. CJTE is initialized to avoid the calculation of J'*e .. C .. NOUT is the unit number for printing intermediate results .. CHARACTER CJTE PARAMETER ( CJTE = 'N' ) INTEGER NOUT PARAMETER ( NOUT = 6 ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER IFLAG, INFO, LDJ, LDWORK, LDY, LDZ, LIPAR, N, $ NFEVL, NSMP C .. Array Arguments .. INTEGER IPAR(*) DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), X(*), Y(LDY,*), $ Z(LDZ,*) C .. Local Scalars .. DOUBLE PRECISION ERR C .. External Functions .. DOUBLE PRECISION DNRM2 EXTERNAL DNRM2 C .. External Subroutines .. EXTERNAL DAXPY, NF01AY, NF01BY C C .. Executable Statements .. C INFO = 0 IF ( IFLAG.EQ.1 ) THEN C C Call NF01AY to compute the output y of the Wiener system (in E) C and then the error functions (also in E). The array Z must C contain the output of the linear part of the Wiener system, and C Y must contain the original output Y of the Wiener system. C IPAR(2) must contain the number of outputs. C Workspace: need: 2*NN, NN = IPAR(3) (number of neurons); C prefer: larger. C CALL NF01AY( NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, LDZ, $ E, NSMP, DWORK, LDWORK, INFO ) CALL DAXPY( NSMP, -ONE, Y, 1, E, 1 ) DWORK(1) = 2*IPAR(3) C ELSE IF ( IFLAG.EQ.2 ) THEN C C Call NF01BY to compute the Jacobian in a compressed form. C IPAR(2), IPAR(3) must have the same content as for IFLAG = 1. C Workspace: need: 0. C CALL NF01BY( CJTE, NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, $ LDZ, E, J, LDJ, DWORK, DWORK, LDWORK, INFO ) NFEVL = 0 DWORK(1) = ZERO C ELSE IF ( IFLAG.EQ.3 ) THEN C C Set the parameter LDJ, the length of the array J, and the sizes C of the workspace for FCN (IFLAG = 1 or 2), QRFACT and LMPARM. C LDJ = NSMP IPAR(1) = NSMP*N IPAR(2) = 2*IPAR(3) IPAR(3) = 0 IPAR(4) = 4*N + 1 IPAR(5) = 4*N C ELSE IF ( IFLAG.EQ.0 ) THEN C C Special call for printing intermediate results. C ERR = DNRM2( NSMP, E, 1 ) WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR END IF RETURN C C *** Last line of NF01BE *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04TY.f0000644000000000000000000000013215012430707016214 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04TY.f0000644000175000017500000001741515012430707017420 0ustar00lilgelilge00000000000000 SUBROUTINE MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, $ LDA, E, LDE, Q, LDQ, Z, LDZ, INFO ) C C PURPOSE C C To perform the triangularization of the submatrices having full C row and column rank in the pencil s*E(eps,inf)-A(eps,inf) below C C | s*E(eps,inf)-A(eps,inf) | X | C s*E - A = |-------------------------|-------------| , C | 0 | s*E(r)-A(r) | C C using Algorithm 3.3.1 in [1]. C On entry, it is assumed that the M-by-N matrices A and E have C been transformed to generalized Schur form by unitary C transformations (see Algorithm 3.2.1 in [1]), and that the pencil C s*E(eps,inf)-A(eps,inf) is in staircase form. C This pencil contains all Kronecker column indices and infinite C elementary divisors of the pencil s*E - A. C The pencil s*E(r)-A(r) contains all Kronecker row indices and C finite elementary divisors of s*E - A. C C ARGUMENTS C C Mode Parameters C C UPDATQ LOGICAL C Indicates whether the user wishes to accumulate in a C matrix Q the orthogonal row transformations, as follows: C = .FALSE.: Do not form Q; C = .TRUE.: The given matrix Q is updated by the orthogonal C row transformations used in the reduction. C C UPDATZ LOGICAL C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal column transformations, as C follows: C = .FALSE.: Do not form Z; C = .TRUE.: The given matrix Z is updated by the orthogonal C column transformations used in the reduction. C C Input/Output Parameters C C M (input) INTEGER C Number of rows in A and E. M >= 0. C C N (input) INTEGER C Number of columns in A and E. N >= 0. C C NBLCKS (input) INTEGER C Number of submatrices having full row rank (possibly zero) C in A(eps,inf). C C INUK (input) INTEGER array, dimension (NBLCKS) C The row dimensions nu(k) (k=1, 2, ..., NBLCKS) of the C submatrices having full row rank in the pencil C s*E(eps,inf)-A(eps,inf). C C IMUK (input) INTEGER array, dimension (NBLCKS) C The column dimensions mu(k) (k=1, 2, ..., NBLCKS) of the C submatrices having full column rank in the pencil. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, this array contains the matrix A to be reduced. C On exit, it contains the transformed matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, this array contains the matrix E to be reduced. C On exit, it contains the transformed matrix E. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,M). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) C On entry, if UPDATQ = .TRUE., then the leading M-by-M C part of this array must contain a given matrix Q (e.g. C from a previous call to another SLICOT routine), and on C exit, the leading M-by-M part of this array contains the C product of the input matrix Q and the row transformation C matrix that has transformed the rows of the matrices A C and E. C If UPDATQ = .FALSE., the array Q is not referenced and C can be supplied as a dummy array (i.e. set parameter C LDQ = 1 and declare this array to be Q(1,1) in the calling C program). C C LDQ INTEGER C The leading dimension of array Q. If UPDATQ = .TRUE., C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) C On entry, if UPDATZ = .TRUE., then the leading N-by-N C part of this array must contain a given matrix Z (e.g. C from a previous call to another SLICOT routine), and on C exit, the leading N-by-N part of this array contains the C product of the input matrix Z and the column C transformation matrix that has transformed the columns of C the matrices A and E. C If UPDATZ = .FALSE., the array Z is not referenced and C can be supplied as a dummy array (i.e. set parameter C LDZ = 1 and declare this array to be Z(1,1) in the calling C program). C C LDZ INTEGER C The leading dimension of array Z. If UPDATZ = .TRUE., C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if incorrect dimensions of a full column rank C submatrix; C = 2: if incorrect dimensions of a full row rank C submatrix. C C REFERENCES C C [1] Beelen, Th. C New Algorithms for Computing the Kronecker structure of a C Pencil with Applications to Systems and Control Theory. C Ph.D.Thesis, Eindhoven University of Technology, C The Netherlands, 1987. 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, Apr. 1997. C Supersedes Release 2.0 routine MB04FY by Th.G.J. Beelen, C Philips Glass Eindhoven, Holland. C C REVISIONS C C - C C KEYWORDS C C Generalized eigenvalue problem, orthogonal transformation, C staircase form. C C ****************************************************************** C C .. Scalar Arguments .. LOGICAL UPDATQ, UPDATZ INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKS C .. Array Arguments .. INTEGER IMUK(*), INUK(*) DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. INTEGER IFICA, IFICE, IFIRE, ISMUK, ISNUK1, K, MUK, $ MUKP1, NUK C .. External Subroutines .. EXTERNAL MB04TV, MB04TW C .. Executable Statements .. C INFO = 0 IF ( M.LE.0 .OR. N.LE.0 ) $ RETURN C C ISMUK = sum(i=1,...,k) MU(i), C ISNUK1 = sum(i=1,...,k-1) NU(i). C ISMUK = 0 ISNUK1 = 0 C DO 20 K = 1, NBLCKS ISMUK = ISMUK + IMUK(K) ISNUK1 = ISNUK1 + INUK(K) 20 CONTINUE C C Note: ISNUK1 has not yet the correct value. C MUKP1 = 0 C DO 40 K = NBLCKS, 1, -1 MUK = IMUK(K) NUK = INUK(K) ISNUK1 = ISNUK1 - NUK C C Determine left upper absolute co-ordinates of E(k) in E-matrix C and of A(k) in A-matrix. C IFIRE = 1 + ISNUK1 IFICE = 1 + ISMUK IFICA = IFICE - MUK C C Reduce E(k) to upper triangular form using Givens C transformations on rows only. Apply the same transformations C to the rows of A(k). C IF ( MUKP1.GT.NUK ) THEN INFO = 1 RETURN END IF C CALL MB04TW( UPDATQ, M, N, NUK, MUKP1, IFIRE, IFICE, IFICA, A, $ LDA, E, LDE, Q, LDQ ) C C Reduce A(k) to upper triangular form using Givens C transformations on columns only. Apply the same transformations C to the columns in the E-matrix. C IF ( NUK.GT.MUK ) THEN INFO = 2 RETURN END IF C CALL MB04TV( UPDATZ, N, NUK, MUK, IFIRE, IFICA, A, LDA, E, LDE, $ Z, LDZ ) C ISMUK = ISMUK - MUK MUKP1 = MUK 40 CONTINUE C RETURN C *** Last line of MB04TY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03MD.f0000644000000000000000000000013015012430707016163 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB03MD.f0000644000175000017500000005112515012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C, $ LDC, SCALE, SEP, FERR, WR, WI, IWORK, DWORK, $ LDWORK, INFO ) 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', 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 If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 > 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 V. Sima, Research Institute for Informatics, Bucharest, July 2011, C Dec. 2016, May 2020. 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, LQUERY, 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 ) INTEGER ISAVE( 3 ) C .. External Functions .. LOGICAL LSAME, SELECT DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS, LSAME, SELECT C .. External Subroutines .. EXTERNAL DCOPY, DGEES, DLACN2, 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' ) LQUERY = LDWORK.EQ.-1 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 MINWRK = MAX( 1, MINWRK ) IF( LQUERY ) THEN IF( NOFACT ) THEN CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, $ SDIM, WR, WI, U, LDU, DWORK, -1, BWORK, $ INFO ) LWA = MAX( MINWRK, INT( DWORK( 1 ) ) ) ELSE LWA = MINWRK END IF ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -19 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB03MD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = LWA 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 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 DLACN2( NN, DWORK(NN+1), DWORK, IWORK, EST, KASE, ISAVE ) 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 control-4.1.2/src/slicot/src/PaxHeaders/NF01BY.f0000644000000000000000000000013015012430707016172 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/NF01BY.f0000644000175000017500000002116615012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BY( CJTE, NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, $ LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the Jacobian of the error function for a neural network C of the structure C C - tanh(w1*z+b1) - C / : \ C z --- : --- sum(ws(i)*...)+ b(n+1) --- y, C \ : / C - tanh(wn*z+bn) - C C for the single-output case. The Jacobian has the form C C d e(1) / d WB(1) ... d e(1) / d WB(NWB) C J = : : , C d e(NSMP) / d WB(1) ... d e(NSMP) / d WB(NWB) C C where e(z) is the error function, WB is the set of weights and C biases of the network (for the considered output), and NWB is C the number of elements of this set, NWB = IPAR(1)*(NZ+2)+1 C (see below). C C In the multi-output case, this routine should be called for each C output. C C NOTE: this routine must have the same arguments as SLICOT Library C routine NF01BD. C C ARGUMENTS C C Mode Parameters C C CJTE CHARACTER*1 C Specifies whether the matrix-vector product J'*e should be C computed or not, as follows: C = 'C' : compute J'*e; C = 'N' : do not compute J'*e. C C Input/Output Parameters C C NSMP (input) INTEGER C The number of training samples. NSMP >= 0. C C NZ (input) INTEGER C The length of each input sample. NZ >= 0. C C L (input) INTEGER C The length of each output sample. C Currently, L must be 1. C C IPAR (input/output) INTEGER array, dimension (LIPAR) C The integer parameters needed. C On entry, the first element of this array must contain C a value related to the number of neurons, n; specifically, C n = abs(IPAR(1)), since setting IPAR(1) < 0 has a special C meaning (see below). C On exit, if IPAR(1) < 0 on entry, then no computations are C performed, except the needed tests on input parameters, C but the following values are returned: C IPAR(1) contains the length of the array J, LJ; C LDJ contains the leading dimension of array J. C Otherwise, IPAR(1) and LDJ are unchanged on exit. C C LIPAR (input) INTEGER C The length of the vector IPAR. LIPAR >= 1. C C WB (input) DOUBLE PRECISION array, dimension (LWB) C The leading NWB = IPAR(1)*(NZ+2)+1 part of this array C must contain the weights and biases of the network, C WB = ( w(1,1), ..., w(1,NZ), ..., w(n,1), ..., w(n,NZ), C ws(1), ..., ws(n), b(1), ..., b(n+1) ), C where w(i,j) are the weights of the hidden layer, C ws(i) are the weights of the linear output layer and C b(i) are the biases. C C LWB (input) INTEGER C The length of array WB. LWB >= NWB. C C Z (input) DOUBLE PRECISION array, dimension (LDZ, NZ) C The leading NSMP-by-NZ part of this array must contain the C set of input samples, C Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ). C C LDZ INTEGER C The leading dimension of array Z. LDZ >= MAX(1,NSMP). C C E (input) DOUBLE PRECISION array, dimension (NSMP) C If CJTE = 'C', this array must contain the error vector e. C If CJTE = 'N', this array is not referenced. C C J (output) DOUBLE PRECISION array, dimension (LDJ, NWB) C The leading NSMP-by-NWB part of this array contains the C Jacobian of the error function. C C LDJ INTEGER C The leading dimension of array J. LDJ >= MAX(1,NSMP). C Note that LDJ is an input parameter, except for C IPAR(1) < 0 on entry, when it is an output parameter. C C JTE (output) DOUBLE PRECISION array, dimension (NWB) C If CJTE = 'C', this array contains the matrix-vector C product J'*e. C If CJTE = 'N', this array is not referenced. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C This argument is included for combatibility with SLICOT C Library routine NF01BD. C C LDWORK INTEGER C Normally, the length of the array DWORK. LDWORK >= 0. 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 Jacobian is computed analytically. C C CONTRIBUTORS C C A. Riedel, R. Schneider, Chemnitz University of Technology, C Oct. 2000, during a stay at University of Twente, NL. C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. C C REVISIONS C C - C C KEYWORDS C C Input output description, neural network, nonlinear system, C optimization, system response. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER CJTE INTEGER INFO, L, LDJ, LDWORK, LDZ, LIPAR, LWB, NSMP, NZ C .. Array Arguments .. DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), WB(*), $ Z(LDZ,*) INTEGER IPAR(*) C .. Local Scalars .. LOGICAL WJTE INTEGER BP1, DI, I, IB, K, M, NN, NWB, WS DOUBLE PRECISION BIGNUM, SMLNUM, TMP C .. External Functions .. DOUBLE PRECISION DLAMCH LOGICAL LSAME EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, EXP, LOG, MAX, MIN C .. C .. Executable Statements .. C WJTE = LSAME( CJTE, 'C' ) INFO = 0 NN = IPAR(1) NWB = NN*( NZ + 2 ) + 1 IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN INFO = -1 ELSEIF ( NSMP.LT.0 ) THEN INFO = -2 ELSEIF ( NZ.LT.0 ) THEN INFO = -3 ELSEIF ( L.NE.1 ) THEN INFO = -4 ELSEIF ( LIPAR.LT.1 ) THEN INFO = -6 ELSEIF ( IPAR(1).LT.0 ) THEN IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01BY', -INFO ) ELSE IPAR(1) = NSMP*( ABS( NN )*( NZ + 2 ) + 1 ) LDJ = NSMP ENDIF RETURN ELSEIF ( LWB.LT.NWB ) THEN INFO = -8 ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN INFO = -10 ELSEIF ( LDJ.LT.MAX( 1, NSMP ) ) THEN INFO = -13 ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01BY', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( MIN( NSMP, NZ ).EQ.0 ) $ RETURN C C Set parameters to avoid overflows and increase accuracy for C extreme values. C SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = LOG( SMLNUM ) BIGNUM = LOG( BIGNUM ) C WS = NZ*NN + 1 IB = WS + NN BP1 = IB + NN C J(1, BP1) = ONE CALL DCOPY( NSMP, J(1, BP1), 0, J(1, BP1), 1 ) C DO 10 I = 0, NN - 1 CALL DCOPY( NSMP, WB(IB+I), 0, J(1, WS+I), 1 ) 10 CONTINUE C CALL DGEMM( 'NoTranspose', 'NoTranspose', NSMP, NN, NZ, -TWO, Z, $ LDZ, WB, NZ, -TWO, J(1, WS), LDJ ) DI = 1 C DO 50 I = 0, NN - 1 C DO 20 K = 1, NSMP TMP = J(K, WS+I) IF ( ABS( TMP ).GE.BIGNUM ) THEN IF ( TMP.GT.ZERO ) THEN J(K, WS+I) = -ONE ELSE J(K, WS+I) = ONE END IF ELSE IF ( ABS( TMP ).LE.SMLNUM ) THEN J(K, WS+I) = ZERO ELSE J(K, WS+I) = TWO/( ONE + EXP( TMP ) ) - ONE END IF J(K, IB+I) = WB(WS+I)*( ONE - J(K, WS+I)**2 ) 20 CONTINUE C DO 40 K = 0, NZ - 1 C DO 30 M = 1, NSMP J(M, DI+K) = J(M, IB+I)*Z(M, K+1) 30 CONTINUE C 40 CONTINUE C DI = DI + NZ 50 CONTINUE C IF ( WJTE ) THEN C C Compute J'e. C CALL DGEMV( 'Transpose', NSMP, NWB, ONE, J, LDJ, E, 1, ZERO, $ JTE, 1 ) END IF C RETURN C C *** Last line of NF01BY *** END control-4.1.2/src/slicot/src/PaxHeaders/MD03AD.f0000644000000000000000000000013015012430707016143 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MD03AD.f0000644000175000017500000011151615012430707017346 0ustar00lilgelilge00000000000000 SUBROUTINE MD03AD( XINIT, ALG, STOR, UPLO, FCN, JPJ, M, N, ITMAX, $ NPRINT, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEV, NJEV, TOL, CGTOL, DWORK, $ LDWORK, IWARN, INFO ) C C PURPOSE C C To minimize the sum of the squares of m nonlinear functions, e, in C n variables, x, by a modification of the Levenberg-Marquardt C algorithm, using either a Cholesky-based or a conjugate gradients C solver. The user must provide a subroutine FCN which calculates C the functions and the Jacobian J (possibly by finite differences), C and another subroutine JPJ, which computes either J'*J + par*I C (if ALG = 'D'), or (J'*J + par*I)*x (if ALG = 'I'), where par is C the Levenberg factor, exploiting the possible structure of the C Jacobian matrix. Template implementations of these routines are C included in the SLICOT Library. C C ARGUMENTS C C Mode Parameters C C XINIT CHARACTER*1 C Specifies how the variables x are initialized, as follows: C = 'R' : the array X is initialized to random values; the C entries DWORK(1:4) are used to initialize the C random number generator: the first three values C are converted to integers between 0 and 4095, and C the last one is converted to an odd integer C between 1 and 4095; C = 'G' : the given entries of X are used as initial values C of variables. C C ALG CHARACTER*1 C Specifies the algorithm used for solving the linear C systems involving a Jacobian matrix J, as follows: C = 'D' : a direct algorithm, which computes the Cholesky C factor of the matrix J'*J + par*I is used; C = 'I' : an iterative Conjugate Gradients algorithm, which C only needs the matrix J, is used. C In both cases, matrix J is stored in a compressed form. C C STOR CHARACTER*1 C If ALG = 'D', specifies the storage scheme for the C symmetric matrix J'*J, as follows: C = 'F' : full storage is used; C = 'P' : packed storage is used. C The option STOR = 'F' usually ensures a faster execution. C This parameter is not relevant if ALG = 'I'. C C UPLO CHARACTER*1 C If ALG = 'D', specifies which part of the matrix J'*J C is stored, as follows: C = 'U' : the upper triagular part is stored; C = 'L' : the lower triagular part is stored. C The option UPLO = 'U' usually ensures a faster execution. C This parameter is not relevant if ALG = 'I'. C C Function Parameters C C FCN EXTERNAL C Subroutine which evaluates the functions and the Jacobian. C FCN must be declared in an external statement in the user C calling program, and must have the following interface: C C SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, C $ DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, JTE, C $ DWORK, LDWORK, INFO ) C C where C C IFLAG (input/output) INTEGER C On entry, this parameter must contain a value C defining the computations to be performed: C = 0 : Optionally, print the current iterate X, C function values E, and Jacobian matrix J, C or other results defined in terms of these C values. See the argument NPRINT of MD03AD. C Do not alter E and J. C = 1 : Calculate the functions at X and return C this vector in E. Do not alter J. C = 2 : Calculate the Jacobian at X and return C this matrix in J. Also return J'*e in JTE C and NFEVL (see below). Do not alter E. C = 3 : Do not compute neither the functions nor C the Jacobian, but return in LDJ and C IPAR/DPAR1,DPAR2 (some of) the integer/real C parameters needed. C On exit, the value of this parameter should not be C changed by FCN unless the user wants to terminate C execution of MD03AD, in which case IFLAG must be C set to a negative integer. C C M (input) INTEGER C The number of functions. M >= 0. C C N (input) INTEGER C The number of variables. M >= N >= 0. C C IPAR (input/output) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of C the Jacobian matrix or needed for problem solving. C IPAR is an input parameter, except for IFLAG = 3 C on entry, when it is also an output parameter. C On exit, if IFLAG = 3, IPAR(1) contains the length C of the array J, for storing the Jacobian matrix, C and the entries IPAR(2:5) contain the workspace C required by FCN for IFLAG = 1, FCN for IFLAG = 2, C JPJ for ALG = 'D', and JPJ for ALG = 'I', C respectively. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 5. C C DPAR1 (input/output) DOUBLE PRECISION array, dimension C (LDPAR1,*) or (LDPAR1) C A first set of real parameters needed for C describing or solving the problem. C DPAR1 can also be used as an additional array for C intermediate results when computing the functions C or the Jacobian. For control problems, DPAR1 could C store the input trajectory of a system. C C LDPAR1 (input) INTEGER C The leading dimension or the length of the array C DPAR1, as convenient. LDPAR1 >= 0. (LDPAR1 >= 1, C if leading dimension.) C C DPAR2 (input/output) DOUBLE PRECISION array, dimension C (LDPAR2,*) or (LDPAR2) C A second set of real parameters needed for C describing or solving the problem. C DPAR2 can also be used as an additional array for C intermediate results when computing the functions C or the Jacobian. For control problems, DPAR2 could C store the output trajectory of a system. C C LDPAR2 (input) INTEGER C The leading dimension or the length of the array C DPAR2, as convenient. LDPAR2 >= 0. (LDPAR2 >= 1, C if leading dimension.) C C X (input) DOUBLE PRECISION array, dimension (N) C This array must contain the value of the C variables x where the functions or the Jacobian C must be evaluated. C C NFEVL (input/output) INTEGER C The number of function evaluations needed to C compute the Jacobian by a finite difference C approximation. C NFEVL is an input parameter if IFLAG = 0, or an C output parameter if IFLAG = 2. If the Jacobian is C computed analytically, NFEVL should be set to a C non-positive value. C C E (input/output) DOUBLE PRECISION array, C dimension (M) C This array contains the value of the (error) C functions e evaluated at X. C E is an input parameter if IFLAG = 0 or 2, or an C output parameter if IFLAG = 1. C C J (input/output) DOUBLE PRECISION array, dimension C (LDJ,NC), where NC is the number of columns C needed. C This array contains a possibly compressed C representation of the Jacobian matrix evaluated C at X. If full Jacobian is stored, then NC = N. C J is an input parameter if IFLAG = 0, or an output C parameter if IFLAG = 2. C C LDJ (input/output) INTEGER C The leading dimension of array J. LDJ >= 1. C LDJ is essentially used inside the routines FCN C and JPJ. C LDJ is an input parameter, except for IFLAG = 3 C on entry, when it is an output parameter. C It is assumed in MD03AD that LDJ is not larger C than needed. C C JTE (output) DOUBLE PRECISION array, dimension (N) C If IFLAG = 2, the matrix-vector product J'*e. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C The workspace array for subroutine FCN. C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C C LDWORK (input) INTEGER C The size of the array DWORK (as large as needed C in the subroutine FCN). LDWORK >= 1. C C INFO INTEGER C Error indicator, set to a negative value if an C input (scalar) argument is erroneous, and to C positive values for other possible errors in the C subroutine FCN. The LAPACK Library routine XERBLA C should be used in conjunction with negative INFO. C INFO must be zero if the subroutine finished C successfully. C C Parameters marked with "(input)" must not be changed. C C JPJ EXTERNAL C Subroutine which computes J'*J + par*I, if ALG = 'D', and C J'*J*x + par*x, if ALG = 'I', where J is the Jacobian as C described above. C C JPJ must have the following interface: C C SUBROUTINE JPJ( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, C $ J, LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) C C if ALG = 'D', and C C SUBROUTINE JPJ( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, C $ INCX, DWORK, LDWORK, INFO ) C C if ALG = 'I', where C C STOR (input) CHARACTER*1 C Specifies the storage scheme for the symmetric C matrix J'*J, as follows: C = 'F' : full storage is used; C = 'P' : packed storage is used. C C UPLO (input) CHARACTER*1 C Specifies which part of the matrix J'*J is stored, C as follows: C = 'U' : the upper triagular part is stored; C = 'L' : the lower triagular part is stored. C C N (input) INTEGER C The number of columns of the matrix J. N >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of C the Jacobian matrix. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 0. C C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) C DPAR(1) must contain an initial estimate of the C Levenberg-Marquardt parameter, par. DPAR(1) >= 0. C C LDPAR (input) INTEGER C The length of the array DPAR. LDPAR >= 1. C C J (input) DOUBLE PRECISION array, dimension C (LDJ, NC), where NC is the number of columns. C The leading NR-by-NC part of this array must C contain the (compressed) representation of the C Jacobian matrix J, where NR is the number of rows C of J (function of IPAR entries). C C LDJ (input) INTEGER C The leading dimension of array J. C LDJ >= MAX(1,NR). C C JTJ (output) DOUBLE PRECISION array, C dimension (LDJTJ,N), if STOR = 'F', C dimension (N*(N+1)/2), if STOR = 'P'. C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 C (if STOR = 'P') part of this array contains the C upper or lower triangle of the matrix J'*J+par*I, C depending on UPLO = 'U', or UPLO = 'L', C respectively, stored either as a two-dimensional, C or one-dimensional array, depending on STOR. C C LDJTJ (input) INTEGER C The leading dimension of the array JTJ. C LDJTJ >= MAX(1,N), if STOR = 'F'. C LDJTJ >= 1, if STOR = 'P'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C The workspace array for subroutine JPJ. C C LDWORK (input) INTEGER C The size of the array DWORK (as large as needed C in the subroutine JPJ). C C INFO INTEGER C Error indicator, set to a negative value if an C input (scalar) argument is erroneous, and to C positive values for other possible errors in the C subroutine JPJ. The LAPACK Library routine XERBLA C should be used in conjunction with negative INFO C values. INFO must be zero if the subroutine C finished successfully. C C If ALG = 'I', the parameters in common with those for C ALG = 'D', have the same meaning, and the additional C parameters are: C C X (input/output) DOUBLE PRECISION array, dimension C (1+(N-1)*INCX) C On entry, this incremented array must contain the C vector x. C On exit, this incremented array contains the value C of the matrix-vector product (J'*J + par)*x. C C INCX (input) INTEGER C The increment for the elements of X. INCX > 0. C C Parameters marked with "(input)" must not be changed. C C Input/Output Parameters C C M (input) INTEGER C The number of functions. M >= 0. C C N (input) INTEGER C The number of variables. M >= N >= 0. C C ITMAX (input) INTEGER C The maximum number of iterations. ITMAX >= 0. C C NPRINT (input) INTEGER C This parameter enables controlled printing of iterates if C it is positive. In this case, FCN is called with IFLAG = 0 C at the beginning of the first iteration and every NPRINT C iterations thereafter and immediately prior to return, C with X, E, and J available for printing. If NPRINT is not C positive, no special calls of FCN with IFLAG = 0 are made. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters needed, for instance, for C describing the structure of the Jacobian matrix, which C are handed over to the routines FCN and JPJ. C The first five entries of this array are modified C internally by a call to FCN (with IFLAG = 3), but are C restored on exit. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 5. C C DPAR1 (input/output) DOUBLE PRECISION array, dimension C (LDPAR1,*) or (LDPAR1) C A first set of real parameters needed for describing or C solving the problem. This argument is not used by MD03AD C routine, but it is passed to the routine FCN. C C LDPAR1 (input) INTEGER C The leading dimension or the length of the array DPAR1, as C convenient. LDPAR1 >= 0. (LDPAR1 >= 1, if leading C dimension.) C C DPAR2 (input/output) DOUBLE PRECISION array, dimension C (LDPAR2,*) or (LDPAR2) C A second set of real parameters needed for describing or C solving the problem. This argument is not used by MD03AD C routine, but it is passed to the routine FCN. C C LDPAR2 (input) INTEGER C The leading dimension or the length of the array DPAR2, as C convenient. LDPAR2 >= 0. (LDPAR2 >= 1, if leading C dimension.) C C X (input/output) DOUBLE PRECISION array, dimension (N) C On entry, if XINIT = 'G', this array must contain the C vector of initial variables x to be optimized. C If XINIT = 'R', this array need not be set before entry, C and random values will be used to initialize x. C On exit, if INFO = 0, this array contains the vector of C values that (approximately) minimize the sum of squares of C error functions. The values returned in IWARN and C DWORK(1:5) give details on the iterative process. C C NFEV (output) INTEGER C The number of calls to FCN with IFLAG = 1. If FCN is C properly implemented, this includes the function C evaluations needed for finite difference approximation C of the Jacobian. C C NJEV (output) INTEGER C The number of calls to FCN with IFLAG = 2. C C Tolerances C C TOL DOUBLE PRECISION C If TOL >= 0, the tolerance which measures the relative C error desired in the sum of squares. Termination occurs C when the actual relative reduction in the sum of squares C is at most TOL. If the user sets TOL < 0, then SQRT(EPS) C is used instead TOL, where EPS is the machine precision C (see LAPACK Library routine DLAMCH). C C CGTOL DOUBLE PRECISION C If ALG = 'I' and CGTOL > 0, the tolerance which measures C the relative residual of the solutions computed by the C conjugate gradients (CG) algorithm. Termination of a C CG process occurs when the relative residual is at C most CGTOL. If the user sets CGTOL <= 0, then SQRT(EPS) C is used instead CGTOL. 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, DWORK(2) returns the residual error norm (the C sum of squares), DWORK(3) returns the number of iterations C performed, DWORK(4) returns the total number of conjugate C gradients iterations performed (zero, if ALG = 'D'), and C DWORK(5) returns the final Levenberg factor. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= max( 5, M + 2*N + size(J) + C max( DW( FCN|IFLAG = 1 ) + N, C DW( FCN|IFLAG = 2 ), C DW( sol ) ) ), C where size(J) is the size of the Jacobian (provided by FCN C in IPAR(1), for IFLAG = 3), DW( f ) is the workspace C needed by the routine f, where f is FCN or JPJ (provided C by FCN in IPAR(2:5), for IFLAG = 3), and DW( sol ) is the C workspace needed for solving linear systems, C DW( sol ) = N*N + DW( JPJ ), if ALG = 'D', STOR = 'F'; C DW( sol ) = N*(N+1)/2 + DW( JPJ ), C if ALG = 'D', STOR = 'P'; C DW( sol ) = 3*N + DW( JPJ ), if ALG = 'I'. C C Warning Indicator C C IWARN INTEGER C < 0: the user set IFLAG = IWARN in the subroutine FCN; C = 0: no warning; C = 1: if the iterative process did not converge in ITMAX C iterations with tolerance TOL; C = 2: if ALG = 'I', and in one or more iterations of the C Levenberg-Marquardt algorithm, the conjugate C gradient algorithm did not finish after 3*N C iterations, with the accuracy required in the C call; C = 3: the cosine of the angle between e and any column of C the Jacobian is at most FACTOR*EPS in absolute C value, where FACTOR = 100 is defined in a PARAMETER C statement; C = 4: TOL is too small: no further reduction in the sum C of squares is possible. C In all these cases, DWORK(1:5) are set as described C above. 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: user-defined routine FCN returned with INFO <> 0 C for IFLAG = 1; C = 2: user-defined routine FCN returned with INFO <> 0 C for IFLAG = 2; C = 3: SLICOT Library routine MB02XD, if ALG = 'D', or C SLICOT Library routine MB02WD, if ALG = 'I' (or C user-defined routine JPJ), returned with INFO <> 0. C C METHOD C C If XINIT = 'R', the initial value for X is set to a vector of C pseudo-random values uniformly distributed in [-1,1]. C C The Levenberg-Marquardt algorithm (described in [1]) is used for C optimizing the parameters. This algorithm needs the Jacobian C matrix J, which is provided by the subroutine FCN. The algorithm C tries to update x by the formula C C x = x - p, C C using the solution of the system of linear equations C C (J'*J + PAR*I)*p = J'*e, C C where I is the identity matrix, and e the error function vector. C The Levenberg factor PAR is decreased after each successfull step C and increased in the other case. C C If ALG = 'D', a direct method, which evaluates the matrix product C J'*J + par*I and then factors it using Cholesky algorithm, C implemented in the SLICOT Libray routine MB02XD, is used for C solving the linear system above. C C If ALG = 'I', the Conjugate Gradients method, described in [2], C and implemented in the SLICOT Libray routine MB02WD, is used for C solving the linear system above. The main advantage of this method C is that in most cases the solution of the system can be computed C in less time than the time needed to compute the matrix J'*J C This is, however, problem dependent. C C REFERENCES C C [1] Kelley, C.T. C Iterative Methods for Optimization. C Society for Industrial and Applied Mathematics (SIAM), C Philadelphia (Pa.), 1999. C C [2] Golub, G.H. and van Loan, C.F. C Matrix Computations. Third Edition. C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, C 1996. C C [3] More, J.J. C The Levenberg-Marquardt algorithm: implementation and theory. C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg C and New York, pp. 105-116, 1978. C C NUMERICAL ASPECTS C C The Levenberg-Marquardt algorithm described in [3] is scaling C invariant and globally convergent to (maybe local) minima. C According to [1], the convergence rate near a local minimum is C quadratic, if the Jacobian is computed analytically, and linear, C if the Jacobian is computed numerically. C C Whether or not the direct algorithm is faster than the iterative C Conjugate Gradients algorithm for solving the linear systems C involved depends on several factors, including the conditioning C of the Jacobian matrix, and the ratio between its dimensions. C C CONTRIBUTORS C C A. Riedel, R. Schneider, Chemnitz University of Technology, C Oct. 2000. C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, C Mar. 2002. C C KEYWORDS C C Conjugate gradients, least-squares approximation, C Levenberg-Marquardt algorithm, matrix operations, optimization. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, FIVE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FIVE = 5.0D0 ) DOUBLE PRECISION FACTOR, MARQF, MINIMP, PARMAX PARAMETER ( FACTOR = 10.0D0**2, MARQF = 2.0D0**2, $ MINIMP = 2.0D0**(-3), PARMAX = 1.0D20 ) C .. Scalar Arguments .. CHARACTER ALG, STOR, UPLO, XINIT INTEGER INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LDWORK, $ LIPAR, M, N, NFEV, NJEV, NPRINT DOUBLE PRECISION CGTOL, TOL C .. Array Arguments .. DOUBLE PRECISION DPAR1(LDPAR1,*), DPAR2(LDPAR2,*), DWORK(*), X(*) INTEGER IPAR(*) C .. Local Scalars .. LOGICAL CHOL, FULL, INIT, UPPER INTEGER DWJTJ, E, I, IFLAG, INFOL, ITER, ITERCG, IW1, $ IW2, IWARNL, JAC, JTE, JW1, JW2, JWORK, LDJ, $ LDW, LFCN1, LFCN2, LJTJ, LJTJD, LJTJI, NFEVL, $ SIZEJ, WRKOPT DOUBLE PRECISION ACTRED, BIGNUM, CGTDEF, EPSMCH, FNORM, FNORM1, $ GNORM, GSMIN, PAR, SMLNUM, SQREPS, TOLDEF C .. Local Arrays .. INTEGER SEED(4) C .. External Functions .. DOUBLE PRECISION DDOT, DLAMCH, DNRM2 LOGICAL LSAME EXTERNAL DDOT, DLAMCH, DNRM2, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLABAD, DLARNV, FCN, JPJ, MB02WD, MB02XD, $ XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, MOD, SQRT C .. C .. Executable Statements .. C C Decode the scalar input parameters. C INIT = LSAME( XINIT, 'R' ) CHOL = LSAME( ALG, 'D' ) FULL = LSAME( STOR, 'F' ) UPPER = LSAME( UPLO, 'U' ) C C Check the scalar input parameters. C IWARN = 0 INFO = 0 IF( .NOT.( INIT .OR. LSAME( XINIT, 'G' ) ) ) THEN INFO = -1 ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG, 'I' ) ) ) THEN INFO = -2 ELSEIF ( CHOL .AND. .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN INFO = -3 ELSEIF ( CHOL .AND. .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -4 ELSEIF ( M.LT.0 ) THEN INFO = -7 ELSEIF ( N.LT.0 .OR. N.GT.M ) THEN INFO = -8 ELSEIF ( ITMAX.LT.0 ) THEN INFO = -9 ELSEIF ( LIPAR.LT.5 ) THEN INFO = -12 ELSEIF( LDPAR1.LT.0 ) THEN INFO = -14 ELSEIF( LDPAR2.LT.0 ) THEN INFO = -16 ELSEIF ( LDWORK.LT.5 ) THEN INFO = -23 ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MD03AD', -INFO ) RETURN ENDIF C C Quick return if possible. C NFEV = 0 NJEV = 0 IF ( MIN( N, ITMAX ).EQ.0 ) THEN DWORK(1) = FIVE DWORK(2) = ZERO DWORK(3) = ZERO DWORK(4) = ZERO DWORK(5) = ZERO RETURN ENDIF C C Call FCN to get the size of the array J, for storing the Jacobian C matrix, the leading dimension LDJ and the workspace required C by FCN for IFLAG = 1 and IFLAG = 2, and JPJ. The entries C DWORK(1:4) should not be modified by the special call of FCN C below, if XINIT = 'R' and the values in DWORK(1:4) are explicitly C desired for initialization of the random number generator. C IFLAG = 3 IW1 = IPAR(1) IW2 = IPAR(2) JW1 = IPAR(3) JW2 = IPAR(4) LJTJ = IPAR(5) C CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, $ X, NFEVL, DWORK, DWORK, LDJ, DWORK, DWORK, LDWORK, $ INFOL ) C SIZEJ = IPAR(1) LFCN1 = IPAR(2) LFCN2 = IPAR(3) LJTJD = IPAR(4) LJTJI = IPAR(5) C IPAR(1) = IW1 IPAR(2) = IW2 IPAR(3) = JW1 IPAR(4) = JW2 IPAR(5) = LJTJ C C Define pointers to the array variables stored in DWORK. C JAC = 1 E = JAC + SIZEJ JTE = E + M IW1 = JTE + N IW2 = IW1 + N JW1 = IW2 JW2 = IW2 + N C C Check the workspace length. C JWORK = JW1 IF ( CHOL ) THEN IF ( FULL ) THEN LDW = N*N ELSE LDW = ( N*( N + 1 ) ) / 2 ENDIF DWJTJ = JWORK JWORK = DWJTJ + LDW LJTJ = LJTJD ELSE LDW = 3*N LJTJ = LJTJI ENDIF IF ( LDWORK.LT.MAX( 5, SIZEJ + M + 2*N + $ MAX( LFCN1 + N, LFCN2, LDW + LJTJ ) ) ) $ THEN INFO = -23 ENDIF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MD03AD', -INFO ) RETURN ENDIF C C Set default tolerances. SQREPS is the square root of the machine C precision, and GSMIN is used in the tests of the gradient norm. C EPSMCH = DLAMCH( 'Epsilon' ) SQREPS = SQRT( EPSMCH ) TOLDEF = TOL IF ( TOLDEF.LT.ZERO ) $ TOLDEF = SQREPS CGTDEF = CGTOL IF ( CGTDEF.LE.ZERO ) $ CGTDEF = SQREPS GSMIN = FACTOR*EPSMCH WRKOPT = 5 C SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) C C Initialization. C IF ( INIT ) THEN C C SEED is the initial state of the random number generator. C SEED(4) must be odd. C SEED(1) = MOD( INT( DWORK(1) ), 4096 ) SEED(2) = MOD( INT( DWORK(2) ), 4096 ) SEED(3) = MOD( INT( DWORK(3) ), 4096 ) SEED(4) = MOD( 2*INT( DWORK(4) ) + 1, 4096 ) CALL DLARNV( 2, SEED, N, X ) ENDIF C C Evaluate the function at the starting point and calculate C its norm. C Workspace: need: SIZEJ + M + 2*N + LFCN1; C prefer: larger. C IFLAG = 1 CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, $ X, NFEVL, DWORK(E), DWORK(JAC), LDJ, DWORK(JTE), $ DWORK(JW1), LDWORK-JW1+1, INFOL ) C IF ( INFOL.NE.0 ) THEN INFO = 1 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) NFEV = 1 FNORM = DNRM2( M, DWORK(E), 1 ) ACTRED = ZERO ITERCG = 0 ITER = 0 IWARNL = 0 PAR = ZERO IF ( IFLAG.LT.0 .OR. FNORM.EQ.ZERO ) $ GO TO 40 C C Set the initial vector for the conjugate gradients algorithm. C DWORK(IW1) = ZERO CALL DCOPY( N, DWORK(IW1), 0, DWORK(IW1), 1 ) C C WHILE ( nonconvergence and ITER < ITMAX ) DO C C Beginning of the outer loop. C 10 CONTINUE C C Calculate the Jacobian matrix. C Workspace: need: SIZEJ + M + 2*N + LFCN2; C prefer: larger. C ITER = ITER + 1 IFLAG = 2 CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEVL, DWORK(E), DWORK(JAC), LDJ, $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) C IF ( INFOL.NE.0 ) THEN INFO = 2 RETURN END IF C C Compute the gradient norm. C GNORM = DNRM2( N, DWORK(JTE), 1 ) IF ( NFEVL.GT.0 ) $ NFEV = NFEV + NFEVL NJEV = NJEV + 1 IF ( GNORM.LE.GSMIN ) $ IWARN = 3 IF ( IWARN.NE.0 ) $ GO TO 40 IF ( ITER.EQ.1 ) THEN WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) PAR = MIN( GNORM, SQRT( PARMAX ) ) END IF IF ( IFLAG.LT.0 ) $ GO TO 40 C C If requested, call FCN to enable printing of iterates. C IF ( NPRINT.GT.0 ) THEN IFLAG = 0 IF ( MOD( ITER-1, NPRINT ).EQ.0 ) THEN CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) C IF ( IFLAG.LT.0 ) $ GO TO 40 END IF END IF C C Beginning of the inner loop. C 20 CONTINUE C C Store the Levenberg factor in DWORK(E) (which is no longer C needed), to pass it to JPJ routine. C DWORK(E) = PAR C C Solve (J'*J + PAR*I)*x = J'*e, and store x in DWORK(IW1). C Additional workspace: C N*N + DW(JPJ), if ALG = 'D', STOR = 'F'; C N*( N + 1)/2 + DW(JPJ), if ALG = 'D', STOR = 'P'; C 3*N + DW(JPJ), if ALG = 'I'. C IF ( CHOL ) THEN CALL DCOPY( N, DWORK(JTE), 1, DWORK(IW1), 1 ) CALL MB02XD( 'Function', STOR, UPLO, JPJ, M, N, 1, IPAR, $ LIPAR, DWORK(E), 1, DWORK(JAC), LDJ, $ DWORK(IW1), N, DWORK(DWJTJ), N, $ DWORK(JWORK), LDWORK-JWORK+1, INFOL ) ELSE CALL MB02WD( 'Function', JPJ, N, IPAR, LIPAR, DWORK(E), $ 1, 3*N, DWORK(JAC), LDJ, DWORK(JTE), 1, $ DWORK(IW1), 1, CGTOL*GNORM, DWORK(JWORK), $ LDWORK-JWORK+1, IWARN, INFOL ) ITERCG = ITERCG + INT( DWORK(JWORK) ) IWARNL = MAX( 2*IWARN, IWARNL ) ENDIF C IF ( INFOL.NE.0 ) THEN INFO = 3 RETURN ENDIF C C Compute updated X. C DO 30 I = 0, N - 1 DWORK(IW2+I) = X(I+1) - DWORK(IW1+I) 30 CONTINUE C C Evaluate the function at x - p and calculate its norm. C Workspace: need: SIZEJ + M + 3*N + LFCN1; C prefer: larger. C IFLAG = 1 CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, DWORK(IW2), NFEVL, DWORK(E), DWORK(JAC), $ LDJ, DWORK(JTE), DWORK(JW2), LDWORK-JW2+1, INFOL ) C IF ( INFOL.NE.0 ) THEN INFO = 1 RETURN END IF C NFEV = NFEV + 1 IF ( IFLAG.LT.0 ) $ GO TO 40 FNORM1 = DNRM2( M, DWORK(E), 1 ) C C Now, check whether this step was successful and update the C Levenberg factor. C IF ( FNORM.LT.FNORM1 ) THEN C C Unsuccessful step: increase PAR. C ACTRED = ONE IF ( PAR.GT.PARMAX ) THEN IF ( PAR/MARQF.LE.BIGNUM ) $ PAR = PAR*MARQF ELSE PAR = PAR*MARQF END IF C ELSE C C Successful step: update PAR, X, and FNORM. C ACTRED = ONE - ( FNORM1/FNORM )**2 IF ( ( FNORM - FNORM1 )*( FNORM + FNORM1 ) .LT. $ MINIMP*DDOT( N, DWORK(IW1), 1, $ DWORK(JTE), 1 ) ) THEN IF ( PAR.GT.PARMAX ) THEN IF ( PAR/MARQF.LE.BIGNUM ) $ PAR = PAR*MARQF ELSE PAR = PAR*MARQF END IF ELSE PAR = MAX( PAR/MARQF, SMLNUM ) ENDIF CALL DCOPY( N, DWORK(IW2), 1, X, 1 ) FNORM = FNORM1 ENDIF C IF ( ( ACTRED.LE.TOLDEF ) .OR. ( ITER.GT.ITMAX ) .OR. $ ( PAR.GT.PARMAX ) ) $ GO TO 40 IF ( ACTRED.LE.EPSMCH ) THEN IWARN = 4 GO TO 40 ENDIF C C End of the inner loop. Repeat if unsuccessful iteration. C IF ( FNORM.LT.FNORM1 ) $ GO TO 20 C C End of the outer loop. C GO TO 10 C C END WHILE 10 C 40 CONTINUE C C Termination, either normal or user imposed. C IF ( ACTRED.GT.TOLDEF ) $ IWARN = 1 IF ( IWARNL.NE.0 ) $ IWARN = 2 C IF ( IFLAG.LT.0 ) $ IWARN = IFLAG IF ( NPRINT.GT.0 ) THEN IFLAG = 0 CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) IF ( IFLAG.LT.0 ) $ IWARN = IFLAG END IF C DWORK(1) = WRKOPT DWORK(2) = FNORM DWORK(3) = ITER DWORK(4) = ITERCG DWORK(5) = PAR C RETURN C *** Last line of MD03AD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01WD.f0000644000000000000000000000013215012430707016203 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01WD.f0000644000175000017500000002433415012430707017405 0ustar00lilgelilge00000000000000 SUBROUTINE TG01WD( N, M, P, A, LDA, E, LDE, B, LDB, C, LDC, $ Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To reduce the pair (A,E) to a real generalized Schur form C by using an orthogonal equivalence transformation C (A,E) <-- (Q'*A*Z,Q'*E*Z) and to apply the transformation C to the matrices B and C: B <-- Q'*B and C <-- C*Z. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e., the order of the matrices A and E. N >= 0. C C M (input) INTEGER C The number of system inputs, or of columns of B. M >= 0. C C P (input) INTEGER C The number of system outputs, or of rows of C. 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 original state dynamics matrix A. C On exit, the leading N-by-N part of this array contains C the matrix Q' * A * Z in an upper quasi-triangular form. C The elements below the first subdiagonal are set to zero. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the original descriptor matrix E. C On exit, the leading N-by-N part of this array contains C the matrix Q' * E * Z in an upper triangular form. C The elements below the diagonal are set to zero. C C LDE INTEGER C The leading dimension of array E. LDE >= 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 matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix Q' * B. 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 output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed output matrix C * Z. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) C The leading N-by-N part of this array contains the left C orthogonal transformation matrix used to reduce (A,E) to C the real generalized Schur form. C The columns of Q are the left generalized Schur vectors C of the pair (A,E). C C LDQ INTEGER C The leading dimension of array Q. LDQ >= 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 right C orthogonal transformation matrix used to reduce (A,E) to C the real generalized Schur form. C The columns of Z are the right generalized Schur vectors C of the pair (A,E). C C LDZ INTEGER C The leading dimension of array Z. LDZ >= max(1,N). 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 On exit, if INFO = 0, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), C j=1,...,N, will be the generalized eigenvalues. C ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j=1,...,N, are the C diagonals of the complex Schur form that would result if C the 2-by-2 diagonal blocks of the real Schur form of C (A,E) were further reduced to triangular form using C 2-by-2 complex unitary transformations. C If ALPHAI(j) is zero, then the j-th eigenvalue is real; C if positive, then the j-th and (j+1)-st eigenvalues are a C complex conjugate pair, with ALPHAI(j+1) negative. 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. LDWORK >= 8*N+16. 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 QZ algorithm failed to compute C the generalized real Schur form; elements i+1:N of C ALPHAR, ALPHAI, and BETA should be correct. C C METHOD C C The pair (A,E) is reduced to a real generalized Schur form using C an orthogonal equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z) C and the transformation is applied to the matrices B and C: C B <-- Q'*B and C <-- C*Z. C C NUMERICAL ASPECTS C 3 C The algorithm requires about 25N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, July 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. C C KEYWORDS C C Orthogonal transformation, generalized real Schur form, similarity C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, $ M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), $ BETA(*), C(LDC,*), DWORK(*), E(LDE,*), $ Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. LOGICAL BLAS3, BLOCK INTEGER BL, CHUNK, I, J, MAXWRK, SDIM C .. Local Arrays .. LOGICAL BWORK(1) C .. External Functions .. LOGICAL LSAME, DELCTG EXTERNAL LSAME, DELCTG C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DGGES, DLACPY, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C C .. Executable Statements .. C INFO = 0 C C Check the scalar input parameters. 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDE.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( LDQ.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDWORK.LT.8*N+16 ) THEN INFO = -20 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01WD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Reduce (A,E) to real generalized Schur form using an orthogonal C equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z), accumulate C the transformations in Q and Z, and compute the generalized C eigenvalues of the pair (A,E) in (ALPHAR, ALPHAI, BETA). C C Workspace: need 8*N+16; C prefer larger. C CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N, $ A, LDA, E, LDE, SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, $ Z, LDZ, DWORK, LDWORK, BWORK, INFO ) IF( INFO.NE.0 ) $ RETURN MAXWRK = INT( DWORK(1) ) C C Apply the transformation: B <-- Q'*B. Use BLAS 3, if enough space. C CHUNK = LDWORK / N BLOCK = M.GT.1 BLAS3 = CHUNK.GE.M .AND. BLOCK C IF( BLAS3 ) THEN C C Enough workspace for a fast BLAS 3 algorithm. C CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, Q, LDQ, $ DWORK, N, ZERO, B, LDB ) C ELSE IF ( BLOCK ) THEN C C Use as many columns of B as possible. C DO 10 J = 1, M, CHUNK BL = MIN( M-J+1, CHUNK ) CALL DLACPY( 'Full', N, BL, B(1,J), LDB, DWORK, N ) CALL DGEMM( 'Transpose', 'NoTranspose', N, BL, N, ONE, Q, $ LDQ, DWORK, N, ZERO, B(1,J), LDB ) 10 CONTINUE C ELSE C C Use a BLAS 2 algorithm. Here, M <= 1. C IF ( M.GT.0 ) THEN CALL DCOPY( N, B, 1, DWORK, 1 ) CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1, ZERO, $ B, 1 ) END IF END IF MAXWRK = MAX( MAXWRK, N*M ) C C Apply the transformation: C <-- C*Z. Use BLAS 3, if enough space. C BLOCK = P.GT.1 BLAS3 = CHUNK.GE.P .AND. BLOCK C IF ( BLAS3 ) THEN CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, $ DWORK, P, Z, LDZ, ZERO, C, LDC ) C ELSE IF ( BLOCK ) THEN C C Use as many rows of C as possible. C DO 20 I = 1, P, CHUNK BL = MIN( P-I+1, CHUNK ) CALL DLACPY( 'Full', BL, N, C(I,1), LDC, DWORK, BL ) CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE, $ DWORK, BL, Z, LDZ, ZERO, C(I,1), LDC ) 20 CONTINUE C ELSE C C Use a BLAS 2 algorithm. Here, P <= 1. C IF ( P.GT.0 ) THEN CALL DCOPY( N, C, LDC, DWORK, 1 ) CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1, ZERO, $ C, LDC ) END IF C END IF MAXWRK = MAX( MAXWRK, P*N ) C DWORK(1) = DBLE( MAXWRK ) C RETURN C *** Last line of TG01WD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB08MY.f0000644000000000000000000000013215012430707016217 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB08MY.f0000644000175000017500000000454715012430707017425 0ustar00lilgelilge00000000000000 SUBROUTINE SB08MY( DA, A, B, EPSB ) C C PURPOSE C C To compute the coefficients of B(s) = A(s) * A(-s) and a norm C for the accuracy of the computed coefficients. C C ARGUMENTS C C Input/Output Parameters C C DA (input) INTEGER C The degree of the polynomials A(s) and B(s). DA >= 0. C C A (input) DOUBLE PRECISION array, dimension (DA+1) C This array must contain the coefficients of the polynomial C A(s) in increasing powers of s. C C B (output) DOUBLE PRECISION array, dimension (DA+1) C This array contains the coefficients of the polynomial C B(s) in increasing powers of s**2. C C EPSB (input/output) DOUBLE PRECISION C On entry, EPSB must contain the machine precision (see C LAPACK Library routine DLAMCH). C On exit, EPSB contains an updated value, using a norm C for the accuracy of the computed coefficients. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB08AZ by A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Laplace transform, polynomial operations, spectral factorization. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO=2.0D0, $ THREE = 3.0D0 ) C .. Scalar Arguments .. INTEGER DA DOUBLE PRECISION EPSB C .. Array Arguments .. DOUBLE PRECISION A(*), B(*) C .. Local Scalars .. INTEGER I, K DOUBLE PRECISION MAXSA, SA, SABS, SIGNI, SIGNK, TERM C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. Executable Statements .. C SIGNI = ONE MAXSA = ZERO C DO 40 I = 0, DA SABS = A(I+1)**2 SA = SIGNI*SABS SIGNK = -TWO*SIGNI C DO 20 K = 1, MIN( I, DA - I ) TERM = SIGNK*A(I-K+1)*A(I+K+1) SA = SA + TERM SABS = SABS + ABS( TERM ) SIGNK = -SIGNK 20 CONTINUE C B(I+1) = SA MAXSA = MAX( MAXSA, SABS ) SIGNI = -SIGNI 40 CONTINUE C EPSB = THREE*MAXSA*EPSB C RETURN C *** Last line of SB08MY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02PD.f0000644000000000000000000000013215012430707016161 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02PD.f0000644000175000017500000005116715012430707017367 0ustar00lilgelilge00000000000000 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 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 = 'E': The matrix A will be equilibrated if necessary, C then copied to AF and factored. C C TRANS CHARACTER*1 C Specifies the form of the system of equations as follows: C = 'N': A * X = B (No transpose); C = 'T': A**T * X = B (Transpose); C = 'C': A**H * X = B (Transpose). C C Input/Output Parameters C C N (input) INTEGER C The number of linear equations, i.e., the order of the C matrix A. N >= 0. C C NRHS (input) INTEGER C The number of right hand sides, i.e., the number of C columns of the matrices B and X. NRHS >= 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' and EQUED is not 'N', C then A must have been equilibrated by the scaling factors C in R and/or C. A is not modified if FACT = 'F' or 'N', C or if FACT = 'E' and EQUED = 'N' on exit. C On exit, if EQUED .NE. 'N', the leading N-by-N part of C this array contains the matrix A scaled as follows: C EQUED = 'R': A := diag(R) * A; C EQUED = 'C': A := A * diag(C); C EQUED = 'B': A := diag(R) * A * diag(C). C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C AF (input or output) DOUBLE PRECISION array, dimension C (LDAF,N) C If FACT = 'F', then AF is an input argument and on entry C the leading N-by-N part of this array must contain the C factors L and U from the factorization A = P*L*U as C computed by DGETRF. If EQUED .NE. 'N', then AF is the C factored form of the equilibrated matrix A. C If FACT = 'N', then AF is an output argument and on exit C the leading N-by-N part of this array contains the factors C L and U from the factorization A = P*L*U of the original C matrix A. C If FACT = 'E', then AF is an output argument and on exit C the leading N-by-N part of this array contains the factors C L and U from the factorization A = P*L*U of the C equilibrated matrix A (see the description of A for the C form of the equilibrated matrix). C C LDAF (input) INTEGER C The leading dimension of the array AF. LDAF >= max(1,N). C C IPIV (input or output) INTEGER array, dimension (N) C If FACT = 'F', then IPIV is an input argument and on entry C it must contain the pivot indices from the factorization C A = P*L*U as computed by DGETRF; row i of the matrix was C interchanged with row IPIV(i). C If FACT = 'N', then IPIV is an output argument and on exit C it contains the pivot indices from the factorization C A = P*L*U of the original matrix A. C If FACT = 'E', then IPIV is an output argument and on exit C it contains the pivot indices from the factorization C A = P*L*U of the equilibrated matrix A. C C EQUED (input or output) CHARACTER*1 C Specifies the form of equilibration that was done as C follows: C = 'N': No equilibration (always true if FACT = 'N'); C = 'R': Row equilibration, i.e., A has been premultiplied C by diag(R); C = 'C': Column equilibration, i.e., A has been C postmultiplied by diag(C); C = 'B': Both row and column equilibration, i.e., A has C been replaced by diag(R) * A * diag(C). C EQUED is an input argument if FACT = 'F'; otherwise, it is C an output argument. C C R (input or output) DOUBLE PRECISION array, dimension (N) C The row scale factors for A. If EQUED = 'R' or 'B', A is C multiplied on the left by diag(R); if EQUED = 'N' or 'C', C R is not accessed. R is an input argument if FACT = 'F'; C otherwise, R is an output argument. If FACT = 'F' and C EQUED = 'R' or 'B', each element of R must be positive. C C C (input or output) DOUBLE PRECISION array, dimension (N) C The column scale factors for A. If EQUED = 'C' or 'B', C A is multiplied on the right by diag(C); if EQUED = 'N' C or 'R', C is not accessed. C is an input argument if C FACT = 'F'; otherwise, C is an output argument. If C FACT = 'F' and EQUED = 'C' or 'B', each element of C must C be positive. C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,NRHS) C On entry, the leading N-by-NRHS part of this array must C contain the right-hand side matrix B. C On exit, C if EQUED = 'N', B is not modified; C if TRANS = 'N' and EQUED = 'R' or 'B', the leading C N-by-NRHS part of this array contains diag(R)*B; C if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', the leading C N-by-NRHS part of this array contains diag(C)*B. C C LDB INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) C If INFO = 0 or INFO = N+1, the leading N-by-NRHS part of C this array contains the solution matrix X to the original C system of equations. Note that A and B are modified on C exit if EQUED .NE. 'N', and the solution to the C equilibrated system is inv(diag(C))*X if TRANS = 'N' and C EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or C 'C' and EQUED = 'R' or 'B'. C C LDX (input) INTEGER C The leading dimension of the array X. LDX >= max(1,N). C C RCOND (output) DOUBLE PRECISION C The estimate of the reciprocal condition number of the C matrix A after equilibration (if done). If RCOND is less C than the machine precision (in particular, if RCOND = 0), C the matrix is singular to working precision. This C condition is indicated by a return code of INFO > 0. C For efficiency reasons, RCOND is computed only when the C matrix A is factored, i.e., for FACT = 'N' or 'E'. For C FACT = 'F', RCOND is not used, but it is assumed that it C has been computed and checked before the routine call. C C FERR (output) DOUBLE PRECISION array, dimension (NRHS) C The estimated forward error bound for each solution vector C X(j) (the j-th column of the solution matrix X). C If XTRUE is the true solution corresponding to X(j), C FERR(j) is an estimated upper bound for the magnitude of C the largest element in (X(j) - XTRUE) divided by the C magnitude of the largest element in X(j). The estimate C is as reliable as the estimate for RCOND, and is almost C always a slight overestimate of the true error. C C BERR (output) DOUBLE PRECISION array, dimension (NRHS) C The componentwise relative backward error of each solution C vector X(j) (i.e., the smallest relative change in C any element of A or B that makes X(j) an exact solution). C C Workspace C C IWORK INTEGER array, dimension (N) C C DWORK DOUBLE PRECISION array, dimension (4*N) C On entry, if FACT = 'F', DWORK(1) contains the reciprocal C pivot growth factor norm(A)/norm(U), computed previously C by this routine, with FACT <> 'N', for the same matrix A. C On exit, DWORK(1) contains the reciprocal pivot growth C factor norm(A)/norm(U). The "max absolute element" norm is C used. If DWORK(1) is much less than 1, then the stability C of the LU factorization of the (equilibrated) matrix A C could be poor. This also means that the solution X, C condition estimator RCOND, and forward error bound FERR C could be unreliable. If factorization fails with C 0 < INFO <= N, then DWORK(1) contains the reciprocal pivot C growth factor for the leading INFO columns 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 > 0: if INFO = i, and i is C <= N: U(i,i) is exactly zero. The factorization C has been completed, but the factor U is C exactly singular, so the solution and error C bounds could not be computed. RCOND = 0 is C returned. C = N+1: U is nonsingular, but RCOND is less than C machine precision, meaning that the matrix is C singular to working precision. Nevertheless, C the solution and error bounds are computed C because there are a number of situations C where the computed solution can be more C accurate than the value of RCOND would C suggest. C The positive values for INFO are set only when the C matrix A is factored, i.e., for FACT = 'N' or 'E'. C C METHOD C C The following steps are performed: C C 1. If FACT = 'E', real scaling factors are computed to equilibrate C the system: C C TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B C TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B C TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B C C Whether or not the system will be equilibrated depends on the C scaling of the matrix A, but if equilibration is used, A is C overwritten by diag(R)*A*diag(C) and B by diag(R)*B C (if TRANS='N') or diag(C)*B (if TRANS = 'T' or 'C'). C C 2. If FACT = 'N' or 'E', the LU decomposition is used to factor C the matrix A (after equilibration if FACT = 'E') as C A = P * L * U, C where P is a permutation matrix, L is a unit lower triangular C matrix, and U is upper triangular. C C 3. If some U(i,i)=0, so that U is exactly singular, then the C routine returns with INFO = i. Otherwise, the factored form C of A is used to estimate the condition number of the matrix A. C If the reciprocal of the condition number is less than machine C precision, INFO = N+1 is returned as a warning, but the routine C still goes on to solve for X and compute error bounds as C described below. C C 4. The system of equations is solved for X using the factored form C of A. C C 5. Iterative refinement is applied to improve the computed C solution matrix and calculate error bounds and backward error C estimates for it. C C 6. If equilibration was used, the matrix X is premultiplied by C diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so C that it solves the original system before equilibration. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., Sorensen, D. C LAPACK Users' Guide: Second Edition, SIAM, Philadelphia, 1995. C C FURTHER COMMENTS C C This is a simplified version of the LAPACK Library routine DGESVX, C useful when several sets of matrix equations with the same C coefficient matrix A and/or A' should be solved. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, May 2020. C C KEYWORDS C C Condition number, matrix algebra, matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER EQUED, FACT, TRANS INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS DOUBLE PRECISION RCOND C .. C .. Array Arguments .. INTEGER IPIV( * ), IWORK( * ) DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), $ BERR( * ), C( * ), DWORK( * ), FERR( * ), $ R( * ), X( LDX, * ) C .. C .. Local Scalars .. LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU CHARACTER NORM INTEGER I, INFEQU, J DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN, $ ROWCND, RPVGRW, SMLNUM C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE, DLANTR EXTERNAL LSAME, DLAMCH, DLANGE, DLANTR C .. C .. External Subroutines .. EXTERNAL DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY, $ DLAQGE, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C INFO = 0 NOFACT = LSAME( FACT, 'N' ) EQUIL = LSAME( FACT, 'E' ) NOTRAN = LSAME( TRANS, 'N' ) IF( NOFACT .OR. EQUIL ) THEN EQUED = 'N' ROWEQU = .FALSE. COLEQU = .FALSE. ELSE ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) SMLNUM = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM END IF C C Test the input parameters. C IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) ) $ THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( NRHS.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN INFO = -10 ELSE IF( ROWEQU ) THEN RCMIN = BIGNUM RCMAX = ZERO DO 10 J = 1, N RCMIN = MIN( RCMIN, R( J ) ) RCMAX = MAX( RCMAX, R( J ) ) 10 CONTINUE IF( RCMIN.LE.ZERO ) THEN INFO = -11 ELSE IF( N.GT.0 ) THEN ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) ELSE ROWCND = ONE END IF END IF IF( COLEQU .AND. INFO.EQ.0 ) THEN RCMIN = BIGNUM RCMAX = ZERO DO 20 J = 1, N RCMIN = MIN( RCMIN, C( J ) ) RCMAX = MAX( RCMAX, C( J ) ) 20 CONTINUE IF( RCMIN.LE.ZERO ) THEN INFO = -12 ELSE IF( N.GT.0 ) THEN COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) ELSE COLCND = ONE END IF END IF IF( INFO.EQ.0 ) THEN IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -16 END IF END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02PD', -INFO ) RETURN END IF C IF( EQUIL ) THEN C C Compute row and column scalings to equilibrate the matrix A. C CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU ) IF( INFEQU.EQ.0 ) THEN C C Equilibrate the matrix. C CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ EQUED ) ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) END IF END IF C C Scale the right hand side. C IF( NOTRAN ) THEN IF( ROWEQU ) THEN DO 40 J = 1, NRHS DO 30 I = 1, N B( I, J ) = R( I )*B( I, J ) 30 CONTINUE 40 CONTINUE END IF ELSE IF( COLEQU ) THEN DO 60 J = 1, NRHS DO 50 I = 1, N B( I, J ) = C( I )*B( I, J ) 50 CONTINUE 60 CONTINUE END IF C IF( NOFACT .OR. EQUIL ) THEN C C Compute the LU factorization of A. C CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) CALL DGETRF( N, N, AF, LDAF, IPIV, INFO ) C C Return if INFO is non-zero. C IF( INFO.NE.0 ) THEN IF( INFO.GT.0 ) THEN C C Compute the reciprocal pivot growth factor of the C leading rank-deficient INFO columns of A. C RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF, $ DWORK ) IF( RPVGRW.EQ.ZERO ) THEN RPVGRW = ONE ELSE RPVGRW = DLANGE( 'M', N, INFO, A, LDA, DWORK ) / $ RPVGRW END IF DWORK( 1 ) = RPVGRW RCOND = ZERO END IF RETURN END IF C C Compute the norm of the matrix A and the C reciprocal pivot growth factor RPVGRW. C IF( NOTRAN ) THEN NORM = '1' ELSE NORM = 'I' END IF ANORM = DLANGE( NORM, N, N, A, LDA, DWORK ) RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, DWORK ) IF( RPVGRW.EQ.ZERO ) THEN RPVGRW = ONE ELSE RPVGRW = DLANGE( 'M', N, N, A, LDA, DWORK ) / RPVGRW END IF C C Compute the reciprocal of the condition number of A. C CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, DWORK, IWORK, $ INFO ) C C Set INFO = N+1 if the matrix is singular to working precision. C IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) $ INFO = N + 1 ELSE RPVGRW = DWORK( 1 ) END IF C C Compute the solution matrix X. C CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) C C Use iterative refinement to improve the computed solution and C compute error bounds and backward error estimates for it. C CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, $ LDX, FERR, BERR, DWORK, IWORK, INFO ) C C Transform the solution matrix X to a solution of the original C system. C IF( NOTRAN ) THEN IF( COLEQU ) THEN DO 80 J = 1, NRHS DO 70 I = 1, N X( I, J ) = C( I )*X( I, J ) 70 CONTINUE 80 CONTINUE DO 90 J = 1, NRHS FERR( J ) = FERR( J ) / COLCND 90 CONTINUE END IF ELSE IF( ROWEQU ) THEN DO 110 J = 1, NRHS DO 100 I = 1, N X( I, J ) = R( I )*X( I, J ) 100 CONTINUE 110 CONTINUE DO 120 J = 1, NRHS FERR( J ) = FERR( J ) / ROWCND 120 CONTINUE END IF C DWORK( 1 ) = RPVGRW RETURN C C *** Last line of MB02PD *** END control-4.1.2/src/slicot/src/PaxHeaders/DG01ND.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/DG01ND.f0000644000175000017500000001724315012430707017355 0ustar00lilgelilge00000000000000 SUBROUTINE DG01ND( INDI, N, XR, XI, INFO ) C C PURPOSE C C To compute the discrete Fourier transform, or inverse Fourier C transform, of a real signal. C C ARGUMENTS C C Mode Parameters C C INDI CHARACTER*1 C Indicates whether a Fourier transform or inverse Fourier C transform is to be performed as follows: C = 'D': (Direct) Fourier transform; C = 'I': Inverse Fourier transform. C C Input/Output Parameters C C N (input) INTEGER C Half the number of real samples. N must be a power of 2. C N >= 2. C C XR (input/output) DOUBLE PRECISION array, dimension (N+1) C On entry with INDI = 'D', the first N elements of this C array must contain the odd part of the input signal; for C example, XR(I) = A(2*I-1) for I = 1,2,...,N. C On entry with INDI = 'I', the first N+1 elements of this C array must contain the the real part of the input discrete C Fourier transform (computed, for instance, by a previous C call of the routine). C On exit with INDI = 'D', the first N+1 elements of this C array contain the real part of the output signal, that is C of the computed discrete Fourier transform. C On exit with INDI = 'I', the first N elements of this C array contain the odd part of the output signal, that is C of the computed inverse discrete Fourier transform. C C XI (input/output) DOUBLE PRECISION array, dimension (N+1) C On entry with INDI = 'D', the first N elements of this C array must contain the even part of the input signal; for C example, XI(I) = A(2*I) for I = 1,2,...,N. C On entry with INDI = 'I', the first N+1 elements of this C array must contain the the imaginary part of the input C discrete Fourier transform (computed, for instance, by a C previous call of the routine). C On exit with INDI = 'D', the first N+1 elements of this C array contain the imaginary part of the output signal, C that is of the computed discrete Fourier transform. C On exit with INDI = 'I', the first N elements of this C array contain the even part of the output signal, that is C of the computed inverse discrete Fourier transform. 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 A(1),....,A(2*N) be a real signal of 2*N samples. Then the C first N+1 samples of the discrete Fourier transform of this signal C are given by the formula: C C 2*N ((m-1)*(i-1)) C FA(m) = SUM ( A(i) * W ), C i=1 C 2 C where m = 1,2,...,N+1, W = exp(-pi*j/N) and j = -1. C C This transform can be computed as follows. First, transform A(i), C i = 1,2,...,2*N, into the complex signal Z(i) = (X(i),Y(i)), C i = 1,2,...,N. That is, X(i) = A(2*i-1) and Y(i) = A(2*i). Next, C perform a discrete Fourier transform on Z(i) by calling SLICOT C Library routine DG01MD. This gives a new complex signal FZ(k), C such that C C N ((k-1)*(i-1)) C FZ(k) = SUM ( Z(i) * V ), C i=1 C C where k = 1,2,...,N, V = exp(-2*pi*j/N). Using the values of C FZ(k), the components of the discrete Fourier transform FA can be C computed by simple linear relations, implemented in the DG01NY C subroutine. C C Finally, let C C XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)), k = 1,2,...,N, C C be the contents of the arrays XR and XI on entry to DG01NY with C INDI = 'D', then on exit XR and XI contain the real and imaginary C parts of the Fourier transform of the original real signal A. C That is, C C XR(m) = Re(FA(m)), XI(m) = Im(FA(m)), C C where m = 1,2,...,N+1. C C If INDI = 'I', then the routine evaluates the inverse Fourier C transform of a complex signal which may itself be the discrete C Fourier transform of a real signal. C C Let FA(m), m = 1,2,...,2*N, denote the full discrete Fourier C transform of a real signal A(i), i=1,2,...,2*N. The relationship C between FA and A is given by the formula: C C 2*N ((m-1)*(i-1)) C A(i) = SUM ( FA(m) * W ), C m=1 C C where W = exp(pi*j/N). C C Let C C XR(m) = Re(FA(m)) and XI(m) = Im(FA(m)) for m = 1,2,...,N+1, C C be the contents of the arrays XR and XI on entry to the routine C DG01NY with INDI = 'I', then on exit the first N samples of the C complex signal FZ are returned in XR and XI such that C C XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)) and k = 1,2,...,N. C C Next, an inverse Fourier transform is performed on FZ (e.g. by C calling SLICOT Library routine DG01MD), to give the complex signal C Z, whose i-th component is given by the formula: C C N ((k-1)*(i-1)) C Z(i) = SUM ( FZ(k) * V ), C k=1 C C where i = 1,2,...,N and V = exp(2*pi*j/N). C C Finally, the 2*N samples of the real signal A can then be obtained C directly from Z. That is, C C A(2*i-1) = Re(Z(i)) and A(2*i) = Im(Z(i)), for i = 1,2,...N. C C Note that a discrete Fourier transform, followed by an inverse C transform will result in a signal which is a factor 2*N larger C than the original input signal. C C REFERENCES C C [1] Rabiner, L.R. and Rader, C.M. C Digital Signal Processing. C IEEE Press, 1972. C C NUMERICAL ASPECTS C C The algorithm requires 0( N*log(N) ) operations. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C Supersedes Release 2.0 routine DG01BD by R. Dekeyser, and C F. Dumortier, State University of Gent, Belgium. C C REVISIONS C C - C C KEYWORDS C C Complex signals, digital signal processing, fast Fourier C transform, real signals. C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER INDI INTEGER INFO, N C .. Array Arguments .. DOUBLE PRECISION XI(*), XR(*) C .. Local Scalars .. INTEGER J LOGICAL LINDI C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DG01MD, DG01NY, XERBLA C .. Intrinsic Functions .. INTRINSIC MOD C .. Executable Statements .. C INFO = 0 LINDI = LSAME( INDI, 'D' ) C C Test the input scalar arguments. C IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN INFO = -1 ELSE J = 0 IF( N.GE.2 ) THEN J = N C WHILE ( MOD( J, 2 ).EQ.0 ) DO 10 CONTINUE IF ( MOD( J, 2 ).EQ.0 ) THEN J = J/2 GO TO 10 END IF C END WHILE 10 END IF IF ( J.NE.1 ) INFO = -2 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'DG01ND', -INFO ) RETURN END IF C C Compute the Fourier transform of Z = (XR,XI). C IF ( .NOT.LINDI ) CALL DG01NY( INDI, N, XR, XI ) C CALL DG01MD( INDI, N, XR, XI, INFO ) C IF ( LINDI ) CALL DG01NY( INDI, N, XR, XI ) C RETURN C *** Last line of DG01ND *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04TS.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04TS.f0000644000175000017500000004267115012430707017414 0ustar00lilgelilge00000000000000 SUBROUTINE MB04TS( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG, $ Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute a symplectic URV (SURV) decomposition of a real C 2N-by-2N matrix H: C C [ op(A) G ] T [ op(R11) R12 ] T C H = [ ] = U R V = U * [ ] * V , C [ Q op(B) ] [ 0 op(R22) ] C C where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real C N-by-N upper triangular matrix, op(R22) is a real N-by-N lower C Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic C matrices. Unblocked version. C C ARGUMENTS C C Mode Parameters C C TRANA CHARACTER*1 C Specifies the form of op( A ) as follows: C = 'N': op( A ) = A; C = 'T': op( A ) = A'; C = 'C': op( A ) = A'. C C TRANB CHARACTER*1 C Specifies the form of op( B ) as follows: C = 'N': op( B ) = B; C = 'T': op( B ) = B'; C = 'C': op( B ) = B'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C ILO (input) INTEGER C It is assumed that op(A) is already upper triangular, C op(B) is lower triangular and Q is zero in rows and C columns 1:ILO-1. ILO is normally set by a previous call C to MB04DD; otherwise it should be set to 1. C 1 <= ILO <= N, if N > 0; ILO=1, if 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. C On exit, the leading N-by-N part of this array contains C the triangular matrix R11, and in the zero part C information about the elementary reflectors used to C compute the SURV decomposition. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) C On entry, the leading N-by-N part of this array must C contain the matrix B. C On exit, the leading N-by-N part of this array contains C the Hessenberg matrix R22, and in the zero part C information about the elementary reflectors used to C compute the SURV decomposition. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,N). C C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) C On entry, the leading N-by-N part of this array must C contain the matrix G. C On exit, the leading N-by-N part of this array contains C the matrix R12. C C LDG INTEGER C The leading dimension of the array G. LDG >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, the leading N-by-N part of this array must C contain the matrix Q. C On exit, the leading N-by-N part of this array contains C information about the elementary reflectors used to C compute the SURV decomposition. C C LDQ INTEGER C The leading dimension of the array Q. LDG >= MAX(1,N). C C CSL (output) DOUBLE PRECISION array, dimension (2N) C On exit, the first 2N elements of this array contain the C cosines and sines of the symplectic Givens rotations C applied from the left-hand side used to compute the SURV C decomposition. C C CSR (output) DOUBLE PRECISION array, dimension (2N-2) C On exit, the first 2N-2 elements of this array contain the C cosines and sines of the symplectic Givens rotations C applied from the right-hand side used to compute the SURV C decomposition. C C TAUL (output) DOUBLE PRECISION array, dimension (N) C On exit, the first N elements of this array contain the C scalar factors of some of the elementary reflectors C applied from the left-hand side. C C TAUR (output) DOUBLE PRECISION array, dimension (N-1) C On exit, the first N-1 elements of this array contain the C scalar factors of some of the elementary reflectors C applied from the right-hand side. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -16, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,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 METHOD C C The matrices U and V are represented as products of symplectic C reflectors and Givens rotations C C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) C .... C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), C C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) C .... C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ). C C Each HU(i) has the form C C HU(i) = 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:n) is stored on exit in C Q(i+1:n,i), and tau in Q(i,i). C C Each FU(i) has the form C C FU(i) = I - nu * w * w' C C where nu is a real scalar, and w is a real vector with C w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in C A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The C scalar nu is stored in TAUL(i). C C Each GU(i) is a Givens rotation acting on rows i and n+i, C where the cosine is stored in CSL(2*i-1) and the sine in C CSL(2*i). C C Each HV(i) has the form C C HV(i) = I - tau * v * v' C C where tau is a real scalar, and v is a real vector with C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in C Q(i,i+2:n), and tau in Q(i,i+1). C C Each FV(i) has the form C C FV(i) = I - nu * w * w' C C where nu is a real scalar, and w is a real vector with C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in C B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise. C The scalar nu is stored in TAUR(i). C C Each GV(i) is a Givens rotation acting on columns i+1 and n+i+1, C where the cosine is stored in CSR(2*i-1) and the sine in C CSR(2*i). C C NUMERICAL ASPECTS C C The algorithm requires 80/3 N**3 + 20 N**2 + O(N) floating point C operations and is numerically backward stable. C C REFERENCES C C [1] Benner, P., Mehrmann, V., and Xu, H. C A numerically stable, structure preserving method for C computing the eigenvalues of real Hamiltonian or symplectic C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESUV). C C KEYWORDS C C Elementary matrix operations, Matrix decompositions, Hamiltonian C matrix C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER TRANA, TRANB INTEGER ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*) C .. Local Scalars .. LOGICAL LTRA, LTRB INTEGER I DOUBLE PRECISION ALPHA, C, NU, S, TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARF, DLARFG, DLARTG, DROT, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN INFO = -1 ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) THEN INFO = -2 ELSE IF ( N.LT.0 ) THEN INFO = -3 ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) 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 ( LDG.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF ( LDQ.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN DWORK(1) = DBLE( MAX( 1, N ) ) INFO = -18 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04TS', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C DO 10 I = ILO, N ALPHA = Q(I,I) IF ( I.LT.N ) THEN C C Generate elementary reflector HU(i) to annihilate Q(i+1:n,i) C CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, NU ) C C Apply HU(i) from the left. C Q(I,I) = ONE CALL DLARF( 'Left', N-I+1, N-I, Q(I,I), 1, NU, Q(I,I+1), $ LDQ, DWORK ) IF ( LTRA ) THEN CALL DLARF( 'Right', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I), $ LDA, DWORK ) ELSE CALL DLARF( 'Left', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I), $ LDA, DWORK ) END IF IF ( LTRB ) THEN CALL DLARF( 'Right', N, N-I+1, Q(I,I), 1, NU, B(1,I), $ LDB, DWORK ) ELSE CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, B(I,1), LDB, $ DWORK ) END IF CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, G(I,1), LDG, $ DWORK ) Q(I,I) = NU ELSE Q(I,I) = ZERO END IF C C Generate symplectic Givens rotation GU(i) to annihilate Q(i,i). C TEMP = A(I,I) CALL DLARTG( TEMP, ALPHA, C, S, A(I,I) ) C C Apply G(i) from the left. C IF ( LTRA ) THEN CALL DROT( N-I, A(I+1,I), 1, Q(I,I+1), LDQ, C, S ) ELSE CALL DROT( N-I, A(I,I+1), LDA, Q(I,I+1), LDQ, C, S ) END IF IF ( LTRB ) THEN CALL DROT( N, G(I,1), LDG, B(1,I), 1, C, S ) ELSE CALL DROT( N, G(I,1), LDG, B(I,1), LDB, C, S ) END IF CSL(2*I-1) = C CSL(2*I) = S C IF ( I.LT.N ) THEN IF ( LTRA ) THEN C C Generate elementary reflector FU(i) to annihilate C A(i,i+1:n). C CALL DLARFG( N-I+1, A(I,I), A(I,I+1), LDA, TAUL(I) ) C C Apply FU(i) from the left. C TEMP = A(I,I) A(I,I) = ONE CALL DLARF( 'Right', N-I, N-I+1, A(I,I), LDA, TAUL(I), $ A(I+1,I), LDA, DWORK ) CALL DLARF( 'Left', N-I+1, N-I, A(I,I), LDA, TAUL(I), $ Q(I,I+1), LDQ, DWORK ) IF ( LTRB ) THEN CALL DLARF( 'Right', N, N-I+1, A(I,I), LDA, TAUL(I), $ B(1,I), LDB, DWORK ) ELSE CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I), $ B(I,1), LDB, DWORK ) END IF CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I), $ G(I,1), LDG, DWORK ) A(I,I) = TEMP ELSE C C Generate elementary reflector FU(i) to annihilate C A(i+1:n,i). C CALL DLARFG( N-I+1, A(I,I), A(I+1,I), 1, TAUL(I) ) C C Apply FU(i) from the left. C TEMP = A(I,I) A(I,I) = ONE CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I), $ A(I,I+1), LDA, DWORK ) CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I), $ Q(I,I+1), LDQ, DWORK ) IF ( LTRB ) THEN CALL DLARF( 'Right', N, N-I+1, A(I,I), 1, TAUL(I), $ B(1,I), LDB, DWORK ) ELSE CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I), $ B(I,1), LDB, DWORK ) END IF CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I), G(I,1), $ LDG, DWORK ) A(I,I) = TEMP END IF ELSE TAUL(I) = ZERO END IF IF ( I.LT.N ) $ ALPHA = Q(I,I+1) IF ( I.LT.N-1 ) THEN C C Generate elementary reflector HV(i) to annihilate Q(i,i+2:n) C CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, NU ) C C Apply HV(i) from the right. C Q(I,I+1) = ONE CALL DLARF( 'Right', N-I, N-I, Q(I,I+1), LDQ, NU, $ Q(I+1,I+1), LDQ, DWORK ) IF ( LTRA ) THEN CALL DLARF( 'Left', N-I, N, Q(I,I+1), LDQ, NU, $ A(I+1,1), LDA, DWORK ) ELSE CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU, $ A(1,I+1), LDA, DWORK ) END IF IF ( LTRB ) THEN CALL DLARF( 'Left', N-I, N-I+1, Q(I,I+1), LDQ, NU, $ B(I+1,I), LDB, DWORK ) ELSE CALL DLARF( 'Right', N-I+1, N-I, Q(I,I+1), LDQ, NU, $ B(I,I+1), LDB, DWORK ) END IF CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU, $ G(1,I+1), LDG, DWORK ) Q(I,I+1) = NU ELSE IF ( I.LT.N ) THEN Q(I,I+1) = ZERO END IF IF ( I.LT.N ) THEN C C Generate symplectic Givens rotation GV(i) to annihilate C Q(i,i+1). C IF ( LTRB ) THEN TEMP = B(I+1,I) CALL DLARTG( TEMP, ALPHA, C, S, B(I+1,I) ) S = -S CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), LDB, C, S ) ELSE TEMP = B(I,I+1) CALL DLARTG( TEMP, ALPHA, C, S, B(I,I+1) ) S = -S CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), 1, C, S ) END IF IF ( LTRA ) THEN CALL DROT( N, A(I+1,1), LDA, G(1,I+1), 1, C, S ) ELSE CALL DROT( N, A(1,I+1), 1, G(1,I+1), 1, C, S ) END IF CSR(2*I-1) = C CSR(2*I) = S END IF IF ( I.LT.N-1 ) THEN IF ( LTRB ) THEN C C Generate elementary reflector FV(i) to annihilate C B(i+2:n,i). C CALL DLARFG( N-I, B(I+1,I), B(I+2,I), 1, TAUR(I) ) C C Apply FV(i) from the right. C TEMP = B(I+1,I) B(I+1,I) = ONE CALL DLARF( 'Left', N-I, N-I, B(I+1,I), 1, TAUR(I), $ B(I+1,I+1), LDB, DWORK ) CALL DLARF( 'Right', N-I, N-I, B(I+1,I), 1, TAUR(I), $ Q(I+1,I+1), LDQ, DWORK ) IF ( LTRA ) THEN CALL DLARF( 'Left', N-I, N, B(I+1,I), 1, $ TAUR(I), A(I+1,1), LDA, DWORK ) ELSE CALL DLARF( 'Right', N, N-I, B(I+1,I), 1, $ TAUR(I), A(1,I+1), LDA, DWORK ) END IF CALL DLARF( 'Right', N, N-I, B(I+1,I), 1, TAUR(I), $ G(1,I+1), LDG, DWORK ) B(I+1,I) = TEMP ELSE C C Generate elementary reflector FV(i) to annihilate C B(i,i+2:n). C CALL DLARFG( N-I, B(I,I+1), B(I,I+2), LDB, TAUR(I) ) C C Apply FV(i) from the right. C TEMP = B(I,I+1) B(I,I+1) = ONE CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I), $ B(I+1,I+1), LDB, DWORK ) CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I), $ Q(I+1,I+1), LDQ, DWORK ) IF ( LTRA ) THEN CALL DLARF( 'Left', N-I, N, B(I,I+1), LDB, TAUR(I), $ A(I+1,1), LDA, DWORK ) ELSE CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB, $ TAUR(I), A(1,I+1), LDA, DWORK ) END IF CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB, TAUR(I), $ G(1,I+1), LDG, DWORK ) B(I,I+1) = TEMP END IF ELSE IF ( I.LT.N ) THEN TAUR(I) = ZERO END IF 10 CONTINUE DWORK(1) = DBLE( MAX( 1, N ) ) RETURN C *** Last line of MB04TS *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04NY.f0000644000000000000000000000013215012430707016214 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB04NY.f0000644000175000017500000001704715012430707017421 0ustar00lilgelilge00000000000000 SUBROUTINE SB04NY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, $ DWORK, LDDWOR, INFO ) C C PURPOSE C C To solve a system of equations in Hessenberg form with one C offdiagonal and one right-hand side. C C ARGUMENTS C C Mode Parameters C C RC CHARACTER*1 C Indicates processing by columns or rows, as follows: C = 'R': Row transformations are applied; C = 'C': Column transformations are applied. C C UL CHARACTER*1 C Indicates whether AB is upper or lower Hessenberg matrix, C as follows: C = 'U': AB is upper Hessenberg; C = 'L': AB is lower Hessenberg. C C Input/Output Parameters C C M (input) INTEGER C The order of the matrix A. M >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,M) C The leading M-by-M part of this array must contain a C matrix A in Hessenberg form. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C LAMBDA (input) DOUBLE PRECISION C This variable must contain the value to be added to the C diagonal elements of A. C C D (input/output) DOUBLE PRECISION array, dimension (M) C On entry, this array must contain the right-hand side C vector of the Hessenberg system. C On exit, if INFO = 0, this array contains the solution C vector of the Hessenberg system. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used to test for near singularity of C the triangular factor R of the Hessenberg matrix. A matrix C whose estimated condition number is less than 1/TOL is C considered to be nonsingular. C C Workspace C C IWORK INTEGER array, dimension (M) C C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) C The leading M-by-M part of this array is used for C computing the triangular factor of the QR decomposition C of the Hessenberg matrix. The remaining 3*M elements are C used as workspace for the computation of the reciprocal C condition estimate. C C LDDWOR INTEGER C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if the Hessenberg matrix is (numerically) singular. C That is, its estimated reciprocal condition number C is less than or equal to TOL. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB04BY by M. Vanbegin, and C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. C C REVISIONS C C - C C Note that RC, UL, M and LDA must be such that the value of the C LOGICAL variable OK in the following statement is true. C C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) C .AND. C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) C .AND. C ( M.GE.0 ) C .AND. C ( LDA.GE.MAX( 1, M ) ) C .AND. C ( LDDWOR.GE.MAX( 1, M ) ) 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 .. CHARACTER RC, UL INTEGER INFO, LDA, LDDWOR, M DOUBLE PRECISION LAMBDA, TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) C .. Local Scalars .. CHARACTER TRANS INTEGER J, J1, MJ DOUBLE PRECISION C, R, RCOND, S C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLARTG, DROT, DTRCON, DTRSV C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. Executable Statements .. C INFO = 0 C C For speed, no tests on the input scalar arguments are made. C Quick return if possible. C IF ( M.EQ.0 ) $ RETURN C IF ( LSAME( UL, 'U' ) ) THEN C DO 20 J = 1, M CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) DWORK(J,J) = DWORK(J,J) + LAMBDA 20 CONTINUE C IF ( LSAME( RC, 'R' ) ) THEN TRANS = 'N' C C A is an upper Hessenberg matrix, row transformations. C DO 40 J = 1, M - 1 MJ = M - J IF ( DWORK(J+1,J).NE.ZERO ) THEN CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) DWORK(J,J) = R DWORK(J+1,J) = ZERO CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), $ LDDWOR, C, S ) CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) END IF 40 CONTINUE C ELSE TRANS = 'T' C C A is an upper Hessenberg matrix, column transformations. C DO 60 J = 1, M - 1 MJ = M - J IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, $ R ) DWORK(MJ+1,MJ+1) = R DWORK(MJ+1,MJ) = ZERO CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, $ S ) CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) END IF 60 CONTINUE C END IF ELSE C DO 80 J = 1, M J1 = MAX( J - 1, 1 ) CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) DWORK(J,J) = DWORK(J,J) + LAMBDA 80 CONTINUE C IF ( LSAME( RC, 'R' ) ) THEN TRANS = 'N' C C A is a lower Hessenberg matrix, row transformations. C DO 100 J = 1, M - 1 MJ = M - J IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, $ R ) DWORK(MJ+1,MJ+1) = R DWORK(MJ,MJ+1) = ZERO CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), $ LDDWOR, C, S ) CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) END IF 100 CONTINUE C ELSE TRANS = 'T' C C A is a lower Hessenberg matrix, column transformations. C DO 120 J = 1, M - 1 MJ = M - J IF ( DWORK(J,J+1).NE.ZERO ) THEN CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) DWORK(J,J) = R DWORK(J,J+1) = ZERO CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, $ S ) C CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) END IF 120 CONTINUE C END IF END IF C CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, $ DWORK(1,M+1), IWORK, INFO ) IF ( RCOND.LE.TOL ) THEN INFO = 1 ELSE CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) END IF C RETURN C *** Last line of SB04NY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04TX.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04TX.f0000644000175000017500000003352515012430707017417 0ustar00lilgelilge00000000000000 SUBROUTINE MB04TX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, $ LDA, E, LDE, Q, LDQ, Z, LDZ, MNEI ) C C PURPOSE C C To separate the pencils s*E(eps)-A(eps) and s*E(inf)-A(inf) in C s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 in [1]. C C On entry, it is assumed that the M-by-N matrices A and E have C been obtained after applying the Algorithms 3.2.1 and 3.3.1 to C the pencil s*E - A as described in [1], i.e. C C | s*E(eps,inf)-A(eps,inf) | X | C Q'(s*E - A)Z = |-------------------------|-------------| C | 0 | s*E(r)-A(r) | C C Here the pencil s*E(eps,inf)-A(eps,inf) is in staircase form. C This pencil contains all Kronecker column indices and infinite C elementary divisors of the pencil s*E - A. C The pencil s*E(r)-A(r) contains all Kronecker row indices and C finite elementary divisors of s*E - A. C Furthermore, the submatrices having full row and column rank in C the pencil s*E(eps,inf)-A(eps,inf) are assumed to be C triangularized. C C On exit, the result then is C C Q'(s*E - A)Z = C C | s*E(eps)-A(eps) | X | X | C |-----------------|-----------------|-------------| C | 0 | s*E(inf)-A(inf) | X | C |===================================|=============| C | | | C | 0 | s*E(r)-A(r) | C C Note that the pencil s*E(r)-A(r) is not reduced further. C C ARGUMENTS C C Mode Parameters C C UPDATQ LOGICAL C Indicates whether the user wishes to accumulate in a C matrix Q the orthogonal row transformations, as follows: C = .FALSE.: Do not form Q; C = .TRUE.: The given matrix Q is updated by the orthogonal C row transformations used in the reduction. C C UPDATZ LOGICAL C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal column transformations, as C follows: C = .FALSE.: Do not form Z; C = .TRUE.: The given matrix Z is updated by the orthogonal C column transformations used in the reduction. C C Input/Output Parameters C C M (input) INTEGER C Number of rows of A and E. M >= 0. C C N (input) INTEGER C Number of columns of A and E. N >= 0. C C NBLCKS (input/output) INTEGER C On entry, the number of submatrices having full row rank C (possibly zero) in A(eps,inf). C On exit, the input value has been reduced by one, if the C last submatrix is a 0-by-0 (empty) matrix. C C INUK (input/output) INTEGER array, dimension (NBLCKS) C On entry, this array contains the row dimensions nu(k), C (k=1, 2, ..., NBLCKS) of the submatrices having full row C rank in the pencil s*E(eps,inf)-A(eps,inf). C On exit, this array contains the row dimensions nu(k), C (k=1, 2, ..., NBLCKS) of the submatrices having full row C rank in the pencil s*E(eps)-A(eps). C C IMUK (input/output) INTEGER array, dimension (NBLCKS) C On entry, this array contains the column dimensions mu(k), C (k=1, 2, ..., NBLCKS) of the submatrices having full C column rank in the pencil s*E(eps,inf)-A(eps,inf). C On exit, this array contains the column dimensions mu(k), C (k=1, 2, ..., NBLCKS) of the submatrices having full C column rank in the pencil s*E(eps)-A(eps). C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, this array contains the matrix A to be reduced. C On exit, it contains the transformed matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, this array contains the matrix E to be reduced. C On exit, it contains the transformed matrix E. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,M). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) C On entry, if UPDATQ = .TRUE., then the leading M-by-M C part of this array must contain a given matrix Q (e.g. C from a previous call to another SLICOT routine), and on C exit, the leading M-by-M part of this array contains the C product of the input matrix Q and the row transformation C matrix that has transformed the rows of the matrices A C and E. C If UPDATQ = .FALSE., the array Q is not referenced and C can be supplied as a dummy array (i.e. set parameter C LDQ = 1 and declare this array to be Q(1,1) in the calling C program). C C LDQ INTEGER C The leading dimension of array Q. If UPDATQ = .TRUE., C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) C On entry, if UPDATZ = .TRUE., then the leading N-by-N C part of this array must contain a given matrix Z (e.g. C from a previous call to another SLICOT routine), and on C exit, the leading N-by-N part of this array contains the C product of the input matrix Z and the column C transformation matrix that has transformed the columns of C the matrices A and E. C If UPDATZ = .FALSE., the array Z is not referenced and C can be supplied as a dummy array (i.e. set parameter C LDZ = 1 and declare this array to be Z(1,1) in the calling C program). C C LDZ INTEGER C The leading dimension of array Z. If UPDATZ = .TRUE., C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. C C MNEI (output) INTEGER array, dimension (4) C MNEI(1) = MEPS = row dimension of s*E(eps)-A(eps), C MNEI(2) = NEPS = column dimension of s*E(eps)-A(eps), C MNEI(3) = MINF = row dimension of s*E(inf)-A(inf), C MNEI(4) = NINF = column dimension of s*E(inf)-A(inf). C C REFERENCES C C [1] Beelen, Th. C New Algorithms for Computing the Kronecker structure of a C Pencil with Applications to Systems and Control Theory. C Ph.D.Thesis, Eindhoven University of Technology, C The Netherlands, 1987. 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, Apr. 1997. C Supersedes Release 2.0 routine MB04FX by Th.G.J. Beelen, C Philips Glass Eindhoven, Holland. C C REVISIONS C C June 13, 1997, V. Sima. C November 24, 1997, A. Varga: initialization of MNEI to 0, instead C of ZERO. C C KEYWORDS C C Generalized eigenvalue problem, Kronecker indices, orthogonal C transformation, staircase form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. LOGICAL UPDATQ, UPDATZ INTEGER LDA, LDE, LDQ, LDZ, M, N, NBLCKS C .. Array Arguments .. INTEGER IMUK(*), INUK(*), MNEI(4) DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. INTEGER CA, CE, CJA, CJE, IP, ISMUK, ISNUK, K, MEPS, $ MINF, MUK, MUKP1, MUP, MUP1, NEPS, NINF, NUK, $ NUP, RA, RJE, SK1P1, TK1P1, TP1 DOUBLE PRECISION SC, SS C .. External Subroutines .. EXTERNAL DROTG, MB04TU C .. Executable Statements .. C MNEI(1) = 0 MNEI(2) = 0 MNEI(3) = 0 MNEI(4) = 0 IF ( M.LE.0 .OR. N.LE.0 ) $ RETURN C C Initialisation. C ISMUK = 0 ISNUK = 0 C DO 20 K = 1, NBLCKS ISMUK = ISMUK + IMUK(K) ISNUK = ISNUK + INUK(K) 20 CONTINUE C C MEPS, NEPS are the dimensions of the pencil s*E(eps)-A(eps). C MEPS = Sum(k=1,...,nblcks) NU(k), C NEPS = Sum(k=1,...,nblcks) MU(k). C MINF, NINF are the dimensions of the pencil s*E(inf)-A(inf). C MEPS = ISNUK NEPS = ISMUK MINF = 0 NINF = 0 C C MUKP1 = mu(k+1). N.B. It is assumed that mu(NBLCKS + 1) = 0. C MUKP1 = 0 C DO 120 K = NBLCKS, 1, -1 NUK = INUK(K) MUK = IMUK(K) C C Reduce submatrix E(k,k+1) to square matrix. C NOTE that always NU(k) >= MU(k+1) >= 0. C C WHILE ( NU(k) > MU(k+1) ) DO 40 IF ( NUK.GT.MUKP1 ) THEN C C sk1p1 = sum(i=k+1,...,p-1) NU(i) C tk1p1 = sum(i=k+1,...,p-1) MU(i) C ismuk = sum(i=1,...,k) MU(i) C tp1 = sum(i=1,...,p-1) MU(i) = ismuk + tk1p1. C SK1P1 = 0 TK1P1 = 0 C DO 100 IP = K + 1, NBLCKS C C Annihilate the elements originally present in the last C row of E(k,p+1) and A(k,p). C Start annihilating the first MU(p) - MU(p+1) elements by C applying column Givens rotations plus interchanging C elements. C Use original bottom diagonal element of A(k,k) as pivot. C Start position of pivot in A = (ra,ca). C TP1 = ISMUK + TK1P1 RA = ISNUK + SK1P1 CA = TP1 C MUP = IMUK(IP) NUP = INUK(IP) MUP1 = NUP C DO 60 CJA = CA, CA + MUP - NUP - 1 C C CJA = current column index of pivot in A. C CALL DROTG( A(RA,CJA), A(RA,CJA+1), SC, SS ) C C Apply transformations to A- and E-matrix. C Interchange columns simultaneously. C Update column transformation matrix Z, if needed. C CALL MB04TU( RA-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, $ SS ) A(RA,CJA+1) = A(RA,CJA) A(RA,CJA) = ZERO CALL MB04TU( RA, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), $ 1, SC, SS ) 60 CONTINUE C C Annihilate the remaining elements originally present in C the last row of E(k,p+1) and A(k,p) by alternatingly C applying row and column rotations plus interchanging C elements. C Use diagonal elements of E(p,p+1) and original bottom C diagonal element of A(k,k) as pivots, respectively. C (re,ce) and (ra,ca) are the starting positions of the C pivots in E and A. C CE = TP1 + MUP CA = CE - MUP1 - 1 C DO 80 RJE = RA + 1, RA + MUP1 C C (RJE,CJE) = current position pivot in E. C CJE = CE + 1 CJA = CA + 1 C C Determine the row transformations. C Apply these transformations to E- and A-matrix. C Interchange the rows simultaneously. C Update row transformation matrix Q, if needed. C CALL DROTG( E(RJE,CJE), E(RJE-1,CJE), SC, SS ) CALL MB04TU( N-CJE, E(RJE,CJE+1), LDE, E(RJE-1,CJE+1), $ LDE, SC, SS ) E(RJE-1,CJE) = E(RJE,CJE) E(RJE,CJE) = ZERO CALL MB04TU( N-CJA+1, A(RJE,CJA), LDA, A(RJE-1,CJA), $ LDA, SC, SS ) IF( UPDATQ ) CALL MB04TU( M, Q(1,RJE), 1, $ Q(1,RJE-1), 1, SC, SS ) C C Determine the column transformations. C Apply these transformations to A- and E-matrix. C Interchange the columns simultaneously. C Update column transformation matrix Z, if needed. C CALL DROTG( A(RJE,CJA), A(RJE,CJA+1), SC, SS ) CALL MB04TU( RJE-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, $ SS ) A(RJE,CJA+1) = A(RJE,CJA) A(RJE,CJA) = ZERO CALL MB04TU( RJE, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), $ 1, SC, SS ) 80 CONTINUE C SK1P1 = SK1P1 + NUP TK1P1 = TK1P1 + MUP C 100 CONTINUE C C Reduce A=A(eps,inf) and E=E(eps,inf) by ignoring their last C row and right most column. The row and column ignored C belong to the pencil s*E(inf)-A(inf). C Redefine blocks in new A and E. C MUK = MUK - 1 NUK = NUK - 1 ISMUK = ISMUK - 1 ISNUK = ISNUK - 1 MEPS = MEPS - 1 NEPS = NEPS - 1 MINF = MINF + 1 NINF = NINF + 1 C GO TO 40 END IF C END WHILE 40 C IMUK(K) = MUK INUK(K) = NUK C C Now submatrix E(k,k+1) is square. C C Consider next submatrix (k:=k-1). C ISNUK = ISNUK - NUK ISMUK = ISMUK - MUK MUKP1 = MUK 120 CONTINUE C C If mu(NBLCKS) = 0, then the last submatrix counted in NBLCKS is C a 0-by-0 (empty) matrix. This "matrix" must be removed. C IF ( IMUK(NBLCKS).EQ.0 ) NBLCKS = NBLCKS - 1 C C Store dimensions of the pencils s*E(eps)-A(eps) and C s*E(inf)-A(inf) in array MNEI. C MNEI(1) = MEPS MNEI(2) = NEPS MNEI(3) = MINF MNEI(4) = NINF C RETURN C *** Last line of MB04TX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02JX.f0000644000000000000000000000013215012430707016177 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02JX.f0000644000175000017500000005763415012430707017412 0ustar00lilgelilge00000000000000 SUBROUTINE MB02JX( JOB, K, L, M, N, TC, LDTC, TR, LDTR, RNK, Q, $ LDQ, R, LDR, JPVT, TOL1, TOL2, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute a low rank QR factorization with column pivoting of a C K*M-by-L*N block Toeplitz matrix T with blocks of size (K,L); C specifically, C T C T P = Q R , C C where R is lower trapezoidal, P is a block permutation matrix C and Q^T Q = I. The number of columns in R is equivalent to the C numerical rank of T with respect to the given tolerance TOL1. C Note that the pivoting scheme is local, i.e., only columns C belonging to the same block in T are permuted. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the output of the routine as follows: C = 'Q': computes Q and R; C = 'R': only computes R. C C Input/Output Parameters C C K (input) INTEGER C The number of rows in one block of T. K >= 0. C C L (input) INTEGER C The number of columns in one block of T. L >= 0. C C M (input) INTEGER C The number of blocks in one block column of T. M >= 0. C C N (input) INTEGER C The number of blocks in one block row of T. N >= 0. C C TC (input) DOUBLE PRECISION array, dimension (LDTC, L) C The leading M*K-by-L part of this array must contain C the first block column of T. C C LDTC INTEGER C The leading dimension of the array TC. C LDTC >= MAX(1,M*K). C C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) C The leading K-by-(N-1)*L part of this array must contain C the first block row of T without the leading K-by-L C block. C C LDTR INTEGER C The leading dimension of the array TR. LDTR >= MAX(1,K). C C RNK (output) INTEGER C The number of columns in R, which is equivalent to the C numerical rank of T. C C Q (output) DOUBLE PRECISION array, dimension (LDQ,RNK) C If JOB = 'Q', then the leading M*K-by-RNK part of this C array contains the factor Q. C If JOB = 'R', then this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= MAX(1,M*K), if JOB = 'Q'; C LDQ >= 1, if JOB = 'R'. C C R (output) DOUBLE PRECISION array, dimension (LDR,RNK) C The leading N*L-by-RNK part of this array contains the C lower trapezoidal factor R. C C LDR INTEGER C The leading dimension of the array R. C LDR >= MAX(1,N*L) C C JPVT (output) INTEGER array, dimension (MIN(M*K,N*L)) C This array records the column pivoting performed. C If JPVT(j) = k, then the j-th column of T*P was C the k-th column of T. C C Tolerances C C TOL1 DOUBLE PRECISION C If TOL1 >= 0.0, the user supplied diagonal tolerance; C if TOL1 < 0.0, a default diagonal tolerance is used. C C TOL2 DOUBLE PRECISION C If TOL2 >= 0.0, the user supplied offdiagonal tolerance; C if TOL2 < 0.0, a default offdiagonal tolerance is used. 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; DWORK(2) and DWORK(3) return the used values C for TOL1 and TOL2, respectively. C On exit, if INFO = -19, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( 3, ( M*K + ( N - 1 )*L )*( L + 2*K ) + 9*L C + MAX(M*K,(N-1)*L) ), if JOB = 'Q'; C LDWORK >= MAX( 3, ( N - 1 )*L*( L + 2*K + 1 ) + 9*L, C M*K*( L + 1 ) + L ), if JOB = '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 = 1: due to perturbations induced by roundoff errors, or C removal of nearly linearly dependent columns of the C generator, the Schur algorithm encountered a C situation where a diagonal element in the negative C generator is larger in magnitude than the C corresponding diagonal element in the positive C generator (modulo TOL1); C = 2: due to perturbations induced by roundoff errors, or C removal of nearly linearly dependent columns of the C generator, the Schur algorithm encountered a C situation where diagonal elements in the positive C and negative generator are equal in magnitude C (modulo TOL1), but the offdiagonal elements suggest C that these columns are not linearly dependent C (modulo TOL2*ABS(diagonal element)). C C METHOD C C Householder transformations and modified hyperbolic rotations C are used in the Schur algorithm [1], [2]. C If, during the process, the hyperbolic norm of a row in the C leading part of the generator is found to be less than or equal C to TOL1, then this row is not reduced. If the difference of the C corresponding columns has a norm less than or equal to TOL2 times C the magnitude of the leading element, then this column is removed C from the generator, as well as from R. Otherwise, the algorithm C breaks down. TOL1 is set to norm(TC)*sqrt(eps) and TOL2 is set C to N*L*sqrt(eps) by default. C If M*K > L, the columns of T are permuted so that the diagonal C elements in one block column of R have decreasing magnitudes. C C REFERENCES C C [1] Kailath, T. and Sayed, A. C Fast Reliable Algorithms for Matrices with Structure. C SIAM Publications, Philadelphia, 1999. C C [2] Kressner, D. and Van Dooren, P. C Factorizations and linear system solvers for matrices with C Toeplitz structure. C SLICOT Working Note 2000-2, 2000. C C NUMERICAL ASPECTS C C The algorithm requires 0(K*RNK*L*M*N) floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, June 2001. C D. Kressner, Technical Univ. Berlin, Germany, July 2002. C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK, M, N, $ RNK DOUBLE PRECISION TOL1, TOL2 C .. Array Arguments .. DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*), $ TR(LDTR,*) INTEGER JPVT(*) C .. Local Scalars .. LOGICAL COMPQ, LAST INTEGER CPCOL, GAP, I, IERR, J, JJ, JWORK, KK, LEN, MK, $ NZC, PDP, PDQ, PDW, PNQ, PNR, PP, PPR, PT, RDEF, $ RRDF, RRNK, WRKMIN, WRKOPT DOUBLE PRECISION LTOL1, LTOL2, NRM, TEMP C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DNRM2 EXTERNAL DLAMCH, DNRM2, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEQP3, DGEQRF, DLACPY, DLASET, $ DORGQR, DSCAL, DSWAP, DTRMV, MA02AD, MB02CU, $ MB02CV, MB02KD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 WRKOPT = 3 MK = M*K COMPQ = LSAME( JOB, 'Q' ) IF ( COMPQ ) THEN WRKMIN = MAX( 3, ( MK + ( N - 1 )*L )*( L + 2*K ) + 9*L + $ MAX( MK, ( N - 1 )*L ) ) ELSE WRKMIN = MAX( 3, MAX ( ( N - 1 )*L*( L + 2*K + 1 ) + 9*L, $ MK*( L + 1 ) + L ) ) END IF C C Check the scalar input parameters. C IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN INFO = -1 ELSE IF ( K.LT.0 ) THEN INFO = -2 ELSE IF ( L.LT.0 ) THEN INFO = -3 ELSE IF ( M.LT.0 ) THEN INFO = -4 ELSE IF ( N.LT.0 ) THEN INFO = -5 ELSE IF ( LDTC.LT.MAX( 1, MK ) ) THEN INFO = -7 ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN INFO = -9 ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.MK ) ) THEN INFO = -12 ELSE IF ( LDR.LT.MAX( 1, N*L ) ) THEN INFO = -14 ELSE IF ( LDWORK.LT.WRKMIN ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = -19 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02JX', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( M, N, K, L ).EQ.0 ) THEN RNK = 0 DWORK(1) = DBLE( WRKOPT ) DWORK(2) = ZERO DWORK(3) = ZERO RETURN END IF C WRKOPT = WRKMIN C IF ( MK.LE.L ) THEN C C Catch M*K <= L. C CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK ) PDW = MK*L + 1 JWORK = PDW + MK CALL DGEQRF( MK, L, DWORK, MK, DWORK(PDW), DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) CALL MA02AD( 'Upper part', MK, L, DWORK, MK, R, LDR ) CALL DORGQR( MK, MK, MK, DWORK, MK, DWORK(PDW), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) IF ( COMPQ ) $ CALL DLACPY( 'All', MK, MK, DWORK, MK, Q, LDQ ) PDW = MK*MK + 1 IF ( N.GT.1 ) THEN CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, MK, ONE, $ ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1), $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) END IF WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) C DO 10 I = 1, MK JPVT(I) = I 10 CONTINUE C RNK = MK DWORK(1) = DBLE( WRKOPT ) DWORK(2) = ZERO DWORK(3) = ZERO RETURN END IF C C Compute the generator: C C 1st column of the generator. C DO 20 I = 1, L JPVT(I) = 0 20 CONTINUE C LTOL1 = TOL1 LTOL2 = TOL2 C IF ( COMPQ ) THEN CALL DLACPY( 'All', MK, L, TC, LDTC, Q, LDQ ) CALL DGEQP3( MK, L, Q, LDQ, JPVT, DWORK, DWORK(L+1), $ LDWORK-L, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) C IF ( LTOL1.LT.ZERO ) THEN C C Compute default tolerance LTOL1. C C Estimate the 2-norm of the first block column of the C matrix with 5 power iterations. C TEMP = ONE / SQRT( DBLE( L ) ) CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(L+1), 1 ) C DO 30 I = 1, 5 CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, Q, $ LDQ, DWORK(L+1), 1 ) CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, Q, LDQ, $ DWORK(L+1), 1 ) NRM = DNRM2( L, DWORK(L+1), 1 ) CALL DSCAL( L, ONE/NRM, DWORK(L+1), 1 ) 30 CONTINUE C LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) ) END IF C I = L C 40 CONTINUE IF ( ABS( Q(I,I) ).LE.LTOL1 ) THEN I = I - 1 IF ( I.GT.0 ) GO TO 40 END IF C RRNK = I RRDF = L - RRNK CALL MA02AD( 'Upper', RRNK, L, Q, LDQ, R, LDR ) IF ( RRNK.GT.1 ) $ CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR ) CALL DORGQR( MK, L, RRNK, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) IF ( N.GT.1 ) THEN CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE, $ ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1), $ LDR, DWORK, LDWORK, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF C ELSE C PDW = MK*L + 1 JWORK = PDW + L CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK ) CALL DGEQP3( MK, L, DWORK, MK, JPVT, DWORK(PDW), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C IF ( LTOL1.LT.ZERO ) THEN C C Compute default tolerance LTOL1. C C Estimate the 2-norm of the first block column of the C matrix with 5 power iterations. C TEMP = ONE / SQRT( DBLE( L ) ) CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(JWORK), 1 ) C DO 50 I = 1, 5 CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, DWORK, $ MK, DWORK(JWORK), 1 ) CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, DWORK, $ MK, DWORK(JWORK), 1 ) NRM = DNRM2( L, DWORK(JWORK), 1 ) CALL DSCAL( L, ONE/NRM, DWORK(JWORK), 1 ) 50 CONTINUE C LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) ) END IF C RRNK = L I = ( L - 1 )*MK + L C 60 CONTINUE IF ( ABS( DWORK(I) ).LE.LTOL1 ) THEN RRNK = RRNK - 1 I = I - MK - 1 IF ( I.GT.0 ) GO TO 60 END IF C RRDF = L - RRNK CALL MA02AD( 'Upper part', RRNK, L, DWORK, MK, R, LDR ) IF ( RRNK.GT.1 ) $ CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR ) CALL DORGQR( MK, L, RRNK, DWORK, MK, DWORK(PDW), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) IF ( N.GT.1 ) THEN CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE, $ ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1), $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) END IF END IF C C Quick return if N = 1. C IF ( N.EQ.1 ) THEN RNK = RRNK DWORK(1) = DBLE( WRKOPT ) DWORK(2) = LTOL1 DWORK(3) = ZERO RETURN END IF C C Compute default tolerance LTOL2. C IF ( LTOL2.LT.ZERO ) $ LTOL2 = DBLE( N*L )*SQRT( DLAMCH( 'Epsilon' ) ) C DO 70 J = 1, L CALL DCOPY( RRNK, R(J,1), LDR, R(L+JPVT(J),RRNK+1), LDR ) 70 CONTINUE C IF ( N.GT.2 ) $ CALL DLACPY( 'All', (N-2)*L, RRNK, R(L+1,1), LDR, $ R(2*L+1,RRNK+1), LDR ) C C 2nd column of the generator. C IF ( RRDF.GT.0 ) $ CALL MA02AD( 'All', MIN( RRDF, K ), (N-1)*L, TR, LDTR, $ R(L+1,2*RRNK+1), LDR ) IF ( K.GT.RRDF ) $ CALL MA02AD( 'All', K-RRDF, (N-1)*L, TR(RRDF+1,1), LDTR, DWORK, $ (N-1)*L ) C C 3rd column of the generator. C PNR = ( N - 1 )*L*MAX( 0, K-RRDF ) + 1 CALL DLACPY( 'All', (N-1)*L, RRNK, R(L+1,1), LDR, DWORK(PNR), $ (N-1)*L ) C C 4th column of the generator. C PDW = PNR + ( N - 1 )*L*RRNK PT = ( M - 1 )*K + 1 C DO 80 I = 1, MIN( M, N-1 ) CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), (N-1)*L ) PT = PT - K PDW = PDW + L 80 CONTINUE C PT = 1 C DO 90 I = M + 1, N - 1 CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), (N-1)*L ) PT = PT + L PDW = PDW + L 90 CONTINUE C IF ( COMPQ ) THEN PDQ = PNR + ( N - 1 )*L*( RRNK + K ) PNQ = PDQ + MK*MAX( 0, K-RRDF ) PDW = PNQ + MK*( RRNK + K ) CALL DLACPY( 'All', MK, RRNK, Q, LDQ, DWORK(PNQ), MK ) IF ( M.GT.1 ) $ CALL DLACPY( 'All', (M-1)*K, RRNK, Q, LDQ, Q(K+1,RRNK+1), $ LDQ ) CALL DLASET( 'All', K, RRNK, ZERO, ZERO, Q(1,RRNK+1), LDQ ) IF ( RRDF.GT.0 ) $ CALL DLASET( 'All', MK, RRDF, ZERO, ONE, Q(1,2*RRNK+1), $ LDQ ) CALL DLASET( 'All', RRDF, MAX( 0, K-RRDF ), ZERO, ZERO, $ DWORK(PDQ), MK ) CALL DLASET( 'All', M*K-RRDF, MAX( 0, K-RRDF ), ZERO, ONE, $ DWORK(PDQ+RRDF), MK ) CALL DLASET( 'All', MK, K, ZERO, ZERO, DWORK(PNQ+MK*RRNK), MK ) ELSE PDW = PNR + ( N - 1 )*L*( RRNK + K ) END IF PPR = 1 RNK = RRNK RDEF = RRDF LEN = N*L GAP = N*L - MIN( N*L, MK ) C C KK is the number of columns in the leading part of the C generator. After sufficiently many rank drops or if C M*K < N*L it may be less than L. C KK = MIN( L+K-RDEF, L ) KK = MIN( KK, MK-L ) C C Generator reduction process. C DO 190 I = L + 1, MIN( MK, N*L ), L IF ( I+L.LE.MIN( MK, N*L ) ) THEN LAST = .FALSE. ELSE LAST = .TRUE. END IF PP = KK + MAX( K - RDEF, 0 ) LEN = LEN - L CALL MB02CU( 'Deficient', KK, PP, L+K-RDEF, -1, R(I,RNK+1), $ LDR, DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, $ RRNK, JPVT(I), DWORK(PDW), LTOL1, DWORK(PDW+5*L), $ LDWORK-PDW-5*L+1, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The current generator is indefinite. C INFO = 1 RETURN END IF C C Apply pivoting to other columns of R. C PDP = PDW + 6*L - I C DO 100 J = I, I + KK - 1 JPVT(J) = JPVT(J) + I - 1 DWORK(PDP+JPVT(J)) = DBLE(J) 100 CONTINUE C DO 120 J = I, I + KK - 1 TEMP = DBLE(J) JJ = J-1 C 110 CONTINUE JJ = JJ + 1 IF ( DWORK(PDP+JJ).NE.TEMP ) GO TO 110 C IF ( JJ.NE.J ) THEN DWORK(PDP+JJ) = DWORK(PDP+J) CALL DSWAP( RNK, R(J,1), LDR, R(JJ,1), LDR ) END IF 120 CONTINUE C DO 130 J = I + KK, I + L - 1 JPVT(J) = J 130 CONTINUE C C Apply reduction to other rows of R. C IF ( LEN.GT.KK ) THEN CALL MB02CV( 'Deficient', 'NoStructure', KK, LEN-KK, PP, $ L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR, $ DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, $ R(I+KK,RNK+1), LDR, DWORK(PPR+KK), (N-1)*L, $ DWORK(PNR+KK), (N-1)*L, DWORK(PDW), $ DWORK(PDW+5*L), LDWORK-PDW-5*L+1, IERR ) END IF C C Apply reduction to Q. C IF ( COMPQ ) THEN CALL MB02CV( 'Deficient', 'NoStructure', KK, MK, PP, $ L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR, $ DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, $ Q(1,RNK+1), LDQ, DWORK(PDQ), MK, DWORK(PNQ), $ MK, DWORK(PDW), DWORK(PDW+5*L), $ LDWORK-PDW-5*L+1, IERR ) END IF C C Inspection of the rank deficient columns: C Look for small diagonal entries. C NZC = 0 C DO 140 J = KK, RRNK + 1, -1 IF ( ABS( R(I+J-1,RNK+J) ).LE.LTOL1 ) NZC = NZC + 1 140 CONTINUE C C The last NZC columns of the generator cannot be removed. C Now, decide whether for the other rank deficient columns C it is safe to remove. C PT = PNR C DO 150 J = RRNK + 1, KK - NZC TEMP = R(I+J-1,RNK+J) CALL DSCAL( LEN-J-GAP, TEMP, R(I+J,RNK+J), 1 ) CALL DAXPY( LEN-J-GAP, -DWORK(PT+J-1), DWORK(PT+J), 1, $ R(I+J,RNK+J), 1 ) IF ( DNRM2( LEN-J-GAP, R(I+J,RNK+J), 1 ) $ .GT.LTOL2*ABS( TEMP ) ) THEN C C Unlucky case: C It is neither advisable to remove the whole column nor C possible to remove the diagonal entries by Hyperbolic C rotations. C INFO = 2 RETURN END IF PT = PT + ( N - 1 )*L 150 CONTINUE C C Annihilate unwanted elements in the factor R. C RRDF = KK - RRNK CALL DLASET( 'All', I-1, RRNK, ZERO, ZERO, R(1,RNK+1), LDR ) CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(I,RNK+2), $ LDR ) C C Construct the generator for the next step. C IF ( .NOT.LAST ) THEN C C Compute KK for the next step. C KK = MIN( L+K-RDEF-RRDF+NZC, L ) KK = MIN( KK, MK-I-L+1 ) C IF ( KK.LE.0 ) THEN RNK = RNK + RRNK GO TO 200 END IF C CALL DLASET( 'All', L, RRDF, ZERO, ZERO, R(I,RNK+RRNK+1), $ LDR ) C C The columns with small diagonal entries form parts of the C new positive generator. C IF ( ( RRDF-NZC ).GT.0 .AND. NZC.GT.0 ) THEN CPCOL = MIN( NZC, KK ) C DO 160 J = RNK + RRNK + 1, RNK + RRNK + CPCOL CALL DCOPY( LEN-L, R(I+L,J+RRDF-NZC), 1, $ R(I+L,J), 1 ) 160 CONTINUE C END IF C C Construct the leading parts of the positive generator. C CPCOL = MIN( RRNK, KK-NZC ) IF ( CPCOL.GT.0 ) THEN C DO 170 J = I, I + L - 1 CALL DCOPY( CPCOL, R(J,RNK+1), LDR, $ R(JPVT(J)+L,RNK+RRNK+NZC+1), LDR ) 170 CONTINUE C IF ( LEN.GT.2*L ) THEN CALL DLACPY( 'All', LEN-2*L, CPCOL, R(I+L,RNK+1), LDR, $ R(I+2*L,RNK+RRNK+NZC+1), LDR ) END IF END IF PPR = PPR + L C C Refill the leading parts of the positive generator. C CPCOL = MIN( K-RDEF, KK-RRNK-NZC ) IF ( CPCOL.GT.0 ) THEN CALL DLACPY( 'All', LEN-L, CPCOL, DWORK(PPR), (N-1)*L, $ R(I+L,RNK+2*RRNK+NZC+1), LDR ) PPR = PPR + CPCOL*( N - 1 )*L END IF PNR = PNR + ( RRDF - NZC )*( N - 1 )*L + L C C Do the same things for Q. C IF ( COMPQ ) THEN IF ( ( RRDF - NZC ).GT.0 .AND. NZC.GT.0 ) THEN CPCOL = MIN( NZC, KK ) C DO 180 J = RNK + RRNK + 1, RNK + RRNK + CPCOL CALL DCOPY( MK, Q(1,J+RRDF-NZC), 1, Q(1,J), 1 ) 180 CONTINUE C END IF CPCOL = MIN( RRNK, KK-NZC ) IF ( CPCOL.GT.0 ) THEN CALL DLASET( 'All', K, CPCOL, ZERO, ZERO, $ Q(1,RNK+RRNK+NZC+1), LDQ ) IF ( M.GT.1 ) $ CALL DLACPY( 'All', (M-1)*K, CPCOL, Q(1,RNK+1), $ LDQ, Q(K+1,RNK+RRNK+NZC+1), LDQ ) END IF CPCOL = MIN( K-RDEF, KK-RRNK-NZC ) IF ( CPCOL.GT.0 ) THEN CALL DLACPY( 'All', MK, CPCOL, DWORK(PDQ), MK, $ Q(1,RNK+2*RRNK+NZC+1), LDQ ) PDQ = PDQ + CPCOL*MK END IF PNQ = PNQ + ( RRDF - NZC )*MK END IF END IF RNK = RNK + RRNK RDEF = RDEF + RRDF - NZC 190 CONTINUE C 200 CONTINUE DWORK(1) = DBLE( WRKOPT ) DWORK(2) = LTOL1 DWORK(3) = LTOL2 C C *** Last line of MB02JX *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04RW.f0000644000000000000000000000013215012430707016216 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB04RW.f0000644000175000017500000001237315012430707017420 0ustar00lilgelilge00000000000000 SUBROUTINE SB04RW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, $ LDBA, D, DWORK ) C C PURPOSE C C To construct the right-hand side D for a system of equations in C Hessenberg form solved via SB04RY (case with 1 right-hand side). C C ARGUMENTS C C Mode Parameters C C ABSCHR CHARACTER*1 C Indicates whether AB contains A or B, as follows: C = 'A': AB contains A; C = 'B': AB contains B. C C UL CHARACTER*1 C Indicates whether AB is upper or lower Hessenberg matrix, C as follows: C = 'U': AB is upper Hessenberg; C = 'L': AB is lower Hessenberg. 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 C (input) DOUBLE PRECISION array, dimension (LDC,M) C The leading N-by-M part of this array must contain both C the not yet modified part of the coefficient matrix C of C the Sylvester equation X + AXB = C, and both the currently C computed part of the solution of the Sylvester equation. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,N). C C INDX (input) INTEGER C The position of the column/row of C to be used in the C construction of the right-hand side D. C C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) C The leading N-by-N or M-by-M part of this array must C contain either A or B of the Sylvester equation C X + AXB = C. C C LDAB INTEGER C The leading dimension of array AB. C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on C ABSCHR = 'A' or ABSCHR = 'B', respectively). C C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) C The leading N-by-N or M-by-M part of this array must C contain either A or B of the Sylvester equation C X + AXB = C, the matrix not contained in AB. C C LDBA INTEGER C The leading dimension of array BA. C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on C ABSCHR = 'B' or ABSCHR = 'A', respectively). C C D (output) DOUBLE PRECISION array, dimension (*) C The leading N or M part of this array (depending on C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the C right-hand side. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C where LDWORK is equal to N or M (depending on ABSCHR = 'B' C or ABSCHR = 'A', respectively). C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C D. Sima, University of Bucharest, May 2000. C C REVISIONS C C - 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 .. CHARACTER ABSCHR, UL INTEGER INDX, LDAB, LDBA, LDC, M, N C .. Array Arguments .. DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMV C .. Executable Statements .. C C For speed, no tests on the input scalar arguments are made. C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 ) $ RETURN C IF ( LSAME( ABSCHR, 'B' ) ) THEN C C Construct the column of the right-hand side. C CALL DCOPY( N, C(1,INDX), 1, D, 1 ) IF ( LSAME( UL, 'U' ) ) THEN IF ( INDX.GT.1 ) THEN CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, $ ZERO, DWORK, 1 ) CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, $ ONE, D, 1 ) END IF ELSE IF ( INDX.LT.M ) THEN CALL DGEMV( 'N', N, M-INDX, ONE, C(1,INDX+1), LDC, $ AB(INDX+1,INDX), 1, ZERO, DWORK, 1 ) CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, D, $ 1 ) END IF END IF ELSE C C Construct the row of the right-hand side. C CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) IF ( LSAME( UL, 'U' ) ) THEN IF ( INDX.LT.N ) THEN CALL DGEMV( 'T', N-INDX, M, ONE, C(INDX+1,1), LDC, $ AB(INDX,INDX+1), LDAB, ZERO, DWORK, 1 ) CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, $ 1 ) END IF ELSE IF ( INDX.GT.1 ) THEN CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), $ LDAB, ZERO, DWORK, 1 ) CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, $ 1 ) END IF END IF END IF C RETURN C *** Last line of SB04RW *** END control-4.1.2/src/slicot/src/PaxHeaders/TB04BV.f0000644000000000000000000000013215012430707016176 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB04BV.f0000644000175000017500000002464615012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE TB04BV( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN, $ GD, D, LDD, TOL, INFO ) C C PURPOSE C C To separate the strictly proper part G0 from the constant part D C of an P-by-M proper transfer function matrix G. C C ARGUMENTS C C Mode Parameters C C ORDER CHARACTER*1 C Specifies the order in which the polynomial coefficients C of the transfer function matrix are stored, as follows: C = 'I': Increasing order of powers of the indeterminate; C = 'D': Decreasing order of powers of the indeterminate. C C Input/Output Parameters C C P (input) INTEGER C The number of the system outputs. P >= 0. C C M (input) INTEGER C The number of the system inputs. M >= 0. C C MD (input) INTEGER C The maximum degree of the polynomials in G, plus 1, i.e., C MD = MAX(IGD(I,J)) + 1. C I,J C C IGN (input/output) INTEGER array, dimension (LDIGN,M) C On entry, the leading P-by-M part of this array must C contain the degrees of the numerator polynomials in G: C the (i,j) element of IGN must contain the degree of the C numerator polynomial of the polynomial ratio G(i,j). C On exit, the leading P-by-M part of this array contains C the degrees of the numerator polynomials in G0. C C LDIGN INTEGER C The leading dimension of array IGN. LDIGN >= max(1,P). C C IGD (input) INTEGER array, dimension (LDIGD,M) C The leading P-by-M part of this array must contain the C degrees of the denominator polynomials in G (and G0): C the (i,j) element of IGD contains the degree of the C denominator polynomial of the polynomial ratio G(i,j). C C LDIGD INTEGER C The leading dimension of array IGD. LDIGD >= max(1,P). C C GN (input/output) DOUBLE PRECISION array, dimension (P*M*MD) C On entry, this array must contain the coefficients of the C numerator polynomials, Num(i,j), of the transfer function C matrix G. The polynomials are stored in a column-wise C order, i.e., Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), C Num(2,2), ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., C Num(P,M); MD memory locations are reserved for each C polynomial, hence, the (i,j) polynomial is stored starting C from the location ((j-1)*P+i-1)*MD+1. The coefficients C appear in increasing or decreasing order of the powers C of the indeterminate, according to ORDER. C On exit, this array contains the coefficients of the C numerator polynomials of the strictly proper part G0 of C the transfer function matrix G, stored similarly. C C GD (input) DOUBLE PRECISION array, dimension (P*M*MD) C This array must contain the coefficients of the C denominator polynomials, Den(i,j), of the transfer C function matrix G. The polynomials are stored as for the C numerator polynomials. C C D (output) DOUBLE PRECISION array, dimension (LDD,M) C The leading P-by-M part of this array contains the C matrix D. C C LDD INTEGER C The leading dimension of array D. LDD >= max(1,P). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in determining the degrees of C the numerators Num0(i,j) of the strictly proper part of C the transfer function matrix G. If the user sets TOL > 0, C then the given value of TOL is used as an absolute C tolerance; the leading coefficients with absolute value C less than TOL are considered neglijible. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = IGN(i,j)*EPS*NORM( Num(i,j) ) is used C instead, where EPS is the machine precision (see LAPACK C Library routine DLAMCH), and NORM denotes the infinity C norm (the maximum coefficient in absolute value). 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 transfer function matrix is not proper; C = 2: if a denominator polynomial is null. C C METHOD C C The (i,j) entry of the real matrix D is zero, if the degree of C Num(i,j), IGN(i,j), is less than the degree of Den(i,j), IGD(i,j), C and it is given by the ratio of the leading coefficients of C Num(i,j) and Den(i,j), if IGN(i,j) is equal to IGD(i,j), C for i = 1 : P, and for j = 1 : M. C C FURTHER COMMENTS C C For maximum efficiency of index calculations, GN and GD are C implemented as one-dimensional arrays. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, May 2002. C Based on the BIMASC Library routine TMPRP by A. Varga. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. C C KEYWORDS C C State-space representation, transfer function. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER ORDER DOUBLE PRECISION TOL INTEGER INFO, LDD, LDIGD, LDIGN, M, MD, P C .. Array Arguments .. DOUBLE PRECISION D(LDD,*), GD(*), GN(*) INTEGER IGD(LDIGD,*), IGN(LDIGN,*) C .. Local Scalars .. LOGICAL ASCEND INTEGER I, II, J, K, KK, KM, ND, NN DOUBLE PRECISION DIJ, EPS, TOLDEF C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DAXPY, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN C .. C .. Executable Statements .. C C Test the input scalar parameters. C INFO = 0 ASCEND = LSAME( ORDER, 'I' ) IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN INFO = -1 ELSE IF( P.LT.0 ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( MD.LT.1 ) THEN INFO = -4 ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN INFO = -6 ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN INFO = -8 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -12 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB04BV', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( P, M ).EQ.0 ) $ RETURN C C Prepare the computation of the default tolerance. C TOLDEF = TOL IF( TOLDEF.LE.ZERO ) $ EPS = DLAMCH( 'Epsilon' ) C K = 1 C IF ( ASCEND ) THEN C C Polynomial coefficients are stored in increasing order. C DO 40 J = 1, M C DO 30 I = 1, P NN = IGN(I,J) ND = IGD(I,J) IF ( NN.GT.ND ) THEN C C Error return: the transfer function matrix is C not proper. C INFO = 1 RETURN ELSE IF ( NN.LT.ND .OR. ( ND.EQ.0 .AND. GN(K).EQ.ZERO ) ) $ THEN D(I,J) = ZERO ELSE C C Here NN = ND. C KK = K + NN C IF ( GD(KK).EQ.ZERO ) THEN C C Error return: the denominator is null. C INFO = 2 RETURN ENDIF C DIJ = GN(KK) / GD(KK) D(I,J) = DIJ GN(KK) = ZERO IF ( NN.GT.0 ) THEN CALL DAXPY( NN, -DIJ, GD(K), 1, GN(K), 1 ) IF ( TOL.LE.ZERO ) $ TOLDEF = DBLE( NN )*EPS* $ ABS( GN(IDAMAX( NN, GN(K), 1 ) ) ) KM = NN DO 10 II = 1, KM KK = KK - 1 NN = NN - 1 IF ( ABS( GN(KK) ).GT.TOLDEF ) $ GO TO 20 10 CONTINUE C 20 CONTINUE C IGN(I,J) = NN ENDIF ENDIF K = K + MD 30 CONTINUE C 40 CONTINUE C ELSE C C Polynomial coefficients are stored in decreasing order. C DO 90 J = 1, M C DO 80 I = 1, P NN = IGN(I,J) ND = IGD(I,J) IF ( NN.GT.ND ) THEN C C Error return: the transfer function matrix is C not proper. C INFO = 1 RETURN ELSE IF ( NN.LT.ND .OR. ( ND.EQ.0 .AND. GN(K).EQ.ZERO ) ) $ THEN D(I,J) = ZERO ELSE C C Here NN = ND. C KK = K C IF ( GD(KK).EQ.ZERO ) THEN C C Error return: the denominator is null. C INFO = 2 RETURN ENDIF C DIJ = GN(KK) / GD(KK) D(I,J) = DIJ GN(KK) = ZERO IF ( NN.GT.0 ) THEN CALL DAXPY( NN, -DIJ, GD(K+1), 1, GN(K+1), 1 ) IF ( TOL.LE.ZERO ) $ TOLDEF = DBLE( NN )*EPS* $ ABS( GN(IDAMAX( NN, GN(K+1), 1 ) ) ) KM = NN DO 50 II = 1, KM KK = KK + 1 NN = NN - 1 IF ( ABS( GN(KK) ).GT.TOLDEF ) $ GO TO 60 50 CONTINUE C 60 CONTINUE C IGN(I,J) = NN DO 70 II = 0, NN GN(K+II) = GN(KK+II) 70 CONTINUE C ENDIF ENDIF K = K + MD 80 CONTINUE C 90 CONTINUE C ENDIF C RETURN C *** Last line of TB04BV *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01QD.f0000644000000000000000000000013215012430707016175 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01QD.f0000644000175000017500000004555015012430707017402 0ustar00lilgelilge00000000000000 SUBROUTINE TG01QD( DICO, STDOM, JOBFI, N, M, P, ALPHA, A, LDA, $ E, LDE, B, LDB, C, LDC, N1, N2, N3, ND, NIBLCK, $ IBLCK, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, $ TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute orthogonal transformation matrices Q and Z which C reduce the regular pole pencil A-lambda*E of the descriptor system C (A-lambda*E,B,C) to the generalized real Schur form with ordered C generalized eigenvalues. The pair (A,E) is reduced to the form C C ( A1 * * ) ( E1 * * ) C Q'*A*Z = ( 0 A2 * ) , Q'*E*Z = ( 0 E2 * ) , (1) C ( 0 0 A3 ) ( 0 0 E2 ) C C where the subpencils Ak-lambda*Ek, for k = 1, 2, 3, contain the C generalized eigenvalues which belong to certain domains of C interest. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of the descriptor system as follows: C = 'C': continuous-time system; C = 'D': discrete-time system. C C STDOM CHARACTER*1 C Specifies the type of the domain of interest for the C generalized eigenvalues, as follows: C = 'S': stability type domain (i.e., left part of complex C plane or inside of a circle); C = 'U': instability type domain (i.e., right part of complex C plane or outside of a circle); C = 'N': whole complex domain, excepting infinity. C C JOBFI CHARACTER*1 C Specifies the type of generalized eigenvalues in the C leading diagonal block(s) as follows: C = 'F': finite generalized eigenvalues are in the C leading diagonal blocks (Af,Ef), and the resulting C transformed pair has the form C C ( Af * ) ( Ef * ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) ; C ( 0 Ai ) ( 0 Ei ) C C = 'I': infinite generalized eigenvalues are in the C leading diagonal blocks (Ai,Ei), and the resulting C transformed pair has the form C C ( Ai * ) ( Ei * ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) . C ( 0 Af ) ( 0 Ef ) C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix B, the number of columns C of the matrix C and the order of the square matrices A C and E. N >= 0. C C M (input) INTEGER C The number of columns of the matrix B. M >= 0. C C P (input) INTEGER C The number of rows of the matrix C. P >= 0. C C ALPHA (input) DOUBLE PRECISION C The boundary of the domain of interest for the finite C generalized eigenvalues of the pair (A,E). For a C continuous-time system (DICO = 'C'), ALPHA is the boundary C value for the real parts of the generalized eigenvalues, C while for a discrete-time system (DICO = 'D'), ALPHA >= 0 C represents the boundary value for the moduli of the C generalized 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 the state dynamics matrix A. C On exit, the leading N-by-N part of this array contains C the matrix Q'*A*Z in real Schur form, with the elements C below the first subdiagonal set to zero. C If JOBFI = 'I', the N1-by-N1 pair (A1,E1) contains the C infinite spectrum, the N2-by-N2 pair (A2,E2) contains the C finite spectrum in the domain of interest, and the C N3-by-N3 pair (A3,E3) contains the finite spectrum ouside C of the domain of interest. C If JOBFI = 'F', the N1-by-N1 pair (A1,E1) contains the C finite spectrum in the domain of interest, the N2-by-N2 C pair (A2,E2) contains the finite spectrum ouside of the C domain of interest, and the N3-by-N3 pair (A3,E3) contains C the infinite spectrum. C Ai has a block structure as in (2), where A0,0 is ND-by-ND C and Ai,i is IBLCK(i)-by-IBLCK(i), for i = 1, ..., NIBLCK. C The domain of interest for the pair (Af,Ef), containing C the finite generalized eigenvalues, is defined by the C parameters ALPHA, DICO and STDOM as follows: C For DICO = 'C': C Real(eig(Af,Ef)) < ALPHA if STDOM = 'S'; C Real(eig(Af,Ef)) > ALPHA if STDOM = 'U'. C For DICO = 'D': C Abs(eig(Af,Ef)) < ALPHA if STDOM = 'S'; C Abs(eig(Af,Ef)) > ALPHA if STDOM = 'U'. 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, the leading N-by-N part of this array must C contain the descriptor matrix E. C On exit, the leading N-by-N part of this array contains C the matrix Q'*E*Z in upper triangular form, with the C elements below the diagonal set to zero. Its structure C corresponds to the block structure of the matrix Q'*A*Z C (see description of A). C C LDE INTEGER C The leading dimension of the array E. LDE >= 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 matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix Q'*B. C C LDB INTEGER C The leading dimension of the 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 output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed output matrix C*Z. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C N1 (output) INTEGER C N2 (output) INTEGER C N3 (output) INTEGER C The number of the generalized eigenvalues of the pairs C (A1,E1), (A2,E2) and (A3,E3), respectively. C C ND (output) INTEGER. C The number of non-dynamic infinite eigenvalues of the C pair (A,E). Note: N-ND is the rank of the matrix E. C C NIBLCK (output) INTEGER C If ND > 0, the number of infinite blocks minus one. C If ND = 0, then NIBLCK = 0. C C IBLCK (output) INTEGER array, dimension (N) C IBLCK(i) contains the dimension of the i-th block in the C staircase form (2), where i = 1,2,...,NIBLCK. C C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) C The leading N-by-N part of this array contains the C orthogonal matrix Q, where Q' is the product of orthogonal C transformations applied to A, E, and B on the left. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= 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 C orthogonal matrix Z, which is the product of orthogonal C transformations applied to A, E, and C on the right. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1,N). 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 On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j = 1, ..., N, C are the generalized eigenvalues. C ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j = 1, ..., N, are C the diagonals of the complex Schur form (S,T) that would C result if the 2-by-2 diagonal blocks of the real Schur C form of (A,E) were further reduced to triangular form C using 2-by-2 complex unitary transformations. C If ALPHAI(j) is zero, then the j-th eigenvalue is real; C if positive, then the j-th and (j+1)-st eigenvalues are a C complex conjugate pair, with ALPHAI(j+1) negative. 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 factorization with column pivoting whose estimated C condition number is less than 1/TOL. If the user sets C TOL <= 0, then an implicitly computed, default tolerance C TOLDEF = N**2*EPS, is used instead, where EPS is the C machine precision (see LAPACK Library routine DLAMCH). C 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) returns the optimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 1, and if N = 0, C LDWORK >= 4*N, if STDOM = 'N'; C LDWORK >= 4*N+16, if STDOM = 'S' or 'U'. C For optimum performance LDWORK should be larger. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 = 1: the pencil A-lambda*E is not regular; C = 2: the QZ algorithm failed to compute all generalized C eigenvalues of the pair (A,E); C = 3: a failure occured during the ordering of the C generalized real Schur form of the pair (A,E). C C METHOD C C The separation of the finite and infinite parts is based on the C reduction algorithm of [1]. C If JOBFI = 'F', the matrices of the pair (Ai,Ei), containing the C infinite generalized eigenvalues, have the form C C ( A0,0 A0,k ... A0,1 ) ( 0 E0,k ... E0,1 ) C Ai = ( 0 Ak,k ... Ak,1 ) , Ei = ( 0 0 ... Ek,1 ) ; (2) C ( : : . : ) ( : : . : ) C ( 0 0 ... A1,1 ) ( 0 0 ... 0 ) C C if JOBFI = 'I', the matrices Ai and Ei have the form C C ( A1,1 ... A1,k A1,0 ) ( 0 ... E1,k E1,0 ) C Ai = ( : . : : ) , Ei = ( : . : : ) , (3) C ( : ... Ak,k Ak,0 ) ( : ... 0 Ek,0 ) C ( 0 ... 0 A0,0 ) ( 0 ... 0 0 ) C C where Ai,i , for i = 0, 1, ..., k, are nonsingular upper C triangular matrices, and A0,0 corresponds to the non-dynamic C infinite modes of the system. C C REFERENCES C C [1] Misra, P., Van Dooren, P., and Varga, A. C Computation of structural invariants of generalized C state-space systems. C Automatica, 30, pp. 1921-1936, 1994. C C NUMERICAL ASPECTS C 3 C The algorithm requires about 25N floating point operations. C C FURTHER COMMENTS C C The number of infinite poles is computed as C C NIBLCK C NINFP = Sum IBLCK(i) = N - ND - NF, C i=1 C C where NF is the number of finite generalized eigenvalues. C The multiplicities of infinite poles can be computed as follows: C there are IBLCK(k)-IBLCK(k+1) infinite poles of multiplicity k, C for k = 1, ..., NIBLCK, where IBLCK(NIBLCK+1) = 0. C Note that each infinite pole of multiplicity k corresponds to an C infinite eigenvalue of multiplicity k+1. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, October 2002. C Based on the RASP routine SRSFOD. C C REVISIONS C C V. Sima, Dec. 2016, June 2017. C C KEYWORDS C C Deflating subspace, orthogonal transformation, C generalized real Schur form, equivalence transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOBFI, STDOM INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, M, N, $ N1, N2, N3, ND, NIBLCK, P DOUBLE PRECISION ALPHA, TOL C .. Array Arguments .. INTEGER IBLCK( * ), IWORK(*) DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), $ BETA(*), C(LDC,*), DWORK(*), E(LDE,*), Q(LDQ,*), $ Z(LDZ,*) C .. Local Scalars .. LOGICAL DISCR, LQUERY, ORDER, REDIF, STAB INTEGER I, LW, MINWRK, NB, NBC, NC, NDIM, NF, NI, NLOW, $ NR, NSUP, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEMM, DGEQRF, DLACPY, MB03QG, MB03QV, TG01MD, $ XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C C .. Executable Statements .. C INFO = 0 DISCR = LSAME( DICO, 'D' ) REDIF = LSAME( JOBFI, 'I' ) STAB = LSAME( STDOM, 'S' ) ORDER = STAB .OR. LSAME( STDOM, 'U' ) C C Check input scalar arguments. C IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.ORDER .AND. .NOT.LSAME( STDOM, 'N' ) ) THEN INFO = -2 ELSE IF( .NOT.REDIF .AND. .NOT.LSAME( JOBFI, 'F' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -23 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -25 ELSE IF( TOL.GE.ONE ) THEN INFO = -29 ELSE IF( N.EQ.0 ) THEN MINWRK = 1 ELSE IF( ORDER ) THEN MINWRK = 4*N + 16 ELSE MINWRK = 4*N END IF LQUERY = LDWORK.EQ.-1 C C Estimate the optimal block size. C CALL DGEQRF( N, MAX( M, P ), A, LDA, DWORK, DWORK, -1, INFO ) NB = INT( DWORK(1) )/MAX( 1, M, P ) LW = MIN( NB*NB, N*MAX( M, P ) ) C IF( LQUERY ) THEN CALL TG01MD( JOBFI, N, 0, 0, A, LDA, E, LDE, B, LDB, C, LDC, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, NF, ND, $ NIBLCK, IBLCK, TOL, IWORK, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, LW, INT( DWORK(1) ) ) IF( ORDER ) THEN NLOW = 1 NSUP = N CALL MB03QG( DICO, STDOM, 'Update', 'Update', N, NLOW, $ NSUP, ALPHA, A, LDA, E, LDE, Q, LDQ, Z, LDZ, $ NDIM, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -32 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01QD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN N1 = 0 N2 = 0 N3 = 0 ND = 0 NIBLCK = 0 DWORK(1) = ONE RETURN END IF C C Finite-infinite separation in generalized real Schur form. C C Workspace: need 4*N; C prefer larger. C CALL TG01MD( JOBFI, N, 0, 0, A, LDA, E, LDE, B, LDB, C, LDC, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, NF, ND, NIBLCK, $ IBLCK, TOL, IWORK, DWORK, LDWORK, INFO ) C IF( INFO.NE.0 ) $ RETURN C WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) C NI = N - NF IF( ORDER ) THEN IF( REDIF ) THEN NLOW = NI + 1 NSUP = N ELSE NLOW = 1 NSUP = MAX( 1, NF ) END IF C C Separate the spectrum of (A,E). The leading NDIM-by-NDIM subpencil C of Af-lambda*Ef corresponds to the generalized eigenvalues in the C domain of interest. C C Workspace: need 4*N+16. C CALL MB03QG( DICO, STDOM, 'Update', 'Update', N, NLOW, NSUP, $ ALPHA, A, LDA, E, LDE, Q, LDQ, Z, LDZ, NDIM, $ DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN INFO = 3 RETURN END IF C WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C IF( REDIF ) THEN N1 = NI N2 = NDIM N3 = N - N1 - N2 ELSE N1 = NDIM N3 = NI N2 = N - N1 - N3 END IF C C Compute the generalized eigenvalues. C CALL MB03QV( N, A, LDA, E, LDE, ALPHAR, ALPHAI, BETA, INFO ) ELSE IF( REDIF ) THEN N1 = NI N3 = NF ELSE N1 = NF N3 = NI END IF N2 = 0 END IF C C Apply the transformation: B <-- Q'*B. C NBC = MAX( 1, MIN( LDWORK/N, M ) ) DO 10 I = 1, M, NBC NC = MIN( NBC, M-I+1 ) CALL DGEMM( 'Transpose', 'No transpose', N, NC, N, ONE, Q, LDQ, $ B(1,I), LDB, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NC, DWORK, N, B(1,I), LDB ) 10 CONTINUE C C Apply the transformation: C <-- C*Z. C NBC = MAX( 1, MIN( LDWORK/N, P ) ) DO 20 I = 1, P, NBC NR = MIN( NBC, P-I+1 ) CALL DGEMM( 'No Transpose', 'No transpose', NR, N, N, ONE, $ C(I,1), LDC, Z, LDZ, ZERO, DWORK, NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC ) 20 CONTINUE C DWORK( 1 ) = MAX( WRKOPT, LW ) C RETURN C *** Last line of TG01QD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01SS.f0000644000000000000000000000013215012430707016202 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01SS.f0000644000175000017500000000735115012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE MB01SS( JOBS, UPLO, N, A, LDA, D ) C C PURPOSE C C To scale a symmetric N-by-N matrix A using the row and column C scaling factors stored in the vector D. C C ARGUMENTS C C Mode Parameters C C JOBS CHARACTER*1 C Specifies the scaling operation to be done, as follows: C = 'D': row and column scaling with D, i.e., A will be C transformed to diag(D)*A*diag(D); C = 'I': row and column scaling with inv(D), i.e., A will C be transformed to inv(diag(D))*A*inv(diag(D)). C C UPLO CHARACTER*1 C Specifies which triangle of the matrix A is stored, as C follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. 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 upper triangular part or C lower triangular part, respectively, of the symmetric C matrix A. C On exit, the leading N-by-N upper triangular part C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') C of this array contains the corresponding triangular part C of the matrix diag(D)*A*diag(D), if JOBS = 'D', or of the C matrix inv(diag(D))*A*inv(diag(D)), JOBS = 'I'. C The stricly lower triangular part (if UPLO = 'U') or C stricly upper triangular part (if UPLO = 'L') is not C referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C D (input) DOUBLE PRECISION array, dimension (N) C The diagonal elements of the diagonal matrix D. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, July 2019. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBS, UPLO INTEGER LDA, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), D(*) C .. Local Scalars .. LOGICAL UPPER INTEGER I, J DOUBLE PRECISION DJ C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. Executable Statements .. C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C UPPER = LSAME( UPLO, 'U' ) C IF( LSAME( JOBS, 'D' ) ) THEN C C Row and column scaling with D. C IF( UPPER ) THEN C DO 20 J = 1, N DJ = D(J) DO 10 I = 1, J A(I,J) = DJ*D(I)*A(I,J) 10 CONTINUE 20 CONTINUE C ELSE C DO 40 J = 1, N DJ = D(J) DO 30 I = J, N A(I,J) = DJ*D(I)*A(I,J) 30 CONTINUE 40 CONTINUE C END IF C ELSE C C Row and column scaling with inv(D). C IF( UPPER ) THEN C DO 60 J = 1, N DJ = ONE/D(J) DO 50 I = 1, J A(I,J) = ( DJ/D(I) )*A(I,J) 50 CONTINUE 60 CONTINUE C ELSE C DO 80 J = 1, N DJ = D(J) DO 70 I = J, N A(I,J) = ( DJ/D(I) )*A(I,J) 70 CONTINUE 80 CONTINUE C END IF C END IF C RETURN C *** Last line of MB01SS *** END control-4.1.2/src/slicot/src/PaxHeaders/BD02AD.f0000644000000000000000000000013215012430707016131 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/BD02AD.f0000644000175000017500000004544515012430707017341 0ustar00lilgelilge00000000000000 SUBROUTINE BD02AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, 1 LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK, 2 LDWORK, INFO ) C C PURPOSE C C To generate benchmark examples for time-invariant, C discrete-time dynamical systems C C E x_k+1 = A x_k + B u_k C C y_k = C x_k + D u_k C C E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and C D is P-by-M. In many examples, E is the identity matrix and D is C the zero matrix. C C This routine is an implementation of the benchmark library C DTDSX (Version 1.0) described in [1]. C C ARGUMENTS C C Mode Parameters C C DEF CHARACTER*1 C Specifies the kind of values used as parameters when C generating parameter-dependent and scalable examples C (i.e., examples with NR(1) = 2, 3, or 4): C = 'D': Default values defined in [1] are used; C = 'N': Values set in DPAR and IPAR are used. C This parameter is not referenced if NR(1) = 1. C Note that the scaling parameter of examples with C NR(1) = 3 or 4 is considered as a regular parameter in C this context. C C Input/Output Parameters C C NR (input) INTEGER array, dimension (2) C Specifies the index of the desired example according C to [1]. C NR(1) defines the group: C 1 : parameter-free problems of fixed size C 2 : parameter-dependent problems of fixed size C 3 : parameter-free problems of scalable size C 4 : parameter-dependent problems of scalable size C NR(2) defines the number of the benchmark example C within a certain group according to [1]. C C DPAR (input/output) DOUBLE PRECISION array, dimension (7) C On entry, if DEF = 'N' and the desired example depends on C real parameters, then the array DPAR must contain the C values for these parameters. C For an explanation of the parameters see [1]. C For Example 2.1, DPAR(1), ..., DPAR(3) define the C parameters 'tau', 'delta', 'K', respectively. C On exit, if DEF = 'D' and the desired example depends on C real parameters, then the array DPAR is overwritten by the C default values given in [1]. C C IPAR (input/output) INTEGER array, dimension (1) C On entry, if DEF = 'N' and the desired example depends on C integer parameters, then the array IPAR must contain the C values for these parameters. C For an explanation of the parameters see [1]. C For Example 3.1, IPAR(1) defines the parameter 'n'. C On exit, if DEF = 'D' and the desired example depends on C integer parameters, then the array IPAR is overwritten by C the default values given in [1]. C C VEC (output) LOGICAL array, dimension (8) C Flag vector which displays the availabilty of the output C data: C VEC(1), ..., VEC(3) refer to N, M, and P, respectively, C and are always .TRUE.. C VEC(4) is .TRUE. iff E is NOT the identity matrix. C VEC(5), ..., VEC(7) refer to A, B, and C, respectively, C and are always .TRUE.. C VEC(8) is .TRUE. iff D is NOT the zero matrix. C C N (output) INTEGER C The actual state dimension, i.e., the order of the C matrices E and A. C C M (output) INTEGER C The number of columns in the matrices B and D. C C P (output) INTEGER C The number of rows in the matrices C and D. C C E (output) DOUBLE PRECISION array, dimension (LDE,N) C The leading N-by-N part of this array contains the C matrix E. C NOTE that this array is overwritten (by the identity C matrix), if VEC(4) = .FALSE.. C C LDE INTEGER C The leading dimension of array E. LDE >= N. C C A (output) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array contains the C matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= N. C C B (output) DOUBLE PRECISION array, dimension (LDB,M) C The leading N-by-M part of this array contains the C matrix B. C C LDB INTEGER C The leading dimension of array B. LDB >= N. C C C (output) DOUBLE PRECISION array, dimension (LDC,N) C The leading P-by-N part of this array contains the C matrix C. C C LDC INTEGER C The leading dimension of array C. LDC >= P. C C D (output) DOUBLE PRECISION array, dimension (LDD,M) C The leading P-by-M part of this array contains the C matrix D. C NOTE that this array is overwritten (by the zero C matrix), if VEC(8) = .FALSE.. C C LDD INTEGER C The leading dimension of array D. LDD >= P. C C NOTE (output) CHARACTER*70 C String containing short information about the chosen C example. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C NOTE that DWORK is not used in the current version C of BD02AD. C C LDWORK INTEGER C LDWORK >= 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; in particular, INFO = -3 or -4 indicates C that at least one of the parameters in DPAR or C IPAR, respectively, has an illegal value; C = 1: data file can not be opened or has wrong format. C C REFERENCES C C [1] Kressner, D., Mehrmann, V. and Penzl, T. C DTDSX - a Collection of Benchmark Examples for State-Space C Realizations of Discrete-Time Dynamical Systems. C SLICOT Working Note 1998-10. 1998. C C NUMERICAL ASPECTS C C None C C CONTRIBUTOR C C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) C C For questions concerning the collection or for the submission of C test examples, please contact Volker Mehrmann C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). C C REVISIONS C C June 1999, V. Sima. C C KEYWORDS C C discrete-time dynamical systems C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, 1 THREE = 3.0D0, FOUR = 4.0D0 ) C .. Scalar Arguments .. CHARACTER DEF CHARACTER*70 NOTE INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, P C .. Array Arguments .. LOGICAL VEC(8) INTEGER IPAR(*), NR(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DPAR(*), 1 DWORK(*), E(LDE,*) C .. Local Scalars .. CHARACTER*12 DATAF INTEGER I, J, STATUS DOUBLE PRECISION TEMP C .. Local Arrays .. LOGICAL VECDEF(8) C .. External Functions .. C . LAPACK . LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. C . LAPACK . EXTERNAL DLASET C .. Data Statements .. C . default values for availabities . DATA VECDEF /.TRUE., .TRUE., .TRUE., .FALSE., 1 .TRUE., .TRUE., .TRUE., .FALSE./ C C .. Executable Statements .. C INFO = 0 DO 10 I = 1, 8 VEC(I) = VECDEF(I) 10 CONTINUE C IF (NR(1) .EQ. 1) THEN C IF (NR(2) .EQ. 1) THEN NOTE = 'Laub 1979, Ex. 2: uncontrollable-unobservable data' N = 2 M = 1 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) A(1,1) = FOUR A(2,1) = -.45D1 A(1,2) = THREE A(2,2) = -.35D1 CALL DLASET('A', N, M, -ONE, ONE, B, LDB) C(1,1) = 3.0D0 C(1,2) = 2.0D0 CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 2) THEN NOTE = 'Laub 1979, Ex. 3' N = 2 M = 2 P = 2 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) A(1,1) = .9512D0 A(2,2) = .9048D0 B(1,1) = .4877D1 B(1,2) = .4877D1 B(2,1) = -.11895D1 B(2,2) = .3569D1 CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 3) THEN NOTE = 'Van Dooren 1981, Ex. II' N = 2 M = 1 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) A(1,1) = TWO A(2,1) = ONE A(1,2) = -ONE A(2,2) = ZERO CALL DLASET('A', N, M, ZERO, ONE, B, LDB) CALL DLASET('A', P, N, ONE, ZERO, C, LDC) D(1,1) = ZERO C ELSE IF (NR(2) .EQ. 4) THEN NOTE = 'Ionescu/Weiss 1992' N = 2 M = 2 P = 2 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) A(1,2) = ONE A(2,2) = -ONE CALL DLASET('A', N, M, ZERO, ONE, B, LDB) B(2,1) = TWO CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 5) THEN NOTE = 'Jonckheere 1981' N = 2 M = 1 P = 2 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) A(1,2) = ONE CALL DLASET('A', N, M, ONE, ZERO, B, LDB) CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 6) THEN NOTE = 'Ackerson/Fu 1970: satellite control problem' N = 4 M = 2 P = 4 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 7) THEN NOTE = 'Litkouhi 1983: system with slow and fast modes' N = 4 M = 2 P = 4 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 8) THEN NOTE = 'Lu/Lin 1993, Ex. 4.3' N = 4 M = 4 P = 4 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('U', P, N, ONE, ONE, C, LDC) C(1,3) = TWO C(1,4) = FOUR C(2,4) = TWO CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 9) THEN NOTE = 'Gajic/Shen 1993, Section 2.7.4: chemical plant' N = 5 M = 2 P = 5 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 10) THEN NOTE = 'Davison/Wang 1974' N = 6 M = 2 P = 2 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN VEC(8) = .TRUE. C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) A(1,2) = ONE A(2,3) = ONE A(4,5) = ONE A(5,6) = ONE CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) B(3,1) = ONE B(6,2) = ONE CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) C(1,1) = ONE C(1,2) = ONE C(2,4) = ONE C(2,5) = -ONE CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) D(1,1) = ONE D(2,1) = ONE C ELSE IF (NR(2) .EQ. 11) THEN NOTE = 'Patnaik et al. 1980: tubular ammonia reactor' N = 9 M = 3 P = 2 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) C(1,1) = ONE C(2,5) = ONE CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE IF (NR(2) .EQ. 12) THEN NOTE = 'Smith 1969: two-stand cold rolling mill' N = 10 M = 3 P = 5 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN VEC(8) = .TRUE. C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) CALL DLASET('A', N, N, ZERO, ONE, A(2,1), LDA) A(1,10) = .112D0 CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) B(1,1) = .276D1 B(1,2) = -.135D1 B(1,3) = -.46D0 CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) C(1,1) = ONE C(2,10) = .894D0 C(3,10) = -.1693D2 C(4,10) = .7D-1 C(5,10) = .398D0 OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD02112.dat') IF (STATUS .NE. 0) THEN INFO = 1 ELSE DO 110 I = 1, P READ (1, FMT = *, IOSTAT = STATUS) (D(I,J), J = 1, M) IF (STATUS .NE. 0) INFO = 1 110 CONTINUE END IF CLOSE(1) C ELSE INFO = -2 END IF C IF (((NR(2) .GE. 6) .AND. (NR(2) .LE. 9)) .OR. 1 (NR(2) .EQ. 11)) THEN C .. loading data files WRITE (DATAF(1:11), '(A,I2.2,A)') 'BD021', NR(2), '.dat' OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:11)) IF (STATUS .NE. 0) THEN INFO = 1 ELSE DO 120 I = 1, N READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) IF (STATUS .NE. 0) INFO = 1 120 CONTINUE DO 130 I = 1, N READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) IF (STATUS .NE. 0) INFO = 1 130 CONTINUE END IF CLOSE(1) END IF C ELSE IF (NR(1) .EQ. 2) THEN IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN INFO = -1 RETURN END IF C IF (NR(2) .EQ. 1) THEN NOTE = 'Pappas et al. 1980: process control of paper machine' IF (LSAME(DEF,'D')) THEN DPAR(1) = .1D9 DPAR(2) = ONE DPAR(3) = ONE END IF IF (DPAR(1) .EQ. ZERO) INFO = -3 N = 4 M = 1 P = 1 IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C TEMP = DPAR(2) / DPAR(1) CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) CALL DLASET('A', N-1, N-1, ZERO, ONE, A(2,1), LDA) A(1,1) = ONE - TEMP CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) B(1,1) = DPAR(3) * TEMP CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) C(1,4) = ONE CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE INFO = -2 END IF C ELSE IF (NR(1) .EQ. 3) THEN IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN INFO = -1 RETURN END IF C IF (NR(2) .EQ. 1) THEN NOTE = 'Pappas et al. 1980, Ex. 3' IF (LSAME(DEF,'D')) IPAR(1) = 100 IF (IPAR(1) .LT. 2) INFO = -4 N = IPAR(1) M = 1 P = N IF (LDE .LT. N) INFO = -10 IF (LDA .LT. N) INFO = -12 IF (LDB .LT. N) INFO = -14 IF (LDC .LT. P) INFO = -16 IF (LDD .LT. P) INFO = -18 IF (INFO .NE. 0) RETURN C CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) CALL DLASET('A', N-1, N-1, ZERO, ONE, A(1,2), LDA) CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) B(N,1) = ONE CALL DLASET('A', P, N, ZERO, ONE, C, LDC) CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) C ELSE INFO = -2 END IF C ELSE INFO = -2 END IF C RETURN C *** Last Line of BD02AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03QV.f0000644000000000000000000000013215012430707016205 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03QV.f0000644000175000017500000000713015012430707017402 0ustar00lilgelilge00000000000000 SUBROUTINE MB03QV( N, S, LDS, T, LDT, ALPHAR, ALPHAI, BETA, INFO ) C C PURPOSE C C To compute the eigenvalues of an upper quasi-triangular matrix C pencil. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices S and T. N >= 0. C C S (input) DOUBLE PRECISION array, dimension(LDS,N) C The upper quasi-triangular matrix S. C C LDS INTEGER C The leading dimension of the array S. LDS >= max(1,N). C C T (input) DOUBLE PRECISION array, dimension(LDT,N) C The upper triangular matrix T. C C LDT INTEGER C The leading dimension of the array T. LDT >= max(1,N). 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 On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, C are the generalized eigenvalues. C ALPHAR(j) + ALPHAI(j)*i, and BETA(j),j=1,...,N, are the C diagonals of the complex Schur form (S,T) that would C result if the 2-by-2 diagonal blocks of the real Schur C form of (A,B) were further reduced to triangular form C using 2-by-2 complex unitary transformations. C If ALPHAI(j) is zero, then the j-th eigenvalue is real; if C positive, then the j-th and (j+1)-st eigenvalues are a C complex conjugate pair, with ALPHAI(j+1) negative. 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 October 2002. C C REVISIONS C C V. Sima, Dec. 2016. C C ****************************************************************** C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDS, LDT, N C .. Array Arguments .. DOUBLE PRECISION ALPHAI(*), ALPHAR(*), BETA(*), S(LDS,*), T(LDT,*) C .. Local Scalars .. INTEGER I, INEXT DOUBLE PRECISION SAFMIN C .. External Functions .. EXTERNAL DLAMCH DOUBLE PRECISION DLAMCH C .. External Subroutines .. EXTERNAL DLAG2, 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( LDS.LT.MAX( 1, N ) ) THEN INFO = -3 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -5 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB03QV', -INFO ) RETURN END IF C SAFMIN = DLAMCH( 'S' ) INEXT = 1 DO 10 I = 1, N IF( I.LT.INEXT ) $ GO TO 10 IF( I.NE.N ) THEN IF( S(I+1,I).NE.ZERO ) THEN C C A pair of eigenvalues. C INEXT = I + 2 CALL DLAG2( S(I,I), LDS, T(I,I), LDT, SAFMIN, BETA(I), $ BETA(I+1), ALPHAR(I), ALPHAR(I+1), $ ALPHAI(I) ) ALPHAI(I+1) = -ALPHAI(I) GO TO 10 END IF END IF C C Simple eigenvalue. C INEXT = I + 1 ALPHAR(I) = S(I,I) ALPHAI(I) = ZERO BETA(I) = T(I,I) 10 CONTINUE C RETURN C *** Last line of MB03QV *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01RT.f0000644000000000000000000000013215012430707016202 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01RT.f0000644000175000017500000002137315012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE MB01RT( UPLO, TRANS, N, ALPHA, BETA, R, LDR, E, LDE, $ X, LDX, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the matrix formula C C R := alpha*R + beta*op( E )*X*op( E )', C C where alpha and beta are scalars, R and X are symmetric matrices, C E is an upper triangular matrix, and op( E ) is one of C C op( E ) = E or op( E ) = E'. 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( E ) to be used in the matrix C multiplication as follows: C = 'N': op( E ) = E; C = 'T': op( E ) = E'; C = 'C': op( E ) = E'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices R, E, and X. 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 E and X are not C referenced. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) C On entry with 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 R. C On entry with 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 R. C In both cases, the other strictly triangular part is not C referenced. C On exit, the leading N-by-N 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 the computed matrix R. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C E (input) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the upper triangular matrix E. C The remaining part of this array is not referenced. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). 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 N = 0. C C LDWORK The length of the array DWORK. C LDWORK >= N*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 = U + L, with U and L upper and C lower triangular matrices, defined by C C U = triu( X ) - (1/2)*diag( X ), C L = tril( X ) - (1/2)*diag( X ), C C where triu, tril, and diag denote the upper triangular part, lower C triangular part, and diagonal part of X, respectively. Then, C if UPLO = 'U', C C E*X*E' = ( E*U )*E' + E*( E*U )', for TRANS = 'N', C E'*X*E = E'*( U*E ) + ( U*E )'*E, for TRANS = 'T', or 'C', C C and if UPLO = 'L', C C E*X*E' = ( E*L' )*E' + E*( E*L' )', for TRANS = 'N', C E'*X*E = E'*( L'*E ) + ( L'*E )'*E, for TRANS = 'T', or 'C', C C which involve operations like in BLAS 2 and 3 (DTRMV and DSYR2K). C This approach ensures that the matrices E*U, U*E, E*L', or L'*E C are upper triangular. C C NUMERICAL ASPECTS C C The algorithm requires approximately N**3/2 operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2019. 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, TWO, HALF PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ HALF = 0.5D0 ) C .. Scalar Arguments .. CHARACTER TRANS, UPLO INTEGER INFO, LDE, LDR, LDWORK, LDX, N DOUBLE PRECISION ALPHA, BETA C .. Array Arguments .. DOUBLE PRECISION DWORK(*), E(LDE,*), R(LDR,*), X(LDX,*) C .. Local Scalars .. LOGICAL LTRANS, LUPLO INTEGER I, J C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DSCAL, DTRMV, $ MB01OT, 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( N.LT.0 ) THEN INFO = -3 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDE.LT.1 .OR. ( LTRANS .AND. LDE.LT.N ) .OR. $ ( .NOT.LTRANS .AND. LDE.LT.N ) ) THEN INFO = -9 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.N*N ) $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.0 ) ) THEN INFO = -13 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01RT', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C IF ( BETA.EQ.ZERO ) THEN IF ( ALPHA.EQ.ZERO ) THEN C C Special case alpha = 0. C CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) ELSE C C Special case beta = 0. C IF ( ALPHA.NE.ONE ) $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, N, N, R, LDR, INFO ) END IF RETURN END IF C C General case: beta <> 0. C Compute W = E*T or W = T*E in DWORK, and apply the updating C formula (see METHOD section). C Workspace: need N*N. C CALL DSCAL( N, HALF, X, LDX+1 ) C IF ( .NOT.LTRANS ) THEN C IF ( LUPLO ) THEN C DO 10 J = 1, N CALL DCOPY( J, X(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, E, LDE, $ DWORK(1+(J-1)*N), 1 ) 10 CONTINUE C ELSE C DO 20 J = 1, N CALL DCOPY( J, X(J,1), LDX, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', J, E, LDE, $ DWORK(1+(J-1)*N), 1 ) 20 CONTINUE C END IF C ELSE C IF ( LUPLO ) THEN C DO 30 J = 1, N CALL DCOPY( J, E(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, X, LDX, $ DWORK(1+(J-1)*N), 1 ) 30 CONTINUE C ELSE C DO 40 J = 1, N CALL DCOPY( J, E(1,J), 1, DWORK(1+(J-1)*N), 1 ) CALL DTRMV( UPLO, 'Tran', 'NoDiag', J, X, LDX, $ DWORK(1+(J-1)*N), 1 ) 40 CONTINUE C END IF C END IF C CALL DSCAL( N, TWO, X, LDX+1 ) C CALL MB01OT( UPLO, TRANS, N, ALPHA, BETA, R, LDR, E, LDE, DWORK, $ N ) C RETURN C *** Last line of MB01RT *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03UD.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03UD.f0000644000175000017500000002545515012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To compute all, or part, of the singular value decomposition of a C real upper triangular matrix. C C The N-by-N upper triangular matrix A is factored as A = Q*S*P', C where Q and P are N-by-N orthogonal matrices and S is an C N-by-N diagonal matrix with non-negative diagonal elements, C SV(1), SV(2), ..., SV(N), ordered such that C C SV(1) >= SV(2) >= ... >= SV(N) >= 0. C C The columns of Q are the left singular vectors of A, the diagonal C elements of S are the singular values of A and the columns of P C are the right singular vectors of A. C C Either or both of Q and P' may be requested. C When P' is computed, it is returned in A. C C ARGUMENTS C C Mode Parameters C C JOBQ CHARACTER*1 C Specifies whether the user wishes to compute the matrix Q C of left singular vectors as follows: C = 'V': Left singular vectors are computed; C = 'N': No left singular vectors are computed. C C JOBP CHARACTER*1 C Specifies whether the user wishes to compute the matrix P' C of right singular vectors as follows: C = 'V': Right singular vectors are computed; C = 'N': No right singular vectors are computed. 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 of this C array must contain the upper triangular matrix A. C On exit, if JOBP = 'V', the leading N-by-N part of this C array contains the N-by-N orthogonal matrix P'; otherwise C the N-by-N upper triangular part of A is used as internal C workspace. The strictly lower triangular part of A is set C internally to zero before the reduction to bidiagonal form C is performed. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) C If JOBQ = 'V', the leading N-by-N part of this array C contains the orthogonal matrix Q. C If JOBQ = 'N', Q is not referenced. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= 1, and when JOBQ = 'V', LDQ >= MAX(1,N). C C SV (output) DOUBLE PRECISION array, dimension (N) C The N singular values of the matrix A, sorted in C descending order. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; C if INFO > 0, DWORK(2:N) contains the unconverged C superdiagonal elements of an upper bidiagonal matrix B C whose diagonal is in SV (not necessarily sorted). C B satisfies A = Q*B*P', so it has the same singular C values as A, and singular vectors related by Q and P'. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1,5*N). 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 > 0: the QR algorithm has failed to converge. In this C case INFO specifies how many superdiagonals did not C converge (see the description of DWORK). C This failure is not likely to occur. C C METHOD C C The routine reduces A to bidiagonal form by means of elementary C reflectors and then uses the QR algorithm on the bidiagonal form. C C CONTRIBUTOR C C V. Sima, Research Institute of Informatics, Bucharest, and C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C March 1998. Based on the RASP routine DTRSVD. C C REVISIONS C C V. Sima, Feb. 2000, Aug. 2011. C C KEYWORDS C C Bidiagonalization, orthogonal transformation, singular value C decomposition, singular values, triangular form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER JOBP, JOBQ INTEGER INFO, LDA, LDQ, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), Q(LDQ,*), SV(*) C .. Local Scalars .. LOGICAL LQUERY, WANTQ, WANTP INTEGER I, IE, ISCL, ITAUP, ITAUQ, JWORK, MAXWRK, $ MINWRK, NCOLP, NCOLQ DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANTR EXTERNAL DLAMCH, DLANTR, LSAME C .. External Subroutines .. EXTERNAL DBDSQR, DGEBRD, DLACPY, DLASCL, DLASET, DORGBR, $ XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, SQRT C .. Executable Statements .. C C Check the input scalar arguments. C INFO = 0 WANTQ = LSAME( JOBQ, 'V' ) WANTP = LSAME( JOBP, 'V' ) IF( .NOT.WANTQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.WANTP .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) .OR. $ ( .NOT.WANTQ .AND. LDQ.LT.1 ) ) THEN INFO = -7 ELSE C C Compute workspace C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 MINWRK = MAX( 1, 5*N ) LQUERY = LDWORK.EQ.-1 IF ( LQUERY ) THEN CALL DGEBRD( N, N, A, LDA, SV, DWORK, DWORK, DWORK, DWORK, $ -1, INFO ) MAXWRK = INT( DWORK(1) ) IF( WANTQ ) THEN CALL DORGBR( 'Q', N, N, N, Q, LDQ, DWORK, DWORK, -1, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) END IF IF( WANTP ) THEN CALL DORGBR( 'P', N, N, N, A, LDA, DWORK, DWORK, -1, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) END IF MAXWRK = MAX( 3*N + MAXWRK, MINWRK ) END IF IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -10 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03UD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = MAXWRK RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Get machine constants. C EPS = DLAMCH( 'P' ) SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS BIGNUM = ONE / SMLNUM C C Scale A if max entry outside range [SMLNUM,BIGNUM]. C ANRM = DLANTR( 'Max', 'Upper', 'Non-unit', N, N, A, LDA, DUM ) ISCL = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN ISCL = 1 CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, N, N, A, LDA, INFO ) ELSE IF( ANRM.GT.BIGNUM ) THEN ISCL = 1 CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, N, N, A, LDA, INFO ) END IF C C Zero out below. C IF ( N.GT.1 ) $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, A(2,1), LDA ) C C Find the singular values and optionally the singular vectors C of the upper triangular matrix A. C IE = 1 ITAUQ = IE + N ITAUP = ITAUQ + N JWORK = ITAUP + N C C First reduce the matrix to bidiagonal form. The diagonal C elements will be in SV and the superdiagonals in DWORK(IE). C (Workspace: need 4*N, prefer 3*N+2*N*NB) C CALL DGEBRD( N, N, A, LDA, SV, DWORK(IE), DWORK(ITAUQ), $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) IF( WANTQ ) THEN C C Generate the transformation matrix Q corresponding to the C left singular vectors. C (Workspace: need 4*N, prefer 3*N+N*NB) C NCOLQ = N CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ ) CALL DORGBR( 'Q', N, N, N, Q, LDQ, DWORK(ITAUQ), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) ELSE NCOLQ = 0 END IF IF( WANTP ) THEN C C Generate the transformation matrix P' corresponding to the C right singular vectors. C (Workspace: need 4*N, prefer 3*N+N*NB) C NCOLP = N CALL DORGBR( 'P', N, N, N, A, LDA, DWORK(ITAUP), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) ELSE NCOLP = 0 END IF JWORK = IE + N C C Perform bidiagonal QR iteration, to obtain all or part of the C singular value decomposition of A. C (Workspace: need 5*N) C CALL DBDSQR( 'U', N, NCOLP, NCOLQ, 0, SV, DWORK(IE), A, LDA, $ Q, LDQ, DUM, 1, DWORK(JWORK), INFO ) C C If DBDSQR failed to converge, copy unconverged superdiagonals C to DWORK(2:N). C IF( INFO.NE.0 ) THEN DO 10 I = N - 1, 1, -1 DWORK(I+1) = DWORK(I+IE-1) 10 CONTINUE END IF C C Undo scaling if necessary. C IF( ISCL.EQ.1 ) THEN IF( ANRM.GT.BIGNUM ) $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N, 1, SV, N, INFO ) IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N-1, 1, DWORK(2), N, $ INFO ) IF( ANRM.LT.SMLNUM ) $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N, 1, SV, N, INFO ) IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N-1, 1, DWORK(2), N, $ INFO ) END IF C C Return optimal workspace in DWORK(1). C DWORK(1) = MAXWRK C RETURN C *** Last line of MB03UD *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BU.f0000644000000000000000000000013015012430707016166 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/NF01BU.f0000644000175000017500000002766515012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BU( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J, $ LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the matrix J'*J + c*I, for the Jacobian J as received C from SLICOT Library routine NF01BD: C C / dy(1)/dwb(1) | dy(1)/dtheta \ C Jc = | : | : | . C \ dy(L)/dwb(L) | dy(L)/dtheta / C C This is a compressed representation of the actual structure C C / J_1 0 .. 0 | L_1 \ C | 0 J_2 .. 0 | L_2 | C J = | : : .. : | : | . C | : : .. : | : | C \ 0 0 .. J_L | L_L / C C ARGUMENTS C C Mode Parameters C C STOR CHARACTER*1 C Specifies the storage scheme for the symmetric C matrix J'*J + c*I, as follows: C = 'F' : full storage is used; C = 'P' : packed storage is used. C C UPLO CHARACTER*1 C Specifies which part of the matrix J'*J + c*I is stored, C as follows: C = 'U' : the upper triagular part is stored; C = 'L' : the lower triagular part is stored. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix J'*J + c*I. C N = BN*BSN + ST >= 0. (See parameter description below.) C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of the C matrix J, as follows: C IPAR(1) must contain ST, the number of parameters C corresponding to the linear part. ST >= 0. C IPAR(2) must contain BN, the number of blocks, BN = L, C for the parameters corresponding to the nonlinear C part. BN >= 0. C IPAR(3) must contain BSM, the number of rows of the blocks C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the C number of rows of the matrix J, if BN <= 1. C IPAR(4) must contain BSN, the number of columns of the C blocks J_k, k = 1:BN. BSN >= 0. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 4. C C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) C The real parameters needed for solving the problem. C The entry DPAR(1) must contain the real scalar c. C C LDPAR (input) INTEGER C The length of the array DPAR. LDPAR >= 1. C C J (input) DOUBLE PRECISION array, dimension (LDJ, NC) C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. C The leading NR-by-NC part of this array must contain C the (compressed) representation (Jc) of the Jacobian C matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM, C if BN > 1. C C LDJ (input) INTEGER C The leading dimension of array J. LDJ >= MAX(1,NR). C C JTJ (output) DOUBLE PRECISION array, C dimension (LDJTJ,N), if STOR = 'F', C dimension (N*(N+1)/2), if STOR = 'P'. C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if C STOR = 'P') part of this array contains the upper or C lower triangle of the matrix J'*J + c*I, depending on C UPLO = 'U', or UPLO = 'L', respectively, stored either as C a two-dimensional, or one-dimensional array, depending C on STOR. C C LDJTJ INTEGER C The leading dimension of the array JTJ. C LDJTJ >= MAX(1,N), if STOR = 'F'. C LDJTJ >= 1, if STOR = 'P'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C Currently, this array is not used. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 0. 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 product is computed columnn-wise, exploiting the C symmetry. BLAS 3 routines DGEMM and DSYRK are used if STOR = 'F', C and BLAS 2 routine DGEMV is used if STOR = 'P'. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. C C REVISIONS C C V. Sima, Dec. 2001, Mar. 2002. C C KEYWORDS C C Elementary matrix operations, matrix algebra, matrix operations, C Wiener system. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER STOR, UPLO INTEGER INFO, LDJ, LDJTJ, LDPAR, LDWORK, LIPAR, N C .. Array Arguments .. DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), JTJ(*) INTEGER IPAR(*) C .. Local Scalars .. LOGICAL FULL, UPPER INTEGER BN, BSM, BSN, I1, IBSM, IBSN, II, JL, K, M, $ NBSN, NTHS, ST DOUBLE PRECISION C C .. Local Arrays .. DOUBLE PRECISION TMP(1) INTEGER ITMP(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, DSYRK, NF01BV, $ XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C INFO = 0 C FULL = LSAME( STOR, 'F' ) UPPER = LSAME( UPLO, 'U' ) C IF( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN INFO = -1 ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -2 ELSEIF ( N.LT.0 ) THEN INFO = -3 ELSEIF ( LIPAR.LT.4 ) THEN INFO = -5 ELSEIF ( LDPAR.LT.1 ) THEN INFO = -7 ELSEIF ( LDJTJ.LT.1 .OR. ( FULL .AND. LDJTJ.LT.N ) ) THEN INFO = -11 ELSEIF ( LDWORK.LT.0 ) THEN INFO = -13 ELSE ST = IPAR(1) BN = IPAR(2) BSM = IPAR(3) BSN = IPAR(4) NTHS = BN*BSN IF ( BN.GT.1 ) THEN M = BN*BSM ELSE M = BSM END IF IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN INFO = -4 ELSEIF ( N.NE.NTHS + ST ) THEN INFO = -3 ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN INFO = -9 END IF ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01BU', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C C = DPAR(1) C IF ( BN.LE.1 .OR. BSN.EQ.0 .OR. BSM.EQ.0 ) THEN C C Special case, l <= 1 or BSN = 0 or BSM = 0: the Jacobian is C represented as a full matrix. C ITMP(1) = M CALL NF01BV( STOR, UPLO, N, ITMP, 1, DPAR, 1, J, LDJ, JTJ, $ LDJTJ, DWORK, LDWORK, INFO ) RETURN END IF C C General case: l > 1, BSN > 0, BSM > 0. C JL = BSN + 1 C IF ( FULL ) THEN C NBSN = N*BSN C IF ( UPPER ) THEN C C Compute the leading upper triangular part (full storage). C CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ, LDJTJ ) CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J, LDJ, ONE, $ JTJ, LDJTJ ) IBSN = BSN I1 = NBSN + 1 C DO 10 IBSM = BSM + 1, M, BSM II = I1 + IBSN CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1), $ LDJTJ ) I1 = I1 + NBSN CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ ) CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1), $ LDJ, ONE, JTJ(II), LDJTJ ) IBSN = IBSN + BSN 10 CONTINUE C IF ( ST.GT.0 ) THEN C C Compute the last block column. C DO 20 IBSM = 1, M, BSM CALL DGEMM( 'Transpose', 'NoTranspose', BSN, ST, BSM, $ ONE, J(IBSM,1), LDJ, J(IBSM,JL), LDJ, $ ZERO, JTJ(I1), LDJTJ ) I1 = I1 + BSN 20 CONTINUE C CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(I1), LDJTJ ) CALL DSYRK( UPLO, 'Transpose', ST, M, ONE, J(1,JL), $ LDJ, ONE, JTJ(I1), LDJTJ ) END IF C ELSE C C Compute the leading lower triangular part (full storage). C IBSN = NTHS II = 1 C DO 30 IBSM = 1, M, BSM I1 = II + BSN CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ ) CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1), $ LDJ, ONE, JTJ(II), LDJTJ ) IBSN = IBSN - BSN CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1), $ LDJTJ ) II = I1 + NBSN IF ( ST.GT.0 ) $ CALL DGEMM( 'Transpose', 'NoTranspose', ST, BSN, BSM, $ ONE, J(IBSM,JL), LDJ, J(IBSM,1), LDJ, $ ZERO, JTJ(I1+IBSN), LDJTJ ) 30 CONTINUE C IF ( ST.GT.0 ) THEN C C Compute the last diagonal block. C CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(II), LDJTJ ) CALL DSYRK( UPLO, 'Transpose', ST, M, ONE, J(1,JL), $ LDJ, ONE, JTJ(II), LDJTJ ) END IF C END IF C ELSE C TMP(1) = ZERO C IF ( UPPER ) THEN C C Compute the leading upper triangular part (packed storage). C IBSN = 0 I1 = 1 C DO 50 IBSM = 1, M, BSM C DO 40 K = 1, BSN II = I1 + IBSN CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 ) CALL DGEMV( 'Transpose', BSM, K, ONE, J(IBSM,1), LDJ, $ J(IBSM,K), 1, ZERO, JTJ(II), 1 ) I1 = II + K JTJ(I1-1) = JTJ(I1-1) + C 40 CONTINUE C IBSN = IBSN + BSN 50 CONTINUE C C Compute the last block column. C DO 70 K = 1, ST C DO 60 IBSM = 1, M, BSM CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1), $ LDJ, J(IBSM,BSN+K), 1, ZERO, JTJ(I1), 1 ) I1 = I1 + BSN 60 CONTINUE C CALL DGEMV( 'Transpose', M, K, ONE, J(1,JL), LDJ, $ J(1,BSN+K), 1, ZERO, JTJ(I1), 1 ) I1 = I1 + K JTJ(I1-1) = JTJ(I1-1) + C 70 CONTINUE C ELSE C C Compute the leading lower triangular part (packed storage). C IBSN = NTHS II = 1 C DO 90 IBSM = 1, M, BSM IBSN = IBSN - BSN C DO 80 K = 1, BSN I1 = II + BSN - K + 1 CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 ) CALL DGEMV( 'Transpose', BSM, BSN-K+1, ONE, J(IBSM,K), $ LDJ, J(IBSM,K), 1, ZERO, JTJ(II), 1 ) JTJ(II) = JTJ(II) + C I1 = I1 + IBSN II = I1 + ST IF ( ST.GT.0 ) $ CALL DGEMV( 'Transpose', BSM, ST, ONE, J(IBSM,JL), $ LDJ, J(IBSM,K), 1, ZERO, JTJ(I1), 1 ) 80 CONTINUE C 90 CONTINUE C C Compute the last diagonal block. C DO 100 K = 1, ST CALL DGEMV( 'Transpose', M, ST-K+1, ONE, J(1,BSN+K), LDJ, $ J(1,BSN+K), 1, ZERO, JTJ(II), 1 ) JTJ(II) = JTJ(II) + C II = II + ST - K + 1 100 CONTINUE C END IF C END IF C RETURN C C *** Last line of NF01BU *** END control-4.1.2/src/slicot/src/PaxHeaders/AB13FD.f0000644000000000000000000000013215012430707016135 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB13FD.f0000644000175000017500000003073115012430707017335 0ustar00lilgelilge00000000000000 SUBROUTINE AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK, $ CWORK, LCWORK, INFO ) C C PURPOSE C C To compute beta(A), the 2-norm distance from a real matrix A to C the nearest complex matrix with an eigenvalue on the imaginary C axis. If A is stable in the sense that all eigenvalues of A lie C in the open left half complex plane, then beta(A) is the complex C stability radius, i.e., the distance to the nearest unstable C complex matrix. The value of beta(A) is the minimum of the C smallest singular value of (A - jwI), taken over all real w. C The value of w corresponding to the minimum is also computed. C C ARGUMENTS 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 part of this array must contain the C matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C BETA (output) DOUBLE PRECISION C The computed value of beta(A), which actually is an upper C bound. C C OMEGA (output) DOUBLE PRECISION C The value of w such that the smallest singular value of C (A - jwI) equals beta(A). C C Tolerances C C TOL DOUBLE PRECISION C Specifies the accuracy with which beta(A) is to be C calculated. (See the Numerical Aspects section below.) C If the user sets TOL to be less than EPS, where EPS is the C machine precision (see LAPACK Library Routine DLAMCH), C then the tolerance is taken to be EPS. 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 If DWORK(1) is not needed, the first 2*N*N entries of C DWORK may overlay CWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( 1, 3*N*(N+2) ). C For optimum performance LDWORK should be larger. C C CWORK COMPLEX*16 array, dimension (LCWORK) C On exit, if INFO = 0, CWORK(1) returns the optimal value C of LCWORK. C If CWORK(1) is not needed, the first N*N entries of C CWORK may overlay DWORK. C C LCWORK INTEGER C The length of the array CWORK. C LCWORK >= MAX( 1, N*(N+3) ). C For optimum performance LCWORK 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: the routine fails to compute beta(A) within the C specified tolerance. Nevertheless, the returned C value is an upper bound on beta(A); C = 2: either the QR or SVD algorithm (LAPACK Library C routines DHSEQR, DGESVD or ZGESVD) fails to C converge; this error is very rare. C C METHOD C C AB13FD combines the methods of [1] and [2] into a provably C reliable, quadratically convergent algorithm. It uses the simple C bisection strategy of [1] to find an interval which contains C beta(A), and then switches to the modified bisection strategy of C [2] which converges quadratically to a minimizer. Note that the C efficiency of the strategy degrades if there are several local C minima that are near or equal the global minimum. C C REFERENCES C C [1] Byers, R. C A bisection method for measuring the distance of a stable C matrix to the unstable matrices. C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988. C C [2] Boyd, S. and Balakrishnan, K. C A regularity result for the singular values of a transfer C matrix and a quadratically convergent algorithm for computing C its L-infinity norm. C Systems and Control Letters, Vol. 15, pp. 1-7, 1990. C C NUMERICAL ASPECTS C C In the presence of rounding errors, the computed function value C BETA satisfies C C beta(A) <= BETA + epsilon, C C BETA/(1+TOL) - delta <= MAX(beta(A), SQRT(2*N*EPS)*norm(A)), C C where norm(A) is the Frobenius norm of A, C C epsilon = p(N) * EPS * norm(A), C and C delta = p(N) * SQRT(EPS) * norm(A), C C and p(N) is a low degree polynomial. It is recommended to choose C TOL greater than SQRT(EPS). Although rounding errors can cause C AB13FD to fail for smaller values of TOL, nevertheless, it usually C succeeds. Regardless of success or failure, the first inequality C holds. C C CONTRIBUTORS C C R. Byers, the routines QSEC and QSEC0 (January, 1995). C C REVISIONS C C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2002, C Jan. 2003. C C KEYWORDS C C complex stability radius, distances, eigenvalue, eigenvalue C perturbation, norms. C C ****************************************************************** C C .. Parameters .. INTEGER MAXIT PARAMETER ( MAXIT = 50 ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) C .. Scalar Arguments .. INTEGER INFO, LCWORK, LDA, LDWORK, N DOUBLE PRECISION BETA, OMEGA, TOL C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*) COMPLEX*16 CWORK(*) C .. Local Scalars .. INTEGER I, IA2, IAA, IGF, IHI, ILO, ITNUM, IWI, IWK, $ IWR, JWORK, KOM, LBEST, MINWRK, N2 DOUBLE PRECISION EPS, LOW, OM, OM1, OM2, SFMN, SIGMA, SV, TAU, $ TEMP, TOL1 LOGICAL SUFWRK C .. Local Arrays .. DOUBLE PRECISION DUMMY(1), DUMMY2(1,1) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE, MB03NY EXTERNAL DLAMCH, DLANGE, MB03NY C .. External Subroutines .. EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM, $ DSYMV, MA02ED, MB04ZD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, SQRT C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 MINWRK = 3*N*( N + 2 ) C IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN INFO = -8 ELSE IF( LCWORK.LT.MAX( 1, N*( N + 3 ) ) ) THEN INFO = -10 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB13FD', -INFO ) RETURN END IF C C Quick return if possible. C OMEGA = ZERO IF ( N.EQ.0 ) THEN BETA = ZERO DWORK(1) = ONE CWORK(1) = CONE RETURN END IF C C Indices for splitting the work array. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C as well as the preferred amount for good performance.) C N2 = N*N IGF = 1 IA2 = IGF + N2 + N IAA = IA2 + N2 IWK = IAA + N2 IWR = IAA IWI = IWR + N C SUFWRK = LDWORK-IWK.GE.N2 C C Computation of the tolerances. EPS is the machine precision. C SFMN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Epsilon' ) TOL1 = SQRT( EPS * DBLE( 2*N ) ) * $ DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) TAU = ONE + MAX( TOL, EPS ) C C Initialization, upper bound at known critical point. C Workspace: need N*(N+1)+5*N; prefer larger. C KOM = 2 LOW = ZERO CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N ) BETA = MB03NY( N, OMEGA, DWORK(IGF), N, DWORK(IGF+N2), $ DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO ) IF ( INFO.NE.0 ) $ RETURN LBEST = MAX( MINWRK, INT( DWORK(IA2) ) - IA2 + 1, 4*N2 + N ) C ITNUM = 1 C WHILE ( ITNUM <= MAXIT and BETA > TAU*MAX( TOL1, LOW ) ) DO 10 IF ( ( ITNUM.LE.MAXIT ) .AND. $ ( BETA.GT.TAU*MAX( TOL1, LOW ) ) ) THEN IF ( KOM.EQ.2 ) THEN SIGMA = BETA/TAU ELSE SIGMA = SQRT( BETA ) * SQRT( MAX( TOL1, LOW ) ) END IF C C Set up H(sigma). C Workspace: N*(N+1)+2*N*N. C CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N ) DWORK(IGF) = SIGMA DWORK(IGF+N) = -SIGMA DUMMY(1) = ZERO CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 ) C DO 20 I = IGF, IA2 - N - 2, N + 1 CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 ) 20 CONTINUE C C Computation of the eigenvalues by the square reduced algorithm. C Workspace: N*(N+1)+2*N*N+2*N. C CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N, $ DUMMY2, 1, DWORK(IWK), INFO ) C C Form the matrix A*A + F*G. C Workspace: need N*(N+1)+2*N*N+N; C prefer N*(N+1)+3*N*N. C JWORK = IA2 IF ( SUFWRK ) $ JWORK = IWK C CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N ) CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) C IF ( SUFWRK ) THEN C C Use BLAS 3 calculation. C CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N, $ DWORK(JWORK), N, ZERO, DWORK(IA2), N ) ELSE C C Use BLAS 2 calculation. C DO 30 I = 1, N CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N, $ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 ) CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 ) 30 CONTINUE C END IF C CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, $ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N ) C C Find the eigenvalues of A*A + F*G. C Workspace: N*(N+1)+N*N+3*N. C JWORK = IWI + N CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK), $ I ) CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, $ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1, $ DWORK(JWORK), N, INFO ) C IF ( INFO.NE.0 ) THEN INFO = 2 RETURN END IF C C Count negative real axis squared eigenvalues. If there are two, C then the valley is isolated, and next approximate minimizer is C mean of the square roots. C KOM = 0 DO 40 I = 0, N - 1 TEMP = ABS( DWORK(IWI+I) ) IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1 IF ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL1 ) ) THEN KOM = KOM + 1 OM = SQRT( -DWORK(IWR+I) ) IF ( KOM.EQ.1 ) OM1 = OM IF ( KOM.EQ.2 ) OM2 = OM END IF 40 CONTINUE C IF ( KOM.EQ.0 ) THEN LOW = SIGMA ELSE C C In exact arithmetic KOM = 1 is impossible, but if tau is C close enough to one, MB04ZD may miss the initial near zero C eigenvalue. C Workspace, real: need 3*N*(N+2); prefer larger; C complex: need N*(N+3); prefer larger. C IF ( KOM.EQ.2 ) THEN OM = OM1 + ( OM2 - OM1 ) / TWO ELSE IF ( KOM.EQ.1 .AND. ITNUM.EQ.1 ) THEN OM = OM1 / TWO KOM = 2 END IF C CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N ) SV = MB03NY( N, OM, DWORK(IGF), N, DWORK(IGF+N2), $ DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO ) IF ( INFO.NE.0 ) $ RETURN IF ( BETA.GT.SV ) THEN BETA = SV OMEGA = OM ELSE INFO = 1 RETURN END IF END IF ITNUM = ITNUM + 1 GO TO 10 C END WHILE 10 END IF C IF ( BETA .GT. TAU*MAX( TOL1, LOW ) ) THEN C C Failed to meet bounds within MAXIT iterations. C INFO = 1 RETURN END IF C C Set optimal real workspace dimension (complex workspace is already C set by MB03NY). C DWORK(1) = LBEST C RETURN C *** Last line of AB13FD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB3LZP.f0000644000000000000000000000013215012430707016244 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB3LZP.f0000644000175000017500000010360515012430707017445 0ustar00lilgelilge00000000000000 SUBROUTINE MB3LZP( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG, $ LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA, $ IWORK, DWORK, LDWORK, ZWORK, LZWORK, BWORK, $ INFO ) C C PURPOSE C C To compute the eigenvalues of a complex N-by-N skew-Hamiltonian/ C Hamiltonian pencil aS - bH, with C C ( A D ) ( B F ) C S = ( ) and H = ( ). (1) C ( E A' ) ( G -B' ) C C The structured Schur form of the embedded real skew-Hamiltonian/ C skew-Hamiltonian pencil aB_S - bB_T, defined as C C ( Re(A) -Im(A) | Re(D) -Im(D) ) C ( | ) C ( Im(A) Re(A) | Im(D) Re(D) ) C ( | ) C B_S = (-----------------+-----------------) , and C ( | ) C ( Re(E) -Im(E) | Re(A') Im(A') ) C ( | ) C ( Im(E) Re(E) | -Im(A') Re(A') ) C (2) C ( -Im(B) -Re(B) | -Im(F) -Re(F) ) C ( | ) C ( Re(B) -Im(B) | Re(F) -Im(F) ) C ( | ) C B_T = (-----------------+-----------------) , T = i*H, C ( | ) C ( -Im(G) -Re(G) | -Im(B') Re(B') ) C ( | ) C ( Re(G) -Im(G) | -Re(B') -Im(B') ) C C is determined and used to compute the eigenvalues. The notation M' C denotes the conjugate transpose of the matrix M. Optionally, C if COMPQ = 'C', an orthonormal basis of the right deflating C subspace of the pencil aS - bH, corresponding to the eigenvalues C with strictly negative real part, is computed. Namely, after C transforming aB_S - bB_H by unitary matrices, we have C C ( BA BD ) ( BB BF ) C B_Sout = ( ) and B_Hout = ( ), (3) C ( 0 BA' ) ( 0 -BB' ) C C and the eigenvalues with strictly negative real part of the C complex pencil aB_Sout - bB_Hout are moved to the top. The C embedding doubles the multiplicities of the eigenvalues of the C pencil aS - bH. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether to compute the deflating subspace C corresponding to the eigenvalues of aS - bH with strictly C negative real part. C = 'N': do not compute the deflating subspace; compute the C eigenvalues only; C = 'C': compute the deflating subspace and store it in the C leading subarray of Q. C C ORTH CHARACTER*1 C If COMPQ = 'C', specifies the technique for computing an C orthonormal basis of the deflating subspace, as follows: C = 'P': QR factorization with column pivoting; C = 'S': singular value decomposition. C If COMPQ = 'N', the ORTH value is not used. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) COMPLEX*16 array, dimension (LDA, N) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix A. C On exit, if COMPQ = 'C', the leading N-by-N part of this C array contains the upper triangular matrix BA in (3) (see C also METHOD). The strictly lower triangular part is not C zeroed; it is preserved in the leading N/2-by-N/2 part. C If COMPQ = 'N', this array is unchanged on exit. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N). C C DE (input/output) COMPLEX*16 array, dimension (LDDE, N) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C skew-Hermitian matrix E, and the N/2-by-N/2 upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array must contain the upper triangular part of C the skew-Hermitian matrix D. C On exit, if COMPQ = 'C', the leading N-by-N part of this C array contains the skew-Hermitian matrix BD in (3) (see C also METHOD). The strictly lower triangular part of the C input matrix is preserved. C If COMPQ = 'N', this array is unchanged on exit. C C LDDE INTEGER C The leading dimension of the array DE. LDDE >= MAX(1, N). C C B (input/output) COMPLEX*16 array, dimension (LDB, N) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C On exit, if COMPQ = 'C', the leading N-by-N part of this C array contains the upper triangular matrix BB in (3) (see C also METHOD). The strictly lower triangular part is not C zeroed; the elements below the first subdiagonal of the C input matrix are preserved. C If COMPQ = 'N', this array is unchanged on exit. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N). C C FG (input/output) COMPLEX*16 array, dimension (LDFG, N) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C Hermitian matrix G, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C Hermitian matrix F. C On exit, if COMPQ = 'C', the leading N-by-N part of this C array contains the Hermitian matrix BF in (3) (see also C METHOD). The strictly lower triangular part of the input C matrix is preserved. The diagonal elements might have tiny C imaginary parts. C If COMPQ = 'N', this array is unchanged on exit. C C LDFG INTEGER C The leading dimension of the array FG. LDFG >= MAX(1, N). C C NEIG (output) INTEGER C If COMPQ = 'C', the number of eigenvalues in aS - bH with C strictly negative real part. C C Q (output) COMPLEX*16 array, dimension (LDQ, 2*N) C On exit, if COMPQ = 'C', the leading N-by-NEIG part of C this array contains an orthonormal basis of the right C deflating subspace corresponding to the eigenvalues of the C pencil aS - bH with strictly negative real part. C The remaining entries are meaningless. C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, 2*N), if COMPQ = 'C'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C C Workspace C C IWORK INTEGER array, dimension (N+1) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -20, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= MAX( 4*N*N + 2*N + MAX(3,N) ), if COMPQ = 'N'; C LDWORK >= MAX( 1, 11*N*N + 2*N ), if COMPQ = 'C'. C For good performance LDWORK should be generally 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 ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal LZWORK. C On exit, if INFO = -22, ZWORK(1) returns the minimum value C of LZWORK. C C LZWORK INTEGER C The dimension of the array ZWORK. C LZWORK >= 1, if COMPQ = 'N'; C LZWORK >= 8*N + 4, if COMPQ = 'C'. C For good performance LZWORK should be generally larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK C is issued by XERBLA. C C BWORK LOGICAL array, dimension (LBWORK) C LBWORK >= 0, if COMPQ = 'N'; C LBWORK >= N - 1, if COMPQ = 'C'. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: QZ iteration failed in the SLICOT Library routine C MB04FP (QZ iteration did not converge or computation C of the shifts failed); C = 2: QZ iteration failed in the LAPACK routine ZHGEQZ when C trying to triangularize the 2-by-2 blocks; C = 3: the singular value decomposition failed in the LAPACK C routine ZGESVD (for ORTH = 'S'); C = 4: warning: the pencil is numerically singular. C C METHOD C C First, T = i*H is set. Then, the embeddings, B_S and B_T, of the C matrices S and T, are determined and, subsequently, the SLICOT C Library routine MB04FP is applied to compute the structured Schur C form, i.e., the factorizations C C ~ ( S11 S12 ) C B_S = J Q' J' B_S Q = ( ) and C ( 0 S11' ) C C ~ ( T11 T12 ) ( 0 I ) C B_T = J Q' J' B_T Q = ( ), with J = ( ), C ( 0 T11' ) ( -I 0 ) C C where Q is real orthogonal, S11 is upper triangular, and T11 is C upper quasi-triangular. C C Second, the SLICOT Library routine MB3JZP is applied, to compute a C ~ C unitary matrix Q, such that C C ~ ~ C ~ ~ ~ ( S11 S12 ) C J Q' J' B_S Q = ( ~ ) =: B_Sout, C ( 0 S11' ) C C ~ ~ ~ ( H11 H12 ) C J Q' J'(-i*B_T) Q = ( ) =: B_Hout, C ( 0 -H11' ) C ~ ~ ~ C with S11, H11 upper triangular, and such that Spec_-(B_S, -i*B_T) C is contained in the spectrum of the 2*NEIG-by-2*NEIG leading C ~ C principal subpencil aS11 - bH11. C C Finally, the right deflating subspace is computed. C See also page 22 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C complex floating point operations. C C FURTHER COMMENTS C C This routine does not perform any scaling of the matrices. Scaling C might sometimes be useful, and it should be done externally. C For large values of N, the routine applies the transformations on C panels of columns. The user may specify in INFO the desired number C of columns. If on entry INFO <= 0, then the routine estimates a C suitable value of this number. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2011. C M. Voigt, Max Planck Institute for Dynamics of Complex Technical C Systems, Dec. 2011. C C REVISIONS C C V. Sima, Mar. 2011, Aug. 2011, Nov. 2011, July 2013, June 2014, C Nov. 2014, Jan. 2017, Apr. 2020. C M. Voigt, Jan. 2012, July 2013. C C KEYWORDS C C Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian C pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) COMPLEX*16 CZERO, CONE, CIMAG PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ), $ CIMAG = ( 0.0D+0, 1.0D+0 ) ) C C .. Scalar Arguments .. CHARACTER COMPQ, ORTH INTEGER INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK, $ LZWORK, N, NEIG C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), DWORK( * ) COMPLEX*16 A( LDA, * ), B( LDB, * ), DE( LDDE, * ), $ FG( LDFG, * ), Q( LDQ, * ), ZWORK( * ) C C .. Local Scalars .. LOGICAL LCMPQ, LQUERY, QR, QRP, SVD CHARACTER*14 CMPQ, JOB INTEGER I, I1, IA, IB, IDE, IEV, IFG, IQ, IQ2, IQB, IS, $ ITAU, IW, IW1, IWA, IWRK, J, J1, J2, JM1, JP2, $ M, MINDB, MINDW, MINZW, N2, NB, NBL, NC, NN, $ OPTDW, OPTZW DOUBLE PRECISION EPS, NRMB, TOL COMPLEX*16 TMP C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C C .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DSCAL, MB3JZP, MB04FP, XERBLA, $ ZAXPY, ZGEMM, ZGEQP3, ZGEQRF, ZGESVD, ZHGEQZ, $ ZLACPY, ZSCAL, ZUNGQR C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, $ SQRT C C .. Executable Statements .. C C Decode the input arguments. C Using ORTH = 'Q' is not safe, but sometimes gives better results. C NBL = INFO M = N/2 NN = N*N N2 = 2*N NEIG = 0 LCMPQ = LSAME( COMPQ, 'C' ) IF( LCMPQ ) THEN QR = LSAME( ORTH, 'Q' ) QRP = LSAME( ORTH, 'P' ) SVD = LSAME( ORTH, 'S' ) ELSE QR = .FALSE. QRP = .FALSE. SVD = .FALSE. END IF C IF( N.EQ.0 ) THEN MINDW = 1 MINZW = 1 ELSE IF( LCMPQ ) THEN MINDB = 8*NN + N2 MINDW = 11*NN + N2 MINZW = 8*N + 4 ELSE MINDB = 4*NN + N2 MINDW = 4*NN + N2 + MAX( 3, N ) MINZW = 1 END IF LQUERY = LDWORK.EQ.-1 .OR. LZWORK.EQ.-1 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( LCMPQ ) THEN IF( .NOT.( QR .OR. QRP .OR. SVD ) ) $ INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDDE.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDFG.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N2 ) ) THEN INFO = -14 ELSE IF( .NOT. LQUERY ) THEN IF( LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -20 ELSE IF( LZWORK.LT.MINZW ) THEN ZWORK( 1 ) = MINZW INFO = -22 END IF END IF C IF( INFO.NE.0) THEN CALL XERBLA( 'MB3LZP', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN C C Compute optimal workspace. C IF( LCMPQ ) THEN JOB = 'Triangularize' CMPQ = 'Initialize' CALL ZGEQRF( N, N, Q, LDQ, ZWORK, ZWORK, -1, INFO ) I = INT( ZWORK( 1 ) ) NB = MAX( I/N, 2 ) ELSE JOB = 'Eigenvalues' CMPQ = 'No Computation' END IF C IF( LQUERY ) THEN CALL MB04FP( JOB, CMPQ, N2, DWORK, N, DWORK, N, DWORK, N, $ DWORK, N, DWORK, N2, ALPHAI, ALPHAR, BETA, $ IWORK, DWORK, -1, INFO ) OPTDW = MAX( MINDW, MINDB + INT( DWORK( 1 ) ) ) C IF( LCMPQ ) THEN IF( SVD ) THEN CALL ZGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, ZWORK, 1, $ ZWORK, 1, ZWORK, -1, DWORK, INFO ) J = INT( ZWORK( 1 ) ) ELSE IF( QR ) THEN J = M CALL ZGEQRF( N, J, Q, LDQ, ZWORK, ZWORK, -1, INFO ) ELSE J = N CALL ZGEQP3( N, J, Q, LDQ, IWORK, ZWORK, ZWORK, -1, $ DWORK, INFO ) END IF CALL ZUNGQR( N, J, J, Q, LDQ, ZWORK, ZWORK( 2 ), -1, $ INFO ) J = J + MAX( INT( ZWORK( 1 ) ), INT( ZWORK( 2 ) ) ) END IF OPTZW = MAX( MINZW, I, J ) ELSE OPTZW = MINZW END IF DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW RETURN ELSE OPTZW = MINZW END IF END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK( 1 ) = ONE ZWORK( 1 ) = CONE RETURN END IF C C Determine machine constants. C EPS = DLAMCH( 'Precision' ) TOL = SQRT( EPS ) C C Set up the embeddings of the matrices S and H. C C Set the pointers for the inputs and outputs of MB04FP. C Real workspace: need 4*N**2+2*N, if COMPQ = 'N'; C 8*N**2+2*N, if COMPQ = 'C'. C IQ = 1 IF( LCMPQ ) THEN IA = IQ + N2*N2 ELSE IA = 1 END IF C IDE = IA + NN IB = IDE + NN + N IFG = IB + NN IWRK = IFG + NN + N C C Build the embedding of A. C IW = IA IS = IW + N*M DO 30 J = 1, M IW1 = IW DO 10 I = 1, M DWORK( IW ) = DBLE( A( I, J ) ) IW = IW + 1 10 CONTINUE C DO 20 I = 1, M DWORK( IW ) = DIMAG( A( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 20 CONTINUE CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IS = IS + M 30 CONTINUE C C Build the embedding of D and E. C IW = IDE DO 60 J = 1, M + 1 DO 40 I = 1, M DWORK( IW ) = DBLE( DE( I, J ) ) IW = IW + 1 40 CONTINUE C IW = IW + J - 1 IS = IW DO 50 I = J, M DWORK( IW ) = DIMAG( DE( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 50 CONTINUE 60 CONTINUE C IW1 = IW I1 = IW DO 80 J = 2, M + 1 IS = I1 I1 = I1 + 1 DO 70 I = 1, J - 1 DWORK( IW ) = -DIMAG( DE( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 70 CONTINUE IW = IW + N - J + 1 80 CONTINUE CALL DLACPY( 'Full', M, M+1, DWORK( IDE ), N, DWORK( IW1-M ), N ) C C Build the embedding of B. C IW = IB IS = IW + N*M DO 110 J = 1, M IW1 = IW DO 90 I = 1, M DWORK( IW ) = -DIMAG( B( I, J ) ) IW = IW + 1 90 CONTINUE C DO 100 I = 1, M DWORK( IW ) = DBLE( B( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 100 CONTINUE CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IS = IS + M 110 CONTINUE C C Build the embedding of F and G. C IW = IFG DO 140 J = 1, M + 1 DO 120 I = 1, M DWORK( IW ) = -DIMAG( FG( I, J ) ) IW = IW + 1 120 CONTINUE C IW = IW + J - 1 IS = IW DO 130 I = J, M DWORK( IW ) = DBLE( FG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 130 CONTINUE 140 CONTINUE C IW1 = IW I1 = IW DO 160 J = 2, M + 1 IS = I1 I1 = I1 + 1 DO 150 I = 1, J - 1 DWORK( IW ) = -DBLE( FG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N 150 CONTINUE IW = IW + N - J + 1 160 CONTINUE CALL DLACPY( 'Full', M, M+1, DWORK( IFG ), N, DWORK( IW1-M ), N ) C C STEP 1: Apply MB04FP to transform the extended pencil to real C skew-Hamiltonian/skew-Hamiltonian Schur form. C C Real workspace: C need 4*N*N + 2*N + MAX( 3, N ), if COMPQ = 'N'; C 8*N*N + 2*N + 3*N*N, if COMPQ = 'C'. C prefer larger. C INFO = NBL CALL MB04FP( JOB, CMPQ, N2, DWORK( IA ), N, DWORK( IDE ), N, $ DWORK( IB ), N, DWORK( IFG ), N, DWORK( IQ ), N2, $ ALPHAI, ALPHAR, BETA, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) IF( INFO.EQ.2 ) THEN IWA = 4 ELSE IF( INFO.GT.0 ) THEN RETURN ELSE IWA = 0 END IF OPTDW = MAX( MINDW, MINDB + INT( DWORK( IWRK ) ) ) C C Scale the eigenvalues. C CALL DSCAL( N, -ONE, ALPHAI, 1 ) C C Return if only the eigenvalues are desired. C IF( .NOT.LCMPQ ) THEN DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW INFO = IWA RETURN END IF C C Convert the results to complex datatype. D and F start in the C first column of DE and FG, respectively. C IW = IA DO 180 J = 1, N DO 170 I = 1, J A( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 170 CONTINUE IF( J.GE.M .AND. J.LT.N ) $ A( J+1, J ) = CZERO IW = IW + N - J 180 CONTINUE C IW = IDE + N DO 200 J = 1, N DO 190 I = 1, J - 1 DE( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 190 CONTINUE DE( J, J ) = CZERO IF( J.GE.M .AND. J.LT.N ) $ DE( J+1, J ) = CZERO IW = IW + N - J + 1 200 CONTINUE C IW = IB DO 220 J = 1, N DO 210 I = 1, MIN( J + 1, N ) B( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 210 CONTINUE IW = IW + N - J - 1 220 CONTINUE C IW = IFG + N DO 240 J = 1, N DO 230 I = 1, J - 1 FG( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 230 CONTINUE FG( J, J ) = CZERO IF( J.GE.M .AND. J.LT.N ) $ FG( J+1, J ) = CZERO IW = IW + N - J + 1 240 CONTINUE C IW = IQ DO 260 J = 1, N2 DO 250 I = 1, N2 Q( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 250 CONTINUE 260 CONTINUE C C Triangularize the 2-by-2 diagonal blocks in B using the complex C version of the QZ algorithm. C C Set up pointers on the outputs of ZHGEQZ. C A block algorithm is used for large N. C IQ2 = 1 IEV = 5 IQ = 9 IWRK = IQ + 4*( N - 1 ) C J = 1 J1 = 1 J2 = MIN( N, J1 + NB - 1 ) C WHILE( J.LT.N ) DO 270 CONTINUE IF( J.LT.N ) THEN NRMB = ABS( B( J, J ) ) + ABS( B( J+1, J+1 ) ) IF( ABS( B( J+1, J ) ).GT.NRMB*EPS ) THEN C C Triangularization step. C Workspace: need 8*N + 4. C NC = MAX( J2-J-1, 0 ) JM1 = MAX( J-1, 1 ) JP2 = MIN( J+2, N ) TMP = A( J+1, J ) A( J+1, J ) = CZERO CALL ZHGEQZ( 'Schur Form', 'Initialize', 'Initialize', 2, 1, $ 2, B( J, J ), LDB, A( J, J ), LDA, $ ZWORK( IEV ), ZWORK( IEV+2 ), ZWORK( IQ ), 2, $ ZWORK( IQ2 ), 2, ZWORK( IWRK ), LZWORK-IWRK+1, $ DWORK, INFO ) A( J+1, J ) = TMP IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF C C Update A. C CALL ZGEMM( 'No Transpose', 'No Transpose', J-1, 2, 2, $ CONE, A( 1, J ), LDA, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), JM1 ) CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, A( 1, J ), $ LDA ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, NC, $ 2, CONE, ZWORK( IQ ), 2, A( J, JP2 ), LDA, $ CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, A( J, JP2 ), $ LDA ) C C Update DE. C TMP = DE( J+1, J ) DE( J+1, J ) = -DE( J, J+1 ) CALL ZGEMM( 'No Transpose', 'No Transpose', J+1, 2, 2, $ CONE, DE( 1, J ), LDDE, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), J+1 ) CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, DE( 1, J ), $ LDDE ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ J2-J+1, 2, CONE, ZWORK( IQ ), 2, DE( J, J ), $ LDDE, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2, $ DE( J, J ), LDDE ) DE( J+1, J ) = TMP C C Update B. C CALL ZGEMM( 'No Transpose', 'No Transpose', J-1, 2, 2, $ CONE, B( 1, J ), LDB, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), JM1 ) CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, B( 1, J ), $ LDB ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, NC, $ 2, CONE, ZWORK( IQ ), 2, B( J, JP2 ), LDB, $ CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, B( J, JP2 ), $ LDB ) C C Update FG. C TMP = FG( J+1, J ) FG( J+1, J ) = -FG( J, J+1 ) CALL ZGEMM( 'No Transpose', 'No Transpose', J+1, 2, 2, $ CONE, FG( 1, J ), LDFG, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), J+1 ) CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, FG( 1, J ), $ LDFG ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ J2-J+1, 2, CONE, ZWORK( IQ ), 2, FG( J, J ), $ LDFG, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2, $ FG( J, J ), LDFG ) FG( J+1, J ) = TMP C C Update Q. C CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, CONE, $ Q( 1, J ), LDQ, ZWORK( IQ2 ), 2, CZERO, $ ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, Q( 1, J ), $ LDQ ) CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, CONE, $ Q( 1, N+J ), LDQ, ZWORK( IQ ), 2, CZERO, $ ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, Q( 1, N+J ), $ LDQ ) C BWORK( J ) = .TRUE. J = J + 2 IQ = IQ + 4 ELSE BWORK( J ) = .FALSE. B( J+1, J ) = CZERO J = J + 1 END IF C IF( J.GE.J2 ) THEN J1 = J2 + 1 J2 = MIN( N, J1 + NB - 1 ) NC = J2 - J1 + 1 C C Update the columns J1 to J2 of A, DE, B, and FG for previous C transformations. C I = 1 IQB = 9 C WHILE( I.LT.J ) DO 280 CONTINUE IF( I.LT.J ) THEN IF( BWORK( I ) ) THEN CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, A( I, J1 ), $ LDA, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ A( I, J1 ), LDA ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, $ DE( I, J1 ), LDDE, CZERO, ZWORK( IWRK ), $ 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ DE( I, J1 ), LDDE ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, B( I, J1 ), $ LDB, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ B( I, J1 ), LDB ) C CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IQB ), 2, $ FG( I, J1 ), LDFG, CZERO, ZWORK( IWRK ), $ 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ FG( I, J1 ), LDFG ) IQB = IQB + 4 C I = I + 2 ELSE I = I + 1 END IF GO TO 280 END IF C END WHILE 280 END IF GO TO 270 END IF C END WHILE 270 C C Scale B and FG by -i. C DO 290 I = 1, N CALL ZSCAL( I, -CIMAG, B( 1, I ), 1 ) 290 CONTINUE C DO 300 I = 1, N CALL ZSCAL( I, -CIMAG, FG( 1, I ), 1 ) 300 CONTINUE C C STEP 2: Apply MB3JZP to reorder the eigenvalues with strictly C negative real part to the top. C CMPQ = 'Update' INFO = NBL CALL MB3JZP( CMPQ, N2, A, LDA, DE, LDDE, B, LDB, FG, LDFG, Q, LDQ, $ NEIG, TOL, DWORK, ZWORK, INFO ) C IF( QR ) $ NEIG = NEIG/2 ITAU = 1 IWRK = NEIG + 1 C C STEP 3: Compute the right deflating subspace corresponding to C the eigenvalues with strictly negative real part. C IF( NEIG.LE.M ) THEN DO 310 I = 1, NEIG CALL ZAXPY( M, CIMAG, Q( M+1, I ), 1, Q( 1, I ), 1 ) 310 CONTINUE CALL ZLACPY( 'Full', M, NEIG, Q( N+1, 1 ), LDQ, Q( M+1, 1 ), $ LDQ ) DO 320 I = 1, NEIG CALL ZAXPY( M, CIMAG, Q( M+N+1, I ), 1, Q( M+1, I ), 1 ) 320 CONTINUE ELSE DO 330 I = 1, M CALL ZAXPY( M, CIMAG, Q( M+1, I ), 1, Q( 1, I ), 1 ) 330 CONTINUE CALL ZLACPY( 'Full', M, M, Q( N+1, 1 ), LDQ, Q( M+1, 1 ), LDQ ) DO 340 I = 1, M CALL ZAXPY( M, CIMAG, Q( M+N+1, I ), 1, Q( M+1, I ), 1 ) 340 CONTINUE C DO 350 I = 1, NEIG - M CALL ZAXPY( M, CIMAG, Q( M+1, M+I ), 1, Q( 1, M+I ), 1 ) 350 CONTINUE CALL ZLACPY( 'Full', M, NEIG-M, Q( N+1, M+1 ), LDQ, $ Q( M+1, M+1 ), LDQ ) DO 360 I = 1, NEIG - M CALL ZAXPY( M, CIMAG, Q( M+N+1, M+I ), 1, Q( M+1, M+I ), 1 ) 360 CONTINUE END IF C C Orthogonalize the basis given in Q(1:n,1:neig). C IF( SVD ) THEN C C Workspace: need 3*N; C prefer larger. C Real workspace: need 6*N. C CALL ZGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK, $ ZWORK, 1, ZWORK, 1, ZWORK, LZWORK, $ DWORK( IWRK ), INFO ) IF( INFO.GT.0 ) THEN INFO = 3 RETURN END IF OPTZW = MAX( OPTZW, INT( ZWORK( 1 ) ) ) NEIG = NEIG/2 C ELSE IF( QR ) THEN C C Workspace: need N; C prefer M+M*NB, where NB is the optimal C blocksize. C CALL ZGEQRF( N, NEIG, Q, LDQ, ZWORK( ITAU ), ZWORK( IWRK ), $ LZWORK-IWRK+1, INFO ) OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 ) ELSE C C Workspace: need 2*N+1; C prefer N+(N+1)*NB. C Real workspace: need 2*N. C DO 370 J = 1, NEIG IWORK( J ) = 0 370 CONTINUE CALL ZGEQP3( N, NEIG, Q, LDQ, IWORK, ZWORK, ZWORK( IWRK ), $ LZWORK-IWRK+1, DWORK, INFO ) OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 ) END IF C C Workspace: need 2*N; C prefer N+N*NB. C CALL ZUNGQR( N, NEIG, NEIG, Q, LDQ, ZWORK( ITAU ), $ ZWORK( IWRK ), LZWORK-IWRK+1, INFO ) OPTZW = MAX( OPTZW, INT( ZWORK( IWRK ) ) + IWRK - 1 ) IF( QRP ) $ NEIG = NEIG/2 END IF C DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW INFO = IWA RETURN C *** Last line of MB3LZP *** END control-4.1.2/src/slicot/src/PaxHeaders/MB4DBZ.f0000644000000000000000000000013015012430707016215 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB4DBZ.f0000644000175000017500000001430215012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE MB4DBZ( JOB, SGN, N, ILO, LSCALE, RSCALE, M, V1, LDV1, $ V2, LDV2, INFO ) C C PURPOSE C C To apply from the left the inverse of a balancing transformation, C computed by the SLICOT Library routine MB4DPZ, to the complex C matrix C C [ V1 ] C [ ], C [ sgn*V2 ] C C where sgn is either +1 or -1. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the type of inverse transformation required: C = 'N': do nothing, return immediately; C = 'P': do inverse transformation for permutation only; C = 'S': do inverse transformation for scaling only; C = 'B': do inverse transformations for both permutation C and scaling. C JOB must be the same as the argument JOB supplied to C MB4DPZ. C C SGN CHARACTER*1 C Specifies the sign to use for V2: C = 'P': sgn = +1; C = 'N': sgn = -1. C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrices V1 and V2. N >= 0. C C ILO (input) INTEGER C The integer ILO determined by MB4DPZ. C 1 <= ILO <= N+1. C C LSCALE (input) DOUBLE PRECISION array, dimension (N) C Details of the permutation and scaling factors applied C from the left, as returned by MB4DPZ. C C RSCALE (input) DOUBLE PRECISION array, dimension (N) C Details of the permutation and scaling factors applied C from the right, as returned by MB4DPZ. C C M (input) INTEGER C The number of columns of the matrices V1 and V2. M >= 0. C C V1 (input/output) COMPLEX*16 array, dimension (LDV1,M) C On entry, the leading N-by-M part of this array must C contain the matrix V1. C On exit, the leading N-by-M part of this array is C overwritten by the updated matrix V1 of the transformed C matrix. C C LDV1 INTEGER C The leading dimension of the array V1. LDV1 >= max(1,N). C C V2 (input/output) COMPLEX*16 array, dimension (LDV2,M) C On entry, the leading N-by-M part of this array must C contain the matrix V2. C On exit, the leading N-by-M part of this array is C overwritten by the updated matrix V2 of the transformed C matrix. C C LDV2 INTEGER C The leading dimension of the array V2. LDV2 >= max(1,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 REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C [2] Benner, P. C Symplectic balancing of Hamiltonian matrices. C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2001. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2015. C C REVISIONS C C V. Sima, Jan. 2016. C C KEYWORDS C C Balancing, Hamiltonian matrix, skew-Hamiltonian matrix, C symplectic equivalence transformation. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D0, 0.0D0 ) ) C .. Scalar Arguments .. CHARACTER JOB, SGN INTEGER ILO, INFO, LDV1, LDV2, M, N C .. Array Arguments .. DOUBLE PRECISION LSCALE(*), RSCALE(*) COMPLEX*16 V1(LDV1,*), V2(LDV2,*) C .. Local Scalars .. LOGICAL LPERM, LSCAL, LSGN, SYSW INTEGER I, K C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA, ZDRSCL, ZSCAL, ZSWAP C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) LSGN = LSAME( SGN, 'N' ) IF ( .NOT.LPERM .AND. .NOT.LSCAL $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN INFO = -1 ELSE IF ( .NOT.LSGN .AND. .NOT.LSAME( SGN, 'P' ) ) THEN INFO = -2 ELSE IF ( N.LT.0 ) THEN INFO = -3 ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN INFO = -4 ELSE IF ( M.LT.0 ) THEN INFO = -7 ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN INFO = -11 END IF C C Return if there were illegal values. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB4DBZ', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 .OR. LSAME( JOB, 'N' ) ) $ RETURN C C Inverse scaling. C IF ( LSCAL ) THEN DO 10 I = ILO, N CALL ZDRSCL( M, LSCALE(I), V1(I,1), LDV1 ) 10 CONTINUE DO 20 I = ILO, N CALL ZDRSCL( M, RSCALE(I), V2(I,1), LDV2 ) 20 CONTINUE END IF C C Inverse permutation. C IF ( LPERM ) THEN DO 30 I = ILO-1, 1, -1 K = LSCALE(I) SYSW = K.GT.N IF ( SYSW ) $ K = K - N C IF ( K.NE.I ) THEN C C Exchange rows k <-> i. C CALL ZSWAP( M, V1(I,1), LDV1, V1(K,1), LDV1 ) CALL ZSWAP( M, V2(I,1), LDV2, V2(K,1), LDV2 ) END IF C IF ( SYSW ) THEN C C Exchange V1(k,:) <-> V2(k,:). C CALL ZSWAP( M, V1(K,1), LDV1, V2(K,1), LDV2 ) C IF ( LSGN ) THEN CALL ZSCAL( M, -ONE, V1(K,1), LDV1 ) ELSE CALL ZSCAL( M, -ONE, V2(K,1), LDV2 ) END IF END IF 30 CONTINUE END IF C RETURN C *** Last line of MB4DBZ *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09ED.f0000644000000000000000000000013215012430707016141 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09ED.f0000644000175000017500000004275715012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE AB09ED( DICO, EQUIL, ORDSEL, N, M, P, NR, ALPHA, $ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1, $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for an original C state-space representation (A,B,C,D) by using the optimal C Hankel-norm approximation method in conjunction with square-root C balancing for the ALPHA-stable part of the system. 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 EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of C the resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. For a system with NU ALPHA-unstable C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), C NR is set as follows: if ORDSEL = 'F', NR is equal to C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the C multiplicity of the Hankel singular value HSV(NR-NU+1), C NR is the desired order on entry, and NMIN is the order C of a minimal realization of the ALPHA-stable part of the C given system; NMIN is determined as the number of Hankel C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where C EPS is the machine precision (see LAPACK Library Routine C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the C ALPHA-stable part of the given system (computed in C HSV(1)); C if ORDSEL = 'A', NR is the sum of NU and the number of C Hankel singular values greater than C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). C C ALPHA (input) DOUBLE PRECISION C Specifies the ALPHA-stability boundary for the eigenvalues C of the state dynamics matrix A. For a continuous-time C system (DICO = 'C'), ALPHA <= 0 is the boundary value for C the real parts of eigenvalues, while for a discrete-time C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the C boundary value for the moduli of eigenvalues. C The ALPHA-stability domain does not include the boundary. 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, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the C reduced order system in a real Schur form. C The resulting A has a block-diagonal form with two blocks. C For a system with NU ALPHA-unstable eigenvalues and C NS ALPHA-stable eigenvalues (NU+NS = N), the leading C NU-by-NU block contains the unreduced part of A C corresponding to ALPHA-unstable eigenvalues. C The trailing (NR+NS-N)-by-(NR+NS-N) block contains C the reduced part of A corresponding to ALPHA-stable C eigenvalues. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C NS (output) INTEGER C The dimension of the ALPHA-stable subsystem. C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, the leading NS elements of HSV contain the C Hankel singular values of the ALPHA-stable part of the C original system ordered decreasingly. C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the C Hankel-norm of the ALPHA-stable part of the given system C (computed in HSV(1)). C If TOL1 <= 0 on entry, the used default value is C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of C ALPHA-stable eigenvalues of A and EPS is the machine C precision (see LAPACK Library Routine DLAMCH). C This value is appropriate to compute a minimal realization C of the ALPHA-stable part. C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the ALPHA-stable part of the given system. C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). C This value is used by default if TOL2 <= 0 on entry. C If TOL2 > 0, then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = MAX(1,M), if DICO = 'C'; C LIWORK = MAX(1,N,M), if DICO = 'D'. C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of C the computed minimal realization. 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( LDW1, LDW2 ), where C LDW1 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + C MAX( 3*M+1, MIN(N,M)+P ). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than NSMIN, the sum of the order of the C ALPHA-unstable part and the order of a minimal C realization of the ALPHA-stable part of the given C system. In this case, the resulting NR is set equal C to NSMIN. C = 2: with ORDSEL = 'F', the selected order NR is less C than the order of the ALPHA-unstable part of the C given system. In this case NR is set equal to the C order of the ALPHA-unstable part. 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 computation of the ordered real Schur form of A C failed; C = 2: the separation of the ALPHA-stable/unstable diagonal C blocks failed because of very close eigenvalues; C = 3: the computed ALPHA-stable part is just stable, C having stable eigenvalues very near to the imaginary C axis (if DICO = 'C') or to the unit circle C (if DICO = 'D'); C = 4: the computation of Hankel singular values failed; C = 5: the computation of stable projection in the C Hankel-norm approximation algorithm failed; C = 6: the order of computed stable projection in the C Hankel-norm approximation algorithm differs C from the order of Hankel-norm approximation. C C METHOD C C Let be the following linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09ED determines for C the given system (1), the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t) (2) C C such that C C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], C C where G and Gr are transfer-function matrices of the systems C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the C infinity-norm of G. C C The following procedure is used to reduce a given G: C C 1) Decompose additively G as C C G = G1 + G2 C C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and C G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles. C C 2) Determine G1r, a reduced order approximation of the C ALPHA-stable part G1. C C 3) Assemble the reduced model Gr as C C Gr = G1r + G2. C C To reduce the ALPHA-stable part G1, the optimal Hankel-norm C approximation method of [1], based on the square-root C balancing projection formulas of [2], is employed. C C REFERENCES C C [1] Glover, K. C All optimal Hankel norm approximation of linear C multivariable systems and their L-infinity error bounds. C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. C C [2] Tombs M.S. and Postlethwaite I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C NUMERICAL ASPECTS C C The implemented methods rely on an accuracy enhancing square-root C technique. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C July 1998. C Based on the RASP routines SADSDC and OHNAP. C C REVISIONS C C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. C March 26, 2005, V. Sima, Research Institute for Informatics. C C KEYWORDS C C Balancing, Hankel-norm approximation, model reduction, C multivariable system, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION C100, ONE, ZERO PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, $ M, N, NR, NS, P DOUBLE PRECISION ALPHA, TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), HSV(*) C .. Local Scalars .. LOGICAL DISCR, FIXORD INTEGER IERR, IWARNL, KI, KL, KU, KW, NRA, NU, NU1 DOUBLE PRECISION ALPWRK, MAXRED, WRKOPT C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB09CX, TB01ID, TB01KD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) FIXORD = LSAME( ORDSEL, 'F' ) C C Check the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -7 ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN INFO = -8 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -14 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -16 ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN INFO = -20 ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + $ ( N*( N + 1 ) )/2, $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN INFO = -23 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09ED', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 NS = 0 IWORK(1) = 0 DWORK(1) = ONE RETURN END IF C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C Workspace: N. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Correct the value of ALPHA to ensure stability. C ALPWRK = ALPHA IF( DISCR ) THEN IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) ELSE IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) END IF C C Allocate working storage. C KU = 1 KL = KU + N*N KI = KL + N KW = KI + N C C Reduce A to a block-diagonal real Schur form, with the C ALPHA-unstable part in the leading diagonal position, using a C non-orthogonal similarity transformation A <- inv(T)*A*T and C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. C C Workspace needed: N*(N+2); C Additional workspace: need 3*N; C prefer larger. C CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) C IF( IERR.NE.0 ) THEN IF( IERR.NE.3 ) THEN INFO = 1 ELSE INFO = 2 END IF RETURN END IF C WRKOPT = DWORK(KW) + DBLE( KW-1 ) C C Determine a reduced order approximation of the ALPHA-stable part. C C Workspace: need MAX( LDW1, LDW2 ), C LDW1 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + C MAX( 3*M+1, MIN(N,M)+P ); C prefer larger. C IWARNL = 0 NS = N - NU IF( FIXORD ) THEN NRA = MAX( 0, NR-NU ) IF( NR.LT.NU ) $ IWARNL = 2 ELSE NRA = 0 END IF C C Finish if only unstable part is present. C IF( NS.EQ.0 ) THEN NR = NU DWORK(1) = WRKOPT RETURN END IF C NU1 = NU + 1 CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) C IWARN = MAX( IWARN, IWARNL ) IF( IERR.NE.0 ) THEN INFO = IERR + 2 RETURN END IF C NR = NRA + NU C DWORK(1) = MAX( WRKOPT, DWORK(1) ) C RETURN C *** Last line of AB09ED *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BD.f0000644000000000000000000000013015012430707016145 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/NF01BD.f0000644000175000017500000003132715012430707017351 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BD( CJTE, NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, $ E, J, LDJ, JTE, DWORK, LDWORK, INFO ) C C PURPOSE C C To calculate the Jacobian dy/dX of the Wiener system C C x(t+1) = A*x(t) + B*u(t) C z(t) = C*x(t) + D*u(t), C C y(t,i) = sum( ws(k, i)*f(w(k, i)*z(t) + b(k,i)) ) + b(k+1,i), C C where t = 1, 2, ..., NSMP, C i = 1, 2, ..., L, C k = 1, 2, ..., NN. C C NN is arbitrary eligible and has to be provided in IPAR(2), and C X = ( wb(1), ..., wb(L), theta ) is described below. C C Denoting y(j) = y(1:NSMP,j), the Jacobian J has the block form C C dy(1)/dwb(1) 0 ..... 0 dy(1)/dtheta C 0 dy(2)/dwb(2) ..... 0 dy(2)/dtheta C ..... ..... ..... ..... ..... C 0 ..... 0 dy(L)/dwb(L) dy(L)/dtheta C C but it will be returned without the zero blocks, in the form C C dy(1)/dwb(1) dy(1)/dtheta C ... C dy(L)/dwb(L) dy(L)/dtheta. C C dy(i)/dwb(i) depends on f and is calculated by the routine NF01BY; C dy(i)/dtheta is computed by a forward-difference approximation. C C ARGUMENTS C C Mode Parameters C C CJTE CHARACTER*1 C Specifies whether the matrix-vector product J'*e should be C computed or not, as follows: C = 'C' : compute J'*e; C = 'N' : do not compute J'*e. C C Input/Output Parameters C C NSMP (input) INTEGER C The number of training samples. NSMP >= 0. C C M (input) INTEGER C The length of each input sample. M >= 0. C C L (input) INTEGER C The length of each output sample. L >= 0. C C IPAR (input/output) INTEGER array, dimension (LIPAR) C On entry, the first entries of this array must contain C the integer parameters needed; specifically, C IPAR(1) must contain the order of the linear part, N; C actually, N = abs(IPAR(1)), since setting C IPAR(1) < 0 has a special meaning (see below); C IPAR(2) must contain the number of neurons for the C nonlinear part, NN, NN >= 0. C On exit, if IPAR(1) < 0 on entry, then no computations are C performed, except the needed tests on input parameters, C but the following values are returned: C IPAR(1) contains the length of the array J, LJ; C LDJ contains the leading dimension of array J. C Otherwise, IPAR(1) and LDJ are unchanged on exit. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 2. C C X (input) DOUBLE PRECISION array, dimension (LX) C The leading LPAR entries of this array must contain the C set of system parameters, where C LPAR = (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M. C X has the form (wb(1), ..., wb(L), theta), where the C vectors wb(i) have the structure C (w(1,1), ..., w(1,L), ..., w(NN,1), ..., w(NN,L), C ws(1), ..., ws(NN), b(1), ..., b(NN+1) ), C and the vector theta represents the matrices A, B, C, D C and x(1), and it can be retrieved from these matrices C by SLICOT Library routine TB01VD and retranslated by C TB01VY. C C LX (input) INTEGER C The length of X. C LX >= (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M. C C U (input) DOUBLE PRECISION array, dimension (LDU, M) C The leading NSMP-by-M part of this array must contain the C set of input samples, C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,NSMP). C C E (input) DOUBLE PRECISION array, dimension (NSMP*L) C If CJTE = 'C', this array must contain a vector e, which C will be premultiplied with J', e = vec( Y - y ), where C Y is set of output samples, and vec denotes the C concatenation of the columns of a matrix. C If CJTE = 'N', this array is not referenced. C C J (output) DOUBLE PRECISION array, dimension (LDJ, *) C The leading NSMP*L-by-NCOLJ part of this array contains C the Jacobian of the error function stored in a compressed C form, as described above, where C NCOLJ = NN*(L + 2) + 1 + N*(M + L + 1) + L*M. C C LDJ INTEGER C The leading dimension of array J. LDJ >= MAX(1,NSMP*L). C Note that LDJ is an input parameter, except for C IPAR(1) < 0 on entry, when it is an output parameter. C C JTE (output) DOUBLE PRECISION array, dimension (LPAR) C If CJTE = 'C', this array contains the matrix-vector C product J'*e. C If CJTE = 'N', this array is not referenced. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + C MAX( N*(N + L), N + M + L ) ) C if M > 0; C LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + C MAX( N*(N + L), L ) ), if M = 0. C A larger value of LDWORK could improve the efficiency. 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 BLAS routines are used for the matrix-vector multiplications, and C the SLICOT Library routine TB01VY is called for the conversion of C the output normal form parameters to an LTI-system; the routine C NF01AD is then used for the simulation of the system with given C parameters, and the routine NF01BY is called for the (analytically C performed) calculation of the parts referring to the parameters C of the static nonlinearity. C C CONTRIBUTORS C C A. Riedel, R. Schneider, Chemnitz University of Technology, C Mar. 2001, during a stay at University of Twente, NL. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, C Dec. 2001. C C KEYWORDS C C Jacobian matrix, nonlinear system, output normal form, simulation, C state-space representation, Wiener system. C C ****************************************************************** C C .. Parameters .. C .. EPSFCN is related to the error in computing the functions .. C .. For EPSFCN = 0.0D0, the square root of the machine precision C .. is used for finite difference approximation of the derivatives. DOUBLE PRECISION ZERO, ONE, EPSFCN PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, EPSFCN = 0.0D0 ) C .. Scalar Arguments .. CHARACTER CJTE INTEGER INFO, L, LDJ, LDU, LDWORK, LX, LIPAR, M, NSMP C .. Array Arguments .. INTEGER IPAR(*) DOUBLE PRECISION DWORK(*), E(*), J(LDJ, *), JTE(*), U(LDU,*), $ X(*) C .. Local Scalars .. LOGICAL WJTE DOUBLE PRECISION EPS, H, PARSAV INTEGER AC, BD, BSN, I, IX, IY, JW, K, KCOL, LDAC, LPAR, $ LTHS, N, NN, NSML, NTHS, Z C .. External Functions .. DOUBLE PRECISION DLAMCH LOGICAL LSAME EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMV, NF01AD, NF01AY, NF01BY, TB01VY, $ TF01MX, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT C .. C .. Executable Statements .. C N = IPAR(1) NN = IPAR(2) BSN = NN*( L + 2 ) + 1 NSML = NSMP*L NTHS = BSN*L LTHS = N*( M + L + 1 ) + L*M LPAR = NTHS + LTHS WJTE = LSAME( CJTE, 'C' ) C C Check the scalar input parameters. C INFO = 0 IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN INFO = -1 ELSEIF ( NSMP.LT.0 ) THEN INFO = -2 ELSEIF ( M.LT.0 ) THEN INFO = -3 ELSEIF ( L.LT.0 ) THEN INFO = -4 ELSEIF ( NN.LT.0 ) THEN INFO = -5 ELSEIF ( LIPAR.LT.2 ) THEN INFO = -6 ELSEIF ( IPAR(1).LT.0 ) THEN IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01BD', -INFO ) ELSE IPAR(1) = NSML*( ABS( N )*( M + L + 1 ) + L*M + BSN ) LDJ = MAX( 1, NSML ) ENDIF RETURN ELSEIF ( LX.LT.LPAR ) THEN INFO = -8 ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN INFO = -10 ELSEIF ( LDJ.LT.MAX( 1, NSML ) ) THEN INFO = -13 ELSE LDAC = N + L IF ( M.GT.0 ) THEN JW = MAX( N*LDAC, N + M + L ) ELSE JW = MAX( N*LDAC, L ) END IF IF ( LDWORK.LT.2*NSML + MAX( 2*NN, LDAC*( N + M ) + 2*N + JW )) $ INFO = -16 ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01BD', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( MIN( NSMP, L ).EQ.0 ) THEN IF ( WJTE .AND. LPAR.GE.1 ) THEN JTE(1) = ZERO CALL DCOPY( LPAR, JTE(1), 0, JTE(1), 1 ) END IF RETURN END IF C C Compute the output of the linear part. C Workspace: need 2*NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1). C (2*NSMP*L locations are reserved for computing two times the C output of the linear part.) C IY = 1 Z = IY + NSML AC = Z + NSML BD = AC + LDAC*N IX = BD + LDAC*M JW = IX + N C CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC, $ DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), $ LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO ) C C Workspace: need 2*NSMP*L + (N + L)*(N + M) + 3*N + M + L, C if M > 0; C 2*NSMP*L + (N + L)*N + 2*N + L, if M = 0; C prefer larger. C CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX), $ DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO ) C C Fill the blocks dy(i)/dwb(i) and the corresponding parts of JTE, C if needed. C JW = AC IF ( WJTE ) THEN C DO 10 I = 0, L - 1 CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1), $ BSN, DWORK(Z), NSMP, E(I*NSMP+1), $ J(I*NSMP+1,1), LDJ, JTE(I*BSN+1), DWORK(JW), $ LDWORK-JW+1, INFO ) 10 CONTINUE C ELSE C DO 20 I = 0, L - 1 CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1), $ BSN, DWORK(Z), NSMP, DWORK, J(I*NSMP+1,1), LDJ, $ DWORK, DWORK(JW), LDWORK-JW+1, INFO ) 20 CONTINUE C END IF C C Compute the output of the system with unchanged parameters. C Workspace: need 2*NSMP*L + 2*NN; C prefer larger. C CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z), $ NSMP, DWORK(IY), NSMP, DWORK(JW), LDWORK-JW+1, $ INFO ) C C Compute dy/dtheta numerically by forward-difference approximation. C Workspace: need 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + C MAX( N*(N + L), N + M + L ) ), C if M > 0; C 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + C MAX( N*(N + L), L ) ), if M = 0; C prefer larger. C JW = Z EPS = SQRT( MAX( EPSFCN, DLAMCH( 'Epsilon' ) ) ) C DO 40 K = NTHS + 1, LPAR KCOL = K - NTHS + BSN PARSAV = X(K) IF ( PARSAV.EQ.ZERO ) THEN H = EPS ELSE H = EPS*ABS( PARSAV ) END IF X(K) = X(K) + H CALL NF01AD( NSMP, M, L, IPAR, LIPAR, X, LPAR, U, LDU, $ J(1,KCOL), NSMP, DWORK(JW), LDWORK-JW+1, $ INFO ) X(K) = PARSAV C DO 30 I = 1, NSML J(I,KCOL) = ( J(I,KCOL) - DWORK(I) ) / H 30 CONTINUE C 40 CONTINUE C IF ( WJTE ) THEN C C Compute the last part of J'e in JTE. C CALL DGEMV( 'Transpose', NSML, LTHS, ONE, J(1,BSN+1), LDJ, E, $ 1, ZERO, JTE(NTHS+1), 1 ) END IF C RETURN C C *** Last line of NF01BD *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01MY.f0000644000000000000000000000013215012430707016176 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/IB01MY.f0000644000175000017500000012160415012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, $ Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, $ INFO ) C C PURPOSE C C To construct an upper triangular factor R of the concatenated C block Hankel matrices using input-output data, via a fast QR C algorithm based on displacement rank. The input-output data can, C optionally, be processed sequentially. C C ARGUMENTS C C Mode Parameters C C METH CHARACTER*1 C Specifies the subspace identification method to be used, C as follows: C = 'M': MOESP algorithm with past inputs and outputs; C = 'N': N4SID algorithm. C C BATCH CHARACTER*1 C Specifies whether or not sequential data processing is to C be used, and, for sequential processing, whether or not C the current data block is the first block, an intermediate C block, or the last block, as follows: C = 'F': the first block in sequential data processing; C = 'I': an intermediate block in sequential data C processing; C = 'L': the last block in sequential data processing; C = 'O': one block only (non-sequential data processing). C NOTE that when 100 cycles of sequential data processing C are completed for BATCH = 'I', a warning is C issued, to prevent for an infinite loop. C C CONCT CHARACTER*1 C Specifies whether or not the successive data blocks in C sequential data processing belong to a single experiment, C as follows: C = 'C': the current data block is a continuation of the C previous data block and/or it will be continued C by the next data block; C = 'N': there is no connection between the current data C block and the previous and/or the next ones. C This parameter is not used if BATCH = 'O'. C C Input/Output Parameters C C NOBR (input) INTEGER C The number of block rows, s, in the input and output C block Hankel matrices to be processed. NOBR > 0. C (In the MOESP theory, NOBR should be larger than n, the C estimated dimension of state vector.) C C M (input) INTEGER C The number of system inputs. M >= 0. C When M = 0, no system inputs are processed. C C L (input) INTEGER C The number of system outputs. L > 0. C C NSMP (input) INTEGER C The number of rows of matrices U and Y (number of C samples, t). (When sequential data processing is used, C NSMP is the number of samples of the current data C block.) C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential C processing; C NSMP >= 2*NOBR, for sequential processing. C The total number of samples when calling the routine with C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. C The NSMP argument may vary from a cycle to another in C sequential data processing, but NOBR, M, and L should C be kept constant. For efficiency, it is advisable to use C NSMP as large as possible. C C U (input) DOUBLE PRECISION array, dimension (LDU,M) C The leading NSMP-by-M part of this array must contain the C t-by-m input-data sequence matrix U, C U = [u_1 u_2 ... u_m]. Column j of U contains the C NSMP values of the j-th input component for consecutive C time increments. C If M = 0, this array is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= NSMP, if M > 0; C LDU >= 1, if M = 0. C C Y (input) DOUBLE PRECISION array, dimension (LDY,L) C The leading NSMP-by-L part of this array must contain the C t-by-l output-data sequence matrix Y, C Y = [y_1 y_2 ... y_l]. Column j of Y contains the C NSMP values of the j-th output component for consecutive C time increments. C C LDY INTEGER C The leading dimension of the array Y. LDY >= NSMP. C C R (output) DOUBLE PRECISION array, dimension C ( LDR,2*(M+L)*NOBR ) C If INFO = 0 and BATCH = 'L' or 'O', the leading C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this C array contains the upper triangular factor R from the C QR factorization of the concatenated block Hankel C matrices. C C LDR INTEGER C The leading dimension of the array R. C LDR >= 2*(M+L)*NOBR. C C Workspace C C IWORK INTEGER array, dimension MAX(3,M+L) C On entry with BATCH = 'I' or BATCH = 'L', IWORK(1:3) C must contain the values of ICYCLE, MAXWRK, and NSMPSM C set by the previous call of this routine. C On exit with BATCH = 'F' or BATCH = 'I', IWORK(1:3) C contains the values of ICYCLE, MAXWRK, and NSMPSM to be C used by the next call of the routine. C ICYCLE counts the cycles for BATCH = 'I'. C MAXWRK stores the current optimal workspace. C NSMPSM sums up the NSMP values for BATCH <> 'O'. C The first three elements of IWORK should be preserved C during successive calls of the routine with BATCH = 'F' C or BATCH = 'I', till the final call with BATCH = 'L'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -16, DWORK(1) returns the minimum C value of LDWORK. C The first (M+L)*2*NOBR*(M+L+c) elements of DWORK should C be preserved during successive calls of the routine C with BATCH = 'F' or 'I', till the final call with C BATCH = 'L', where C c = 1, if the successive data blocks do not belong to a C single experiment (CONCT = 'N'); C c = 2, if the successive data blocks belong to a single C experiment (CONCT = 'C'). C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= (M+L)*2*NOBR*(M+L+3), C if BATCH <> 'O' and CONCT = 'C'; C LDWORK >= (M+L)*2*NOBR*(M+L+1), C if BATCH = 'F' or 'I' and CONCT = 'N'; C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, C if BATCH = 'L' and CONCT = 'N', C or BATCH = 'O'. 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. The workspace query should be done C for BATCH = 'L' or BATCH = 'O'. To get it in advance, use C BATCH = 'O'. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: the number of 100 cycles in sequential data C processing has been exhausted without signaling C that the last block of data was get. 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 fast QR factorization algorithm failed. The C matrix H'*H is not (numerically) positive definite. C C METHOD C C Consider the t x 2(m+l)s matrix H of concatenated block Hankel C matrices C C H = [ Uf' Up' Y' ], for METH = 'M', C s+1,2s,t 1,s,t 1,2s,t C C H = [ U' Y' ], for METH = 'N', C 1,2s,t 1,2s,t C C where Up , Uf , U , and Y are block C 1,s,t s+1,2s,t 1,2s,t 1,2s,t C Hankel matrices defined in terms of the input and output data [3]. C The fast QR algorithm uses a factorization of H'*H which exploits C the block-Hankel structure, via a displacement rank technique [5]. C C REFERENCES C C [1] Verhaegen M., and Dewilde, P. C Subspace Model Identification. Part 1: The output-error C state-space model identification class of algorithms. C Int. J. Control, 56, pp. 1187-1210, 1992. C C [2] Verhaegen M. C Subspace Model Identification. Part 3: Analysis of the C ordinary output-error state-space model identification C algorithm. C Int. J. Control, 58, pp. 555-586, 1993. C C [3] Verhaegen M. C Identification of the deterministic part of MIMO state space C models given in innovations form from input-output data. C Automatica, Vol.30, No.1, pp.61-74, 1994. C C [4] Van Overschee, P., and De Moor, B. C N4SID: Subspace Algorithms for the Identification of C Combined Deterministic-Stochastic Systems. C Automatica, Vol.30, No.1, pp. 75-93, 1994. C C [5] Kressner, D., Mastronardi, N., Sima, V., Van Dooren, P., and C Van Huffel, S. C A Fast Algorithm for Subspace State-space System C Identification via Exploitation of the Displacement Structure. C J. Comput. Appl. Math., Vol.132, No.1, pp. 71-81, 2001. C C NUMERICAL ASPECTS C C The implemented method is reliable and efficient. Numerical C difficulties are possible when the matrix H'*H is nearly rank C defficient. The method cannot be used if the matrix H'*H is not C numerically positive definite. C 2 3 2 C The algorithm requires 0(2t(m+l) s)+0(4(m+l) s ) floating point C operations. C C CONTRIBUTORS C C V. Sima, Katholieke Universiteit Leuven, June 2000. C Partly based on Matlab codes developed by N. Mastronardi, C Katholieke Universiteit Leuven, February 2000. C C REVISIONS C C V. Sima, July 2000, August 2000, Feb. 2004, May 2009, May 2011, C May 2020. C C KEYWORDS C C Displacement rank, Hankel matrix, Householder transformation, C identification methods, multivariable systems. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER MAXCYC PARAMETER ( MAXCYC = 100 ) C .. Scalar Arguments .. INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, NOBR, $ NSMP CHARACTER BATCH, CONCT, METH C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION DWORK(*), R(LDR, *), U(LDU, *), Y(LDY, *) C .. Local Scalars .. DOUBLE PRECISION BETA, CS, SN, UPD, TAU INTEGER I, ICJ, ICOL, ICONN, ICYCLE, IERR, IMAX, ING, $ INGC, INGP, IPG, IPGC, IPY, IREV, ITAU, J, JD, $ JDS, JWORK, K, LDRWRK, LLNOBR, LNOBR, LNRG, $ MAXWRK, MINWRK, MMNOBR, MNOBR, MNRG, NOBR2, $ NOBR21, NR, NRG, NS, NSM, NSMPSM LOGICAL CONNEC, FIRST, INTERM, LAST, LQUERY, MOESP, $ N4SID, ONEBCH C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX EXTERNAL IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLARF, DLARFG, $ DLASET, DORMQR, DSCAL, DSWAP, DSYRK, MA02ED, $ MA02FD, MB04ID, MB04OD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, SQRT C .. C .. Executable Statements .. C C Decode the scalar input parameters. C MOESP = LSAME( METH, 'M' ) N4SID = LSAME( METH, 'N' ) ONEBCH = LSAME( BATCH, 'O' ) FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH INTERM = LSAME( BATCH, 'I' ) LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH IF( .NOT.ONEBCH ) THEN CONNEC = LSAME( CONCT, 'C' ) ELSE CONNEC = .FALSE. END IF MNOBR = M*NOBR LNOBR = L*NOBR MMNOBR = MNOBR + MNOBR LLNOBR = LNOBR + LNOBR NOBR2 = 2*NOBR NOBR21 = NOBR2 - 1 IWARN = 0 INFO = 0 IF( FIRST ) THEN ICYCLE = 1 MAXWRK = 1 NSMPSM = 0 ELSE IF( .NOT.ONEBCH ) THEN ICYCLE = IWORK(1) MAXWRK = IWORK(2) NSMPSM = IWORK(3) END IF NSMPSM = NSMPSM + NSMP NR = MMNOBR + LLNOBR C C Check the scalar input parameters. C IF( .NOT.( MOESP .OR. N4SID ) ) THEN INFO = -1 ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN INFO = -2 ELSE IF( .NOT. ONEBCH ) THEN IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) $ INFO = -3 END IF IF( INFO.EQ.0 ) THEN IF( NOBR.LE.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( L.LE.0 ) THEN INFO = -6 ELSE IF( NSMP.LT.NOBR2 .OR. $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN INFO = -7 ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN INFO = -9 ELSE IF( LDY.LT.NSMP ) THEN INFO = -11 ELSE IF( LDR.LT.NR ) THEN INFO = -13 ELSE C C Compute workspace. C NRG is the number of positive (or negative) generators. C NRG = M + L + 1 IF ( .NOT.ONEBCH .AND. CONNEC ) THEN MINWRK = NR*( NRG + 2 ) ELSE IF ( FIRST .OR. INTERM ) THEN MINWRK = NR*NRG ELSE MINWRK = 2*NR*NRG + NR END IF MAXWRK = MAX( MINWRK, MAXWRK ) LQUERY = LDWORK.EQ.-1 C IF ( LQUERY ) THEN I = NRG*2*NR IF ( M.GT.0 ) THEN I = I + M CALL DGEQRF( NRG, M, DWORK, NRG, DWORK, DWORK, -1, $ IERR ) MAXWRK = MAX( MAXWRK, I + INT( DWORK(1) ) ) CALL DORMQR( 'Left', 'Transpose', NRG, NR-M, M, DWORK, $ NRG, DWORK, DWORK, NRG, DWORK, -1, IERR ) MAXWRK = MAX( MAXWRK, I + INT( DWORK(1) ) ) I = I - M END IF I = I + L CALL DGEQRF( NRG, L, DWORK, NRG, DWORK, DWORK, -1, IERR ) MAXWRK = MAX( MAXWRK, I + INT( DWORK(1) ) ) CALL DORMQR( 'Left', 'Transpose', NRG, LLNOBR-L, L, $ DWORK, NRG, DWORK, DWORK, NRG, DWORK, -1, $ IERR ) MAXWRK = MAX( MAXWRK, I + INT( DWORK(1) ) ) IF ( MOESP .AND. M.GT.0 ) THEN CALL MB04ID( MMNOBR, MMNOBR, MNOBR-1, LLNOBR, R, LDR, $ R, LDR, DWORK, DWORK, -1, IERR ) MAXWRK = MAX( MAXWRK, MMNOBR + INT( DWORK(1) ) ) END IF ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -16 END IF END IF END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN NSMPSM = 0 IF( .NOT.ONEBCH ) THEN IWORK(1) = 1 IWORK(2) = MAXWRK IWORK(3) = NSMPSM END IF IF ( INFO.EQ.-16 ) $ DWORK(1) = MINWRK CALL XERBLA( 'IB01MY', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = MAXWRK RETURN END IF C C Compute the R factor from a fast QR factorization of the C matrix H, a concatenation of two block Hankel matrices. C Specifically, a displacement rank technique is applied to C the block Toeplitz matrix, G = (P*H)'*(P*H), where P is a C 2-by-2 block diagonal matrix, having as diagonal blocks identity C matrices with columns taken in the reverse order. C The technique builds and processes the generators of G. The C matrices G and G1 = H'*H have the same R factor. C C Set the parameters for constructing the correlations of the C current block. C NSM is the number of processed samples in U and Y, t - 2s. C IPG and ING are pointers to the "positive" and "negative" C generators, stored row-wise in the workspace. All "positive" C generators are stored before any "negative" generators. C If BATCH <> 'O' and CONCT = 'C', the "connection" elements of C two successive batches are stored in the same workspace as the C "negative" generators (which will be computed later on). C IPY is a pointer to the Y part of the "positive" generators. C LDRWRK is used as a leading dimension for the workspace part used C to store the "connection" elements. C NS = NSMP - NOBR21 NSM = NS - 1 MNRG = M*NRG LNRG = L*NRG C LDRWRK = 2*NOBR2 IF( FIRST ) THEN UPD = ZERO ELSE UPD = ONE END IF DUM(1) = ZERO C IPG = 1 IPY = IPG + M ING = IPG + NRG*NR ICONN = ING C IF( .NOT.FIRST .AND. CONNEC ) THEN C C Restore the saved (M+L)*2*NOBR "connection" elements of C U and Y into their appropriate position in sequential C processing. The process is performed column-wise, in C reverse order, first for Y and then for U. C ICONN is a pointer to the first saved "connection" element. C Workspace: need (M+L)*2*NOBR*(M+L+3). C IREV = ICONN + NR ICOL = ICONN + 2*NR C DO 10 I = 2, M + L IREV = IREV - NOBR2 ICOL = ICOL - LDRWRK CALL DCOPY( NOBR2, DWORK(IREV), 1, DWORK(ICOL), 1 ) 10 CONTINUE C IF ( M.GT.0 ) $ CALL DLACPY( 'Full', NOBR2, M, U, LDU, DWORK(ICONN+NOBR2), $ LDRWRK ) CALL DLACPY( 'Full', NOBR2, L, Y, LDY, $ DWORK(ICONN+LDRWRK*M+NOBR2), LDRWRK ) END IF C IF ( M.GT.0 ) THEN C C Let Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' + C ... + u_(i+NSM-1)*u_(j+NSM-1)', C where u_i' is the i-th row of U, j = 1 : 2s, i = 1 : j, C NSM = NSMP - 2s, and Guu0(i,j) is a zero matrix for C BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed C till the current block for BATCH = 'I' or 'L'. The matrix C Guu(i,j) is m-by-m, and Guu(j,j) is symmetric. The C submatrices of the first block-row, Guu(1,j), are needed only. C C Compute/update Guu(1,1). C IF( .NOT.FIRST .AND. CONNEC ) $ CALL DSYRK( 'Upper', 'Transpose', M, NOBR2, ONE, $ DWORK(ICONN), LDRWRK, UPD, DWORK(IPG), NRG ) CALL DSYRK( 'Upper', 'Transpose', M, NSM, ONE, U, LDU, UPD, $ DWORK(IPG), NRG ) CALL MA02ED( 'Upper', M, DWORK(IPG), NRG ) C JD = 1 C IF( FIRST .OR. .NOT.CONNEC ) THEN C DO 20 J = 2, NOBR2 JD = JD + M C C Compute/update Guu(1,j). C CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, $ U, LDU, U(J,1), LDU, UPD, $ DWORK(IPG+(JD-1)*NRG), NRG ) 20 CONTINUE C ELSE C DO 30 J = 2, NOBR2 JD = JD + M C C Compute/update Guu(1,j) for sequential processing C with connected blocks. C CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR2, $ ONE, DWORK(ICONN), LDRWRK, DWORK(ICONN+J-1), $ LDRWRK, UPD, DWORK(IPG+(JD-1)*NRG), NRG ) CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, $ U, LDU, U(J,1), LDU, ONE, $ DWORK(IPG+(JD-1)*NRG), NRG ) 30 CONTINUE C END IF C C Let Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' + C ... + u_(i+NSM-1)*y_(j+NSM-1)', C where u_i' is the i-th row of U, y_j' is the j-th row C of Y, j = 1 : 2s, i = 1 : 2s, NSM = NSMP - 2s, and C Guy0(i,j) is a zero matrix for BATCH = 'O' or 'F', and it C is the matrix Guy(i,j) computed till the current block for C BATCH = 'I' or 'L'. Guy(i,j) is m-by-L. The submatrices C of the first block-row, Guy(1,j), as well as the transposes C of the submatrices of the first block-column, i.e., Gyu(1,j), C are needed only. C JD = MMNOBR + 1 C IF( FIRST .OR. .NOT.CONNEC ) THEN C DO 40 J = 1, NOBR2 C C Compute/update Guy(1,j). C CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, $ U, LDU, Y(J,1), LDY, UPD, $ DWORK(IPG+(JD-1)*NRG), NRG ) JD = JD + L 40 CONTINUE C ELSE C DO 50 J = 1, NOBR2 C C Compute/update Guy(1,j) for sequential processing C with connected blocks. C CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR2, $ ONE, DWORK(ICONN), LDRWRK, $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, $ DWORK(IPG+(JD-1)*NRG), NRG ) CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, $ U, LDU, Y(J,1), LDY, ONE, $ DWORK(IPG+(JD-1)*NRG), NRG ) JD = JD + L 50 CONTINUE C END IF C C Now, the first M "positive" generators have been built. C Transpose Guy(1,1) in the first block of the Y part of the C "positive" generators. C DO 60 J = 1, L CALL DCOPY( M, DWORK(IPG+(MMNOBR+J-1)*NRG), 1, $ DWORK(IPY+J-1), NRG ) 60 CONTINUE C JD = 1 C IF( FIRST .OR. .NOT.CONNEC ) THEN C DO 70 J = 2, NOBR2 JD = JD + M C C Compute/update Gyu(1,j). C CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, $ Y, LDY, U(J,1), LDU, UPD, $ DWORK(IPY+(JD-1)*NRG), NRG ) 70 CONTINUE C ELSE C DO 80 J = 2, NOBR2 JD = JD + M C C Compute/update Gyu(1,j) for sequential processing C with connected blocks. C CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NOBR2, $ ONE, DWORK(ICONN+LDRWRK*M), LDRWRK, $ DWORK(ICONN+J-1), LDRWRK, UPD, $ DWORK(IPY+(JD-1)*NRG), NRG ) CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, $ Y, LDY, U(J,1), LDU, ONE, $ DWORK(IPY+(JD-1)*NRG), NRG ) 80 CONTINUE C END IF C END IF C C Let Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... + C y_(i+NSM-1)*y_(i+NSM-1)', C where y_i' is the i-th row of Y, j = 1 : 2s, i = 1 : j, C NSM = NSMP - 2s, and Gyy0(i,j) is a zero matrix for C BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till C the current block for BATCH = 'I' or 'L'. Gyy(i,j) is L-by-L, C and Gyy(j,j) is symmetric. The submatrices of the first C block-row, Gyy(1,j), are needed only. C JD = MMNOBR + 1 C C Compute/update Gyy(1,1). C IF( .NOT.FIRST .AND. CONNEC ) $ CALL DSYRK( 'Upper', 'Transpose', L, NOBR2, ONE, $ DWORK(ICONN+LDRWRK*M), LDRWRK, UPD, $ DWORK(IPY+MMNOBR*NRG), NRG ) CALL DSYRK( 'Upper', 'Transpose', L, NSM, ONE, Y, LDY, UPD, $ DWORK(IPY+MMNOBR*NRG), NRG ) CALL MA02ED( 'Upper', L, DWORK(IPY+MMNOBR*NRG), NRG ) C IF( FIRST .OR. .NOT.CONNEC ) THEN C DO 90 J = 2, NOBR2 JD = JD + L C C Compute/update Gyy(1,j). C CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, $ LDY, Y(J,1), LDY, UPD, DWORK(IPY+(JD-1)*NRG), $ NRG ) 90 CONTINUE C ELSE C DO 100 J = 2, NOBR2 JD = JD + L C C Compute/update Gyy(1,j) for sequential processing with C connected blocks. C CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR2, ONE, $ DWORK(ICONN+LDRWRK*M), LDRWRK, $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, $ DWORK(IPY+(JD-1)*NRG), NRG ) CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, $ LDY, Y(J,1), LDY, ONE, DWORK(IPY+(JD-1)*NRG), $ NRG ) 100 CONTINUE C END IF C IF ( .NOT.LAST ) THEN IF ( FIRST ) THEN C C For sequential processing, save the first 2*NOBR-1 rows of C the first block of U and Y in the appropriate C (M+L)*(2*NOBR-1) locations of DWORK starting at (1+M)*NRG. C These will be used to construct the last negative generator. C JD = NRG IF ( M.GT.0 ) THEN CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) C DO 110 J = 1, NOBR21 JD = JD + MNRG CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) 110 CONTINUE C JD = JD + MNRG END IF CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) C DO 120 J = 1, NOBR21 JD = JD + LNRG CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) 120 CONTINUE C END IF C IF ( CONNEC ) THEN C C For sequential processing with connected data blocks, C save the remaining ("connection") elements of U and Y C in (M+L)*2*NOBR locations of DWORK starting at ICONN. C IF ( M.GT.0 ) $ CALL DLACPY( 'Full', NOBR2, M, U(NS,1), LDU, $ DWORK(ICONN), NOBR2 ) CALL DLACPY( 'Full', NOBR2, L, Y(NS,1), LDY, $ DWORK(ICONN+MMNOBR), NOBR2 ) END IF C C Return to get new data. C ICYCLE = ICYCLE + 1 IWORK(1) = ICYCLE IWORK(2) = MAXWRK IWORK(3) = NSMPSM IF ( ICYCLE.GT.MAXCYC ) $ IWARN = 1 RETURN END IF C IF ( LAST ) THEN C C Try to compute the R factor. C C Scale the first M+L positive generators and set the first C M+L negative generators. C Workspace: need (M+L)*4*NOBR*(M+L+1)+M+L. C JWORK = NRG*2*NR + 1 CALL DCOPY( M, DWORK(IPG), NRG+1, DWORK(JWORK), 1 ) CALL DCOPY( L, DWORK(IPY+MMNOBR*NRG), NRG+1, DWORK(JWORK+M), $ 1 ) C DO 130 I = 1, M + L IWORK(I) = IDAMAX( M+L, DWORK(JWORK), 1 ) DWORK(JWORK+IWORK(I)-1) = ZERO 130 CONTINUE C DO 150 I = 1, M + L IMAX = IWORK(I) IF ( IMAX.LE.M ) THEN ICOL = IMAX ELSE ICOL = MMNOBR - M + IMAX END IF BETA = SQRT( ABS( DWORK(IPG+IMAX-1+(ICOL-1)*NRG) ) ) IF ( BETA.EQ.ZERO ) THEN C C Error exit. C INFO = 1 RETURN END IF CALL DSCAL( NR, ONE / BETA, DWORK(IPG+IMAX-1), NRG ) CALL DCOPY( NR, DWORK(IPG+IMAX-1), NRG, DWORK(ING+IMAX-1), $ NRG ) DWORK(IPG+IMAX-1+(ICOL-1)*NRG) = BETA DWORK(ING+IMAX-1+(ICOL-1)*NRG) = ZERO C DO 140 J = I + 1, M + L DWORK(IPG+IWORK(J)-1+(ICOL-1)*NRG) = ZERO 140 CONTINUE C 150 CONTINUE C C Compute the last two generators. C IF ( .NOT.FIRST ) THEN C C For sequential processing, move the stored last negative C generator. C CALL DCOPY( NR, DWORK(NRG), NRG, DWORK(ING+NRG-1), NRG ) END IF C JD = NRG IF ( M.GT.0 ) THEN C DO 160 J = NS, NSMP CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) JD = JD + MNRG 160 CONTINUE C END IF C DO 170 J = NS, NSMP CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) JD = JD + LNRG 170 CONTINUE C IF ( FIRST ) THEN IF ( M.GT.0 ) THEN CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) C DO 180 J = 1, NOBR21 JD = JD + MNRG CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) 180 CONTINUE C JD = JD + MNRG END IF CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) C DO 190 J = 1, NOBR21 JD = JD + LNRG CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) 190 CONTINUE C END IF C ITAU = JWORK IPGC = IPG + MMNOBR*NRG C IF ( M.GT.0 ) THEN C C Process the input part of the generators. C JWORK = ITAU + M C C Reduce the first M columns of the matrix G1 of positive C generators to an upper triangular form. C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*M; C prefer (M+L)*4*NOBR*(M+L+1)+M+M*NB. C INGC = ING CALL DGEQRF( NRG, M, DWORK(IPG), NRG, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Workspace: need (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR; C prefer (M+L)*4*NOBR*(M+L+1)+M+ C ((M+L)*2*NOBR-M)*NB. C CALL DORMQR( 'Left', 'Transpose', NRG, NR-M, M, DWORK(IPG), $ NRG, DWORK(ITAU), DWORK(IPG+MNRG), NRG, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Annihilate, column by column, the first M columns of the C matrix G2 of negative generators, using Householder C transformations and modified hyperbolic plane rotations. C In the DLARF calls, ITAU is a pointer to the workspace C array. C DO 210 J = 1, M CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) BETA = DWORK(INGC) DWORK(INGC) = ONE INGP = INGC + NRG CALL DLARF( 'Left', NRG, NR-J, DWORK(INGC), 1, TAU, $ DWORK(INGP), NRG, DWORK(ITAU) ) DWORK(INGC) = BETA C C Compute the coefficients of the modified hyperbolic C rotation. C CALL MA02FD( DWORK(IPG+(J-1)*(NRG+1)), DWORK(INGC), CS, $ SN, IERR ) IF( IERR.NE.0 ) THEN C C Error return: the matrix H'*H is not (numerically) C positive definite. C INFO = 1 RETURN END IF C DO 200 I = J*NRG, ( NR - 1 )*NRG, NRG DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - $ SN * DWORK(ING+I) ) / CS DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + $ CS * DWORK(ING+I) 200 CONTINUE C INGC = INGP 210 CONTINUE C C Save one block row of R, and shift the generators for the C calculation of the following row. C CALL DLACPY( 'Upper', M, NR, DWORK(IPG), NRG, R, LDR ) C DO 220 I = ( MMNOBR - M )*NRG, MNRG, -MNRG CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, $ DWORK(IPG+I), NRG ) 220 CONTINUE C DO 230 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, $ DWORK(IPG+I), NRG ) 230 CONTINUE C CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) C C Update the input part of generators using Schur algorithm. C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*(M+L)-M. C JDS = MNRG ICOL = M C DO 280 K = 2, NOBR2 CALL MB04OD( 'Full', M, NR-ICOL-M, L+1, DWORK(IPG+JDS), $ NRG, DWORK(IPY+JDS), NRG, $ DWORK(IPG+JDS+MNRG), NRG, $ DWORK(IPY+JDS+MNRG), NRG, DWORK(ITAU), $ DWORK(JWORK) ) C DO 250 J = 1, M ICJ = ICOL + J CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) BETA = DWORK(INGC) DWORK(INGC) = ONE INGP = INGC + NRG CALL DLARF( 'Left', NRG, NR-ICJ, DWORK(INGC), 1, TAU, $ DWORK(INGP), NRG, DWORK(ITAU) ) DWORK(INGC) = BETA C C Compute the coefficients of the modified hyperbolic C rotation. C CALL MA02FD( DWORK(IPG+J-1+(ICJ-1)*NRG), DWORK(INGC), $ CS, SN, IERR ) IF( IERR.NE.0 ) THEN C C Error return: the matrix H'*H is not (numerically) C positive definite. C INFO = 1 RETURN END IF C DO 240 I = ICJ*NRG, ( NR - 1 )*NRG, NRG DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - $ SN * DWORK(ING+I) ) / CS DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + $ CS * DWORK(ING+I) 240 CONTINUE C INGC = INGP 250 CONTINUE C C Save one block row of R, and shift the generators for the C calculation of the following row. C CALL DLACPY( 'Upper', M, NR-ICOL, DWORK(IPG+JDS), NRG, $ R(ICOL+1,ICOL+1), LDR ) ICOL = ICOL + M C DO 260 I = ( MMNOBR - M )*NRG, ICOL*NRG, -MNRG CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, $ DWORK(IPG+I), NRG ) 260 CONTINUE C DO 270 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, $ DWORK(IPG+I), NRG ) 270 CONTINUE C CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) JDS = JDS + MNRG 280 CONTINUE C END IF C C Process the output part of the generators. C JWORK = ITAU + L C C Reduce the first L columns of the submatrix C G1(1:M+L+1,2*M*NOBR+1:2*(M+L)*NOBR) to upper triangular form. C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*L; C prefer (M+L)*4*NOBR*(M+L+1)+L+L*NB. C INGC = ING + MMNOBR*NRG CALL DGEQRF( NRG, L, DWORK(IPGC), NRG, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Workspace: need (M+L)*4*NOBR*(M+L+1)+L*2*NOBR; C prefer (M+L)*4*NOBR*(M+L+1)+L+(L*2*NOBR-L)*NB. C CALL DORMQR( 'Left', 'Transpose', NRG, LLNOBR-L, L, $ DWORK(IPGC), NRG, DWORK(ITAU), DWORK(IPGC+LNRG), $ NRG, DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Annihilate, column by column, the first L columns of the C output part of the matrix G2 of negative generators, using C Householder transformations and modified hyperbolic rotations. C DO 300 J = 1, L CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) BETA = DWORK(INGC) DWORK(INGC) = ONE INGP = INGC + NRG CALL DLARF( 'Left', NRG, LLNOBR-J, DWORK(INGC), 1, TAU, $ DWORK(INGP), NRG, DWORK(ITAU) ) DWORK(INGC) = BETA C C Compute the coefficients of the modified hyperbolic C rotation. C CALL MA02FD( DWORK(IPGC+(J-1)*(NRG+1)), DWORK(INGC), CS, SN, $ IERR ) IF( IERR.NE.0 ) THEN C C Error return: the matrix H'*H is not (numerically) C positive definite. C INFO = 1 RETURN END IF C DO 290 I = ( J + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - $ SN * DWORK(ING+I) ) / CS DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + $ CS * DWORK(ING+I) 290 CONTINUE C INGC = INGP 300 CONTINUE C C Save one block row of R, and shift the generators for the C calculation of the following row. C CALL DLACPY( 'Upper', L, LLNOBR, DWORK(IPGC), NRG, $ R(MMNOBR+1,MMNOBR+1), LDR ) C DO 310 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, $ DWORK(IPG+I), NRG ) 310 CONTINUE C C Update the output part of generators using the Schur algorithm. C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*L-L. C JDS = LNRG ICOL = L C DO 350 K = 2, NOBR2 CALL MB04OD( 'Full', L, LLNOBR-ICOL-L, M+1, DWORK(IPGC+JDS), $ NRG, DWORK(IPGC+L+JDS), NRG, $ DWORK(IPGC+JDS+LNRG), NRG, $ DWORK(IPGC+L+JDS+LNRG), NRG, DWORK(ITAU), $ DWORK(JWORK) ) C DO 330 J = 1, L ICJ = ICOL + J CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) BETA = DWORK(INGC) DWORK(INGC) = ONE INGP = INGC + NRG CALL DLARF( 'Left', NRG, LLNOBR-ICJ, DWORK(INGC), 1, $ TAU, DWORK(INGP), NRG, DWORK(ITAU) ) DWORK(INGC) = BETA C C Compute the coefficients of the modified hyperbolic C rotation. C CALL MA02FD( DWORK(IPGC+J-1+(ICJ-1)*NRG), DWORK(INGC), $ CS, SN, IERR ) IF( IERR.NE.0 ) THEN C C Error return: the matrix H'*H is not (numerically) C positive definite. C INFO = 1 RETURN END IF C DO 320 I = ( ICJ + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - $ SN * DWORK(ING+I) ) / CS DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + $ CS * DWORK(ING+I) 320 CONTINUE C INGC = INGP 330 CONTINUE C C Save one block row of R, and shift the generators for the C calculation of the following row. C CALL DLACPY( 'Upper', L, LLNOBR-ICOL, DWORK(IPGC+JDS), NRG, $ R(MMNOBR+ICOL+1,MMNOBR+ICOL+1), LDR ) C DO 340 I = ( NR - L )*NRG, ( MMNOBR + ICOL )*NRG, -LNRG CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, $ DWORK(IPG+I), NRG ) 340 CONTINUE C ICOL = ICOL + L JDS = JDS + LNRG 350 CONTINUE C IF ( MOESP .AND. M.GT.0 ) THEN C C For the MOESP algorithm, interchange the past and future C input parts of the R factor, and compute the new R factor C using a specialized QR factorization. A tailored fast C QR factorization for the MOESP algorithm could be slightly C more efficient. C DO 360 J = 1, MNOBR CALL DSWAP( J, R(1,J), 1, R(1,MNOBR+J), 1 ) CALL DCOPY( MNOBR, R(J+1,MNOBR+J), 1, R(J+1,J), 1 ) CALL DCOPY( MMNOBR-J, DUM, 0, R(J+1,MNOBR+J), 1 ) 360 CONTINUE C C Triangularize the first two block columns (using structure), C and apply the transformation to the corresponding part of C the remaining block columns. C Workspace: need 2*(M+L)*NOBR. C ITAU = 1 JWORK = ITAU + MMNOBR CALL MB04ID( MMNOBR, MMNOBR, MNOBR-1, LLNOBR, R, LDR, $ R(1,MMNOBR+1), LDR, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) END IF END IF C NSMPSM = 0 ICYCLE = 1 C C Return optimal workspace in DWORK(1). C DWORK( 1 ) = MAXWRK MAXWRK = 1 IF( .NOT.ONEBCH ) THEN IWORK(1) = ICYCLE IWORK(2) = MAXWRK IWORK(3) = NSMPSM END IF RETURN C C *** Last line of IB01MY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04DD.f0000644000000000000000000000013215012430707016147 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04DD.f0000644000175000017500000003476515012430707017362 0ustar00lilgelilge00000000000000 SUBROUTINE MB04DD( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) C C PURPOSE C C To balance a real Hamiltonian matrix, C C [ A G ] C H = [ T ] , C [ Q -A ] C C where A is an N-by-N matrix and G, Q are N-by-N symmetric C matrices. This involves, first, permuting H by a symplectic C similarity transformation to isolate eigenvalues in the first C 1:ILO-1 elements on the diagonal of A; and second, applying a C diagonal similarity transformation to rows and columns C ILO:N, N+ILO:2*N to make the rows and columns as close in 1-norm C as possible. Both steps are optional. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the operations to be performed on H: C = 'N': none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N; C = 'P': permute only; C = 'S': scale only; C = 'B': both permute and scale. 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 part of this array must C contain the matrix A. C On exit, the leading N-by-N part of this array contains C the matrix A of the balanced Hamiltonian. In particular, C the strictly lower triangular part of the first ILO-1 C columns of A is zero. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input/output) DOUBLE PRECISION array, dimension C (LDQG,N+1) C On entry, the leading N-by-N+1 part of this array must C contain the lower triangular part of the matrix Q and C the upper triangular part of the matrix G. C On exit, the leading N-by-N+1 part of this array contains C the lower and upper triangular parts of the matrices Q and C G, respectively, of the balanced Hamiltonian. In C particular, the lower triangular part of the first ILO-1 C columns of QG is zero. C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C ILO (output) INTEGER C ILO-1 is the number of deflated eigenvalues in the C balanced Hamiltonian matrix. C C SCALE (output) DOUBLE PRECISION array of dimension (N) C Details of the permutations and scaling factors applied to C H. For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N, C then rows and columns P(j) and P(j)+N are interchanged C with rows and columns j and j+N, respectively. If C P(j) > N, then row and column P(j)-N are interchanged with C row and column j+N by a generalized symplectic C permutation. For j = ILO,...,N the j-th element of SCALE C contains the factor of the scaling applied to row and C column j. 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] Benner, P. C Symplectic balancing of Hamiltonian matrices. C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2001. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHABAL). C V. Sima, Mar. 2016. C C KEYWORDS C C Balancing, Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER ILO, INFO, LDA, LDQG, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), QG(LDQG,*), SCALE(*) C .. Local Scalars .. LOGICAL CONV, LPERM, LSCAL INTEGER I, IC, ILOOLD, J DOUBLE PRECISION C, F, GII, MAXC, MAXR, QII, R, SCLFAC, $ SFMAX1, SFMAX2, SFMIN1, SFMIN2, TEMP C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DASUM, DLAMCH EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) C IF ( .NOT.LPERM .AND. .NOT.LSCAL $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN INFO = -1 ELSE IF ( N.LT.0 ) THEN INFO = -2 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN INFO = -6 END IF C C Return if there were illegal values. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04DD', -INFO ) RETURN END IF C ILO = 1 C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN DO 10 I = 1, N SCALE(I) = ONE 10 CONTINUE RETURN END IF C C Permutations to isolate eigenvalues if possible. C IF ( LPERM ) THEN ILOOLD = 0 C WHILE ( ILO.NE.ILOOLD ) 20 IF ( ILO.NE.ILOOLD ) THEN ILOOLD = ILO C C Scan columns ILO .. N. C I = ILO C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) 30 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN DO 40 J = ILO, I-1 IF ( A(J,I).NE.ZERO ) THEN I = I + 1 GOTO 30 END IF 40 CONTINUE DO 50 J = I+1, N IF ( A(J,I).NE.ZERO ) THEN I = I + 1 GOTO 30 END IF 50 CONTINUE DO 60 J = ILO, I IF ( QG(I,J).NE.ZERO ) THEN I = I + 1 GOTO 30 END IF 60 CONTINUE DO 70 J = I+1, N IF ( QG(J,I).NE.ZERO ) THEN I = I + 1 GOTO 30 END IF 70 CONTINUE C C Exchange columns/rows ILO <-> I. C SCALE( ILO ) = DBLE( I ) IF ( ILO.NE.I ) THEN C CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) C CALL DSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) CALL DSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) CALL DSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) C CALL DSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) CALL DSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), $ LDQG ) CALL DSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), $ 1 ) END IF ILO = ILO + 1 END IF C END WHILE 30 C C Scan columns N+ILO .. 2*N. C I = ILO C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) 80 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN DO 90 J = ILO, I-1 IF ( A(I,J).NE.ZERO ) THEN I = I + 1 GOTO 80 END IF 90 CONTINUE DO 100 J = I+1, N IF ( A(I,J).NE.ZERO ) THEN I = I + 1 GOTO 80 END IF 100 CONTINUE DO 110 J = ILO, I IF ( QG(J,I+1).NE.ZERO ) THEN I = I + 1 GOTO 80 END IF 110 CONTINUE DO 120 J = I+1, N IF ( QG(I,J+1).NE.ZERO ) THEN I = I + 1 GOTO 80 END IF 120 CONTINUE SCALE( ILO ) = DBLE( N+I ) C C Exchange columns/rows I <-> I+N with a symplectic C generalized permutation. C CALL DSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG ) CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA ) CALL DSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 ) CALL DSCAL( N-I, -ONE, A(I,I+1), LDA ) CALL DSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 ) CALL DSCAL( I-1, -ONE, A(1,I), 1 ) CALL DSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG ) CALL DSCAL( N-I, -ONE, A(I+1,I), 1 ) A(I,I) = -A(I,I) TEMP = QG(I,I) QG(I,I) = -QG(I,I+1) QG(I,I+1) = -TEMP C C Exchange columns/rows ILO <-> I. C IF ( ILO.NE.I ) THEN C CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) C CALL DSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) CALL DSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) CALL DSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) C CALL DSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) CALL DSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), $ LDQG ) CALL DSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), $ 1 ) END IF ILO = ILO + 1 END IF C END WHILE 80 GOTO 20 END IF C END WHILE 20 END IF C DO 130 I = ILO, N SCALE(I) = ONE 130 CONTINUE C C Scale to reduce the 1-norm of the remaining blocks. C IF ( LSCAL ) THEN SCLFAC = DLAMCH( 'B' ) SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 C C Scale the rows and columns one at a time to minimize the C 1-norm of the remaining Hamiltonian submatrix. C Stop when the 1-norm is very roughly minimal. C 140 CONTINUE CONV = .TRUE. DO 170 I = ILO, N C C Compute 1-norm of row and column I without diagonal C elements. C R = DASUM( I-ILO, A(I,ILO), LDA ) + $ DASUM( N-I, A(I,I+1), LDA ) + $ DASUM( I-ILO, QG(ILO,I+1), 1 ) + $ DASUM( N-I, QG(I,I+2), LDQG ) C = DASUM( I-ILO, A(ILO,I), 1 ) + $ DASUM( N-I, A(I+1,I), 1 ) + $ DASUM( I-ILO, QG(I,ILO), LDQG ) + $ DASUM( N-I, QG(I+1,I), 1 ) QII = ABS( QG(I,I) ) GII = ABS( QG(I,I+1) ) C C Compute inf-norms of row and column I. C IC = IDAMAX( N-ILO+1, A(I,ILO), LDA ) MAXR = ABS( A(I,IC+ILO-1) ) IF ( I.GT.1 ) THEN IC = IDAMAX( I-1, QG(1,I+1), 1 ) MAXR = MAX( MAXR, ABS( QG(IC,I+1) ) ) END IF IF ( N.GT.I ) THEN IC = IDAMAX( N-I, QG(I,I+2), LDQG ) MAXR = MAX( MAXR, ABS( QG(I,IC+I+1) ) ) END IF IC = IDAMAX( N, A(1,I), 1 ) MAXC = ABS( A(IC,I) ) IF ( I.GT.ILO ) THEN IC = IDAMAX( I-ILO, QG(I,ILO), LDQG ) MAXC = MAX( MAXC, ABS( QG(I,IC+ILO-1) ) ) END IF IF ( N.GT.I ) THEN IC = IDAMAX( N-I, QG(I+1,I), 1 ) MAXC = MAX( MAXC, ABS( QG(IC+I,I) ) ) END IF IF ( ( C + QII ).EQ.ZERO .OR. ( R + GII ).EQ.ZERO ) $ GO TO 170 C F = ONE 150 CONTINUE IF ( ( ( R + GII/SCLFAC )/SCLFAC ).GE. $ ( ( C + QII*SCLFAC )*SCLFAC ) .AND. $ MAX( F*SCLFAC, C*SCLFAC, MAXC*SCLFAC, $ QII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. $ MIN( ( R + GII/SCLFAC )/SCLFAC, MAX( MAXR/SCLFAC, $ GII/SCLFAC/SCLFAC ) ).GT.SFMIN2 ) THEN F = F*SCLFAC C = C*SCLFAC QII = QII*SCLFAC*SCLFAC R = R / SCLFAC GII = GII/SCLFAC/SCLFAC MAXC = MAXC*SCLFAC MAXR = MAXR / SCLFAC GO TO 150 END IF C 160 CONTINUE IF ( ( ( R + GII*SCLFAC )*SCLFAC ).LE. $ ( ( C + QII/SCLFAC )/SCLFAC ) .AND. $ MAX( R*SCLFAC, MAXR*SCLFAC, $ GII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. $ MIN( F/SCLFAC, ( C + QII/SCLFAC )/SCLFAC, $ MAX( MAXC/SCLFAC, QII/SCLFAC/SCLFAC ) ) $ .GT.SFMIN2 ) THEN F = F / SCLFAC C = C / SCLFAC QII = QII/SCLFAC/SCLFAC R = R*SCLFAC GII = GII*SCLFAC*SCLFAC MAXC = MAXC/SCLFAC MAXR = MAXR*SCLFAC GO TO 160 END IF C C Now balance if necessary. C IF ( F.NE.ONE ) THEN IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN IF ( F*SCALE(I).LE.SFMIN1 ) $ GO TO 170 END IF IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN IF ( SCALE(I).GE.SFMAX1 / F ) $ GO TO 170 END IF CONV = .FALSE. SCALE(I) = SCALE(I)*F CALL DRSCL( I-ILO, F, A(I,ILO), LDA ) CALL DRSCL( N-I, F, A(I,I+1), LDA ) CALL DSCAL( I-1, F, A(1,I), 1 ) CALL DSCAL( N-I, F, A(I+1,I), 1 ) CALL DRSCL( I-1, F, QG(1,I+1), 1 ) QG(I,I+1) = QG(I,I+1) / F / F CALL DRSCL( N-I, F, QG(I,I+2), LDQG ) CALL DSCAL( I-ILO, F, QG(I,ILO), LDQG ) QG(I,I) = QG(I,I) * F * F CALL DSCAL( N-I, F, QG(I+1,I), 1 ) END IF 170 CONTINUE IF ( .NOT.CONV ) GO TO 140 END IF RETURN C *** Last line of MB04DD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02CU.f0000644000000000000000000000013215012430707016165 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02CU.f0000644000175000017500000010677215012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE MB02CU( TYPEG, K, P, Q, NB, A1, LDA1, A2, LDA2, B, LDB, $ RNK, IPVT, CS, TOL, DWORK, LDWORK, INFO ) C C PURPOSE C C To bring the first blocks of a generator to proper form. C The positive part of the generator is contained in the arrays A1 C and A2. The negative part of the generator is contained in B. C Transformation information will be stored and can be applied C via SLICOT Library routine MB02CV. C C ARGUMENTS C C Mode Parameters C C TYPEG CHARACTER*1 C Specifies the type of the generator, as follows: C = 'D': generator is column oriented and rank C deficiencies are expected; C = 'C': generator is column oriented and rank C deficiencies are not expected; C = 'R': generator is row oriented and rank C deficiencies are not expected. C C Input/Output Parameters C C K (input) INTEGER C The number of rows in A1 to be processed. K >= 0. C C P (input) INTEGER C The number of columns of the positive generator. P >= K. C C Q (input) INTEGER C The number of columns in B containing the negative C generators. C If TYPEG = 'D', Q >= K; C If TYPEG = 'C' or 'R', Q >= 0. C C NB (input) INTEGER C On entry, if TYPEG = 'C' or TYPEG = 'R', NB specifies C the block size to be used in the blocked parts of the C algorithm. If NB <= 0, an unblocked algorithm is used. C C A1 (input/output) DOUBLE PRECISION array, dimension C (LDA1, K) C On entry, the leading K-by-K part of this array must C contain the leading submatrix of the positive part of the C generator. If TYPEG = 'C', A1 is assumed to be lower C triangular and the strictly upper triangular part is not C referenced. If TYPEG = 'R', A1 is assumed to be upper C triangular and the strictly lower triangular part is not C referenced. C On exit, if TYPEG = 'D', the leading K-by-RNK part of this C array contains the lower trapezoidal part of the proper C generator and information for the Householder C transformations applied during the reduction process. C On exit, if TYPEG = 'C', the leading K-by-K part of this C array contains the leading lower triangular part of the C proper generator. C On exit, if TYPEG = 'R', the leading K-by-K part of this C array contains the leading upper triangular part of the C proper generator. C C LDA1 INTEGER C The leading dimension of the array A1. LDA1 >= MAX(1,K). C C A2 (input/output) DOUBLE PRECISION array, C if TYPEG = 'D' or TYPEG = 'C', dimension (LDA2, P-K); C if TYPEG = 'R', dimension (LDA2, K). C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading C K-by-(P-K) part of this array must contain the (K+1)-st C to P-th columns of the positive part of the generator. C On entry, if TYPEG = 'R', the leading (P-K)-by-K part of C this array must contain the (K+1)-st to P-th rows of the C positive part of the generator. C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading C K-by-(P-K) part of this array contains information for C Householder transformations. C On exit, if TYPEG = 'R', the leading (P-K)-by-K part of C this array contains information for Householder C transformations. C C LDA2 INTEGER C The leading dimension of the array A2. C If P = K, LDA2 >= 1; C If P > K and (TYPEG = 'D' or TYPEG = 'C'), C LDA2 >= MAX(1,K); C if P > K and TYPEG = 'R', LDA2 >= P-K. C C B (input/output) DOUBLE PRECISION array, C if TYPEG = 'D' or TYPEG = 'C', dimension (LDB, Q); C if TYPEG = 'R', dimension (LDB, K). C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading C K-by-Q part of this array must contain the negative part C of the generator. C On entry, if TYPEG = 'R', the leading Q-by-K part of this C array must contain the negative part of the generator. C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading C K-by-Q part of this array contains information for C Householder transformations. C On exit, if TYPEG = 'R', the leading Q-by-K part of this C array contains information for Householder transformations. C C LDB INTEGER C The leading dimension of the array B. C If Q = 0, LDB >= 1; C if Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), C LDB >= MAX(1,K); C if Q > 0 and TYPEG = 'R', LDB >= Q. C C RNK (output) INTEGER C If TYPEG = 'D', the number of columns in the reduced C generator which are found to be linearly independent. C If TYPEG = 'C' or TYPEG = 'R', then RNK is not set. C C IPVT (output) INTEGER array, dimension (K) C If TYPEG = 'D', then if IPVT(i) = k, the k-th row of the C proper generator is the reduced i-th row of the input C generator. C If TYPEG = 'C' or TYPEG = 'R', this array is not C referenced. C C CS (output) DOUBLE PRECISION array, dimension (x) C If TYPEG = 'D' and P = K, x = 3*K; C if TYPEG = 'D' and P > K, x = 5*K; C if (TYPEG = 'C' or TYPEG = 'R') and P = K, x = 4*K; C if (TYPEG = 'C' or TYPEG = 'R') and P > K, x = 6*K. C On exit, the first x elements of this array contain C necessary information for the SLICOT library routine C MB02CV (Givens and modified hyperbolic rotation C parameters, scalar factors of the Householder C transformations). C C Tolerances C C TOL DOUBLE PRECISION C If TYPEG = 'D', this number specifies the used tolerance C for handling deficiencies. If the hyperbolic norm C of two diagonal elements in the positive and negative C generators appears to be less than or equal to TOL, then C the corresponding columns are not reduced. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = -17, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1,4*K), if TYPEG = 'D'; C LDWORK >= MAX(1,MAX(NB,1)*K), if TYPEG = 'C' or '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 = 1: if TYPEG = 'D', the generator represents a C (numerically) indefinite matrix; and if TYPEG = 'C' C or TYPEG = 'R', the generator represents a C (numerically) semidefinite matrix. C C METHOD C C If TYPEG = 'C' or TYPEG = 'R', blocked Householder transformations C and modified hyperbolic rotations are used to downdate the C matrix [ A1 A2 sqrt(-1)*B ], cf. [1], [2]. C If TYPEG = 'D', then an algorithm with row pivoting is used. In C the first stage it maximizes the hyperbolic norm of the active C row. As soon as the hyperbolic norm is below the threshold TOL, C the strategy is changed. Now, in the second stage, the algorithm C applies an LQ decomposition with row pivoting on B such that C the Euclidean norm of the active row is maximized. C C REFERENCES C C [1] Kailath, T. and Sayed, A. C Fast Reliable Algorithms for Matrices with Structure. C SIAM Publications, Philadelphia, 1999. C C [2] Kressner, D. and Van Dooren, P. C Factorizations and linear system solvers for matrices with C Toeplitz structure. C SLICOT Working Note 2000-2, 2000. C C NUMERICAL ASPECTS C 2 C The algorithm requires 0(K *( P + Q )) floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, June 2001. C D. Kressner, Technical Univ. Berlin, Germany, July 2002. C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. C V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. Scalar Arguments .. CHARACTER TYPEG INTEGER INFO, K, LDA1, LDA2, LDB, LDWORK, NB, P, Q, RNK DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IPVT(*) DOUBLE PRECISION A1(LDA1,*), A2(LDA2,*), B(LDB,*), CS(*), $ DWORK(*) C .. Local Scalars .. LOGICAL LCOL, LRDEF INTEGER COL2, I, IB, IERR, IMAX, ITEMP, J, JJ, LEN, $ NBL, PDW, PHV, POS, PST2, PVT, WRKMIN DOUBLE PRECISION ALPHA, ALPHA2, BETA, C, DMAX, S, TAU1, TAU2, $ TEMP, TEMP2, TOLZ C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2, IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DGELQ2, DGEQR2, DLARF, DLARFB, DLARFG, $ DLARFT, DLARTG, DROT, DSCAL, DSWAP, MA02FD, $ XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 COL2 = P - K LRDEF = LSAME( TYPEG, 'D' ) LCOL = LSAME( TYPEG, 'C' ) IF ( LRDEF ) THEN WRKMIN = MAX( 1, 4*K ) ELSE WRKMIN = MAX( 1, NB*K, K ) END IF C C Check the scalar input parameters. C IF ( .NOT.( LCOL .OR. LRDEF .OR. LSAME( TYPEG, 'R' ) ) ) THEN INFO = -1 ELSE IF ( K.LT.0 ) THEN INFO = -2 ELSE IF ( P.LT.K ) THEN INFO = -3 ELSE IF ( Q.LT.0 .OR. ( LRDEF .AND. Q.LT.K ) ) THEN INFO = -4 ELSE IF ( LDA1.LT.MAX( 1, K ) ) THEN INFO = -7 ELSE IF ( ( ( P.EQ.K ) .AND. LDA2.LT.1 ) .OR. $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. $ ( LDA2.LT.MAX( 1, K ) ) ) .OR. $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. $ ( LDA2.LT.( P - K ) ) ) ) THEN INFO = -9 ELSE IF ( ( ( Q.EQ.0 ) .AND. LDB.LT.1 ) .OR. $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. $ ( LDB.LT.MAX( 1, K ) ) ) .OR. $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. $ ( LDB.LT.Q ) ) ) THEN INFO = -11 ELSE IF ( LDWORK.LT.WRKMIN ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = -17 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02CU', -INFO ) RETURN END IF C C Quick return if possible. C IF ( K.EQ.0 .OR. ( .NOT.LRDEF .AND. Q.EQ.0 .AND. P.EQ.K ) ) THEN IF ( LRDEF ) $ RNK = 0 RETURN END IF C TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) C IF ( LRDEF ) THEN C C Deficient generator. C IF ( COL2.EQ.0 ) THEN PST2 = 2*K ELSE PST2 = 4*K END IF C C Initialize partial hyperbolic row norms. C RNK = 0 PHV = 3*K C DO 10 I = 1, K IPVT(I) = I DWORK(I) = DNRM2( K, A1(I,1), LDA1 ) 10 CONTINUE C DO 20 I = 1, K DWORK(I) = DLAPY2( DWORK(I), $ DNRM2( COL2, A2(I,1), LDA2 ) ) DWORK(I+K) = DWORK(I) 20 CONTINUE C PDW = 2*K C DO 30 I = 1, K PDW = PDW + 1 DWORK(PDW) = DNRM2( Q, B(I,1), LDB ) 30 CONTINUE C C Compute factorization. C DO 90 I = 1, K C C Determine pivot row and swap if necessary. C PDW = I ALPHA = ABS( DWORK(PDW) ) BETA = ABS( DWORK(PDW+2*K) ) DMAX = SIGN( SQRT( ABS( ALPHA - BETA ) )* $ SQRT( ALPHA + BETA ), ALPHA - BETA ) IMAX = I C DO 40 J = 1, K - I PDW = PDW + 1 ALPHA = ABS( DWORK(PDW) ) BETA = ABS ( DWORK(PDW+2*K) ) TEMP = SIGN( SQRT( ABS( ALPHA - BETA ) )* $ SQRT( ALPHA + BETA ), ALPHA - BETA ) IF ( TEMP.GT.DMAX ) THEN IMAX = I + J DMAX = TEMP END IF 40 CONTINUE C C Proceed with the reduction if the hyperbolic norm is C beyond the threshold. C IF ( DMAX.GT.TOL ) THEN C PVT = IMAX IF ( PVT.NE.I ) THEN CALL DSWAP( K, A1(PVT,1), LDA1, A1(I,1), LDA1 ) CALL DSWAP( COL2, A2(PVT,1), LDA2, A2(I,1), LDA2 ) CALL DSWAP( Q, B(PVT,1), LDB, B(I,1), LDB ) ITEMP = IPVT(PVT) IPVT(PVT) = IPVT(I) IPVT(I) = ITEMP DWORK(PVT) = DWORK(I) DWORK(K+PVT) = DWORK(K+I) DWORK(2*K+PVT) = DWORK(2*K+I) END IF C C Generate and apply elementary reflectors. C IF ( COL2.GT.1 ) THEN CALL DLARFG( COL2, A2(I,1), A2(I,2), LDA2, TAU2 ) ALPHA2 = A2(I,1) IF ( K.GT.I ) THEN A2(I,1) = ONE CALL DLARF( 'Right', K-I, COL2, A2(I,1), LDA2, $ TAU2, A2(I+1,1), LDA2, DWORK(PHV+1) ) END IF A2(I,1) = TAU2 ELSE IF ( COL2.GT.0 ) THEN ALPHA2 = A2(I,1) A2(I,1) = ZERO END IF C IF ( K.GT.I ) THEN CALL DLARFG( K-I+1, A1(I,I), A1(I,I+1), LDA1, TAU1 ) ALPHA = A1(I,I) A1(I,I) = ONE CALL DLARF( 'Right', K-I, K-I+1, A1(I,I), LDA1, TAU1, $ A1(I+1,I), LDA1, DWORK(PHV+1) ) CS(PST2+I) = TAU1 ELSE ALPHA = A1(I,I) END IF C IF ( COL2.GT.0 ) THEN TEMP = ALPHA CALL DLARTG( TEMP, ALPHA2, C, S, ALPHA ) IF ( K.GT.I ) $ CALL DROT( K-I, A1(I+1,I), 1, A2(I+1,1), 1, C, S ) CS(2*K+I*2-1) = C CS(2*K+I*2) = S END IF A1(I,I) = ALPHA C IF ( Q.GT.1 ) THEN CALL DLARFG( Q, B(I,1), B(I,2), LDB, TAU2 ) BETA = B(I,1) IF ( K.GT.I ) THEN B(I,1) = ONE CALL DLARF( 'Right', K-I, Q, B(I,1), LDB, TAU2, $ B(I+1,1), LDB, DWORK(PHV+1) ) END IF B(I,1) = TAU2 ELSE IF ( Q.GT.0 ) THEN BETA = B(I,1) B(I,1) = ZERO ELSE BETA = ZERO END IF C C Create hyperbolic Givens rotation. C CALL MA02FD( A1(I,I), BETA, C, S, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: This should not happen. C INFO = 1 RETURN END IF C C Apply hyperbolic rotation. C IF ( K.GT.I ) THEN CALL DSCAL( K-I, ONE/C, A1(I+1,I), 1 ) CALL DAXPY( K-I, -S/C, B(I+1,1), 1, A1(I+1,I), 1 ) CALL DSCAL( K-I, C, B(I+1,1), 1 ) CALL DAXPY( K-I, -S, A1(I+1,I), 1, B(I+1,1), 1 ) END IF CS(I*2-1) = C CS(I*2) = S C C Downdate the norms in A1. C DO 50 J = I + 1, K TEMP = ABS( A1(J,I) ) / DWORK(J) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO ) TEMP2 = TEMP*( DWORK(J) / DWORK(K+J) )**2 IF( TEMP2.LE.TOLZ ) THEN DWORK(J) = DLAPY2( DNRM2( K-I, A1(J,I+1), LDA1 ), $ DNRM2( COL2, A2(J,1), LDA2 ) ) DWORK(K+J) = DWORK(J) DWORK(2*K+J) = DNRM2( Q, B(J,1), LDB ) ELSE IF ( TEMP.GE.ZERO ) THEN DWORK(J) = DWORK(J)*SQRT( TEMP ) ELSE DWORK(J) = -DWORK(J)*SQRT( -TEMP ) END IF END IF 50 CONTINUE C RNK = RNK + 1 ELSE IF ( ABS( DMAX ).LT.TOL ) THEN C C Displacement is positive semidefinite. C Do an LQ decomposition with pivoting of the leftover C negative part to find diagonal elements with almost zero C norm. These columns cannot be removed from the C generator. C C Initialize norms. C DO 60 J = I, K DWORK(J) = DNRM2( Q, B(J,1), LDB ) DWORK(J+K) = DWORK(J) 60 CONTINUE C LEN = Q POS = 1 C DO 80 J = I, K C C Generate and apply elementary reflectors. C PVT = ( J-1 ) + IDAMAX( K-J+1, DWORK(J), 1 ) C C Swap rows if necessary. C IF ( PVT.NE.J ) THEN CALL DSWAP( K, A1(PVT,1), LDA1, A1(J,1), LDA1 ) CALL DSWAP( COL2, A2(PVT,1), LDA2, A2(J,1), LDA2 ) CALL DSWAP( Q, B(PVT,1), LDB, B(J,1), LDB ) ITEMP = IPVT(PVT) IPVT(PVT) = IPVT(J) IPVT(J) = ITEMP DWORK(PVT) = DWORK(J) DWORK(K+PVT) = DWORK(K+J) END IF C C Annihilate second part of the positive generators. C IF ( COL2.GT.1 ) THEN CALL DLARFG( COL2, A2(J,1), A2(J,2), LDA2, TAU2 ) ALPHA2 = A2(J,1) IF ( K.GT.J ) THEN A2(J,1) = ONE CALL DLARF( 'Right', K-J, COL2, A2(J,1), LDA2, $ TAU2, A2(J+1,1), LDA2, DWORK(PHV+1)) END IF A2(J,1) = TAU2 ELSE IF ( COL2.GT.0 ) THEN ALPHA2 = A2(J,1) A2(J,1) = ZERO END IF C C Transform first part of the positive generators to C lower triangular form. C IF ( K.GT.J ) THEN CALL DLARFG( K-J+1, A1(J,J), A1(J,J+1), LDA1, $ TAU1 ) ALPHA = A1(J,J) A1(J,J) = ONE CALL DLARF( 'Right', K-J, K-J+1, A1(J,J), LDA1, $ TAU1, A1(J+1,J), LDA1, DWORK(PHV+1) ) CS(PST2+J) = TAU1 ELSE ALPHA = A1(J,J) END IF C IF ( COL2.GT.0 ) THEN TEMP = ALPHA CALL DLARTG( TEMP, ALPHA2, C, S, ALPHA ) IF ( K.GT.J ) $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, $ S ) CS(2*K+J*2-1) = C CS(2*K+J*2) = S END IF A1(J,J) = ALPHA C C Transform negative part to lower triangular form. C IF ( LEN.GT.1) THEN CALL DLARFG( LEN, B(J,POS), B(J,POS+1), LDB, TAU2 ) BETA = B(J,POS) IF ( K.GT.J ) THEN B(J,POS) = ONE CALL DLARF( 'Right', K-J, LEN, B(J,POS), LDB, $ TAU2, B(J+1,POS), LDB, DWORK(PHV+1)) END IF B(J,POS) = BETA CS(J*2-1) = TAU2 END IF C C Downdate the norms of the rows in the negative part. C DO 70 JJ = J + 1, K IF ( DWORK(JJ).NE.ZERO ) THEN TEMP = ABS( B(JJ,POS) ) / DWORK(JJ) TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO) TEMP2 = TEMP*( DWORK(JJ) / DWORK(K+JJ) )**2 IF( TEMP2.LE.TOLZ ) THEN DWORK(JJ) = DNRM2( LEN-1, B(JJ,POS+1), LDB) DWORK(K+JJ) = DWORK(JJ) ELSE IF ( TEMP.GE.ZERO ) THEN DWORK(JJ) = DWORK(JJ)*SQRT( TEMP ) ELSE DWORK(JJ) = -DWORK(JJ)*SQRT( -TEMP ) END IF END IF END IF 70 CONTINUE C LEN = LEN - 1 POS = POS + 1 80 CONTINUE C RETURN ELSE C C Error return: C C Displacement is indefinite. C Due to roundoff error, positive semidefiniteness is C violated. This is a rather bad situation. There is no C meaningful way to continue the computations from this C point. C INFO = 1 RETURN END IF 90 CONTINUE C ELSE IF ( LCOL ) THEN C C Column oriented and not deficient generator. C C Apply an LQ like hyperbolic/orthogonal blocked decomposition. C IF ( COL2.GT.0 ) THEN NBL = MIN( COL2, NB ) IF ( NBL.GT.0 ) THEN C C Blocked version. C DO 110 I = 1, K - NBL + 1, NBL IB = MIN( K-I+1, NBL ) CALL DGELQ2( IB, COL2, A2(I,1), LDA2, CS(4*K+I), $ DWORK, IERR ) IF ( I+IB.LE.K ) THEN CALL DLARFT( 'Forward', 'Rowwise', COL2, IB, $ A2(I,1), LDA2, CS(4*K+I), DWORK, K ) CALL DLARFB( 'Right', 'No Transpose', 'Forward', $ 'Rowwise', K-I-IB+1, COL2, IB, $ A2(I,1), LDA2, DWORK, K, A2(I+IB,1), $ LDA2, DWORK(IB+1), K ) END IF C C Annihilate the remaining parts of A2. C DO 100 J = I, I + IB - 1 IF ( COL2.GT.1 ) THEN LEN = MIN( COL2, J-I+1 ) CALL DLARFG( LEN, A2(J,1), A2(J,2), LDA2, TAU2 ) ALPHA2 = A2(J,1) IF ( K.GT.J ) THEN A2(J,1) = ONE CALL DLARF( 'Right', K-J, LEN, A2(J,1), LDA2, $ TAU2, A2(J+1,1), LDA2, DWORK ) END IF A2(J,1) = TAU2 ELSE ALPHA2 = A2(J,1) A2(J,1) = ZERO END IF ALPHA = A1(J,J) CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) IF ( K.GT.J ) $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, $ S ) CS(2*K+J*2-1) = C CS(2*K+J*2) = S 100 CONTINUE C 110 CONTINUE C ELSE I = 1 END IF C C Unblocked version for the last or only block. C DO 120 J = I, K IF ( COL2.GT.1 ) THEN CALL DLARFG( COL2, A2(J,1), A2(J,2), LDA2, TAU2 ) ALPHA2 = A2(J,1) IF ( K.GT.J ) THEN A2(J,1) = ONE CALL DLARF( 'Right', K-J, COL2, A2(J,1), LDA2, $ TAU2, A2(J+1,1), LDA2, DWORK ) END IF A2(J,1) = TAU2 ELSE ALPHA2 = A2(J,1) A2(J,1) = ZERO END IF ALPHA = A1(J,J) CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) IF ( K.GT.J ) $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, S ) CS(2*K+J*2-1) = C CS(2*K+J*2) = S 120 CONTINUE C PST2 = 5*K ELSE PST2 = 2*K END IF C C Annihilate B with hyperbolic transformations. C NBL = MIN( NB, Q ) IF ( NBL.GT.0 ) THEN C C Blocked version. C DO 140 I = 1, K - NBL + 1, NBL IB = MIN( K-I+1, NBL ) CALL DGELQ2( IB, Q, B(I,1), LDB, CS(PST2+I), DWORK, $ IERR ) IF ( I+IB.LE.K ) THEN CALL DLARFT( 'Forward', 'Rowwise', Q, IB, B(I,1), $ LDB, CS(PST2+I), DWORK, K ) CALL DLARFB( 'Right', 'No Transpose', 'Forward', $ 'Rowwise', K-I-IB+1, Q, IB, B(I,1), $ LDB, DWORK, K, B(I+IB,1), LDB, $ DWORK( IB+1 ), K ) END IF C C Annihilate the remaining parts of B. C DO 130 J = I, I + IB - 1 IF ( Q.GT.1 ) THEN CALL DLARFG( J-I+1, B(J,1), B(J,2), LDB, TAU2 ) ALPHA2 = B(J,1) IF ( K.GT.J ) THEN B(J,1) = ONE CALL DLARF( 'Right', K-J, J-I+1, B(J,1), LDB, $ TAU2, B(J+1,1), LDB, DWORK ) END IF B(J,1) = TAU2 ELSE ALPHA2 = B(J,1) B(J,1) = ZERO END IF C C Create hyperbolic rotation. C CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C C Apply hyperbolic rotation. C IF ( K.GT.J ) THEN CALL DSCAL( K-J, ONE/C, A1(J+1,J), 1 ) CALL DAXPY( K-J, -S/C, B(J+1,1), 1, A1(J+1,J), 1 ) CALL DSCAL( K-J, C, B(J+1,1), 1 ) CALL DAXPY( K-J, -S, A1(J+1,J), 1, B(J+1,1), 1 ) END IF CS(J*2-1) = C CS(J*2) = S 130 CONTINUE C 140 CONTINUE C ELSE I = 1 END IF C C Unblocked version for the last or only block. C DO 150 J = I, K IF ( Q.GT.1 ) THEN CALL DLARFG( Q, B(J,1), B(J,2), LDB, TAU2 ) ALPHA2 = B(J,1) IF ( K.GT.J ) THEN B(J,1) = ONE CALL DLARF( 'Right', K-J, Q, B(J,1), LDB, TAU2, $ B(J+1,1), LDB, DWORK ) END IF B(J,1) = TAU2 ELSE IF ( Q.GT.0 ) THEN ALPHA2 = B(J,1) B(J,1) = ZERO END IF IF ( Q.GT.0 ) THEN C C Create hyperbolic rotation. C CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C C Apply hyperbolic rotation. C IF ( K.GT.J ) THEN CALL DSCAL( K-J, ONE/C, A1(J+1,J), 1 ) CALL DAXPY( K-J, -S/C, B(J+1,1), 1, A1(J+1,J), 1 ) CALL DSCAL( K-J, C, B(J+1,1), 1 ) CALL DAXPY( K-J, -S, A1(J+1,J), 1, B(J+1,1), 1 ) END IF CS(J*2-1) = C CS(J*2) = S END IF 150 CONTINUE C ELSE C C Row oriented and not deficient generator. C IF ( COL2.GT.0 ) THEN NBL = MIN( NB, COL2 ) IF ( NBL.GT.0 ) THEN C C Blocked version. C DO 170 I = 1, K - NBL + 1, NBL IB = MIN( K-I+1, NBL ) CALL DGEQR2( COL2, IB, A2(1,I), LDA2, CS(4*K+I), $ DWORK, IERR ) IF ( I+IB.LE.K ) THEN CALL DLARFT( 'Forward', 'Columnwise', COL2, IB, $ A2(1,I), LDA2, CS(4*K+I), DWORK, K ) CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', COL2, K-I-IB+1, IB, $ A2(1,I), LDA2, DWORK, K, A2(1,I+IB), $ LDA2, DWORK(IB+1), K ) END IF C C Annihilate the remaining parts of A2. C DO 160 J = I, I + IB - 1 IF ( COL2.GT.1 ) THEN LEN = MIN( COL2, J-I+1 ) CALL DLARFG( LEN, A2(1,J), A2(2,J), 1, TAU2 ) ALPHA2 = A2(1,J) IF ( K.GT.J ) THEN A2(1,J) = ONE CALL DLARF( 'Left', LEN, K-J, A2(1,J), 1, $ TAU2, A2(1,J+1), LDA2, DWORK ) END IF A2(1,J) = TAU2 ELSE ALPHA2 = A2(1,J) A2(1,J) = ZERO END IF ALPHA = A1(J,J) CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) IF ( K.GT.J ) $ CALL DROT( K-J, A1(J,J+1), LDA1, A2(1,J+1), $ LDA2, C, S ) CS(2*K+J*2-1) = C CS(2*K+J*2) = S 160 CONTINUE C 170 CONTINUE C ELSE I = 1 END IF C C Unblocked version for the last or only block. C DO 180 J = I, K IF ( COL2.GT.1 ) THEN CALL DLARFG( COL2, A2(1,J), A2(2,J), 1, TAU2 ) ALPHA2 = A2(1,J) IF ( K.GT.J ) THEN A2(1,J) = ONE CALL DLARF( 'Left', COL2, K-J, A2(1,J), 1, TAU2, $ A2(1,J+1), LDA2, DWORK ) END IF A2(1,J) = TAU2 ELSE ALPHA2 = A2(1,J) A2(1,J) = ZERO END IF ALPHA = A1(J,J) CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) IF ( K.GT.J ) $ CALL DROT( K-J, A1(J,J+1), LDA1, A2(1,J+1), LDA2, C, $ S ) CS(2*K+J*2-1) = C CS(2*K+J*2) = S 180 CONTINUE C PST2 = 5*K ELSE PST2 = 2*K END IF C C Annihilate B with hyperbolic transformations. C NBL = MIN( NB, Q ) IF ( NBL.GT.0 ) THEN C C Blocked version. C DO 200 I = 1, K - NBL + 1, NBL IB = MIN( K-I+1, NBL ) CALL DGEQR2( Q, IB, B(1,I), LDB, CS(PST2+I), DWORK, $ IERR ) IF ( I+IB.LE.K ) THEN CALL DLARFT( 'Forward', 'Columnwise', Q, IB, B(1,I), $ LDB, CS(PST2+I), DWORK, K ) CALL DLARFB( 'Left', 'Transpose', 'Forward', $ 'Columnwise', Q, K-I-IB+1, IB, B(1,I), $ LDB, DWORK, K, B(1,I+IB), LDB, $ DWORK( IB+1 ), K ) END IF C C Annihilate the remaining parts of B. C DO 190 J = I, I + IB - 1 IF ( Q.GT.1 ) THEN CALL DLARFG( J-I+1, B(1,J), B(2,J), 1, TAU2 ) ALPHA2 = B(1,J) IF ( K.GT.J ) THEN B(1,J) = ONE CALL DLARF( 'Left', J-I+1, K-J, B(1,J), 1, $ TAU2, B(1,J+1), LDB, DWORK ) END IF B(1,J) = TAU2 ELSE ALPHA2 = B(1,J) B(1,J) = ZERO END IF C C Create hyperbolic rotation. C CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C C Apply hyperbolic rotation. C IF ( K.GT.J ) THEN CALL DSCAL( K-J, ONE/C, A1(J,J+1), LDA1 ) CALL DAXPY( K-J, -S/C, B(1,J+1), LDB, A1(J,J+1), $ LDA1 ) CALL DSCAL( K-J, C, B(1,J+1), LDB ) CALL DAXPY( K-J, -S, A1(J,J+1), LDA1, B(1,J+1), $ LDB ) END IF CS(J*2-1) = C CS(J*2) = S 190 CONTINUE C 200 CONTINUE C ELSE I = 1 END IF C C Unblocked version for the last or only block. C DO 210 J = I, K IF ( Q.GT.1 ) THEN CALL DLARFG( Q, B(1,J), B(2,J), 1, TAU2 ) ALPHA2 = B(1,J) IF ( K.GT.J ) THEN B(1,J) = ONE CALL DLARF( 'Left', Q, K-J, B(1,J), 1, TAU2, $ B(1,J+1), LDB, DWORK ) END IF B(1,J) = TAU2 ELSE IF ( Q.GT.0 ) THEN ALPHA2 = B(1,J) B(1,J) = ZERO END IF IF ( Q.GT.0 ) THEN C C Create hyperbolic rotation. C CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C C Apply hyperbolic rotation. C IF ( K.GT.J ) THEN CALL DSCAL( K-J, ONE/C, A1(J,J+1), LDA1 ) CALL DAXPY( K-J, -S/C, B(1,J+1), LDB, A1(J,J+1), LDA1 $ ) CALL DSCAL( K-J, C, B(1,J+1), LDB ) CALL DAXPY( K-J, -S, A1(J,J+1), LDA1, B(1,J+1), LDB $ ) END IF CS(J*2-1) = C CS(J*2) = S END IF 210 CONTINUE C END IF C C *** Last line of MB02CU *** END control-4.1.2/src/slicot/src/PaxHeaders/AB01ND.f0000644000000000000000000000013215012430707016142 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB01ND.f0000644000175000017500000003760015012430707017344 0ustar00lilgelilge00000000000000 SUBROUTINE AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON, $ NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To find a controllable realization for the linear time-invariant C multi-input system C C dX/dt = A * X + B * U, C C where A and B are N-by-N and N-by-M matrices, respectively, C which are reduced by this routine to orthogonal canonical form C using (and optionally accumulating) orthogonal similarity C transformations. Specifically, the pair (A, B) is reduced to C the pair (Ac, Bc), Ac = Z' * A * Z, Bc = Z' * B, given by C C [ Acont * ] [ Bcont ] C Ac = [ ], Bc = [ ], C [ 0 Auncont ] [ 0 ] C C and C C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] C Acont = [ . . . . . . . ], Bc = [ . ], C [ . . . . . . ] [ . ] C [ . . . . . ] [ . ] C [ 0 0 . . . Ap,p-1 App ] [ 0 ] C C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and C p is the controllability index of the pair. The size of the C block Auncont is equal to the dimension of the uncontrollable C subspace of the pair (A, B). C C ARGUMENTS C C Mode Parameters C C JOBZ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal similarity transformations for C reducing the system, as follows: C = 'N': Do not form Z and do not store the orthogonal C transformations; C = 'F': Do not form Z, but store the orthogonal C transformations in the factored form; C = 'I': Z is initialized to the unit matrix and the C orthogonal transformation matrix Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e. the order of the matrix A. N >= 0. C C M (input) INTEGER C The number of system inputs, or of columns of 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 original state dynamics matrix A. C On exit, the leading NCONT-by-NCONT part contains the C upper block Hessenberg state dynamics matrix Acont in Ac, C given by Z' * A * Z, of a controllable realization for C the original system. The elements below the first block- C subdiagonal are set to zero. 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 matrix B. C On exit, the leading NCONT-by-M part of this array C contains the transformed input matrix Bcont in Bc, given C by Z' * B, with all elements but the first block set to C zero. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C NCONT (output) INTEGER C The order of the controllable state-space representation. C C INDCON (output) INTEGER C The controllability index of the controllable part of the C system representation. C C NBLK (output) INTEGER array, dimension (N) C The leading INDCON elements of this array contain the C the orders of the diagonal blocks of Acont. C C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) C If JOBZ = 'I', then the leading N-by-N part of this C array contains the matrix of accumulated orthogonal C similarity transformations which reduces the given system C to orthogonal canonical form. C If JOBZ = 'F', the elements below the diagonal, with the C array TAU, represent the orthogonal transformation matrix C as a product of elementary reflectors. The transformation C matrix can then be obtained by calling the LAPACK Library C routine DORGQR. C If JOBZ = 'N', the array Z is not referenced and can be C supplied as a dummy array (i.e. set parameter LDZ = 1 and C declare this array to be Z(1,1) in the calling program). C C LDZ INTEGER C The leading dimension of array Z. If JOBZ = 'I' or C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. C C TAU (output) DOUBLE PRECISION array, dimension (N) C The elements of TAU contain the scalar factors of the C elementary reflectors used in the reduction of B and A. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determination when C transforming (A, B). If the user sets TOL > 0, then C the given value of TOL is used as a lower bound for the C reciprocal condition number (see the description of the C argument RCOND in the SLICOT routine MB03OD); a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*N*EPS, is used instead, where EPS C is the machine precision (see LAPACK Library routine C DLAMCH). C C Workspace C C IWORK INTEGER array, dimension (M) 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, N, 3*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 C METHOD C C Matrix B is first QR-decomposed and the appropriate orthogonal C similarity transformation applied to the matrix A. Leaving the C first rank(B) states unchanged, the remaining lower left block C of A is then QR-decomposed and the new orthogonal matrix, Q1, C is also applied to the right of A to complete the similarity C transformation. By continuing in this manner, a completely C controllable state-space pair (Acont, Bcont) is found for the C given (A, B), where Acont is upper block Hessenberg with each C subdiagonal block of full row rank, and Bcont is zero apart from C its (independent) first rank(B) rows. C NOTE that the system controllability indices are easily C calculated from the dimensions of the blocks of Acont. C C REFERENCES C C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. C Orthogonal Invariants and Canonical Forms for Linear C Controllable Systems. C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. C C [2] Paige, C.C. C Properties of numerical algorithms related to computing C controllablity. C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. C C [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and C Postlethwaite, I. C Optimal Pole Assignment Design of Linear Multi-Input Systems. C Leicester University, Report 99-11, May 1996. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations and is backward stable. C C FURTHER COMMENTS C C If the system matrices A and B are badly scaled, it would be C useful to scale them with SLICOT routine TB01ID, before calling C the routine. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. C Supersedes Release 2.0 routine AB01BD by P.Hr. Petkov. C C REVISIONS C C V. Sima, January 14, 1997, June 4, 1997, February 13, 1998, C September 22, 2003, February 29, 2004, April 2, 2017. C C KEYWORDS C C Controllability, minimal realization, orthogonal canonical form, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBZ INTEGER INDCON, INFO, LDA, LDB, LDWORK, LDZ, M, N, NCONT DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*), Z(LDZ,*) INTEGER IWORK(*), NBLK(*) C .. Local Scalars .. LOGICAL LJOBF, LJOBI, LJOBZ INTEGER IQR, ITAU, J, MCRT, NBL, NCRT, NI, NJ, RANK, $ WRKOPT DOUBLE PRECISION ANORM, BNORM, FNRM, TOLDEF C .. Local Arrays .. DOUBLE PRECISION SVAL(3) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR, $ MB01PD, MB03OY, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C INFO = 0 LJOBF = LSAME( JOBZ, 'F' ) LJOBI = LSAME( JOBZ, 'I' ) LJOBZ = LJOBF.OR.LJOBI C C Test the input scalar arguments. C IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN INFO = -12 ELSE IF( LDWORK.LT.MAX( 1, N, 3*M ) ) THEN INFO = -17 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB01ND', -INFO ) RETURN END IF C NCONT = 0 INDCON = 0 C C Quick return if possible. C IF ( MIN( N, M ).EQ.0 ) THEN IF( N.GT.0 ) THEN IF ( LJOBI ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) ELSE IF ( LJOBF ) THEN CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) END IF END IF DWORK(1) = ONE RETURN END IF C C Calculate the absolute norms of A and B (used for scaling). C ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) BNORM = DLANGE( 'M', N, M, B, LDB, DWORK ) C C Return if matrix B is zero. C IF( BNORM.EQ.ZERO ) THEN IF ( LJOBI ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) ELSE IF ( LJOBF ) THEN CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) END IF DWORK(1) = ONE RETURN END IF C C Scale (if needed) the matrices A and B. C CALL MB01PD( 'Scale', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, $ INFO ) CALL MB01PD( 'Scale', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, $ INFO ) C C Compute the Frobenius norm of [ B A ] (used for rank estimation). C FNRM = DLANGE( 'F', N, M, B, LDB, DWORK ) C TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance in controllability determination. C TOLDEF = DBLE( N*N )*DLAMCH( 'Precision' ) END IF C WRKOPT = 1 NI = 0 ITAU = 1 NCRT = N MCRT = M IQR = 1 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 10 CONTINUE C C Rank-revealing QR decomposition with column pivoting. C The calculation is performed in NCRT rows of B starting from C the row IQR (initialized to 1 and then set to rank(B)+1). C Workspace: 3*MCRT. C CALL MB03OY( NCRT, MCRT, B(IQR,1), LDB, TOLDEF, FNRM, RANK, $ SVAL, IWORK, TAU(ITAU), DWORK, INFO ) C IF ( RANK.NE.0 ) THEN NJ = NI NI = NCONT NCONT = NCONT + RANK INDCON = INDCON + 1 NBLK(INDCON) = RANK C C Premultiply and postmultiply the appropriate block row C and block column of A by Q' and Q, respectively. C Workspace: need NCRT; C prefer NCRT*NB. C CALL DORMQR( 'Left', 'Transpose', NCRT, NCRT, RANK, $ B(IQR,1), LDB, TAU(ITAU), A(NI+1,NI+1), LDA, $ DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Workspace: need N; C prefer N*NB. C CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK, $ B(IQR,1), LDB, TAU(ITAU), A(1,NI+1), LDA, $ DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C If required, save transformations. C IF ( LJOBZ.AND.NCRT.GT.1 ) THEN CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ), $ B(IQR+1,1), LDB, Z(NI+2,ITAU), LDZ ) END IF C C Zero the subdiagonal elements of the current matrix. C IF ( RANK.GT.1 ) $ CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO, B(IQR+1,1), $ LDB ) C C Backward permutation of the columns of B or A. C IF ( INDCON.EQ.1 ) THEN CALL DLAPMT( .FALSE., RANK, M, B(IQR,1), LDB, IWORK ) IQR = RANK + 1 FNRM = DLANGE( 'F', N, N, A, LDA, DWORK ) ELSE DO 20 J = 1, MCRT CALL DCOPY( RANK, B(IQR,J), 1, A(NI+1,NJ+IWORK(J)), $ 1 ) 20 CONTINUE END IF C ITAU = ITAU + RANK IF ( RANK.NE.NCRT ) THEN MCRT = RANK NCRT = NCRT - RANK CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NI+1), LDA, $ B(IQR,1), LDB ) CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, $ A(NCONT+1,NI+1), LDA ) GO TO 10 END IF END IF C C If required, accumulate transformations. C Workspace: need N; prefer N*NB. C IF ( LJOBI ) THEN CALL DORGQR( N, N, MAX( 1, ITAU-1 ), Z, LDZ, TAU, DWORK, $ LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF C C Annihilate the trailing blocks of B. C IF ( N.GE.IQR ) $ CALL DLASET( 'G', N-IQR+1, M, ZERO, ZERO, B(IQR,1), LDB ) C C Annihilate the trailing elements of TAU, if JOBZ = 'F'. C IF ( LJOBF ) THEN DO 30 J = ITAU, N TAU(J) = ZERO 30 CONTINUE END IF C C Undo scaling of A and B. C IF ( INDCON.LT.N ) THEN NBL = INDCON + 1 NBLK(NBL) = N - NCONT ELSE NBL = 0 END IF CALL MB01PD( 'Undo', 'H', N, N, 0, 0, ANORM, NBL, NBLK, A, $ LDA, INFO ) CALL MB01PD( 'Undo', 'G', NBLK(1), M, 0, 0, BNORM, 0, NBLK, B, $ LDB, INFO ) C C Set optimal workspace dimension. C DWORK(1) = WRKOPT RETURN C *** Last line of AB01ND *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09KX.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09KX.f0000644000175000017500000007520215012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE AB09KX( JOB, DICO, WEIGHT, N, NV, NW, M, P, $ A, LDA, B, LDB, C, LDC, D, LDD, $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, $ DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To construct a state-space representation (A,BS,CS,DS) of the C stable projection of V*G*W or conj(V)*G*conj(W) from the C state-space representations (A,B,C,D), (AV,BV,CV,DV), and C (AW,BW,CW,DW) of the transfer-function matrices G, V and W, C respectively. G is assumed to be a stable transfer-function C matrix and the state matrix A must be in a real Schur form. C When computing the stable projection of V*G*W, V and W are assumed C to be completely unstable transfer-function matrices. C When computing the stable projection of conj(V)*G*conj(W), C V and W are assumed to be stable transfer-function matrices. C C For a transfer-function matrix G, conj(G) denotes the conjugate C of G given by G'(-s) for a continuous-time system or G'(1/z) C for a discrete-time system. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies which projection to be computed as follows: C = 'N': compute the stable projection of V*G*W; C = 'C': compute the stable projection of C conj(V)*G*conj(W). C C DICO CHARACTER*1 C Specifies the type of the systems as follows: C = 'C': G, V and W are continuous-time systems; C = 'D': G, V and W are discrete-time systems. C C WEIGHT CHARACTER*1 C Specifies the type of frequency weighting, as follows: C = 'N': no weightings are used (V = I, W = I); C = 'L': only left weighting V is used (W = I); C = 'R': only right weighting W is used (V = I); C = 'B': both left and right weightings V and W are used. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. Also the number of rows of C the matrix B and the number of columns of the matrix C. C N represents the dimension of the state vector of the C system with the transfer-function matrix G. N >= 0. C C NV (input) INTEGER C The order of the matrix AV. Also the number of rows of C the matrix BV and the number of columns of the matrix CV. C NV represents the dimension of the state vector of the C system with the transfer-function matrix V. NV >= 0. C C NW (input) INTEGER C The order of the matrix AW. Also the number of rows of C the matrix BW and the number of columns of the matrix CW. C NW represents the dimension of the state vector of the C system with the transfer-function matrix W. NW >= 0. C C M (input) INTEGER C The number of columns of the matrices B, D, BW and DW C and number of rows of the matrices CW and DW. M >= 0. C M represents the dimension of input vectors of the C systems with the transfer-function matrices G and W and C also the dimension of the output vector of the system C with the transfer-function matrix W. C C P (input) INTEGER C The number of rows of the matrices C, D, CV and DV and the C number of columns of the matrices BV and DV. P >= 0. C P represents the dimension of output vectors of the C systems with the transfer-function matrices G and V and C also the dimension of the input vector of the system C with the transfer-function matrix V. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must C contain the state matrix A of the system with the C transfer-function matrix G in a real Schur form. C C LDA INTEGER C The leading dimension of the 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 matrix B of the system with the C transfer-function matrix G. C On exit, if INFO = 0, the leading N-by-M part of this C array contains the input matrix BS of the stable C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) C if JOB = 'C'. C C LDB INTEGER C The leading dimension of the 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 output matrix C of the system with the C transfer-function matrix G. C On exit, if INFO = 0, the leading P-by-N part of this C array contains the output matrix CS of the stable C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) C if JOB = 'C'. C C LDC INTEGER C The leading dimension of the 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 feedthrough matrix D of the system with the C transfer-function matrix G. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the feedthrough matrix DS of the stable C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) C if JOB = 'C'. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1,P). C C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV C part of this array must contain the state matrix AV of C the system with the transfer-function matrix V. C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading C NV-by-NV part of this array contains a real Schur form C of AV. C AV is not referenced if WEIGHT = 'R' or 'N'. C C LDAV INTEGER C The leading dimension of the array AV. C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; C LDAV >= 1, if WEIGHT = 'R' or 'N'. C C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part C of this array must contain the input matrix BV of the C system with the transfer-function matrix V. C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading C NV-by-P part of this array contains the transformed input C matrix BV. C BV is not referenced if WEIGHT = 'R' or 'N'. C C LDBV INTEGER C The leading dimension of the array BV. C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; C LDBV >= 1, if WEIGHT = 'R' or 'N'. C C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) C On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part C of this array must contain the output matrix CV of the C system with the transfer-function matrix V. C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading C P-by-NV part of this array contains the transformed output C matrix CV. C CV is not referenced if WEIGHT = 'R' or 'N'. C C LDCV INTEGER C The leading dimension of the array CV. C LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B'; C LDCV >= 1, if WEIGHT = 'R' or 'N'. C C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) C If WEIGHT = 'L' or 'B', the leading P-by-P part of this C array must contain the feedthrough matrix DV of the system C with the transfer-function matrix V. C DV is not referenced if WEIGHT = 'R' or 'N'. C C LDDV INTEGER C The leading dimension of the array DV. C LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B'; C LDDV >= 1, if WEIGHT = 'R' or 'N'. C C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW C part of this array must contain the state matrix AW of C the system with the transfer-function matrix W. C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading C NW-by-NW part of this array contains a real Schur form C of AW. C AW is not referenced if WEIGHT = 'L' or 'N'. C C LDAW INTEGER C The leading dimension of the array AW. C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; C LDAW >= 1, if WEIGHT = 'L' or 'N'. C C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part C of this array must contain the input matrix BW of the C system with the transfer-function matrix W. C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading C NW-by-M part of this array contains the transformed input C matrix BW. C BW is not referenced if WEIGHT = 'L' or 'N'. C C LDBW INTEGER C The leading dimension of the array BW. C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; C LDBW >= 1, if WEIGHT = 'L' or 'N'. C C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part C of this array must contain the output matrix CW of the C system with the transfer-function matrix W. C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading C M-by-NW part of this array contains the transformed output C matrix CW. C CW is not referenced if WEIGHT = 'L' or 'N'. C C LDCW INTEGER C The leading dimension of the array CW. C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; C LDCW >= 1, if WEIGHT = 'L' or 'N'. C C DW (input) DOUBLE PRECISION array, dimension (LDDW,M) C If WEIGHT = 'R' or 'B', the leading M-by-M part of this C array must contain the feedthrough matrix DW of the system C with the transfer-function matrix W. C DW is not referenced if WEIGHT = 'L' or 'N'. C C LDDW INTEGER C The leading dimension of the array DW. C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; C LDDW >= 1, if WEIGHT = 'L' or 'N'. 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 length of the array DWORK. C LDWORK >= MAX( 1, LDW1, LDW2 ), where C LDW1 = 0 if WEIGHT = 'R' or 'N' and C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) C if WEIGHT = 'L' or WEIGHT = 'B', C LDW2 = 0 if WEIGHT = 'L' or 'N' and C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) C if WEIGHT = 'R' or WEIGHT = 'B', C a = 0, b = 0, if DICO = 'C' or JOB = 'N', C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'. C For good performance, LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: JOB = 'N' and AV is not completely unstable, or C JOB = 'C' and AV is not stable; C = 2: JOB = 'N' and AW is not completely unstable, or C JOB = 'C' and AW is not stable; C = 3: both above conditions appear. 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 AV to a real Schur form failed; C = 2: the reduction of AW to a real Schur form failed; C = 3: the solution of the Sylvester equation failed C because the matrices A and AV have common C eigenvalues (if JOB = 'N'), or -AV and A have C common eigenvalues (if JOB = 'C' and DICO = 'C'), C or AV has an eigenvalue which is the reciprocal of C one of the eigenvalues of A (if JOB = 'C' and C DICO = 'D'); C = 4: the solution of the Sylvester equation failed C because the matrices A and AW have common C eigenvalues (if JOB = 'N'), or -AW and A have C common eigenvalues (if JOB = 'C' and DICO = 'C'), C or AW has an eigenvalue which is the reciprocal of C one of the eigenvalues of A (if JOB = 'C' and C DICO = 'D'). C C METHOD C C The matrices of the stable projection of V*G*W are computed as C C BS = B*DW + Y*BW, CS = CV*X + DV*C, DS = DV*D*DW, C C where X and Y satisfy the continuous-time Sylvester equations C C AV*X - X*A + BV*C = 0, C -A*Y + Y*AW + B*CW = 0. C C The matrices of the stable projection of conj(V)*G*conj(W) are C computed using the explicit formulas established in [1]. C C For a continuous-time system, the matrices BS, CS and DS of C the stable projection are computed as C C BS = B*DW' + Y*CW', CS = BV'*X + DV'*C, DS = DV'*D*DW', C C where X and Y satisfy the continuous-time Sylvester equations C C AV'*X + X*A + CV'*C = 0, C A*Y + Y*AW' + B*BW' = 0. C C For a discrete-time system, the matrices BS, CS and DS of C the stable projection are computed as C C BS = B*DW' + A*Y*CW', CS = BV'*X*A + DV'*C, C DS = DV'*D*DW' + BV'*X*B*DW' + DV'*C*Y*CW' + BV'*X*A*Y*CW', C C where X and Y satisfy the discrete-time Sylvester equations C C AV'*X*A + CV'*C = X, C A*Y*AW' + B*BW' = Y. C C REFERENCES C C [1] Varga A. C Explicit formulas for an efficient implementation C of the frequency-weighting model reduction approach. C Proc. 1993 European Control Conference, Groningen, NL, C pp. 693-696, 1993. C C NUMERICAL ASPECTS C C The implemented methods rely on numerically stable algorithms. C C FURTHER COMMENTS C C The matrix A must be stable, but its stability is not checked by C this routine. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000. C D. Sima, University of Bucharest, May 2000. C V. Sima, Research Institute for Informatics, Bucharest, May 2000. C Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1, C by A. Varga, 1992. C C REVISIONS C C - C C KEYWORDS C C Frequency weighting, model reduction, multivariable system, C state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOB, WEIGHT INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, $ NV, NW, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ AV(LDAV,*), BV(LDBV,*), CV(LDCV,*), DV(LDDV,*), $ AW(LDAW,*), BW(LDBW,*), CW(LDCW,*), DW(LDDW,*), $ DWORK(*) C .. Local Scalars LOGICAL CONJS, DISCR, FRWGHT, LEFTW, RIGHTW DOUBLE PRECISION SCALE, WORK INTEGER I, IA, IB, IERR, KW, LDW, LDWN, LW C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAPY2 EXTERNAL DLAPY2, LSAME C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DTRSYL, SB04PY, TB01WD, XERBLA C .. Executable Statements .. C CONJS = LSAME( JOB, 'C' ) DISCR = LSAME( DICO, 'D' ) LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) FRWGHT = LEFTW .OR. RIGHTW C IWARN = 0 INFO = 0 IF ( DISCR .AND. CONJS ) THEN IA = 2*NV IB = 2*NW ELSE IA = 0 IB = 0 END IF LW = 1 IF( LEFTW ) $ LW = MAX( LW, NV*( NV + 5 ), NV*N + MAX( IA, P*N, P*M ) ) IF( RIGHTW ) $ LW = MAX( LW, NW*( NW + 5 ), NW*N + MAX( IB, M*N, P*M ) ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -2 ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( NV.LT.0 ) THEN INFO = -5 ELSE IF( NW.LT.0 ) THEN INFO = -6 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( P.LT.0 ) THEN INFO = -8 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -14 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -16 ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN INFO = -18 ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN INFO = -20 ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN INFO = -22 ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN INFO = -24 ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN INFO = -26 ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN INFO = -28 ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN INFO = -30 ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN INFO = -32 ELSE IF( LDWORK.LT.LW ) THEN INFO = -34 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09KX', -INFO ) RETURN END IF C C Quick return if possible. C IF( .NOT.FRWGHT .OR. MIN( M, P ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C WORK = ONE IF( LEFTW .AND. NV.GT.0 ) THEN C C Reduce AV to a real Schur form using an orthogonal similarity C transformation AV <- Q'*AV*Q and apply the transformation to C BV and CV: BV <- Q'*BV and CV <- CV*Q. C C Workspace needed: NV*(NV+5); C prefer larger. C KW = NV*( NV + 2 ) + 1 CALL TB01WD( NV, P, P, AV, LDAV, BV, LDBV, CV, LDCV, $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), DWORK(KW), $ LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) C IF( CONJS ) THEN C C Check the stability of the eigenvalues of AV. C IF ( DISCR ) THEN DO 10 I = 1, NV IF( DLAPY2( DWORK(I), DWORK(NV+I) ).GE.ONE) THEN IWARN = 1 GO TO 50 END IF 10 CONTINUE ELSE DO 20 I = 1, NV IF( DWORK(I).GE.ZERO ) THEN IWARN = 1 GO TO 50 END IF 20 CONTINUE END IF ELSE C C Check the anti-stability of the eigenvalues of AV. C IF ( DISCR ) THEN DO 30 I = 1, NV IF( DLAPY2( DWORK(I), DWORK(NV+I) ).LE.ONE) THEN IWARN = 1 GO TO 50 END IF 30 CONTINUE ELSE DO 40 I = 1, NV IF( DWORK(I).LE.ZERO ) THEN IWARN = 1 GO TO 50 END IF 40 CONTINUE END IF END IF 50 CONTINUE C END IF C IF( RIGHTW .AND. NW.GT.0 ) THEN C C Reduce AW to a real Schur form using an orthogonal similarity C transformation AW <- T'*AW*T and apply the transformation to C BW and CW: BW <- T'*BW and CW <- CW*T. C C Workspace needed: NW*(NW+5); C prefer larger. C KW = NW*( NW + 2 ) + 1 CALL TB01WD( NW, M, M, AW, LDAW, BW, LDBW, CW, LDCW, $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), DWORK(KW), $ LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 2 RETURN END IF WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) C IF( CONJS ) THEN C C Check the stability of the eigenvalues of AW. C IF ( DISCR ) THEN DO 60 I = 1, NW IF( DLAPY2( DWORK(I), DWORK(NW+I) ).GE.ONE) THEN IWARN = IWARN + 2 GO TO 100 END IF 60 CONTINUE ELSE DO 70 I = 1, NW IF( DWORK(I).GE.ZERO ) THEN IWARN = IWARN + 2 GO TO 100 END IF 70 CONTINUE END IF ELSE C C Check the anti-stability of the eigenvalues of AW. C IF ( DISCR ) THEN DO 80 I = 1, NW IF( DLAPY2( DWORK(I), DWORK(NW+I) ).LE.ONE) THEN IWARN = IWARN + 2 GO TO 100 END IF 80 CONTINUE ELSE DO 90 I = 1, NW IF( DWORK(I).LE.ZERO ) THEN IWARN = IWARN + 2 GO TO 100 END IF 90 CONTINUE END IF END IF 100 CONTINUE END IF C IF( LEFTW ) THEN LDW = MAX( NV, 1 ) KW = NV*N + 1 IF( CONJS ) THEN C C Compute the projection of conj(V)*G. C C Total workspace needed: NV*N + MAX( a, P*N, P*M ), where C a = 0, if DICO = 'C', C a = 2*NV, if DICO = 'D'. C C Compute -CV'*C. C Workspace needed: NV*N. C CALL DGEMM( 'T', 'N', NV, N, P, -ONE, CV, LDCV, C, LDC, $ ZERO, DWORK, LDW ) C IF( DISCR ) THEN C C Compute X and SCALE satisfying C C AV'*X*A - X = -SCALE*CV'*C. C C Additional workspace needed: 2*NV. C CALL SB04PY( 'T', 'N', -1, NV, N, AV, LDAV, A, LDA, $ DWORK, LDW, SCALE, DWORK(KW), IERR ) IF( IERR.NE.0 ) THEN INFO = 3 RETURN END IF C C Construct C <- DV'*C + BV'*X*A/SCALE, C D <- DV'*D + BV'*X*B/SCALE. C C Additional workspace needed: MAX( P*N, P*M ). C C C <- DV'*C. C CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC, $ ZERO, DWORK(KW), P ) CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) C C D <- DV'*D. C CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD, $ ZERO, DWORK(KW), P ) CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) C C C <- C + BV'*X*A/SCALE. C CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV, $ DWORK, LDW, ZERO, DWORK(KW), P ) CALL DGEMM( 'N', 'N', P, N, N, ONE, DWORK(KW), P, A, LDA, $ ONE, C, LDC ) C C D <- D + BV'*X*B/SCALE. C CALL DGEMM( 'N', 'N', P, M, N, ONE, DWORK(KW), P, B, LDB, $ ONE, D, LDD ) ELSE C C Compute X and SCALE satisfying C C AV'*X + X*A + SCALE*CV'*C = 0. C CALL DTRSYL( 'T', 'N', 1, NV, N, AV, LDAV, A, LDA, $ DWORK, LDW, SCALE, IERR ) IF( IERR.NE.0 ) THEN INFO = 3 RETURN END IF C C Construct C and D. C Additional workspace needed: MAX( P*N, P*M ). C C Construct C <- BV'*X/SCALE + DV'*C. C CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC, $ ZERO, DWORK(KW), P ) CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV, $ DWORK, LDW, ONE, C, LDC ) C C Construct D <- DV'*D. C CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD, $ ZERO, DWORK(KW), P ) CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) END IF ELSE C C Compute the projection of V*G. C C Total workspace needed: NV*N + MAX( P*N, P*M ). C C Compute -BV*C. C Workspace needed: NV*N. C CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, $ ZERO, DWORK, LDW ) C C Compute X and SCALE satisfying C C AV*X - X*A + SCALE*BV*C = 0. C CALL DTRSYL( 'N', 'N', -1, NV, N, AV, LDAV, A, LDA, $ DWORK, LDW, SCALE, IERR ) IF( IERR.NE.0 ) THEN INFO = 3 RETURN END IF C C Construct C <- CV*X/SCALE + DV*C. C CALL DGEMM( 'N', 'N', P, N, P, ONE, DV, LDDV, C, LDC, $ ZERO, DWORK(KW), P ) CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) CALL DGEMM( 'N', 'N', P, N, NV, ONE / SCALE, CV, LDCV, $ DWORK, LDW, ONE, C, LDC ) C C Construct D <- DV*D. C CALL DGEMM( 'N', 'N', P, M, P, ONE, DV, LDDV, D, LDD, $ ZERO, DWORK(KW), P ) CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) END IF END IF C IF( RIGHTW ) THEN LDWN = MAX( N, 1 ) KW = N*NW + 1 IF( CONJS ) THEN C C Compute the projection of G*conj(W) or of conj(V)*G*conj(W). C C Total workspace needed: NW*N + MAX( b, M*N, P*M ), where C b = 0, if DICO = 'C', C b = 2*NW, if DICO = 'D'. C C Compute -BW*B'. C Workspace needed: N*NW. C LDW = MAX( NW, 1 ) CALL DGEMM( 'N', 'T', NW, N, M, -ONE, BW, LDBW, B, LDB, $ ZERO, DWORK, LDW ) C IF( DISCR ) THEN C C Compute Y' and SCALE satisfying C C AW*Y'*A' - Y' = -SCALE*BW*B'. C C Additional workspace needed: 2*NW. C CALL SB04PY( 'N', 'T', -1, NW, N, AW, LDAW, A, LDA, $ DWORK, LDW, SCALE, DWORK(KW), IERR ) IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF C C Construct B <- B*DW' + A*Y*CW'/SCALE, C D <- D*DW' + C*Y*CW'/SCALE. C C Additional workspace needed: MAX( N*M, P*M ). C C B <- B*DW'. C CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW, $ ZERO, DWORK(KW), LDWN ) CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) C C D <- D*DW'. C CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW, $ ZERO, DWORK(KW), P ) CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) C C B <- B + A*Y*CW'/SCALE. C CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW, $ CW, LDCW, ZERO, DWORK(KW), LDWN ) CALL DGEMM( 'N', 'N', N, M, N, ONE, A, LDA, $ DWORK(KW), LDWN, ONE, B, LDB ) C C D <- D + C*Y*CW'/SCALE. C CALL DGEMM( 'N', 'N', P, M, N, ONE, C, LDC, $ DWORK(KW), LDWN, ONE, D, LDD ) ELSE C C Compute Y' and SCALE satisfying C C AW*Y' + Y'*A' + SCALE*BW*B' = 0. C CALL DTRSYL( 'N', 'T', 1, NW, N, AW, LDAW, A, LDA, $ DWORK, LDW, SCALE, IERR ) IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF C C Construct B and D. C Additional workspace needed: MAX( N*M, P*M ). C C Construct B <- B*DW' + Y*CW'/SCALE. C CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW, $ ZERO, DWORK(KW), LDWN ) CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW, $ CW, LDCW, ONE, B, LDB) C C D <- D*DW'. C CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW, $ ZERO, DWORK(KW), P ) CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) END IF ELSE C C Compute the projection of G*W or of V*G*W. C C Total workspace needed: NW*N + MAX( M*N, P*M ). C C Compute B*CW. C Workspace needed: N*NW. C CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, $ ZERO, DWORK, LDWN ) C C Compute Y and SCALE satisfying C C A*Y - Y*AW - SCALE*B*CW = 0. C CALL DTRSYL( 'N', 'N', -1, N, NW, A, LDA, AW, LDAW, $ DWORK, LDWN, SCALE, IERR ) IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF C C Construct B and D. C Additional workspace needed: MAX( N*M, P*M ). C Construct B <- B*DW + Y*BW/SCALE. C CALL DGEMM( 'N', 'N', N, M, M, ONE, B, LDB, DW, LDDW, $ ZERO, DWORK(KW), LDWN ) CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) CALL DGEMM( 'N', 'N', N, M, NW, ONE / SCALE, DWORK, LDWN, $ BW, LDBW, ONE, B, LDB) C C D <- D*DW. C CALL DGEMM( 'N', 'N', P, M, M, ONE, D, LDD, DW, LDDW, $ ZERO, DWORK(KW), P ) CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) END IF END IF C DWORK(1) = MAX( WORK, DBLE( LW ) ) C RETURN C *** Last line of AB09KX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04DZ.f0000644000000000000000000000013215012430707016175 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04DZ.f0000644000175000017500000003714315012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE MB04DZ( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) C C PURPOSE C C To balance a complex Hamiltonian matrix, C C [ A G ] C H = [ H ] , C [ Q -A ] C C where A is an N-by-N matrix and G, Q are N-by-N Hermitian C matrices. This involves, first, permuting H by a symplectic C similarity transformation to isolate eigenvalues in the first C 1:ILO-1 elements on the diagonal of A; and second, applying a C diagonal similarity transformation to rows and columns C ILO:N, N+ILO:2*N to make the rows and columns as close in 1-norm C as possible. Both steps are optional. Assuming ILO = 1, let D be a C diagonal matrix of order N with the scaling factors on the C diagonal. The scaled Hamiltonian is defined by C C [ D**-1*A*D D**-1*G*D**-1 ] C Hs = [ H ] . C [ D*Q*D -D*A *D**-1 ] C C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the operations to be performed on H: C = 'N': none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N; C = 'P': permute only; C = 'S': scale only; C = 'B': both permute and scale. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the matrix A. C On exit, the leading N-by-N part of this array contains C the matrix A of the balanced Hamiltonian. In particular, C the strictly lower triangular part of the first ILO-1 C columns of A is zero. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input/output) COMPLEX*16 array, dimension C (LDQG,N+1) C On entry, the leading N-by-N+1 part of this array must C contain the lower triangular part of the matrix Q and C the upper triangular part of the matrix G. C On exit, the leading N-by-N+1 part of this array contains C the lower and upper triangular parts of the matrices Q and C G, respectively, of the balanced Hamiltonian. In C particular, the lower triangular part of the first ILO-1 C columns of QG is zero. C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C ILO (output) INTEGER C ILO-1 is the number of deflated eigenvalues in the C balanced Hamiltonian matrix. C C SCALE (output) DOUBLE PRECISION array of dimension (N) C Details of the permutations and scaling factors applied to C H. For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N, C then rows and columns P(j) and P(j)+N are interchanged C with rows and columns j and j+N, respectively. If C P(j) > N, then row and column P(j)-N are interchanged with C row and column j+N by a generalized symplectic C permutation. For j = ILO,...,N the j-th element of SCALE C contains the factor of the scaling applied to row and C column j. 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] Benner, P. C Symplectic balancing of Hamiltonian matrices. C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2001. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2011. C Based on the SLICOT Library routine MB04DD. C C REVISIONS C C V. Sima, Mar. 2016. C C KEYWORDS C C Balancing, Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER ILO, INFO, LDA, LDQG, N C .. Array Arguments .. DOUBLE PRECISION SCALE(*) COMPLEX*16 A(LDA,*), QG(LDQG,*) C .. Local Scalars .. LOGICAL CONV, LPERM, LSCAL INTEGER I, IC, ILOOLD, J DOUBLE PRECISION C, F, GII, MAXC, MAXR, QII, R, SCLFAC, $ SFMAX1, SFMAX2, SFMIN1, SFMIN2 COMPLEX*16 CDUM C .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH, DZASUM EXTERNAL DLAMCH, DZASUM, IZAMAX, LSAME C .. External Subroutines .. EXTERNAL XERBLA, ZDRSCL, ZDSCAL, ZSWAP C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG, MAX, MIN C .. Statement Functions .. DOUBLE PRECISION CABS1 C .. C .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) C IF ( .NOT.LPERM .AND. .NOT.LSCAL .AND. $ .NOT.LSAME( JOB, 'N' ) ) THEN INFO = -1 ELSE IF ( N.LT.0 ) THEN INFO = -2 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN INFO = -6 END IF C C Return if there were illegal values. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04DZ', -INFO ) RETURN END IF C ILO = 1 C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN DO 10 I = 1, N SCALE(I) = ONE 10 CONTINUE RETURN END IF C C Permutations to isolate eigenvalues if possible. C IF ( LPERM ) THEN ILOOLD = 0 C WHILE ( ILO.NE.ILOOLD ) 20 CONTINUE IF ( ILO.NE.ILOOLD ) THEN ILOOLD = ILO C C Scan columns ILO .. N. C I = ILO C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) 30 CONTINUE IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN DO 40 J = ILO, I-1 IF ( DBLE( A(J,I) ).NE.ZERO .OR. $ DIMAG( A(J,I) ).NE.ZERO ) THEN I = I + 1 GO TO 30 END IF 40 CONTINUE DO 50 J = I+1, N IF ( DBLE( A(J,I) ).NE.ZERO .OR. $ DIMAG( A(J,I) ).NE.ZERO ) THEN I = I + 1 GO TO 30 END IF 50 CONTINUE DO 60 J = ILO, I IF ( DBLE( QG(I,J) ).NE.ZERO .OR. $ DIMAG( QG(I,J) ).NE.ZERO ) THEN I = I + 1 GO TO 30 END IF 60 CONTINUE DO 70 J = I+1, N IF ( DBLE( QG(J,I) ).NE.ZERO .OR. $ DIMAG( QG(J,I) ).NE.ZERO ) THEN I = I + 1 GO TO 30 END IF 70 CONTINUE C C Exchange columns/rows ILO <-> I. C SCALE( ILO ) = DBLE( I ) IF ( ILO.NE.I ) THEN C CALL ZSWAP( N, A(1,ILO), 1, A(1,I), 1 ) CALL ZSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) C CALL ZSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) CALL ZSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) CALL ZSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) C CALL ZSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) CALL ZSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), $ LDQG ) CALL ZSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), $ 1 ) END IF ILO = ILO + 1 END IF C END WHILE 30 C C Scan columns N+ILO .. 2*N. C I = ILO C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) 80 CONTINUE IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN DO 90 J = ILO, I-1 IF ( DBLE( A(I,J) ).NE.ZERO .OR. $ DIMAG( A(I,J) ).NE.ZERO ) THEN I = I + 1 GO TO 80 END IF 90 CONTINUE DO 100 J = I+1, N IF ( DBLE( A(I,J) ).NE.ZERO .OR. $ DIMAG( A(I,J) ).NE.ZERO ) THEN I = I + 1 GO TO 80 END IF 100 CONTINUE DO 110 J = ILO, I IF ( DBLE( QG(J,I+1) ).NE.ZERO .OR. $ DIMAG( QG(J,I+1) ).NE.ZERO ) THEN I = I + 1 GO TO 80 END IF 110 CONTINUE DO 120 J = I+1, N IF ( DBLE( QG(I,J+1) ).NE.ZERO .OR. $ DIMAG( QG(I,J+1) ).NE.ZERO ) THEN I = I + 1 GO TO 80 END IF 120 CONTINUE SCALE( ILO ) = DBLE( N+I ) C C Exchange columns/rows I <-> I+N with a symplectic C generalized permutation. C CALL ZSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG ) CALL ZDSCAL( I-ILO, -ONE, A(I,ILO), LDA ) CALL ZSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 ) CALL ZDSCAL( N-I, -ONE, A(I,I+1), LDA ) CALL ZSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 ) CALL ZDSCAL( I-1, -ONE, A(1,I), 1 ) CALL ZSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG ) CALL ZDSCAL( N-I, -ONE, A(I+1,I), 1 ) A(I,I) = -A (I,I) CDUM = QG(I,I) QG(I,I) = -QG(I,I+1) QG(I,I+1) = -CDUM C C Exchange columns/rows ILO <-> I. C IF ( ILO.NE.I ) THEN C CALL ZSWAP( N, A(1,ILO), 1, A(1,I), 1 ) CALL ZSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) C CALL ZSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) CALL ZSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) CALL ZSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) C CALL ZSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) CALL ZSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), $ LDQG ) CALL ZSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), $ 1 ) END IF ILO = ILO + 1 END IF C END WHILE 80 GO TO 20 END IF C END WHILE 20 END IF C DO 130 I = ILO, N SCALE(I) = ONE 130 CONTINUE C C Scale to reduce the 1-norm of the remaining blocks. C IF ( LSCAL ) THEN SCLFAC = DLAMCH( 'B' ) SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 C C Scale the rows and columns one at a time to minimize the C 1-norm of the remaining Hamiltonian submatrix. C Stop when the 1-norm is very roughly minimal. C 140 CONTINUE CONV = .TRUE. DO 170 I = ILO, N C C Compute 1-norm of row and column I without diagonal C elements. C R = DZASUM( I-ILO, A(I,ILO), LDA ) + $ DZASUM( N-I, A(I,I+1), LDA ) + $ DZASUM( I-ILO, QG(ILO,I+1), 1 ) + $ DZASUM( N-I, QG(I,I+2), LDQG ) C = DZASUM( I-ILO, A(ILO,I), 1 ) + $ DZASUM( N-I, A(I+1,I), 1 ) + $ DZASUM( I-ILO, QG(I,ILO), LDQG ) + $ DZASUM( N-I, QG(I+1,I), 1 ) QII = CABS1( QG(I,I) ) GII = CABS1( QG(I,I+1) ) C C Compute inf-norms of row and column I. C IC = IZAMAX( N-ILO+1, A(I,ILO), LDA ) MAXR = CABS1( A(I,IC+ILO-1) ) IF ( I.GT.1 ) THEN IC = IZAMAX( I-1, QG(1,I+1), 1 ) MAXR = MAX( MAXR, CABS1( QG(IC,I+1) ) ) END IF IF ( N.GT.I ) THEN IC = IZAMAX( N-I, QG(I,I+2), LDQG ) MAXR = MAX( MAXR, CABS1( QG(I,IC+I+1) ) ) END IF IC = IZAMAX( N, A(1,I), 1 ) MAXC = CABS1( A(IC,I) ) IF ( I.GT.ILO ) THEN IC = IZAMAX( I-ILO, QG(I,ILO), LDQG ) MAXC = MAX( MAXC, CABS1( QG(I,IC+ILO-1) ) ) END IF IF ( N.GT.I ) THEN IC = IZAMAX( N-I, QG(I+1,I), 1 ) MAXC = MAX( MAXC, CABS1( QG(IC+I,I) ) ) END IF IF ( ( C + QII ).EQ.ZERO .OR. ( R + GII ).EQ.ZERO ) $ GO TO 170 C F = ONE 150 CONTINUE IF ( ( ( R + GII/SCLFAC )/SCLFAC ).GE. $ ( ( C + QII*SCLFAC )*SCLFAC ) .AND. $ MAX( F*SCLFAC, C*SCLFAC, MAXC*SCLFAC, $ QII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. $ MIN( ( R + GII/SCLFAC )/SCLFAC, MAX( MAXR/SCLFAC, $ GII/SCLFAC/SCLFAC ) ).GT.SFMIN2 ) THEN F = F*SCLFAC C = C*SCLFAC QII = QII*SCLFAC*SCLFAC R = R / SCLFAC GII = GII/SCLFAC/SCLFAC MAXC = MAXC*SCLFAC MAXR = MAXR/SCLFAC GO TO 150 END IF C 160 CONTINUE IF ( ( ( R + GII*SCLFAC )*SCLFAC ).LE. $ ( ( C + QII/SCLFAC )/SCLFAC ) .AND. $ MAX( R*SCLFAC, MAXR*SCLFAC, $ GII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. $ MIN( F/SCLFAC, ( C + QII/SCLFAC )/SCLFAC, $ MAX( MAXC/SCLFAC, QII/SCLFAC/SCLFAC ) ) $ .GT.SFMIN2 ) THEN F = F / SCLFAC C = C / SCLFAC QII = QII/SCLFAC/SCLFAC R = R * SCLFAC GII = GII*SCLFAC*SCLFAC MAXC = MAXC/SCLFAC MAXR = MAXR*SCLFAC GO TO 160 END IF C C Now balance if necessary. C IF ( F.NE.ONE ) THEN IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN IF ( F*SCALE(I).LE.SFMIN1 ) $ GO TO 170 END IF IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN IF ( SCALE(I).GE.SFMAX1 / F ) $ GO TO 170 END IF CONV = .FALSE. SCALE(I) = SCALE(I)*F CALL ZDRSCL( I-ILO, F, A(I,ILO), LDA ) CALL ZDRSCL( N-I, F, A(I,I+1), LDA ) CALL ZDSCAL( I-1, F, A(1,I), 1 ) CALL ZDSCAL( N-I, F, A(I+1,I), 1 ) CALL ZDRSCL( I-1, F, QG(1,I+1), 1 ) QG(I,I+1) = QG(I,I+1) / F / F CALL ZDRSCL( N-I, F, QG(I,I+1+1), LDQG ) CALL ZDSCAL( I-ILO, F, QG(I,ILO), LDQG ) QG(I,I) = QG(I,I) * F * F CALL ZDSCAL( N-I, F, QG(I+1,I), 1 ) END IF 170 CONTINUE IF ( .NOT.CONV ) GO TO 140 END IF RETURN C *** Last line of MB04DZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04IY.f0000644000000000000000000000013215012430707016201 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04IY.f0000644000175000017500000002327615012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE MB04IY( SIDE, TRANS, N, M, K, P, A, LDA, TAU, C, LDC, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To overwrite the real n-by-m matrix C with Q' * C, Q * C, C C * Q', or C * Q, according to the following table C C SIDE = 'L' SIDE = 'R' C TRANS = 'N': Q * C C * Q C TRANS = 'T': Q'* C C * Q' C C where Q is a real orthogonal matrix defined as the product of C k elementary reflectors C C Q = H(1) H(2) . . . H(k) C C as returned by SLICOT Library routine MB04ID. Q is of order n C if SIDE = 'L' and of order m if SIDE = 'R'. C C ARGUMENTS C C Mode Parameters C C SIDE CHARACTER*1 C Specify if Q or Q' is applied from the left or right, C as follows: C = 'L': apply Q or Q' from the left; C = 'R': apply Q or Q' from the right. C C TRANS CHARACTER*1 C Specify if Q or Q' is to be applied, as follows: C = 'N': apply Q (No transpose); C = 'T': apply Q' (Transpose). C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix C. N >= 0. C C M (input) INTEGER C The number of columns of the matrix C. M >= 0. C C K (input) INTEGER C The number of elementary reflectors whose product defines C the matrix Q. C N >= K >= 0, if SIDE = 'L'; C M >= K >= 0, if SIDE = 'R'. C C P (input) INTEGER C The order of the zero triagle (or the number of rows of C the zero trapezoid) in the matrix triangularized by SLICOT C Library routine MB04ID. P >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,K) C On input, the elements in the rows i+1:min(n,n-p-1+i) of C the i-th column, and TAU(i), represent the orthogonal C reflector H(i), so that matrix Q is the product of C elementary reflectors: Q = H(1) H(2) . . . H(k). C A is modified by the routine but restored on exit. C C LDA INTEGER C The leading dimension of the array A. C LDA >= max(1,N), if SIDE = 'L'; C LDA >= max(1,M), if SIDE = 'R'. C C TAU (input) DOUBLE PRECISION array, dimension (K) C The scalar factors of the elementary reflectors. 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 matrix C. C On exit, the leading N-by-M part of this array contains C the updated matrix C. C C LDC INTEGER C The leading dimension of the array C. LDC >= max(1,N). 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 length of the array DWORK. C LDWORK >= MAX(1,M), if SIDE = 'L'; C LDWORK >= MAX(1,N), if SIDE = 'R'. C For optimum performance LDWORK >= M*NB if SIDE = 'L', C or LDWORK >= N*NB if SIDE = 'R', where NB is the optimal C block size. 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 If SIDE = 'L', each elementary reflector H(i) modifies C n-p elements of each column of C, for i = 1:p+1, and C n-i+1 elements, for i = p+2:k. C If SIDE = 'R', each elementary reflector H(i) modifies C m-p elements of each row of C, for i = 1:p+1, and C m-i+1 elements, for i = p+2:k. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. C C REVISIONS C C - C C KEYWORDS C C Matrix operations, QR decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) C .. Scalar Arguments .. INTEGER INFO, K, LDA, LDC, LDWORK, M, N, P CHARACTER SIDE, TRANS C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), TAU( * ) C .. Local Scalars .. LOGICAL LEFT, TRAN INTEGER I DOUBLE PRECISION AII, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARF, DORMQR, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C .. Executable Statements .. C C Check the scalar input arguments. C INFO = 0 LEFT = LSAME( SIDE, 'L' ) TRAN = LSAME( TRANS, 'T' ) C IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. ( LEFT .AND. K.GT.N ) .OR. $ ( .NOT.LEFT .AND. K.GT.M ) ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( ( LEFT .AND. LDA.LT.MAX( 1, N ) ) .OR. $ ( .NOT.LEFT .AND. LDA.LT.MAX( 1, M ) ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( ( LEFT .AND. LDWORK.LT.MAX( 1, M ) ) .OR. $ ( .NOT.LEFT .AND. LDWORK.LT.MAX( 1, N ) ) ) THEN INFO = -13 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04IY', -INFO ) RETURN END IF C C Quick return if possible. C IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 .OR. ( LEFT .AND. N.LT.P ) $ .OR. ( .NOT.LEFT .AND. M.LT.P ) ) THEN DWORK(1) = ONE RETURN 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 NB refers to the optimal block size for the immediately C following subroutine, as returned by ILAENV.) C IF( LEFT ) THEN WRKOPT = DBLE( M ) IF( TRAN ) THEN C DO 10 I = 1, MIN( K, P ) C C Apply H(i) to C(i:i+n-p-1,1:m), from the left. C Workspace: need M. C AII = A( I, I ) A( I, I ) = ONE CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), $ C( I, 1 ), LDC, DWORK ) A( I, I ) = AII 10 CONTINUE C IF ( P.LE.MIN( N, K ) ) THEN C C Apply H(i) to C, i = p+1:k, from the left. C Workspace: need M; prefer M*NB. C CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, $ LDWORK, I ) WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) END IF C ELSE C IF ( P.LE.MIN( N, K ) ) THEN C C Apply H(i) to C, i = k:p+1:-1, from the left. C Workspace: need M; prefer M*NB. C CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, $ LDWORK, I ) WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) END IF C DO 20 I = MIN( K, P ), 1, -1 C C Apply H(i) to C(i:i+n-p-1,1:m), from the left. C Workspace: need M. C AII = A( I, I ) A( I, I ) = ONE CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), $ C( I, 1 ), LDC, DWORK ) A( I, I ) = AII 20 CONTINUE END IF C ELSE C WRKOPT = DBLE( N ) IF( TRAN ) THEN C IF ( P.LE.MIN( M, K ) ) THEN C C Apply H(i) to C, i = k:p+1:-1, from the right. C Workspace: need N; prefer N*NB. C CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, $ LDWORK, I ) WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) END IF C DO 30 I = MIN( K, P ), 1, -1 C C Apply H(i) to C(1:n,i:i+m-p-1), from the right. C Workspace: need N. C AII = A( I, I ) A( I, I ) = ONE CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), $ C( 1, I ), LDC, DWORK ) A( I, I ) = AII 30 CONTINUE C ELSE C DO 40 I = 1, MIN( K, P ) C C Apply H(i) to C(1:n,i:i+m-p-1), from the right. C Workspace: need N. C AII = A( I, I ) A( I, I ) = ONE CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), $ C( 1, I ), LDC, DWORK ) A( I, I ) = AII 40 CONTINUE C IF ( P.LE.MIN( M, K ) ) THEN C C Apply H(i) to C, i = p+1:k, from the right. C Workspace: need N; prefer N*NB. C CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, $ LDWORK, I ) WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) END IF C END IF END IF C DWORK( 1 ) = WRKOPT RETURN C C *** Last line of MB04IY *** END control-4.1.2/src/slicot/src/PaxHeaders/dlatzm.f0000644000000000000000000000013215012430707016570 xustar0030 mtime=1747595719.993101108 30 atime=1747595719.993101108 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/dlatzm.f0000644000175000017500000001356315012430707017774 0ustar00lilgelilge00000000000000*> \brief \b DLATZM * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly *> Download DLATZM + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] *> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * * .. Scalar Arguments .. * CHARACTER SIDE * INTEGER INCV, LDC, M, N * DOUBLE PRECISION TAU * .. * .. Array Arguments .. * DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine DORMRZ. *> *> DLATZM applies a Householder matrix generated by DTZRQF to a matrix. *> *> Let P = I - tau*u*u**T, u = ( 1 ), *> ( v ) *> where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if *> SIDE = 'R'. *> *> If SIDE equals 'L', let *> C = [ C1 ] 1 *> [ C2 ] m-1 *> n *> Then C is overwritten by P*C. *> *> If SIDE equals 'R', let *> C = [ C1, C2 ] m *> 1 n-1 *> Then C is overwritten by C*P. *> \endverbatim * * Arguments: * ========== * *> \param[in] SIDE *> \verbatim *> SIDE is CHARACTER*1 *> = 'L': form P * C *> = 'R': form C * P *> \endverbatim *> *> \param[in] M *> \verbatim *> M is INTEGER *> The number of rows of the matrix C. *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The number of columns of the matrix C. *> \endverbatim *> *> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension *> (1 + (M-1)*abs(INCV)) if SIDE = 'L' *> (1 + (N-1)*abs(INCV)) if SIDE = 'R' *> The vector v in the representation of P. V is not used *> if TAU = 0. *> \endverbatim *> *> \param[in] INCV *> \verbatim *> INCV is INTEGER *> The increment between elements of v. INCV <> 0 *> \endverbatim *> *> \param[in] TAU *> \verbatim *> TAU is DOUBLE PRECISION *> The value tau in the representation of P. *> \endverbatim *> *> \param[in,out] C1 *> \verbatim *> C1 is DOUBLE PRECISION array, dimension *> (LDC,N) if SIDE = 'L' *> (M,1) if SIDE = 'R' *> On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 *> if SIDE = 'R'. *> *> On exit, the first row of P*C if SIDE = 'L', or the first *> column of C*P if SIDE = 'R'. *> \endverbatim *> *> \param[in,out] C2 *> \verbatim *> C2 is DOUBLE PRECISION array, dimension *> (LDC, N) if SIDE = 'L' *> (LDC, N-1) if SIDE = 'R' *> On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the *> m x (n - 1) matrix C2 if SIDE = 'R'. *> *> On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P *> if SIDE = 'R'. *> \endverbatim *> *> \param[in] LDC *> \verbatim *> LDC is INTEGER *> The leading dimension of the arrays C1 and C2. LDC >= (1,M). *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension *> (N) if SIDE = 'L' *> (M) if SIDE = 'R' *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \ingroup doubleOTHERcomputational * * ===================================================================== SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DGER * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) ) $ RETURN * IF( LSAME( SIDE, 'L' ) ) THEN * * w := (C1 + v**T * C2)**T * CALL DCOPY( N, C1, LDC, WORK, 1 ) CALL DGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE, $ WORK, 1 ) * * [ C1 ] := [ C1 ] - tau* [ 1 ] * w**T * [ C2 ] [ C2 ] [ v ] * CALL DAXPY( N, -TAU, WORK, 1, C1, LDC ) CALL DGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC ) * ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * w := C1 + C2 * v * CALL DCOPY( M, C1, 1, WORK, 1 ) CALL DGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE, $ WORK, 1 ) * * [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v**T] * CALL DAXPY( M, -TAU, WORK, 1, C1, 1 ) CALL DGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC ) END IF * RETURN * * End of DLATZM * END control-4.1.2/src/slicot/src/PaxHeaders/MB04OW.f0000644000000000000000000000013215012430707016205 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04OW.f0000644000175000017500000001760215012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE MB04OW( M, N, P, A, LDA, T, LDT, X, INCX, B, LDB, $ C, LDC, D, INCD ) C C PURPOSE C C To perform the QR factorization C C ( U ) = Q*( R ), where U = ( U1 U2 ), R = ( R1 R2 ), C ( x' ) ( 0 ) ( 0 T ) ( 0 R3 ) C C where U and R are (m+n)-by-(m+n) upper triangular matrices, x is C an m+n element vector, U1 is m-by-m, T is n-by-n, stored C separately, and Q is an (m+n+1)-by-(m+n+1) orthogonal matrix. C C The matrix ( U1 U2 ) must be supplied in the m-by-(m+n) upper C trapezoidal part of the array A and this is overwritten by the C corresponding part ( R1 R2 ) of R. The remaining upper triangular C part of R, R3, is overwritten on the array T. C C The transformations performed are also applied to the (m+n+1)-by-p C matrix ( B' C' d )' (' denotes transposition), where B, C, and d' C are m-by-p, n-by-p, and 1-by-p matrices, respectively. C C ARGUMENTS C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrix ( U1 U2 ). M >= 0. C C N (input) INTEGER C The order of the matrix T. N >= 0. C C P (input) INTEGER C The number of columns of the matrices B and C. P >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading M-by-(M+N) upper trapezoidal part of C this array must contain the upper trapezoidal matrix C ( U1 U2 ). C On exit, the leading M-by-(M+N) upper trapezoidal part of C this array contains the upper trapezoidal matrix ( R1 R2 ). C The strict lower triangle of A is not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the upper triangular matrix T. C On exit, the leading N-by-N upper triangular part of this C array contains the upper triangular matrix R3. C The strict lower triangle of T is not referenced. C C LDT INTEGER C The leading dimension of the array T. LDT >= max(1,N). C C X (input/output) DOUBLE PRECISION array, dimension C (1+(M+N-1)*INCX), if M+N > 0, or dimension (0), if M+N = 0. C On entry, the incremented array X must contain the C vector x. On exit, the content of X is changed. C C INCX (input) INTEGER C Specifies the increment for the elements of X. INCX > 0. C C B (input/output) DOUBLE PRECISION array, dimension (LDB,P) C On entry, the leading M-by-P part of this array must C contain the matrix B. C On exit, the leading M-by-P part of this array contains C the transformed matrix B. C If M = 0 or P = 0, this array is not referenced. C C LDB INTEGER C The leading dimension of the array B. C LDB >= max(1,M), if P > 0; C LDB >= 1, if P = 0. C C C (input/output) DOUBLE PRECISION array, dimension (LDC,P) C On entry, the leading N-by-P part of this array must C contain the matrix C. C On exit, the leading N-by-P part of this array contains C the transformed matrix C. C If N = 0 or P = 0, this array is not referenced. C C LDC INTEGER C The leading dimension of the array C. C LDC >= max(1,N), if P > 0; C LDC >= 1, if P = 0. C C D (input/output) DOUBLE PRECISION array, dimension C (1+(P-1)*INCD), if P > 0, or dimension (0), if P = 0. C On entry, the incremented array D must contain the C vector d. C On exit, this incremented array contains the transformed C vector d. C If P = 0, this array is not referenced. C C INCD (input) INTEGER C Specifies the increment for the elements of D. INCD > 0. C C METHOD C C Let q = m+n. The matrix Q is formed as a sequence of plane C rotations in planes (1, q+1), (2, q+1), ..., (q, q+1), the C rotation in the (j, q+1)th plane, Q(j), being chosen to C annihilate the jth element of x. C C NUMERICAL ASPECTS C C The algorithm requires 0((M+N)*(M+N+P)) operations and is backward C stable. C C FURTHER COMMENTS C C For P = 0, this routine produces the same result as SLICOT Library C routine MB04OX, but matrix T may not be stored in the array A. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C - C C KEYWORDS C C Matrix operations, plane rotations. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INCD, INCX, LDA, LDB, LDC, LDT, M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*), T(LDT,*), $ X(*) C .. Local Scalars .. DOUBLE PRECISION CI, SI, TEMP INTEGER I, IX, MN C .. External Subroutines .. EXTERNAL DLARTG, DROT C C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked. C MN = M + N IF ( INCX.GT.1 ) THEN C C Code for increment INCX > 1. C IX = 1 IF ( M.GT.0 ) THEN C DO 10 I = 1, M - 1 CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP ) A(I,I) = TEMP IX = IX + INCX CALL DROT( MN-I, A(I,I+1), LDA, X(IX), INCX, CI, SI ) IF ( P.GT.0 ) $ CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI ) 10 CONTINUE C CALL DLARTG( A(M,M), X(IX), CI, SI, TEMP ) A(M,M) = TEMP IX = IX + INCX IF ( N.GT.0 ) $ CALL DROT( N, A(M,M+1), LDA, X(IX), INCX, CI, SI ) IF ( P.GT.0 ) $ CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI ) END IF C IF ( N.GT.0 ) THEN C DO 20 I = 1, N - 1 CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP ) T(I,I) = TEMP IX = IX + INCX CALL DROT( N-I, T(I,I+1), LDT, X(IX), INCX, CI, SI ) IF ( P.GT.0 ) $ CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI ) 20 CONTINUE C CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP ) T(N,N) = TEMP IF ( P.GT.0 ) $ CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI ) END IF C ELSEIF ( INCX.EQ.1 ) THEN C C Code for increment INCX = 1. C IF ( M.GT.0 ) THEN C DO 30 I = 1, M - 1 CALL DLARTG( A(I,I), X(I), CI, SI, TEMP ) A(I,I) = TEMP CALL DROT( MN-I, A(I,I+1), LDA, X(I+1), 1, CI, SI ) IF ( P.GT.0 ) $ CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI ) 30 CONTINUE C CALL DLARTG( A(M,M), X(M), CI, SI, TEMP ) A(M,M) = TEMP IF ( N.GT.0 ) $ CALL DROT( N, A(M,M+1), LDA, X(M+1), 1, CI, SI ) IF ( P.GT.0 ) $ CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI ) END IF C IF ( N.GT.0 ) THEN IX = M + 1 C DO 40 I = 1, N - 1 CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP ) T(I,I) = TEMP IX = IX + 1 CALL DROT( N-I, T(I,I+1), LDT, X(IX), 1, CI, SI ) IF ( P.GT.0 ) $ CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI ) 40 CONTINUE C CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP ) T(N,N) = TEMP IF ( P.GT.0 ) $ CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI ) END IF END IF C RETURN C *** Last line of MB04OW *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10LD.f0000644000000000000000000000013215012430707016162 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB10LD.f0000644000175000017500000003277315012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the matrices of the closed-loop system C C | AC | BC | C G = |----|----|, C | CC | DC | C C from the matrices of the open-loop system C C | A | B | C P = |---|---| C | C | D | C C and the matrices of the controller C C | AK | BK | C K = |----|----|. C | CK | DK | 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 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 (input) DOUBLE PRECISION array, dimension (LDAK,N) C The leading N-by-N part of this array must contain 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 (input) DOUBLE PRECISION array, dimension (LDBK,NMEAS) C The leading N-by-NMEAS part of this array must contain 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 (input) DOUBLE PRECISION array, dimension (LDCK,N) C The leading NCON-by-N part of this array must contain 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 (input) DOUBLE PRECISION array, dimension (LDDK,NMEAS) C The leading NCON-by-NMEAS part of this array must contain C the controller input/output matrix DK. C C LDDK INTEGER C The leading dimension of the array DK. C LDDK >= max(1,NCON). C C AC (output) DOUBLE PRECISION array, dimension (LDAC,2*N) C The leading 2*N-by-2*N part of this array contains the C closed-loop system state matrix AC. C C LDAC INTEGER C The leading dimension of the array AC. C LDAC >= max(1,2*N). C C BC (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON) C The leading 2*N-by-(M-NCON) part of this array contains C the closed-loop system input matrix BC. C C LDBC INTEGER C The leading dimension of the array BC. C LDBC >= max(1,2*N). C C CC (output) DOUBLE PRECISION array, dimension (LDCC,2*N) C The leading (NP-NMEAS)-by-2*N part of this array contains C the closed-loop system output matrix CC. C C LDCC INTEGER C The leading dimension of the array CC. C LDCC >= max(1,NP-NMEAS). C C DC (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON) C The leading (NP-NMEAS)-by-(M-NCON) part of this array C contains the closed-loop system input/output matrix DC. C C LDDC INTEGER C The leading dimension of the array DC. C LDDC >= max(1,NP-NMEAS). C C Workspace C C IWORK INTEGER array, dimension (2*max(NCON,NMEAS)) 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 >= 2*M*M+NP*NP+2*M*N+M*NP+2*N*NP. C For good performance, LDWORK must generally be larger. C C Error Indicactor 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 Inp2 - D22*DK is singular to working C precision; C = 2: if the matrix Im2 - DK*D22 is singular to working C precision. C C METHOD C C The routine implements the formulas given in [1]. C C REFERENCES C C [1] 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 NUMERICAL ASPECTS C C The accuracy of the result depends on the condition numbers of the C matrices Inp2 - D22*DK and Im2 - DK*D22. 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 A. Markovski, Technical University, Sofia, April, 2003. C C KEYWORDS C C Closed loop systems, feedback control, robust 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, LDAC, LDAK, LDB, LDBC, LDBK, LDC, $ LDCC, LDCK, LDD, LDDC, LDDK, LDWORK, M, N, $ NCON, NMEAS, NP C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), AK( LDAK, * ), $ B( LDB, * ), BC( LDBC, * ), BK( LDBK, * ), $ C( LDC, * ), CC( LDCC, * ), CK( LDCK, * ), $ D( LDD, * ), DC( LDDC, * ), DK( LDDK, * ), $ DWORK( * ) C .. C .. Local Scalars .. INTEGER INFO2, IW2, IW3, IW4, IW5, IW6, IW7, IW8, IWRK, $ LWAMAX, M1, M2, MINWRK, N2, NP1, NP2 DOUBLE PRECISION ANORM, EPS, RCOND C .. C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE C .. C .. External Subroutines .. EXTERNAL DGECON, DGEMM, DGETRF, DGETRI, DLACPY, DLASET, $ XERBLA C .. C .. Executable Statements .. C C Decode and Test input parameters. C N2 = 2*N 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -11 ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN INFO = -13 ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN INFO = -19 ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN INFO = -21 ELSE IF( LDAC.LT.MAX( 1, N2 ) ) THEN INFO = -23 ELSE IF( LDBC.LT.MAX( 1, N2 ) ) THEN INFO = -25 ELSE IF( LDCC.LT.MAX( 1, NP1 ) ) THEN INFO = -27 ELSE IF( LDDC.LT.MAX( 1, NP1 ) ) THEN INFO = -29 ELSE C C Compute workspace. C MINWRK = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP IF( LDWORK.LT.MINWRK ) $ INFO = -32 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10LD', -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 DWORK( 1 ) = ONE RETURN END IF C C Get the machine precision. C EPS = DLAMCH( 'Epsilon' ) C C Workspace usage. C IW2 = NP2*NP2 + 1 IW3 = IW2 + M2*M2 IW4 = IW3 + NP2*N IW5 = IW4 + M2*N IW6 = IW5 + NP2*M1 IW7 = IW6 + M2*M1 IW8 = IW7 + M2*N IWRK = IW8 + NP2*N C C Compute inv(Inp2 - D22*DK) . C CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK, NP2 ) CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, D( NP1+1, M1+1 ), $ LDD, DK, LDDK, ONE, DWORK, NP2 ) ANORM = DLANGE( '1', NP2, NP2, DWORK, NP2, DWORK( IWRK ) ) CALL DGETRF( NP2, NP2, DWORK, NP2, IWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF CALL DGECON( '1', NP2, DWORK, NP2, ANORM, RCOND, DWORK( IWRK ), $ IWORK( NP2+1 ), INFO ) LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 C C Return if the matrix is singular to working precision. C IF( RCOND.LT.EPS ) THEN INFO = 1 RETURN END IF CALL DGETRI( NP2, DWORK, NP2, IWORK, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO2 ) LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Compute inv(Im2 - DK*D22) . C CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) CALL DGEMM( 'N', 'N', M2, M2, NP2, -ONE, DK, LDDK, $ D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 ) ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 2 RETURN END IF CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND, $ DWORK( IWRK ), IWORK( M2+1 ), INFO ) LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Return if the matrix is singular to working precision. C IF( RCOND.LT.EPS ) THEN INFO = 2 RETURN END IF CALL DGETRI( M2, DWORK( IW2 ), M2, IWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO2 ) LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Compute inv(Inp2 - D22*DK)*C2 . C CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, DWORK, NP2, C( NP1+1, 1 ), $ LDC, ZERO, DWORK( IW3 ), NP2 ) C C Compute DK*inv(Inp2 - D22*DK)*C2 . C CALL DGEMM( 'N', 'N', M2, N, NP2, ONE, DK, LDDK, DWORK( IW3 ), $ NP2, ZERO, DWORK( IW4 ), M2 ) C C Compute inv(Inp2 - D22*DK)*D21 . C CALL DGEMM( 'N', 'N', NP2, M1, NP2, ONE, DWORK, NP2, $ D( NP1+1, 1 ), LDD, ZERO, DWORK( IW5 ), NP2 ) C C Compute DK*inv(Inp2 - D22*DK)*D21 . C CALL DGEMM( 'N', 'N', M2, M1, NP2, ONE, DK, LDDK, DWORK( IW5 ), $ NP2, ZERO, DWORK( IW6 ), M2 ) C C Compute inv(Im2 - DK*D22)*CK . C CALL DGEMM( 'N', 'N', M2, N, M2, ONE, DWORK( IW2 ), M2, CK, LDCK, $ ZERO, DWORK( IW7 ), M2 ) C C Compute D22*inv(Im2 - DK*D22)*CK . C CALL DGEMM( 'N', 'N', NP2, N, M2, ONE, D( NP1+1, M1+1 ), LDD, $ DWORK( IW7 ), M2, ZERO, DWORK( IW8 ), NP2 ) C C Compute AC . C CALL DLACPY( 'Full', N, N, A, LDA, AC, LDAC ) CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, $ DWORK( IW4 ), M2, ONE, AC, LDAC ) CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, $ DWORK( IW7 ), M2, ZERO, AC( 1, N+1 ), LDAC ) CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, DWORK( IW3 ), NP2, $ ZERO, AC( N+1, 1 ), LDAC ) CALL DLACPY( 'Full', N, N, AK, LDAK, AC( N+1, N+1 ), LDAC ) CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, DWORK( IW8 ), NP2, $ ONE, AC( N+1, N+1 ), LDAC ) C C Compute BC . C CALL DLACPY( 'Full', N, M1, B, LDB, BC, LDBC ) CALL DGEMM( 'N', 'N', N, M1, M2, ONE, B( 1, M1+1 ), LDB, $ DWORK( IW6 ), M2, ONE, BC, LDBC ) CALL DGEMM( 'N', 'N', N, M1, NP2, ONE, BK, LDBK, DWORK( IW5 ), $ NP2, ZERO, BC( N+1, 1 ), LDBC ) C C Compute CC . C CALL DLACPY( 'Full', NP1, N, C, LDC, CC, LDCC ) CALL DGEMM( 'N', 'N', NP1, N, M2, ONE, D( 1, M1+1 ), LDD, $ DWORK( IW4 ), M2, ONE, CC, LDCC ) CALL DGEMM( 'N', 'N', NP1, N, M2, ONE, D( 1, M1+1 ), LDD, $ DWORK( IW7 ), M2, ZERO, CC( 1, N+1 ), LDCC ) C C Compute DC . C CALL DLACPY( 'Full', NP1, M1, D, LDD, DC, LDDC ) CALL DGEMM( 'N', 'N', NP1, M1, M2, ONE, D( 1, M1+1 ), LDD, $ DWORK( IW6 ), M2, ONE, DC, LDDC ) C RETURN C *** Last line of SB10LD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10YD.f0000644000000000000000000000013215012430707016177 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB10YD.f0000644000175000017500000005160115012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE SB10YD( DISCFL, FLAG, LENDAT, RFRDAT, IFRDAT, OMEGA, N, $ A, LDA, B, C, D, TOL, IWORK, DWORK, LDWORK, $ ZWORK, LZWORK, INFO ) C C PURPOSE C C To fit a supplied frequency response data with a stable, minimum C phase SISO (single-input single-output) system represented by its C matrices A, B, C, D. It handles both discrete- and continuous-time C cases. C C ARGUMENTS C C Input/Output parameters C C DISCFL (input) INTEGER C Indicates the type of the system, as follows: C = 0: continuous-time system; C = 1: discrete-time system. C C FLAG (input) INTEGER C If FLAG = 0, then the system zeros and poles are not C constrained. C If FLAG = 1, then the system zeros and poles will have C negative real parts in the continuous-time case, or moduli C less than 1 in the discrete-time case. Consequently, FLAG C must be equal to 1 in mu-synthesis routines. C C LENDAT (input) INTEGER C The length of the vectors RFRDAT, IFRDAT and OMEGA. C LENDAT >= 2. C C RFRDAT (input) DOUBLE PRECISION array, dimension (LENDAT) C The real part of the frequency data to be fitted. C C IFRDAT (input) DOUBLE PRECISION array, dimension (LENDAT) C The imaginary part of the frequency data to be fitted. C C OMEGA (input) DOUBLE PRECISION array, dimension (LENDAT) C The frequencies corresponding to RFRDAT and IFRDAT. C These values must be nonnegative and monotonically C increasing. Additionally, for discrete-time systems C they must be between 0 and PI. C C N (input/output) INTEGER C On entry, the desired order of the system to be fitted. C N <= LENDAT-1. C On exit, the order of the obtained system. The value of N C could only be modified if N > 0 and FLAG = 1. C C A (output) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array contains the C matrix A. If FLAG = 1, then A is in an upper Hessenberg C form, and corresponds to a minimal realization. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (output) DOUBLE PRECISION array, dimension (N) C The computed vector B. C C C (output) DOUBLE PRECISION array, dimension (N) C The computed vector C. If FLAG = 1, the first N-1 elements C are zero (for the exit value of N). C C D (output) DOUBLE PRECISION array, dimension (1) C The computed scalar D. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used for determining the effective C rank of matrices. If the user sets TOL > 0, then the given C value of TOL is used as a lower bound for the reciprocal C condition number; a (sub)matrix whose estimated condition C number is less than 1/TOL is considered to be of full C rank. If the user sets TOL <= 0, then an implicitly C computed, default tolerance, defined by TOLDEF = SIZE*EPS, C is used instead, where SIZE is the product of the matrix C dimensions, and EPS is the machine precision (see LAPACK C Library routine DLAMCH). C C Workspace C C IWORK INTEGER array, dimension (max(2,2*N+1)) 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) contains the optimal value of C LZWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK = max( 2, LW1, LW2, LW3, LW4 ), where C LW1 = 2*LENDAT + 4*HNPTS; HNPTS = 2048; C LW2 = LENDAT + 6*HNPTS; C MN = min( 2*LENDAT, 2*N+1 ) C LW3 = 2*LENDAT*(2*N+1) + max( 2*LENDAT, 2*N+1 ) + C max( MN + 6*N + 4, 2*MN + 1 ), if N > 0; C LW3 = 4*LENDAT + 5 , if N = 0; C LW4 = max( N*N + 5*N, 6*N + 1 + min( 1,N ) ), if FLAG = 1; C LW4 = 0, if FLAG = 0. C For optimum performance LDWORK should be larger. C C ZWORK COMPLEX*16 array, dimension (LZWORK) C C LZWORK INTEGER C The length of the array ZWORK. C LZWORK = LENDAT*(2*N+3), if N > 0; C LZWORK = LENDAT, if N = 0. 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 discrete --> continuous transformation cannot C be made; C = 2: if the system poles cannot be found; C = 3: if the inverse system cannot be found, i.e., D is C (close to) zero; C = 4: if the system zeros cannot be found; C = 5: if the state-space representation of the new C transfer function T(s) cannot be found; C = 6: if the continuous --> discrete transformation cannot C be made. C C METHOD C C First, if the given frequency data are corresponding to a C continuous-time system, they are changed to a discrete-time C system using a bilinear transformation with a scaled alpha. C Then, the magnitude is obtained from the supplied data. C Then, the frequency data are linearly interpolated around C the unit-disc. C Then, Oppenheim and Schafer complex cepstrum method is applied C to get frequency data corresponding to a stable, minimum- C phase system. This is done in the following steps: C - Obtain LOG (magnitude) C - Obtain IFFT of the result (DG01MD SLICOT subroutine); C - halve the data at 0; C - Obtain FFT of the halved data (DG01MD SLICOT subroutine); C - Obtain EXP of the result. C Then, the new frequency data are interpolated back to the C original frequency. C Then, based on these newly obtained data, the system matrices C A, B, C, D are constructed; the very identification is C performed by Least Squares Method using DGELSY LAPACK subroutine. C If needed, a discrete-to-continuous time transformation is C applied on the system matrices by AB04MD SLICOT subroutine. C Finally, if requested, the poles and zeros of the system are C checked. If some of them have positive real parts in the C continuous-time case (or are not inside the unit disk in the C complex plane in the discrete-time case), they are exchanged with C their negatives (or reciprocals, respectively), to preserve the C frequency response, while getting a minimum phase and stable C system. This is done by SB10ZP SLICOT subroutine. C C REFERENCES C C [1] Oppenheim, A.V. and Schafer, R.W. C Discrete-Time Signal Processing. C Prentice-Hall Signal Processing Series, 1989. C C [2] Balas, G., Doyle, J., Glover, K., Packard, A., and Smith, R. C Mu-analysis and Synthesis toolbox - User's Guide, C The Mathworks Inc., Natick, MA, USA, 1998. C C CONTRIBUTORS C C Asparuh Markovski, Technical University of Sofia, July 2003. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. C A. Markovski, Technical University of Sofia, October 2003. C C KEYWORDS C C Bilinear transformation, frequency response, least-squares C approximation, stability. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ZZERO, ZONE PARAMETER ( ZZERO = ( 0.0D+0, 0.0D+0 ), $ ZONE = ( 1.0D+0, 0.0D+0 ) ) DOUBLE PRECISION ZERO, ONE, TWO, FOUR, TEN PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, $ FOUR = 4.0D+0, TEN = 1.0D+1 ) INTEGER HNPTS PARAMETER ( HNPTS = 2048 ) C .. C .. Scalar Arguments .. INTEGER DISCFL, FLAG, INFO, LDA, LDWORK, LENDAT, $ LZWORK, N DOUBLE PRECISION TOL C .. C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA, *), B(*), C(*), D(*), DWORK(*), $ IFRDAT(*), OMEGA(*), RFRDAT(*) COMPLEX*16 ZWORK(*) C .. C .. Local Scalars .. INTEGER CLWMAX, DLWMAX, I, II, INFO2, IP1, IP2, ISTART, $ ISTOP, IWA0, IWAB, IWBMAT, IWBP, IWBX, IWDME, $ IWDOMO, IWMAG, IWS, IWVAR, IWXI, IWXR, IWYMAG, $ K, LW1, LW2, LW3, LW4, MN, N1, N2, P, RANK DOUBLE PRECISION P1, P2, PI, PW, RAT, TOLB, TOLL COMPLEX*16 XHAT(HNPTS/2) C .. C .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 C .. C .. External Subroutines .. EXTERNAL AB04MD, DCOPY, DG01MD, DGELSY, DLASET, DSCAL, $ SB10ZP, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ACOS, ATAN, COS, DBLE, DCMPLX, DIMAG, EXP, LOG, $ MAX, MIN, SIN, SQRT C C Test input parameters and workspace. C PI = FOUR*ATAN( ONE ) PW = OMEGA(1) N1 = N + 1 N2 = N + N1 C INFO = 0 IF( DISCFL.NE.0 .AND. DISCFL.NE.1 ) THEN INFO = -1 ELSE IF( FLAG.NE.0 .AND. FLAG.NE.1 ) THEN INFO = -2 ELSE IF ( LENDAT.LT.2 ) THEN INFO = -3 ELSE IF ( PW.LT.ZERO ) THEN INFO = -6 ELSE IF( N.GT.LENDAT - 1 ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE C DO 10 K = 2, LENDAT IF ( OMEGA(K).LT.PW ) $ INFO = -6 PW = OMEGA(K) 10 CONTINUE C IF ( DISCFL.EQ.1 .AND. OMEGA(LENDAT).GT.PI ) $ INFO = -6 END IF C IF ( INFO.EQ.0 ) THEN C C Workspace. C LW1 = 2*LENDAT + 4*HNPTS LW2 = LENDAT + 6*HNPTS MN = MIN( 2*LENDAT, N2 ) C IF ( N.GT.0 ) THEN LW3 = 2*LENDAT*N2 + MAX( 2*LENDAT, N2 ) + $ MAX( MN + 6*N + 4, 2*MN + 1 ) ELSE LW3 = 4*LENDAT + 5 END IF C IF ( FLAG.EQ.0 ) THEN LW4 = 0 ELSE LW4 = MAX( N*N + 5*N, 6*N + 1 + MIN ( 1, N ) ) END IF C DLWMAX = MAX( 2, LW1, LW2, LW3, LW4 ) C IF ( N.GT.0 ) THEN CLWMAX = LENDAT*( N2 + 2 ) ELSE CLWMAX = LENDAT END IF C IF ( LDWORK.LT.DLWMAX ) THEN INFO = -16 ELSE IF ( LZWORK.LT.CLWMAX ) THEN INFO = -18 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB10YD', -INFO ) RETURN END IF C C Set tolerances. C TOLB = DLAMCH( 'Epsilon' ) TOLL = TOL IF ( TOLL.LE.ZERO ) $ TOLL = FOUR*DBLE( LENDAT*N )*TOLB C C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ C C Workspace usage 1. C Workspace: need 2*LENDAT + 4*HNPTS. C IWDOMO = 1 IWDME = IWDOMO + LENDAT IWYMAG = IWDME + 2*HNPTS IWMAG = IWYMAG + 2*HNPTS C C Bilinear transformation. C IF ( DISCFL.EQ.0 ) THEN PW = SQRT( OMEGA(1)*OMEGA(LENDAT) + SQRT( TOLB ) ) C DO 20 K = 1, LENDAT DWORK(IWDME+K-1) = ( OMEGA(K)/PW )**2 DWORK(IWDOMO+K-1) = $ ACOS( ( ONE - DWORK(IWDME+K-1) )/ $ ( ONE + DWORK(IWDME+K-1) ) ) 20 CONTINUE C ELSE CALL DCOPY( LENDAT, OMEGA, 1, DWORK(IWDOMO), 1 ) END IF C C Linear interpolation. C DO 30 K = 1, LENDAT DWORK(IWMAG+K-1) = DLAPY2( RFRDAT(K), IFRDAT(K) ) DWORK(IWMAG+K-1) = ( ONE/LOG( TEN ) ) * LOG( DWORK(IWMAG+K-1) ) 30 CONTINUE C DO 40 K = 1, HNPTS DWORK(IWDME+K-1) = ( K - 1 )*PI/HNPTS DWORK(IWYMAG+K-1) = ZERO C IF ( DWORK(IWDME+K-1).LT.DWORK(IWDOMO) ) THEN DWORK(IWYMAG+K-1) = DWORK(IWMAG) ELSE IF ( DWORK(IWDME+K-1).GE.DWORK(IWDOMO+LENDAT-1) ) THEN DWORK(IWYMAG+K-1) = DWORK(IWMAG+LENDAT-1) END IF C 40 CONTINUE C DO 60 I = 2, LENDAT P1 = HNPTS*DWORK(IWDOMO+I-2)/PI + ONE C IP1 = INT( P1 ) IF ( DBLE( IP1 ).NE.P1 ) $ IP1 = IP1 + 1 C P2 = HNPTS*DWORK(IWDOMO+I-1)/PI + ONE C IP2 = INT( P2 ) IF ( DBLE( IP2 ).NE.P2 ) $ IP2 = IP2 + 1 C DO 50 P = IP1, IP2 - 1 RAT = DWORK(IWDME+P-1) - DWORK(IWDOMO+I-2) RAT = RAT/( DWORK(IWDOMO+I-1) - DWORK(IWDOMO+I-2) ) DWORK(IWYMAG+P-1) = ( ONE - RAT )*DWORK(IWMAG+I-2) + $ RAT*DWORK(IWMAG+I-1) 50 CONTINUE C 60 CONTINUE C DO 70 K = 1, HNPTS DWORK(IWYMAG+K-1) = EXP( LOG( TEN )*DWORK(IWYMAG+K-1) ) 70 CONTINUE C C Duplicate data around disc. C DO 80 K = 1, HNPTS DWORK(IWDME+HNPTS+K-1) = TWO*PI - DWORK(IWDME+HNPTS-K) DWORK(IWYMAG+HNPTS+K-1) = DWORK(IWYMAG+HNPTS-K) 80 CONTINUE C C Complex cepstrum to get min phase: C LOG (Magnitude) C DO 90 K = 1, 2*HNPTS DWORK(IWYMAG+K-1) = TWO*LOG( DWORK(IWYMAG+K-1) ) 90 CONTINUE C C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ C C Workspace usage 2. C Workspace: need LENDAT + 6*HNPTS. C IWXR = IWYMAG IWXI = IWMAG C DO 100 K = 1, 2*HNPTS DWORK(IWXI+K-1) = ZERO 100 CONTINUE C C IFFT C CALL DG01MD( 'I', 2*HNPTS, DWORK(IWXR), DWORK(IWXI), INFO2 ) C C Rescale, because DG01MD doesn't do it. C CALL DSCAL( HNPTS, ONE/( TWO*HNPTS ), DWORK(IWXR), 1 ) CALL DSCAL( HNPTS, ONE/( TWO*HNPTS ), DWORK(IWXI), 1 ) C C Halve the result at 0. C DWORK(IWXR) = DWORK(IWXR)/TWO DWORK(IWXI) = DWORK(IWXI)/TWO C C FFT C CALL DG01MD( 'D', HNPTS, DWORK(IWXR), DWORK(IWXI), INFO2 ) C C Get the EXP of the result. C DO 110 K = 1, HNPTS/2 XHAT(K) = EXP( DWORK(IWXR+K-1) )* $ DCMPLX ( COS( DWORK(IWXI+K-1)), SIN( DWORK(IWXI+K-1) ) ) DWORK(IWDME+K-1) = DWORK(IWDME+2*K-2) 110 CONTINUE C C Interpolate back to original frequency data. C ISTART = 1 ISTOP = LENDAT C DO 120 I = 1, LENDAT ZWORK(I) = ZZERO IF ( DWORK(IWDOMO+I-1).LE.DWORK(IWDME) ) THEN ZWORK(I) = XHAT(1) ISTART = I + 1 ELSE IF ( DWORK(IWDOMO+I-1).GE.DWORK(IWDME+HNPTS/2-1) ) $ THEN ZWORK(I) = XHAT(HNPTS/2) ISTOP = ISTOP - 1 END IF 120 CONTINUE C DO 140 I = ISTART, ISTOP II = HNPTS/2 P = II 130 CONTINUE IF ( DWORK(IWDME+II-1).GE.DWORK(IWDOMO+I-1) ) $ P = II II = II - 1 IF ( II.GT.0 ) $ GOTO 130 RAT = ( DWORK(IWDOMO+I-1) - DWORK(IWDME+P-2) )/ $ ( DWORK(IWDME+P-1) - DWORK(IWDME+P-2) ) ZWORK(I) = RAT*XHAT(P) + ( ONE - RAT )*XHAT(P-1) 140 CONTINUE C C CASE N > 0. C This is the only allowed case in mu-synthesis subroutines. C IF ( N.GT.0 ) THEN C C Preparation for frequency identification. C C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ C C Complex workspace usage 1. C Complex workspace: need 2*LENDAT + LENDAT*(N+1). C IWA0 = 1 + LENDAT IWVAR = IWA0 + LENDAT*N1 C DO 150 K = 1, LENDAT IF ( DISCFL.EQ.0 ) THEN ZWORK(IWVAR+K-1) = DCMPLX( COS( DWORK(IWDOMO+K-1) ), $ SIN( DWORK(IWDOMO+K-1) ) ) ELSE ZWORK(IWVAR+K-1) = DCMPLX( COS( OMEGA(K) ), $ SIN( OMEGA(K) ) ) END IF 150 CONTINUE C C Array for DGELSY. C DO 160 K = 1, N2 IWORK(K) = 0 160 CONTINUE C C Constructing A0. C DO 170 K = 1, LENDAT ZWORK(IWA0+N*LENDAT+K-1) = ZONE 170 CONTINUE C DO 190 I = 1, N DO 180 K = 1, LENDAT ZWORK(IWA0+(N-I)*LENDAT+K-1) = $ ZWORK(IWA0+(N1-I)*LENDAT+K-1)*ZWORK(IWVAR+K-1) 180 CONTINUE 190 CONTINUE C C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ C C Complex workspace usage 2. C Complex workspace: need 2*LENDAT + LENDAT*(2*N+1). C IWBP = IWVAR IWAB = IWBP + LENDAT C C Constructing BP. C DO 200 K = 1, LENDAT ZWORK(IWBP+K-1) = ZWORK(IWA0+K-1)*ZWORK(K) 200 CONTINUE C C Constructing AB. C DO 220 I = 1, N DO 210 K = 1, LENDAT ZWORK(IWAB+(I-1)*LENDAT+K-1) = -ZWORK(K)* $ ZWORK(IWA0+I*LENDAT+K-1) 210 CONTINUE 220 CONTINUE C C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ C C Workspace usage 3. C Workspace: need LW3 = 2*LENDAT*(2*N+1) + max(2*LENDAT,2*N+1). C IWBX = 1 + 2*LENDAT*N2 IWS = IWBX + MAX( 2*LENDAT, N2 ) C C Constructing AX. C DO 240 I = 1, N1 DO 230 K = 1, LENDAT DWORK(2*(I-1)*LENDAT+K) = $ DBLE( ZWORK(IWA0+(I-1)*LENDAT+K-1) ) DWORK((2*I-1)*LENDAT+K) = $ DIMAG( ZWORK(IWA0+(I-1)*LENDAT+K-1) ) 230 CONTINUE 240 CONTINUE C DO 260 I = 1, N DO 250 K = 1, LENDAT DWORK(2*N1*LENDAT+2*(I-1)*LENDAT+K) = $ DBLE( ZWORK(IWAB+(I-1)*LENDAT+K-1) ) DWORK(2*N1*LENDAT+(2*I-1)*LENDAT+K) = $ DIMAG( ZWORK(IWAB+(I-1)*LENDAT+K-1) ) 250 CONTINUE 260 CONTINUE C C Constructing BX. C DO 270 K = 1, LENDAT DWORK(IWBX+K-1) = DBLE( ZWORK(IWBP+K-1) ) DWORK(IWBX+LENDAT+K-1) = DIMAG( ZWORK(IWBP+K-1) ) 270 CONTINUE C C Estimating X. C Workspace: need LW3 + max( MN+3*(2*N+1)+1, 2*MN+1 ), C where MN = min( 2*LENDAT, 2*N+1 ); C prefer larger. C CALL DGELSY( 2*LENDAT, N2, 1, DWORK, 2*LENDAT, DWORK(IWBX), $ MAX( 2*LENDAT, N2 ), IWORK, TOLL, RANK, $ DWORK(IWS), LDWORK-IWS+1, INFO2 ) DLWMAX = MAX( DLWMAX, INT( DWORK(IWS) + IWS - 1 ) ) C C Constructing A matrix. C DO 280 K = 1, N A(K,1) = -DWORK(IWBX+N1+K-1) 280 CONTINUE C IF ( N.GT.1 ) $ CALL DLASET( 'Full', N, N-1, ZERO, ONE, A(1,2), LDA ) C C Constructing B matrix. C DO 290 K = 1, N B(K) = DWORK(IWBX+N1+K-1)*DWORK(IWBX) - DWORK(IWBX+K) 290 CONTINUE C C Constructing C matrix. C C(1) = -ONE C DO 300 K = 2, N C(K) = ZERO 300 CONTINUE C C Constructing D matrix. C D(1) = DWORK(IWBX) C C Transform to continuous-time case, if needed. C Workspace: need max(1,N); C prefer larger. C IF ( DISCFL.EQ.0 ) THEN CALL AB04MD( 'D', N, 1, 1, ONE, PW, A, LDA, B, LDA, C, 1, $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) IF ( INFO2.NE.0 ) THEN INFO = 1 RETURN END IF DLWMAX = MAX( DLWMAX, INT( DWORK(1) ) ) END IF C C Make all the real parts of the poles and the zeros negative. C IF ( FLAG.EQ.1 ) THEN C C Workspace: need max(N*N + 5*N, 6*N + 1 + min(1,N)); C prefer larger. CALL SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK, $ LDWORK, INFO ) IF ( INFO.NE.0 ) $ RETURN DLWMAX = MAX( DLWMAX, INT( DWORK(1) ) ) END IF C ELSE C C CASE N = 0. C C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ C C Workspace usage 4. C Workspace: need 4*LENDAT. C IWBMAT = 1 + 2*LENDAT IWS = IWBMAT + 2*LENDAT C C Constructing AMAT and BMAT. C DO 310 K = 1, LENDAT DWORK(K) = ONE DWORK(K+LENDAT) = ZERO DWORK(IWBMAT+K-1) = DBLE( ZWORK(K) ) DWORK(IWBMAT+LENDAT+K-1) = DIMAG( ZWORK(K) ) 310 CONTINUE C C Estimating D matrix. C Workspace: need 4*LENDAT + 5; C prefer larger. C IWORK(1) = 0 CALL DGELSY( 2*LENDAT, 1, 1, DWORK, 2*LENDAT, DWORK(IWBMAT), $ 2*LENDAT, IWORK, TOLL, RANK, DWORK(IWS), $ LDWORK-IWS+1, INFO2 ) DLWMAX = MAX( DLWMAX, INT( DWORK(IWS) + IWS - 1 ) ) C D(1) = DWORK(IWBMAT) C END IF C C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ C DWORK(1) = DLWMAX DWORK(2) = CLWMAX RETURN C C *** Last line of SB10YD *** END control-4.1.2/src/slicot/src/PaxHeaders/MC03MD.f0000644000000000000000000000013015012430707016156 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MC03MD.f0000644000175000017500000002503515012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE MC03MD( RP1, CP1, CP2, DP1, DP2, DP3, ALPHA, P1, $ LDP11, LDP12, P2, LDP21, LDP22, P3, LDP31, $ LDP32, DWORK, INFO ) C C PURPOSE C C To compute the coefficients of the real polynomial matrix C C P(x) = P1(x) * P2(x) + alpha * P3(x), C C where P1(x), P2(x) and P3(x) are given real polynomial matrices C and alpha is a real scalar. C C Each of the polynomial matrices P1(x), P2(x) and P3(x) may be the C zero matrix. C C ARGUMENTS C C Input/Output Parameters C C RP1 (input) INTEGER C The number of rows of the matrices P1(x) and P3(x). C RP1 >= 0. C C CP1 (input) INTEGER C The number of columns of matrix P1(x) and the number of C rows of matrix P2(x). CP1 >= 0. C C CP2 (input) INTEGER C The number of columns of the matrices P2(x) and P3(x). C CP2 >= 0. C C DP1 (input) INTEGER C The degree of the polynomial matrix P1(x). DP1 >= -1. C C DP2 (input) INTEGER C The degree of the polynomial matrix P2(x). DP2 >= -1. C C DP3 (input/output) INTEGER C On entry, the degree of the polynomial matrix P3(x). C DP3 >= -1. C On exit, the degree of the polynomial matrix P(x). C C ALPHA (input) DOUBLE PRECISION C The scalar value alpha of the problem. C C P1 (input) DOUBLE PRECISION array, dimension (LDP11,LDP12,*) C If DP1 >= 0, then the leading RP1-by-CP1-by-(DP1+1) part C of this array must contain the coefficients of the C polynomial matrix P1(x). Specifically, P1(i,j,k) must C contain the coefficient of x**(k-1) of the polynomial C which is the (i,j)-th element of P1(x), where i = 1,2,..., C RP1, j = 1,2,...,CP1 and k = 1,2,...,DP1+1. C If DP1 = -1, then P1(x) is taken to be the zero polynomial C matrix, P1 is not referenced and can be supplied as a C dummy array (i.e. set the parameters LDP11 = LDP12 = 1 and C declare this array to be P1(1,1,1) in the calling C program). C C LDP11 INTEGER C The leading dimension of array P1. C LDP11 >= MAX(1,RP1) if DP1 >= 0, C LDP11 >= 1 if DP1 = -1. C C LDP12 INTEGER C The second dimension of array P1. C LDP12 >= MAX(1,CP1) if DP1 >= 0, C LDP12 >= 1 if DP1 = -1. C C P2 (input) DOUBLE PRECISION array, dimension (LDP21,LDP22,*) C If DP2 >= 0, then the leading CP1-by-CP2-by-(DP2+1) part C of this array must contain the coefficients of the C polynomial matrix P2(x). Specifically, P2(i,j,k) must C contain the coefficient of x**(k-1) of the polynomial C which is the (i,j)-th element of P2(x), where i = 1,2,..., C CP1, j = 1,2,...,CP2 and k = 1,2,...,DP2+1. C If DP2 = -1, then P2(x) is taken to be the zero polynomial C matrix, P2 is not referenced and can be supplied as a C dummy array (i.e. set the parameters LDP21 = LDP22 = 1 and C declare this array to be P2(1,1,1) in the calling C program). C C LDP21 INTEGER C The leading dimension of array P2. C LDP21 >= MAX(1,CP1) if DP2 >= 0, C LDP21 >= 1 if DP2 = -1. C C LDP22 INTEGER C The second dimension of array P2. C LDP22 >= MAX(1,CP2) if DP2 >= 0, C LDP22 >= 1 if DP2 = -1. C C P3 (input/output) DOUBLE PRECISION array, dimension C (LDP31,LDP32,n), where n = MAX(DP1+DP2,DP3,0)+1. C On entry, if DP3 >= 0, then the leading C RP1-by-CP2-by-(DP3+1) part of this array must contain the C coefficients of the polynomial matrix P3(x). Specifically, C P3(i,j,k) must contain the coefficient of x**(k-1) of the C polynomial which is the (i,j)-th element of P3(x), where C i = 1,2,...,RP1, j = 1,2,...,CP2 and k = 1,2,...,DP3+1. C If DP3 = -1, then P3(x) is taken to be the zero polynomial C matrix. C On exit, if DP3 >= 0 on exit (ALPHA <> 0.0 and DP3 <> -1, C on entry, or DP1 <> -1 and DP2 <> -1), then the leading C RP1-by-CP2-by-(DP3+1) part of this array contains the C coefficients of P(x). Specifically, P3(i,j,k) contains the C coefficient of x**(k-1) of the polynomial which is the C (i,j)-th element of P(x), where i = 1,2,...,RP1, j = 1,2, C ...,CP2 and k = 1,2,...,DP3+1. C If DP3 = -1 on exit, then the coefficients of P(x) (the C zero polynomial matrix) are not stored in the array. C C LDP31 INTEGER C The leading dimension of array P3. LDP31 >= MAX(1,RP1). C C LDP32 INTEGER C The second dimension of array P3. LDP32 >= MAX(1,CP2). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (CP1) 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 Given real polynomial matrices C C DP1 i C P1(x) = SUM (A(i+1) * x ), C i=0 C C DP2 i C P2(x) = SUM (B(i+1) * x ), C i=0 C C DP3 i C P3(x) = SUM (C(i+1) * x ) C i=0 C C and a real scalar alpha, the routine computes the coefficients C d ,d ,..., of the polynomial matrix C 1 2 C C P(x) = P1(x) * P2(x) + alpha * P3(x) C C from the formula C C s C d = SUM (A(k+1) * B(i-k+1)) + alpha * C(i+1), C i+1 k=r C C where i = 0,1,...,DP1+DP2 and r and s depend on the value of i C (e.g. if i <= DP1 and i <= DP2, then r = 0 and s = i). C C NUMERICAL ASPECTS C C None. C C FURTHER COMMENTS C C Other elementary operations involving polynomial matrices can C easily be obtained by calling the appropriate BLAS routine(s). C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC03AD by A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Elementary polynomial operations, input output description, C polynomial matrix, polynomial operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER CP1, CP2, DP1, DP2, DP3, INFO, LDP11, LDP12, $ LDP21, LDP22, LDP31, LDP32, RP1 DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION DWORK(*), P1(LDP11,LDP12,*), P2(LDP21,LDP22,*), $ P3(LDP31,LDP32,*) C .. Local Scalars .. LOGICAL CFZERO INTEGER DPOL3, E, H, I, J, K C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. External Subroutines .. EXTERNAL DCOPY, DLASET, DSCAL, XERBLA C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 IF( RP1.LT.0 ) THEN INFO = -1 ELSE IF( CP1.LT.0 ) THEN INFO = -2 ELSE IF( CP2.LT.0 ) THEN INFO = -3 ELSE IF( DP1.LT.-1 ) THEN INFO = -4 ELSE IF( DP2.LT.-1 ) THEN INFO = -5 ELSE IF( DP3.LT.-1 ) THEN INFO = -6 ELSE IF( ( DP1.EQ.-1 .AND. LDP11.LT.1 ) .OR. $ ( DP1.GE. 0 .AND. LDP11.LT.MAX( 1, RP1 ) ) ) THEN INFO = -9 ELSE IF( ( DP1.EQ.-1 .AND. LDP12.LT.1 ) .OR. $ ( DP1.GE. 0 .AND. LDP12.LT.MAX( 1, CP1 ) ) ) THEN INFO = -10 ELSE IF( ( DP2.EQ.-1 .AND. LDP21.LT.1 ) .OR. $ ( DP2.GE. 0 .AND. LDP21.LT.MAX( 1, CP1 ) ) ) THEN INFO = -12 ELSE IF( ( DP2.EQ.-1 .AND. LDP22.LT.1 ) .OR. $ ( DP2.GE. 0 .AND. LDP22.LT.MAX( 1, CP2 ) ) ) THEN INFO = -13 ELSE IF( LDP31.LT.MAX( 1, RP1 ) ) THEN INFO = -15 ELSE IF( LDP32.LT.MAX( 1, CP2 ) ) THEN INFO = -16 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MC03MD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( RP1.EQ.0 .OR. CP2.EQ.0 ) $ RETURN C IF ( ALPHA.EQ.ZERO ) $ DP3 = -1 C IF ( DP3.GE.0 ) THEN C C P3(x) := ALPHA * P3(x). C DO 40 K = 1, DP3 + 1 C DO 20 J = 1, CP2 CALL DSCAL( RP1, ALPHA, P3(1,J,K), 1 ) 20 CONTINUE C 40 CONTINUE END IF C IF ( ( DP1.EQ.-1 ) .OR. ( DP2.EQ.-1 ) .OR. ( CP1.EQ.0 ) ) $ RETURN C C Neither of P1(x) and P2(x) is the zero polynomial. C DPOL3 = DP1 + DP2 IF ( DPOL3.GT.DP3 ) THEN C C Initialize the additional part of P3(x) to zero. C DO 80 K = DP3 + 2, DPOL3 + 1 CALL DLASET( 'Full', RP1, CP2, ZERO, ZERO, P3(1,1,K), $ LDP31 ) 80 CONTINUE C DP3 = DPOL3 END IF C k-1 C The inner product of the j-th row of the coefficient of x of P1 C i-1 C and the h-th column of the coefficient of x of P2(x) contribute C k+i-2 C the (j,h)-th element of the coefficient of x of P3(x). C DO 160 K = 1, DP1 + 1 C DO 140 J = 1, RP1 CALL DCOPY( CP1, P1(J,1,K), LDP11, DWORK, 1 ) C DO 120 I = 1, DP2 + 1 E = K + I - 1 C DO 100 H = 1, CP2 P3(J,H,E) = DDOT( CP1, DWORK, 1, P2(1,H,I), 1 ) + $ P3(J,H,E) 100 CONTINUE C 120 CONTINUE C 140 CONTINUE C 160 CONTINUE C C Computation of the exact degree of P3(x). C CFZERO = .TRUE. C WHILE ( DP3 >= 0 and CFZERO ) DO 180 IF ( ( DP3.GE.0 ) .AND. CFZERO ) THEN DPOL3 = DP3 + 1 C DO 220 J = 1, CP2 C DO 200 I = 1, RP1 IF ( P3(I,J,DPOL3 ).NE.ZERO ) CFZERO = .FALSE. 200 CONTINUE C 220 CONTINUE C IF ( CFZERO ) DP3 = DP3 - 1 GO TO 180 END IF C END WHILE 180 C RETURN C *** Last line of MC03MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03LD.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03LD.f0000644000175000017500000007205315012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE MB03LD( COMPQ, ORTH, N, A, LDA, DE, LDDE, B, LDB, FG, $ LDFG, NEIG, Q, LDQ, ALPHAR, ALPHAI, BETA, $ IWORK, LIWORK, DWORK, LDWORK, BWORK, INFO ) C C PURPOSE C C To compute the relevant eigenvalues of a real N-by-N skew- C Hamiltonian/Hamiltonian pencil aS - bH, with C C ( A D ) ( B F ) C S = ( ) and H = ( ), (1) C ( E A' ) ( G -B' ) C C where the notation M' denotes the transpose of the matrix M. C Optionally, if COMPQ = 'C', an orthogonal basis of the right C deflating subspace of aS - bH corresponding to the eigenvalues C with strictly negative real part is computed. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether to compute the right deflating subspace C corresponding to the eigenvalues of aS - bH with strictly C negative real part. C = 'N': do not compute the deflating subspace; C = 'C': compute the deflating subspace and store it in the C leading subarray of Q. C C ORTH CHARACTER*1 C If COMPQ = 'C', specifies the technique for computing an C orthogonal basis of the deflating subspace, as follows: C = 'P': QR factorization with column pivoting; C = 'S': singular value decomposition. C If COMPQ = 'N', the ORTH value is not used. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix A. C On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of C this array contains the upper triangular matrix Aout C (see METHOD); otherwise, it contains the upper triangular C matrix A obtained just before the application of the C periodic QZ algorithm (see SLICOT Library routine MB04BD). C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C DE (input/output) DOUBLE PRECISION array, dimension C (LDDE, N/2+1) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C skew-symmetric matrix E, and the N/2-by-N/2 upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array must contain the upper triangular part of the C skew-symmetric matrix D. C The entries on the diagonal and the first superdiagonal of C this array need not be set, but are assumed to be zero. C On exit, if COMPQ = 'C', the leading N/2-by-N/2 lower C triangular part and the first superdiagonal contain the C transpose of the upper quasi-triangular matrix C2out (see C METHOD), and the (N/2-1)-by-(N/2-1) upper triangular part C of the submatrix in the columns 3 to N/2+1 of this array C contains the strictly upper triangular part of the C skew-symmetric matrix Dout (see METHOD), without the main C diagonal, which is zero. C On exit, if COMPQ = 'N', the leading N/2-by-N/2 lower C triangular part and the first superdiagonal contain the C transpose of the upper Hessenberg matrix C2, and the C (N/2-1)-by-(N/2-1) upper triangular part of the submatrix C in the columns 3 to N/2+1 of this array contains the C strictly upper triangular part of the skew-symmetric C matrix D (without the main diagonal) just before the C application of the periodic QZ algorithm. C C LDDE INTEGER C The leading dimension of the array DE. C LDDE >= MAX(1, N/2). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of C this array contains the upper triangular matrix C1out C (see METHOD); otherwise, it contains the upper triangular C matrix C1 obtained just before the application of the C periodic QZ algorithm. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C FG (input/output) DOUBLE PRECISION array, dimension C (LDFG, N/2+1) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C symmetric matrix G, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C symmetric matrix F. C On exit, if COMPQ = 'C', the leading N/2-by-N/2 part of C the submatrix in the columns 2 to N/2+1 of this array C contains the matrix Vout (see METHOD); otherwise, it C contains the matrix V obtained just before the application C of the periodic QZ algorithm. C C LDFG INTEGER C The leading dimension of the array FG. C LDFG >= MAX(1, N/2). C C NEIG (output) INTEGER C If COMPQ = 'C', the number of eigenvalues in aS - bH with C strictly negative real part. C C Q (output) DOUBLE PRECISION array, dimension (LDQ, 2*N) C On exit, if COMPQ = 'C', the leading N-by-NEIG part of C this array contains an orthogonal basis of the right C deflating subspace corresponding to the eigenvalues of C aA - bB with strictly negative real part. The remaining C part of this array is used as workspace. C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, 2*N), if COMPQ = 'C'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C Due to the skew-Hamiltonian/Hamiltonian structure of the C pencil, for every eigenvalue lambda, -lambda is also an C eigenvalue, and thus it has only to be saved once in C ALPHAR, ALPHAI and BETA. C Specifically, only eigenvalues with imaginary parts C greater than or equal to zero are stored; their conjugate C eigenvalues are not stored. If imaginary parts are zero C (i.e., for real eigenvalues), only positive eigenvalues C are stored. The remaining eigenvalues have opposite signs. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = -19, IWORK(1) returns the minimum value C of LIWORK. C C LIWORK INTEGER C The dimension of the array IWORK. LIWORK = 1, if N = 0, C LIWORK >= MAX( N + 12, 2*N + 3 ), if COMPQ = 'N', C LIWORK >= MAX( 32, 2*N + 3 ), if COMPQ = 'C'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C On exit, if INFO = -21, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. LDWORK = 1, if N = 0, C LDWORK >= 3*(N/2)**2 + N**2 + MAX( L, 36 ), C if COMPQ = 'N', C where L = 4*N + 4, if N/2 is even, and C L = 4*N , if N/2 is odd; C LDWORK >= 8*N**2 + MAX( 8*N + 32, 272 ), if COMPQ = 'C'. C For good performance LDWORK should be generally larger. C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C BWORK LOGICAL array, dimension (N/2) C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: periodic QZ iteration failed in the SLICOT Library C routines MB04BD or MB04HD (QZ iteration did not C converge or computation of the shifts failed); C = 2: standard QZ iteration failed in the SLICOT Library C routines MB04HD or MB03DD (called by MB03JD); C = 3: a numerically singular matrix was found in the SLICOT C Library routine MB03HD (called by MB03JD); C = 4: the singular value decomposition failed in the LAPACK C routine DGESVD (for ORTH = 'S'); C = 5: some eigenvalues might be inaccurate. This is a C warning. C C METHOD C C First, the decompositions of S and H are computed via orthogonal C transformations Q1 and Q2 as follows: C C ( Aout Dout ) C Q1' S J Q1 J' = ( ), C ( 0 Aout' ) C C ( Bout Fout ) C J' Q2' J S Q2 = ( ) =: T, (2) C ( 0 Bout' ) C C ( C1out Vout ) ( 0 I ) C Q1' H Q2 = ( ), where J = ( ), C ( 0 C2out' ) ( -I 0 ) C C and Aout, Bout, C1out are upper triangular, C2out is upper quasi- C triangular and Dout and Fout are skew-symmetric. C C Then, orthogonal matrices Q3 and Q4 are found, for the extended C matrices C C ( Aout 0 ) ( 0 C1out ) C Se = ( ) and He = ( ), C ( 0 Bout ) ( -C2out 0 ) C C such that S11 := Q4' Se Q3 is upper triangular and C H11 := Q4' He Q3 is upper quasi-triangular. The following matrices C are computed: C C ( Dout 0 ) ( 0 Vout ) C S12 := Q4' ( ) Q4 and H12 := Q4' ( ) Q4. C ( 0 Fout ) ( Vout' 0 ) C C Then, an orthogonal matrix Q is found such that the eigenvalues C with strictly negative real parts of the pencil C C ( S11 S12 ) ( H11 H12 ) C a ( ) - b ( ) C ( 0 S11' ) ( 0 -H11' ) C C are moved to the top of this pencil. C C Finally, an orthogonal basis of the right deflating subspace C corresponding to the eigenvalues with strictly negative real part C is computed. See also page 12 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C floating point operations. C C FURTHER COMMENTS C C This routine does not perform any scaling of the matrices. Scaling C might sometimes be useful, and it should be done externally. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Oct. 2010. C C REVISIONS C C V. Sima, Nov. 2010, Dec. 2010, Mar. 2011, Aug. 2011, Nov. 2011, C Oct. 2012, July 2013, July 2014, Jan. 2017, May 2020. C M. Voigt, Jan. 2012. C C KEYWORDS C C Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian C pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) C C .. Scalar Arguments .. CHARACTER COMPQ, ORTH INTEGER INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK, $ LIWORK, N, NEIG C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), DE( LDDE, * ), $ DWORK( * ), FG( LDFG, * ), Q( LDQ, * ) C C .. Local Scalars .. LOGICAL LINIQ, LQUERY, QR, QRP, SVD CHARACTER*14 CMPQ INTEGER IB, IC2, IFO, IH11, IH12, IQ1, IQ2, IQ3, IQ4, $ IRT, IS11, IS12, IW, IWRK, J, M, MINDW, MINIW, $ MM, N2, NM, NMM, NN, OPTDW C C .. Local Arrays .. DOUBLE PRECISION DUM( 4 ) C C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEQP3, DGEQRF, DGESVD, $ DLACPY, DORGQR, DSCAL, DSYR2K, DTRMM, MA02AD, $ MB01KD, MB01LD, MB03JD, MB04BD, MB04HD, XERBLA C C .. Intrinsic Functions .. INTRINSIC INT, MAX, MOD, SQRT C C .. Executable Statements .. C C Decode the input arguments. C Using ORTH = 'Q' is not safe, but sometimes gives better results. C M = N/2 N2 = N*2 NN = N*N MM = M*M NEIG = 0 LINIQ = LSAME( COMPQ, 'C' ) IF( LINIQ ) THEN QR = LSAME( ORTH, 'Q' ) QRP = LSAME( ORTH, 'P' ) SVD = LSAME( ORTH, 'S' ) END IF IF( N.EQ.0 ) THEN MINIW = 1 MINDW = 1 ELSE IF( LINIQ ) THEN MINIW = MAX( 32, N2 + 3 ) MINDW = 8*NN + MAX( 8*N + 32, 272 ) ELSE IF( MOD( M, 2 ).EQ.0 ) THEN J = MAX( 4*N, 32 ) + 4 ELSE J = MAX( 4*N, 36 ) END IF MINIW = MAX( N + 12, N2 + 3 ) MINDW = 3*M**2 + NN + J END IF LQUERY = LDWORK.EQ.-1 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LINIQ ) ) THEN INFO = -1 ELSE IF( LINIQ ) THEN IF( .NOT.( QR .OR. QRP .OR. SVD ) ) $ INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LDDE.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( LDFG.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LDQ.LT.1 .OR. ( LINIQ .AND. LDQ.LT.N2 ) ) THEN INFO = -14 ELSE IF( LIWORK.LT.MINIW ) THEN IWORK( 1 ) = MINIW INFO = -19 ELSE IF( .NOT. LQUERY .AND. LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -21 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03LD', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN C C Compute optimal workspace. C IF( LQUERY ) THEN IF( LINIQ ) THEN CALL MB04HD( 'I', 'I', N, DWORK, N, DWORK, N, DWORK, N, $ DWORK, N, IWORK, LIWORK, DUM, -1, BWORK, $ INFO ) IF( SVD ) THEN CALL DGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, DWORK, $ LDQ, DWORK, 1, DUM( 2 ), -1, INFO ) J = N + INT( DUM( 2 ) ) ELSE IF( QR ) THEN CALL DGEQRF( N, M, Q, LDQ, DWORK, DUM( 2 ), -1, $ INFO ) J = M ELSE CALL DGEQP3( N, N, Q, LDQ, IWORK, DWORK, DUM( 2 ), $ -1, INFO ) J = N END IF CALL DORGQR( N, J, J, Q, LDQ, DWORK, DUM( 3 ), -1, $ INFO ) J = J + MAX( INT( DUM( 2 ) ), INT( DUM( 3 ) ) ) END IF OPTDW = MAX( MINDW, 6*NN + INT( DUM( 1 ) ), J ) ELSE OPTDW = MINDW END IF DWORK( 1 ) = OPTDW RETURN END IF END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK( 1 ) = ONE RETURN END IF C IFO = 1 C C STEP 1: Apply MB04BD to transform the pencil to real C skew-Hamiltonian/Hamiltonian Schur form. C C Set the computation option and pointers for the inputs and outputs C of MB04BD. If possible, array Q is used as vectorized workspace. C C Real workspace: need w1 + w0 + MAX( L, 36 ), where C w1 = 2*N**2, w0 = 2*N**2, if COMPQ = 'C'; C w1 = 3*M**2, w0 = N**2, if COMPQ = 'N'; C L = 4*N + 4, if N/2 is even, and C L = 4*N , if N/2 is odd. C Integer workspace: need MAX(N+12,2*N+3). C IF( LINIQ ) THEN CMPQ = 'Initialize' IQ1 = 1 IQ2 = IQ1 + NN IWRK = IQ2 + NN IF( MOD( M, 4 ).EQ.0 ) THEN IC2 = M/4 ELSE IC2 = INT( M/4 ) + 1 END IF IB = 2*IC2 + 1 IC2 = IC2 + 1 CALL MB04BD( 'Triangularize', CMPQ, CMPQ, N, A, LDA, DE, LDDE, $ B, LDB, FG, LDFG, DWORK( IQ1 ), N, DWORK( IQ2 ), $ N, Q( 1, IB ), M, Q( 1, IFO ), M, Q( 1, IC2 ), M, $ ALPHAR, ALPHAI, BETA, IWORK, LIWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) ELSE CMPQ = 'No Computation' IB = IFO + MM IC2 = IB + MM IWRK = IC2 + MM CALL MB04BD( 'Eigenvalues', CMPQ, CMPQ, N, A, LDA, DE, LDDE, B, $ LDB, FG, LDFG, DWORK, N, DWORK, N, DWORK( IB ), M, $ DWORK( IFO ), M, DWORK( IC2 ), M, ALPHAR, ALPHAI, $ BETA, IWORK, LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) END IF OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C IF( INFO.GT.0 .AND. INFO.LT.3 ) THEN INFO = 1 RETURN ELSE IF( INFO.EQ.3 ) THEN IW = 5 ELSE IW = 0 END IF C IF( .NOT.LINIQ ) THEN CALL MA02AD( 'Upper', M, M, DWORK( IC2 ), M, DE, LDDE ) CALL DCOPY( M-1, DWORK( IC2+1 ), M+1, DE( 1, 2 ), LDDE+1 ) DWORK( 1 ) = OPTDW INFO = IW RETURN END IF C C STEP 2: Build the needed parts of the extended matrices Se and He, C and compute the transformed matrices and the orthogonal matrices C Q3 and Q4. C C Real workspace: need w1 + w2 + 2*N**2 + MAX(M+168,272), with C w2 = 4*N**2 (COMPQ = 'C'); C prefer larger. C Integer workspace: need MAX(M+1,32). C NM = N*M NMM = NM + M IQ3 = IWRK IQ4 = IQ3 + NN IS11 = IQ4 + NN IH11 = IS11 + NN IWRK = IH11 + NN C CALL DLACPY( 'Full', M, M, A, LDA, DWORK( IS11 ), N ) CALL DLACPY( 'Full', M, M, Q( 1, IB ), M, DWORK( IS11+NMM ), N ) CALL DSCAL( MM, -ONE, Q( 1, IC2 ), 1 ) CALL DLACPY( 'Full', M, M, Q( 1, IC2 ), M, DWORK( IH11+M ), N ) CALL DLACPY( 'Full', M, M, B, LDB, DWORK( IH11+NM ), N ) C CALL MB04HD( CMPQ, CMPQ, N, DWORK( IS11 ), N, DWORK( IH11 ), N, $ DWORK( IQ3 ), N, DWORK( IQ4 ), N, IWORK, LIWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO ) IF( INFO.GT.0 ) THEN IF( INFO.GT.2 ) $ INFO = 2 RETURN END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C STEP 3: Update S12 and H12, building the upper triangular parts, C and exploiting the structure. Note that S12 is skew-symmetric and C H12 is symmetric. C C Real workspace: need w1 + w2 + w3, where C w3 = N**2 + M**2. C IS12 = IWRK IH12 = IS12 + NN IWRK = IH12 C IF( M.GT.1 ) THEN C C [ Qa Qc ] C Compute Qa'*Do*Qc + Qb'*Fo*Qd, where Q4 =: [ ], C [ Qb Qd ] C with Do := Dout, etc. C Compute also Qc'*Do*Qc + Qd'*Fo*Qd, using MB01KD. C Part of the array Q and DWORK(IS12) are used as workspace. C CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NM+1 ), N, $ DWORK( IS12 ), M ) CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NM ), N, Q( 2, IB ), $ M ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', M-1, $ M, ONE, DE( 1, 3 ), LDDE, DWORK( IS12 ), M ) C CALL MB01KD( 'Upper', 'Transpose', M, M-1, ONE, $ DWORK( IQ4+NM ), N, DWORK( IS12 ), M, ZERO, $ DWORK( IS12+NMM ), N, INFO ) C CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-Unit', M-1, M, $ -ONE, DE( 1, 3 ), LDDE, Q( 2, IB ), M ) DUM( 1 ) = ZERO CALL DCOPY( M, DUM, 0, DWORK( IS12+M-1 ), M ) CALL DCOPY( M, DUM, 0, Q( 1, IB ), M ) CALL DAXPY( MM, ONE, Q( 1, IB ), 1, DWORK( IS12 ), 1 ) C CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NMM+1 ), N, $ DWORK( IWRK ), M ) CALL DLACPY( 'Full', M-1, M, DWORK( IQ4+NMM ), N, Q( 2, IB ), $ M ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'Non-Unit', M-1, $ M, ONE, Q( M+1, IFO ), M, DWORK( IWRK ), M ) C CALL MB01KD( 'Upper', 'Transpose', M, M-1, ONE, $ DWORK( IQ4+NMM ), N, DWORK( IWRK ), M, ONE, $ DWORK( IS12+NMM ), N, INFO ) C CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-Unit', M-1, $ M, -ONE, Q( M+1, IFO ), M, Q( 2, IB ), M ) CALL DCOPY( M, DUM, 0, DWORK( IWRK+M-1 ), M ) CALL DAXPY( MM, ONE, Q( 1, IB ), 1, DWORK( IWRK ), 1 ) C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4 ), N, DWORK( IS12 ), M, ZERO, $ DWORK( IS12+NM ), N ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4+M ), N, DWORK( IWRK ), M, ONE, $ DWORK( IS12+NM ), N ) C C Compute Qa'*Do*Qa + Qb'*Fo*Qb. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, $ DWORK( IS12 ), N, DWORK( IQ4 ), N, DE( 1, 2 ), $ LDDE, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) CALL MB01LD( 'Upper', 'Transpose', M, M, ONE, ONE, $ DWORK( IS12 ), N, DWORK( IQ4+M ), N, Q( 1, IFO ), $ M, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) END IF C C Compute Qb'*Vo'*Qc + Qa'*Vo*Qd. C Real workspace: need w1 + w2 + w3, where C w3 = 2*N**2. C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ FG( 1, 2 ), LDFG, DWORK( IQ4+NM ), N, ZERO, $ Q( 1, IFO ), M ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ FG( 1, 2 ), LDFG, DWORK( IQ4 ), N, ZERO, $ DWORK( IH12+NMM ), N ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ4+M ), N, Q( 1, IFO ), M, ZERO, $ DWORK( IH12+NM ), N ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IH12+NMM ), N, DWORK( IQ4+NMM ), N, ONE, $ DWORK( IH12+NM ), N ) C C Compute the upper triangle of Qa'*Vo*Qb + (Qa'*Vo*Qb)'. C CALL DSYR2K( 'Upper', 'Transpose', M, M, ONE, DWORK( IH12+NMM ), $ N, DWORK( IQ4+M ), N, ZERO, DWORK( IH12 ), N ) C C Compute the upper triangle of Qc'*Vo*Qd + (Qc'*Vo*Qd)'. C CALL DSYR2K( 'Upper', 'Transpose', M, M, ONE, Q( 1, IFO ), M, $ DWORK( IQ4+NMM ), N, ZERO, DWORK( IH12+NMM ), N ) C C Return C2out. C CALL DSCAL( MM, -ONE, Q( 1, IC2 ), 1 ) CALL MA02AD( 'Upper', M, M, Q( 1, IC2 ), M, DE, LDDE ) CALL DCOPY( M-1, Q( 2, IC2 ), M+1, DE( 1, 2 ), LDDE+1 ) C C STEP 4: Apply MB03JD to reorder the eigenvalues with strictly C negative real part to the top. C C Real workspace: need w1 + w2 + w3 + MAX(8*N+32,108), C w3 = 2*N**2. C Integer workspace: need 2*N + 1. C IWRK = IH12 + NN C CALL MB03JD( CMPQ, N2, DWORK( IS11 ), N, DWORK( IS12 ), N, $ DWORK( IH11 ), N, DWORK( IH12 ), N, Q, LDQ, NEIG, $ IWORK, LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN INFO = INFO + 1 RETURN END IF C C STEP 5: Compute the deflating subspace corresponding to the C eigenvalues with strictly negative real part. C C Real workspace: need w2 + 3*N**2, if ORTH = 'QR'; C w2 + 4*N**2, otherwise. C IWRK = IS11 IF( QR ) $ NEIG = NEIG/2 C C Compute [ J*Q1*J' Q2 ]. C CALL DLACPY( 'Full', M, M, DWORK( IQ1+NMM ), N, DWORK( IWRK ), N ) CALL DLACPY( 'Full', M, M, DWORK( IQ1+NM ), N, DWORK( IWRK+M ), $ N ) DO 10 J = 1, M CALL DSCAL( M, -ONE, DWORK( IWRK+M+(J-1)*N ), 1 ) 10 CONTINUE CALL DLACPY( 'Full', M, M, DWORK( IQ1+M ), N, DWORK( IWRK+NM ), $ N ) DO 20 J = 1, M CALL DSCAL( M, -ONE, DWORK( IWRK+NM+(J-1)*N ), 1 ) 20 CONTINUE CALL DLACPY( 'Full', M, M, DWORK( IQ1 ), N, DWORK( IWRK+NMM ), N ) C CALL DLACPY( 'Full', N, N, DWORK( IQ2 ), N, DWORK( IWRK+NN ), N ) C C Compute the first NEIG columns of P*[ Q3 0; 0 Q4 ]*Q. C IRT = IWRK + N*N2 CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ3 ), N, Q, LDQ, ZERO, DWORK( IRT ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ4 ), N, Q( N+1, 1 ), LDQ, ZERO, $ DWORK( IRT+M ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ3+M ), N, Q, LDQ, ZERO, DWORK( IRT+N ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ4+M ), N, Q( N+1, 1 ), LDQ, ZERO, $ DWORK( IRT+N+M ), N2 ) C C Compute the deflating subspace. C CALL DGEMM( 'No Transpose', 'No Transpose', N, NEIG, N2, $ SQRT( TWO )/TWO, DWORK( IWRK ), N, DWORK( IRT ), N2, $ ZERO, Q, LDQ ) C C Orthogonalize the basis given in Q(1:n,1:neig). C IWRK = NEIG + 1 IF( SVD ) THEN C C Real workspace: need N + MAX(1,5*N); C prefer larger. C CALL DGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK, $ DWORK, 1, DWORK, 1, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO ) IF( INFO.GT.0 ) THEN INFO = 4 RETURN END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) NEIG = NEIG/2 C ELSE IF( QR ) THEN C C Real workspace: need N; C prefer M+M*NB, where NB is the optimal C blocksize. C CALL DGEQRF( N, NEIG, Q, LDQ, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) ELSE C C Real workspace: need 4*N+1; C prefer 3*N+(N+1)*NB. C DO 30 J = 1, NEIG IWORK( J ) = 0 30 CONTINUE CALL DGEQP3( N, NEIG, Q, LDQ, IWORK, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Real workspace: need 2*NEIG; C prefer NEIG + NEIG*NB. C CALL DORGQR( N, NEIG, NEIG, Q, LDQ, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) IF( QRP ) $ NEIG = NEIG/2 END IF C DWORK( 1 ) = OPTDW INFO = IW RETURN C *** Last line of MB03LD *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01RD.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/IB01RD.f0000644000175000017500000006434515012430707017366 0ustar00lilgelilge00000000000000 SUBROUTINE IB01RD( JOB, N, M, L, NSMP, A, LDA, B, LDB, C, LDC, D, $ LDD, U, LDU, Y, LDY, X0, TOL, IWORK, DWORK, $ LDWORK, IWARN, INFO ) C C PURPOSE C C To estimate the initial state of a linear time-invariant (LTI) C discrete-time system, given the system matrices (A,B,C,D) and C the input and output trajectories of the system. The model C structure is : C C x(k+1) = Ax(k) + Bu(k), k >= 0, C y(k) = Cx(k) + Du(k), C C where x(k) is the n-dimensional state vector (at time k), C u(k) is the m-dimensional input vector, C y(k) is the l-dimensional output vector, C and A, B, C, and D are real matrices of appropriate dimensions. C Matrix A is assumed to be in a real Schur form. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies whether or not the matrix D is zero, as follows: C = 'Z': the matrix D is zero; C = 'N': the matrix D is not zero. 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 number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L > 0. C C NSMP (input) INTEGER C The number of rows of matrices U and Y (number of C samples used, t). NSMP >= N. 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 in a real Schur form. 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 (corresponding to the real Schur C form of A). C If N = 0 or M = 0, this array is not referenced. C C LDB INTEGER C The leading dimension of the array B. C LDB >= N, if N > 0 and M > 0; C LDB >= 1, if N = 0 or M = 0. C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C The leading L-by-N part of this array must contain the C system output matrix C (corresponding to the real Schur C form of A). C C LDC INTEGER C The leading dimension of the array C. LDC >= L. C C D (input) DOUBLE PRECISION array, dimension (LDD,M) C The leading L-by-M part of this array must contain the C system input-output matrix. C If M = 0 or JOB = 'Z', this array is not referenced. C C LDD INTEGER C The leading dimension of the array D. C LDD >= L, if M > 0 and JOB = 'N'; C LDD >= 1, if M = 0 or JOB = 'Z'. C C U (input) DOUBLE PRECISION array, dimension (LDU,M) C If M > 0, the leading NSMP-by-M part of this array must C contain the t-by-m input-data sequence matrix U, C U = [u_1 u_2 ... u_m]. Column j of U contains the C NSMP values of the j-th input component for consecutive C time increments. C If M = 0, this array is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= MAX(1,NSMP), if M > 0; C LDU >= 1, if M = 0. C C Y (input) DOUBLE PRECISION array, dimension (LDY,L) C The leading NSMP-by-L part of this array must contain the C t-by-l output-data sequence matrix Y, C Y = [y_1 y_2 ... y_l]. Column j of Y contains the C NSMP values of the j-th output component for consecutive C time increments. C C LDY INTEGER C The leading dimension of the array Y. LDY >= MAX(1,NSMP). C C X0 (output) DOUBLE PRECISION array, dimension (N) C The estimated initial state of the system, x(0). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used for estimating the rank of C matrices. If the user sets TOL > 0, then the given value C of TOL is used as a lower bound for the reciprocal C condition number; a matrix whose estimated condition C number is less than 1/TOL is considered to be of full C rank. If the user sets TOL <= 0, then EPS is used C instead, where EPS is the relative machine precision C (see LAPACK Library routine DLAMCH). 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) returns the optimal value C of LDWORK and DWORK(2) contains the reciprocal condition C number of the triangular factor of the QR factorization of C the matrix Gamma (see METHOD). C On exit, if INFO = -22, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= max( 2, min( LDW1, LDW2 ) ), where C LDW1 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ), C LDW2 = N*(N + 1) + 2*N + C max( q*(N + 1) + 2*N*N + L*N, 4*N ), C q = N*L. C For good performance, LDWORK should be larger. C If LDWORK >= LDW1, then standard QR factorization of C the matrix Gamma (see METHOD) is used. Otherwise, the C QR factorization is computed sequentially by performing C NCYCLE cycles, each cycle (except possibly the last one) C processing s samples, where s is chosen by equating C LDWORK to LDW2, for q replaced by s*L. C The computational effort may increase and the accuracy may C decrease with the decrease of s. Recommended value is C LDRWRK = LDW1, assuming a large enough cache size, to C also accommodate A, B, C, D, U, and Y. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 4: the least squares problem to be solved has a C rank-deficient coefficient matrix. 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 = 2: the singular value decomposition (SVD) algorithm did C not converge. C C METHOD C C An extension and refinement of the method in [1] is used. C Specifically, the output y0(k) of the system for zero initial C state is computed for k = 0, 1, ..., t-1 using the given model. C Then the following least squares problem is solved for x(0) C C ( C ) ( y(0) - y0(0) ) C ( C*A ) ( y(1) - y0(1) ) C Gamma * x(0) = ( : ) * x(0) = ( : ). C ( : ) ( : ) C ( C*A^(t-1) ) ( y(t-1) - y0(t-1) ) C C The coefficient matrix Gamma is evaluated using powers of A with C exponents 2^k. The QR decomposition of this matrix is computed. C If its triangular factor R is too ill conditioned, then singular C value decomposition of R is used. C C If the coefficient matrix cannot be stored in the workspace (i.e., C LDWORK < LDW1), the QR decomposition is computed sequentially. C C REFERENCES C C [1] Verhaegen M., and Varga, A. C Some Experience with the MOESP Class of Subspace Model C Identification Methods in Identifying the BO105 Helicopter. C Report TR R165-94, DLR Oberpfaffenhofen, 1994. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. C C KEYWORDS C C Identification methods; least squares solutions; multivariable C systems; QR decomposition; singular value decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) C IBLOCK is a threshold value for switching to a block algorithm C for U (to avoid row by row passing through U). INTEGER IBLOCK PARAMETER ( IBLOCK = 16384 ) C .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, $ LDWORK, LDY, M, N, NSMP CHARACTER JOB C .. Array Arguments .. DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), $ DWORK(*), U(LDU, *), X0(*), Y(LDY, *) INTEGER IWORK(*) C .. Local Scalars .. DOUBLE PRECISION RCOND, TOLL INTEGER I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON, $ IG, INIGAM, INIH, INIR, INIT, IQ, IREM, IRHS, $ ISIZE, ISV, ITAU, IU, IUPNT, IUT, IUTRAN, IX, $ IXINIT, IY, IYPNT, J, JWORK, K, LDDW, LDR, $ LDW1, LDW2, MAXWRK, MINSMP, MINWLS, MINWRK, NC, $ NCP1, NCYCLE, NN, NOBS, NRBL, NROW, NSMPL, RANK LOGICAL BLOCK, FIRST, NCYC, POWER2, SWITCH, WITHD C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, ILAENV, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY, $ DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSV, $ MA02AD, MB01TD, MB04OD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD C .. Executable Statements .. C C Check the input parameters. C WITHD = LSAME( JOB, 'N' ) IWARN = 0 INFO = 0 NN = N*N MINSMP = N C IF( .NOT.( LSAME( JOB, 'Z' ) .OR. WITHD ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( L.LE.0 ) THEN INFO = -4 ELSE IF( NSMP.LT.MINSMP ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) THEN INFO = -9 ELSE IF( LDC.LT.L ) THEN INFO = -11 ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) $ THEN INFO = -13 ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN INFO = -15 ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN INFO = -17 ELSE IF( TOL.GT.ONE ) THEN INFO = -19 END IF C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 NSMPL = NSMP*L IQ = MINSMP*L NCP1 = N + 1 ISIZE = NSMPL*NCP1 IC = 2*NN MINWLS = MINSMP*NCP1 ITAU = IC + L*N LDW1 = ISIZE + 2*N + MAX( IC, 4*N ) LDW2 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N ) MINWRK = MAX( MIN( LDW1, LDW2 ), 2 ) IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN MAXWRK = ISIZE + 2*N + MAX( N*ILAENV( 1, 'DGEQRF', ' ', NSMPL, $ N, -1, -1 ), $ ILAENV( 1, 'DORMQR', 'LT', NSMPL, $ 1, N, -1 ) ) MAXWRK = MAX( MAXWRK, MINWRK ) END IF C IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN INFO = -22 DWORK(1) = MINWRK END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB01RD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = TWO DWORK(2) = ONE RETURN END IF C C Set up the least squares problem, either directly, if enough C workspace, or sequentially, otherwise. C IYPNT = 1 IUPNT = 1 INIR = 1 IF ( LDWORK.GE.LDW1 ) THEN C C Enough workspace for solving the problem directly. C NCYCLE = 1 NOBS = NSMP LDDW = NSMPL INIGAM = 1 ELSE C C NCYCLE > 1 cycles are needed for solving the problem C sequentially, taking NOBS samples in each cycle (or the C remaining samples in the last cycle). C JWORK = LDWORK - MINWLS - 2*N - ITAU LDDW = JWORK/NCP1 NOBS = LDDW/L LDDW = L*NOBS NCYCLE = NSMP/NOBS IF ( MOD( NSMP, NOBS ).NE.0 ) $ NCYCLE = NCYCLE + 1 INIH = INIR + NN INIGAM = INIH + N END IF C NCYC = NCYCLE.GT.1 IRHS = INIGAM + LDDW*N IXINIT = IRHS + LDDW IC = IXINIT + N IF( NCYC ) THEN IA = IC + L*N LDR = N IE = INIGAM ELSE INIH = IRHS IA = IC LDR = LDDW IE = IXINIT END IF IUTRAN = IA IAS = IA + NN ITAU = IA DUM(1) = ZERO C C Set block parameters for passing through the array U. C BLOCK = M.GT.1 .AND. NSMP*M.GE.IBLOCK IF ( BLOCK ) THEN NRBL = ( LDWORK - IUTRAN + 1 )/M NC = NOBS/NRBL IF ( MOD( NOBS, NRBL ).NE.0 ) $ NC = NC + 1 INIT = ( NC - 1 )*NRBL BLOCK = BLOCK .AND. NRBL.GT.1 END IF C C Perform direct of sequential compression of the matrix Gamma. C DO 150 ICYCLE = 1, NCYCLE FIRST = ICYCLE.EQ.1 IF ( .NOT.FIRST ) THEN IF ( ICYCLE.EQ.NCYCLE ) THEN NOBS = NSMP - ( NCYCLE - 1 )*NOBS LDDW = L*NOBS IF ( BLOCK ) THEN NC = NOBS/NRBL IF ( MOD( NOBS, NRBL ).NE.0 ) $ NC = NC + 1 INIT = ( NC - 1 )*NRBL END IF END IF END IF C C Compute the extended observability matrix Gamma. C Workspace: need s*L*(N + 1) + 2*N*N + 2*N + a + w, C where s = NOBS, C a = 0, w = 0, if NCYCLE = 1, C a = L*N, w = N*(N + 1), if NCYCLE > 1; C prefer as above, with s = t, a = w = 0. C JWORK = IAS + NN IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) ) IREM = L*( NOBS - 2**IEXPON ) POWER2 = IREM.EQ.0 IF ( .NOT.POWER2 ) $ IEXPON = IEXPON + 1 C IF ( FIRST ) THEN CALL DLACPY( 'Full', L, N, C, LDC, DWORK(INIGAM), LDDW ) ELSE CALL DLACPY( 'Full', L, N, DWORK(IC), L, DWORK(INIGAM), $ LDDW ) END IF C p C Use powers of the matrix A: A , p = 2**(J-1). C CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N ) IF ( N.GT.1 ) $ CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) I2 = L NROW = 0 C DO 20 J = 1, IEXPON IG = INIGAM IF ( J.LT.IEXPON .OR. POWER2 ) THEN NROW = I2 ELSE NROW = IREM END IF C CALL DLACPY( 'Full', NROW, N, DWORK(IG), LDDW, DWORK(IG+I2), $ LDDW ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', $ NROW, N, ONE, DWORK(IA), N, DWORK(IG+I2), $ LDDW ) C p C Compute the contribution of the subdiagonal of A to the C product. C DO 10 IX = 1, N - 1 CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), DWORK(IG+LDDW), $ 1, DWORK(IG+I2), 1 ) IG = IG + LDDW 10 CONTINUE C IF ( J.LT.IEXPON ) THEN 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 MB01TD( N, DWORK(IAS), N, DWORK(IA), N, $ DWORK(JWORK), IERR ) I2 = I2*2 END IF 20 CONTINUE C IF ( NCYC ) THEN IG = INIGAM + I2 + NROW - L CALL DLACPY( 'Full', L, N, DWORK(IG), LDDW, DWORK(IC), L ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', L, $ N, ONE, A, LDA, DWORK(IC), L ) C C Compute the contribution of the subdiagonal of A to the C product. C DO 30 IX = 1, N - 1 CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), 1, $ DWORK(IC+(IX-1)*L), 1 ) IG = IG + LDDW 30 CONTINUE C END IF C C Setup (part of) the right hand side of the least squares C problem starting from DWORK(IRHS); use the estimated output C trajectory for zero initial state, or for the saved final state C value of the previous cycle. C A specialization of SLICOT Library routine TF01ND is used. C For large input sets (NSMP*M >= IBLOCK), chunks of U are C transposed, to reduce the number of row-wise passes. C Workspace: need s*L*(N + 1) + N + w; C prefer as above, with s = t, w = 0. C IF ( FIRST ) $ CALL DCOPY( N, DUM, 0, DWORK(IXINIT), 1 ) CALL DCOPY( N, DWORK(IXINIT), 1, X0, 1 ) IY = IRHS C DO 40 J = 1, L CALL DCOPY( NOBS, Y(IYPNT,J), 1, DWORK(IY), L ) IY = IY + 1 40 CONTINUE C IY = IRHS IU = IUPNT IF ( M.GT.0 ) THEN IF ( WITHD ) THEN C IF ( BLOCK ) THEN SWITCH = .TRUE. NROW = NRBL C DO 60 K = 1, NOBS IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN IUT = IUTRAN IF ( K.GT.INIT ) THEN NROW = NOBS - INIT SWITCH = .FALSE. END IF CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, $ DWORK(IUT), M ) IU = IU + NROW END IF CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, $ 1, ONE, DWORK(IY), 1 ) CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, $ DWORK(IUT), 1, ONE, DWORK(IY), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, $ A, LDA, X0, 1 ) C DO 50 IX = 2, N X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) 50 CONTINUE C CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, $ DWORK(IUT), 1, ONE, X0, 1 ) CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) IY = IY + L IUT = IUT + M 60 CONTINUE C ELSE C DO 80 K = 1, NOBS CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, $ 1, ONE, DWORK(IY), 1 ) CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, $ U(IU,1), LDU, ONE, DWORK(IY), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, $ A, LDA, X0, 1 ) C DO 70 IX = 2, N X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) 70 CONTINUE C CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, $ U(IU,1), LDU, ONE, X0, 1 ) CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) IY = IY + L IU = IU + 1 80 CONTINUE C END IF C ELSE C IF ( BLOCK ) THEN SWITCH = .TRUE. NROW = NRBL C DO 100 K = 1, NOBS IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN IUT = IUTRAN IF ( K.GT.INIT ) THEN NROW = NOBS - INIT SWITCH = .FALSE. END IF CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, $ DWORK(IUT), M ) IU = IU + NROW END IF CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, $ 1, ONE, DWORK(IY), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, $ A, LDA, X0, 1 ) C DO 90 IX = 2, N X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) 90 CONTINUE C CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, $ DWORK(IUT), 1, ONE, X0, 1 ) CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) IY = IY + L IUT = IUT + M 100 CONTINUE C ELSE C DO 120 K = 1, NOBS CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, $ 1, ONE, DWORK(IY), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, $ A, LDA, X0, 1 ) C DO 110 IX = 2, N X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) 110 CONTINUE C CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, $ U(IU,1), LDU, ONE, X0, 1 ) CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) IY = IY + L IU = IU + 1 120 CONTINUE C END IF C END IF C ELSE C DO 140 K = 1, NOBS CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, 1, $ ONE, DWORK(IY), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, A, $ LDA, X0, 1 ) C DO 130 IX = 2, N X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) 130 CONTINUE C CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) IY = IY + L 140 CONTINUE C END IF C C Compress the data using (sequential) QR factorization. C Workspace: need v + 2*N; C where v = s*L*(N + 1) + N + a + w. C JWORK = ITAU + N IF ( FIRST ) THEN C C Compress the first data segment of Gamma. C Workspace: need v + 2*N, C prefer v + N + N*NB. C CALL DGEQRF( LDDW, N, DWORK(INIGAM), LDDW, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C C Apply the transformation to the right hand side part. C Workspace: need v + N + 1, C prefer v + N + NB. C CALL DORMQR( 'Left', 'Transpose', LDDW, 1, N, DWORK(INIGAM), $ LDDW, DWORK(ITAU), DWORK(IRHS), LDDW, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C IF ( NCYC ) THEN C C Save the triangular factor of Gamma and the C corresponding right hand side. C CALL DLACPY( 'Upper', N, NCP1, DWORK(INIGAM), LDDW, $ DWORK(INIR), LDR ) END IF ELSE C C Compress the current (but not the first) data segment of C Gamma. C Workspace: need v + N - 1. C CALL MB04OD( 'Full', N, 1, LDDW, DWORK(INIR), LDR, $ DWORK(INIGAM), LDDW, DWORK(INIH), LDR, $ DWORK(IRHS), LDDW, DWORK(ITAU), DWORK(JWORK) ) END IF C IUPNT = IUPNT + NOBS IYPNT = IYPNT + NOBS 150 CONTINUE C C Estimate the reciprocal condition number of the triangular factor C of the QR decomposition. C Workspace: need u + 3*N, where C u = t*L*(N + 1), if NCYCLE = 1; C u = w, if NCYCLE > 1. C CALL DTRCON( '1-norm', 'Upper', 'No Transpose', N, DWORK(INIR), $ LDR, RCOND, DWORK(IE), IWORK, IERR ) C TOLL = TOL IF ( TOLL.LE.ZERO ) $ TOLL = DLAMCH( 'Precision' ) IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN IWARN = 4 C C The least squares problem is ill-conditioned. C Use SVD to solve it. C Workspace: need u + 6*N; C prefer larger. C CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, DWORK(INIR+1), $ LDR ) ISV = IE JWORK = ISV + N CALL DGELSS( N, N, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) IF ( IERR.GT.0 ) THEN C C Return if SVD algorithm did not converge. C INFO = 2 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) ELSE C C Find the least squares solution using QR decomposition only. C CALL DTRSV( 'Upper', 'No Transpose', 'Non Unit', N, $ DWORK(INIR), LDR, DWORK(INIH), 1 ) END IF C C Return the estimated initial state of the system x0. C CALL DCOPY( N, DWORK(INIH), 1, X0, 1 ) C DWORK(1) = MAXWRK DWORK(2) = RCOND C RETURN C C *** End of IB01RD *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02DD.f0000644000000000000000000000013215012430707016144 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02DD.f0000644000175000017500000001056515012430707017347 0ustar00lilgelilge00000000000000 SUBROUTINE MA02DD( JOB, UPLO, N, A, LDA, AP ) C C PURPOSE C C To pack/unpack the upper or lower triangle of a symmetric matrix. C The packed matrix is stored column-wise in the one-dimensional C array AP. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies whether the matrix should be packed or unpacked, C as follows: C = 'P': The matrix should be packed; C = 'U': The matrix should be unpacked. C C UPLO CHARACTER*1 C Specifies the part of the matrix to be packed/unpacked, C as follows: C = 'U': Upper triangular part; C = 'L': Lower triangular part. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C A (input or output) DOUBLE PRECISION array, dimension C (LDA,N) C This array is an input parameter if JOB = 'P', and an C output parameter if JOB = 'U'. C On entry, if JOB = 'P', the leading N-by-N upper C triangular part (if UPLO = 'U'), or lower triangular part C (if UPLO = 'L'), of this array must contain the C corresponding upper or lower triangle of the symmetric C matrix A, and the other strictly triangular part is not C referenced. C On exit, if JOB = 'U', the leading N-by-N upper triangular C part (if UPLO = 'U'), or lower triangular part (if C UPLO = 'L'), of this array contains the corresponding C upper or lower triangle of the symmetric matrix A; the C other strictly triangular part is not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C AP (output or input) DOUBLE PRECISION array, dimension C (N*(N+1)/2) C This array is an output parameter if JOB = 'P', and an C input parameter if JOB = 'U'. C On entry, if JOB = 'U', the leading N*(N+1)/2 elements of C this array must contain the upper (if UPLO = 'U') or lower C (if UPLO = 'L') triangle of the symmetric matrix A, packed C column-wise. That is, the elements are stored in the order C 11, 12, 22, ..., 1n, 2n, 3n, ..., nn, if UPLO = 'U'; C 11, 21, 31, ..., n1, 22, 32, ..., n2, ..., if UPLO = 'L'. C On exit, if JOB = 'P', the leading N*(N+1)/2 elements of C this array contain the upper (if UPLO = 'U') or lower C (if UPLO = 'L') triangle of the symmetric matrix A, packed C column-wise, as described above. 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 JOB, UPLO INTEGER LDA, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), AP(*) C .. Local Scalars .. LOGICAL LUPLO INTEGER IJ, 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 LUPLO = LSAME( UPLO, 'L' ) IJ = 1 IF( LSAME( JOB, 'P' ) ) THEN IF( LUPLO ) THEN C C Pack the lower triangle of A. C DO 20 J = 1, N CALL DCOPY( N-J+1, A(J,J), 1, AP(IJ), 1 ) IJ = IJ + N - J + 1 20 CONTINUE C ELSE C C Pack the upper triangle of A. C DO 40 J = 1, N CALL DCOPY( J, A(1,J), 1, AP(IJ), 1 ) IJ = IJ + J 40 CONTINUE C END IF ELSE IF( LUPLO ) THEN C C Unpack the lower triangle of A. C DO 60 J = 1, N CALL DCOPY( N-J+1, AP(IJ), 1, A(J,J), 1 ) IJ = IJ + N - J + 1 60 CONTINUE C ELSE C C Unpack the upper triangle of A. C DO 80 J = 1, N CALL DCOPY( J, AP(IJ), 1, A(1,J), 1 ) IJ = IJ + J 80 CONTINUE C END IF END IF C RETURN C *** Last line of MA02DD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB03AD.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB03AD.f0000644000175000017500000006273715012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE TB03AD( LERI, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, $ D, LDD, NR, INDEX, PCOEFF, LDPCO1, LDPCO2, $ QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, LDVCO2, $ TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To find a relatively prime left polynomial matrix representation C inv(P(s))*Q(s) or right polynomial matrix representation C Q(s)*inv(P(s)) with the same transfer matrix T(s) as that of a C given state-space representation, i.e. C C inv(P(s))*Q(s) = Q(s)*inv(P(s)) = T(s) = C*inv(s*I-A)*B + D. C C ARGUMENTS C C Mode Parameters C C LERI CHARACTER*1 C Indicates whether the left polynomial matrix C representation or the right polynomial matrix C representation is required as follows: C = 'L': A left matrix fraction is required; C = 'R': A right matrix fraction is required. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to balance the triplet C (A,B,C), before computing a minimal state-space C representation, 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 order of the state-space representation, i.e. the C order of the original state dynamics 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/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the original state dynamics matrix A. C On exit, the leading NR-by-NR part of this array contains C the upper block Hessenberg state dynamics matrix Amin of a C minimal realization for the original system. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,MAX(M,P)) C On entry, the leading N-by-M part of this array must C contain the original input/state matrix B; the remainder C of the leading N-by-MAX(M,P) part is used as internal C workspace. C On exit, the leading NR-by-M part of this array contains C the transformed input/state matrix Bmin. 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 original state/output matrix C; the remainder C of the leading MAX(M,P)-by-N part is used as internal C workspace. C On exit, the leading P-by-NR part of this array contains C the transformed state/output matrix Cmin. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,M,P). C C D (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) C The leading P-by-M part of this array must contain the C original direct transmission matrix D; the remainder of C the leading MAX(M,P)-by-MAX(M,P) part is used as internal C workspace. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,M,P). C C NR (output) INTEGER C The order of the minimal state-space representation C (Amin,Bmin,Cmin). C C INDEX (output) INTEGER array, dimension (P), if LERI = 'L', or C dimension (M), if LERI = 'R'. C If LERI = 'L', INDEX(I), I = 1,2,...,P, contains the C maximum degree of the polynomials in the I-th row of the C denominator matrix P(s) of the left polynomial matrix C representation. C These elements are ordered so that C INDEX(1) >= INDEX(2) >= ... >= INDEX(P). C If LERI = 'R', INDEX(I), I = 1,2,...,M, contains the C maximum degree of the polynomials in the I-th column of C the denominator matrix P(s) of the right polynomial C matrix representation. C These elements are ordered so that C INDEX(1) >= INDEX(2) >= ... >= INDEX(M). C C PCOEFF (output) DOUBLE PRECISION array, dimension C (LDPCO1,LDPCO2,N+1) C If LERI = 'L' then porm = P, otherwise porm = M. C The leading porm-by-porm-by-kpcoef part of this array C contains the coefficients of the denominator matrix P(s), C where kpcoef = MAX(INDEX(I)) + 1. C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if C LERI = 'L' then iorj = I, otherwise iorj = J. C Thus for LERI = 'L', P(s) = C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). C C LDPCO1 INTEGER C The leading dimension of array PCOEFF. C LDPCO1 >= MAX(1,P), if LERI = 'L'; C LDPCO1 >= MAX(1,M), if LERI = 'R'. C C LDPCO2 INTEGER C The second dimension of array PCOEFF. C LDPCO2 >= MAX(1,P), if LERI = 'L'; C LDPCO2 >= MAX(1,M), if LERI = 'R'. C C QCOEFF (output) DOUBLE PRECISION array, dimension C (LDQCO1,LDQCO2,N+1) C If LERI = 'L' then porp = M, otherwise porp = P. C If LERI = 'L', the leading porm-by-porp-by-kpcoef part C of this array contains the coefficients of the numerator C matrix Q(s). C If LERI = 'R', the leading porp-by-porm-by-kpcoef part C of this array contains the coefficients of the numerator C matrix Q(s). C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). C C LDQCO1 INTEGER C The leading dimension of array QCOEFF. C LDQCO1 >= MAX(1,P), if LERI = 'L'; C LDQCO1 >= MAX(1,M,P), if LERI = 'R'. C C LDQCO2 INTEGER C The second dimension of array QCOEFF. C LDQCO2 >= MAX(1,M), if LERI = 'L'; C LDQCO2 >= MAX(1,M,P), if LERI = 'R'. C C VCOEFF (output) DOUBLE PRECISION array, dimension C (LDVCO1,LDVCO2,N+1) C The leading porm-by-NR-by-kpcoef part of this array C contains the coefficients of the intermediate matrix V(s). C VCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). C C LDVCO1 INTEGER C The leading dimension of array VCOEFF. C LDVCO1 >= MAX(1,P), if LERI = 'L'; C LDVCO1 >= MAX(1,M), if LERI = 'R'. C C LDVCO2 INTEGER C The second dimension of array VCOEFF. LDVCO2 >= MAX(1,N). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determination when C transforming (A, B, C). If the user sets TOL > 0, then C the given value of TOL is used as a lower bound for the C reciprocal condition number (see the description of the C argument RCOND in the SLICOT routine MB03OD); a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance C (determined by the SLICOT routine TB01UD) is used instead. C C Workspace C C IWORK INTEGER array, dimension (N+MAX(M,P)) C On exit, if INFO = 0, the first nonzero elements of C IWORK(1:N) return the orders of the diagonal blocks of A. 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, N + MAX(N, 3*M, 3*P), PM*(PM + 2)) C where PM = P, if LERI = 'L'; C PM = M, if LERI = 'R'. 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: if a singular matrix was encountered during the C computation of V(s); C = 2: if a singular matrix was encountered during the C computation of P(s). C C METHOD C C The method for a left matrix fraction will be described here: C right matrix fractions are dealt with by constructing a left C fraction for the dual of the original system. The first step is to C obtain, by means of orthogonal similarity transformations, a C minimal state-space representation (Amin,Bmin,Cmin,D) for the C original system (A,B,C,D), where Amin is lower block Hessenberg C with all its superdiagonal blocks upper triangular and Cmin has C all but its first rank(C) columns zero. The number and dimensions C of the blocks of Amin now immediately yield the row degrees of C P(s) with P(s) row proper: furthermore, the P-by-NR polynomial C matrix V(s) (playing a similar role to S(s) in Wolovich's C Structure Theorem) can be calculated a column block at a time, in C reverse order, from Amin. P(s) is then found as if it were the C O-th column block of V(s) (using Cmin as well as Amin), while C Q(s) = (V(s) * Bmin) + (P(s) * D). Finally, a special similarity C transformation is used to put Amin in an upper block Hessenberg C form. C C REFERENCES C C [1] Williams, T.W.C. C An Orthogonal Structure Theorem for Linear Systems. C Kingston Polytechnic Control Systems Research Group, C Internal Report 82/2, July 1982. C C [2] Patel, R.V. C On Computing Matrix Fraction Descriptions and Canonical C Forms of Linear Time-Invariant Systems. C UMIST Control Systems Centre Report 489, 1980. C (Algorithms 1 and 2, extensively modified). C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. C Supersedes Release 3.0 routine TB01SD. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. C C KEYWORDS C C Canonical form, coprime matrix fraction, dual system, elementary C polynomial operations, Hessenberg form, minimal realization, C orthogonal transformation, polynomial matrix, state-space C representation, transfer matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL, LERI INTEGER INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, $ LDQCO1, LDQCO2, LDVCO1, LDVCO2, LDWORK, M, N, $ NR, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER INDEX(*), IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), $ QCOEFF(LDQCO1,LDQCO2,*), VCOEFF(LDVCO1,LDVCO2,*) C .. Local Scalars .. LOGICAL LEQUIL, LLERIL, LLERIR INTEGER I, IC, IFIRST, INDBLK, INPLUS, IOFF, IRANKC, $ ISTART, ISTOP, ITAU, IZ, JOFF, JWORK, K, KMAX, $ KPCOEF, KPLUS, KWORK, LDWRIC, MAXMP, MPLIM, $ MWORK, NCOL, NCONT, NREFLC, NROW, PWORK, WRKOPT DOUBLE PRECISION MAXRED C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB07MD, DGEMM, DGEQRF, DGETRF, DLACPY, DLASET, $ DORMQR, DTRSM, MA02GD, TB01ID, TB01UD, TB01YD, $ TB03AY, TC01OD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C INFO = 0 LLERIL = LSAME( LERI, 'L' ) LLERIR = LSAME( LERI, 'R' ) LEQUIL = LSAME( EQUIL, 'S' ) MAXMP = MAX( M, P ) MPLIM = MAX( 1, MAXMP ) IF ( LLERIR ) THEN C C Initialization for right matrix fraction. C PWORK = M MWORK = P ELSE C C Initialization for left matrix fraction. C PWORK = P MWORK = M END IF C C Test the input scalar arguments. C IF( .NOT.LLERIL .AND. .NOT.LLERIR ) THEN INFO = -1 ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) 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.MPLIM ) THEN INFO = -11 ELSE IF( LDD.LT.MPLIM ) THEN INFO = -13 ELSE IF( LDPCO1.LT.MAX( 1, PWORK ) ) THEN INFO = -17 ELSE IF( LDPCO2.LT.MAX( 1, PWORK ) ) THEN INFO = -18 ELSE IF( LDQCO1.LT.MAX( 1, PWORK ) .OR. LLERIR .AND. $ LDQCO1.LT.MPLIM ) THEN INFO = -20 ELSE IF( LDQCO2.LT.MAX( 1, MWORK ) .OR. LLERIR .AND. $ LDQCO2.LT.MPLIM ) THEN INFO = -21 ELSE IF( LDVCO1.LT.MAX( 1, PWORK ) ) THEN INFO = -23 ELSE IF( LDVCO2.LT.MAX( 1, N ) ) THEN INFO = -24 ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ), $ PWORK*( PWORK + 2 ) ) ) THEN INFO = -28 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB03AD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, M, P ).EQ.0 ) THEN NR = 0 DWORK(1) = ONE RETURN END IF C IF ( LLERIR ) THEN C C For right matrix fraction, obtain dual system. C CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ INFO ) END IF C C Obtain minimal realization, in canonical form, for this system. C Part of the code in SLICOT routine TB01PD is included in-line C here. (TB01PD cannot be directly used.) 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 C If required, balance the triplet (A,B,C) (default MAXRED). C Workspace: need N. C IF ( LEQUIL ) THEN MAXRED = ZERO CALL TB01ID( 'A', N, MWORK, PWORK, MAXRED, A, LDA, B, LDB, C, $ LDC, DWORK, INFO ) END IF C IZ = 1 ITAU = 1 JWORK = ITAU + N C C Separate out controllable subsystem (of order NCONT): C A <-- Z'*A*Z, B <-- Z'*B, C <-- C*Z. C C Workspace: need N + MAX(N, 3*MWORK, PWORK). C prefer larger. C CALL TB01UD( 'No Z', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, $ NCONT, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL, $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 C C Separate out the observable subsystem (of order NR): C Form the dual of the subsystem of order NCONT (which is C controllable), leaving rest as it is. C CALL AB07MD( 'Z', NCONT, MWORK, PWORK, A, LDA, B, LDB, C, LDC, $ DWORK, 1, INFO ) C C And separate out the controllable part of this dual subsystem. C C Workspace: need NCONT + MAX(NCONT, 3*PWORK, MWORK). C prefer larger. C CALL TB01UD( 'No Z', NCONT, PWORK, MWORK, A, LDA, B, LDB, C, LDC, $ NR, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL, $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Retranspose, giving controllable and observable (i.e. minimal) C part of original system. C CALL AB07MD( 'Z', NR, PWORK, MWORK, A, LDA, B, LDB, C, LDC, DWORK, $ 1, INFO ) C C Annihilate the trailing components of IWORK(1:N). C DO 10 I = INDBLK + 1, N IWORK(I) = 0 10 CONTINUE C C Initialize polynomial matrices P(s), Q(s) and V(s) to zero. C DO 20 K = 1, N + 1 CALL DLASET( 'Full', PWORK, PWORK, ZERO, ZERO, PCOEFF(1,1,K), $ LDPCO1 ) CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, QCOEFF(1,1,K), $ LDQCO1 ) CALL DLASET( 'Full', PWORK, NR, ZERO, ZERO, VCOEFF(1,1,K), $ LDVCO1 ) 20 CONTINUE C C Finish initializing V(s), and set up row degrees of P(s). C INPLUS = INDBLK + 1 ISTART = 1 JOFF = NR C DO 40 K = 1, INDBLK KWORK = INPLUS - K KPLUS = KWORK + 1 ISTOP = IWORK(KWORK) JOFF = JOFF - ISTOP C DO 30 I = ISTART, ISTOP INDEX(I) = KWORK VCOEFF(I,JOFF+I,KPLUS) = ONE 30 CONTINUE C ISTART = ISTOP + 1 40 CONTINUE C C ISTART = IWORK(1)+1 now: if .LE. PWORK, set up final rows of P(s). C DO 50 I = ISTART, PWORK INDEX(I) = 0 PCOEFF(I,I,1) = ONE 50 CONTINUE C C Triangularize the superdiagonal blocks of Amin. C NROW = IWORK(INDBLK) IOFF = NR - NROW KMAX = INDBLK - 1 ITAU = 1 IFIRST = 0 IF ( INDBLK.GT.2 ) IFIRST = IOFF - IWORK(KMAX) C C QR decomposition of each superdiagonal block of A in turn C (done in reverse order to preserve upper triangular blocks in A). C DO 60 K = 1, KMAX C C Calculate dimensions of new block & its position in A. C KWORK = INDBLK - K NCOL = NROW NROW = IWORK(KWORK) JOFF = IOFF IOFF = IOFF - NROW NREFLC = MIN( NROW, NCOL ) JWORK = ITAU + NREFLC IF ( KWORK.GE.2 ) IFIRST = IFIRST - IWORK(KWORK-1) C C Find QR decomposition of this (full rank) block: C block = QR. No pivoting is needed. C C Workspace: need MIN(NROW,NCOL) + NCOL; C prefer MIN(NROW,NCOL) + NCOL*NB. C CALL DGEQRF( NROW, NCOL, A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Premultiply appropriate row block of A by Q'. C C Workspace: need MIN(NROW,NCOL) + JOFF; C prefer MIN(NROW,NCOL) + JOFF*NB. C CALL DORMQR( 'Left', 'Transpose', NROW, JOFF, NREFLC, $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), A(IOFF+1,1), $ LDA, DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Premultiply appropriate row block of B by Q' also. C C Workspace: need MIN(NROW,NCOL) + MWORK; C prefer MIN(NROW,NCOL) + MWORK*NB. C CALL DORMQR( 'Left', 'Transpose', NROW, MWORK, NREFLC, $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), B(IOFF+1,1), $ LDB, DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C And postmultiply the non-zero part of appropriate column C block of A by Q. C C Workspace: need MIN(NROW,NCOL) + NR; C prefer MIN(NROW,NCOL) + NR*NB. C CALL DORMQR( 'Right', 'No Transpose', NR-IFIRST, NROW, NREFLC, $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), $ A(IFIRST+1,IOFF+1), LDA, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Annihilate the lower triangular part of the block in A. C IF ( K.NE.KMAX .AND. NROW.GT.1 ) $ CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO, $ A(IOFF+2,JOFF+1), LDA ) C 60 CONTINUE C C Finally: postmultiply non-zero columns of C by Q (K = KMAX). C C Workspace: need MIN(NROW,NCOL) + PWORK; C prefer MIN(NROW,NCOL) + PWORK*NB. C CALL DORMQR( 'Right', 'No Transpose', PWORK, NROW, NREFLC, $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), C, LDC, $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Annihilate the lower triangular part of the block in A. C IF ( NROW.GT.1 ) $ CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO, $ A(IOFF+2,JOFF+1), LDA ) C C Calculate the (PWORK x NR) polynomial matrix V(s) ... C CALL TB03AY( NR, A, LDA, INDBLK, IWORK, VCOEFF, LDVCO1, LDVCO2, $ PCOEFF, LDPCO1, LDPCO2, INFO) C IF ( INFO.NE.0 ) THEN INFO = 1 RETURN ELSE C C And then use this matrix to calculate P(s): first store C C1 from C. C IC = 1 IRANKC = IWORK(1) LDWRIC = MAX( 1, PWORK ) CALL DLACPY( 'Full', PWORK, IRANKC, C, LDC, DWORK(IC), LDWRIC ) C IF ( IRANKC.LT.PWORK ) THEN C C rank(C) .LT. PWORK: obtain QR decomposition of C1, C giving R and Q. C C Workspace: need PWORK*IRANKC + 2*IRANKC; C prefer PWORK*IRANKC + IRANKC + IRANKC*NB. C ITAU = IC + LDWRIC*IRANKC JWORK = ITAU + IRANKC C CALL DGEQRF( PWORK, IRANKC, DWORK(IC), LDWRIC, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C First IRANKC rows of Pbar(s) are given by Wbar(s) * inv(R). C Check for zero diagonal elements of R. C DO 70 I = 1, IRANKC IF ( DWORK(IC+(I-1)*LDWRIC+I-1).EQ.ZERO ) THEN C C Error return. C INFO = 2 RETURN END IF 70 CONTINUE C NROW = IRANKC C DO 80 K = 1, INPLUS CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit', $ NROW, IRANKC, ONE, DWORK(IC), LDWRIC, $ PCOEFF(1,1,K), LDPCO1 ) NROW = IWORK(K) 80 CONTINUE C C P(s) itself is now given by Pbar(s) * Q'. C NROW = PWORK C DO 90 K = 1, INPLUS C C Workspace: need PWORK*IRANKC + IRANKC + NROW; C prefer PWORK*IRANKC + IRANKC + NROW*NB. C CALL DORMQR( 'Right', 'Transpose', NROW, PWORK, IRANKC, $ DWORK(IC), LDWRIC, DWORK(ITAU), $ PCOEFF(1,1,K), LDPCO1, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) NROW = IWORK(K) 90 CONTINUE C ELSE C C Special case rank(C) = PWORK, full: C no QR decomposition (P(s)=Wbar(s)*inv(C1)). C CALL DGETRF( PWORK, PWORK, DWORK(IC), LDWRIC, IWORK(N+1), $ INFO ) C IF ( INFO.NE.0 ) THEN C C Error return. C INFO = 2 RETURN ELSE C NROW = IRANKC C C Workspace: need PWORK*IRANKC + N. C DO 100 K = 1, INPLUS CALL DTRSM( 'Right', 'Upper', 'No Transpose', $ 'Non-unit', NROW, PWORK, ONE, DWORK(IC), $ LDWRIC, PCOEFF(1,1,K), LDPCO1 ) CALL DTRSM( 'Right', 'Lower', 'No Transpose', 'Unit', $ NROW, PWORK, ONE, DWORK(IC), LDWRIC, $ PCOEFF(1,1,K), LDPCO1 ) CALL MA02GD( NROW, PCOEFF(1,1,K), LDPCO1, 1, PWORK, $ IWORK(N+1), -1 ) NROW = IWORK(K) 100 CONTINUE END IF END IF C C Finally, Q(s) = V(s) * B + P(s) * D can now be evaluated. C NROW = PWORK C DO 110 K = 1, INPLUS CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK, $ NR, ONE, VCOEFF(1,1,K), LDVCO1, B, LDB, ZERO, $ QCOEFF(1,1,K), LDQCO1 ) CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK, $ PWORK, ONE, PCOEFF(1,1,K), LDPCO1, D, LDD, ONE, $ QCOEFF(1,1,K), LDQCO1 ) NROW = IWORK(K) 110 CONTINUE C END IF C IF ( LLERIR ) THEN C C For right matrix fraction, return to original (dual of dual) C system. C CALL AB07MD( 'Z', NR, MWORK, PWORK, A, LDA, B, LDB, C, LDC, $ DWORK, 1, INFO ) C C Also, obtain the dual of the polynomial matrix representation. C KPCOEF = 0 C DO 120 I = 1, PWORK KPCOEF = MAX( KPCOEF, INDEX(I) ) 120 CONTINUE C KPCOEF = KPCOEF + 1 CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO ) ELSE C C Reorder the rows and columns of the system, to get an upper C block Hessenberg matrix A of the minimal system. C CALL TB01YD( NR, M, P, A, LDA, B, LDB, C, LDC, INFO ) END IF C C Set optimal workspace dimension. C DWORK(1) = WRKOPT RETURN C *** Last line of TB03AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03RY.f0000644000000000000000000000013215012430707016211 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03RY.f0000644000175000017500000001767715012430707017427 0ustar00lilgelilge00000000000000 SUBROUTINE MB03RY( M, N, PMAX, A, LDA, B, LDB, C, LDC, INFO ) C C PURPOSE C C To solve the Sylvester equation -AX + XB = C, where A and B are C M-by-M and N-by-N matrices, respectively, in real Schur form. C C This routine is intended to be called only by SLICOT Library C routine MB03RD. For efficiency purposes, the computations are C aborted when the infinity norm of an elementary submatrix of X is C greater than a given value PMAX. C C ARGUMENTS C C Input/Output Parameters C C M (input) INTEGER C The order of the matrix A and the number of rows of the C matrices C and X. M >= 0. C C N (input) INTEGER C The order of the matrix B and the number of columns of the C matrices C and X. N >= 0. C C PMAX (input) DOUBLE PRECISION C An upper bound for the infinity norm of an elementary C submatrix of X (see METHOD). C C A (input) DOUBLE PRECISION array, dimension (LDA,M) C The leading M-by-M part of this array must contain the C matrix A of the Sylvester equation, in real Schur form. C The elements below the real Schur form are not referenced. 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 the C matrix B of the Sylvester equation, in real Schur form. C The elements below the real Schur form are not referenced. 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 matrix C of the Sylvester equation. C On exit, if INFO = 0, the leading M-by-N part of this C array contains the solution matrix X of the Sylvester C equation, and each elementary submatrix of X (see METHOD) C has the infinity norm less than or equal to PMAX. C On exit, if INFO = 1, the solution matrix X has not been C computed completely, because an elementary submatrix of X C had the infinity norm greater than PMAX. Part of the C matrix C has possibly been overwritten with the C corresponding part of X. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,M). C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: an elementary submatrix of X had the infinity norm C greater than the given value PMAX. C C METHOD C C The routine uses an adaptation of the standard method for solving C Sylvester equations [1], which controls the magnitude of the C individual elements of the computed solution [2]. The equation C -AX + XB = C can be rewritten as C p l-1 C -A X + X B = C + sum A X - sum X B C kk kl kl ll kl i=k+1 ki il j=1 kj jl C C for l = 1:q, and k = p:-1:1, where A , B , C , and X , are C kk ll kl kl C block submatrices defined by the partitioning induced by the Schur C form of A and B, and p and q are the numbers of the diagonal C blocks of A and B, respectively. So, the elementary submatrices of C X are found block column by block column, starting from the C bottom. If any such elementary submatrix has the infinity norm C greater than the given value PMAX, the calculations are ended. C C REFERENCES C C [1] 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 [2] Bavely, C. and Stewart, G.W. C An Algorithm for Computing Reducing Subspaces by Block C Diagonalization. C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. C C NUMERICAL ASPECTS C 2 2 C The algorithm requires 0(M N + MN ) operations. C C FURTHER COMMENTS C C Let C C ( A C ) ( I X ) C M = ( ), Y = ( ). C ( 0 B ) ( 0 I ) C C Then C C -1 ( A 0 ) C Y M Y = ( ), C ( 0 B ) C C hence Y is an non-orthogonal transformation matrix which performs C the reduction of M to a block-diagonal form. Bounding a norm of C X is equivalent to setting an upper bound to the condition number C of the transformation matrix Y. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. C Based on the RASP routine SYLSM by A. Varga, German Aerospace C Center, DLR Oberpfaffenhofen. C C REVISIONS C C - C C KEYWORDS C C Diagonalization, real Schur form, 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, M, N DOUBLE PRECISION PMAX C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) C .. Local Scalars .. INTEGER DK, DL, I, IERR, J, K, KK, KK1, L, LL, LM1 DOUBLE PRECISION PNORM, SCALE C .. Local Arrays .. DOUBLE PRECISION P(4) C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. External Subroutines .. EXTERNAL DGEMM, DGEMV, DLASY2 C .. Executable Statements .. C C For efficiency reasons, this routine does not check the input C parameters for errors. C INFO = 0 C C Column loop indexed by L. C L = 1 C WHILE ( L.LE.N ) DO 10 IF ( L.LE.N ) THEN LM1 = L - 1 DL = 1 IF ( L.LT.N ) THEN IF ( B(L+1,L).NE.ZERO ) $ DL = 2 ENDIF LL = LM1 + DL IF ( LM1.GT.0 ) THEN C C Update one (or two) column(s) of C. C IF ( DL.EQ.2 ) THEN CALL DGEMM( 'No transpose', 'No transpose', M, DL, LM1, $ -ONE, C, LDC, B(1,L), LDB, ONE, C(1,L), LDC ) ELSE CALL DGEMV( 'No transpose', M, LM1, -ONE, C, LDC, B(1,L), $ 1, ONE, C(1,L), 1 ) END IF ENDIF C C Row loop indexed by KK. C KK = M C WHILE ( KK.GE.1 ) DO 20 IF ( KK.GE.1 ) THEN KK1 = KK + 1 DK = 1 IF ( KK.GT.1 ) THEN IF ( A(KK,KK-1).NE.ZERO ) $ DK = 2 ENDIF K = KK1 - DK IF ( K.LT.M ) THEN C C Update an elementary submatrix of C. C DO 40 J = L, LL C DO 30 I = K, KK C(I,J) = C(I,J) + $ DDOT( M-KK, A(I,KK1), LDA, C(KK1,J), 1 ) 30 CONTINUE C 40 CONTINUE C ENDIF CALL DLASY2( .FALSE., .FALSE., -1, DK, DL, A(K,K), LDA, $ B(L,L), LDB, C(K,L), LDC, SCALE, P, DK, PNORM, $ IERR ) IF( SCALE.NE.ONE .OR. PNORM.GT.PMAX ) THEN INFO = 1 RETURN END IF C(K,L) = -P(1) IF ( DL.EQ.1 ) THEN IF ( DK.EQ.2 ) $ C(KK,L) = -P(2) ELSE IF ( DK.EQ.1 ) THEN C(K,LL) = -P(2) ELSE C(KK,L) = -P(2) C(K,LL) = -P(3) C(KK,LL) = -P(4) ENDIF ENDIF KK = KK - DK GO TO 20 END IF C END WHILE 20 L = L + DL GO TO 10 END IF C END WHILE 10 RETURN C *** Last line of MB03RY *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01MD.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01MD.f0000644000175000017500000004040015012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE TG01MD( JOB, N, M, P, A, LDA, E, LDE, B, LDB, C, LDC, $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, NF, ND, $ NIBLCK, IBLCK, TOL, IWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute orthogonal transformation matrices Q and Z which C reduce the regular pole pencil A-lambda*E of the descriptor system C (A-lambda*E,B,C) to the form (if JOB = 'F') C C ( Af * ) ( Ef * ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) , (1) C ( 0 Ai ) ( 0 Ei ) C C or to the form (if JOB = 'I') C C ( Ai * ) ( Ei * ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) , (2) C ( 0 Af ) ( 0 Ef ) C C where the pair (Af,Ef) is in a generalized real Schur form, with C Ef nonsingular and upper triangular and Af in real Schur form. C The subpencil Af-lambda*Ef contains the finite eigenvalues. C The pair (Ai,Ei) is in a generalized real Schur form with C both Ai and Ei upper triangular. The subpencil Ai-lambda*Ei, C with Ai nonsingular and Ei nilpotent contains the infinite C eigenvalues and is in a block staircase form (see METHOD). C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C = 'F': perform the finite-infinite separation; C = 'I': perform the infinite-finite separation. C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix B, the number of columns C of the matrix C and the order of the square matrices A C and E. N >= 0. C C M (input) INTEGER C The number of columns of the matrix B. M >= 0. C C P (input) INTEGER C The number of rows of the matrix C. 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 N-by-N state matrix A. C On exit, the leading N-by-N part of this array contains C the transformed state matrix Q'*A*Z in the form C C ( Af * ) ( Ai * ) C ( ) for JOB = 'F', or ( ) for JOB = 'I', C ( 0 Ai ) ( 0 Af ) C C where Af is an NF-by-NF matrix in real Schur form, and Ai C is an (N-NF)-by-(N-NF) nonsingular and upper triangular C matrix. Ai has a block structure as in (3) or (4), where C A0,0 is ND-by-ND and Ai,i , for i = 1, ..., NIBLCK, is C IBLCK(i)-by-IBLCK(i). (See METHOD.) 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, the leading N-by-N part of this array must C contain the N-by-N descriptor matrix E. C On exit, the leading N-by-N part of this array contains C the transformed descriptor matrix Q'*E*Z in the form C C ( Ef * ) ( Ei * ) C ( ) for JOB = 'F', or ( ) for JOB = 'I', C ( 0 Ei ) ( 0 Ef ) C C where Ef is an NF-by-NF nonsingular and upper triangular C matrix, and Ei is an (N-NF)-by-(N-NF) nilpotent matrix in C an upper triangular block form as in (3) or (4). C C LDE INTEGER C The leading dimension of the array E. LDE >= 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 N-by-M input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix Q'*B. C C LDB INTEGER C The leading dimension of the 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Z. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C ALPHAR (output) DOUBLE PRECISION array, dimension (N) C ALPHAR(1:NF) will be set to the real parts of the diagonal C elements of Af that would result from reducing A and E to C the Schur form, and then further reducing both of them to C triangular form using unitary transformations, subject to C having the diagonal of E positive real. Thus, if Af(j,j) C is in a 1-by-1 block (i.e., Af(j+1,j) = Af(j,j+1) = 0), C then ALPHAR(j) = Af(j,j). Note that the (real or complex) C values (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,NF, are C the finite generalized eigenvalues of the matrix pencil C A - lambda*E. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N) C ALPHAI(1:NF) will be set to the imaginary parts of the C diagonal elements of Af that would result from reducing A C and E to Schur form, and then further reducing both of C them to triangular form using unitary transformations, C subject to having the diagonal of E positive real. Thus, C if Af(j,j) is in a 1-by-1 block (see above), then C ALPHAI(j) = 0. Note that the (real or complex) values C (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,NF, are the C finite generalized eigenvalues of the matrix pencil C A - lambda*E. C C BETA (output) DOUBLE PRECISION array, dimension (N) C BETA(1:NF) will be set to the (real) diagonal elements of C Ef that would result from reducing A and E to Schur form, C and then further reducing both of them to triangular form C using unitary transformations, subject to having the C diagonal of E positive real. Thus, if Af(j,j) is in a C 1-by-1 block (see above), then BETA(j) = Ef(j,j). C Note that the (real or complex) values C (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,NF, are the C finite generalized eigenvalues of the matrix pencil C A - lambda*E. C C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) C The leading N-by-N part of this array contains the C orthogonal matrix Q, which is the accumulated product of C the transformations applied to A, E, and B on the left. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= 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 C orthogonal matrix Z, which is the accumulated product of C the transformations applied to A, E, and C on the right. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1,N). C C NF (output) INTEGER C The order of the reduced matrices Af and Ef; also, the C number of finite generalized eigenvalues of the pencil C A-lambda*E. C C ND (output) INTEGER C The number of non-dynamic infinite eigenvalues of the C matrix pair (A,E). Note: N-ND is the rank of the matrix E. C C NIBLCK (output) INTEGER C If ND > 0, the number of infinite blocks minus one. C If ND = 0, then NIBLCK = 0. C C IBLCK (output) INTEGER array, dimension (N) C IBLCK(i) contains the dimension of the i-th block in the C staircase form (3), where i = 1,2,...,NIBLCK. 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 factorization with column pivoting whose estimated C condition number is less than 1/TOL. If the user sets C TOL <= 0, then an implicitly computed, default tolerance C TOLDEF = N**2*EPS, is used instead, where EPS is the C machine precision (see LAPACK Library routine DLAMCH). C 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) returns the optimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 1, and if N > 0, C LDWORK >= 4*N. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 = 1: the pencil A-lambda*E is not regular; C = 2: the QZ iteration did not converge. C C METHOD C C For the separation of infinite structure, the reduction algorithm C of [1] is employed. C If JOB = 'F', the matrices Ai and Ei have the form C C ( A0,0 A0,k ... A0,1 ) ( 0 E0,k ... E0,1 ) C Ai = ( 0 Ak,k ... Ak,1 ) , Ei = ( 0 0 ... Ek,1 ) ; (3) C ( : : . : ) ( : : . : ) C ( 0 0 ... A1,1 ) ( 0 0 ... 0 ) C C if JOB = 'I' the matrices Ai and Ei have the form C C ( A1,1 ... A1,k A1,0 ) ( 0 ... E1,k E1,0 ) C Ai = ( : . : : ) , Ei = ( : . : : ) , (4) C ( : ... Ak,k Ak,0 ) ( : ... 0 Ek,0 ) C ( 0 ... 0 A0,0 ) ( 0 ... 0 0 ) C C where Ai,i, for i = 0, 1, ..., k, are nonsingular upper triangular C matrices. A0,0 corresponds to the non-dynamic infinite modes of C the system. C C REFERENCES C C [1] Misra, P., Van Dooren, P., and Varga, A. C Computation of structural invariants of generalized C state-space systems. C Automatica, 30, pp. 1921-1936, 1994. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N**3 ) floating point operations. C C FURTHER COMMENTS C C The number of infinite poles is computed as C C NIBLCK C NINFP = Sum IBLCK(i) = N - ND - NF. C i=1 C The multiplicities of infinite poles can be computed as follows: C there are IBLCK(k)-IBLCK(k+1) infinite poles of multiplicity C k, for k = 1, ..., NIBLCK, where IBLCK(NIBLCK+1) = 0. C Note that each infinite pole of multiplicity k corresponds to C an infinite eigenvalue of multiplicity k+1. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C July 1999. Based on the RASP routines SRISEP and RPDSGH. C C REVISIONS C C V. Sima, Dec. 2016. C C KEYWORDS C C Generalized eigenvalue problem, system poles, multivariable C system, orthogonal transformation, structural invariant. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, M, $ N, ND, NF, NIBLCK, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IBLCK( * ), IWORK(*) DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), $ BETA(*), C(LDC,*), DWORK(*), E(LDE,*), $ Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. LOGICAL LQUERY, TRINF INTEGER I, IHI, ILO, MINWRK, NBC, NC, NR, WRKOPT C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEMM, DHGEQZ, DLACPY, TG01LD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C C Test the input parameters. C INFO = 0 TRINF = LSAME( JOB, 'I' ) IF( .NOT.LSAME( JOB, 'F' ) .AND. .NOT.TRINF ) 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( LDE.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -12 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -19 ELSE IF( TOL.GE.ONE ) THEN INFO = -24 ELSE LQUERY = LDWORK.EQ.-1 IF( N.EQ.0 ) THEN MINWRK = 1 ELSE MINWRK = 4*N END IF IF( LQUERY ) THEN ILO = 1 IHI = N C CALL TG01LD( JOB, 'Hessenberg', 'Identity', 'Identity', N, $ 0, 0, A, LDA, E, LDE, DUM, LDB, DUM, LDC, Q, $ LDQ, Z, LDZ, NF, ND, NIBLCK, IBLCK, TOL, IWORK, $ DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) CALL DHGEQZ( 'Schur', 'Vector', 'Vector', N, ILO, IHI, A, $ LDA, E, LDE, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, $ LDZ, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -27 END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01MD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible C IF( N.EQ.0 ) THEN NF = 0 ND = 0 NIBLCK = 0 DWORK(1) = ONE RETURN END IF C C Compute the finite-infinite separation with A in Hessenberg form C and E upper triangular. C Workspace: need 4*N. C CALL TG01LD( JOB, 'Hessenberg', 'Identity', 'Identity', N, 0, 0, $ A, LDA, E, LDE, DUM, LDB, DUM, LDC, Q, LDQ, Z, LDZ, $ NF, ND, NIBLCK, IBLCK, TOL, IWORK, DWORK, LDWORK, $ INFO ) C IF( INFO.NE.0 ) $ RETURN WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) C C Reduce the finite part to generalized real Schur form. C Workspace: need N; C prefer larger. C IF( TRINF ) THEN ILO = N - NF + 1 IHI = N ELSE ILO = 1 IHI = NF END IF CALL DHGEQZ( 'Schur', 'Vector', 'Vector', N, ILO, IHI, A, LDA, $ E, LDE, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, $ LDWORK, INFO ) IF( INFO.NE.0 ) THEN INFO = 2 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C B <-- Q' * B. C Workspace: need N; C prefer N*M. C NBC = MAX( 1, MIN( LDWORK/N, M ) ) DO 10 I = 1, M, NBC NC = MIN( NBC, M-I+1 ) CALL DGEMM( 'Transpose', 'No transpose', N, NC, N, ONE, Q, LDQ, $ B(1,I), LDB, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NC, DWORK, N, B(1,I), LDB ) 10 CONTINUE C C C <-- C * Z C Workspace: need N; C prefer P*N. C NBC = MAX( 1, MIN( LDWORK/N, P ) ) DO 20 I = 1, P, NBC NR = MIN( NBC, P-I+1 ) CALL DGEMM( 'No Transpose', 'No transpose', NR, N, N, ONE, $ C(I,1), LDC, Z, LDZ, ZERO, DWORK, NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC ) 20 CONTINUE C DWORK(1) = WRKOPT C RETURN C *** Last line of TG01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01LY.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01LY.f0000644000175000017500000006475015012430707017425 0ustar00lilgelilge00000000000000 SUBROUTINE TG01LY( COMPQ, COMPZ, N, M, P, RANKE, RNKA22, A, LDA, $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NF, $ NIBLCK, IBLCK, TOL, IWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute orthogonal transformation matrices Q and Z which reduce C the regular pole pencil A-lambda*E of the descriptor system C (A-lambda*E,B,C), with the A and E matrices in the form C C ( A11 A12 A13 ) ( E11 0 0 ) C A = ( A21 A22 A23 ) , E = ( 0 0 0 ) , (1) C ( A31 0 0 ) ( 0 0 0 ) C C where E11 and A22 are nonsingular and upper triangular matrices, C to the form C C ( Af * ) ( Ef * ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) , C ( 0 Ai ) ( 0 Ei ) C C where the subpencil Af-lambda*Ef contains the finite eigenvalues C and the subpencil Ai-lambda*Ei contains the infinite eigenvalues. C The subpencil Ai-lambda*Ei is in a staircase form with the C matrices Ai and Ei of form C C C ( A0,0 A0,k ... A0,1 ) ( 0 E0,k ... E0,1 ) C Ai = ( 0 Ak,k ... Ak,1 ) , Ei = ( 0 0 ... Ek,1 ) , (2) C ( : : ... : ) ( : : ... : ) C ( 0 0 ... A1,1 ) ( 0 0 ... 0 ) C C where Ai,i, for i = 0, 1, ..., k, are nonsingular upper triangular C matrices. C C ARGUMENTS C C Mode Parameters C C COMPQ LOGICAL C Specify the option to accumulate or not the performed C left transformations: C COMPQ = .FALSE. : do not accumulate the transformations; C COMPQ = .TRUE. : accumulate the transformations; in this C case, Q must contain an orthogonal matrix Q1 C on entry, and the product Q1*Q is returned. C C COMPZ LOGICAL C Specify the option to accumulate or not the performed C right transformations: C COMPZ = .FALSE. : do not accumulate the transformations; C COMPZ = .TRUE. : accumulate the transformations; in this C case, Z must contain an orthogonal matrix Z1 C on entry, and the product Z1*Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix B, the number of columns C of the matrix C and the order of the square matrices A C and E. N >= 0. C C M (input) INTEGER C The number of columns of the matrix B. M >= 0. C C P (input) INTEGER C The number of rows of the matrix C. P >= 0. C C RANKE (input) INTEGER C The rank of the matrix E; also, the order of the upper C triangular matrix E11. 0 <= RANKE <= N. C C RNKA22 (input) DOUBLE PRECISION C The order of the nonsingular submatrix A22 of A. C 0 <= RNKA22 <= N - RANKE. 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 N-by-N state matrix A in the form (1). C On exit, the leading N-by-N part of this array contains C the transformed state matrix Q'*A*Z, C C ( Af * ) C Q'*A*Z = ( ) , C ( 0 Ai ) C C where Af is NF-by-NF and Ai is (N-NF)-by-(N-NF). C The submatrix Ai is in the staircase form (2), where A0,0 C is (N-RANKE)-by-(N-RANKE), and Ai,i , for i = 1, ..., C NIBLCK is IBLCK(i)-by-IBLCK(i). 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, the leading N-by-N part of this array must C contain the N-by-N descriptor matrix E in the form (1). C On exit, the leading N-by-N part of this array contains C the transformed descriptor matrix Q'*E*Z, C C ( Ef * ) C Q'*E*Z = ( ) , C ( 0 Ei ) C C where Ef is an NF-by-NF nonsingular matrix and Ei is an C (N-NF)-by-(N-NF) nilpotent matrix in the staircase C form (2). C C LDE INTEGER C The leading dimension of the array E. LDE >= 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 N-by-M input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix Q'*B. C C LDB INTEGER C The leading dimension of the 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Z. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C If COMPQ = .FALSE., Q is not referenced. C If COMPQ = .TRUE., on entry, the leading N-by-N part of C this array must contain an orthogonal matrix C Q1; on exit, the leading N-by-N part of this C array contains the orthogonal matrix Q1*Q. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = .FALSE.; C LDQ >= MAX(1,N), if COMPQ = .TRUE. . C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C If COMPZ = .FALSE., Z is not referenced. C If COMPZ = .TRUE., on entry, the leading N-by-N part of C this array must contain an orthogonal matrix C Z1; on exit, the leading N-by-N part of this C array contains the orthogonal matrix Z1*Z. C C LDZ INTEGER C The leading dimension of the array Z. C LDZ >= 1, if COMPZ = .FALSE.; C LDZ >= MAX(1,N), if COMPZ = .TRUE. . C C NF (output) INTEGER C The order of the reduced matrices Af and Ef; also, the C number of finite generalized eigenvalues of the pencil C A-lambda*E. C C NIBLCK (output) INTEGER C If RANKE < N, the number of infinite blocks minus one. C If RANKE = N, NIBLCK = 0. C C IBLCK (output) INTEGER array, dimension (N) C IBLCK(i) contains the dimension of the i-th block in the C staircase form (2), where i = 1, 2, ..., NIBLCK. 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 factorization with column pivoting whose estimated C condition number is less than 1/TOL. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C TOLDEF = N**2*EPS, is used instead, where EPS is the C machine precision (see LAPACK Library routine DLAMCH). C TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (N-RANKE) 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 >= 1, if RANKE = N; otherwise, C LDWORK >= MAX(4*(N-RANKE)-1, N-RANKE-RNKA22+MAX(N,M)). C For optimal 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 = 1: the pencil A-lambda*E is not regular. C C METHOD C C The subroutine is based on the reduction algorithm of [1]. C C REFERENCES C C [1] Misra, P., Van Dooren, P., and Varga, A. C Computation of structural invariants of generalized C state-space systems. C Automatica, 30, pp. 1921-1936, 1994. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N**3 ) floating point operations. C C FURTHER COMMENTS C C The number of infinite poles is computed as C C NIBLCK C Sum IBLCK(i) = RANKE - NF. C i=1 C C The multiplicities of infinite poles can be computed as follows: C there are IBLCK(k)-IBLCK(k+1) infinite poles of multiplicity C k, for k = 1, ..., NIBLCK, where IBLCK(NIBLCK+1) = 0. C Note that each infinite pole of multiplicity k corresponds to C an infinite eigenvalue of multiplicity k+1. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C July 1999. Based on the RASP routine SRISEP. C C REVISIONS C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C July 2001; Nov. 2002 C V. Sima, Dec. 2016, Feb. 2017, June 2017. C C KEYWORDS C C Generalized eigenvalue problem, system poles, multivariable C system, orthogonal transformation, structural invariant. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. LOGICAL COMPQ, COMPZ INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, M, $ N, NF, NIBLCK, P, RANKE, RNKA22 DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IBLCK( * ), IWORK(*) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), $ Z( LDZ, * ) C .. Local Scalars .. LOGICAL FIRST, LQUERY INTEGER I, I0, I1, ICOL, IPIV, IROW, ITAU, J, JWORK1, $ JWORK2, K, MINWRK, MM1, N1, ND, NR, RANK, RO, $ RO1, SIGMA, WRKOPT DOUBLE PRECISION CO, RCOND, SI, SVLMAX, T, TOLDEF C .. Local Arrays .. DOUBLE PRECISION DUM(1), SVAL(3) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE, DLANTR, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLANGE, DLANTR, DLAPY2, DNRM2 C .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DLAPMT, DLARFG, DLARTG, DLASET, $ DLATZM, DORMQR, DROT, DSWAP, DTRCON, MB03OY, $ XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, MOD C .. Executable Statements .. C C Test the input parameters. C INFO = 0 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( RANKE.LT.0 .OR. RANKE.GT.N ) THEN INFO = -6 ELSE IF( RNKA22.LT.0 .OR. RNKA22+RANKE.GT.N ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( ( COMPQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN INFO = -17 ELSE IF( ( COMPZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -19 ELSE IF( TOL.GE.ONE ) THEN INFO = -23 ELSE LQUERY = ( LDWORK.EQ.-1 ) C ND = N - RANKE RO1 = ND IF( RANKE.EQ.N ) THEN MINWRK = 1 ELSE MINWRK = MAX( 4*ND - 1, RO1 + MAX( N, M ) ) END IF IF( LQUERY ) THEN CALL DORMQR( 'Left', 'Transpose', RO1, RANKE, ND, $ A, LDA, DWORK, A, LDA, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) + ND ) CALL DORMQR( 'Left', 'Transpose', RO1, M, ND, A, LDA, $ DWORK, B, LDB, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + ND ) IF( COMPQ ) THEN CALL DORMQR( 'Right', 'No-Transpose', N, RO1, ND, A, $ LDA, DWORK, Q, LDQ, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + ND ) END IF ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -26 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01LY', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Initialize output variables. C NF = RANKE NIBLCK = 0 C C Quick return if possible. C IF( RANKE.EQ.N ) THEN DWORK(1) = ONE RETURN END IF C C Trivial rank check. C IF( RANKE.EQ.0 .AND. RNKA22.EQ.0 ) THEN INFO = 1 RETURN END IF C C Skip reduction if A22 has rank N-RANKE. C WRKOPT = MINWRK IF( RNKA22.EQ.ND ) $ GO TO 110 C TOLDEF = TOL IF( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance in rank determination. C TOLDEF = DBLE( N*N ) * DLAMCH( 'Precision' ) END IF C C Permute block columns to put E in the form E = ( 0 E1 ) C ( 0 0 ) C C and define accordingly A = ( B1 A1 ). C ( D1 C1 ) C MM1 = ND + 1 CALL DLACPY( 'Full', N, ND, A(1,RANKE+1), LDA, E(1,RANKE+1), LDE ) IF( RANKE.LE.ND ) THEN CALL DLACPY( 'Full', N, RANKE, A, LDA, A(1,MM1), LDA ) ELSE K = MOD( RANKE, ND ) DO 10 I = N-2*ND+1, K+1, -ND CALL DLACPY( 'Full', N, ND, A(1,I), LDA, A(1,I+ND), LDA ) 10 CONTINUE IF( K.NE.0 ) $ CALL DLACPY( 'Full', N, K, A, LDA, A(1,MM1), LDA ) END IF CALL DLACPY( 'Full', N, ND, E(1,RANKE+1), LDE, A, LDA ) IF( COMPZ ) THEN CALL DLACPY( 'Full', N, ND, Z(1,RANKE+1), LDZ, E(1,RANKE+1), $ LDE ) IF( RANKE.LE.ND ) THEN CALL DLACPY( 'Full', N, RANKE, Z, LDZ, Z(1,MM1), LDZ ) ELSE DO 20 I = N-2*ND+1, K+1, -ND CALL DLACPY( 'Full', N, ND, Z(1,I), LDZ, Z(1,I+ND), LDZ ) 20 CONTINUE IF( K.NE.0 ) $ CALL DLACPY( 'Full', N, K, Z, LDZ, Z(1,MM1), LDZ ) END IF CALL DLACPY( 'Full', N, ND, E(1,RANKE+1), LDE, Z, LDZ ) END IF IF( P.LE.N ) THEN CALL DLACPY( 'Full', P, ND, C(1,RANKE+1), LDC, E(1,RANKE+1), $ LDE ) IF( RANKE.LE.ND ) THEN CALL DLACPY( 'Full', P, RANKE, C, LDC, C(1,MM1), LDC ) ELSE DO 30 I = N-2*ND+1, K+1, -ND CALL DLACPY( 'Full', P, ND, C(1,I), LDC, C(1,I+ND), LDC ) 30 CONTINUE IF( K.NE.0 ) $ CALL DLACPY( 'Full', P, K, C, LDC, C(1,MM1), LDC ) END IF CALL DLACPY( 'Full', P, ND, E(1,RANKE+1), LDE, C, LDC ) ELSE DO 40 I = 1, P CALL DCOPY( ND, C(I,RANKE+1), LDC, DWORK, 1 ) CALL DCOPY( RANKE, C(I,1), LDC, DWORK(ND+1), 1 ) CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) 40 CONTINUE END IF IF( RANKE.LE.ND ) THEN CALL DLACPY( 'Full', N, RANKE, E, LDE, E(1,MM1), LDE ) ELSE DO 50 I = N-2*ND+1, K+1, -ND CALL DLACPY( 'Full', N, ND, E(1,I), LDE, E(1,I+ND), LDE ) 50 CONTINUE IF( K.NE.0 ) $ CALL DLACPY( 'Full', N, K, E, LDE, E(1,MM1), LDE ) END IF CALL DLASET( 'Full', N, ND, ZERO, ZERO, E, LDE ) C C Set the estimate of the maximum singular value of A to ||A||_F. C SVAL(1) = DLANGE( 'Frobenius', RANKE, RNKA22, A, LDA, DWORK ) SVAL(2) = DLANTR( 'Frobenius', 'Upper', 'Non-Unit', RNKA22, $ RNKA22, A(RANKE+1,1), LDA, DWORK ) SVAL(3) = DLANGE( 'Frobenius', RANKE+RNKA22, ND-RNKA22, $ A(1,RNKA22+1), LDA, DWORK ) SVLMAX = DLAPY2( DNRM2( 3, SVAL, 1 ), $ DLANGE( 'Frobenius', N, RANKE, A(1,ND+1), LDA, $ DWORK ) )/DBLE( N ) C C The D1 matrix is (RO+SIGMA)-by-(RO+SIGMA), where RO = ND - SIGMA C and SIGMA = 0. At each iteration the leading (RO+SIGMA)-by-SIGMA C submatrix of D1 has full column rank, with the trailing C SIGMA-by-SIGMA submatrix upper triangular. C RO = ND C SIGMA = 0 FIRST = .TRUE. ITAU = 1 JWORK1 = ITAU + ND JWORK2 = JWORK1 + 1 DUM(1) = ZERO C 60 CONTINUE IF( FIRST ) THEN RO1 = ND - RNKA22 ELSE C C (NF+1,1) points to the current position of matrix D1. C RO1 = RO C C Compress columns of D1; first exploit the trapezoidal shape of C the (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D1; C compress the first SIGMA columns without column pivoting: C C ( x x x x x ) ( x x x x x ) C ( x x x x x ) ( 0 x x x x ) C ( x x x x x ) - > ( 0 0 x x x ) C ( 0 x x x x ) ( 0 0 0 x x ) C ( 0 0 x x x ) ( 0 0 0 x x ) C C where SIGMA = 3 and RO = 2. C Workspace: need MAX( N, M ). C IROW = NF DO 70 ICOL = 1, SIGMA IROW = IROW + 1 CALL DLARFG( RO+1, A(IROW,ICOL), A(IROW+1,ICOL), 1, T ) CALL DLATZM( 'L', RO+1, N-ICOL, A(IROW+1,ICOL), 1, T, $ A(IROW,ICOL+1), A(IROW+1,ICOL+1), LDA, DWORK ) CALL DLATZM( 'L', RO+1, RANKE, A(IROW+1,ICOL), 1, T, $ E(IROW,ND+1), E(IROW+1,ND+1), LDE, DWORK ) IF( COMPQ ) $ CALL DLATZM( 'R', N, RO+1, A(IROW+1,ICOL), 1, T, $ Q(1, IROW), Q(1, IROW+1), LDQ, DWORK ) CALL DLATZM( 'L', RO+1, M, A(IROW+1,ICOL), 1, T, $ B(IROW,1), B(IROW+1,1), LDB, DWORK ) CALL DCOPY( ND-ICOL, DUM, 0, A(IROW+1, ICOL), 1 ) 70 CONTINUE C C Continue with Householder with column pivoting. C C ( x x x x x ) ( x x x x x ) C ( 0 x x x x ) ( 0 x x x x ) C ( 0 0 x x x ) -> ( 0 0 x x x ) . C ( 0 0 0 x x ) ( 0 0 0 x x ) C ( 0 0 0 x x ) ( 0 0 0 0 0 ) C C ( D11 D12 ) C Reduce further D1 to ( 0 D22 ), where D22 is full C ( 0 0 ) C row rank upper triangular. C Real workspace: need 4*ND - 1; C Integer workspace: need ND. C IROW = MIN( NF+SIGMA+1, N ) ICOL = MIN( SIGMA+1, ND ) CALL MB03OY( RO1, ND-SIGMA, A(IROW,ICOL), LDA, TOLDEF, SVLMAX, $ RANK, SVAL, IWORK, DWORK(ITAU), DWORK(JWORK1), $ INFO ) C C Apply the column permutations to D12 and to the corresponding C columns of B1. C CALL DLAPMT( .TRUE., NF+SIGMA, ND-SIGMA, A(1,ICOL), LDA, $ IWORK ) CALL DLAPMT( .TRUE., P, ND-SIGMA, C(1,ICOL), LDC, IWORK ) IF( COMPZ ) $ CALL DLAPMT( .TRUE., N, ND-SIGMA, Z(1,ICOL), LDZ, IWORK ) C IF( RANK.GT.0 ) THEN C C Apply the Householder transformations to the submatrix C1 C ( C11 ) C and define the transformed C1 as ( C21 ). C ( C31 ) C Workspace: need RANK + MAX(N,M); C prefer RANK + MAX(N,M)*NB. C CALL DORMQR( 'Left', 'Transpose', RO1, RANKE, RANK, $ A(IROW,ICOL), LDA, DWORK(ITAU), A(IROW,MM1), $ LDA, DWORK(JWORK1), LDWORK-JWORK1+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK1) ) + JWORK1 - 1 ) CALL DORMQR( 'Left', 'Transpose', RO1, M, RANK, $ A(IROW,ICOL), LDA, DWORK(ITAU), B(IROW,1), LDB, $ DWORK(JWORK1), LDWORK-JWORK1+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK1) ) + JWORK1 - 1 ) CALL DORMQR( 'Left', 'Transpose', RO1, RANKE, RANK, $ A(IROW,ICOL), LDA, DWORK(ITAU), E(IROW,MM1), $ LDE, DWORK(JWORK1), LDWORK-JWORK1+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK1) ) + JWORK1 - 1 ) IF( COMPQ ) THEN CALL DORMQR( 'Right', 'No-Transpose', N, RO1, RANK, $ A(IROW,ICOL), LDA, DWORK(ITAU), Q(1,IROW), $ LDQ, DWORK(JWORK1), LDWORK-JWORK1+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK1) ) + JWORK1 - 1 ) END IF CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, $ ZERO, A(MIN( IROW+1, N ),ICOL), LDA ) RO1 = RO1 - RANK END IF END IF C C Terminate if D1 has maximal row rank. C IF( RO1.GT.0 ) THEN C C Update SIGMA and number of blocks. C SIGMA = ND - RO1 NIBLCK = NIBLCK + 1 C C Compress the columns of current C31 to separate a RO1-by-RO1 C invertible block. C Perform RQ-decomposition on the current C31 while keeping E1 C upper triangular. No row pivoting is necessary since the C pencil is assumed regular. Still check regularity at first C iteration. C The current C31 is the RO1-by-NF matrix delimited by rows C NF+SIGMA+1 to NF+SIGMA+RO1 and columns ND+1 to ND+NF of A1. C The rank of current C21 is checked only for the first iteration. C C IPIV will point to the current pivot position in C31. C IPIV = NF + ND + 1 N1 = NF + 1 DO 90 I = 1, RO1 IPIV = IPIV - 1 N1 = N1 - 1 C C Zero elements left to A(IPIV,IPIV). C DO 80 K = 1, N1-1 J = ND + K C C Rotate columns J, J+1 to zero A(IPIV,J). C T = A(IPIV,J+1) CALL DLARTG( T, A(IPIV,J), CO, SI, A(IPIV,J+1) ) A(IPIV,J) = ZERO CALL DROT( IPIV-1, A(1,J+1), 1, A(1,J), 1, CO, SI ) CALL DROT( K+1, E(1,J+1), 1, E(1,J), 1, CO, SI ) CALL DROT( P, C(1,J+1), 1, C(1,J), 1, CO, SI ) IF( COMPZ ) $ CALL DROT( N, Z(1,J+1), 1, Z(1,J), 1, CO, SI ) C C Rotate rows K, K+1 to zero E(K+1,J). C T = E(K,J) CALL DLARTG( T, E(K+1,J), CO, SI, E(K,J) ) E(K+1,J) = ZERO CALL DROT( N-J, E(K,J+1), LDE, E(K+1,J+1), LDE, CO, SI ) CALL DROT( N, A(K,1), LDA, A(K+1,1), LDA, CO, SI ) CALL DROT( M, B(K,1), LDB, B(K+1,1), LDB, CO, SI ) IF( COMPQ ) $ CALL DROT( N, Q(1,K), 1, Q(1,K+1), 1, CO, SI ) 80 CONTINUE C 90 CONTINUE C C Check regularity of the pencil. C Real workspace: need 3*RO1. C Integer workspace: need RO1. C IF( DLANTR( 'Frobenius', 'Upper', 'Non-Unit', RO1, RO1, $ A(IPIV,IPIV), LDA, DWORK ) .LE. TOLDEF*SVLMAX ) $ THEN INFO = 1 ELSE CALL DTRCON( '1-norm', 'Upper', 'Non-unit', RO1, $ A(IPIV,IPIV), LDA, RCOND, DWORK, IWORK, INFO ) IF( RCOND.LE.TOLDEF ) $ INFO = 1 END IF C C Return with error for non-regular system. C IF( INFO.NE.0 ) $ RETURN C NF = NF - RO1 C C Set the order of i-th block. C IBLCK(NIBLCK) = RO1 RO = RO1 FIRST = .FALSE. C GO TO 60 END IF C IF( NF.GT.0 ) THEN C C Permute block columns to put A and E in the form C C ( A1 B1 * ) ( E1 0 * ) C A = ( C1 D1 * ), E = ( 0 0 * ) . C ( 0 0 Ai ) ( 0 0 Ei ) C NR = NF + ND DUM(1) = ZERO CALL DLACPY( 'Full', NR, ND, A, LDA, E, LDE ) CALL DLACPY( 'Full', NR, NF, A(1,ND+1), LDA, A, LDA ) CALL DLACPY( 'Full', NR, ND, E, LDE, A(1,NF+1), LDA ) IF( COMPZ ) THEN CALL DLACPY( 'Full', N, ND, Z, LDZ, E, LDE ) CALL DLACPY( 'Full', N, NF, Z(1,ND+1), LDZ, Z, LDZ ) CALL DLACPY( 'Full', N, ND, E, LDE, Z(1,NF+1), LDZ ) END IF IF( P.LE.N ) THEN CALL DLACPY( 'Full', P, ND, C, LDC, E, LDE ) CALL DLACPY( 'Full', P, NF, C(1,ND+1), LDC, C, LDC ) CALL DLACPY( 'Full', P, ND, E, LDE, C(1,NF+1), LDC ) ELSE DO 100 I = 1, P CALL DCOPY( ND, C(I,1), LDC, DWORK, 1 ) CALL DCOPY( NF, C(I,ND+1), LDC, C(I,1), LDC ) CALL DCOPY( ND, DWORK, 1, C(I,NF+1), LDC ) 100 CONTINUE END IF CALL DLACPY( 'Full', N, NF, E(1,ND+1), LDE, E, LDE ) CALL DLASET( 'Full', N, ND, ZERO, ZERO, E(1,NF+1), LDE ) CALL DLASET( 'Full', N-NF-ND, NF+ND, ZERO, ZERO, $ A(NF+ND+1,1), LDA ) END IF C C Annihilate C1 keeping E upper triangular, to obtain C C ( Af * * ) ( Ef * * ) C A = ( 0 A0,0 * ), E = ( 0 0 * ) . C ( 0 0 Ai ) ( 0 0 Ei ) C 110 CONTINUE I1 = NF + ND DO 130 I0 = ND, 1, -1 C C Annihilate elements A(I1,1), ..., A(I1,NF) using A(I1,I1) C as pivot element; E remains further upper triangular. C K = 1 DO 120 J = 1, NF C C Rotate columns I1 and J to zero A(I1,J). C T = A(I1,I1) CALL DLARTG( T, A(I1,J), CO, SI, A(I1,I1) ) A(I1,J) = ZERO CALL DROT( I1-1, A(1,I1), 1, A(1,J), 1, CO, SI ) CALL DROT( K, E(1,I1), 1, E(1,J), 1, CO, SI ) CALL DROT( P, C(1,I1), 1, C(1,J), 1, CO, SI ) IF( COMPZ ) $ CALL DROT( N, Z(1,I1), 1, Z(1,J), 1, CO, SI ) K = K + 1 120 CONTINUE I1 = I1 - 1 130 CONTINUE C DWORK(1) = WRKOPT RETURN C *** Last line of TG01LY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02UW.f0000644000000000000000000000013215012430707016211 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02UW.f0000644000175000017500000002304415012430707017410 0ustar00lilgelilge00000000000000 SUBROUTINE MB02UW( LTRANS, N, M, PAR, A, LDA, B, LDB, SCALE, $ IWARN ) C C PURPOSE C C To solve a system of the form A X = s B or A' X = s B with C possible scaling ("s") and perturbation of A. (A' means C A-transpose.) A is an N-by-N real matrix, and X and B are C N-by-M matrices. N may be 1 or 2. The scalar "s" is a scaling C factor (.LE. 1), computed by this subroutine, which is so chosen C that X can be computed without overflow. X is further scaled if C necessary to assure that norm(A)*norm(X) is less than overflow. C C ARGUMENTS C C Mode Parameters C C LTRANS LOGICAL C Specifies if A or A-transpose is to be used, as follows: C =.TRUE. : A-transpose will be used; C =.FALSE.: A will be used (not transposed). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. It may (only) be 1 or 2. C C M (input) INTEGER C The number of right hand size vectors. C C PAR (input) DOUBLE PRECISION array, dimension (3) C Machine related parameters: C PAR(1) =: PREC (machine precision)*base, DLAMCH( 'P' ); C PAR(2) =: SFMIN safe minimum, DLAMCH( 'S' ); C PAR(3) =: SMIN The desired lower bound on the singular C values of A. This should be a safe C distance away from underflow or overflow, C say, between (underflow/machine precision) C and (machine precision * overflow). C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-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 >= 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 matrix B (right-hand side). C On exit, the leading N-by-M part of this array contains C the N-by-M matrix X (unknowns). C C LDB INTEGER C The leading dimension of the array B. LDB >= N. C C SCALE (output) DOUBLE PRECISION C The scale factor that B must be multiplied by to insure C that overflow does not occur when computing X. Thus, C A X will be SCALE*B, not B (ignoring perturbations of A). C SCALE will be at most 1. C C Warning Indicator C C IWARN INTEGER C = 0: no warnings (A did not have to be perturbed); C = 1: A had to be perturbed to make its smallest (or only) C singular value greater than SMIN (see below). C C METHOD C C Gaussian elimination with complete pivoting is used. The matrix A C is slightly perturbed if it is (close to being) singular. C C FURTHER COMMENTS C C If both singular values of A are less than SMIN, SMIN*identity C will be used instead of A. If only one singular value is less C than SMIN, one element of A will be perturbed enough to make the C smallest singular value roughly SMIN. If both singular values C are at least SMIN, A will not be perturbed. In any case, the C perturbation will be at most some small multiple of C max( SMIN, EPS*norm(A) ), where EPS is the machine precision C (see LAPACK Library routine DLAMCH). The singular values are C computed by infinity-norm approximations, and thus will only be C correct to a factor of 2 or so. C C Note: all input quantities are assumed to be smaller than overflow C by a reasonable factor. (See BIGNUM.) In the interests of speed, C this routine does not check the inputs for errors. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2009. C Based on the LAPACK Library routine DLALN2. C C REVISIONS C C V. Sima, Nov. 2010, Apr. 2016. C C KEYWORDS C C Linear system of equations, matrix operations, matrix algebra. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C C .. Scalar Arguments .. LOGICAL LTRANS INTEGER IWARN, LDA, LDB, N, M DOUBLE PRECISION SCALE, SMIN C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), PAR( * ) C C .. Local Scalars .. INTEGER I, ICMAX, J DOUBLE PRECISION BBND, BIGNUM, BNORM, B1, B2, CMAX, C21, C22, $ CS, EPS, L21, SCALEP, SMINI, SMLNUM, TEMP, U11, $ U11R, U12, U22, XNORM, X1, X2 C C .. Local Arrays .. LOGICAL RSWAP( 4 ), ZSWAP( 4 ) INTEGER IPIVOT( 4, 4 ) DOUBLE PRECISION C( 2, 2 ), CV( 4 ) C C ..External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLANGE EXTERNAL DLANGE, IDAMAX C C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. C .. Equivalences .. EQUIVALENCE ( C( 1, 1 ), CV( 1 ) ) C .. C .. Data statements .. DATA ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. / DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. / DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, $ 3, 2, 1 / C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C IWARN = 0 C C Compute BIGNUM. C SMIN = PAR( 3 ) EPS = PAR( 1 ) SMLNUM = TWO*PAR( 2 ) / EPS BIGNUM = ONE / SMLNUM SMINI = MAX( SMIN, SMLNUM ) C C Standard initializations. C SCALE = ONE C IF( N.EQ.1 ) THEN C C 1-by-1 (i.e., scalar) systems C X = B. C CS = A( 1, 1 ) CMAX = ABS( CS ) C C If | C | < SMINI, use C = SMINI. C IF( CMAX.LT.SMINI ) THEN CS = SMINI CMAX = SMINI IWARN = 1 END IF C C Check scaling for X = B / C. C BNORM = ABS( B( 1, IDAMAX( M, B, LDB ) ) ) IF( CMAX.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CMAX ) $ SCALE = ONE / BNORM END IF C C Compute X. C DO 10 I = 1, M B( 1, I ) = ( B( 1, I )*SCALE ) / CS 10 CONTINUE C ELSE C C 2x2 systems. C C Compute C = A (or A'). C C( 1, 1 ) = A( 1, 1 ) C( 2, 2 ) = A( 2, 2 ) IF( LTRANS ) THEN C( 1, 2 ) = A( 2, 1 ) C( 2, 1 ) = A( 1, 2 ) ELSE C( 2, 1 ) = A( 2, 1 ) C( 1, 2 ) = A( 1, 2 ) END IF C C Find the largest element in C. C CMAX = ZERO ICMAX = 0 C DO 20 J = 1, 4 IF( ABS( CV( J ) ).GT.CMAX ) THEN CMAX = ABS( CV( J ) ) ICMAX = J END IF 20 CONTINUE C C If norm(C) < SMINI, use SMINI*identity. C IF( CMAX.LT.SMINI ) THEN BNORM = DLANGE( 'M', N, M, B, LDB, CV ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI C DO 30 I = 1, M B( 1, I ) = TEMP*B( 1, I ) B( 2, I ) = TEMP*B( 2, I ) 30 CONTINUE C IWARN = 1 RETURN END IF C C Gaussian elimination with complete pivoting. C U11 = CV( ICMAX ) C21 = CV( IPIVOT( 2, ICMAX ) ) U12 = CV( IPIVOT( 3, ICMAX ) ) C22 = CV( IPIVOT( 4, ICMAX ) ) U11R = ONE / U11 L21 = U11R*C21 U22 = C22 - U12*L21 C C If smaller pivot < SMINI, use SMINI. C IF( ABS( U22 ).LT.SMINI ) THEN U22 = SMINI IWARN = 1 END IF C SCALEP = ONE C DO 50 I = 1, M IF( RSWAP( ICMAX ) ) THEN B1 = B( 2, I ) B2 = B( 1, I ) ELSE B1 = B( 1, I ) B2 = B( 2, I ) END IF B2 = B2 - L21*B1 BBND = MAX( ABS( B1*( U22*U11R ) ), ABS( B2 ) ) IF( BBND.GT.ONE .AND. ABS( U22 ).LT.ONE ) THEN IF( BBND.GE.BIGNUM*ABS( U22 ) ) $ SCALE = ONE / BBND END IF SCALE = MIN( SCALE, SCALEP ) IF( SCALE.LT.SCALEP ) THEN SCALEP = SCALE / SCALEP C DO 40 J = 1, I - 1 B( 1, J ) = B( 1, J )*SCALEP B( 2, J ) = B( 2, J )*SCALEP 40 CONTINUE C END IF C X2 = ( B2*SCALE ) / U22 X1 = ( SCALE*B1 )*U11R - X2*( U11R*U12 ) IF( ZSWAP( ICMAX ) ) THEN B( 1, I ) = X2 B( 2, I ) = X1 ELSE B( 1, I ) = X1 B( 2, I ) = X2 END IF XNORM = MAX( ABS( X1 ), ABS( X2 ) ) C C Further scaling if norm(A) norm(X) > overflow. C IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM B( 1, I ) = TEMP*B( 1, I ) B( 2, I ) = TEMP*B( 2, I ) SCALE = TEMP*SCALE END IF END IF SCALEP = SCALE 50 CONTINUE C END IF C RETURN C C *** Last line of MB02UW *** END control-4.1.2/src/slicot/src/PaxHeaders/AB13DX.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB13DX.f0000644000175000017500000004346215012430707017364 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION AB13DX( DICO, JOBE, JOBD, N, M, P, $ OMEGA, A, LDA, E, LDE, B, LDB, $ C, LDC, D, LDD, IWORK, DWORK, $ LDWORK, CWORK, LCWORK, INFO ) C C PURPOSE C C To compute the maximum singular value of a given continuous-time C or discrete-time transfer-function matrix, either standard or in C the descriptor form, C C -1 C G(lambda) = C*( lambda*E - A ) *B + D , C C for a given complex value lambda, where lambda = j*omega, in the C continuous-time case, and lambda = exp(j*omega), in the C discrete-time case. The matrices A, E, B, C, and D are real C matrices of appropriate dimensions. Matrix A must be in an upper C Hessenberg form, and if JOBE ='G', the matrix E must be upper C triangular. The matrices B and C must correspond to the system C in (generalized) Hessenberg form. C C FUNCTION VALUE C C AB13DX DOUBLE PRECISION C The maximum singular value of G(lambda). 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 an upper triangular or an identity C matrix, as follows: C = 'G': E is a general upper triangular matrix; C = 'I': E is the identity matrix. 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 OMEGA (input) DOUBLE PRECISION C The frequency value for which the calculations should be C done. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading N-by-N upper Hessenberg part of this C array must contain the state dynamics matrix A in upper C Hessenberg form. The elements below the subdiagonal are C not referenced. C On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0, C and C <> 0, the leading N-by-N upper Hessenberg part of C this array contains the factors L and U from the LU C factorization of A (A = P*L*U); the unit diagonal elements C of L are not stored, L is lower bidiagonal, and P is C stored in IWORK (see SLICOT Library routine MB02SD). C Otherwise, this array is unchanged on exit. 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 upper triangular part of C this array must contain the upper triangular descriptor C matrix E of the system. The elements of the strict lower C triangular part of this array are not referenced. 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/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, the leading N-by-M part of this array must C contain the system input matrix B. C On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0, C C <> 0, and INFO = 0 or N+1, the leading N-by-M part of C this array contains the solution of the system A*X = B. C Otherwise, this array is unchanged on exit. 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/output) DOUBLE PRECISION array, dimension (LDD,M) C On entry, if JOBD = 'D', the leading P-by-M part of this C array must contain the direct transmission matrix D. C On exit, if (N = 0, or B = 0, or C = 0) and JOBD = 'D', C or (OMEGA = 0, DICO = 'C', JOBD = 'D', and INFO = 0 or C N+1), the contents of this array is destroyed. C Otherwise, this array is unchanged on exit. C This array 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 Workspace C C IWORK INTEGER array, dimension (LIWORK), where C LIWORK = N, if N > 0, M > 0, P > 0, B <> 0, and C <> 0; C LIWORK = 0, otherwise. C This array contains the pivot indices in the LU C factorization of the matrix lambda*E - A; for 1 <= i <= N, C row i of the matrix was interchanged with row IWORK(i). C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) contains the optimal value C of LDWORK, and DWORK(2), ..., DWORK(MIN(P,M)) contain the C singular values of G(lambda), except for the first one, C which is returned in the function value AB13DX. C If (N = 0, or B = 0, or C = 0) and JOBD = 'Z', the last C MIN(P,M)-1 zero singular values of G(lambda) are not C stored in DWORK(2), ..., DWORK(MIN(P,M)). C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= MAX(1, LDW1 + LDW2 ), C LDW1 = P*M, if N > 0, B <> 0, C <> 0, OMEGA = 0, C DICO = 'C', and JOBD = 'Z'; C LDW1 = 0, otherwise; C LDW2 = MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), 5*MIN(P,M)), C if (N = 0, or B = 0, or C = 0) and JOBD = 'D', C or (N > 0, B <> 0, C <> 0, OMEGA = 0, and C DICO = 'C'); C LDW2 = 0, if (N = 0, or B = 0, or C = 0) and JOBD = 'Z', C or MIN(P,M) = 0; C LDW2 = 6*MIN(P,M), otherwise. C For good performance, LDWORK must generally be larger. 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, or (OMEGA = 0 C and DICO = 'C') or MIN(P,M) = 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 > 0: if INFO = i, U(i,i) is exactly zero; the LU C factorization of the matrix lambda*E - A has been C completed, but the factor U is exactly singular, C i.e., the matrix lambda*E - A is exactly singular; C = N+1: the SVD algorithm for computing singular values C did not converge. C C METHOD C C The routine implements standard linear algebra calculations, C taking problem structure into account. LAPACK Library routines C DGESVD and ZGESVD are used for finding the singular values. C C CONTRIBUTORS C C D. Sima, University of Bucharest, May 2001. C V. Sima, Research Institute for Informatics, Bucharest, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Sep. 2005. C C KEYWORDS C C H-infinity optimal control, robust control, system norm. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 CONE PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER DICO, JOBD, JOBE INTEGER INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK, $ M, N, P DOUBLE PRECISION OMEGA C .. C .. Array Arguments .. COMPLEX*16 CWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), DWORK( * ), E( LDE, * ) INTEGER IWORK( * ) C .. C .. Local Scalars .. LOGICAL DISCR, FULLE, NODYN, SPECL, WITHD INTEGER I, ICB, ICC, ICD, ICWK, ID, IERR, IS, IWRK, J, $ MAXWRK, MINCWR, MINPM, MINWRK DOUBLE PRECISION BNORM, CNORM, LAMBDI, LAMBDR, UPD C C .. External Functions .. DOUBLE PRECISION DLANGE LOGICAL LSAME EXTERNAL DLANGE, LSAME C .. C .. External Subroutines .. EXTERNAL DGEMM, DGESVD, MB02RD, MB02RZ, MB02SD, MB02SZ, $ XERBLA, ZGEMM, ZGESVD, ZLACP2 C .. C .. Intrinsic Functions .. INTRINSIC COS, DCMPLX, INT, MAX, MIN, SIN C .. C .. Executable Statements .. C C Test the input scalar parameters. C INFO = 0 DISCR = LSAME( DICO, 'D' ) FULLE = LSAME( JOBE, 'G' ) 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. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN INFO = -17 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 SPECL = .NOT.NODYN .AND. OMEGA.EQ.ZERO .AND. .NOT.DISCR MINPM = MIN( P, M ) C C Compute workspace. C IF( MINPM.EQ.0 ) THEN MINWRK = 0 ELSE IF( SPECL .OR. ( NODYN .AND. WITHD ) ) THEN MINWRK = MINPM + MAX( 3*MINPM + MAX( P, M ), 5*MINPM ) IF ( SPECL .AND. .NOT.WITHD ) $ MINWRK = MINWRK + P*M ELSE IF ( NODYN .AND. .NOT.WITHD ) THEN MINWRK = 0 ELSE MINWRK = 6*MINPM END IF MINWRK = MAX( 1, MINWRK ) C IF( LDWORK.LT.MINWRK ) THEN INFO = -20 ELSE IF ( NODYN .OR. ( OMEGA.EQ.ZERO .AND. .NOT.DISCR ) .OR. $ MINPM.EQ.0 ) THEN MINCWR = 1 ELSE MINCWR = MAX( 1, ( N + M )*( N + P ) + $ 2*MINPM + MAX( P, M ) ) END IF IF( LCWORK.LT.MINCWR ) $ INFO = -22 END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'AB13DX', -INFO ) RETURN END IF C C Quick return if possible. C IF( MINPM.EQ.0 ) THEN AB13DX = ZERO C DWORK( 1 ) = ONE CWORK( 1 ) = ONE RETURN 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 IS = 1 IWRK = IS + MINPM C IF( NODYN ) THEN C C No dynamics: Determine the maximum singular value of G = D . C IF ( WITHD ) THEN C C Workspace: need MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), C 5*MIN(P,M)); C prefer larger. C CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD, $ DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ), $ LDWORK-IWRK+1, IERR ) IF( IERR.GT.0 ) THEN INFO = N + 1 RETURN END IF AB13DX = DWORK( IS ) MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1 ELSE AB13DX = ZERO MAXWRK = 1 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 The (generalized) Hessenberg form of the system is used. C IF ( SPECL ) THEN C C Special continuous-time case: C Determine the maximum singular value of the real matrix G(0). C Workspace: need MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), C 5*MIN(P,M)); C prefer larger. C CALL MB02SD( N, A, LDA, IWORK, IERR ) IF( IERR.GT.0 ) THEN INFO = IERR DWORK( 1 ) = ONE CWORK( 1 ) = ONE RETURN END IF CALL MB02RD( 'No Transpose', N, M, A, LDA, IWORK, B, LDB, $ IERR ) IF ( WITHD ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', P, M, N, -ONE, $ C, LDC, B, LDB, ONE, D, LDD ) CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD, $ DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ), $ LDWORK-IWRK+1, IERR ) ELSE C C Additional workspace: need P*M. C ID = IWRK IWRK = ID + P*M CALL DGEMM( 'No Transpose', 'No Transpose', P, M, N, -ONE, $ C, LDC, B, LDB, ZERO, DWORK( ID ), P ) CALL DGESVD( 'No Vectors', 'No Vectors', P, M, DWORK( ID ), $ P, DWORK( IS ), DWORK, P, DWORK, M, $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) END IF IF( IERR.GT.0 ) THEN INFO = N + 1 RETURN END IF C AB13DX = DWORK( IS ) DWORK( 1 ) = INT( DWORK( IWRK ) ) + IWRK - 1 CWORK( 1 ) = ONE RETURN END IF C C General case: Determine the maximum singular value of G(lambda). C Complex workspace: need N*N + N*M + P*N + P*M. C ICB = 1 + N*N ICC = ICB + N*M ICD = ICC + P*N ICWK = ICD + P*M C IF ( WITHD ) THEN UPD = ONE ELSE UPD = ZERO END IF C IF ( DISCR ) THEN LAMBDR = COS( OMEGA ) LAMBDI = SIN( OMEGA ) C C Build lambda*E - A . C IF ( FULLE ) THEN C DO 20 J = 1, N C DO 10 I = 1, J CWORK( I+(J-1)*N ) = $ DCMPLX( LAMBDR*E( I, J ) - A( I, J ), $ LAMBDI*E( I, J ) ) 10 CONTINUE C IF( J.LT.N ) $ CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO ) 20 CONTINUE C ELSE C DO 40 J = 1, N C DO 30 I = 1, MIN( J+1, N ) CWORK( I+(J-1)*N ) = -A( I, J ) 30 CONTINUE C CWORK( J+(J-1)*N ) = DCMPLX( LAMBDR - A( J, J ), LAMBDI ) 40 CONTINUE C END IF C ELSE C C Build j*omega*E - A. C IF ( FULLE ) THEN C DO 60 J = 1, N C DO 50 I = 1, J CWORK( I+(J-1)*N ) = $ DCMPLX( -A( I, J ), OMEGA*E( I, J ) ) 50 CONTINUE C IF( J.LT.N ) $ CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO ) 60 CONTINUE C ELSE C DO 80 J = 1, N C DO 70 I = 1, MIN( J+1, N ) CWORK( I+(J-1)*N ) = -A( I, J ) 70 CONTINUE C CWORK( J+(J-1)*N ) = DCMPLX( -A( J, J ), OMEGA ) 80 CONTINUE C END IF C END IF C C Build G(lambda) . C CALL ZLACP2( 'Full', N, M, B, LDB, CWORK( ICB ), N ) CALL ZLACP2( 'Full', P, N, C, LDC, CWORK( ICC ), P ) IF ( WITHD ) $ CALL ZLACP2( 'Full', P, M, D, LDD, CWORK( ICD ), P ) C CALL MB02SZ( N, CWORK, N, IWORK, IERR ) IF( IERR.GT.0 ) THEN INFO = IERR DWORK( 1 ) = ONE CWORK( 1 ) = ICWK - 1 RETURN END IF CALL MB02RZ( 'No Transpose', N, M, CWORK, N, IWORK, $ CWORK( ICB ), N, IERR ) CALL ZGEMM( 'No Transpose', 'No Transpose', P, M, N, CONE, $ CWORK( ICC ), P, CWORK( ICB ), N, $ DCMPLX( UPD, ZERO ), CWORK( ICD ), P ) C C Additional workspace, complex: need 2*MIN(P,M) + MAX(P,M); C prefer larger; C real: need 5*MIN(P,M). C CALL ZGESVD( 'No Vectors', 'No Vectors', P, M, CWORK( ICD ), P, $ DWORK( IS ), CWORK, P, CWORK, M, CWORK( ICWK ), $ LCWORK-ICWK+1, DWORK( IWRK ), IERR ) IF( IERR.GT.0 ) THEN INFO = N + 1 RETURN END IF AB13DX = DWORK( IS ) C DWORK( 1 ) = 6*MINPM CWORK( 1 ) = INT( CWORK( ICWK ) ) + ICWK - 1 C RETURN C *** Last line of AB13DX *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01AD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01AD.f0000644000175000017500000003625615012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE TG01AD( JOB, L, N, M, P, THRESH, A, LDA, E, LDE, $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO ) C C PURPOSE C C To balance the matrices of the system pencil C C S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, C ( C 0 ) ( 0 0 ) C C corresponding to the descriptor triple (A-lambda E,B,C), C by balancing. This involves diagonal similarity transformations C (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system C (A-lambda E,B,C) to make the rows and columns of system pencil C matrices C C diag(Dl,I) * S * diag(Dr,I) C C as close in norm as possible. Balancing may reduce the 1-norms C of the matrices of the system pencil S. C C The balancing can be performed optionally on the following C particular system pencils C C S = A-lambda E, C C S = ( A-lambda E B ), or C C S = ( A-lambda E ). C ( C ) C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Indicates which matrices are involved in balancing, as C follows: C = 'A': All matrices are involved in balancing; C = 'B': B, A and E matrices are involved in balancing; C = 'C': C, A and E matrices are involved in balancing; C = 'N': B and C matrices are not involved in balancing. C C Input/Output Parameters C C L (input) INTEGER C The number of rows of matrices A, B, and E. L >= 0. C C N (input) INTEGER C The number of columns of matrices A, E, and C. N >= 0. C C M (input) INTEGER C The number of columns of matrix B. M >= 0. C C P (input) INTEGER C The number of rows of matrix C. P >= 0. C C THRESH (input) DOUBLE PRECISION C Threshold value for magnitude of elements: C elements with magnitude less than or equal to C THRESH are ignored for balancing. THRESH >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the state dynamics matrix A. C On exit, the leading L-by-N part of this array contains C the balanced matrix Dl*A*Dr. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,L). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the descriptor matrix E. C On exit, the leading L-by-N part of this array contains C the balanced matrix Dl*E*Dr. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,L). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, the leading L-by-M part of this array must C contain the input/state matrix B. C On exit, if M > 0, the leading L-by-M part of this array C contains the balanced matrix Dl*B. C The array B is not referenced if M = 0. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. 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 C. C On exit, if P > 0, the leading P-by-N part of this array C contains the balanced matrix C*Dr. C The array C is not referenced if P = 0. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C LSCALE (output) DOUBLE PRECISION array, dimension (L) C The scaling factors applied to S from left. If Dl(j) is C the scaling factor applied to row j, then C SCALE(j) = Dl(j), for j = 1,...,L. C C RSCALE (output) DOUBLE PRECISION array, dimension (N) C The scaling factors applied to S from right. If Dr(j) is C the scaling factor applied to column j, then C SCALE(j) = Dr(j), for j = 1,...,N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (3*(L+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 METHOD C C Balancing consists of applying a diagonal similarity C transformation C -1 C diag(Dl,I) * S * diag(Dr,I) C C to make the 1-norms of each row of the first L rows of S and its C corresponding N columns nearly equal. C C Information about the diagonal matrices Dl and Dr are returned in C the vectors LSCALE and RSCALE, respectively. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C [2] R.C. Ward, R. C. C Balancing the generalized eigenvalue problem. C SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C March 1999. Based on the LAPACK routine DGGBAL. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 1999, C May 2003, March 2004, Jan. 2009, May 2012. C C KEYWORDS C C Balancing, eigenvalue, matrix algebra, matrix operations, C similarity transformation. C C ********************************************************************* C C .. Parameters .. DOUBLE PRECISION HALF, ONE, ZERO PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) DOUBLE PRECISION SCLFAC, THREE PARAMETER ( SCLFAC = 1.0D+1, THREE = 3.0D+0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER INFO, L, LDA, LDB, LDC, LDE, M, N, P DOUBLE PRECISION THRESH C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), LSCALE( * ), $ RSCALE( * ) C .. Local Scalars .. LOGICAL WITHB, WITHC INTEGER I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2, $ KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN, $ NRP2 DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, EPS, EW, EWC, GAMMA, PGAMMA, RAB, $ SFMAX, SFMIN, SUM, T, TA, TB, TC, TE C .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL DDOT, DLAMCH, IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN C C .. Executable Statements .. C C Test the input parameters. C INFO = 0 WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) C IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) $ THEN INFO = -1 ELSE IF( L.LT.0 ) 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( THRESH.LT.ZERO ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, L ) ) THEN INFO = -8 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -10 ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN INFO = -12 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -14 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01AD', -INFO ) RETURN END IF C C Quick return if possible. C IF( L.EQ.0 .OR. N.EQ.0 ) THEN DUM( 1 ) = ONE IF( L.GT.0 ) THEN CALL DCOPY( L, DUM, 0, LSCALE, 1 ) ELSE IF( N.GT.0 ) THEN CALL DCOPY( N, DUM, 0, RSCALE, 1 ) END IF RETURN END IF C C Initialize balancing and allocate work storage. C KW1 = N KW2 = KW1 + L KW3 = KW2 + L KW4 = KW3 + N KW5 = KW4 + L DUM( 1 ) = ZERO CALL DCOPY( L, DUM, 0, LSCALE, 1 ) CALL DCOPY( N, DUM, 0, RSCALE, 1 ) CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 ) C C Compute right side vector in resulting linear equations. C BASL = LOG10( SCLFAC ) DO 20 I = 1, L DO 10 J = 1, N TE = ABS( E( I, J ) ) TA = ABS( A( I, J ) ) IF( TA.GT.THRESH ) THEN TA = LOG10( TA ) / BASL ELSE TA = ZERO END IF IF( TE.GT.THRESH ) THEN TE = LOG10( TE ) / BASL ELSE TE = ZERO END IF DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE 10 CONTINUE 20 CONTINUE C IF( M.EQ.0 ) THEN WITHB = .FALSE. TB = ZERO END IF IF( P.EQ.0 ) THEN WITHC = .FALSE. TC = ZERO END IF C IF( WITHB ) THEN DO 30 I = 1, L J = IDAMAX( M, B( I, 1 ), LDB ) TB = ABS( B( I, J ) ) IF( TB.GT.THRESH ) THEN TB = LOG10( TB ) / BASL DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB END IF 30 CONTINUE END IF C IF( WITHC ) THEN DO 40 J = 1, N I = IDAMAX( P, C( 1, J ), 1 ) TC = ABS( C( I, J ) ) IF( TC.GT.THRESH ) THEN TC = LOG10( TC ) / BASL DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC END IF 40 CONTINUE END IF C COEF = ONE / DBLE( L+N ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = MAX( L, N ) + 2 BETA = ZERO EPS = DLAMCH( 'Precision' ) IT = 1 C C Start generalized conjugate gradient iteration. C 50 CONTINUE C GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) + $ DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 ) C EW = ZERO DO 60 I = 1, L EW = EW + DWORK( I+KW4 ) 60 CONTINUE C EWC = ZERO DO 70 I = 1, N EWC = EWC + DWORK( I+KW5 ) 70 CONTINUE C GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - $ COEF5*( EW - EWC )**2 IF( ABS( GAMMA ).LE.EPS ) $ GO TO 160 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = COEF5*( EWC - THREE*EW ) TC = COEF5*( EW - THREE*EWC ) C CALL DSCAL( N+L, BETA, DWORK, 1 ) C CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 ) CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 ) C DO 80 J = 1, N DWORK( J ) = DWORK( J ) + TC 80 CONTINUE C DO 90 I = 1, L DWORK( I+KW1 ) = DWORK( I+KW1 ) + T 90 CONTINUE C C Apply matrix to vector. C DO 110 I = 1, L KOUNT = 0 SUM = ZERO DO 100 J = 1, N IF( ABS( A( I, J ) ).GT.THRESH ) THEN KOUNT = KOUNT + 1 SUM = SUM + DWORK( J ) END IF IF( ABS( E( I, J ) ).GT.THRESH ) THEN KOUNT = KOUNT + 1 SUM = SUM + DWORK( J ) END IF 100 CONTINUE IF( WITHB ) THEN J = IDAMAX( M, B( I, 1 ), LDB ) IF( ABS( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 END IF DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM 110 CONTINUE C DO 130 J = 1, N KOUNT = 0 SUM = ZERO DO 120 I = 1, L IF( ABS( A( I, J ) ).GT.THRESH ) THEN KOUNT = KOUNT + 1 SUM = SUM + DWORK( I+KW1 ) END IF IF( ABS( E( I, J ) ).GT.THRESH ) THEN KOUNT = KOUNT + 1 SUM = SUM + DWORK( I+KW1 ) END IF 120 CONTINUE IF( WITHC ) THEN I = IDAMAX( P, C( 1, J ), 1 ) IF( ABS( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 END IF DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM 130 CONTINUE C SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) + $ DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 ) ALPHA = GAMMA / SUM C C Determine correction to current iteration. C CMAX = ZERO DO 140 I = 1, L COR = ALPHA*DWORK( I+KW1 ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE( I ) = LSCALE( I ) + COR 140 CONTINUE C DO 150 J = 1, N COR = ALPHA*DWORK( J ) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE( J ) = RSCALE( J ) + COR 150 CONTINUE IF( CMAX.LT.HALF ) $ GO TO 160 C CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 ) CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 ) C PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 50 C C End generalized conjugate gradient iteration. C 160 CONTINUE SFMIN = DLAMCH( 'Safe minimum' ) SFMAX = ONE / SFMIN LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) C C Compute left diagonal scaling matrix. C DO 170 I = 1, L IRAB = IDAMAX( N, A( I, 1 ), LDA ) RAB = ABS( A( I, IRAB ) ) IRAB = IDAMAX( N, E( I, 1 ), LDE ) RAB = MAX( RAB, ABS( E( I, IRAB ) ) ) IF( WITHB ) THEN IRAB = IDAMAX( M, B( I, 1 ), LDB ) RAB = MAX( RAB, ABS( B( I, IRAB ) ) ) END IF LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE( I ) = SCLFAC**IR 170 CONTINUE C C Compute right diagonal scaling matrix. C DO 180 J = 1, N ICAB = IDAMAX( L, A( 1, J ), 1 ) CAB = ABS( A( ICAB, J ) ) ICAB = IDAMAX( L, E( 1, J ), 1 ) CAB = MAX( CAB, ABS( E( ICAB, J ) ) ) IF( WITHC ) THEN ICAB = IDAMAX( P, C( 1, J ), 1 ) CAB = MAX( CAB, ABS( C( ICAB, J ) ) ) END IF LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) ) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) RSCALE( J ) = SCLFAC**JC 180 CONTINUE C C Row scaling of matrices A, E and B. C DO 190 I = 1, L CALL DSCAL( N, LSCALE( I ), A( I, 1 ), LDA ) CALL DSCAL( N, LSCALE( I ), E( I, 1 ), LDE ) IF( WITHB ) $ CALL DSCAL( M, LSCALE( I ), B( I, 1 ), LDB ) 190 CONTINUE C C Column scaling of matrices A, E and C. C DO 200 J = 1, N CALL DSCAL( L, RSCALE( J ), A( 1, J ), 1 ) CALL DSCAL( L, RSCALE( J ), E( 1, J ), 1 ) IF( WITHC ) $ CALL DSCAL( P, RSCALE( J ), C( 1, J ), 1 ) 200 CONTINUE C RETURN C *** Last line of TG01AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03KC.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03KC.f0000644000175000017500000001762015012430707017356 0ustar00lilgelilge00000000000000 SUBROUTINE MB03KC( K, KHESS, N, R, S, A, LDA, V, TAU ) C C PURPOSE C C To reduce a 2-by-2 general, formal matrix product A of length K, C C A_K^s(K) * A_K-1^s(K-1) * ... * A_1^s(1), C C to the periodic Hessenberg-triangular form using a K-periodic C sequence of elementary reflectors (Householder matrices). The C matrices A_k, k = 1, ..., K, are stored in the N-by-N-by-K array A C starting in the R-th row and column, and N can be 3 or 4. C C Each elementary reflector H_k is represented as C C H_k = I - tau_k * v_k * v_k', (1) C C where I is the 2-by-2 identity, tau_k is a real scalar, and v_k is C a vector of length 2, k = 1,...,K, and it is constructed such that C the following holds for k = 1,...,K: C C H_{k+1} * A_k * H_k = T_k, if s(k) = 1, C (2) C H_k * A_k * H_{k+1} = T_k, if s(k) = -1, C C with H_{K+1} = H_1 and all T_k upper triangular except for C T_{khess} which is full. Clearly, C C T_K^s(K) *...* T_1^s(1) = H_1 * A_K^s(K) *...* A_1^s(1) * H_1. C C The reflectors are suitably applied to the whole, extended N-by-N C matrices Ae_k, not only to the submatrices A_k, k = 1, ..., K. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of matrices in the sequence A_k. K >= 2. C C KHESS (input) INTEGER C The index for which the returned matrix A_khess should be C in the Hessenberg form on output. 1 <= KHESS <= K. C C N (input) INTEGER C The order of the extended matrices. N = 3 or N = 4. C C R (input) INTEGER C The starting row and column index for the C 2-by-2 submatrices. R = 1, or R = N-1. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures of the factors. Each entry in S must be either C 1 or -1; the value S(k) = -1 corresponds to using the C inverse of the factor A_k. C C A (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXA(k) = C (k-1)*N*LDA+1 the N-by-N matrix Ae_k stored with leading C dimension LDA. C On exit, this array contains at position IXA(k) the C N-by-N matrix Te_k stored with leading dimension LDA. C C LDA INTEGER C Leading dimension of the matrices Ae_k and Te_k in the C one-dimensional array A. LDA >= N. C C V (output) DOUBLE PRECISION array, dimension (2*K) C On exit, this array contains the K vectors v_k, C k = 1,...,K, defining the elementary reflectors H_k as C in (1). The k-th reflector is stored in V(2*k-1:2*k). C C TAU (output) DOUBLE PRECISION array, dimension (K) C On exit, this array contains the K values of tau_k, C k = 1,...,K, defining the elementary reflectors H_k C as in (1). C C METHOD C C A K-periodic sequence of elementary reflectors (Householder C matrices) is used. The computations start for k = khess with the C left reflector in (1), which is the identity matrix. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Mar. 2010, an essentially new version of the PEP routine C PEP_DGEHR2, by R. Granat, Umea University, Sweden, Apr. 2008. C C REVISIONS C C V. Sima, Apr. 2010, May 2010. C C KEYWORDS C C Orthogonal transformation, periodic QZ algorithm, QZ algorithm. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. INTEGER K, KHESS, LDA, N, R C .. C .. Array Arguments .. INTEGER S( * ) DOUBLE PRECISION A( * ), TAU( * ), V( * ) C .. C .. Local Scalars .. INTEGER I, I1, I2, IC, INC, IP1, IR, IX, NO C .. C .. Local Arrays .. DOUBLE PRECISION TMP( 1 ), WORK( 2 ) C .. C .. External Subroutines .. EXTERNAL DLARFG, DLARFX C .. C .. Intrinsic Functions .. INTRINSIC MOD C .. C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked. C C Compute the periodic Hessenberg form of A with the Hessenberg C matrix at position KHESS - start construction from I = KHESS, C i.e., to the left of (and including) the Hessenberg matrix in the C corresponding matrix product. C C Since the problem is 2-by-2, the orthogonal matrix working on C A_{khess} from the left, if s(khess) = 1, or from the right, C if s(khess) = -1, hence H_{khess+1}, will be the identity. C IR = ( R - 1 )*LDA IC = IR + R - 1 NO = N - R INC = N*LDA I1 = KHESS*INC + 1 IP1 = MOD( KHESS, K ) + 1 C TAU( IP1 ) = ZERO V( 2*IP1-1 ) = ZERO V( 2*IP1 ) = ZERO C DO 10 I = KHESS + 1, K IP1 = MOD( I, K ) IX = I1 + IC I2 = IP1*INC + 1 IP1 = IP1 + 1 C C Compute and apply the reflector H_{i+1} working on A_i^s(i) C from the left. C IF( S( I ).EQ.1 ) THEN WORK( 1 ) = ONE WORK( 2 ) = A( IX+1 ) CALL DLARFG( 2, A( IX ), WORK( 2 ), 1, TAU( IP1 ) ) V( 2*IP1-1 ) = ONE V( 2*IP1 ) = WORK( 2 ) CALL DLARFX( 'Left', 2, NO, WORK, TAU( IP1 ), A( IX+LDA ), $ LDA, TMP ) ELSE WORK( 1 ) = A( IX+1 ) WORK( 2 ) = ONE CALL DLARFG( 2, A( IX+LDA+1 ), WORK, 1, TAU( IP1 ) ) V( 2*IP1-1 ) = WORK( 1 ) V( 2*IP1 ) = ONE CALL DLARFX( 'Right', R, 2, WORK, TAU( IP1 ), A( I1+IR ), $ LDA, TMP ) END IF A( IX+1 ) = ZERO C C Apply the reflector to A_{mod(i,K)+1}. C IF( S( IP1 ).EQ.1 ) THEN CALL DLARFX( 'Right', R+1, 2, WORK, TAU( IP1 ), A( I2+IR ), $ LDA, TMP ) ELSE CALL DLARFX( 'Left', 2, NO+1, WORK, TAU( IP1 ), A( I2+IC ), $ LDA, TMP ) END IF I1 = I1 + INC 10 CONTINUE C C Continue to the right of the Hessenberg matrix. C I1 = 1 C DO 20 I = 1, KHESS - 1 IP1 = MOD( I, K ) IX = I1 + IC I2 = IP1*INC + 1 IP1 = IP1 + 1 C C Compute and apply the reflector H_{i+1} working on A_i^s(i) C from the left. C IF( S( I ).EQ.1 ) THEN WORK( 1 ) = ONE WORK( 2 ) = A( IX+1 ) CALL DLARFG( 2, A( IX ), WORK( 2 ), 1, TAU( IP1 ) ) V( 2*IP1-1 ) = ONE V( 2*IP1 ) = WORK( 2 ) CALL DLARFX( 'Left', 2, NO, WORK, TAU( IP1 ), A( IX+LDA ), $ LDA, TMP ) ELSE WORK( 1 ) = A( IX+1 ) WORK( 2 ) = ONE CALL DLARFG( 2, A( IX+LDA+1 ), WORK, 1, TAU( IP1 ) ) V( 2*IP1-1 ) = WORK( 1 ) V( 2*IP1 ) = ONE CALL DLARFX( 'Right', R, 2, WORK, TAU( IP1 ), A( I1+IR ), $ LDA, TMP ) END IF A( IX+1 ) = ZERO C C Apply the reflector to A_{mod(i,K)+1}. C IF( S( IP1 ).EQ.1 ) THEN CALL DLARFX( 'Right', R+1, 2, WORK, TAU( IP1 ), A( I2+IR ), $ LDA, TMP ) ELSE CALL DLARFX( 'Left', 2, NO+1, WORK, TAU( IP1 ), A( I2+IC ), $ LDA, TMP ) END IF I1 = I1 + INC 20 CONTINUE C C The periodic Hessenberg-triangular form has been computed. C RETURN C C *** Last line of MB03KC *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01PD.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01PD.f0000644000175000017500000001763115012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE MB01PD( SCUN, TYPE, M, N, KL, KU, ANRM, NBL, NROWS, A, $ LDA, INFO ) C C PURPOSE C C To scale a matrix or undo scaling. Scaling is performed, if C necessary, so that the matrix norm will be in a safe range of C representable numbers. C C ARGUMENTS C C Mode Parameters C C SCUN CHARACTER*1 C SCUN indicates the operation to be performed. C = 'S': scale the matrix. C = 'U': undo scaling of the matrix. C C TYPE CHARACTER*1 C TYPE indicates the storage type of the input matrix. C = 'G': A is a full matrix. C = 'L': A is a (block) lower triangular matrix. C = 'U': A is an (block) upper triangular matrix. C = 'H': A is an (block) upper Hessenberg matrix. C = 'B': A is a symmetric band matrix with lower bandwidth C KL and upper bandwidth KU and with the only the C lower half stored. C = 'Q': A is a symmetric band matrix with lower bandwidth C KL and upper bandwidth KU and with the only the C upper half stored. C = 'Z': A is a band matrix with lower bandwidth KL and C upper bandwidth KU. 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 KL (input) INTEGER C The lower bandwidth of A. Referenced only if TYPE = 'B', C 'Q' or 'Z'. C C KU (input) INTEGER C The upper bandwidth of A. Referenced only if TYPE = 'B', C 'Q' or 'Z'. C C ANRM (input) DOUBLE PRECISION C The norm of the initial matrix A. ANRM >= 0. C When ANRM = 0 then an immediate return is effected. C ANRM should be preserved between the call of the routine C with SCUN = 'S' and the corresponding one with SCUN = 'U'. C C NBL (input) INTEGER C The number of diagonal blocks of the matrix A, if it has a C block structure. To specify that matrix A has no block C structure, set NBL = 0. NBL >= 0. C C NROWS (input) INTEGER array, dimension max(1,NBL) C NROWS(i) contains the number of rows and columns of the C i-th diagonal block of matrix A. The sum of the values C NROWS(i), for i = 1: NBL, should be equal to min(M,N). C The elements of the array NROWS are not referenced if C NBL = 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading M by N part of this array must C contain the matrix to be scaled/unscaled. C On exit, the leading M by N part of A will contain C the modified matrix. C The storage mode of A is specified by TYPE. C C LDA (input) INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C Error Indicator C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -i, the i-th argument had an illegal C value. C C METHOD C C Denote by ANRM the norm of the matrix, and by SMLNUM and BIGNUM, C two positive numbers near the smallest and largest safely C representable numbers, respectively. The matrix is scaled, if C needed, such that the norm of the result is in the range C [SMLNUM, BIGNUM]. The scaling factor is represented as a ratio C of two numbers, one of them being ANRM, and the other one either C SMLNUM or BIGNUM, depending on ANRM being less than SMLNUM or C larger than BIGNUM, respectively. For undoing the scaling, the C norm is again compared with SMLNUM or BIGNUM, and the reciprocal C of the previous scaling factor is used. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. C C REVISIONS C C V. Sima, Oct. 2001, June 2022. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER SCUN, TYPE INTEGER INFO, KL, KU, LDA, M, MN, N, NBL DOUBLE PRECISION ANRM C .. Array Arguments .. INTEGER NROWS ( * ) DOUBLE PRECISION A( LDA, * ) C .. Local Scalars .. LOGICAL LSCALE INTEGER I, ISUM, ITYPE DOUBLE PRECISION BIGNUM, SMLNUM C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. C .. External Subroutines .. EXTERNAL DLABAD, MB01QD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 LSCALE = LSAME( SCUN, 'S' ) IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF C MN = MIN( M, N ) C ISUM = 0 IF( NBL.GT.0 ) THEN DO 10 I = 1, NBL ISUM = ISUM + NROWS(I) 10 CONTINUE END IF C IF( .NOT.LSCALE .AND. .NOT.LSAME( SCUN, 'U' ) ) THEN INFO = -1 ELSE IF( ITYPE.EQ.-1 ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. N.NE.M ) ) THEN INFO = -4 ELSE IF( ANRM.LT.ZERO ) THEN INFO = -7 ELSE IF( NBL.LT.0 ) THEN INFO = -8 ELSE IF( NBL.GT.0 .AND. ISUM.NE.MN ) THEN INFO = -9 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -5 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -6 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -11 END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB01PD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MN.EQ.0 .OR. ANRM.EQ.ZERO ) $ RETURN C C Get machine parameters. C SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) C IF ( LSCALE ) THEN C C Scale A, if its norm is outside range [SMLNUM,BIGNUM]. C IF( ANRM.LT.SMLNUM ) THEN C C Scale matrix norm up to SMLNUM. C CALL MB01QD( TYPE, M, N, KL, KU, ANRM, SMLNUM, NBL, NROWS, $ A, LDA, INFO ) ELSE IF( ANRM.GT.BIGNUM ) THEN C C Scale matrix norm down to BIGNUM. C CALL MB01QD( TYPE, M, N, KL, KU, ANRM, BIGNUM, NBL, NROWS, $ A, LDA, INFO ) END IF C ELSE C C Undo scaling. C IF( ANRM.LT.SMLNUM ) THEN CALL MB01QD( TYPE, M, N, KL, KU, SMLNUM, ANRM, NBL, NROWS, $ A, LDA, INFO ) ELSE IF( ANRM.GT.BIGNUM ) THEN CALL MB01QD( TYPE, M, N, KL, KU, BIGNUM, ANRM, NBL, NROWS, $ A, LDA, INFO ) END IF END IF C RETURN C *** Last line of MB01PD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB05SD.f0000644000000000000000000000013215012430707016153 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB05SD.f0000644000175000017500000002667315012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB, $ C, LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK, $ LDWORK, INFO) C C PURPOSE C C To construct for a given state space system (A,B,C,D) the closed- C loop system (Ac,Bc,Cc,Dc) corresponding to the output feedback C control law C C u = alpha*F*y + v. C C ARGUMENTS C C Mode Parameters C C FBTYPE CHARACTER*1 C Specifies the type of the feedback law as follows: C = 'I': Unitary output feedback (F = I); C = 'O': General output feedback. 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 number of state variables, i.e. the order of the C matrix A, the number of rows of B and the number of C columns of C. N >= 0. C C M (input) INTEGER C The number of input variables, i.e. the number of columns C of matrices B and D, and the number of rows of F. M >= 0. C C P (input) INTEGER C The number of output variables, i.e. the number of rows of C matrices C and D, and the number of columns of F. P >= 0 C and P = M if FBTYPE = 'I'. C C ALPHA (input) DOUBLE PRECISION C The coefficient alpha in the output feedback law. 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 system state transition matrix A. C On exit, the leading N-by-N part of this array contains C the state matrix Ac of the closed-loop system. 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 system input matrix B. C On exit, the leading N-by-M part of this array contains C the input matrix Bc of the closed-loop system. 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 system output matrix C. C On exit, the leading P-by-N part of this array contains C the output matrix Cc of the closed-loop system. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,P) if N > 0. C LDC >= 1 if N = 0. 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 system direct input/output transmission C matrix D. C On exit, if JOBD = 'D', the leading P-by-M part of this C array contains the direct input/output transmission C matrix Dc of the closed-loop system. 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 F (input) DOUBLE PRECISION array, dimension (LDF,P) C If FBTYPE = 'O', the leading M-by-P part of this array C must contain the output feedback matrix F. C If FBTYPE = 'I', then the feedback matrix is assumed to be C an M x M order identity matrix. C The array F is not referenced if FBTYPE = 'I' or C ALPHA = 0. C C LDF INTEGER C The leading dimension of array F. C LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0. C LDF >= 1 if FBTYPE = 'I' or ALPHA = 0. C C RCOND (output) DOUBLE PRECISION C The reciprocal condition number of the matrix C I - alpha*D*F. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK >= MAX(1,2*P) if JOBD = 'D'. C LIWORK >= 1 if JOBD = 'Z'. C IWORK is not referenced if JOBD = 'Z'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= wspace, where C wspace = MAX( 1, M, P*P + 4*P ) if JOBD = 'D', C wspace = MAX( 1, M ) if JOBD = 'Z'. C For best performance, LDWORK >= MAX( wspace, N*M, N*P ). 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 I - alpha*D*F is numerically singular. C C METHOD C C The matrices of the closed-loop system have the expressions: C C Ac = A + alpha*B*F*E*C, Bc = B + alpha*B*F*E*D, C Cc = E*C, Dc = E*D, C C where E = (I - alpha*D*F)**-1. C C NUMERICAL ASPECTS C C The accuracy of computations basically depends on the conditioning C of the matrix I - alpha*D*F. If RCOND is very small, it is likely C that the computed results are inaccurate. C C CONTRIBUTORS C C A. Varga, German Aerospace Research Establishment, C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, C Belgium, Nov. 1996. C C REVISIONS C C January 14, 1997. C V. Sima, Research Institute for Informatics, Bucharest, July 2003. C C KEYWORDS C C Multivariable system, state-space model, state-space C representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER FBTYPE, JOBD INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDWORK, M, N, P DOUBLE PRECISION ALPHA, RCOND C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), F(LDF,*) C .. Local Scalars .. LOGICAL LJOBD, OUTPF, UNITF INTEGER I, IW, LDWN, LDWP DOUBLE PRECISION ENORM C .. Local Arrays .. DOUBLE PRECISION DUMMY(1) C .. External functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External subroutines .. EXTERNAL DAXPY, DCOPY, DGECON, DGEMM, DGEMV, DGETRF, $ DGETRS, DLACPY, DLASCL, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C C .. Executable Statements .. C C Check the input scalar arguments. C UNITF = LSAME( FBTYPE, 'I' ) OUTPF = LSAME( FBTYPE, 'O' ) LJOBD = LSAME( JOBD, 'D' ) LDWN = MAX( 1, N ) LDWP = MAX( 1, P ) C INFO = 0 C IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN INFO = -1 ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN INFO = -5 ELSE IF( LDA.LT.LDWN ) THEN INFO = -7 ELSE IF( LDB.LT.LDWN ) THEN INFO = -9 ELSE IF( ( N.GT.0 .AND. LDC.LT.LDWP ) .OR. $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN INFO = -11 ELSE IF( ( LJOBD .AND. LDD.LT.LDWP ) .OR. $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN INFO = -13 ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) ) $ .OR. ( ( UNITF .OR. ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN INFO = -16 ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*P + 4*P ) ) .OR. $ ( .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN INFO = -20 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB05SD', -INFO ) RETURN END IF C C Quick return if possible. C RCOND = ONE IF ( MAX( N, MIN( M, P ) ).EQ.0 .OR. ALPHA.EQ.ZERO ) $ RETURN C IF (LJOBD) THEN IW = P*P + 1 C C Compute I - alpha*D*F. C IF( UNITF) THEN CALL DLACPY( 'F', P, P, D, LDD, DWORK, LDWP ) IF ( ALPHA.NE.-ONE ) $ CALL DLASCL( 'G', 0, 0, ONE, -ALPHA, P, P, DWORK, LDWP, $ INFO ) ELSE CALL DGEMM( 'N', 'N', P, P, M, -ALPHA, D, LDD, F, LDF, ZERO, $ DWORK, LDWP ) END IF C DUMMY(1) = ONE CALL DAXPY( P, ONE, DUMMY, 0, DWORK, P+1 ) C C Compute Cc = E*C, Dc = E*D, where E = (I - alpha*D*F)**-1. C ENORM = DLANGE( '1', P, P, DWORK, LDWP, DWORK(IW) ) CALL DGETRF( P, P, DWORK, LDWP, IWORK, INFO ) IF( INFO.GT.0 ) THEN C C Error return. C RCOND = ZERO INFO = 1 RETURN END IF CALL DGECON( '1', P, DWORK, LDWP, ENORM, RCOND, DWORK(IW), $ IWORK(P+1), INFO ) IF( RCOND.LE.DLAMCH('E') ) THEN C C Error return. C INFO = 1 RETURN END IF C IF( N.GT.0 ) $ CALL DGETRS( 'N', P, N, DWORK, LDWP, IWORK, C, LDC, INFO ) CALL DGETRS( 'N', P, M, DWORK, LDWP, IWORK, D, LDD, INFO ) END IF C IF ( N.EQ.0 ) $ RETURN C C Compute Ac = A + alpha*B*F*Cc and Bc = B + alpha*B*F*Dc. C IF( UNITF ) THEN CALL DGEMM( 'N', 'N', N, N, M, ALPHA, B, LDB, C, LDC, ONE, A, $ LDA ) IF( LJOBD ) THEN C IF( LDWORK.LT.N*M ) THEN C C Not enough working space for using DGEMM. C DO 10 I = 1, N CALL DCOPY( P, B(I,1), LDB, DWORK, 1 ) CALL DGEMV( 'T', P, P, ALPHA, D, LDD, DWORK, 1, ONE, $ B(I,1), LDB ) 10 CONTINUE C ELSE CALL DLACPY( 'F', N, M, B, LDB, DWORK, LDWN ) CALL DGEMM( 'N', 'N', N, P, M, ALPHA, DWORK, LDWN, D, $ LDD, ONE, B, LDB ) END IF END IF ELSE C IF( LDWORK.LT.N*P ) THEN C C Not enough working space for using DGEMM. C DO 20 I = 1, N CALL DGEMV( 'N', M, P, ALPHA, F, LDF, C(1,I), 1, ZERO, $ DWORK, 1 ) CALL DGEMV( 'N', N, M, ONE, B, LDB, DWORK, 1, ONE, $ A(1,I), 1 ) 20 CONTINUE C IF( LJOBD ) THEN C DO 30 I = 1, N CALL DGEMV( 'T', M, P, ALPHA, F, LDF, B(I,1), LDB, $ ZERO, DWORK, 1 ) CALL DGEMV( 'T', P, M, ONE, D, LDD, DWORK, 1, ONE, $ B(I,1), LDB ) 30 CONTINUE C END IF ELSE C CALL DGEMM( 'N', 'N', N, P, M, ALPHA, B, LDB, F, LDF, $ ZERO, DWORK, LDWN ) CALL DGEMM( 'N', 'N', N, N, P, ONE, DWORK, LDWN, C, LDC, $ ONE, A, LDA ) IF( LJOBD ) $ CALL DGEMM( 'N', 'N', N, M, P, ONE, DWORK, LDWN, D, LDD, $ ONE, B, LDB ) END IF END IF C RETURN C *** Last line of AB05SD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01LD.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01LD.f0000644000175000017500000003475215012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE MB01LD( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, $ X, LDX, DWORK, LDWORK, INFO ) 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 skew-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 skew-symmetric matrices R C and X are given, as follows: C = 'U': the strictly upper triangular part is given; C = 'L': the strictly 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 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 or N <= 1, or M <= 1, C then A and X are not referenced. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) C On entry with UPLO = 'U', the leading M-by-M strictly C upper triangular part of this array must contain the C strictly upper triangular part of the skew-symmetric C matrix R. The lower triangle is not referenced. C On entry with UPLO = 'L', the leading M-by-M strictly C lower triangular part of this array must contain the C strictly lower triangular part of the skew-symmetric C matrix R. The upper triangle is not referenced. C On exit, the leading M-by-M strictly upper triangular part C (if UPLO = 'U'), or strictly lower triangular part C (if UPLO = 'L'), of this array contains the corresponding C _ C strictly triangular part of the computed matrix R. C C LDR INTEGER C The leading dimension of the 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 the 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 or input/output) DOUBLE PRECISION array, dimension C (LDX,K), where K = N, if UPLO = 'U' or LDWORK >= M*(N-1), C or K = MAX(N,M), if UPLO = 'L' and LDWORK < M*(N-1). C On entry, if UPLO = 'U', the leading N-by-N strictly upper C triangular part of this array must contain the strictly C upper triangular part of the skew-symmetric matrix X and C the lower triangular part of the array is not referenced. C On entry, if UPLO = 'L', the leading N-by-N strictly lower C triangular part of this array must contain the strictly C lower triangular part of the skew-symmetric matrix X and C the upper triangular part of the array is not referenced. C If LDWORK < M*(N-1), this array is overwritten with the C matrix op(A)*X, if UPLO = 'U', or X*op(A)', if UPLO = 'L'. C C LDX INTEGER C The leading dimension of the array X. C LDX >= MAX(1,N), if UPLO = 'L' or LDWORK >= M*(N-1); C LDX >= MAX(1,N,M), if UPLO = 'U' and LDWORK < M*(N-1). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C This array is not referenced when beta = 0, or M <= 1, or C N <= 1. C C LDWORK The length of the array DWORK. C LDWORK >= N, if beta <> 0, and M > 0, and N > 1; C LDWORK >= 0, if beta = 0, or M = 0, or N <= 1. C For optimum performance, LDWORK >= M*(N-1), if beta <> 0, C M > 1, and N > 1. 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 skew- C symmetry into account. If LDWORK >= M*(N-1), a BLAS 3 like C implementation is used. Specifically, let X = T - T', with T a C strictly upper or strictly lower triangular matrix, defined by C C T = striu( X ), if UPLO = 'U', C T = stril( X ), if UPLO = 'L', C C where striu and stril denote the strictly upper triangular part C and strictly lower triangular 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 the skew-symmetric C correspondent of DSYR2K (with a Fortran implementation available C in the SLICOT Library routine MB01KD). C If LDWORK < M*(N-1), a BLAS 2 implementation is used. 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, Research Institute for Informatics, Bucharest, Jan. 2010. C Based on the SLICOT Library routine MB01RU and the HAPACK Library C routine DSKUPD. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2010. 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 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, NOTTRA, UPPER INTEGER I, J, M2 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DLASET, DSCAL, $ DTRMM, MB01KD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTTRA = LSAME( TRANS, 'N' ) LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) C IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = -1 ELSE IF( ( .NOT.NOTTRA ).AND.( .NOT.LTRANS ) )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. $ ( NOTTRA .AND. LDA.LT.M ) ) THEN INFO = -10 ELSE IF( LDX.LT.MAX( 1, N ) .OR. $ ( LDX.LT.M .AND. UPPER .AND. LDWORK.LT.M*( N - 1 ) ) ) THEN INFO = -12 ELSE IF( LDWORK.LT.0 .OR. ( BETA.NE.ZERO .AND. M.GT.1 .AND. N.GT.1 $ .AND. LDWORK.LT.N ) ) THEN INFO = -14 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01LD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( M.LE.0 ) $ RETURN C M2 = MIN( 2, M ) IF ( BETA.EQ.ZERO .OR. N.LE.1 ) THEN IF ( UPPER ) THEN I = 1 J = M2 ELSE I = M2 J = 1 END IF C IF ( ALPHA.EQ.ZERO ) THEN C C Special case alpha = 0. C CALL DLASET( UPLO, M-1, M-1, ZERO, ZERO, R(I,J), LDR ) ELSE C C Special case beta = 0 or N <= 1. C IF ( ALPHA.NE.ONE ) $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M-1, M-1, R(I,J), $ LDR, INFO ) END IF RETURN END IF C C General case: beta <> 0. C IF ( LDWORK.GE.M*( N - 1 ) ) THEN C C Use a BLAS 3 like implementation. C Compute W = A*T or W = T*A in DWORK, and apply the updating C formula (see METHOD section). Note that column 1 (if C UPLO = 'U') or column N (if UPLO = 'L') is zero in the first C case, and it is not stored; similarly, row N (if UPLO = 'U') or C row 1 (if UPLO = 'L') is zero in the second case, and it is not C stored. C Workspace: need M*(N-1). C IF ( UPPER ) THEN I = 1 J = M2 ELSE I = M2 J = 1 END IF C IF( NOTTRA ) THEN C CALL DLACPY( 'Full', M, N-1, A(1,I), LDA, DWORK, M ) CALL DTRMM( 'Right', UPLO, 'NoTranspose', 'Non-unit', M, $ N-1, ONE, X(I,J), LDX, DWORK, M ) CALL MB01KD( UPLO, TRANS, M, N-1, BETA, DWORK, M, A(1,J), $ LDA, ALPHA, R, LDR, INFO ) C ELSE C CALL DLACPY( 'Full', N-1, M, A(J,1), LDA, DWORK, N-1 ) CALL DTRMM( 'Left', UPLO, 'NoTranspose', 'Non-unit', N-1, $ M, ONE, X(I,J), LDX, DWORK, N-1 ) CALL MB01KD( UPLO, TRANS, M, N-1, BETA, A(I,1), LDA, DWORK, $ N-1, ALPHA, R, LDR, INFO ) C END IF C ELSE C C Use a BLAS 2 implementation. C C IF ( NOTTRA ) THEN C C Compute A*X*A'. C IF ( UPPER ) THEN C C Compute A*X in X (M-by-N). C DO 10 J = 1, N-1 CALL DCOPY( J-1, X(1,J), 1, DWORK, 1 ) DWORK(J) = ZERO CALL DCOPY( N-J, X(J,J+1), LDX, DWORK(J+1), 1 ) CALL DSCAL( N-J, -ONE, DWORK(J+1), 1 ) CALL DGEMV( TRANS, M, N, ONE, A, LDA, DWORK, 1, ZERO, $ X(1,J), 1 ) 10 CONTINUE C CALL DCOPY( N-1, X(1,N), 1, DWORK, 1 ) CALL DGEMV( TRANS, M, N-1, ONE, A, LDA, DWORK, 1, ZERO, $ X(1,N), 1 ) C C Compute alpha*striu( R ) + beta*striu( X*A' ) in the C strictly upper triangular part of R. C DO 20 I = 1, M-1 CALL DCOPY( N, X(I,1), LDX, DWORK, 1 ) CALL DGEMV( TRANS, M-I, N, BETA, A(I+1,1), LDA, DWORK, $ 1, ALPHA, R(I,I+1), LDR ) 20 CONTINUE C ELSE C C Compute X*A' in X (N-by-M). C DO 30 I = 1, N-1 CALL DCOPY( I-1, X(I,1), LDX, DWORK, 1 ) DWORK(I) = ZERO CALL DCOPY( N-I, X(I+1,I), 1, DWORK(I+1), 1 ) CALL DSCAL( N-I, -ONE, DWORK(I+1), 1 ) CALL DGEMV( TRANS, M, N, ONE, A, LDA, DWORK, 1, ZERO, $ X(I,1), LDX ) 30 CONTINUE C CALL DCOPY( N-1, X(N,1), LDX, DWORK, 1 ) CALL DGEMV( TRANS, M, N-1, ONE, A, LDA, DWORK, 1, ZERO, $ X(N,1), LDX ) C C Compute alpha*stril( R ) + beta*stril( A*X ) in the C strictly lower triangular part of R. C DO 40 J = 1, M-1 CALL DCOPY( N, X(1,J), 1, DWORK, 1 ) CALL DGEMV( TRANS, M-J, N, BETA, A(J+1,1), LDA, DWORK, $ 1, ALPHA, R(J+1,J), 1 ) 40 CONTINUE C END IF C ELSE C C Compute A'*X*A. C IF ( UPPER ) THEN C C Compute A'*X in X (M-by-N). C DO 50 J = 1, N-1 CALL DCOPY( J-1, X(1,J), 1, DWORK, 1 ) DWORK(J) = ZERO CALL DCOPY( N-J, X(J,J+1), LDX, DWORK(J+1), 1 ) CALL DSCAL( N-J, -ONE, DWORK(J+1), 1 ) CALL DGEMV( TRANS, N, M, ONE, A, LDA, DWORK, 1, ZERO, $ X(1,J), 1 ) 50 CONTINUE C CALL DCOPY( N-1, X(1,N), 1, DWORK, 1 ) CALL DGEMV( TRANS, N-1, M, ONE, A, LDA, DWORK, 1, ZERO, $ X(1,N), 1 ) C C Compute alpha*striu( R ) + beta*striu( X*A ) in the C strictly upper triangular part of R. C DO 60 I = 1, M-1 CALL DCOPY( N, X(I,1), LDX, DWORK, 1 ) CALL DGEMV( TRANS, N, M-I, BETA, A(1,I+1), LDA, DWORK, $ 1, ALPHA, R(I,I+1), LDR ) 60 CONTINUE C ELSE C C Compute X*A in X (N-by-M). C DO 70 I = 1, N-1 CALL DCOPY( I-1, X(I,1), LDX, DWORK, 1 ) DWORK(I) = ZERO CALL DCOPY( N-I, X(I+1,I), 1, DWORK(I+1), 1 ) CALL DSCAL( N-I, -ONE, DWORK(I+1), 1 ) CALL DGEMV( TRANS, N, M, ONE, A, LDA, DWORK, 1, ZERO, $ X(I,1), LDX ) 70 CONTINUE C CALL DCOPY( N-1, X(N,1), LDX, DWORK, 1 ) CALL DGEMV( TRANS, N-1, M, ONE, A, LDA, DWORK, 1, ZERO, $ X(N,1), LDX ) C C Compute alpha*stril( R ) + beta*stril( A'*X ) in the C strictly lower triangular part of R. C DO 80 J = 1, M-1 CALL DCOPY( N, X(1,J), 1, DWORK, 1 ) CALL DGEMV( TRANS, N, M-J, BETA, A(1,J+1), LDA, DWORK, $ 1, ALPHA, R(J+1,J), 1 ) 80 CONTINUE C END IF END IF END IF C RETURN C *** Last line of MB01LD *** END control-4.1.2/src/slicot/src/PaxHeaders/MA01AD.f0000644000000000000000000000013215012430707016140 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA01AD.f0000644000175000017500000000405615012430707017341 0ustar00lilgelilge00000000000000 SUBROUTINE MA01AD( XR, XI, YR, YI ) C C PURPOSE C C To compute the complex square root YR + i*YI of a complex number C XR + i*XI in real arithmetic. The returned result is so that C YR >= 0.0 and SIGN(YI) = SIGN(XI). C C ARGUMENTS C C Input/Output Parameters C C XR (input) DOUBLE PRECISION C XI (input) DOUBLE PRECISION C These scalars define the real and imaginary part of the C complex number of which the square root is sought. C C YR (output) DOUBLE PRECISION C YI (output) DOUBLE PRECISION C These scalars define the real and imaginary part of the C complex square root. C C METHOD C C The complex square root YR + i*YI of the complex number XR + i*XI C is computed in real arithmetic, taking care to avoid overflow. C C REFERENCES C C Adapted from EISPACK subroutine CSROOT. C C CONTRIBUTOR C C P. Benner, Universitaet Bremen, Germany, and C R. Byers, University of Kansas, Lawrence, USA, C Aug. 1998, routine DCROOT. C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Oct. 1998, SLICOT Library version. C C REVISIONS C C - C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF PARAMETER ( ZERO = 0.0D0, HALF = 1.0D0/2.0D0 ) C .. C .. Scalar Arguments .. DOUBLE PRECISION XR, XI, YR, YI C .. C .. Local Scalars .. DOUBLE PRECISION S C .. C .. External Functions .. DOUBLE PRECISION DLAPY2 EXTERNAL DLAPY2 C C .. Intrinsic functions .. INTRINSIC ABS, SQRT C .. C .. Executable Statements .. C S = SQRT( HALF*( DLAPY2( XR, XI ) + ABS( XR ) ) ) IF ( XR.GE.ZERO ) YR = S IF ( XI.LT.ZERO ) S = -S IF ( XR.LE.ZERO ) THEN YI = S IF ( XR.LT.ZERO ) YR = HALF*( XI/S ) ELSE YI = HALF*( XI/YR ) END IF C RETURN C *** Last line of MA01AD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03OV.f0000644000000000000000000000013215012430707016211 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB03OV.f0000644000175000017500000000566215012430707017416 0ustar00lilgelilge00000000000000 SUBROUTINE SB03OV( A, B, SMALL, C, S ) C C PURPOSE C C To construct a complex plane rotation such that, for a complex C number a and a real number b, C C ( conjg( c ) s )*( a ) = ( d ), C ( -s c ) ( b ) ( 0 ) C C where d is always real and is overwritten on a, so that on C return the imaginary part of a is zero. b is unaltered. C C This routine has A and C declared as REAL, because it is intended C for use within a real Lyapunov solver and the REAL declarations C mean that a standard Fortran DOUBLE PRECISION version may be C readily constructed. However A and C could safely be declared C COMPLEX in the calling program, although some systems may give a C type mismatch warning. C C ARGUMENTS C C Input/Output Parameters C C A (input/output) DOUBLE PRECISION array, dimension (2) C On entry, A(1) and A(2) must contain the real and C imaginary part, respectively, of the complex number a. C On exit, A(1) contains the real part of d, and A(2) is C set to zero. C C B (input) DOUBLE PRECISION C The real number b. C C SMALL (input) DOUBLE PRECISION C A small real number. If the norm d of [ a; b ] is smaller C than SMALL, then the rotation is taken as a unit matrix, C and A(1) and A(2) are set to d and 0, respectively. C C C (output) DOUBLE PRECISION array, dimension (2) C C(1) and C(2) contain the real and imaginary part, C respectively, of the complex number c, the cosines of C the plane rotation. C C S (output) DOUBLE PRECISION C The real number s, the sines of the plane rotation. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB03CV by Sven Hammarling, C NAG Ltd., United Kingdom, May 1985. C C REVISIONS C C Dec. 1997, Aug. 2012. C C KEYWORDS C C Lyapunov equation, orthogonal transformation. C C ***************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION B, S, SMALL C .. Array Arguments .. DOUBLE PRECISION A(2), C(2) C .. Local Scalars .. DOUBLE PRECISION D C .. External Functions .. DOUBLE PRECISION DLAPY3 EXTERNAL DLAPY3 C .. Executable Statements .. C D = DLAPY3( A(1), A(2), B ) IF ( D.LT.SMALL ) THEN C(1) = ONE C(2) = ZERO S = ZERO IF ( D.GT.ZERO ) THEN A(1) = D A(2) = ZERO END IF ELSE C(1) = A(1)/D C(2) = A(2)/D S = B/D A(1) = D A(2) = ZERO END IF C RETURN C *** Last line of SB03OV *** END control-4.1.2/src/slicot/src/PaxHeaders/DK01MD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/DK01MD.f0000644000175000017500000001015015012430707017346 0ustar00lilgelilge00000000000000 SUBROUTINE DK01MD( TYPE, N, A, INFO ) C C PURPOSE C C To apply an anti-aliasing window to a real signal. C C ARGUMENTS C C Mode Parameters C C TYPE CHARACTER*1 C Indicates the type of window to be applied to the signal C as follows: C = 'M': Hamming window; C = 'N': Hann window; C = 'Q': Quadratic window. C C Input/Output Parameters C C N (input) INTEGER C The number of samples. N >= 1. C C A (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the signal to be C processed. C On exit, this array contains the windowing function. 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 If TYPE = 'M', then a Hamming window is applied to A(1),...,A(N), C which yields C _ C A(i) = (0.54 + 0.46*cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N. C C If TYPE = 'N', then a Hann window is applied to A(1),...,A(N), C which yields C _ C A(i) = 0.5*(1 + cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N. C C If TYPE = 'Q', then a quadratic window is applied to A(1),..., C A(N), which yields C _ C A(i) = (1 - 2*((i-1)/(N-1))**2)*(1 - (i-1)/(N-1))*A(i), C i = 1,2,...,(N-1)/2+1; C _ C A(i) = 2*(1 - ((i-1)/(N-1))**3)*A(i), i = (N-1)/2+2,...,N. C C REFERENCES C C [1] Rabiner, L.R. and Rader, C.M. C Digital Signal Processing. C IEEE Press, 1972. C C NUMERICAL ASPECTS C C The algorithm requires 0( N ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C Supersedes Release 2.0 routine DK01AD by R. Dekeyser, State C University of Gent, Belgium. C C REVISIONS C C - C C KEYWORDS C C Digital signal processing, Hamming window, Hann window, real C signals, windowing. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION PT46, HALF, PT54, ONE, TWO, FOUR PARAMETER ( PT46=0.46D0, HALF=0.5D0, PT54=0.54D0, $ ONE = 1.0D0, TWO=2.0D0, FOUR=4.0D0 ) C .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, N C .. Array Arguments .. DOUBLE PRECISION A(*) C .. Local Scalars .. LOGICAL MTYPE, MNTYPE, NTYPE INTEGER I, N1 DOUBLE PRECISION BUF, FN, TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC ATAN, COS, DBLE C .. Executable Statements .. C INFO = 0 MTYPE = LSAME( TYPE, 'M' ) NTYPE = LSAME( TYPE, 'N' ) MNTYPE = MTYPE.OR.NTYPE C C Test the input scalar arguments. C IF( .NOT.MNTYPE .AND. .NOT.LSAME( TYPE, 'Q' ) ) $ THEN INFO = -1 ELSE IF( N.LE.0 ) THEN INFO = -2 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'DK01MD', -INFO ) RETURN END IF C FN = DBLE( N-1 ) IF( MNTYPE ) TEMP = FOUR*ATAN( ONE )/FN C IF ( MTYPE ) THEN C C Hamming window. C DO 10 I = 1, N A(I) = A(I)*( PT54 + PT46*COS( TEMP*DBLE( I-1 ) ) ) 10 CONTINUE C ELSE IF ( NTYPE ) THEN C C Hann window. C DO 20 I = 1, N A(I) = A(I)*HALF*( ONE + COS( TEMP*DBLE( I-1 ) ) ) 20 CONTINUE C ELSE C C Quadratic window. C N1 = ( N-1 )/2 + 1 C DO 30 I = 1, N BUF = DBLE( I-1 )/FN TEMP = BUF**2 IF ( I.LE.N1 ) THEN A(I) = A(I)*( ONE - TWO*TEMP )*( ONE - BUF ) ELSE A(I) = A(I)*TWO*( ONE - BUF*TEMP ) END IF 30 CONTINUE C END IF C RETURN C *** Last line of DK01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01XD.f0000644000000000000000000000013015012430707016167 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MC01XD.f0000644000175000017500000002374215012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE MC01XD( ALPHA, BETA, GAMMA, DELTA, EVR, EVI, EVQ, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the roots of the polynomial C C P(t) = ALPHA + BETA*t + GAMMA*t^2 + DELTA*t^3 . C C ARGUMENTS C C Input/Output Parameters C C ALPHA (input) DOUBLE PRECISION C BETA (input) DOUBLE PRECISION C GAMMA (input) DOUBLE PRECISION C DELTA (input) DOUBLE PRECISION C The coefficients of the polynomial P. C C EVR (output) DOUBLE PRECISION array, DIMENSION at least 3 C EVI (output) DOUBLE PRECISION array, DIMENSION at least 3 C EVQ (output) DOUBLE PRECISION array, DIMENSION at least 3 C On output, the kth root of P will be equal to C (EVR(K) + i*EVI(K))/EVQ(K) if EVQ(K) .NE. ZERO. Note that C the quotient may over- or underflow. If P has a degree d C less than 3, then 3-d computed roots will be infinite. C EVQ(K) >= 0. C C Workspace C C DWORK DOUBLE PRECISION array, DIMENSION (LDWORK) C On exit, if LDWORK = -1 on input, then DWORK(1) returns C the optimal value of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. LDWORK >= 42. C C If LDWORK = -1, an optimal workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message 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 > 0: if INFO = j, 1 <= j <= 6, an error occurred during C the call to one of the LAPACK Library routines DGGEV C or DGEEV (1 <= j <= 3). If INFO < 3, the values C returned in EVR(K), EVI(K), and EVQ(K) should be C correct for K = INFO+1,...,3. C C METHOD C C A matrix pencil is built, whose eigenvalues are the roots of the C given polynomial, and they are computed using the QZ algorithm. C However, when the ratio between the largest and smallest (in C magnitude) polynomial coefficients is relatively big, and either C ALPHA or DELTA has the largest magnitude, then a standard C eigenproblem is solved using the QR algorithm, and EVQ(I) are set C to 1, for I = 1,2,3. C C NUMERICAL ASPECTS C C The algorithm is numerically stable. C C CONTRIBUTORS C C M. Slowik, Institut fur Mathematik, TU Berlin, Dec. 2004. C P. Benner, Fakultat fur Mathematik, TU Chemnitz, Dec. 2004. C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2005. C C REVISIONS C C V. Sima, Jan. 2013, Dec. 2013. C C KEYWORDS C C Eigenvalues, equivalence transformation, generalized real Schur C form, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TEN PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 1.0D1 ) C .. Scalar Arguments .. INTEGER INFO, LDWORK DOUBLE PRECISION ALPHA, BETA, DELTA, GAMMA C .. Array Arguments .. DOUBLE PRECISION DWORK(*), EVI(3), EVQ(3), EVR(3) C .. Local Scalars .. INTEGER I, J, M2POS, NMIN, WRKPOS DOUBLE PRECISION MAXC, MINC, VAR C .. External Subroutines .. EXTERNAL DGEEV, DGGEV, DLADIV, DLASET, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C NMIN = 42 IF ( LDWORK.EQ.-1 ) THEN CALL DGEEV( 'N', 'N', 3, DWORK, 3, EVR, EVI, DWORK, 1, DWORK, $ 1, DWORK, -1, INFO ) CALL DGGEV( 'N', 'N', 3, DWORK, 3, DWORK, 3, EVR, EVI, EVQ, $ DWORK, 1, DWORK, 1, DWORK(2), -1, INFO ) DWORK(1) = MAX( NMIN, 9+INT( DWORK(1) ), 18+INT( DWORK(2) ) ) RETURN ELSE IF ( LDWORK.LT.NMIN ) THEN INFO = -9 C C Error return. C CALL XERBLA( 'MC01XD', -INFO ) RETURN END IF C C Initialize DWORK positions. C CALL DLASET( 'All', 18, 1, ZERO, ZERO, DWORK, 18 ) C M2POS = 10 WRKPOS = 19 C C Specify the different cases. C IF ( ABS( ALPHA ).GT.ABS( BETA ) ) THEN I = 0 EVR(1) = ALPHA ELSE I = 1 EVR(1) = BETA END IF C IF ( ABS( GAMMA ).GT.ABS( DELTA ) ) THEN J = 2 EVR(2) = GAMMA ELSE J = 3 EVR(2) = DELTA END IF C IF ( ABS( EVR(2) ).GT.ABS( EVR(1) ) ) THEN I = J MAXC = ABS( EVR(2) ) ELSE MAXC = ABS( EVR(1) ) END IF C MINC = MIN( ABS( ALPHA ), ABS( BETA ), $ ABS( GAMMA ), ABS( DELTA ) ) IF ( MINC.GT.ZERO ) THEN VAR = MAXC/MINC ELSE VAR = MAXC END IF C IF ( VAR.GT.TEN ) THEN C C Large variation in the coefficients of the polynomial. C Generate the matrices M1 and M2 stored in DWORK. C If I = 0 or 3, a standard eigenvalue problem is solved, C since the current LAPACK generalized eigensolver does not C perform balancing. C IF ( I.EQ.0 ) THEN C C Elements of matrix M2. C DWORK(1) = -BETA/ALPHA DWORK(2) = ONE DWORK(4) = -GAMMA/ALPHA DWORK(6) = ONE DWORK(7) = -DELTA/ALPHA C ELSE IF ( I.EQ.1 ) THEN C C Elements of matrix M1. C DWORK(1) = -ALPHA/BETA DWORK(4) = -GAMMA/BETA DWORK(5) = ONE DWORK(7) = -DELTA/BETA DWORK(9) = ONE C C Elements of matrix M2. C DWORK(10) = ONE DWORK(11) = DWORK(1) DWORK(14) = DWORK(4) DWORK(15) = ONE DWORK(17) = DWORK(7) C ELSE IF ( I.EQ.2 ) THEN C C Elements of matrix M1. C DWORK(2) = -ALPHA/GAMMA DWORK(4) = ONE DWORK(5) = -BETA/GAMMA DWORK(8) = -DELTA/GAMMA DWORK(9) = ONE C C Elements of matrix M2. C DWORK(10) = ONE DWORK(12) = DWORK(2) DWORK(14) = ONE DWORK(15) = DWORK(5) DWORK(18) = DWORK(8) C ELSE C C Elements of matrix M1. C DWORK(3) = -ALPHA/DELTA DWORK(4) = ONE DWORK(6) = -BETA/DELTA DWORK(8) = ONE DWORK(9) = -GAMMA/DELTA END IF C C Compute the roots of the polynomial by solving an eigenproblem C using the QR- or QZ-Algorithm. C IF ( I.EQ.0 .OR. I.EQ.3 ) THEN CALL DGEEV( 'N', 'N', 3, DWORK, 3, EVR, EVI, DWORK(WRKPOS), $ 1, DWORK(WRKPOS), 1, DWORK(M2POS), LDWORK-9, $ INFO ) IF ( I.EQ.0 ) THEN C C The roots are reciprocals of the computed eigenvalues. C J = 1 C WHILE J.LE.3-INFO 10 CONTINUE IF ( J.LE.3 - INFO ) THEN IF ( EVI(J).EQ.ZERO ) THEN EVR(J) = ONE/EVR(J) J = J + 1 GO TO 10 ELSE IF ( EVI(J).GT.ZERO ) THEN CALL DLADIV( ONE, ZERO, EVR(J), EVI(J), EVR(J+1), $ EVI(J+1) ) EVR(J) = EVR(J+1) EVI(J) = -EVI(J+1) J = J + 2 GO TO 10 END IF END IF C END WHILE 10 END IF EVQ(1) = ONE EVQ(2) = ONE EVQ(3) = ONE ELSE CALL DGGEV( 'N', 'N', 3, DWORK, 3, DWORK(M2POS), 3, EVR, $ EVI, EVQ, DWORK(WRKPOS), 1, DWORK(WRKPOS), 1, $ DWORK(WRKPOS), LDWORK-18, INFO ) END IF C ELSE C C Small variation in the coefficients of the polynomial. C Generate the matrices M1 and M2 stored in DWORK. C IF ( I.EQ.0 ) THEN C C Elements of matrix M1. C DWORK(1) = ALPHA DWORK(5) = ALPHA DWORK(9) = ALPHA C C Elements of matrix M2. C DWORK(10) = -BETA DWORK(11) = ALPHA DWORK(13) = -GAMMA DWORK(15) = ALPHA DWORK(16) = -DELTA C ELSE IF ( I.EQ.1 ) THEN C C Elements of matrix M1. C DWORK(1) = -ALPHA DWORK(4) = -GAMMA DWORK(5) = BETA DWORK(7) = -DELTA DWORK(9) = BETA C C Elements of matrix M2. C DWORK(10) = BETA DWORK(11) = -ALPHA DWORK(14) = -GAMMA DWORK(15) = BETA DWORK(17) = -DELTA C ELSE IF ( I.EQ.2 ) THEN C C Elements of matrix M1. C DWORK(2) = -ALPHA DWORK(4) = GAMMA DWORK(5) = -BETA DWORK(8) = -DELTA DWORK(9) = GAMMA C C Elements of matrix M2. C DWORK(10) = GAMMA DWORK(12) = -ALPHA DWORK(14) = GAMMA DWORK(15) = -BETA DWORK(18) = -DELTA C ELSE C C Elements of matrix M1. C DWORK(3) = -ALPHA DWORK(4) = DELTA DWORK(6) = -BETA DWORK(8) = DELTA DWORK(9) = -GAMMA C C Elements of matrix M2. C DWORK(10) = DELTA DWORK(14) = DELTA DWORK(18) = DELTA END IF C C Compute the roots of the polynomial by solving an eigenproblem C using the QZ-Algorithm. C CALL DGGEV( 'N', 'N', 3, DWORK, 3, DWORK(M2POS), 3, EVR, EVI, $ EVQ, DWORK(WRKPOS), 1, DWORK(WRKPOS), 1, $ DWORK(WRKPOS), LDWORK-18, INFO ) END IF C RETURN C *** Last line of MC01XD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01PD.f0000644000000000000000000000013215012430707016174 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01PD.f0000644000175000017500000004616415012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE TG01PD( DICO, STDOM, JOBAE, COMPQ, COMPZ, N, M, P, $ NLOW, NSUP, ALPHA, A, LDA, E, LDE, B, LDB, $ C, LDC, Q, LDQ, Z, LDZ, NDIM, ALPHAR, ALPHAI, $ BETA, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute orthogonal transformation matrices Q and Z which C reduce the regular pole pencil A-lambda*E of the descriptor system C (A-lambda*E,B,C) to the generalized real Schur form with ordered C generalized eigenvalues. The pair (A,E) is reduced to the form C C ( * * * * ) ( * * * * ) C ( ) ( ) C ( 0 A1 * * ) ( 0 E1 * * ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) , C ( 0 0 A2 * ) ( 0 0 E2 * ) C ( ) ( ) C ( 0 0 0 * ) ( 0 0 0 * ) C C where the subpencil A1-lambda*E1 contains the eigenvalues which C belong to a suitably defined domain of interest and the subpencil C A2-lambda*E2 contains the eigenvalues which are outside of the C domain of interest. C If JOBAE = 'S', the pair (A,E) is assumed to be already in a C generalized real Schur form and the reduction is performed only C on the subpencil A12 - lambda*E12 defined by rows and columns C NLOW to NSUP of A - lambda*E. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of the descriptor system as follows: C = 'C': continuous-time system; C = 'D': discrete-time system. 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 JOBAE CHARACTER*1 C Specifies the shape of the matrix pair (A,E) on entry C as follows: C = 'S': (A,E) is in a generalized real Schur form; C = 'G': A and E are general square dense matrices. C C COMPQ CHARACTER*1 C = 'I': Q is initialized to the unit matrix, and the C orthogonal matrix Q is returned; C = 'U': Q must contain an orthogonal matrix Q1 on entry, C and the product Q1*Q is returned. C This option can not be used when JOBAE = 'G'. C C COMPZ CHARACTER*1 C = 'I': Z is initialized to the unit matrix, and the C orthogonal matrix Z is returned; C = 'U': Z must contain an orthogonal matrix Z1 on entry, C and the product Z1*Z is returned. C This option can not be used when JOBAE = 'G'. C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix B, the number of columns C of the matrix C, and the order of the square matrices A C and E. N >= 0. C C M (input) INTEGER C The number of columns of the matrix B. M >= 0. C C P (input) INTEGER C The number of rows of the matrix C. P >= 0. C C NLOW, (input) INTEGER C NSUP (input) INTEGER C NLOW and NSUP specify the boundary indices for the rows C and columns of the principal subpencil of A - lambda*E C whose diagonal blocks are to be reordered. C 0 <= NLOW <= NSUP <= N, if JOBAE = 'S'. C NLOW = MIN( 1, N ), NSUP = N, if JOBAE = 'G'. C C ALPHA (input) DOUBLE PRECISION C The boundary of the domain of interest for the generalized C eigenvalues of the pair (A,E). For a continuous-time C system (DICO = 'C'), ALPHA is the boundary value for the C real parts of the generalized eigenvalues, while for a C discrete-time system (DICO = 'D'), ALPHA >= 0 represents C the boundary value for the moduli of the generalized 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 the state dynamics matrix A. C If JOBAE = 'S' then A must be a matrix in real Schur form. C On exit, the leading N-by-N part of this array contains C the matrix Q'*A*Z in real Schur form, with the elements C below the first subdiagonal set to zero. C The leading NDIM-by-NDIM part of the principal subpencil C A12 - lambda*E12, defined by A12 := A(NLOW:NSUP,NLOW:NSUP) C and E12 := E(NLOW:NSUP,NLOW:NSUP), has generalized C eigenvalues in the domain of interest, and the trailing C part of this subpencil has generalized eigenvalues outside C the domain of interest. C The domain of interest for eig(A12,E12), the generalized C eigenvalues of the pair (A12,E12), is defined by the C parameters ALPHA, DICO and STDOM as follows: C For DICO = 'C': C Real(eig(A12,E12)) < ALPHA if STDOM = 'S'; C Real(eig(A12,E12)) > ALPHA if STDOM = 'U'. C For DICO = 'D': C Abs(eig(A12,E12)) < ALPHA if STDOM = 'S'; C Abs(eig(A12,E12)) > ALPHA if STDOM = 'U'. 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, the leading N-by-N part of this array must C contain the descriptor matrix E. C If JOBAE = 'S', then E must be an upper triangular matrix. C On exit, the leading N-by-N part of this array contains an C upper triangular matrix Q'*E*Z, with the elements below C the diagonal set to zero. C The leading NDIM-by-NDIM part of the principal subpencil C A12 - lambda*E12 (see description of A) has generalized C eigenvalues in the domain of interest, and the trailing C part of this subpencil has generalized eigenvalues outside C the domain of interest. C C LDE INTEGER C The leading dimension of the array E. LDE >= 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 matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix Q'*B. C C LDB INTEGER C The leading dimension of the 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 output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed output matrix C*Z. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C If COMPQ = 'I': on entry, Q need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Q, C where Q' is the product of orthogonal C transformations which are applied to A, C E, and B on the left. C If COMPQ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix C Q1; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Q1*Q. 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 If COMPZ = 'I': on entry, Z need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Z, C which is the product of orthogonal C transformations applied to A, E, and C C on the right. C If COMPZ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix C Z1; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Z1*Z. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1,N). C C NDIM (output) INTEGER C The number of generalized eigenvalues of the principal C subpencil A12 - lambda*E12 (see description of A) lying C inside the domain of interest for eigenvalues. 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 On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, C are the generalized eigenvalues. C ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j = 1,...,N, are the C diagonals of the complex Schur form (S,T) that would C result if the 2-by-2 diagonal blocks of the real Schur C form of (A,B) were further reduced to triangular form C using 2-by-2 complex unitary transformations. C If ALPHAI(j) is zero, then the j-th eigenvalue is real; C if positive, then the j-th and (j+1)-st eigenvalues are a C complex conjugate pair, with ALPHAI(j+1) negative. 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 length of the array DWORK. C LDWORK >= 8*N+16, if JOBAE = 'G'; C LDWORK >= 4*N+16, if JOBAE = 'S'. C For optimum performance LDWORK should be larger. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 = 1: the QZ algorithm failed to compute all generalized C eigenvalues of the pair (A,E); C = 2: a failure occured during the ordering of the C generalized real Schur form of the pair (A,E). C C METHOD C C If JOBAE = 'G', the pair (A,E) is reduced to an ordered C generalized real Schur form using an orthogonal equivalence C transformation A <-- Q'*A*Z and E <-- Q'*E*Z. This transformation C is determined so that the leading diagonal blocks of the resulting C pair (A,E) have generalized eigenvalues in a suitably defined C domain of interest. Then, the transformations are applied to the C matrices B and C: B <-- Q'*B and C <-- C*Z. C If JOBAE = 'S', then the diagonal blocks of the subpencil C A12 - lambda*E12, defined by A12 := A(NLOW:NSUP,NLOW:NSUP) C and E12 := E(NLOW:NSUP,NLOW:NSUP), are reordered using orthogonal C equivalence transformations, such that the leading blocks have C generalized eigenvalues in a suitably defined domain of interest. C C NUMERICAL ASPECTS C 3 C The algorithm requires about 25N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, October 2002. C Based on the RASP routine SRSFOD. C C REVISIONS C C V. Sima, Dec. 2016. C C KEYWORDS C C Deflating subspace, orthogonal transformation, C generalized real Schur form, equivalence transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER COMPQ, COMPZ, DICO, JOBAE, STDOM INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, M, N, $ NDIM, NLOW, NSUP, P DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), $ BETA(*), C(LDC,*), DWORK(*), E(LDE,*), $ Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. LOGICAL DISCR, LJOBG, LQUERY INTEGER I, ICOMPQ, ICOMPZ, LW, MINWRK, NB, NBC, NC, NR, $ SDIM, WRKOPT C .. Local Arrays .. LOGICAL BWORK(1) C .. External Functions .. LOGICAL DELCTG, LSAME EXTERNAL DELCTG, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEQRF, DGGES, DLACPY, DLASET, $ MB03QG, MB03QV, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C C .. Executable Statements .. C C Decode COMPQ. C IF( LSAME( COMPQ, 'I' ) ) THEN ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'U' ) ) THEN ICOMPQ = 2 ELSE ICOMPQ = 0 END IF C C Decode COMPZ. C IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'U' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = 0 END IF C INFO = 0 DISCR = LSAME( DICO, 'D' ) LJOBG = LSAME( JOBAE, 'G' ) C C Check input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR. $ LSAME( STDOM, 'U' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( LSAME( JOBAE, 'S' ) .OR. LJOBG ) ) THEN INFO = -3 ELSE IF( ICOMPQ.LE.0 .OR. ( LJOBG .AND. ICOMPQ.EQ.2 ) ) THEN INFO = -4 ELSE IF( ICOMPZ.LE.0 .OR. ( LJOBG .AND. ICOMPZ.EQ.2 ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( P.LT.0 ) THEN INFO = -8 ELSE IF( ( LJOBG .AND. NLOW.NE.MIN( 1, N ) ) .OR. $ ( .NOT.LJOBG .AND. NLOW.LT.0 ) ) THEN INFO = -9 ELSE IF( ( LJOBG .AND. NSUP.NE.N ) .OR. ( .NOT.LJOBG .AND. $ ( NSUP.LT.NLOW .OR. N.LT.NSUP ) ) ) THEN INFO = -10 ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN INFO = -11 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -19 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -21 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -23 ELSE IF( N.EQ.0 ) THEN MINWRK = 1 ELSE IF( LJOBG ) THEN MINWRK = 8*N + 16 ELSE MINWRK = 4*N + 16 END IF LQUERY = LDWORK.EQ.-1 C C Estimate the optimal block size. C CALL DGEQRF( N, MAX( M, P ), A, LDA, DWORK, DWORK, -1, INFO ) NB = INT( DWORK(1) )/MAX( 1, M, P ) LW = MIN( NB*NB, N*MAX( M, P ) ) C IF( LQUERY ) THEN WRKOPT = MINWRK IF( LJOBG ) THEN CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, $ N, A, LDA, E, LDE, SDIM, ALPHAR, ALPHAI, $ BETA, Q, LDQ, Z, LDZ, DWORK, -1, BWORK, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF CALL MB03QG( DICO, STDOM, 'Update', 'Update', N, NLOW, NSUP, $ ALPHA, A, LDA, E, LDE, Q, LDQ, Z, LDZ, NDIM, $ DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LW, INT( DWORK(1) ) ) ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -29 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01PD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C NDIM = 0 IF( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C IF( LJOBG ) THEN C C Reduce (A,E) to real generalized Schur form using an orthogonal C equivalence transformation (A,E) <- (Q'*A*Z,Q'*E*Z), accumulate C the transformations in Q and Z, and compute the generalized C eigenvalues of the pair (A,E) in (ALPHAR, ALPHAI, BETA). C C Workspace: need 8*N+16; C prefer larger. C CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N, $ A, LDA, E, LDE, SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, $ Z, LDZ, DWORK, LDWORK, BWORK, INFO ) IF( INFO.NE.0 ) THEN INFO = 1 RETURN END IF WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) ELSE C C Initialize Q and Z if necessary. C IF( ICOMPQ.EQ.1 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.1 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) WRKOPT = MINWRK END IF C C Separate the spectrum of (A,E). The leading NDIM-by-NDIM subpencil C of A12-lambda*E12 corresponds to the generalized eigenvalues of C interest. C Workspace: need 4*N+16. C CALL MB03QG( DICO, STDOM, 'Update', 'Update', N, NLOW, NSUP, $ ALPHA, A, LDA, E, LDE, Q, LDQ, Z, LDZ, NDIM, DWORK, $ LDWORK, INFO ) IF( INFO.NE.0 ) THEN INFO = 2 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Compute the generalized eigenvalues. C CALL MB03QV( N, A, LDA, E, LDE, ALPHAR, ALPHAI, BETA, INFO ) C C Apply the transformation: B <-- Q'*B. C NBC = MAX( 1, MIN( LDWORK/N, M ) ) DO 10 I = 1, M, NBC NC = MIN( NBC, M-I+1 ) CALL DGEMM( 'Transpose', 'No transpose', N, NC, N, ONE, Q, LDQ, $ B(1,I), LDB, ZERO, DWORK, N ) CALL DLACPY( 'All', N, NC, DWORK, N, B(1,I), LDB ) 10 CONTINUE C C Apply the transformation: C <-- C*Z. C NBC = MAX( 1, MIN( LDWORK/N, P ) ) DO 20 I = 1, P, NBC NR = MIN( NBC, P-I+1 ) CALL DGEMM( 'No Transpose', 'No transpose', NR, N, N, ONE, $ C(I,1), LDC, Z, LDZ, ZERO, DWORK, NR ) CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC ) 20 CONTINUE C DWORK( 1 ) = MAX( WRKOPT, LW ) C RETURN C *** Last line of TG01PD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB16AD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB16AD.f0000644000175000017500000006722015012430707017360 0ustar00lilgelilge00000000000000 SUBROUTINE SB16AD( DICO, JOBC, JOBO, JOBMR, WEIGHT, EQUIL, ORDSEL, $ N, M, P, NC, NCR, ALPHA, A, LDA, B, LDB, $ C, LDC, D, LDD, AC, LDAC, BC, LDBC, CC, LDCC, $ DC, LDDC, NCS, HSVC, TOL1, TOL2, IWORK, DWORK, $ LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order controller (Acr,Bcr,Ccr,Dcr) for an C original state-space controller representation (Ac,Bc,Cc,Dc) by C using the frequency-weighted square-root or balancing-free C square-root Balance & Truncate (B&T) or Singular Perturbation C Approximation (SPA) model reduction methods. The algorithm tries C to minimize the norm of the frequency-weighted error C C ||V*(K-Kr)*W|| C C where K and Kr are the transfer-function matrices of the original C and reduced order controllers, respectively. V and W are special C frequency-weighting transfer-function matrices constructed C to enforce closed-loop stability and/or closed-loop performance. C If G is the transfer-function matrix of the open-loop system, then C the following weightings V and W can be used: C -1 C (a) V = (I-G*K) *G, W = I - to enforce closed-loop stability; C -1 C (b) V = I, W = (I-G*K) *G - to enforce closed-loop stability; C -1 -1 C (c) V = (I-G*K) *G, W = (I-G*K) - to enforce closed-loop C stability and performance. C C G has the state space representation (A,B,C,D). C If K is unstable, only the ALPHA-stable part of K is reduced. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of the original controller as follows: C = 'C': continuous-time controller; C = 'D': discrete-time controller. C C JOBC CHARACTER*1 C Specifies the choice of frequency-weighted controllability C Grammian as follows: C = 'S': choice corresponding to standard Enns' method [1]; C = 'E': choice corresponding to the stability enhanced C modified Enns' method of [2]. C C JOBO CHARACTER*1 C Specifies the choice of frequency-weighted observability C Grammian as follows: C = 'S': choice corresponding to standard Enns' method [1]; C = 'E': choice corresponding to the stability enhanced C modified combination method of [2]. C C JOBMR CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root B&T method; C = 'F': use the balancing-free square-root B&T method; C = 'S': use the square-root SPA method; C = 'P': use the balancing-free square-root SPA method. C C WEIGHT CHARACTER*1 C Specifies the type of frequency-weighting, as follows: C = 'N': no weightings are used (V = I, W = I); C = 'O': stability enforcing left (output) weighting C -1 C V = (I-G*K) *G is used (W = I); C = 'I': stability enforcing right (input) weighting C -1 C W = (I-G*K) *G is used (V = I); C = 'P': stability and performance enforcing weightings C -1 -1 C V = (I-G*K) *G , W = (I-G*K) are used. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplets (A,B,C) and (Ac,Bc,Cc) as C follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NCR is fixed; C = 'A': the resulting order NCR is automatically C determined on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the open-loop system state-space C representation, i.e., the order of the 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 NC (input) INTEGER C The order of the controller state-space representation, C i.e., the order of the matrix AC. NC >= 0. C C NCR (input/output) INTEGER C On entry with ORDSEL = 'F', NCR is the desired order of C the resulting reduced order controller. 0 <= NCR <= NC. C On exit, if INFO = 0, NCR is the order of the resulting C reduced order controller. For a controller with NCU C ALPHA-unstable eigenvalues and NCS ALPHA-stable C eigenvalues (NCU+NCS = NC), NCR is set as follows: C if ORDSEL = 'F', NCR is equal to C NCU+MIN(MAX(0,NCR-NCU),NCMIN), where NCR is the desired C order on entry, NCMIN is the number of frequency-weighted C Hankel singular values greater than NCS*EPS*S1, EPS is the C machine precision (see LAPACK Library Routine DLAMCH) and C S1 is the largest Hankel singular value (computed in C HSVC(1)); NCR can be further reduced to ensure C HSVC(NCR-NCU) > HSVC(NCR+1-NCU); C if ORDSEL = 'A', NCR is the sum of NCU and the number of C Hankel singular values greater than MAX(TOL1,NCS*EPS*S1). C C ALPHA (input) DOUBLE PRECISION C Specifies the ALPHA-stability boundary for the eigenvalues C of the state dynamics matrix AC. For a continuous-time C controller (DICO = 'C'), ALPHA <= 0 is the boundary value C for the real parts of eigenvalues; for a discrete-time C controller (DICO = 'D'), 0 <= ALPHA <= 1 represents the C boundary value for the moduli of eigenvalues. C The ALPHA-stability domain does not include the boundary. 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 of the open-loop C system. C On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-N C part of this array contains the scaled state dynamics C matrix of the open-loop system. C If EQUIL = 'N', this array is unchanged on exit. 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 B of the open-loop system. C On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-M C part of this array contains the scaled input/state matrix C of the open-loop system. C If EQUIL = 'N', this array is unchanged on exit. 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 C of the open-loop system. C On exit, if INFO = 0 and EQUIL = 'S', the leading P-by-N C part of this array contains the scaled state/output matrix C of the open-loop system. C If EQUIL = 'N', this array is unchanged on exit. 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 input/output matrix D of the open-loop system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C AC (input/output) DOUBLE PRECISION array, dimension (LDAC,NC) C On entry, the leading NC-by-NC part of this array must C contain the state dynamics matrix Ac of the original C controller. C On exit, if INFO = 0, the leading NCR-by-NCR part of this C array contains the state dynamics matrix Acr of the C reduced controller. The resulting Ac has a C block-diagonal form with two blocks. C For a system with NCU ALPHA-unstable eigenvalues and C NCS ALPHA-stable eigenvalues (NCU+NCS = NC), the leading C NCU-by-NCU block contains the unreduced part of Ac C corresponding to the ALPHA-unstable eigenvalues. C The trailing (NCR+NCS-NC)-by-(NCR+NCS-NC) block contains C the reduced part of Ac corresponding to ALPHA-stable C eigenvalues. C C LDAC INTEGER C The leading dimension of array AC. LDAC >= MAX(1,NC). C C BC (input/output) DOUBLE PRECISION array, dimension (LDBC,P) C On entry, the leading NC-by-P part of this array must C contain the input/state matrix Bc of the original C controller. C On exit, if INFO = 0, the leading NCR-by-P part of this C array contains the input/state matrix Bcr of the reduced C controller. C C LDBC INTEGER C The leading dimension of array BC. LDBC >= MAX(1,NC). C C CC (input/output) DOUBLE PRECISION array, dimension (LDCC,NC) C On entry, the leading M-by-NC part of this array must C contain the state/output matrix Cc of the original C controller. C On exit, if INFO = 0, the leading M-by-NCR part of this C array contains the state/output matrix Ccr of the reduced C controller. C C LDCC INTEGER C The leading dimension of array CC. LDCC >= MAX(1,M). C C DC (input/output) DOUBLE PRECISION array, dimension (LDDC,P) C On entry, the leading M-by-P part of this array must C contain the input/output matrix Dc of the original C controller. C On exit, if INFO = 0, the leading M-by-P part of this C array contains the input/output matrix Dcr of the reduced C controller. C C LDDC INTEGER C The leading dimension of array DC. LDDC >= MAX(1,M). C C NCS (output) INTEGER C The dimension of the ALPHA-stable part of the controller. C C HSVC (output) DOUBLE PRECISION array, dimension (NC) C If INFO = 0, the leading NCS elements of this array C contain the frequency-weighted Hankel singular values, C ordered decreasingly, of the ALPHA-stable part of the C controller. C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of the reduced controller. C For model reduction, the recommended value is C TOL1 = c*S1, where c is a constant in the C interval [0.00001,0.001], and S1 is the largest C frequency-weighted Hankel singular value of the C ALPHA-stable part of the original controller C (computed in HSVC(1)). C If TOL1 <= 0 on entry, the used default value is C TOL1 = NCS*EPS*S1, where NCS is the number of C ALPHA-stable eigenvalues of Ac and EPS is the machine C precision (see LAPACK Library Routine DLAMCH). C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the ALPHA-stable part of the given C controller. The recommended value is TOL2 = NCS*EPS*S1. C This value is used by default if TOL2 <= 0 on entry. C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension (MAX(1,LIWRK1,LIWRK2)) C LIWRK1 = 0, if JOBMR = 'B'; C LIWRK1 = NC, if JOBMR = 'F'; C LIWRK1 = 2*NC, if JOBMR = 'S' or 'P'; C LIWRK2 = 0, if WEIGHT = 'N'; C LIWRK2 = 2*(M+P), if WEIGHT = 'O', 'I', or 'P'. C On exit, if INFO = 0, IWORK(1) contains NCMIN, the order C of the computed minimal realization of the stable part of C the controller. 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 >= 2*NC*NC + MAX( 1, LFREQ, LSQRED ), C where C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4)) C if WEIGHT = 'I' or 'O' or 'P'; C LFREQ = NC*(MAX(M,P)+5) if WEIGHT = 'N' and EQUIL = 'N'; C LFREQ = MAX(N,NC*(MAX(M,P)+5)) if WEIGHT = 'N' and C EQUIL = 'S'; C LSQRED = MAX( 1, 2*NC*NC+5*NC ); C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NCR is greater C than NSMIN, the sum of the order of the C ALPHA-unstable part and the order of a minimal C realization of the ALPHA-stable part of the given C controller; in this case, the resulting NCR is set C equal to NSMIN; C = 2: with ORDSEL = 'F', the selected order NCR C corresponds to repeated singular values for the C ALPHA-stable part of the controller, which are C neither all included nor all excluded from the C reduced model; in this case, the resulting NCR is C automatically decreased to exclude all repeated C singular values; C = 3: with ORDSEL = 'F', the selected order NCR is less C than the order of the ALPHA-unstable part of the C given controller. In this case NCR is set equal to C the order of the ALPHA-unstable part. 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 closed-loop system is not well-posed; C its feedthrough matrix is (numerically) singular; C = 2: the computation of the real Schur form of the C closed-loop state matrix failed; C = 3: the closed-loop state matrix is not stable; C = 4: the solution of a symmetric eigenproblem failed; C = 5: the computation of the ordered real Schur form of Ac C failed; C = 6: the separation of the ALPHA-stable/unstable C diagonal blocks failed because of very close C eigenvalues; C = 7: the computation of Hankel singular values failed. C C METHOD C C Let K be the transfer-function matrix of the original linear C controller C C d[xc(t)] = Ac*xc(t) + Bc*y(t) C u(t) = Cc*xc(t) + Dc*y(t), (1) C C where d[xc(t)] is dxc(t)/dt for a continuous-time system and C xc(t+1) for a discrete-time system. The subroutine SB16AD C determines the matrices of a reduced order controller C C d[z(t)] = Acr*z(t) + Bcr*y(t) C u(t) = Ccr*z(t) + Dcr*y(t), (2) C C such that the corresponding transfer-function matrix Kr minimizes C the norm of the frequency-weighted error C C V*(K-Kr)*W, (3) C C where V and W are special stable transfer-function matrices C chosen to enforce stability and/or performance of the closed-loop C system [3] (see description of the parameter WEIGHT). C C The following procedure is used to reduce K in conjunction C with the frequency-weighted balancing approach of [2] C (see also [3]): C C 1) Decompose additively K, of order NC, as C C K = K1 + K2, C C such that K1 has only ALPHA-stable poles and K2, of order NCU, C has only ALPHA-unstable poles. C C 2) Compute for K1 a B&T or SPA frequency-weighted approximation C K1r of order NCR-NCU using the frequency-weighted balancing C approach of [1] in conjunction with accuracy enhancing C techniques specified by the parameter JOBMR. C C 3) Assemble the reduced model Kr as C C Kr = K1r + K2. C C For the reduction of the ALPHA-stable part, several accuracy C enhancing techniques can be employed (see [2] for details). C C If JOBMR = 'B', the square-root B&T method of [1] is used. C C If JOBMR = 'F', the balancing-free square-root version of the C B&T method [1] is used. C C If JOBMR = 'S', the square-root version of the SPA method [2,3] C is used. C C If JOBMR = 'P', the balancing-free square-root version of the C SPA method [2,3] is used. C C For each of these methods, two left and right truncation matrices C are determined using the Cholesky factors of an input C frequency-weighted controllability Grammian P and an output C frequency-weighted observability Grammian Q. C P and Q are determined as the leading NC-by-NC diagonal blocks C of the controllability Grammian of K*W and of the C observability Grammian of V*K. Special techniques developed in [2] C are used to compute the Cholesky factors of P and Q directly C (see also SLICOT Library routine SB16AY). C The frequency-weighted Hankel singular values HSVC(1), ...., C HSVC(NC) are computed as the square roots of the eigenvalues C of the product P*Q. C C REFERENCES C C [1] Enns, D. C Model reduction with balanced realizations: An error bound C and a frequency weighted generalization. C Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. C C [2] Varga, A. and Anderson, B.D.O. C Square-root balancing-free methods for frequency-weighted C balancing related model reduction. C (report in preparation) C C [3] Anderson, B.D.O and Liu, Y. C Controller reduction: concepts and approaches. C IEEE Trans. Autom. Control, Vol. 34, pp. 802-812, 1989. C C NUMERICAL ASPECTS C C The implemented methods rely on accuracy enhancing square-root C techniques. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, Sept. 2000. C D. Sima, University of Bucharest, Sept. 2000. C V. Sima, Research Institute for Informatics, Bucharest, Sept.2000. C C REVISIONS C C A. Varga, Australian National University, Canberra, November 2000. C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, C Sep. 2001. C C KEYWORDS C C Controller reduction, frequency weighting, multivariable system, C state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION C100, ONE, ZERO PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, JOBC, JOBO, JOBMR, ORDSEL, WEIGHT INTEGER INFO, IWARN, LDA, LDAC, LDB, LDBC, LDC, LDCC, $ LDD, LDDC, LDWORK, M, N, NC, NCR, NCS, P DOUBLE PRECISION ALPHA, TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*), $ C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*), $ DWORK(*), HSVC(*) C .. Local Scalars .. LOGICAL BTA, DISCR, FIXORD, FRWGHT, ISTAB, LEFTW, OSTAB, $ PERF, RIGHTW, SPA INTEGER IERR, IWARNL, KI, KR, KT, KTI, KU, KW, LW, MP, $ NCU, NCU1, NMR, NNC, NRA, WRKOPT DOUBLE PRECISION ALPWRK, MAXRED, SCALEC, SCALEO C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB09IX, SB16AY, TB01ID, TB01KD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) BTA = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'F' ) SPA = LSAME( JOBMR, 'S' ) .OR. LSAME( JOBMR, 'P' ) FIXORD = LSAME( ORDSEL, 'F' ) ISTAB = LSAME( WEIGHT, 'I' ) OSTAB = LSAME( WEIGHT, 'O' ) PERF = LSAME( WEIGHT, 'P' ) LEFTW = OSTAB .OR. PERF RIGHTW = ISTAB .OR. PERF FRWGHT = LEFTW .OR. RIGHTW C LW = 1 NNC = N + NC MP = M + P IF( FRWGHT ) THEN LW = NNC*( NNC + 2*MP ) + $ MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) ) ELSE LW = NC*( MAX( M, P ) + 5 ) IF ( LSAME( EQUIL, 'S' ) ) $ LW = MAX( N, LW ) END IF LW = 2*NC*NC + MAX( 1, LW, NC*( 2*NC + 5 ) ) C C Check the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) $ THEN INFO = -2 ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) $ THEN INFO = -3 ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN INFO = -4 ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN INFO = -5 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -6 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -7 ELSE IF( N.LT.0 ) THEN INFO = -8 ELSE IF( M.LT.0 ) THEN INFO = -9 ELSE IF( P.LT.0 ) THEN INFO = -10 ELSE IF( NC.LT.0 ) THEN INFO = -11 ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.NC ) ) THEN INFO = -12 ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN INFO = -13 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -19 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -21 ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN INFO = -23 ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN INFO = -25 ELSE IF( LDCC.LT.MAX( 1, M ) ) THEN INFO = -27 ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN INFO = -29 ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN INFO = -33 ELSE IF( LDWORK.LT.LW ) THEN INFO = -36 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB16AD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( NC, M, P ).EQ.0 ) THEN NCR = 0 NCS = 0 IWORK(1) = 0 DWORK(1) = ONE RETURN END IF C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C and AC, BC and CC; C A <- inv(T1)*A*T1, B <- inv(T1)*B and C <- C*T1, where T1 is a C diagonal matrix; C AC <- inv(T2)*AC*T2, BC <- inv(T2)*BC and CC <- CC*T2, where T2 C is a diagonal matrix. C C Real workspace: need MAX(N,NC). C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) MAXRED = C100 CALL TB01ID( 'All', NC, P, M, MAXRED, AC, LDAC, BC, LDBC, $ CC, LDCC, DWORK, INFO ) END IF C C Correct the value of ALPHA to ensure stability. C ALPWRK = ALPHA IF( DISCR ) THEN IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) ELSE IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) END IF C C Reduce Ac to a block-diagonal real Schur form, with the C ALPHA-unstable part in the leading diagonal position, using a C non-orthogonal similarity transformation, AC <- inv(T)*AC*T, and C apply the transformation to BC and CC: C BC <- inv(T)*BC and CC <- CC*T. C C Workspace: need NC*(NC+5); C prefer larger. C WRKOPT = 1 KU = 1 KR = KU + NC*NC KI = KR + NC KW = KI + NC C CALL TB01KD( DICO, 'Unstable', 'General', NC, P, M, ALPWRK, $ AC, LDAC, BC, LDBC, CC, LDCC, NCU, DWORK(KU), NC, $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) C IF( IERR.NE.0 ) THEN IF( IERR.NE.3 ) THEN INFO = 5 ELSE INFO = 6 END IF RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C IWARNL = 0 NCS = NC - NCU IF( FIXORD ) THEN NRA = MAX( 0, NCR-NCU ) IF( NCR.LT.NCU ) $ IWARNL = 3 ELSE NRA = 0 END IF C C Finish if only unstable part is present. C IF( NCS.EQ.0 ) THEN NCR = NCU IWORK(1) = 0 DWORK(1) = WRKOPT RETURN END IF C C Allocate working storage. C KT = 1 KTI = KT + NC*NC KW = KTI + NC*NC C C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R C of the frequency-weighted controllability and observability C Grammians, respectively. C C Real workspace: need 2*NC*NC + MAX( 1, LFREQ ), C where C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), C (M+P)*(M+P+4)) C if WEIGHT = 'I' or 'O' or 'P'; C LFREQ = NCS*(MAX(M,P)+5) if WEIGHT = 'N'; C prefer larger. C Integer workspace: 2*(M+P) if WEIGHT = 'I' or 'O' or 'P'; C 0, if WEIGHT = 'N'. C CALL SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS, $ A, LDA, B, LDB, C, LDC, D, LDD, $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, $ SCALEC, SCALEO, DWORK(KTI), NC, DWORK(KT), NC, $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) IF( INFO.NE.0 ) $ RETURN WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Compute a BTA or SPA of the stable part. C Real workspace: need 2*NC*NC + MAX( 1, 2*NC*NC+5*NC, C NC*MAX(M,P) ); C prefer larger. C Integer workspace: 0, if JOBMR = 'B'; C NC, if JOBMR = 'F'; C 2*NC, if JOBMR = 'S' or 'P'. C NCU1 = NCU + 1 CALL AB09IX( DICO, JOBMR, 'Schur', ORDSEL, NCS, P, M, NRA, SCALEC, $ SCALEO, AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC, $ CC(1,NCU1), LDCC, DC, LDDC, DWORK(KTI), NC, $ DWORK(KT), NC, NMR, HSVC, TOL1, TOL2, IWORK, $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) IWARN = MAX( IWARN, IWARNL ) IF( IERR.NE.0 ) THEN INFO = 7 RETURN END IF NCR = NRA + NCU IWORK(1) = NMR C DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C RETURN C *** Last line of SB16AD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB13AD.f0000644000000000000000000000013215012430707016130 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB13AD.f0000644000175000017500000002662415012430707017336 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION AB13AD( DICO, EQUIL, N, M, P, ALPHA, A, $ LDA, B, LDB, C, LDC, NS, HSV, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the Hankel-norm of the ALPHA-stable projection of the C transfer-function matrix G of the state-space system (A,B,C). C C FUNCTION VALUE C C AB13AD DOUBLE PRECISION C The Hankel-norm of the ALPHA-stable projection of G C (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 EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C Input/Output Parameters C C N (input) INTEGER C The order of the state-space representation, i.e. the C order of the 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 ALPHA (input) DOUBLE PRECISION C Specifies the ALPHA-stability boundary for the eigenvalues C of the state dynamics matrix A. For a continuous-time C system (DICO = 'C'), ALPHA <= 0 is the boundary value for C the real parts of eigenvalues, while for a discrete-time C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the C boundary value for the moduli of eigenvalues. C The ALPHA-stability domain does not include the boundary C (see the Note below). 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, if INFO = 0, the leading N-by-N part of this C array contains the state dynamics matrix A in a block C diagonal real Schur form with its eigenvalues reordered C and separated. The resulting A has two diagonal blocks. C The leading NS-by-NS part of A has eigenvalues in the C ALPHA-stability domain and the trailing (N-NS) x (N-NS) C part has eigenvalues outside the ALPHA-stability domain. C Note: The ALPHA-stability domain is defined either C as the open half complex plane left to ALPHA, C for a continous-time system (DICO = 'C'), or the C interior of the ALPHA-radius circle centered in the C origin, for a discrete-time system (DICO = 'D'). 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 original input/state matrix B. C On exit, if INFO = 0, the leading N-by-M part of this C array contains the input/state matrix B of the transformed C system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-N part of this C array contains the state/output matrix C of the C transformed system. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C NS (output) INTEGER C The dimension of the ALPHA-stable subsystem. C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, the leading NS elements of HSV contain the C Hankel singular values of the ALPHA-stable part of the C original system ordered decreasingly. C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. 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 length of the array DWORK. C LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2). 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: the computation of the ordered real Schur form of A C failed; C = 2: the separation of the ALPHA-stable/unstable diagonal C blocks failed because of very close eigenvalues; C = 3: the computed ALPHA-stable part is just stable, C having stable eigenvalues very near to the imaginary C axis (if DICO = 'C') or to the unit circle C (if DICO = 'D'); C = 4: the computation of Hankel singular values failed. C C METHOD C C Let be the following linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system, and let G be the corresponding C transfer-function matrix. The following procedure is used to C compute the Hankel-norm of the ALPHA-stable projection of G: C C 1) Decompose additively G as C C G = G1 + G2 C C such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. C For the computation of the additive decomposition, the C algorithm presented in [1] is used. C C 2) Compute the Hankel-norm of ALPHA-stable projection G1 as the C the maximum Hankel singular value of the system (As,Bs,Cs). C The computation of the Hankel singular values is performed C by using the square-root method of [2]. C C REFERENCES C C [1] Safonov, M.G., Jonckheere, E.A., Verma, M. and Limebeer, D.J. C Synthesis of positive real multivariable feedback systems, C Int. J. Control, Vol. 45, pp. 817-842, 1987. C C [2] Tombs, M.S. and Postlethwaite, I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C NUMERICAL ASPECTS C C The implemented method relies on a square-root technique. C 3 C The algorithms require about 17N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C July 1998. C Based on the RASP routine SHANRM. 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 C KEYWORDS C C Additive spectral decomposition, model reduction, C multivariable system, state-space model, system norms. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION C100, ONE, ZERO PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, NS, P DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) C .. Local Scalars .. LOGICAL DISCR INTEGER IERR, KT, KW, KW1, KW2 DOUBLE PRECISION ALPWRK, MAXRED, WRKOPT C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION AB13AX, DLAMCH EXTERNAL AB13AX, DLAMCH, LSAME C .. External Subroutines .. EXTERNAL TB01ID, TB01KD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 DISCR = LSAME( DICO, 'D' ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) 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( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. $ ( .NOT.DISCR .AND. ALPHA.GT.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, P ) ) THEN INFO = -12 ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + $ ( N*( N + 1 ) )/2 ) ) THEN INFO = -16 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB13AD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NS = 0 AB13AD = ZERO DWORK(1) = ONE RETURN END IF C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C Workspace: N. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Correct the value of ALPHA to ensure stability. C ALPWRK = ALPHA IF( DISCR ) THEN IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) ELSE IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) END IF C C Allocate working storage. C KT = 1 KW1 = N*N + 1 KW2 = KW1 + N KW = KW2 + N C C Reduce A to a block diagonal real Schur form, with the C ALPHA-stable part in the leading diagonal position, using a C non-orthogonal similarity transformation A <- inv(T)*A*T and C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. C C Workspace needed: N*(N+2); C Additional workspace: need 3*N; C prefer larger. C CALL TB01KD( DICO, 'Stable', 'General', N, M, P, ALPWRK, A, LDA, $ B, LDB, C, LDC, NS, DWORK(KT), N, DWORK(KW1), $ DWORK(KW2), DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.NE.3 ) THEN INFO = 1 ELSE INFO = 2 END IF RETURN END IF C WRKOPT = DWORK(KW) + DBLE( KW-1 ) C IF( NS.EQ.0 ) THEN AB13AD = ZERO ELSE C C Workspace: need N*(MAX(N,M,P)+5)+N*(N+1)/2; C prefer larger. C AB13AD = AB13AX( DICO, NS, M, P, A, LDA, B, LDB, C, LDC, HSV, $ DWORK, LDWORK, IERR ) C IF( IERR.NE.0 ) THEN INFO = IERR + 2 RETURN END IF C DWORK(1) = MAX( WRKOPT, DWORK(1) ) END IF C RETURN C *** Last line of AB13AD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09CX.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09CX.f0000644000175000017500000004520215012430707017362 0ustar00lilgelilge00000000000000 SUBROUTINE AB09CX( DICO, ORDSEL, N, M, P, NR, A, LDA, B, LDB, $ C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, $ DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable C original state-space representation (A,B,C,D) by using the optimal C Hankel-norm approximation method in conjunction with square-root C balancing. The state dynamics matrix A of the original system is C an upper quasi-triangular matrix in real Schur canonical form. 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 ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of C the resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. NR is set as follows: C if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN), C where KR is the multiplicity of the Hankel singular value C HSV(NR+1), NR is the desired order on entry, and NMIN is C the order of a minimal realization of the given system; C NMIN is determined as the number of Hankel singular values C greater than N*EPS*HNORM(A,B,C), where EPS is the machine C precision (see LAPACK Library Routine DLAMCH) and C HNORM(A,B,C) is the Hankel norm of the system (computed C in HSV(1)); C if ORDSEL = 'A', NR is equal to the number of Hankel C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). 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 in a real Schur C canonical form. C On exit, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the C reduced order system in a real Schur 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 N-by-M part of this array must C contain the original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, it contains the Hankel singular values of C the original system ordered decreasingly. HSV(1) is the C Hankel norm of the system. C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL1 = c*HNORM(A,B,C), where c is a constant in the C interval [0.00001,0.001], and HNORM(A,B,C) is the C Hankel-norm of the given system (computed in HSV(1)). C For computing a minimal realization, the recommended C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the C machine precision (see LAPACK Library Routine DLAMCH). C This value is used by default if TOL1 <= 0 on entry. C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the given system. The recommended value is C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default C if TOL2 <= 0 on entry. C If TOL2 > 0, then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = MAX(1,M), if DICO = 'C'; C LIWORK = MAX(1,N,M), if DICO = 'D'. C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of C the computed minimal realization. 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( LDW1,LDW2 ), where C LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2, C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + C MAX( 3*M+1, MIN(N,M)+P ). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than the order of a minimal realization of the C given system. In this case, the resulting NR is set C automatically to a value corresponding to the order C of a minimal realization of the system. 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 state matrix A is not stable (if DICO = 'C') C or not convergent (if DICO = 'D'); C = 2: the computation of Hankel singular values failed; C = 3: the computation of stable projection failed; C = 4: the order of computed stable projection differs C from the order of Hankel-norm approximation. C C METHOD C C Let be the stable linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09CX determines for C the given system (1), the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t) (2) C C such that C C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], C C where G and Gr are transfer-function matrices of the systems C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the C infinity-norm of G. C C The optimal Hankel-norm approximation method of [1], based on the C square-root balancing projection formulas of [2], is employed. C C REFERENCES C C [1] Glover, K. C All optimal Hankel norm approximation of linear C multivariable systems and their L-infinity error bounds. C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. C C [2] Tombs M.S. and Postlethwaite I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C NUMERICAL ASPECTS C C The implemented methods rely on an accuracy enhancing square-root C technique. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, April 1998. C Based on the RASP routine OHNAP1. C C REVISIONS C C November 11, 1998, V. Sima, Research Institute for Informatics, C Bucharest. C April 24, 2000, A. Varga, DLR Oberpfaffenhofen. C April 8, 2001, A. Varga, DLR Oberpfaffenhofen. C March 26, 2005, V. Sima, Research Institute for Informatics. C C KEYWORDS C C Balancing, Hankel-norm approximation, model reduction, C multivariable system, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, $ M, N, NR, P DOUBLE PRECISION TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), HSV(*) C .. Local Scalars LOGICAL DISCR, FIXORD INTEGER I, I1, IERR, IRANK, J, KB1, KB2, KC1, KC2T, $ KHSVP, KHSVP2, KR, KT, KTI, KU, KW, KW1, KW2, $ LDB1, LDB2, LDC1, LDC2T, NA, NDIM, NKR1, NMINR, $ NR1, NU, WRKOPT DOUBLE PRECISION ATOL, RTOL, SKP, SKP2, SRRTOL C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB04MD, AB09AX, DAXPY, DCOPY, DGELSY, DGEMM, $ DLACPY, DSWAP, MA02AD, MB01SD, TB01KD, TB01WD, $ XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) FIXORD = LSAME( ORDSEL, 'F' ) C C Check the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) 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( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) 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, P ) ) THEN INFO = -12 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -14 ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN INFO = -17 ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + $ ( N*( N + 1 ) )/2, $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN INFO = -20 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09CX', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 IWORK(1) = 0 DWORK(1) = ONE RETURN END IF C RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) SRRTOL = SQRT( RTOL ) C C Allocate working storage. C KT = 1 KTI = KT + N*N KW = KTI + N*N C C Compute a minimal order balanced realization of the given system. C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; C prefer larger. C CALL AB09AX( DICO, 'Balanced', 'Automatic', N, M, P, NMINR, A, $ LDA, B, LDB, C, LDC, HSV, DWORK(KT), N, DWORK(KTI), $ N, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) C IF( INFO.NE.0 ) $ RETURN WRKOPT = INT( DWORK(KW) ) + KW - 1 C C Compute the order of reduced system. C ATOL = RTOL*HSV(1) IF( FIXORD ) THEN IF( NR.GT.0 ) THEN IF( NR.GT.NMINR ) THEN NR = NMINR IWARN = 1 ENDIF ENDIF ELSE ATOL = MAX( TOL1, ATOL ) NR = 0 DO 10 I = 1, NMINR IF( HSV(I).LE.ATOL ) GO TO 20 NR = NR + 1 10 CONTINUE 20 CONTINUE ENDIF C IF( NR.EQ.NMINR ) THEN IWORK(1) = NMINR DWORK(1) = WRKOPT KW = N*(N+2)+1 C C Reduce Ar to a real Schur form. C CALL TB01WD( NMINR, M, P, A, LDA, B, LDB, C, LDC, $ DWORK(2*N+1), N, DWORK, DWORK(N+1), DWORK(KW), $ LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 3 RETURN END IF RETURN END IF SKP = HSV(NR+1) C C If necessary, reduce the order such that HSV(NR) > HSV(NR+1). C 30 IF( NR.GT.0 ) THEN IF( ABS( HSV(NR)-SKP ).LE.SRRTOL*SKP ) THEN NR = NR - 1 GO TO 30 END IF END IF C C Determine KR, the multiplicity of HSV(NR+1). C KR = 1 DO 40 I = NR+2, NMINR IF( ABS( HSV(I)-SKP ).GT.SRRTOL*SKP ) GO TO 50 KR = KR + 1 40 CONTINUE 50 CONTINUE C C For discrete-time case, apply the discrete-to-continuous bilinear C transformation. C IF( DISCR ) THEN C C Workspace: need N; C prefer larger. C CALL AB04MD( 'Discrete', NMINR, M, P, ONE, ONE, A, LDA, B, LDB, $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF C C Define leading dimensions and offsets for temporary data. C NU = NMINR - NR - KR NA = NR + NU LDB1 = NA LDC1 = P LDB2 = KR LDC2T = MAX( KR, M ) NR1 = NR + 1 NKR1 = MIN( NMINR, NR1 + KR ) C KHSVP = 1 KHSVP2 = KHSVP + NA KU = KHSVP2 + NA KB1 = KU + P*M KB2 = KB1 + LDB1*M KC1 = KB2 + LDB2*M KC2T = KC1 + LDC1*NA KW = KC2T + LDC2T*P C C Save B2 and C2'. C CALL DLACPY( 'Full', KR, M, B(NR1,1), LDB, DWORK(KB2), LDB2 ) CALL MA02AD( 'Full', P, KR, C(1,NR1), LDC, DWORK(KC2T), LDC2T ) IF( NR.GT.0 ) THEN C C Permute the elements of HSV and of matrices A, B, C. C CALL DCOPY( NR, HSV(1), 1, DWORK(KHSVP), 1 ) CALL DCOPY( NU, HSV(NKR1), 1, DWORK(KHSVP+NR), 1 ) CALL DLACPY( 'Full', NMINR, NU, A(1,NKR1), LDA, A(1,NR1), LDA ) CALL DLACPY( 'Full', NU, NA, A(NKR1,1), LDA, A(NR1,1), LDA ) CALL DLACPY( 'Full', NU, M, B(NKR1,1), LDB, B(NR1,1), LDB ) CALL DLACPY( 'Full', P, NU, C(1,NKR1), LDC, C(1,NR1), LDC ) C C Save B1 and C1. C CALL DLACPY( 'Full', NA, M, B, LDB, DWORK(KB1), LDB1 ) CALL DLACPY( 'Full', P, NA, C, LDC, DWORK(KC1), LDC1 ) END IF C C Compute U = C2*pinv(B2'). C Workspace: need N*(M+P+2) + 2*M*P + C max(min(KR,M)+3*M+1,2*min(KR,M)+P); C prefer N*(M+P+2) + 2*M*P + C max(min(KR,M)+2*M+(M+1)*NB,2*min(KR,M)+P*NB), C where NB is the maximum of the block sizes for C DGEQP3, DTZRZF, DTZRQF, DORMQR, and DORMRZ. C DO 55 J = 1, M IWORK(J) = 0 55 CONTINUE CALL DGELSY( KR, M, P, DWORK(KB2), LDB2, DWORK(KC2T), LDC2T, $ IWORK, RTOL, IRANK, DWORK(KW), LDWORK-KW+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) CALL MA02AD( 'Full', M, P, DWORK(KC2T), LDC2T, DWORK(KU), P ) C C Compute D <- D + HSV(NR+1)*U. C I = KU DO 60 J = 1, M CALL DAXPY( P, SKP, DWORK(I), 1, D(1,J), 1 ) I = I + P 60 CONTINUE C IF( NR.GT.0 ) THEN SKP2 = SKP*SKP C C Compute G = inv(S1*S1-skp*skp*I), where S1 is the diagonal C matrix of relevant singular values (of order NMINR - KR). C I1 = KHSVP2 DO 70 I = KHSVP, KHSVP+NA-1 DWORK(I1) = ONE / ( DWORK(I)*DWORK(I) - SKP2 ) I1 = I1 + 1 70 CONTINUE C C Compute C <- C1*S1-skp*U*B1'. C CALL MB01SD( 'Column', P, NA, C, LDC, DWORK, DWORK(KHSVP) ) CALL DGEMM( 'NoTranspose', 'Transpose', P, NA, M, -SKP, $ DWORK(KU), P, DWORK(KB1), LDB1, ONE, C, LDC ) C C Compute B <- G*(S1*B1-skp*C1'*U). C CALL MB01SD( 'Row', NA, M, B, LDB, DWORK(KHSVP), DWORK ) CALL DGEMM( 'Transpose', 'NoTranspose', NA, M, P, -SKP, $ DWORK(KC1), LDC1, DWORK(KU), P, ONE, B, LDB ) CALL MB01SD( 'Row', NA, M, B, LDB, DWORK(KHSVP2), DWORK ) C C Compute A <- -A1' - B*B1'. C DO 80 J = 2, NA CALL DSWAP( J-1, A(1,J), 1, A(J,1), LDA ) 80 CONTINUE CALL DGEMM( 'NoTranspose', 'Transpose', NA, NA, M, -ONE, B, $ LDB, DWORK(KB1), LDB1, -ONE, A, LDA ) C C Extract stable part. C Workspace: need N*N+5*N; C prefer larger. C KW1 = NA*NA + 1 KW2 = KW1 + NA KW = KW2 + NA CALL TB01KD( 'Continuous', 'Stability', 'General', NA, M, P, $ ZERO, A, LDA, B, LDB, C, LDC, NDIM, DWORK, NA, $ DWORK(KW1), DWORK(KW2), DWORK(KW), LDWORK-KW+1, $ IERR ) IF( IERR.NE.0 ) THEN INFO = 3 RETURN END IF C IF( NDIM.NE.NR ) THEN INFO = 4 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C For discrete-time case, apply the continuous-to-discrete C bilinear transformation. C IF( DISCR ) $ CALL AB04MD( 'Continuous', NR, M, P, ONE, ONE, A, LDA, B, $ LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK, $ INFO ) END IF IWORK(1) = NMINR DWORK(1) = WRKOPT C RETURN C *** Last line of AB09CX *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01MD.f0000644000000000000000000000013215012430707016151 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/IB01MD.f0000644000175000017500000015122615012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, $ LDU, Y, LDY, R, LDR, IWORK, DWORK, LDWORK, $ IWARN, INFO ) C C PURPOSE C C To construct an upper triangular factor R of the concatenated C block Hankel matrices using input-output data. The input-output C data can, optionally, be processed sequentially. C C ARGUMENTS C C Mode Parameters C C METH CHARACTER*1 C Specifies the subspace identification method to be used, C as follows: C = 'M': MOESP algorithm with past inputs and outputs; C = 'N': N4SID algorithm. C C ALG CHARACTER*1 C Specifies the algorithm for computing the triangular C factor R, as follows: C = 'C': Cholesky algorithm applied to the correlation C matrix of the input-output data; C = 'F': Fast QR algorithm; C = 'Q': QR algorithm applied to the concatenated block C Hankel matrices. C C BATCH CHARACTER*1 C Specifies whether or not sequential data processing is to C be used, and, for sequential processing, whether or not C the current data block is the first block, an intermediate C block, or the last block, as follows: C = 'F': the first block in sequential data processing; C = 'I': an intermediate block in sequential data C processing; C = 'L': the last block in sequential data processing; C = 'O': one block only (non-sequential data processing). C NOTE that when 100 cycles of sequential data processing C are completed for BATCH = 'I', a warning is C issued, to prevent for an infinite loop. C C CONCT CHARACTER*1 C Specifies whether or not the successive data blocks in C sequential data processing belong to a single experiment, C as follows: C = 'C': the current data block is a continuation of the C previous data block and/or it will be continued C by the next data block; C = 'N': there is no connection between the current data C block and the previous and/or the next ones. C This parameter is not used if BATCH = 'O'. C C Input/Output Parameters C C NOBR (input) INTEGER C The number of block rows, s, in the input and output C block Hankel matrices to be processed. NOBR > 0. C (In the MOESP theory, NOBR should be larger than n, C the estimated dimension of state vector.) C C M (input) INTEGER C The number of system inputs. M >= 0. C When M = 0, no system inputs are processed. C C L (input) INTEGER C The number of system outputs. L > 0. C C NSMP (input) INTEGER C The number of rows of matrices U and Y (number of C samples, t). (When sequential data processing is used, C NSMP is the number of samples of the current data C block.) C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential C processing; C NSMP >= 2*NOBR, for sequential processing. C The total number of samples when calling the routine with C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. C The NSMP argument may vary from a cycle to another in C sequential data processing, but NOBR, M, and L should C be kept constant. For efficiency, it is advisable to use C NSMP as large as possible. C C U (input) DOUBLE PRECISION array, dimension (LDU,M) C The leading NSMP-by-M part of this array must contain the C t-by-m input-data sequence matrix U, C U = [u_1 u_2 ... u_m]. Column j of U contains the C NSMP values of the j-th input component for consecutive C time increments. C If M = 0, this array is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= NSMP, if M > 0; C LDU >= 1, if M = 0. C C Y (input) DOUBLE PRECISION array, dimension (LDY,L) C The leading NSMP-by-L part of this array must contain the C t-by-l output-data sequence matrix Y, C Y = [y_1 y_2 ... y_l]. Column j of Y contains the C NSMP values of the j-th output component for consecutive C time increments. C C LDY INTEGER C The leading dimension of the array Y. LDY >= NSMP. C C R (output or input/output) DOUBLE PRECISION array, dimension C ( LDR,2*(M+L)*NOBR ) C On exit, if INFO = 0 and ALG = 'Q', or (ALG = 'C' or 'F', C and BATCH = 'L' or 'O'), the leading C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of C this array contains the (current) upper triangular factor C R from the QR factorization of the concatenated block C Hankel matrices. The diagonal elements of R are positive C when the Cholesky algorithm was successfully used. C On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this C array contains the current upper triangular part of the C correlation matrix in sequential data processing. C If ALG = 'F' and BATCH = 'F' or 'I', the array R is not C referenced. C On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or C 'L', the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper C triangular part of this array must contain the upper C triangular matrix R computed at the previous call of this C routine in sequential data processing. The array R need C not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'. C C LDR INTEGER C The leading dimension of the array R. C LDR >= 2*(M+L)*NOBR. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK >= MAX(3,M+L), if ALG = 'F'; C LIWORK >= 3, if ALG = 'C' or 'Q'. C On entry with BATCH = 'I' or BATCH = 'L', IWORK(1:3) C must contain the values of ICYCLE, MAXWRK, and NSMPSM C set by the previous call of this routine. C On exit with BATCH = 'F' or BATCH = 'I', IWORK(1:3) C contains the values of ICYCLE, MAXWRK, and NSMPSM to be C used by the next call of the routine. C ICYCLE counts the cycles for BATCH = 'I'. C MAXWRK stores the current optimal workspace. C NSMPSM sums up the NSMP values for BATCH <> 'O'. C The first three elements of IWORK should be preserved C during successive calls of the routine with BATCH = 'F' C or BATCH = 'I', till the final call with BATCH = 'L'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -17, DWORK(1) returns the minimum C value of LDWORK. C Let C k = 0, if CONCT = 'N' and ALG = 'C' or 'Q'; C k = 2*NOBR-1, if CONCT = 'C' and ALG = 'C' or 'Q'; C k = 2*NOBR*(M+L+1), if CONCT = 'N' and ALG = 'F'; C k = 2*NOBR*(M+L+2), if CONCT = 'C' and ALG = 'F'. C The first (M+L)*k elements of DWORK should be preserved C during successive calls of the routine with BATCH = 'F' C or 'I', till the final call with BATCH = 'L'. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH <> 'O' and C CONCT = 'C'; C LDWORK >= 1, if ALG = 'C', BATCH = 'O' or C CONCT = 'N'; C LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F', C BATCH <> 'O' and CONCT = 'C'; C LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F', C BATCH = 'F', 'I' and CONCT = 'N'; C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F', C BATCH = 'L' and CONCT = 'N', or C BATCH = 'O'; C LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O', C and LDR >= NS = NSMP - 2*NOBR + 1; C LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O', C and LDR < NS, or BATCH = 'I' or C 'L' and CONCT = 'N'; C LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I' C or 'L' and CONCT = 'C'. C The workspace used for ALG = 'Q' is C LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, C where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended C value LDRWRK = NS, assuming a large enough cache size. C For good 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 Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: the number of 100 cycles in sequential data C processing has been exhausted without signaling C that the last block of data was get; the cycle C counter was reinitialized; C = 2: a fast algorithm was requested (ALG = 'C' or 'F'), C but it failed, and the QR algorithm was then used C (non-sequential data processing). 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 fast algorithm was requested (ALG = 'C', or 'F') C in sequential data processing, but it failed. The C routine can be repeatedly called again using the C standard QR algorithm. C C METHOD C C 1) For non-sequential data processing using QR algorithm, a C t x 2(m+l)s matrix H is constructed, where C C H = [ Uf' Up' Y' ], for METH = 'M', C s+1,2s,t 1,s,t 1,2s,t C C H = [ U' Y' ], for METH = 'N', C 1,2s,t 1,2s,t C C and Up , Uf , U , and Y are block Hankel C 1,s,t s+1,2s,t 1,2s,t 1,2s,t C matrices defined in terms of the input and output data [3]. C A QR factorization is used to compress the data. C The fast QR algorithm uses a QR factorization which exploits C the block-Hankel structure. Actually, the Cholesky factor of H'*H C is computed. C C 2) For sequential data processing using QR algorithm, the QR C decomposition is done sequentially, by updating the upper C triangular factor R. This is also performed internally if the C workspace is not large enough to accommodate an entire batch. C C 3) For non-sequential or sequential data processing using C Cholesky algorithm, the correlation matrix of input-output data is C computed (sequentially, if requested), taking advantage of the C block Hankel structure [7]. Then, the Cholesky factor of the C correlation matrix is found, if possible. C C REFERENCES C C [1] Verhaegen M., and Dewilde, P. C Subspace Model Identification. Part 1: The output-error C state-space model identification class of algorithms. C Int. J. Control, 56, pp. 1187-1210, 1992. C C [2] Verhaegen M. C Subspace Model Identification. Part 3: Analysis of the C ordinary output-error state-space model identification C algorithm. C Int. J. Control, 58, pp. 555-586, 1993. C C [3] Verhaegen M. C Identification of the deterministic part of MIMO state space C models given in innovations form from input-output data. C Automatica, Vol.30, No.1, pp.61-74, 1994. C C [4] Van Overschee, P., and De Moor, B. C N4SID: Subspace Algorithms for the Identification of C Combined Deterministic-Stochastic Systems. C Automatica, Vol.30, No.1, pp. 75-93, 1994. C C [5] Peternell, K., Scherrer, W. and Deistler, M. C Statistical Analysis of Novel Subspace Identification Methods. C Signal Processing, 52, pp. 161-177, 1996. C C [6] Sima, V. C Subspace-based Algorithms for Multivariable System C Identification. C Studies in Informatics and Control, 5, pp. 335-344, 1996. C C [7] Sima, V. C Cholesky or QR Factorization for Data Compression in C Subspace-based Identification ? C Proceedings of the Second NICONET Workshop on ``Numerical C Control Software: SLICOT, a Useful Tool in Industry'', C December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999. C C NUMERICAL ASPECTS C C The implemented method is numerically stable (when QR algorithm is C used), reliable and efficient. The fast Cholesky or QR algorithms C are more efficient, but the accuracy could diminish by forming the C correlation matrix. C 2 C The QR algorithm needs 0(t(2(m+l)s) ) floating point operations. C 2 3 C The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating C point operations. C 2 3 2 C The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating C point operations. C C FURTHER COMMENTS C C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the C calculations could be rather inefficient if only minimal workspace C (see argument LDWORK) is provided. It is advisable to provide as C much workspace as possible. Almost optimal efficiency can be C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the C cache size is large enough to accommodate R, U, Y, and DWORK. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. C C REVISIONS C C Feb. 2000, Aug. 2000, Feb. 2004, Apr. 2011, June 2012, May 2020. C C KEYWORDS C C Cholesky decomposition, Hankel matrix, identification methods, C multivariable systems, QR decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) INTEGER MAXCYC PARAMETER ( MAXCYC = 100 ) C .. Scalar Arguments .. INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, NOBR, $ NSMP CHARACTER ALG, BATCH, CONCT, METH C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION DWORK(*), R(LDR, *), U(LDU, *), Y(LDY, *) C .. Local Scalars .. DOUBLE PRECISION UPD, TEMP INTEGER I, ICOL, ICYCLE, ID, IERR, II, INICYC, INIT, $ INITI, INU, INY, IREV, ISHFT2, ISHFTU, ISHFTY, $ ITAU, J, JD, JWORK, LDRWMX, LDRWRK, LLDRW, $ LMNOBR, LNOBR, MAXWRK, MINWRK, MLDRW, MMNOBR, $ MNOBR, NCYCLE, NICYCL, NOBR2, NOBR21, NOBRM1, $ NR, NS, NSF, NSL, NSLAST, NSMPSM LOGICAL CHALG, CONNEC, FIRST, FQRALG, INTERM, LAST, $ LINR, LQUERY, MOESP, N4SID, ONEBCH, QRALG C .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DGER, DLACPY, $ DLASET, DPOTRF, DSWAP, DSYRK, IB01MY, MB04OD, $ XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. C .. Executable Statements .. C C Decode the scalar input parameters. C MOESP = LSAME( METH, 'M' ) N4SID = LSAME( METH, 'N' ) FQRALG = LSAME( ALG, 'F' ) QRALG = LSAME( ALG, 'Q' ) CHALG = LSAME( ALG, 'C' ) ONEBCH = LSAME( BATCH, 'O' ) FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH INTERM = LSAME( BATCH, 'I' ) LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH IF( .NOT.ONEBCH ) THEN CONNEC = LSAME( CONCT, 'C' ) ELSE CONNEC = .FALSE. END IF C MNOBR = M*NOBR LNOBR = L*NOBR LMNOBR = LNOBR + MNOBR MMNOBR = MNOBR + MNOBR NOBRM1 = NOBR - 1 NOBR21 = NOBR + NOBRM1 NOBR2 = NOBR21 + 1 IWARN = 0 INFO = 0 IERR = 0 IF( FIRST ) THEN ICYCLE = 1 MAXWRK = 1 NSMPSM = 0 ELSE IF( .NOT.ONEBCH ) THEN ICYCLE = IWORK(1) MAXWRK = IWORK(2) NSMPSM = IWORK(3) END IF NSMPSM = NSMPSM + NSMP NR = LMNOBR + LMNOBR C C Check the scalar input parameters. C IF( .NOT.( MOESP .OR. N4SID ) ) THEN INFO = -1 ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN INFO = -2 ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN INFO = -3 ELSE IF( .NOT. ONEBCH ) THEN IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) $ INFO = -4 END IF IF( INFO.EQ.0 ) THEN IF( NOBR.LE.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( L.LE.0 ) THEN INFO = -7 ELSE IF( NSMP.LT.NOBR2 .OR. $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN INFO = -8 ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN INFO = -10 ELSE IF( LDY.LT.NSMP ) THEN INFO = -12 ELSE IF( LDR.LT.NR ) THEN INFO = -14 ELSE LQUERY = LDWORK.EQ.-1 C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe C the minimal amount of 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 NS = NSMP - NOBR21 IF ( CHALG ) THEN IF ( .NOT.ONEBCH .AND. CONNEC ) THEN MINWRK = 2*( NR - M - L ) ELSE MINWRK = 1 END IF ELSE IF ( FQRALG ) THEN IF ( .NOT.ONEBCH .AND. CONNEC ) THEN MINWRK = NR*( M + L + 3 ) ELSE IF ( FIRST .OR. INTERM ) THEN MINWRK = NR*( M + L + 1 ) ELSE MINWRK = 2*NR*( M + L + 1 ) + NR END IF IF ( LQUERY ) THEN CALL IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, $ LDU, Y, LDY, R, LDR, IWORK, DWORK, -1, $ IWARN, IERR ) MAXWRK = INT( DWORK(1) ) END IF ELSE MINWRK = 2*NR CALL DGEQRF( NS, NR, DWORK, NS, DWORK, DWORK, -1, IERR ) MAXWRK = NR + INT( DWORK(1) ) IF ( FIRST ) THEN IF ( LDR.LT.NS ) THEN MINWRK = MINWRK + NR MAXWRK = NS*NR + MAXWRK END IF ELSE IF ( CONNEC ) THEN MINWRK = MINWRK*( NOBR + 1 ) ELSE MINWRK = MINWRK + NR END IF MAXWRK = NS*NR + MAXWRK END IF END IF MAXWRK = MAX( MINWRK, MAXWRK ) C IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN INFO = -17 DWORK( 1 ) = MINWRK END IF END IF END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN IF( .NOT.ONEBCH ) THEN IWORK(1) = 1 IWORK(2) = MAXWRK IWORK(3) = 0 END IF IF ( INFO.EQ.-17 ) $ DWORK(1) = MINWRK CALL XERBLA( 'IB01MD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = MAXWRK RETURN END IF C IF ( CHALG ) THEN C C Compute the R factor from a Cholesky factorization of the C input-output data correlation matrix. C C Set the parameters for constructing the correlations of the C current block. C LDRWRK = 2*NOBR2 - 2 IF( FIRST ) THEN UPD = ZERO ELSE UPD = ONE END IF C IF( .NOT.FIRST .AND. CONNEC ) THEN C C Restore the saved (M+L)*(2*NOBR-1) "connection" elements of C U and Y into their appropriate position in sequential C processing. The process is performed column-wise, in C reverse order, first for Y and then for U. C Workspace: need (4*NOBR-2)*(M+L). C IREV = NR - M - L - NOBR21 + 1 ICOL = 2*( NR - M - L ) - LDRWRK + 1 C DO 10 J = 2, M + L DO 5 I = NOBR21 - 1, 0, -1 DWORK(ICOL+I) = DWORK(IREV+I) 5 CONTINUE IREV = IREV - NOBR21 ICOL = ICOL - LDRWRK 10 CONTINUE C IF ( M.GT.0 ) $ CALL DLACPY( 'Full', NOBR21, M, U, LDU, DWORK(NOBR2), $ LDRWRK ) CALL DLACPY( 'Full', NOBR21, L, Y, LDY, $ DWORK(LDRWRK*M+NOBR2), LDRWRK ) END IF C IF ( M.GT.0 ) THEN C C Let Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' + C ... + u_(i+NS-1)*u_(j+NS-1)', C where u_i' is the i-th row of U, j = 1 : 2s, i = 1 : j, C NS = NSMP - 2s + 1, and Guu0(i,j) is a zero matrix for C BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed C till the current block for BATCH = 'I' or 'L'. The matrix C Guu(i,j) is m-by-m, and Guu(j,j) is symmetric. The C upper triangle of the U-U correlations, Guu, is computed C (or updated) column-wise in the array R, that is, in the C order Guu(1,1), Guu(1,2), Guu(2,2), ..., Guu(2s,2s). C Only the submatrices of the first block-row are fully C computed (or updated). The remaining ones are determined C exploiting the block-Hankel structure, using the updating C formula C C Guu(i+1,j+1) = Guu0(i+1,j+1) - Guu0(i,j) + Guu(i,j) + C u_(i+NS)*u_(j+NS)' - u_i*u_j'. C IF( .NOT.FIRST ) THEN C C Subtract the contribution of the previous block of data C in sequential processing. The columns must be processed C in backward order. C DO 20 I = NOBR21*M, 1, -1 CALL DAXPY( I, -ONE, R(1,I), 1, R(M+1,M+I), 1 ) 20 CONTINUE C END IF C C Compute/update Guu(1,1). C IF( .NOT.FIRST .AND. CONNEC ) $ CALL DSYRK( 'Upper', 'Transpose', M, NOBR21, ONE, DWORK, $ LDRWRK, UPD, R, LDR ) CALL DSYRK( 'Upper', 'Transpose', M, NS, ONE, U, LDU, UPD, $ R, LDR ) C JD = 1 C IF( FIRST .OR. .NOT.CONNEC ) THEN C DO 70 J = 2, NOBR2 JD = JD + M ID = M + 1 C C Compute/update Guu(1,j). C CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE, $ U, LDU, U(J,1), LDU, UPD, R(1,JD), LDR ) C C Compute/update Guu(2:j,j), exploiting the C block-Hankel structure. C IF( FIRST ) THEN C DO 30 I = JD - M, JD - 1 CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 ) 30 CONTINUE C ELSE C DO 40 I = JD - M, JD - 1 CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 ) 40 CONTINUE C END IF C DO 50 I = 2, J - 1 CALL DGER( M, M, ONE, U(NS+I-1,1), LDU, $ U(NS+J-1,1), LDU, R(ID,JD), LDR ) CALL DGER( M, M, -ONE, U(I-1,1), LDU, U(J-1,1), $ LDU, R(ID,JD), LDR ) ID = ID + M 50 CONTINUE C DO 60 I = 1, M CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU, $ R(JD,JD+I-1), 1 ) CALL DAXPY( I, -U(J-1,I), U(J-1,1), LDU, $ R(JD,JD+I-1), 1 ) 60 CONTINUE C 70 CONTINUE C ELSE C DO 120 J = 2, NOBR2 JD = JD + M ID = M + 1 C C Compute/update Guu(1,j) for sequential processing C with connected blocks. C CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR21, $ ONE, DWORK, LDRWRK, DWORK(J), LDRWRK, UPD, $ R(1,JD), LDR ) CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE, $ U, LDU, U(J,1), LDU, ONE, R(1,JD), LDR ) C C Compute/update Guu(2:j,j) for sequential processing C with connected blocks, exploiting the block-Hankel C structure. C IF( FIRST ) THEN C DO 80 I = JD - M, JD - 1 CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 ) 80 CONTINUE C ELSE C DO 90 I = JD - M, JD - 1 CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 ) 90 CONTINUE C END IF C DO 100 I = 2, J - 1 CALL DGER( M, M, ONE, U(NS+I-1,1), LDU, $ U(NS+J-1,1), LDU, R(ID,JD), LDR ) CALL DGER( M, M, -ONE, DWORK(I-1), LDRWRK, $ DWORK(J-1), LDRWRK, R(ID,JD), LDR ) ID = ID + M 100 CONTINUE C DO 110 I = 1, M CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU, $ R(JD,JD+I-1), 1 ) CALL DAXPY( I, -DWORK((I-1)*LDRWRK+J-1), $ DWORK(J-1), LDRWRK, R(JD,JD+I-1), 1 ) 110 CONTINUE C 120 CONTINUE C END IF C IF ( LAST .AND. MOESP ) THEN C C Interchange past and future parts for MOESP algorithm. C (Only the upper triangular parts are interchanged, and C the (1,2) part is transposed in-situ.) C TEMP = R(1,1) R(1,1) = R(MNOBR+1,MNOBR+1) R(MNOBR+1,MNOBR+1) = TEMP C DO 130 J = 2, MNOBR CALL DSWAP( J, R(1,J), 1, R(MNOBR+1,MNOBR+J), 1 ) CALL DSWAP( J-1, R(1,MNOBR+J), 1, R(J,MNOBR+1), LDR ) 130 CONTINUE C END IF C C Let Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' + C ... + u_(i+NS-1)*y_(j+NS-1)', C where u_i' is the i-th row of U, y_j' is the j-th row C of Y, j = 1 : 2s, i = 1 : 2s, NS = NSMP - 2s + 1, and C Guy0(i,j) is a zero matrix for BATCH = 'O' or 'F', and it C is the matrix Guy(i,j) computed till the current block for C BATCH = 'I' or 'L'. Guy(i,j) is m-by-L. The U-Y C correlations, Guy, are computed (or updated) column-wise C in the array R. Only the submatrices of the first block- C column and block-row are fully computed (or updated). The C remaining ones are determined exploiting the block-Hankel C structure, using the updating formula C C Guy(i+1,j+1) = Guy0(i+1,j+1) - Guy0(i,j) + Guy(i,j) + C u_(i+NS)*y(j+NS)' - u_i*y_j'. C II = MMNOBR - M IF( .NOT.FIRST ) THEN C C Subtract the contribution of the previous block of data C in sequential processing. The columns must be processed C in backward order. C DO 140 I = NR - L, MMNOBR + 1, -1 CALL DAXPY( II, -ONE, R(1,I), 1, R(M+1,L+I), 1 ) 140 CONTINUE C END IF C C Compute/update the first block-column of Guy, Guy(i,1). C IF( FIRST .OR. .NOT.CONNEC ) THEN C DO 150 I = 1, NOBR2 CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, $ U(I,1), LDU, Y, LDY, UPD, $ R((I-1)*M+1,MMNOBR+1), LDR ) 150 CONTINUE C ELSE C DO 160 I = 1, NOBR2 CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21, $ ONE, DWORK(I), LDRWRK, DWORK(LDRWRK*M+1), $ LDRWRK, UPD, R((I-1)*M+1,MMNOBR+1), LDR ) CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, $ U(I,1), LDU, Y, LDY, ONE, $ R((I-1)*M+1,MMNOBR+1), LDR ) 160 CONTINUE C END IF C JD = MMNOBR + 1 C IF( FIRST .OR. .NOT.CONNEC ) THEN C DO 200 J = 2, NOBR2 JD = JD + L ID = M + 1 C C Compute/update Guy(1,j). C CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, $ U, LDU, Y(J,1), LDY, UPD, R(1,JD), LDR ) C C Compute/update Guy(2:2*s,j), exploiting the C block-Hankel structure. C IF( FIRST ) THEN C DO 170 I = JD - L, JD - 1 CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 ) 170 CONTINUE C ELSE C DO 180 I = JD - L, JD - 1 CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 ) 180 CONTINUE C END IF C DO 190 I = 2, NOBR2 CALL DGER( M, L, ONE, U(NS+I-1,1), LDU, $ Y(NS+J-1,1), LDY, R(ID,JD), LDR ) CALL DGER( M, L, -ONE, U(I-1,1), LDU, Y(J-1,1), $ LDY, R(ID,JD), LDR ) ID = ID + M 190 CONTINUE C 200 CONTINUE C ELSE C DO 240 J = 2, NOBR2 JD = JD + L ID = M + 1 C C Compute/update Guy(1,j) for sequential processing C with connected blocks. C CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21, $ ONE, DWORK, LDRWRK, DWORK(LDRWRK*M+J), $ LDRWRK, UPD, R(1,JD), LDR ) CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, $ U, LDU, Y(J,1), LDY, ONE, R(1,JD), LDR ) C C Compute/update Guy(2:2*s,j) for sequential C processing with connected blocks, exploiting the C block-Hankel structure. C IF( FIRST ) THEN C DO 210 I = JD - L, JD - 1 CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 ) 210 CONTINUE C ELSE C DO 220 I = JD - L, JD - 1 CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 ) 220 CONTINUE C END IF C DO 230 I = 2, NOBR2 CALL DGER( M, L, ONE, U(NS+I-1,1), LDU, $ Y(NS+J-1,1), LDY, R(ID,JD), LDR ) CALL DGER( M, L, -ONE, DWORK(I-1), LDRWRK, $ DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD), $ LDR ) ID = ID + M 230 CONTINUE C 240 CONTINUE C END IF C IF ( LAST .AND. MOESP ) THEN C C Interchange past and future parts of U-Y correlations C for MOESP algorithm. C DO 250 J = MMNOBR + 1, NR CALL DSWAP( MNOBR, R(1,J), 1, R(MNOBR+1,J), 1 ) 250 CONTINUE C END IF END IF C C Let Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... + C y_(i+NS-1)*y_(i+NS-1)', C where y_i' is the i-th row of Y, j = 1 : 2s, i = 1 : j, C NS = NSMP - 2s + 1, and Gyy0(i,j) is a zero matrix for C BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till C the current block for BATCH = 'I' or 'L'. Gyy(i,j) is L-by-L, C and Gyy(j,j) is symmetric. The upper triangle of the Y-Y C correlations, Gyy, is computed (or updated) column-wise in C the corresponding part of the array R, that is, in the order C Gyy(1,1), Gyy(1,2), Gyy(2,2), ..., Gyy(2s,2s). Only the C submatrices of the first block-row are fully computed (or C updated). The remaining ones are determined exploiting the C block-Hankel structure, using the updating formula C C Gyy(i+1,j+1) = Gyy0(i+1,j+1) - Gyy0(i,j) + Gyy(i,j) + C y_(i+NS)*y_(j+NS)' - y_i*y_j'. C JD = MMNOBR + 1 C IF( .NOT.FIRST ) THEN C C Subtract the contribution of the previous block of data C in sequential processing. The columns must be processed in C backward order. C DO 260 I = NR - L, MMNOBR + 1, -1 CALL DAXPY( I-MMNOBR, -ONE, R(JD,I), 1, R(JD+L,L+I), 1 ) 260 CONTINUE C END IF C C Compute/update Gyy(1,1). C IF( .NOT.FIRST .AND. CONNEC ) $ CALL DSYRK( 'Upper', 'Transpose', L, NOBR21, ONE, $ DWORK(LDRWRK*M+1), LDRWRK, UPD, R(JD,JD), LDR ) CALL DSYRK( 'Upper', 'Transpose', L, NS, ONE, Y, LDY, UPD, $ R(JD,JD), LDR ) C IF( FIRST .OR. .NOT.CONNEC ) THEN C DO 310 J = 2, NOBR2 JD = JD + L ID = MMNOBR + L + 1 C C Compute/update Gyy(1,j). C CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y, $ LDY, Y(J,1), LDY, UPD, R(MMNOBR+1,JD), LDR ) C C Compute/update Gyy(2:j,j), exploiting the block-Hankel C structure. C IF( FIRST ) THEN C DO 270 I = JD - L, JD - 1 CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1, $ R(MMNOBR+L+1,L+I), 1 ) 270 CONTINUE C ELSE C DO 280 I = JD - L, JD - 1 CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1, $ R(MMNOBR+L+1,L+I), 1 ) 280 CONTINUE C END IF C DO 290 I = 2, J - 1 CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1), $ LDY, R(ID,JD), LDR ) CALL DGER( L, L, -ONE, Y(I-1,1), LDY, Y(J-1,1), LDY, $ R(ID,JD), LDR ) ID = ID + L 290 CONTINUE C DO 300 I = 1, L CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY, $ R(JD,JD+I-1), 1 ) CALL DAXPY( I, -Y(J-1,I), Y(J-1,1), LDY, R(JD,JD+I-1), $ 1 ) 300 CONTINUE C 310 CONTINUE C ELSE C DO 360 J = 2, NOBR2 JD = JD + L ID = MMNOBR + L + 1 C C Compute/update Gyy(1,j) for sequential processing with C connected blocks. C CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR21, $ ONE, DWORK(LDRWRK*M+1), LDRWRK, $ DWORK(LDRWRK*M+J), LDRWRK, UPD, $ R(MMNOBR+1,JD), LDR ) CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y, $ LDY, Y(J,1), LDY, ONE, R(MMNOBR+1,JD), LDR ) C C Compute/update Gyy(2:j,j) for sequential processing C with connected blocks, exploiting the block-Hankel C structure. C IF( FIRST ) THEN C DO 320 I = JD - L, JD - 1 CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1, $ R(MMNOBR+L+1,L+I), 1 ) 320 CONTINUE C ELSE C DO 330 I = JD - L, JD - 1 CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1, $ R(MMNOBR+L+1,L+I), 1 ) 330 CONTINUE C END IF C DO 340 I = 2, J - 1 CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1), $ LDY, R(ID,JD), LDR ) CALL DGER( L, L, -ONE, DWORK(LDRWRK*M+I-1), LDRWRK, $ DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD), $ LDR ) ID = ID + L 340 CONTINUE C DO 350 I = 1, L CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY, $ R(JD,JD+I-1), 1 ) CALL DAXPY( I, -DWORK(LDRWRK*(M+I-1)+J-1), $ DWORK(LDRWRK*M+J-1), LDRWRK, R(JD,JD+I-1), $ 1 ) 350 CONTINUE C 360 CONTINUE C END IF C IF ( .NOT.LAST ) THEN IF ( CONNEC ) THEN C C For sequential processing with connected data blocks, C save the remaining ("connection") elements of U and Y C in the first (M+L)*(2*NOBR-1) locations of DWORK. C IF ( M.GT.0 ) $ CALL DLACPY( 'Full', NOBR21, M, U(NS+1,1), LDU, DWORK, $ NOBR21 ) CALL DLACPY( 'Full', NOBR21, L, Y(NS+1,1), LDY, $ DWORK(MMNOBR-M+1), NOBR21 ) END IF C C Return to get new data. C ICYCLE = ICYCLE + 1 IWORK(1) = ICYCLE IWORK(2) = MAXWRK IWORK(3) = NSMPSM IF ( ICYCLE.GT.MAXCYC ) $ IWARN = 1 RETURN C ELSE C C Try to compute the Cholesky factor of the correlation C matrix. C CALL DPOTRF( 'Upper', NR, R, LDR, IERR ) GO TO 370 END IF ELSE IF ( FQRALG ) THEN C C Compute the R factor from a fast QR factorization of the C input-output data correlation matrix. C CALL IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, $ Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, $ IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) IWORK(1) = ICYCLE IWORK(2) = MAXWRK IWORK(3) = NSMPSM IF( .NOT.LAST ) $ RETURN END IF C 370 CONTINUE C IF( IERR.NE.0 ) THEN C C Error return from a fast factorization algorithm of the C input-output data correlation matrix. C IF( ONEBCH ) THEN QRALG = .TRUE. IWARN = 2 MINWRK = 2*NR CALL DGEQRF( NS, NR, DWORK, NS, DWORK, DWORK, -1, IERR ) MAXWRK = NR + INT( DWORK(1) ) IF ( LDR.LT.NS ) THEN MINWRK = MINWRK + NR MAXWRK = NS*NR + MAXWRK END IF MAXWRK = MAX( MINWRK, MAXWRK ) C IF( LDWORK.LT.MINWRK ) THEN INFO = -17 C C Return: Not enough workspace. C DWORK( 1 ) = MINWRK CALL XERBLA( 'IB01MD', -INFO ) RETURN END IF ELSE INFO = 1 RETURN END IF END IF C IF ( QRALG ) THEN C C Compute the R factor from a QR factorization of the matrix H C of concatenated block Hankel matrices. C C Construct the matrix H. C C Set the parameters for constructing the current segment of the C Hankel matrix, taking the available memory space into account. C INITI+1 points to the beginning rows of U and Y from which C data are taken when NCYCLE > 1 inner cycles are needed, C or for sequential processing with connected blocks. C LDRWMX is the number of rows that can fit in the working space. C LDRWRK is the actual number of rows processed in this space. C NSLAST is the number of samples to be processed at the last C inner cycle. C INITI = 0 LDRWMX = LDWORK / NR - 2 NCYCLE = 1 NSLAST = NSMP LINR = .FALSE. IF ( FIRST ) THEN LINR = LDR.GE.NS LDRWRK = NS ELSE IF ( CONNEC ) THEN LDRWRK = NSMP ELSE LDRWRK = NS END IF INICYC = 1 C IF ( .NOT.LINR ) THEN IF ( LDRWMX.LT.LDRWRK ) THEN C C Not enough working space for doing a single inner cycle. C NCYCLE inner cycles are to be performed for the current C data block using the working space. C NCYCLE = LDRWRK / LDRWMX NSLAST = MOD( LDRWRK, LDRWMX ) IF ( NSLAST.NE.0 ) THEN NCYCLE = NCYCLE + 1 ELSE NSLAST = LDRWMX END IF LDRWRK = LDRWMX NS = LDRWRK IF ( FIRST ) INICYC = 2 END IF MLDRW = M*LDRWRK LLDRW = L*LDRWRK INU = MLDRW*NOBR + 1 INY = MLDRW*NOBR2 + 1 END IF C C Process the data given at the current call. C IF ( .NOT.FIRST .AND. CONNEC ) THEN C C Restore the saved (M+L)*(2*NOBR-1) "connection" elements of C U and Y into their appropriate position in sequential C processing. The process is performed column-wise, in C reverse order, first for Y and then for U. C IREV = NR - M - L - NOBR21 + 1 ICOL = INY + LLDRW - LDRWRK C DO 380 J = 1, L DO 375 I = NOBR21 - 1, 0, -1 DWORK(ICOL+I) = DWORK(IREV+I) 375 CONTINUE IREV = IREV - NOBR21 ICOL = ICOL - LDRWRK 380 CONTINUE C IF( MOESP ) THEN ICOL = INU + MLDRW - LDRWRK ELSE ICOL = MLDRW - LDRWRK + 1 END IF C DO 390 J = 1, M DO 385 I = NOBR21 - 1, 0, -1 DWORK(ICOL+I) = DWORK(IREV+I) 385 CONTINUE IREV = IREV - NOBR21 ICOL = ICOL - LDRWRK 390 CONTINUE C IF( MOESP ) $ CALL DLACPY( 'Full', NOBRM1, M, DWORK(INU+NOBR), LDRWRK, $ DWORK, LDRWRK ) END IF C C Data compression using QR factorization. C IF ( FIRST ) THEN C C Non-sequential data processing or first block in C sequential data processing: C Use the general QR factorization algorithm. C IF ( LINR ) THEN C C Put the input-output data in the array R. C IF( M.GT.0 ) THEN IF( MOESP ) THEN C DO 400 I = 1, NOBR CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, $ R(1,M*(I-1)+1), LDR ) 400 CONTINUE C DO 410 I = 1, NOBR CALL DLACPY( 'Full', NS, M, U(I,1), LDU, $ R(1,MNOBR+M*(I-1)+1), LDR ) 410 CONTINUE C ELSE C DO 420 I = 1, NOBR2 CALL DLACPY( 'Full', NS, M, U(I,1), LDU, $ R(1,M*(I-1)+1), LDR ) 420 CONTINUE C END IF END IF C DO 430 I = 1, NOBR2 CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, $ R(1,MMNOBR+L*(I-1)+1), LDR ) 430 CONTINUE C C Workspace: need 4*(M+L)*NOBR, C prefer 2*(M+L)*NOBR+2*(M+L)*NOBR*NB. C ITAU = 1 JWORK = ITAU + NR CALL DGEQRF( NS, NR, R, LDR, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) ELSE C C Put the input-output data in the array DWORK. C IF( M.GT.0 ) THEN ISHFTU = 1 IF( MOESP ) THEN ISHFT2 = INU C DO 440 I = 1, NOBR CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, $ DWORK(ISHFTU), LDRWRK ) ISHFTU = ISHFTU + MLDRW 440 CONTINUE C DO 450 I = 1, NOBR CALL DLACPY( 'Full', NS, M, U(I,1), LDU, $ DWORK(ISHFT2), LDRWRK ) ISHFT2 = ISHFT2 + MLDRW 450 CONTINUE C ELSE C DO 460 I = 1, NOBR2 CALL DLACPY( 'Full', NS, M, U(I,1), LDU, $ DWORK(ISHFTU), LDRWRK ) ISHFTU = ISHFTU + MLDRW 460 CONTINUE C END IF END IF C ISHFTY = INY C DO 470 I = 1, NOBR2 CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, $ DWORK(ISHFTY), LDRWRK ) ISHFTY = ISHFTY + LLDRW 470 CONTINUE C C Workspace: need 2*(M+L)*NOBR + 4*(M+L)*NOBR, C prefer NS*2*(M+L)*NOBR + 2*(M+L)*NOBR C + 2*(M+L)*NOBR*NB, C used LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, C where NS = NSMP - 2*NOBR + 1, C LDRWRK = min(NS, LDWORK/(2*(M+L)*NOBR)-2). C ITAU = LDRWRK*NR + 1 JWORK = ITAU + NR CALL DGEQRF( NS, NR, DWORK, LDRWRK, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) CALL DLACPY( 'Upper ', MIN(NS,NR), NR, DWORK, LDRWRK, R, $ LDR ) END IF C IF ( NS.LT.NR ) $ CALL DLASET( 'Upper ', NR - NS, NR - NS, ZERO, ZERO, $ R(NS+1,NS+1), LDR ) INITI = INITI + NS END IF C IF ( NCYCLE.GT.1 .OR. .NOT.FIRST ) THEN C C Remaining segments of the first data block or C remaining segments/blocks in sequential data processing: C Use a structure-exploiting QR factorization algorithm. C NSL = LDRWRK IF ( .NOT.CONNEC ) NSL = NS ITAU = LDRWRK*NR + 1 JWORK = ITAU + NR C DO 560 NICYCL = INICYC, NCYCLE C C INIT denotes the beginning row where new data are put. C IF ( CONNEC .AND. NICYCL.EQ.1 ) THEN INIT = NOBR2 ELSE INIT = 1 END IF IF ( NCYCLE.GT.1 .AND. NICYCL.EQ.NCYCLE ) THEN C C Last samples in the last data segment of a block. C NS = NSLAST NSL = NSLAST END IF C C Put the input-output data in the array DWORK. C NSF = NS IF ( INIT.GT.1 .AND. NCYCLE.GT.1 ) NSF = NSF - NOBR21 IF ( M.GT.0 ) THEN ISHFTU = INIT C IF( MOESP ) THEN ISHFT2 = INIT + INU - 1 C DO 480 I = 1, NOBR CALL DLACPY( 'Full', NSF, M, U(INITI+NOBR+I,1), $ LDU, DWORK(ISHFTU), LDRWRK ) ISHFTU = ISHFTU + MLDRW 480 CONTINUE C DO 490 I = 1, NOBR CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, $ DWORK(ISHFT2), LDRWRK ) ISHFT2 = ISHFT2 + MLDRW 490 CONTINUE C ELSE C DO 500 I = 1, NOBR2 CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, $ DWORK(ISHFTU), LDRWRK ) ISHFTU = ISHFTU + MLDRW 500 CONTINUE C END IF END IF C ISHFTY = INIT + INY - 1 C DO 510 I = 1, NOBR2 CALL DLACPY( 'Full', NSF, L, Y(INITI+I,1), LDY, $ DWORK(ISHFTY), LDRWRK ) ISHFTY = ISHFTY + LLDRW 510 CONTINUE C IF ( INIT.GT.1 ) THEN C C Prepare the connection to the previous block of data C in sequential processing. C IF( MOESP .AND. M.GT.0 ) $ CALL DLACPY( 'Full', NOBR, M, U, LDU, DWORK(NOBR), $ LDRWRK ) C C Shift the elements from the connection to the previous C block of data in sequential processing. C IF ( M.GT.0 ) THEN ISHFTU = MLDRW + 1 C IF( MOESP ) THEN ISHFT2 = MLDRW + INU C DO 520 I = 1, NOBRM1 CALL DLACPY( 'Full', NOBR21, M, $ DWORK(ISHFTU-MLDRW+1), LDRWRK, $ DWORK(ISHFTU), LDRWRK ) ISHFTU = ISHFTU + MLDRW 520 CONTINUE C DO 530 I = 1, NOBRM1 CALL DLACPY( 'Full', NOBR21, M, $ DWORK(ISHFT2-MLDRW+1), LDRWRK, $ DWORK(ISHFT2), LDRWRK ) ISHFT2 = ISHFT2 + MLDRW 530 CONTINUE C ELSE C DO 540 I = 1, NOBR21 CALL DLACPY( 'Full', NOBR21, M, $ DWORK(ISHFTU-MLDRW+1), LDRWRK, $ DWORK(ISHFTU), LDRWRK ) ISHFTU = ISHFTU + MLDRW 540 CONTINUE C END IF END IF C ISHFTY = LLDRW + INY C DO 550 I = 1, NOBR21 CALL DLACPY( 'Full', NOBR21, L, $ DWORK(ISHFTY-LLDRW+1), LDRWRK, $ DWORK(ISHFTY), LDRWRK ) ISHFTY = ISHFTY + LLDRW 550 CONTINUE C END IF C C Workspace: need LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR. C CALL MB04OD( 'Full', NR, 0, NSL, R, LDR, DWORK, LDRWRK, $ DUM, NR, DUM, NR, DWORK(ITAU), DWORK(JWORK) $ ) INITI = INITI + NSF 560 CONTINUE C END IF C IF ( .NOT.LAST ) THEN IF ( CONNEC ) THEN C C For sequential processing with connected data blocks, C save the remaining ("connection") elements of U and Y C in the first (M+L)*(2*NOBR-1) locations of DWORK. C IF ( M.GT.0 ) $ CALL DLACPY( 'Full', NOBR21, M, U(INITI+1,1), LDU, $ DWORK, NOBR21 ) CALL DLACPY( 'Full', NOBR21, L, Y(INITI+1,1), LDY, $ DWORK(MMNOBR-M+1), NOBR21 ) END IF C C Return to get new data. C ICYCLE = ICYCLE + 1 IWORK(1) = ICYCLE IWORK(2) = MAXWRK IWORK(3) = NSMPSM IF ( ICYCLE.LE.MAXCYC ) $ RETURN IWARN = 1 ICYCLE = 1 C END IF C END IF C C Return optimal workspace in DWORK(1). C DWORK( 1 ) = MAXWRK IF( .NOT.ONEBCH ) THEN IWORK(1) = ICYCLE IWORK(2) = MAXWRK IWORK(3) = NSMPSM END IF RETURN C C *** Last line of IB01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04VX.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04VX.f0000644000175000017500000003270715012430707017422 0ustar00lilgelilge00000000000000 SUBROUTINE MB04VX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, $ LDA, E, LDE, Q, LDQ, Z, LDZ, MNEI ) C C PURPOSE C C To separate the pencils s*E(eps)-A(eps) and s*E(inf)-A(inf) in C s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 in [1]. C C On entry, it is assumed that the M-by-N matrices A and E have C been obtained after applying the Algorithms 3.2.1 and 3.3.1 to C the pencil s*E - A as described in [1], i.e. C C | s*E(eps,inf)-A(eps,inf) | X | C Q'(s*E - A)Z = |-------------------------|-------------| C | 0 | s*E(r)-A(r) | C C Here the pencil s*E(eps,inf)-A(eps,inf) is in staircase form. C This pencil contains all Kronecker column indices and infinite C elementary divisors of the pencil s*E - A. C The pencil s*E(r)-A(r) contains all Kronecker row indices and C finite elementary divisors of s*E - A. C Furthermore, the submatrices having full row and column rank in C the pencil s*E(eps,inf)-A(eps,inf) are assumed to be C triangularized. C C On exit, the result then is C C Q'(s*E - A)Z = C C | s*E(eps)-A(eps) | X | X | C |-----------------|-----------------|-------------| C | 0 | s*E(inf)-A(inf) | X | C |===================================|=============| C | | | C | 0 | s*E(r)-A(r) | C C Note that the pencil s*E(r)-A(r) is not reduced further. C C ARGUMENTS C C Mode Parameters C C UPDATQ LOGICAL C Indicates whether the user wishes to accumulate in a C matrix Q the orthogonal row transformations, as follows: C = .FALSE.: Do not form Q; C = .TRUE.: The given matrix Q is updated by the orthogonal C row transformations used in the reduction. C C UPDATZ LOGICAL C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal column transformations, as C follows: C = .FALSE.: Do not form Z; C = .TRUE.: The given matrix Z is updated by the orthogonal C column transformations used in the reduction. C C Input/Output Parameters C C M (input) INTEGER C Number of rows of A and E. M >= 0. C C N (input) INTEGER C Number of columns of A and E. N >= 0. C C NBLCKS (input) INTEGER C The number of submatrices having full row rank (possibly C zero) in A(eps,inf). C C INUK (input/output) INTEGER array, dimension (NBLCKS) C On entry, this array contains the row dimensions nu(k), C (k=1, 2, ..., NBLCKS) of the submatrices having full row C rank in the pencil s*E(eps,inf)-A(eps,inf). C On exit, this array contains the row dimensions nu(k), C (k=1, 2, ..., NBLCKS) of the submatrices having full row C rank in the pencil s*E(eps)-A(eps). C C IMUK (input/output) INTEGER array, dimension (NBLCKS) C On entry, this array contains the column dimensions mu(k), C (k=1, 2, ..., NBLCKS) of the submatrices having full C column rank in the pencil s*E(eps,inf)-A(eps,inf). C On exit, this array contains the column dimensions mu(k), C (k=1, 2, ..., NBLCKS) of the submatrices having full C column rank in the pencil s*E(eps)-A(eps). C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, this array contains the matrix A to be reduced. C On exit, it contains the transformed matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, this array contains the matrix E to be reduced. C On exit, it contains the transformed matrix E. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,M). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) C On entry, if UPDATQ = .TRUE., then the leading M-by-M C part of this array must contain a given matrix Q (e.g. C from a previous call to another SLICOT routine), and on C exit, the leading M-by-M part of this array contains the C product of the input matrix Q and the row transformation C matrix that has transformed the rows of the matrices A C and E. C If UPDATQ = .FALSE., the array Q is not referenced and C can be supplied as a dummy array (i.e. set parameter C LDQ = 1 and declare this array to be Q(1,1) in the calling C program). C C LDQ INTEGER C The leading dimension of array Q. If UPDATQ = .TRUE., C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) C On entry, if UPDATZ = .TRUE., then the leading N-by-N C part of this array must contain a given matrix Z (e.g. C from a previous call to another SLICOT routine), and on C exit, the leading N-by-N part of this array contains the C product of the input matrix Z and the column C transformation matrix that has transformed the columns of C the matrices A and E. C If UPDATZ = .FALSE., the array Z is not referenced and C can be supplied as a dummy array (i.e. set parameter C LDZ = 1 and declare this array to be Z(1,1) in the calling C program). C C LDZ INTEGER C The leading dimension of array Z. If UPDATZ = .TRUE., C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. C C MNEI (output) INTEGER array, dimension (3) C MNEI(1) = MEPS = row dimension of sE(eps)-A(eps); C MNEI(2) = NEPS = column dimension of sE(eps)-A(eps); C MNEI(3) = MINF = order of the regular pencil C sE(inf)-A(inf). C C REFERENCES C C [1] Beelen, Th. C New Algorithms for Computing the Kronecker structure of a C Pencil with Applications to Systems and Control Theory. C Ph.D.Thesis, Eindhoven University of Technology, C The Netherlands, 1987. 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, Jan. 1998. C Based on Release 3.0 routine MB04TX modified by A. Varga, C German Aerospace Research Establishment, Oberpfaffenhofen, C Germany, Nov. 1997, as follows: C 1) NBLCKS is only an input variable; C 2) the significance of MNEI is changed. C C REVISIONS C C A. Varga, DLR Oberpfaffenhofen, March 2002. C C KEYWORDS C C Generalized eigenvalue problem, Kronecker indices, orthogonal C transformation, staircase form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. LOGICAL UPDATQ, UPDATZ INTEGER LDA, LDE, LDQ, LDZ, M, N, NBLCKS C .. Array Arguments .. INTEGER IMUK(*), INUK(*), MNEI(3) DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. INTEGER CA, CJA, CJE, IP, ISMUK, ISNUK, K, MEPS, MINF, $ MUK, MUKP1, MUP, MUP1, NEPS, NUK, NUP, RA, RJE, $ SK1P1, TK1P1, TP1 DOUBLE PRECISION SC, SS C .. External Subroutines .. EXTERNAL DROTG, MB04TU C .. Executable Statements .. C MNEI(1) = 0 MNEI(2) = 0 MNEI(3) = 0 IF ( M.LE.0 .OR. N.LE.0 ) $ RETURN C C Initialisation. C ISMUK = 0 ISNUK = 0 C DO 20 K = 1, NBLCKS ISMUK = ISMUK + IMUK(K) ISNUK = ISNUK + INUK(K) 20 CONTINUE C C MEPS, NEPS are the dimensions of the pencil s*E(eps)-A(eps). C MEPS = Sum(k=1,...,nblcks) NU(k), C NEPS = Sum(k=1,...,nblcks) MU(k). C MINF is the order of the regular pencil s*E(inf)-A(inf). C MEPS = ISNUK NEPS = ISMUK MINF = 0 C C MUKP1 = mu(k+1). N.B. It is assumed that mu(NBLCKS + 1) = 0. C MUKP1 = 0 C DO 120 K = NBLCKS, 1, -1 NUK = INUK(K) MUK = IMUK(K) C C Reduce submatrix E(k,k+1) to square matrix. C NOTE that always NU(k) >= MU(k+1) >= 0. C C WHILE ( NU(k) > MU(k+1) ) DO 40 IF ( NUK.GT.MUKP1 ) THEN C C sk1p1 = sum(i=k+1,...,p-1) NU(i) C tk1p1 = sum(i=k+1,...,p-1) MU(i) C ismuk = sum(i=1,...,k) MU(i) C tp1 = sum(i=1,...,p-1) MU(i) = ismuk + tk1p1. C SK1P1 = 0 TK1P1 = 0 C DO 100 IP = K + 1, NBLCKS C C Annihilate the elements originally present in the last C row of E(k,p+1) and A(k,p). C Start annihilating the first MU(p) - MU(p+1) elements by C applying column Givens rotations plus interchanging C elements. C Use original bottom diagonal element of A(k,k) as pivot. C Start position of pivot in A = (ra,ca). C TP1 = ISMUK + TK1P1 RA = ISNUK + SK1P1 CA = TP1 C MUP = IMUK(IP) NUP = INUK(IP) MUP1 = NUP C DO 60 CJA = CA, CA + MUP - NUP - 1 C C CJA = current column index of pivot in A. C CALL DROTG( A(RA,CJA), A(RA,CJA+1), SC, SS ) C C Apply transformations to A- and E-matrix. C Interchange columns simultaneously. C Update column transformation matrix Z, if needed. C CALL MB04TU( RA-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, $ SS ) A(RA,CJA+1) = A(RA,CJA) A(RA,CJA) = ZERO CALL MB04TU( RA, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), $ 1, SC, SS ) 60 CONTINUE C C Annihilate the remaining elements originally present in C the last row of E(k,p+1) and A(k,p) by alternatingly C applying row and column rotations plus interchanging C elements. C Use diagonal elements of E(p,p+1) and original bottom C diagonal element of A(k,k) as pivots, respectively. C (re,ce) and (ra,ca) are the starting positions of the C pivots in E and A. C CJE = TP1 + MUP CJA = CJE - MUP1 - 1 C DO 80 RJE = RA + 1, RA + MUP1 C C (RJE,CJE) = current position pivot in E. C CJE = CJE + 1 CJA = CJA + 1 C C Determine the row transformations. C Apply these transformations to E- and A-matrix. C Interchange the rows simultaneously. C Update row transformation matrix Q, if needed. C CALL DROTG( E(RJE,CJE), E(RJE-1,CJE), SC, SS ) CALL MB04TU( N-CJE, E(RJE,CJE+1), LDE, E(RJE-1,CJE+1), $ LDE, SC, SS ) E(RJE-1,CJE) = E(RJE,CJE) E(RJE,CJE) = ZERO CALL MB04TU( N-CJA+1, A(RJE,CJA), LDA, A(RJE-1,CJA), $ LDA, SC, SS ) IF( UPDATQ ) CALL MB04TU( M, Q(1,RJE), 1, $ Q(1,RJE-1), 1, SC, SS ) C C Determine the column transformations. C Apply these transformations to A- and E-matrix. C Interchange the columns simultaneously. C Update column transformation matrix Z, if needed. C CALL DROTG( A(RJE,CJA), A(RJE,CJA+1), SC, SS ) CALL MB04TU( RJE-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, $ SS ) A(RJE,CJA+1) = A(RJE,CJA) A(RJE,CJA) = ZERO CALL MB04TU( RJE, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), $ 1, SC, SS ) 80 CONTINUE C SK1P1 = SK1P1 + NUP TK1P1 = TK1P1 + MUP C 100 CONTINUE C C Reduce A=A(eps,inf) and E=E(eps,inf) by ignoring their last C row and right most column. The row and column ignored C belong to the pencil s*E(inf)-A(inf). C Redefine blocks in new A and E. C MUK = MUK - 1 NUK = NUK - 1 ISMUK = ISMUK - 1 ISNUK = ISNUK - 1 MEPS = MEPS - 1 NEPS = NEPS - 1 MINF = MINF + 1 C GO TO 40 END IF C END WHILE 40 C IMUK(K) = MUK INUK(K) = NUK C C Now submatrix E(k,k+1) is square. C C Consider next submatrix (k:=k-1). C ISNUK = ISNUK - NUK ISMUK = ISMUK - MUK MUKP1 = MUK 120 CONTINUE C C Store dimensions of the pencils s*E(eps)-A(eps) and C s*E(inf)-A(inf) in array MNEI. C MNEI(1) = MEPS MNEI(2) = NEPS MNEI(3) = MINF C RETURN C *** Last line of MB04VX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03VY.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03VY.f0000644000175000017500000001637015012430707017420 0ustar00lilgelilge00000000000000 SUBROUTINE MB03VY( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To generate the real orthogonal matrices Q_1, Q_2, ..., Q_p, C which are defined as the product of ihi-ilo elementary reflectors C of order n, as returned by SLICOT Library routine MB03VD: C C Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices Q_1, Q_2, ..., Q_p. N >= 0. C C P (input) INTEGER C The number p of transformation matrices. P >= 1. C C ILO (input) INTEGER C IHI (input) INTEGER C The values of the indices ilo and ihi, respectively, used C in the previous call of the SLICOT Library routine MB03VD. C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA1,LDA2,N) C On entry, the leading N-by-N strictly lower triangular C part of A(*,*,j) must contain the vectors which define the C elementary reflectors used for reducing A_j, as returned C by SLICOT Library routine MB03VD, j = 1, ..., p. C On exit, the leading N-by-N part of A(*,*,j) contains the C N-by-N orthogonal matrix Q_j, j = 1, ..., p. C C LDA1 INTEGER C The first leading dimension of the array A. C LDA1 >= max(1,N). C C LDA2 INTEGER C The second leading dimension of the array A. C LDA2 >= max(1,N). C C TAU (input) DOUBLE PRECISION array, dimension (LDTAU,P) C The leading N-1 elements in the j-th column must contain C the scalar factors of the elementary reflectors used to C form the matrix Q_j, as returned by SLICOT Library routine C MB03VD. C C LDTAU INTEGER C The leading dimension of the array TAU. C LDTAU >= max(1,N-1). 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 length of the array DWORK. LDWORK >= MAX(1,N). 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 Each matrix Q_j is generated as the product of the elementary C reflectors used for reducing A_j. Standard LAPACK routines for C Hessenberg and QR decompositions are used. C C REFERENCES C C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. C The periodic Schur decomposition: algorithms and applications. C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, C 1992. C C [2] Sreedhar, J. and Van Dooren, P. C Periodic Schur form and some matrix equations. C Proc. of the Symposium on the Mathematical Theory of Networks C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. C C NUMERICAL ASPECTS C C The algorithm is numerically stable. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. C Partly based on the routine PSHTR by A. Varga C (DLR Oberpfaffenhofen), November 26, 1995. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004, C July 2012, June 2022. C C KEYWORDS C C Hessenberg form, orthogonal transformation, periodic systems, C similarity transformation, triangular form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C C .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA1, LDA2, LDTAU, LDWORK, N, P C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * ) C .. C .. Local Scalars .. LOGICAL LQUERY INTEGER J, NH, WRKOPT C .. C .. External Subroutines .. EXTERNAL DLASET, DORGHR, DORGQR, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( P.LT.1 ) THEN INFO = -2 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -3 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -4 ELSE IF( LDA1.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDA2.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDTAU.LT.MAX( 1, N-1 ) ) THEN INFO = -9 ELSE NH = IHI - ILO + 1 LQUERY = LDWORK.EQ.-1 IF( LQUERY ) THEN CALL DORGHR( N, ILO, IHI, A, LDA1, TAU, DWORK, -1, INFO ) WRKOPT = MAX( 1, N, INT( DWORK( 1 ) ) ) IF ( NH.GT.1 ) THEN CALL DORGQR( NH, NH, NH-1, A, LDA1, TAU, DWORK, -1, INFO) WRKOPT = MAX( WRKOPT, INT( DWORK( 1 ) ) ) END IF END IF IF( LDWORK.LT.MAX( 1, N ) .AND. .NOT. LQUERY ) $ INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03VY', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK( 1 ) = ONE RETURN ELSE IF( LQUERY ) THEN DWORK( 1 ) = WRKOPT RETURN END IF C C Generate the orthogonal matrix Q_1. C CALL DORGHR( N, ILO, IHI, A, LDA1, TAU, DWORK, LDWORK, INFO ) WRKOPT = INT( DWORK( 1 ) ) C DO 20 J = 2, P C C Generate the orthogonal matrix Q_j. C Set the first ILO-1 and the last N-IHI rows and columns of Q_j C to those of the unit matrix. C CALL DLASET( 'Full', N, ILO-1, ZERO, ONE, A( 1, 1, J ), LDA1 ) CALL DLASET( 'Full', ILO-1, NH, ZERO, ZERO, A( 1, ILO, J ), $ LDA1 ) IF ( NH.GT.1 ) THEN CALL DORGQR( NH, NH, NH-1, A( ILO, ILO, J ), LDA1, $ TAU( ILO, J ), DWORK, LDWORK, INFO ) ELSE A( ILO, ILO, J ) = ONE END IF IF ( IHI.LT.N ) THEN CALL DLASET( 'Full', N-IHI, NH, ZERO, ZERO, $ A( IHI+1, ILO, J ), LDA1 ) CALL DLASET( 'Full', IHI, N-IHI, ZERO, ZERO, $ A( 1, IHI+1, J ), LDA1 ) CALL DLASET( 'Full', N-IHI, N-IHI, ZERO, ONE, $ A( IHI+1, IHI+1, J ), LDA1 ) END IF 20 CONTINUE C DWORK( 1 ) = MAX( WRKOPT, INT( DWORK( 1 ) ) ) RETURN C C *** Last line of MB03VY *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02AZ.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02AZ.f0000644000175000017500000000651315012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE MA02AZ( TRANS, JOB, M, N, A, LDA, B, LDB ) C C PURPOSE C C To (conjugate) transpose all or part of a two-dimensional complex C matrix A into another matrix B. C C ARGUMENTS C C Mode Parameters C C TRANS CHARACTER*1 C Specifies if a transpose or conjugate transpose operation C should be performed as follows: C = 'T': transpose operation; C = 'C': conjugate transpose operation. C C JOB CHARACTER*1 C Specifies the part of the matrix A to be transposed into B C as follows: C = 'U': Upper triangular part; C = 'L': Lower triangular part; C Otherwise: All of the matrix A. 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) COMPLEX*16 array, dimension (LDA,N) C The m-by-n matrix A. If JOB = 'U', only the upper C triangle or trapezoid is accessed; if JOB = 'L', only the C lower triangle or trapezoid is accessed. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C B (output) COMPLEX*16 array, dimension (LDB,M) C B = A' in the locations specified by JOB, where ' denotes C the transpose or conjugate transpose operation, as C as specified by TRANS. C C LDB INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C CONTRIBUTOR C C V. Sima, June 2021. C C REVISIONS C C - C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER JOB, TRANS INTEGER LDA, LDB, M, N C .. Array Arguments .. COMPLEX*16 A(LDA,*), B(LDB,*) C .. Local Scalars .. INTEGER I, J C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. Intrinsic Functions .. INTRINSIC DCONJG, MIN C C .. Executable Statements .. C IF( LSAME( TRANS, 'T' ) ) THEN IF( LSAME( JOB, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B(J,I) = A(I,J) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( JOB, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B(J,I) = A(I,J) 30 CONTINUE 40 CONTINUE ELSE DO 60 J = 1, N DO 50 I = 1, M B(J,I) = A(I,J) 50 CONTINUE 60 CONTINUE END IF ELSE IF( LSAME( JOB, 'U' ) ) THEN DO 80 J = 1, N DO 70 I = 1, MIN( J, M ) B(J,I) = DCONJG( A(I,J) ) 70 CONTINUE 80 CONTINUE ELSE IF( LSAME( JOB, 'L' ) ) THEN DO 100 J = 1, N DO 90 I = J, M B(J,I) = DCONJG( A(I,J) ) 90 CONTINUE 100 CONTINUE ELSE DO 120 J = 1, N DO 110 I = 1, M B(J,I) = DCONJG( A(I,J) ) 110 CONTINUE 120 CONTINUE END IF END IF C RETURN C *** Last line of MA02AZ *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02RD.f0000644000000000000000000000013015012430707016167 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB02RD.f0000644000175000017500000012772315012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE SB02RD( JOB, DICO, HINV, TRANA, UPLO, SCAL, SORT, FACT, $ LYAPUN, N, A, LDA, T, LDT, V, LDV, G, LDG, Q, $ LDQ, X, LDX, SEP, RCOND, FERR, WR, WI, S, LDS, $ IWORK, DWORK, LDWORK, BWORK, INFO ) C C PURPOSE C C To solve for X either the continuous-time algebraic Riccati C equation C -1 C Q + op(A)'*X + X*op(A) - X*op(B)*R op(B)'*X = 0, (1) C C or the discrete-time algebraic Riccati equation C -1 C X = op(A)'*X*op(A) - op(A)'*X*op(B)*(R + op(B)'*X*op(B)) * C op(B)'*X*op(A) + Q, (2) C C where op(M) = M or M' (M**T), A, op(B), Q, and R are N-by-N, C N-by-M, N-by-N, and M-by-M matrices respectively, with Q symmetric C and R symmetric nonsingular; X is an N-by-N symmetric matrix. C -1 C The matrix G = op(B)*R *op(B)' must be provided on input, instead C of B and R, that is, the continuous-time equation C C Q + op(A)'*X + X*op(A) - X*G*X = 0, (3) C C or the discrete-time equation C -1 C Q + op(A)'*X*(I_n + G*X) *op(A) - X = 0, (4) C C are solved, where G is an N-by-N symmetric matrix. SLICOT Library C routine SB02MT should be used to compute G, given B and R. SB02MT C also enables to solve Riccati equations corresponding to optimal C problems with coupling terms. C C The routine also returns the computed values of the closed-loop C spectrum of the optimal system, i.e., the stable eigenvalues C lambda(1),...,lambda(N) of the corresponding Hamiltonian or C symplectic matrix associated to the optimal problem. It is assumed C that the matrices A, G, and Q are such that the associated C Hamiltonian or symplectic matrix has N stable eigenvalues, i.e., C with negative real parts, in the continuous-time case, and with C moduli less than one, in the discrete-time case. C C Optionally, estimates of the conditioning and error bound on the C solution of the Riccati equation (3) or (4) are returned. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'X': Compute the solution only; C = 'C': Compute the reciprocal condition number only; C = 'E': Compute the error bound only; C = 'A': Compute all: the solution, reciprocal condition C number, and the error bound. C C DICO CHARACTER*1 C Specifies the type of Riccati equation to be solved or C analyzed, as follows: C = 'C': Equation (3), continuous-time case; C = 'D': Equation (4), discrete-time case. C C HINV CHARACTER*1 C If DICO = 'D' and JOB = 'X' or JOB = 'A', specifies which C symplectic matrix is to be constructed, as follows: C = 'D': The matrix H in (6) (see METHOD) is constructed; C = 'I': The inverse of the matrix H in (6) is constructed. C HINV is not used if DICO = 'C', or JOB = 'C' or 'E'. 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 UPLO CHARACTER*1 C Specifies which triangle of the matrices G and Q is C stored, as follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. C C SCAL CHARACTER*1 C If JOB = 'X' or JOB = 'A', specifies whether or not a C scaling strategy should be used, as follows: C = 'G': General scaling should be used; C = 'N': No scaling should be used. C SCAL is not used if JOB = 'C' or 'E'. C C SORT CHARACTER*1 C If JOB = 'X' or JOB = 'A', specifies which eigenvalues C should be obtained in the top of the Schur form, as C follows: C = 'S': Stable eigenvalues come first; C = 'U': Unstable eigenvalues come first. C SORT is not used if JOB = 'C' or 'E'. C C FACT CHARACTER*1 C If JOB <> 'X', specifies whether or not a real Schur C factorization of the closed-loop system matrix Ac is C supplied on entry, as follows: C = 'F': On entry, T and V contain the factors from a real C Schur factorization of the matrix Ac; C = 'N': A Schur factorization of Ac will be computed C and the factors will be stored in T and V. C For a continuous-time system, the matrix Ac is given by C Ac = A - G*X, if TRANA = 'N', or C Ac = A - X*G, if TRANA = 'T' or 'C', C and for a discrete-time system, the matrix Ac is given by C Ac = inv(I_n + G*X)*A, if TRANA = 'N', or C Ac = A*inv(I_n + X*G), if TRANA = 'T' or 'C'. C FACT is not used if JOB = 'X'. C C LYAPUN CHARACTER*1 C If JOB <> 'X', specifies whether or not the original or C "reduced" Lyapunov equations should be solved for C estimating reciprocal condition number and/or the error C bound, as follows: C = 'O': Solve the original Lyapunov equations, updating C the right-hand sides and solutions with the C matrix V, e.g., X <-- V'*X*V; C = 'R': Solve reduced Lyapunov equations only, without C updating the right-hand sides and solutions. C This means that a real Schur form T of Ac appears C in the equations, instead of Ac. C LYAPUN is not used if JOB = 'X'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, Q, G, and X. N >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C If JOB = 'X' or JOB = 'A' or FACT = 'N' or LYAPUN = 'O', C the leading N-by-N part of this array must contain the C coefficient matrix A of the equation. C If JOB = 'C' or 'E' and FACT = 'F' and LYAPUN = 'R', A is C not referenced. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,N), if JOB = 'X' or JOB = 'A' or C FACT = 'N' or LYAPUN = 'O'. C LDA >= 1, otherwise. C C T (input or output) DOUBLE PRECISION array, dimension C (LDT,N) C If JOB <> 'X' and FACT = 'F', then T is an input argument C and on entry, the leading N-by-N upper Hessenberg part of C this array must contain the upper quasi-triangular matrix C T in Schur canonical form from a Schur factorization of Ac C (see argument FACT). C If JOB <> 'X' and FACT = 'N', then T is an output argument C and on exit, if INFO = 0 or INFO = 7, the leading N-by-N C upper Hessenberg part of this array contains the upper C quasi-triangular matrix T in Schur canonical form from a C Schur factorization of Ac (see argument FACT). C If JOB = 'X', the array T is not referenced. C C LDT INTEGER C The leading dimension of the array T. C LDT >= 1, if JOB = 'X'; C LDT >= MAX(1,N), if JOB <> 'X'. C C V (input or output) DOUBLE PRECISION array, dimension C (LDV,N) C If JOB <> 'X' and FACT = 'F', then V is an input argument C and on entry, the leading N-by-N part of this array must C contain the orthogonal matrix V from a real Schur C factorization of Ac (see argument FACT). C If JOB <> 'X' and FACT = 'N', then V is an output argument C and on exit, if INFO = 0 or INFO = 7, the leading N-by-N C part of this array contains the orthogonal N-by-N matrix C from a real Schur factorization of Ac (see argument FACT). C If JOB = 'X', the array V is not referenced. C C LDV INTEGER C The leading dimension of the array V. C LDV >= 1, if JOB = 'X'; C LDV >= MAX(1,N), if JOB <> 'X'. C C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) C On entry, the leading N-by-N upper triangular part (if C UPLO = 'U') or lower triangular part (if UPLO = 'L') of C this array must contain the upper triangular part or lower C triangular part, respectively, of the symmetric matrix G. C On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and C LYAPUN = 'R', the leading N-by-N part of this array C contains the symmetric matrix G fully stored. C If JOB <> 'X' and LYAPUN = 'R', this array is modified C internally, but restored on exit. C C LDG INTEGER C The leading dimension of the array G. LDG >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, the leading N-by-N upper triangular part (if C UPLO = 'U') or lower triangular part (if UPLO = 'L') of C this array must contain the upper triangular part or lower C triangular part, respectively, of the symmetric matrix Q. C On exit, if JOB = 'X' and DICO = 'D', or JOB <> 'X' and C LYAPUN = 'R', the leading N-by-N part of this array C contains the symmetric matrix Q fully stored. C If JOB <> 'X' and LYAPUN = 'R', this array is modified C internally, but restored on exit. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= MAX(1,N). C C X (input or output) DOUBLE PRECISION array, dimension C (LDX,N) C If JOB = 'C' or JOB = 'E', then X is an input argument C and on entry, the leading N-by-N part of this array must C contain the symmetric solution matrix of the algebraic C Riccati equation. If LYAPUN = 'R', this array is modified C internally, but restored on exit; however, it could differ C from the input matrix at the round-off error level. C If JOB = 'X' or JOB = 'A', then X is an output argument C and on exit, if INFO = 0 or INFO >= 6, the leading N-by-N C part of this array contains the symmetric solution matrix C X of the algebraic Riccati equation. C C LDX INTEGER C The leading dimension of the array X. LDX >= MAX(1,N). C C SEP (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, the C estimated quantity C sep(op(Ac),-op(Ac)'), if DICO = 'C', or C sepd(op(Ac),op(Ac)'), if DICO = 'D'. (See METHOD.) C If JOB = 'C' or JOB = 'A' and X = 0, or JOB = 'E', SEP is C not referenced. C If JOB = 'X', and INFO = 0, INFO = 5 or INFO = 7, C SEP contains the scaling factor used, which should C multiply the (2,1) submatrix of U to recover X from the C first N columns of U (see METHOD). If SCAL = 'N', SEP is C set to 1. C C RCOND (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'A', and INFO = 0 or INFO = 7, an C estimate of the reciprocal condition number of the C algebraic Riccati equation. C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. C If JOB = 'X', or JOB = 'E', RCOND is not referenced. C C FERR (output) DOUBLE PRECISION C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = 7, an C estimated forward error bound for the solution X. If XTRUE C is the true solution, FERR bounds the magnitude of the C largest entry in (X - XTRUE) divided by the magnitude of C the largest entry in X. C If N = 0 or X = 0, FERR is set to 0. C If JOB = 'X', or JOB = 'C', FERR is not referenced. C C WR (output) DOUBLE PRECISION array, dimension (2*N) C WI (output) DOUBLE PRECISION array, dimension (2*N) C If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5, C these arrays contain the real and imaginary parts, C respectively, of the eigenvalues of the 2N-by-2N matrix S, C ordered as specified by SORT (except for the case C HINV = 'D', when the order is opposite to that specified C by SORT). The leading N elements of these arrays contain C the closed-loop spectrum of the system matrix Ac (see C argument FACT). Specifically, C lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N. C If JOB = 'C' or JOB = 'E', these arrays are not C referenced. C C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) C If JOB = 'X' or JOB = 'A', and INFO = 0 or INFO >= 5, the C leading 2N-by-2N part of this array contains the ordered C real Schur form S of the (scaled, if SCAL = 'G') C Hamiltonian or symplectic matrix H. That is, C C ( S S ) C ( 11 12 ) C S = ( ), C ( 0 S ) C ( 22 ) C C where S , S and S are N-by-N matrices. C 11 12 22 C If JOB = 'C' or JOB = 'E', this array is not referenced. C C LDS INTEGER C The leading dimension of the array S. C LDS >= MAX(1,2*N), if JOB = 'X' or JOB = 'A'; C LDS >= 1, if JOB = 'C' or JOB = 'E'. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK >= 2*N, if JOB = 'X'; C LIWORK >= N*N, if JOB = 'C' or JOB = 'E'; C LIWORK >= MAX(2*N,N*N), if JOB = 'A'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, or INFO = 7, DWORK(1) returns the C optimal value of LDWORK. If INFO = 0, or INFO >= 5, and C JOB = 'X', or JOB = 'A', then DWORK(2) returns an estimate C RCONDU of the reciprocal of the condition number (in the C 1-norm) of the N-th order system of algebraic equations C from which the solution matrix X is obtained, and DWORK(3) C returns the reciprocal pivot growth factor for the LU C factorization of the coefficient matrix of that system C (see SLICOT Library routine MB02PD); if DWORK(3) is much C less than 1, then the computed X and RCONDU could be C unreliable. C If DICO = 'D', and JOB = 'X', or JOB = 'A', then DWORK(4) C returns the reciprocal condition number RCONDA of the C given matrix A, and DWORK(5) returns the reciprocal pivot C growth factor for A or for its leading columns, if A is C singular (see SLICOT Library routine MB02PD); if DWORK(5) C is much less than 1, then the computed S and RCONDA could C be unreliable. C On exit, if INFO = 0, or INFO >= 4, and JOB = 'X', the C elements DWORK(6:5+4*N*N) contain the 2*N-by-2*N C transformation matrix U which reduced the Hamiltonian or C symplectic matrix H to the ordered real Schur form S. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 5+MAX(1,4*N*N+8*N), if JOB = 'X' or JOB = 'A'; C This may also be used for JOB = 'C' or JOB = 'E', but C exact bounds are as follows: C LDWORK >= 5 + MAX(1,LWS,LWE) + LWN, where C LWS = 0, if FACT = 'F' or LYAPUN = 'R'; C = 5*N, if FACT = 'N' and LYAPUN = 'O' and C DICO = 'C' and JOB = 'C'; C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and C DICO = 'C' and JOB = 'E'; C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and C DICO = 'D'; C LWE = 2*N*N, if DICO = 'C' and JOB = 'C'; C = 4*N*N, if DICO = 'C' and JOB = 'E'; C = MAX(3,2*N*N) + N*N, if DICO = 'D' and JOB = 'C'; C = MAX(3,2*N*N) + 2*N*N, if DICO = 'D' and JOB = 'E'; C LWN = 0, if LYAPUN = 'O' or JOB = 'C'; C = 2*N, if LYAPUN = 'R' and DICO = 'C' and JOB = 'E'; C = 3*N, if LYAPUN = 'R' and DICO = 'D' and JOB = 'E'. C For optimum performance LDWORK should sometimes be larger. C C BWORK LOGICAL array, dimension (LBWORK) C LBWORK >= 2*N, if JOB = 'X' or JOB = 'A'; C LBWORK >= 1, if JOB = 'C' or JOB = 'E', and C FACT = 'N' and LYAPUN = 'R'; C LBWORK >= 0, otherwise. 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 matrix A is (numerically) singular in discrete- C time case; C = 2: if the Hamiltonian or symplectic matrix H cannot be C reduced to real Schur form; C = 3: if the real Schur form of the Hamiltonian or C symplectic matrix H cannot be appropriately ordered; C = 4: if the Hamiltonian or symplectic matrix H has less C than N stable eigenvalues; C = 5: if the N-th order system of linear algebraic C equations, from which the solution matrix X would C be obtained, is singular to working precision; C = 6: if the QR algorithm failed to complete the reduction C of the matrix Ac to Schur canonical form, T; C = 7: if T and -T' have some almost equal eigenvalues, if C DICO = 'C', or T has almost reciprocal eigenvalues, C if DICO = 'D'; perturbed values were used to solve C Lyapunov equations, but the matrix T, if given (for C FACT = 'F'), is unchanged. (This is a warning C indicator.) C C METHOD C C The method used is the Schur vector approach proposed by Laub [1], C but with an optional scaling, which enhances the numerical C stability [6]. It is assumed that [A,B] is a stabilizable pair C (where for (3) or (4), B is any matrix such that B*B' = G with C rank(B) = rank(G)), and [E,A] is a detectable pair, where E is any C matrix such that E*E' = Q with rank(E) = rank(Q). Under these C assumptions, any of the algebraic Riccati equations (1)-(4) is C known to have a unique non-negative definite solution. See [2]. C Now consider the 2N-by-2N Hamiltonian or symplectic matrix C C ( op(A) -G ) C H = ( ), (5) C ( -Q -op(A)' ), C C for continuous-time equation, and C -1 -1 C ( op(A) op(A) *G ) C H = ( -1 -1 ), (6) C ( Q*op(A) op(A)' + Q*op(A) *G ) C C for discrete-time equation, respectively, where C -1 C G = op(B)*R *op(B)'. C The assumptions guarantee that H in (5) has no pure imaginary C eigenvalues, and H in (6) has no eigenvalues on the unit circle. C If Y is an N-by-N matrix then there exists an orthogonal matrix U C such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U C can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks C (corresponding to the complex conjugate eigenvalues and real C eigenvalues respectively) appear in any desired order. This is the C ordered real Schur form. Thus, we can find an orthogonal C similarity transformation U which puts (5) or (6) in ordered real C Schur form C C U'*H*U = S = (S(1,1) S(1,2)) C ( 0 S(2,2)) C C where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1) C have negative real parts in case of (5), or moduli greater than C one in case of (6). If U is conformably partitioned into four C N-by-N blocks C C U = (U(1,1) U(1,2)) C (U(2,1) U(2,2)) C C with respect to the assumptions we then have C (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1), C (2), (3), or (4) with X = X' and non-negative definite; C (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if C DICO = 'D') are equal to the eigenvalues of optimal system C (the 'closed-loop' spectrum). C C [A,B] is stabilizable if there exists a matrix F such that (A-BF) C is stable. [E,A] is detectable if [A',E'] is stabilizable. C C The condition number of a Riccati equation is estimated as C C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + C norm(Pi)*norm(G) ) / norm(X), C C where Omega, Theta and Pi are linear operators defined by C C Omega(W) = op(Ac)'*W + W*op(Ac), C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), C Pi(W) = inv(Omega(X*W*X)), C C in the continuous-time case, and C C Omega(W) = op(Ac)'*W*op(Ac) - W, C Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))), C Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))), C C in the discrete-time case, and Ac has been defined (see argument C FACT). Details are given in the comments of SLICOT Library C routines SB02QD and SB02SD. C C The routine estimates the quantities C C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), C sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)), C C norm(Theta) and norm(Pi) using 1-norm condition estimator. C C The forward error bound is estimated using a practical error bound C similar to the one proposed in [5]. C C REFERENCES C C [1] Laub, A.J. C A Schur Method for Solving Algebraic Riccati equations. C IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979. C C [2] Wonham, W.M. C On a matrix Riccati equation of stochastic control. C SIAM J. Contr., 6, pp. 681-697, 1968. C C [3] Sima, V. C Algorithms for Linear-Quadratic Optimization. C Pure and Applied Mathematics: A Series of Monographs and C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. C C [4] Ghavimi, A.R. and Laub, A.J. C Backward error, sensitivity, and refinement of computed C solutions of algebraic Riccati equations. C Numerical Linear Algebra with Applications, vol. 2, pp. 29-49, C 1995. C C [5] Higham, N.J. C Perturbation theory and backward error for AX-XB=C. C BIT, vol. 33, pp. 124-136, 1993. C C [6] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. C DGRSVX and DMSRIC: Fortran 77 subroutines for solving C continuous-time matrix algebraic Riccati equations with C condition and accuracy estimates. C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. C Chemnitz, May 1998. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. The solution accuracy C can be controlled by the output parameter FERR. C C FURTHER COMMENTS C C To obtain a stabilizing solution of the algebraic Riccati C equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set C SORT = 'S', if HINV = 'I'. C C The routine can also compute the anti-stabilizing solutions of C the algebraic Riccati equations, by specifying C SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or C SORT = 'S' if DICO = 'D' and HINV = 'D'. C C Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I' C and SORT = 'U', for stabilizing and anti-stabilizing solutions, C respectively, will be faster then the other combinations [3]. C C The option LYAPUN = 'R' may produce slightly worse or better C estimates, and it is faster than the option 'O'. C C This routine is a functionally extended and more accurate C version of the SLICOT Library routine SB02MD. Transposed problems C can be dealt with as well. Iterative refinement is used whenever C useful to solve linear algebraic systems. Condition numbers and C error bounds on the solutions are optionally provided. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, C Dec. 2002, Oct. 2004. C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, discrete-time system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, FACT, HINV, JOB, LYAPUN, SCAL, SORT, $ TRANA, UPLO INTEGER INFO, LDA, LDG, LDQ, LDS, LDT, LDV, LDWORK, LDX, $ N DOUBLE PRECISION FERR, RCOND, SEP C .. Array Arguments .. LOGICAL BWORK(*) INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), $ S(LDS,*), T(LDT,*), V(LDV,*), WI(*), WR(*), $ X(LDX,*) C .. Local Scalars .. LOGICAL COLEQU, DISCR, JBXA, JOBA, JOBC, JOBE, JOBX, $ LHINV, LSCAL, LSCL, LSORT, LUPLO, NOFACT, $ NOTRNA, ROWEQU, UPDATE CHARACTER EQUED, JOBS, LOFACT, LOUP, TRANAT INTEGER I, IERR, IU, IW, IWB, IWC, IWF, IWI, IWR, LDW, $ LWE, LWN, LWS, N2, NN, NP1, NROT DOUBLE PRECISION GNORM, QNORM, PIVOTA, PIVOTU, RCONDA, RCONDU, $ WRKOPT C .. External Functions .. LOGICAL LSAME, SB02MR, SB02MS, SB02MV, SB02MW DOUBLE PRECISION DLAMCH, DLANGE, DLANSY EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MS, $ SB02MV, SB02MW C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEES, DGESV, DLACPY, DLASCL, $ DLASET, DSCAL, DSWAP, DSYMM, MA02AD, MA02ED, $ MB01RU, MB01SD, MB02PD, SB02QD, SB02RU, SB02SD, $ XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C .. Executable Statements .. C C Decode the input parameters. C N2 = N + N NN = N*N NP1 = N + 1 INFO = 0 JOBA = LSAME( JOB, 'A' ) JOBC = LSAME( JOB, 'C' ) JOBE = LSAME( JOB, 'E' ) JOBX = LSAME( JOB, 'X' ) NOFACT = LSAME( FACT, 'N' ) NOTRNA = LSAME( TRANA, 'N' ) DISCR = LSAME( DICO, 'D' ) LUPLO = LSAME( UPLO, 'U' ) LSCAL = LSAME( SCAL, 'G' ) LSORT = LSAME( SORT, 'S' ) UPDATE = LSAME( LYAPUN, 'O' ) JBXA = JOBX .OR. JOBA LHINV = .FALSE. IF ( DISCR .AND. JBXA ) $ LHINV = LSAME( HINV, 'D' ) C C Test the input scalar arguments. C IF( .NOT.( JBXA .OR. JOBC .OR. JOBE ) ) THEN INFO = -1 ELSE IF( .NOT.( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN INFO = -2 ELSE IF( DISCR .AND. JBXA ) THEN IF( .NOT.( LHINV .OR. LSAME( HINV, 'I' ) ) ) $ INFO = -3 END IF IF( INFO.EQ.0 ) THEN IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. $ LSAME( TRANA, 'C' ) ) ) THEN INFO = -4 ELSE IF( .NOT.( LUPLO .OR. LSAME( UPLO, 'L' ) ) ) $ THEN INFO = -5 ELSE IF( JBXA ) THEN IF( .NOT.( LSCAL .OR. LSAME( SCAL, 'N' ) ) ) THEN INFO = -6 ELSE IF( .NOT.( LSORT .OR. LSAME( SORT, 'U' ) ) ) THEN INFO = -7 END IF END IF IF( INFO.EQ.0 .AND. .NOT.JOBX ) THEN IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN INFO = -8 ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN INFO = -9 END IF END IF IF( INFO.EQ.0 ) THEN IF( N.LT.0 ) THEN INFO = -10 ELSE IF( LDA.LT.1 .OR. ( ( JBXA .OR. NOFACT .OR. UPDATE ) $ .AND. LDA.LT.N ) ) THEN INFO = -12 ELSE IF( LDT.LT.1 .OR. ( .NOT. JOBX .AND. LDT.LT.N ) ) THEN INFO = -14 ELSE IF( LDV.LT.1 .OR. ( .NOT. JOBX .AND. LDV.LT.N ) ) THEN INFO = -16 ELSE IF( LDG.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -20 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -22 ELSE IF( LDS.LT.1 .OR. ( JBXA .AND. LDS.LT.N2 ) ) THEN INFO = -29 ELSE IF( JBXA ) THEN IF( LDWORK.LT.5 + MAX( 1, 4*NN + 8*N ) ) $ INFO = -32 ELSE IF( NOFACT .AND. UPDATE ) THEN IF( .NOT.DISCR .AND. JOBC ) THEN LWS = 5*N ELSE LWS = 5*N + NN END IF ELSE LWS = 0 END IF IF( DISCR ) THEN IF( JOBC ) THEN LWE = MAX( 3, 2*NN) + NN ELSE LWE = MAX( 3, 2*NN) + 2*NN END IF ELSE IF( JOBC ) THEN LWE = 2*NN ELSE LWE = 4*NN END IF END IF IF( UPDATE .OR. JOBC ) THEN LWN = 0 ELSE IF( DISCR ) THEN LWN = 3*N ELSE LWN = 2*N END IF END IF IF( LDWORK.LT.5 + MAX( 1, LWS, LWE ) + LWN ) $ INFO = -32 END IF END IF END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB02RD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN IF( JOBX ) $ SEP = ONE IF( JOBC .OR. JOBA ) $ RCOND = ONE IF( JOBE .OR. JOBA ) $ FERR = ZERO DWORK(1) = ONE DWORK(2) = ONE DWORK(3) = ONE IF ( DISCR ) THEN DWORK(4) = ONE DWORK(5) = ONE END IF RETURN END IF C IF ( JBXA ) THEN C C Compute the solution matrix X. C C Initialise the Hamiltonian or symplectic matrix associated with C the problem. C Workspace: need 0 if DICO = 'C'; C 6*N, if DICO = 'D'. C CALL SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q, $ LDQ, S, LDS, IWORK, DWORK, LDWORK, IERR ) C IF ( IERR.NE.0 ) THEN INFO = 1 IF ( DISCR ) THEN DWORK(4) = DWORK(1) DWORK(5) = DWORK(2) END IF RETURN END IF C IF ( DISCR ) THEN WRKOPT = 6*N RCONDA = DWORK(1) PIVOTA = DWORK(2) ELSE WRKOPT = 0 END IF C IF ( LSCAL ) THEN C C Scale the Hamiltonian or symplectic matrix S, using the C square roots of the norms of the matrices Q and G. C QNORM = SQRT( DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) ) GNORM = SQRT( DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) ) C LSCL = QNORM.GT.GNORM .AND. GNORM.GT.ZERO IF( LSCL ) THEN CALL DLASCL( 'G', 0, 0, QNORM, GNORM, N, N, S(NP1,1), $ LDS, IERR ) CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, S(1,NP1), $ LDS, IERR ) END IF ELSE LSCL = .FALSE. END IF C C Find the ordered Schur factorization of S, S = U*H*U'. C Workspace: need 5 + 4*N*N + 6*N; C prefer larger. C IU = 6 IW = IU + 4*NN LDW = LDWORK - IW + 1 IF ( .NOT.DISCR ) THEN IF ( LSORT ) THEN CALL DGEES( 'Vectors', 'Sorted', SB02MV, N2, S, LDS, $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, $ BWORK, IERR ) ELSE CALL DGEES( 'Vectors', 'Sorted', SB02MR, N2, S, LDS, $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, $ BWORK, IERR ) END IF ELSE IF ( LSORT ) THEN CALL DGEES( 'Vectors', 'Sorted', SB02MW, N2, S, LDS, $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, $ BWORK, IERR ) ELSE CALL DGEES( 'Vectors', 'Sorted', SB02MS, N2, S, LDS, $ NROT, WR, WI, DWORK(IU), N2, DWORK(IW), LDW, $ BWORK, IERR ) END IF IF ( LHINV ) THEN CALL DSWAP( N, WR, 1, WR(NP1), 1 ) CALL DSWAP( N, WI, 1, WI(NP1), 1 ) END IF END IF IF ( IERR.GT.N2 ) THEN INFO = 3 ELSE IF ( IERR.GT.0 ) THEN INFO = 2 ELSE IF ( NROT.NE.N ) THEN INFO = 4 END IF IF ( INFO.NE.0 ) THEN IF ( DISCR ) THEN DWORK(4) = RCONDA DWORK(5) = PIVOTA END IF RETURN END IF C WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) C C Compute the solution of X*U(1,1) = U(2,1) using C LU factorization and iterative refinement. The (2,1) block of S C is used as a workspace for factoring U(1,1). C Workspace: need 5 + 4*N*N + 8*N. C C First transpose U(2,1) in-situ. C DO 20 I = 1, N - 1 CALL DSWAP( N-I, DWORK(IU+N+I*(N2+1)-1), N2, $ DWORK(IU+N+(I-1)*(N2+1)+1), 1 ) 20 CONTINUE C IWR = IW IWC = IWR + N IWF = IWC + N IWB = IWF + N IW = IWB + N C CALL MB02PD( 'Equilibrate', 'Transpose', N, N, DWORK(IU), N2, $ S(NP1,1), LDS, IWORK, EQUED, DWORK(IWR), $ DWORK(IWC), DWORK(IU+N), N2, X, LDX, RCONDU, $ DWORK(IWF), DWORK(IWB), IWORK(NP1), DWORK(IW), $ IERR ) IF( JOBX ) THEN C C Restore U(2,1) back in-situ. C DO 40 I = 1, N - 1 CALL DSWAP( N-I, DWORK(IU+N+I*(N2+1)-1), N2, $ DWORK(IU+N+(I-1)*(N2+1)+1), 1 ) 40 CONTINUE C IF( .NOT.LSAME( EQUED, 'N' ) ) THEN C C Undo the equilibration of U(1,1) and U(2,1). C ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) C IF( ROWEQU ) THEN C DO 60 I = 1, N DWORK(IWR+I-1) = ONE / DWORK(IWR+I-1) 60 CONTINUE C CALL MB01SD( 'Row scaling', N, N, DWORK(IU), N2, $ DWORK(IWR), DWORK(IWC) ) END IF C IF( COLEQU ) THEN C DO 80 I = 1, N DWORK(IWC+I-1) = ONE / DWORK(IWC+I-1) 80 CONTINUE C CALL MB01SD( 'Column scaling', N, N, DWORK(IU), N2, $ DWORK(IWR), DWORK(IWC) ) CALL MB01SD( 'Column scaling', N, N, DWORK(IU+N), N2, $ DWORK(IWR), DWORK(IWC) ) END IF END IF C C Set S(2,1) to zero. C CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) END IF C PIVOTU = DWORK(IW) C IF ( IERR.GT.0 ) THEN C C Singular matrix. Set INFO and DWORK for error return. C INFO = 5 GO TO 160 END IF C C Make sure the solution matrix X is symmetric. C DO 100 I = 1, N - 1 CALL DAXPY( N-I, ONE, X(I,I+1), LDX, X(I+1,I), 1 ) CALL DSCAL( N-I, HALF, X(I+1,I), 1 ) CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) 100 CONTINUE C IF( LSCAL ) THEN C C Undo scaling for the solution matrix. C IF( LSCL ) $ CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, X, LDX, $ IERR ) END IF END IF C IF ( .NOT.JOBX ) THEN IF ( .NOT.JOBA ) $ WRKOPT = 0 C C Estimate the conditioning and compute an error bound on the C solution of the algebraic Riccati equation. C IW = 6 LOFACT = FACT IF ( NOFACT .AND. .NOT.UPDATE ) THEN C C Compute Ac and its Schur factorization. C IF ( DISCR ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(IW), N ) CALL DSYMM( 'Left', UPLO, N, N, ONE, G, LDG, X, LDX, $ ONE, DWORK(IW), N ) IF ( NOTRNA ) THEN C C Compute Ac = inv(I_n + G*X)*A. C CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) CALL DGESV( N, N, DWORK(IW), N, IWORK, T, LDT, IERR ) ELSE C C Compute Ac = A*inv(I_n + X*G). C CALL MA02AD( 'Full', N, N, A, LDA, T, LDT ) CALL DGESV( N, N, DWORK(IW), N, IWORK, T, LDT, IERR ) DO 120 I = 2, N CALL DSWAP( I-1, T(1,I), 1, T(I,1), LDT ) 120 CONTINUE END IF C ELSE C CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) IF ( NOTRNA ) THEN C C Compute Ac = A - G*X. C CALL DSYMM( 'Left', UPLO, N, N, -ONE, G, LDG, X, LDX, $ ONE, T, LDT ) ELSE C C Compute Ac = A - X*G. C CALL DSYMM( 'Right', UPLO, N, N, -ONE, G, LDG, X, LDX, $ ONE, T, LDT ) END IF END IF C C Compute the Schur factorization of Ac, Ac = V*T*V'. C Workspace: need 5 + 5*N. C prefer larger. C IWR = IW IWI = IWR + N IW = IWI + N LDW = LDWORK - IW + 1 C CALL DGEES( 'Vectors', 'Not ordered', SB02MS, N, T, LDT, $ NROT, DWORK(IWR), DWORK(IWI), V, LDV, DWORK(IW), $ LDW, BWORK, IERR ) C IF( IERR.NE.0 ) THEN INFO = 6 GO TO 160 END IF C WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) LOFACT = 'F' IW = 6 END IF C IF ( .NOT.UPDATE ) THEN C C Update G, Q, and X using the orthogonal matrix V. C TRANAT = 'T' C C Save the diagonal elements of G and Q. C CALL DCOPY( N, G, LDG+1, DWORK(IW), 1 ) CALL DCOPY( N, Q, LDQ+1, DWORK(IW+N), 1 ) IW = IW + N2 C IF ( JOBA ) $ CALL DLACPY( 'Full', N, N, X, LDX, S(NP1,1), LDS ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX, V, LDV, $ X, LDX, DWORK(IW), NN, IERR ) CALL DSCAL( N, HALF, X, LDX+1 ) CALL MA02ED( UPLO, N, X, LDX ) IF( .NOT.DISCR ) THEN CALL MA02ED( UPLO, N, G, LDG ) CALL MA02ED( UPLO, N, Q, LDQ ) END IF CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, G, LDG, V, LDV, $ G, LDG, DWORK(IW), NN, IERR ) CALL DSCAL( N, HALF, G, LDG+1 ) CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, Q, LDQ, V, LDV, $ Q, LDQ, DWORK(IW), NN, IERR ) CALL DSCAL( N, HALF, Q, LDQ+1 ) END IF C C Estimate the conditioning and/or the error bound. C Workspace: 5 + MAX(1,LWS,LWE) + LWN, where C C LWS = 0, if FACT = 'F' or LYAPUN = 'R'; C = 5*N, if FACT = 'N' and LYAPUN = 'O' and DICO = 'C' C and JOB = 'C'; C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and DICO = 'C' C and (JOB = 'E' or JOB = 'A'); C = 5*N+N*N, if FACT = 'N' and LYAPUN = 'O' and C DICO = 'D'; C LWE = 2*N*N, if DICO = 'C' and JOB = 'C'; C = 4*N*N, if DICO = 'C' and (JOB = 'E' or C JOB = 'A'); C = MAX(3,2*N*N) + N*N, if DICO = 'D' and JOB = 'C'; C = MAX(3,2*N*N) + 2*N*N, if DICO = 'D' and (JOB = 'E' or C JOB = 'A'); C LWN = 0, if LYAPUN = 'O' or JOB = 'C'; C = 2*N, if LYAPUN = 'R' and DICO = 'C' and (JOB = 'E' or C JOB = 'A'); C = 3*N, if LYAPUN = 'R' and DICO = 'D' and (JOB = 'E' or C JOB = 'A'). C LDW = LDWORK - IW + 1 IF ( JOBA ) THEN JOBS = 'B' ELSE JOBS = JOB END IF C IF ( DISCR ) THEN CALL SB02SD( JOBS, LOFACT, TRANA, UPLO, LYAPUN, N, A, LDA, $ T, LDT, V, LDV, G, LDG, Q, LDQ, X, LDX, SEP, $ RCOND, FERR, IWORK, DWORK(IW), LDW, IERR ) ELSE CALL SB02QD( JOBS, LOFACT, TRANA, UPLO, LYAPUN, N, A, LDA, $ T, LDT, V, LDV, G, LDG, Q, LDQ, X, LDX, SEP, $ RCOND, FERR, IWORK, DWORK(IW), LDW, IERR ) END IF C WRKOPT = MAX( WRKOPT, DWORK(IW) + DBLE( IW - 1 ) ) IF( IERR.EQ.NP1 ) THEN INFO = 7 ELSE IF( IERR.GT.0 ) THEN INFO = 6 GO TO 160 END IF C IF ( .NOT.UPDATE ) THEN C C Restore X, G, and Q and set S(2,1) to zero, if needed. C IF ( JOBA ) THEN CALL DLACPY( 'Full', N, N, S(NP1,1), LDS, X, LDX ) CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) ELSE CALL MB01RU( UPLO, TRANA, N, N, ZERO, ONE, X, LDX, V, $ LDV, X, LDX, DWORK(IW), NN, IERR ) CALL DSCAL( N, HALF, X, LDX+1 ) CALL MA02ED( UPLO, N, X, LDX ) END IF IF ( LUPLO ) THEN LOUP = 'L' ELSE LOUP = 'U' END IF C IW = 6 CALL DCOPY( N, DWORK(IW), 1, G, LDG+1 ) CALL MA02ED( LOUP, N, G, LDG ) CALL DCOPY( N, DWORK(IW+N), 1, Q, LDQ+1 ) CALL MA02ED( LOUP, N, Q, LDQ ) END IF C END IF C C Set the optimal workspace and other details. C DWORK(1) = WRKOPT 160 CONTINUE IF( JBXA ) THEN DWORK(2) = RCONDU DWORK(3) = PIVOTU IF ( DISCR ) THEN DWORK(4) = RCONDA DWORK(5) = PIVOTA END IF IF( JOBX ) THEN IF ( LSCL ) THEN SEP = QNORM / GNORM ELSE SEP = ONE END IF END IF END IF C RETURN C *** Last line of SB02RD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01VD.f0000644000000000000000000000013215012430707016175 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB01VD.f0000644000175000017500000004105515012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE TB01VD( APPLY, N, M, L, A, LDA, B, LDB, C, LDC, D, LDD, $ X0, THETA, LTHETA, DWORK, LDWORK, INFO ) C C PURPOSE C C To convert the linear discrete-time system given as (A, B, C, D), C with initial state x0, into the output normal form [1], with C parameter vector THETA. The matrix A is assumed to be stable. C The matrices A, B, C, D and the vector x0 are converted, so that C on exit they correspond to the system defined by THETA. C C ARGUMENTS C C Mode Parameters C C APPLY CHARACTER*1 C Specifies whether or not the parameter vector should be C transformed using a bijective mapping, as follows: C = 'A' : apply the bijective mapping to the N vectors in C THETA corresponding to the matrices A and C; C = 'N' : do not apply the bijective mapping. C The transformation performed when APPLY = 'A' allows C to get rid of the constraints norm(THETAi) < 1, i = 1:N. C A call of the SLICOT Library routine TB01VY associated to C a call of TB01VD must use the same value of APPLY. 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 number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L >= 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 system state matrix A, assumed to be stable. C On exit, the leading N-by-N part of this array contains C the transformed system state matrix corresponding to the C output normal form with parameter vector THETA. 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 system input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed system input matrix corresponding to the C output normal form with parameter vector THETA. 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 L-by-N part of this array must C contain the system output matrix C. C On exit, the leading L-by-N part of this array contains C the transformed system output matrix corresponding to the C output normal form with parameter vector THETA. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,L). C C D (input) DOUBLE PRECISION array, dimension (LDD,M) C The leading L-by-M part of this array must contain the C system input/output matrix D. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,L). C C X0 (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the initial state of the C system, x0. C On exit, this array contains the transformed initial state C of the system, corresponding to the output normal form C with parameter vector THETA. C C THETA (output) DOUBLE PRECISION array, dimension (LTHETA) C The leading N*(L+M+1)+L*M part of this array contains the C parameter vector that defines a system (A, B, C, D, x0) C which is equivalent up to a similarity transformation to C the system given on entry. The parameters are: C C THETA(1:N*L) : parameters for A, C; C THETA(N*L+1:N*(L+M)) : parameters for B; C THETA(N*(L+M)+1:N*(L+M)+L*M) : parameters for D; C THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0. C C LTHETA INTEGER C The length of array THETA. LTHETA >= N*(L+M+1)+L*M. 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 length of the array DWORK. C LDWORK >= MAX(1, N*N*L + N*L + N, C N*N + MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), C 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 = 1: if the Lyapunov equation A'*Q*A - Q = -scale^2*C'*C C could only be solved with scale = 0; C = 2: if matrix A is not discrete-time stable; C = 3: if the QR algorithm failed to converge for C matrix A. C C METHOD C C The matrices A and C are converted to output normal form. C First, the Lyapunov equation C C A'*Q*A - Q = -scale^2*C'*C, C C is solved in the Cholesky factor T, T'*T = Q, and then T is used C to get the transformation matrix. C C The matrix B and the initial state x0 are transformed accordingly. C C Then, the QR factorization of the transposed observability matrix C is computed, and the matrix Q is used to further transform the C system matrices. The parameters characterizing A and C are finally C obtained by applying a set of N orthogonal transformations. C C REFERENCES C C [1] Peeters, R.L.M., Hanzon, B., and Olivi, M. C Balanced realizations of discrete-time stable all-pass C systems and the tangential Schur algorithm. C Proceedings of the European Control Conference, C 31 August - 3 September 1999, Karlsruhe, Germany. C Session CP-6, Discrete-time Systems, 1999. C C CONTRIBUTORS C C A. Riedel, R. Schneider, Chemnitz University of Technology, C Oct. 2000, during a stay at University of Twente, NL. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, C Feb. 2002, Feb. 2004. C C KEYWORDS C C Asymptotically stable, Lyapunov equation, output normal form, C parameter estimation, similarity transformation. 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 APPLY INTEGER INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M, $ N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), THETA(*), X0(*) C .. Local Scalars .. DOUBLE PRECISION PIBY2, RI, SCALE, TI INTEGER CA, I, IA, IN, IQ, IR, IT, ITAU, IU, IWI, IWR, $ J, JWORK, K, LDCA, LDT, WRKOPT LOGICAL LAPPLY C .. External Functions .. EXTERNAL DNRM2, LSAME DOUBLE PRECISION DNRM2 LOGICAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGEQRF, DGER, $ DLACPY, DLASET, DORMQR, DSCAL, DTRMM, DTRMV, $ DTRSM, MA02AD, SB03OD, XERBLA C .. Intrinsic Functions .. INTRINSIC ATAN, INT, MAX, MIN, SQRT, TAN C .. C .. Executable Statements .. C C Check the scalar input parameters. C LAPPLY = LSAME( APPLY, 'A' ) C INFO = 0 IF ( .NOT.( LAPPLY .OR. LSAME( APPLY, 'N' ) ) ) THEN INFO = -1 ELSEIF ( N.LT.0 ) THEN INFO = -2 ELSEIF ( M.LT.0 ) THEN INFO = -3 ELSEIF ( L.LT.0 ) THEN INFO = -4 ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSEIF ( LDC.LT.MAX( 1, L ) ) THEN INFO = -10 ELSEIF ( LDD.LT.MAX( 1, L ) ) THEN INFO = -12 ELSEIF ( LTHETA.LT.( N*( M + L + 1 ) + L*M ) ) THEN INFO = -15 ELSEIF ( LDWORK.LT.MAX( 1, N*N*L + N*L + N, N*N + $ MAX( N*( N + MAX( N, L ) + 6 ) + $ MIN( N, L ), N*M ) ) ) THEN INFO = -17 ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'TB01VD', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( MAX( N, M, L ).EQ.0 ) THEN DWORK(1) = ONE RETURN ELSE IF ( N.EQ.0 ) THEN CALL DLACPY( 'Full', L, M, D, LDD, THETA, MAX( 1, L ) ) DWORK(1) = ONE RETURN ELSE IF ( L.EQ.0 ) THEN CALL DLACPY( 'Full', N, M, B, LDB, THETA, N ) CALL DCOPY( N, X0, 1, THETA(N*M+1), 1 ) DWORK(1) = ONE RETURN ENDIF 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 WRKOPT = 1 PIBY2 = TWO*ATAN( ONE ) C C Convert A and C to output normal form. C First, solve the Lyapunov equation C A'*Q*A - Q = -scale^2*C'*C, C in the Cholesky factor T, T'*T = Q, and use T to get the C transformation matrix. Copy A and C, to preserve them. C C Workspace: need N*(2*N + MAX(N,L) + 6) + MIN(N,L). C prefer larger. C C Initialize the indices in the workspace. C LDT = MAX( N, L ) CA = 1 IA = 1 IT = IA + N*N IU = IT + LDT*N IWR = IU + N*N IWI = IWR + N C JWORK = IWI + N C CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IT), LDT ) C CALL SB03OD( 'Discrete', 'NotFactored', 'NoTranspose', N, L, $ DWORK(IA), N, DWORK(IU), N, DWORK(IT), LDT, SCALE, $ DWORK(IWR), DWORK(IWI), DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) IF ( INFO.NE.0 ) THEN IF ( INFO.EQ.6 ) THEN INFO = 3 ELSE INFO = 2 ENDIF RETURN ENDIF WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 C IF ( SCALE.EQ.ZERO ) THEN INFO = 1 RETURN ENDIF C C Compute A = T*A*T^(-1). C CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, N, ONE, $ DWORK(IT), LDT, A, LDA ) C CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, N, ONE, $ DWORK(IT), LDT, A, LDA ) IF ( M.GT.0 ) THEN C C Compute B = (1/scale)*T*B. C CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, M, $ ONE/SCALE, DWORK(IT), LDT, B, LDB ) ENDIF C C Compute x0 = (1/scale)*T*x0. C CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(IT), LDT, $ X0, 1 ) CALL DSCAL( N, ONE/SCALE, X0, 1 ) C C Compute C = scale*C*T^(-1). C CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', L, N, $ SCALE, DWORK(IT), LDT, C, LDC ) C C Now, the system has been transformed to the output normal form. C Build the transposed observability matrix in DWORK(CA) and compute C its QR factorization. C CALL MA02AD( 'Full', L, N, C, LDC, DWORK(CA), N ) C DO 10 I = 1, N - 1 CALL DGEMM( 'Transpose', 'NoTranspose', N, L, N, ONE, A, LDA, $ DWORK(CA+(I-1)*N*L), N, ZERO, DWORK(CA+I*N*L), N ) 10 CONTINUE C C Compute the QR factorization. C C Workspace: need N*N*L + N + L*N. C prefer N*N*L + N + NB*L*N. C ITAU = CA + N*N*L JWORK = ITAU + N CALL DGEQRF( N, L*N, DWORK(CA), N, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Compute Q such that R has all diagonal elements nonnegative. C Only the first N*N part of R is needed. Move the details C of the QR factorization process, to gain memory and efficiency. C C Workspace: need 2*N*N + 2*N. C prefer 2*N*N + N + NB*N. C IR = N*N + 1 IF ( L.NE.2 ) $ CALL DCOPY( N, DWORK(ITAU), 1, DWORK(IR+N*N), 1 ) CALL DLACPY( 'Lower', N, N, DWORK(CA), N, DWORK(IR), N ) ITAU = IR + N*N JWORK = ITAU + N C IQ = 1 CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(IQ), N ) C DO 20 I = 1, N IF ( DWORK(IR+(I-1)*(N+1)).LT.ZERO ) $ DWORK(IQ+(I-1)*(N+1))= -ONE 20 CONTINUE C CALL DORMQR( 'Left', 'NoTranspose', N, N, N, DWORK(IR), N, $ DWORK(ITAU), DWORK(IQ), N, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) JWORK = IR C C Now, the transformation matrix Q is in DWORK(IQ). C C Compute A = Q'*A*Q. C CALL DGEMM( 'Transpose', 'NoTranspose', N, N, N, ONE, DWORK(IQ), $ N, A, LDA, ZERO, DWORK(JWORK), N ) CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, $ DWORK(JWORK), N, DWORK(IQ), N, ZERO, A, LDA ) C IF ( M.GT.0 ) THEN C C Compute B = Q'*B. C Workspace: need N*N + N*M. C CALL DLACPY( 'Full', N, M, B, LDB, DWORK(JWORK), N ) CALL DGEMM( 'Transpose', 'NoTranspose', N, M, N, ONE, $ DWORK(IQ), N, DWORK(JWORK), N, ZERO, B, LDB ) ENDIF C C Compute C = C*Q. C Workspace: need N*N + N*L. C CALL DLACPY( 'Full', L, N, C, LDC, DWORK(JWORK), L ) CALL DGEMM( 'NoTranspose', 'NoTranspose', L, N, N, ONE, $ DWORK(JWORK), L, DWORK(IQ), N, ZERO, C, LDC ) C C Compute x0 = Q'*x0. C CALL DCOPY( N, X0, 1, DWORK(JWORK), 1 ) CALL DGEMV( 'Transpose', N, N, ONE, DWORK(IQ), N, DWORK(JWORK), $ 1, ZERO, X0, 1 ) C C Now, copy C and A into the workspace to make it easier to read out C the corresponding part of THETA, and to apply the transformations. C LDCA = N + L C DO 30 I = 1, N CALL DCOPY( L, C(1,I), 1, DWORK(CA+(I-1)*LDCA), 1 ) CALL DCOPY( N, A(1,I), 1, DWORK(CA+L+(I-1)*LDCA), 1 ) 30 CONTINUE C JWORK = CA + LDCA*N C C The parameters characterizing A and C are extracted in this loop. C Workspace: need N*(N + L + 1). C DO 60 I = 1, N CALL DCOPY( L, DWORK(CA+1+(N-I)*(LDCA+1)), 1, THETA((I-1)*L+1), $ 1 ) RI = DWORK(CA+(N-I)*(LDCA+1)) TI = DNRM2( L, THETA((I-1)*L+1), 1 ) C C Multiply the part of [C; A] which will be currently transformed C with Ui = [ -THETAi, Si; RI, THETAi' ] from the left, without C storing Ui. Ui has the size (L+1)-by-(L+1). C CALL DGEMV( 'Transpose', L, N, ONE, DWORK(CA+N-I+1), LDCA, $ THETA((I-1)*L+1), 1, ZERO, DWORK(JWORK), 1 ) C IF ( TI.GT.ZERO ) THEN CALL DGER( L, N, (RI-ONE)/TI/TI, THETA((I-1)*L+1), 1, $ DWORK(JWORK), 1, DWORK(CA+N-I+1), LDCA ) ELSE C C The call below is for the limiting case. C CALL DGER( L, N, -HALF, THETA((I-1)*L+1), 1, $ DWORK(JWORK), 1, DWORK(CA+N-I+1), LDCA ) ENDIF C CALL DGER( L, N, -ONE, THETA((I-1)*L+1), 1, DWORK(CA+N-I), $ LDCA, DWORK(CA+N-I+1), LDCA ) CALL DAXPY( N, RI, DWORK(CA+N-I), LDCA, DWORK(JWORK), 1 ) C C Move these results to their appropriate locations. C DO 50 J = 1, N IN = CA + N - I + ( J - 1 )*LDCA DO 40 K = IN + 1, IN + L DWORK(K-1) = DWORK(K) 40 CONTINUE DWORK(IN+L) = DWORK(JWORK+J-1) 50 CONTINUE C C Now, apply the bijective mapping, which allows to get rid C of the constraint norm(THETAi) < 1. C IF ( LAPPLY .AND. TI.NE.ZERO ) $ CALL DSCAL( L, TAN( TI*PIBY2 )/TI, THETA((I-1)*L+1), 1 ) C 60 CONTINUE C IF ( M.GT.0 ) THEN C C The next part of THETA is B. C CALL DLACPY( 'Full', N, M, B, LDB, THETA(N*L+1), N ) C C Copy the matrix D. C CALL DLACPY( 'Full', L, M, D, LDD, THETA(N*(L+M)+1), L ) ENDIF C C Copy the initial state x0. C CALL DCOPY( N, X0, 1, THETA(N*(L+M)+L*M+1), 1 ) C DWORK(1) = WRKOPT RETURN C C *** Last line of TB01VD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04YD.f0000644000000000000000000000013215012430707016174 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04YD.f0000644000175000017500000005450015012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE MB04YD( JOBU, JOBV, M, N, RANK, THETA, Q, E, U, LDU, V, $ LDV, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN, $ INFO ) C C PURPOSE C C To partially diagonalize the bidiagonal matrix C C |q(1) e(1) 0 ... 0 | C | 0 q(2) e(2) . | C J = | . . | (1) C | . e(MIN(M,N)-1)| C | 0 ... ... q(MIN(M,N)) | C C using QR or QL iterations in such a way that J is split into C unreduced bidiagonal submatrices whose singular values are either C all larger than a given bound or are all smaller than (or equal C to) this bound. The left- and right-hand Givens rotations C performed on J (corresponding to each QR or QL iteration step) may C be optionally accumulated in the arrays U and V. C C ARGUMENTS C C Mode Parameters C C JOBU CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix U the left-hand Givens rotations, as follows: C = 'N': Do not form U; C = 'I': U is initialized to the M-by-MIN(M,N) submatrix of C the unit matrix and the left-hand Givens rotations C are accumulated in U; C = 'U': The given matrix U is updated by the left-hand C Givens rotations used in the calculation. C C JOBV CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix V the right-hand Givens rotations, as follows: C = 'N': Do not form V; C = 'I': V is initialized to the N-by-MIN(M,N) submatrix of C the unit matrix and the right-hand Givens C rotations are accumulated in V; C = 'U': The given matrix V is updated by the right-hand C Givens rotations used in the calculation. C C Input/Output Parameters C C M (input) INTEGER C The number of rows in matrix U. M >= 0. C C N (input) INTEGER C The number of rows in matrix V. N >= 0. C C RANK (input/output) INTEGER C On entry, if RANK < 0, then the rank of matrix J is C computed by the routine as the number of singular values C larger than THETA. C Otherwise, RANK must specify the rank of matrix J. C RANK <= MIN(M,N). C On exit, if RANK < 0 on entry, then RANK contains the C computed rank of J. That is, the number of singular C values of J larger than THETA. C Otherwise, the user-supplied value of RANK may be C changed by the routine on exit if the RANK-th and the C (RANK+1)-th singular values of J are considered to be C equal. See also the parameter TOL. C C THETA (input/output) DOUBLE PRECISION C On entry, if RANK < 0, then THETA must specify an upper C bound on the smallest singular values of J. THETA >= 0.0. C Otherwise, THETA must specify an initial estimate (t say) C for computing an upper bound such that precisely RANK C singular values are greater than this bound. C If THETA < 0.0, then t is computed by the routine. C On exit, if RANK >= 0 on entry, then THETA contains the C computed upper bound such that precisely RANK singular C values of J are greater than THETA + TOL. C Otherwise, THETA is unchanged. C C Q (input/output) DOUBLE PRECISION array, dimension C (MIN(M,N)) C On entry, this array must contain the diagonal elements C q(1),q(2),...,q(MIN(M,N)) of the bidiagonal matrix J. That C is, Q(i) = J(i,i) for i = 1,2,...,MIN(M,N). C On exit, this array contains the leading diagonal of the C transformed bidiagonal matrix J. C C E (input/output) DOUBLE PRECISION array, dimension C (MIN(M,N)-1) C On entry, this array must contain the superdiagonal C elements e(1),e(2),...,e(MIN(M,N)-1) of the bidiagonal C matrix J. That is, E(k) = J(k,k+1) for k = 1,2,..., C MIN(M,N)-1. C On exit, this array contains the superdiagonal of the C transformed bidiagonal matrix J. C C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) C On entry, if JOBU = 'U', the leading M-by-MIN(M,N) part C of this array must contain a left transformation matrix C applied to the original matrix of the problem, and C on exit, the leading M-by-MIN(M,N) part of this array C contains the product of the input matrix U and the C left-hand Givens rotations. C On exit, if JOBU = 'I', then the leading M-by-MIN(M,N) C part of this array contains the matrix of accumulated C left-hand Givens rotations used. C If JOBU = 'N', the array U is not referenced and can be C supplied as a dummy array (i.e. set parameter LDU = 1 and C declare this array to be U(1,1) in the calling program). C C LDU INTEGER C The leading dimension of array U. If JOBU = 'U' or C JOBU = 'I', LDU >= MAX(1,M); if JOBU = 'N', LDU >= 1. C C V (input/output) DOUBLE PRECISION array, dimension (LDV,*) C On entry, if JOBV = 'U', the leading N-by-MIN(M,N) part C of this array must contain a right transformation matrix C applied to the original matrix of the problem, and C on exit, the leading N-by-MIN(M,N) part of this array C contains the product of the input matrix V and the C right-hand Givens rotations. C On exit, if JOBV = 'I', then the leading N-by-MIN(M,N) C part of this array contains the matrix of accumulated C right-hand Givens rotations used. C If JOBV = 'N', the array V is not referenced and can be C supplied as a dummy array (i.e. set parameter LDV = 1 and C declare this array to be V(1,1) in the calling program). C C LDV INTEGER C The leading dimension of array V. If JOBV = 'U' or C JOBV = 'I', LDV >= MAX(1,N); if JOBV = 'N', LDV >= 1. C C INUL (input/output) LOGICAL array, dimension (MIN(M,N)) C On entry, the leading MIN(M,N) elements of this array must C be set to .FALSE. unless the i-th columns of U (if JOBU = C 'U') and V (if JOBV = 'U') already contain a computed base C vector of the desired singular subspace of the original C matrix, in which case INUL(i) must be set to .TRUE. C for 1 <= i <= MIN(M,N). C On exit, the indices of the elements of this array with C value .TRUE. indicate the indices of the diagonal entries C of J which belong to those bidiagonal submatrices whose C singular values are all less than or equal to THETA. C C Tolerances C C TOL DOUBLE PRECISION C This parameter defines the multiplicity of singular values C by considering all singular values within an interval of C length TOL as coinciding. TOL is used in checking how many C singular values are less than or equal to THETA. Also in C computing an appropriate upper bound THETA by a bisection C method, TOL is used as a stopping criterion defining the C minimum (absolute) subinterval width. TOL is also taken C as an absolute tolerance for negligible elements in the C QR/QL iterations. If the user sets TOL to be less than or C equal to 0, then the tolerance is taken as C EPS * MAX(ABS(Q(i)), ABS(E(k))), where EPS is the C machine precision (see LAPACK Library routine DLAMCH), C i = 1,2,...,MIN(M,N) and k = 1,2,...,MIN(M,N)-1. C C RELTOL DOUBLE PRECISION C This parameter specifies the minimum relative width of an C interval. When an interval is narrower than TOL, or than C RELTOL times the larger (in magnitude) endpoint, then it C is considered to be sufficiently small and bisection has C converged. If the user sets RELTOL to be less than C BASE * EPS, where BASE is machine radix and EPS is machine C precision (see LAPACK Library routine DLAMCH), then the C tolerance is taken as BASE * EPS. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1,6*MIN(M,N)-5), if JOBU = 'I' or 'U', or C JOBV = 'I' or 'U'; C LDWORK >= MAX(1,4*MIN(M,N)-3), if JOBU = 'N' and C JOBV = 'N'. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: if the rank of the bidiagonal matrix J (as specified C by the user) has been lowered because a singular C value of multiplicity larger than 1 was found. 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; this includes values like RANK > MIN(M,N), or C THETA < 0.0 and RANK < 0; C = 1: if the maximum number of QR/QL iteration steps C (30*MIN(M,N)) has been exceeded. C C METHOD C C If the upper bound THETA is not specified by the user, then it is C computed by the routine (using a bisection method) such that C precisely (MIN(M,N) - RANK) singular values of J are less than or C equal to THETA + TOL. C C The method used by the routine (see [1]) then proceeds as follows. C C The unreduced bidiagonal submatrices of J(j), where J(j) is the C transformed bidiagonal matrix after the j-th iteration step, are C classified into the following three classes: C C - C1 contains the bidiagonal submatrices with all singular values C > THETA, C - C2 contains the bidiagonal submatrices with all singular values C <= THETA and C - C3 contains the bidiagonal submatrices with singular values C > THETA and also singular values <= THETA. C C If C3 is empty, then the partial diagonalization is complete, and C RANK is the sum of the dimensions of the bidiagonal submatrices of C C1. C Otherwise, QR or QL iterations are performed on each bidiagonal C submatrix of C3, until this bidiagonal submatrix has been split C into two bidiagonal submatrices. These two submatrices are then C classified and the iterations are restarted. C If the upper left diagonal element of the bidiagonal submatrix is C larger than its lower right diagonal element, then QR iterations C are performed, else QL iterations are used. The shift is taken as C the smallest diagonal element of the bidiagonal submatrix (in C magnitude) unless its value exceeds THETA, in which case it is C taken as zero. C C REFERENCES C C [1] Van Huffel, S., Vandewalle, J. and Haegemans, A. C An efficient and reliable algorithm for computing the C singular subspace of a matrix associated with its smallest C singular values. C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. C C NUMERICAL ASPECTS C C The algorithm is backward stable. C C To avoid overflow, matrix J is scaled so that its largest element C is no greater than overflow**(1/2) * underflow**(1/4) in absolute C value (and not much smaller than that, for maximal accuracy). C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. C Supersedes Release 2.0 routine MB04QD by S. Van Huffel, Katholieke C University Leuven, Belgium. C C REVISIONS C C July 10, 1997. V. Sima. C November 25, 1997. V. Sima: Setting INUL(K) = .TRUE. when handling C 2-by-2 submatrix. C C KEYWORDS C C Bidiagonal matrix, orthogonal transformation, singular values. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TEN, HNDRD PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0, $ HNDRD = 100.0D0 ) DOUBLE PRECISION MEIGTH PARAMETER ( MEIGTH = -0.125D0 ) INTEGER MAXITR PARAMETER ( MAXITR = 30 ) C .. Scalar Arguments .. CHARACTER JOBU, JOBV INTEGER INFO, IWARN, LDU, LDV, LDWORK, M, N, RANK DOUBLE PRECISION RELTOL, THETA, TOL C .. Array Arguments .. LOGICAL INUL(*) DOUBLE PRECISION DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*) C .. Local Scalars .. LOGICAL LJOBUA, LJOBUI, LJOBVA, LJOBVI, NOC12, QRIT INTEGER I, I1, IASCL, INFO1, ITER, J, K, MAXIT, NUMEIG, $ OLDI, OLDK, P, R DOUBLE PRECISION COSL, COSR, EPS, PIVMIN, RMAX, RMIN, SAFEMN, $ SHIFT, SIGMA, SIGMN, SIGMX, SINL, SINR, SMAX, $ SMLNUM, THETAC, THRESH, TOLABS, TOLREL, X C .. External Functions .. LOGICAL LSAME INTEGER MB03ND DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME, MB03ND C .. External Subroutines .. EXTERNAL DLASET, DLASV2, DROT, DSCAL, MB02NY, MB03MD, $ MB04YW, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT C .. Executable Statements .. C P = MIN( M, N ) INFO = 0 IWARN = 0 LJOBUI = LSAME( JOBU, 'I' ) LJOBVI = LSAME( JOBV, 'I' ) LJOBUA = LJOBUI.OR.LSAME( JOBU, 'U' ) LJOBVA = LJOBVI.OR.LSAME( JOBV, 'U' ) C C Test the input scalar arguments. C IF( .NOT.LJOBUA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LJOBVA .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( RANK.GT.P ) THEN INFO = -5 ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN INFO = -6 ELSE IF( .NOT.LJOBUA .AND. LDU.LT.1 .OR. $ LJOBUA .AND. LDU.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( .NOT.LJOBVA .AND. LDV.LT.1 .OR. $ LJOBVA .AND. LDV.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( ( ( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 6*P-5 ) ) $ .OR.(.NOT.( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 4*P-3 ) ) $ ) THEN INFO = -17 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB04YD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( P.EQ.0 ) THEN IF ( RANK.GE.0 ) $ THETA = ZERO RANK = 0 RETURN END IF C C Set tolerances and machine parameters. C TOLABS = TOL TOLREL = RELTOL SMAX = ABS( Q(P) ) C DO 20 J = 1, P - 1 SMAX = MAX( SMAX, ABS( Q(J) ), ABS( E(J) ) ) 20 CONTINUE C SAFEMN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Epsilon' ) IF ( TOLABS.LE.ZERO ) TOLABS = EPS*SMAX X = DLAMCH( 'Base' )*EPS IF ( TOLREL.LE.X ) TOLREL = X THRESH = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )*EPS SMLNUM = SAFEMN / EPS RMIN = SQRT( SMLNUM ) RMAX = MIN( ONE / RMIN, ONE / SQRT( SQRT( SAFEMN ) ) ) THETAC = THETA C C Scale the matrix to allowable range, if necessary, and set PIVMIN, C using the squares of Q and E (saved in DWORK). C IASCL = 0 IF( SMAX.GT.ZERO .AND. SMAX.LT.RMIN ) THEN IASCL = 1 SIGMA = RMIN / SMAX ELSE IF( SMAX.GT.RMAX ) THEN IASCL = 1 SIGMA = RMAX / SMAX END IF IF( IASCL.EQ.1 ) THEN CALL DSCAL( P, SIGMA, Q, 1 ) CALL DSCAL( P-1, SIGMA, E, 1 ) THETAC = SIGMA*THETA TOLABS = SIGMA*TOLABS END IF C PIVMIN = Q(P)**2 DWORK(P) = PIVMIN C DO 40 J = 1, P - 1 DWORK(J) = Q(J)**2 DWORK(P+J) = E(J)**2 PIVMIN = MAX( PIVMIN, DWORK(J), DWORK(P+J) ) 40 CONTINUE C PIVMIN = MAX( PIVMIN*SAFEMN, SAFEMN ) C C Initialize U and/or V to the identity matrix, if needed. C IF ( LJOBUI ) $ CALL DLASET( 'Full', M, P, ZERO, ONE, U, LDU ) IF ( LJOBVI ) $ CALL DLASET( 'Full', N, P, ZERO, ONE, V, LDV ) C C Estimate THETA (if not fixed by the user), and set R. C IF ( RANK.GE.0 ) THEN J = P - RANK CALL MB03MD( P, J, THETAC, Q, E, DWORK(1), DWORK(P+1), PIVMIN, $ TOLABS, TOLREL, IWARN, INFO1 ) THETA = THETAC IF ( IASCL.EQ.1 ) THETA = THETA / SIGMA IF ( J.LE.0 ) $ RETURN R = P - J ELSE R = P - MB03ND( P, THETAC, DWORK, DWORK(P+1), PIVMIN, INFO1 ) END IF C RANK = P C DO 60 I = 1, P IF ( INUL(I) ) RANK = RANK - 1 60 CONTINUE C C From now on K is the smallest known index such that the elements C of the bidiagonal matrix J with indices larger than K belong to C1 C or C2. C RANK = P - SUM(dimensions of known bidiagonal matrices of C2). C K = P OLDI = -1 OLDK = -1 ITER = 0 MAXIT = MAXITR*P C WHILE ( C3 NOT EMPTY ) DO 80 IF ( RANK.GT.R .AND. K.GT.0 ) THEN C WHILE ( K.GT.0 .AND. INUL(K) ) DO C C Search for the rightmost index of a bidiagonal submatrix, C not yet classified. C 100 IF ( K.GT.0 ) THEN IF ( INUL(K) ) THEN K = K - 1 GO TO 100 END IF END IF C END WHILE 100 C IF ( K.EQ.0 ) $ RETURN C NOC12 = .TRUE. C WHILE ((ITER < MAXIT).AND.(No bidiagonal matrix of C1 or C C2 found)) DO 120 IF ( ( ITER.LT.MAXIT ) .AND. NOC12 ) THEN C C Search for negligible Q(I) or E(I-1) (for I > 1) and find C the shift. C I = K X = ABS( Q(I) ) SHIFT = X C WHILE ABS( Q(I) ) > TOLABS .AND. ABS( E(I-1) ) > TOLABS ) DO 140 IF ( I.GT.1 ) THEN IF ( ( X.GT.TOLABS ).AND.( ABS( E(I-1) ).GT.TOLABS ) ) $ THEN I = I - 1 X = ABS( Q(I) ) IF ( X.LT.SHIFT ) SHIFT = X GO TO 140 END IF END IF C END WHILE 140 C C Classify the bidiagonal submatrix (of order J) found. C J = K - I + 1 IF ( ( X.LE.TOLABS ) .OR. ( K.EQ.I ) ) THEN NOC12 = .FALSE. ELSE NUMEIG = MB03ND( J, THETAC, DWORK(I), DWORK(P+I), PIVMIN, $ INFO1 ) IF ( NUMEIG.GE.J .OR. NUMEIG.LE.0 ) NOC12 = .FALSE. END IF IF ( NOC12 ) THEN IF ( J.EQ.2 ) THEN C C Handle separately the 2-by-2 submatrix. C CALL DLASV2( Q(I), E(I), Q(K), SIGMN, SIGMX, SINR, $ COSR, SINL, COSL ) Q(I) = SIGMX Q(K) = SIGMN E(I) = ZERO RANK = RANK - 1 INUL(K) = .TRUE. NOC12 = .FALSE. C C Update U and/or V, if needed. C IF( LJOBUA ) $ CALL DROT( M, U(1,I), 1, U(1,K), 1, COSL, SINL ) IF( LJOBVA ) $ CALL DROT( N, V(1,I), 1, V(1,K), 1, COSR, SINR ) ELSE C C If working on new submatrix, choose QR or C QL iteration. C IF ( I.NE.OLDI .OR. K.NE.OLDK ) $ QRIT = ABS( Q(I) ).GE.ABS( Q(K) ) OLDI = I IF ( QRIT ) THEN IF ( ABS( E(K-1) ).LE.THRESH*ABS( Q(K) ) ) $ E(K-1) = ZERO ELSE IF ( ABS( E(I) ).LE.THRESH*ABS( Q(I) ) ) $ E(I) = ZERO END IF C CALL MB04YW( QRIT, LJOBUA, LJOBVA, M, N, I, K, SHIFT, $ Q, E, U, LDU, V, LDV, DWORK(2*P) ) C IF ( QRIT ) THEN IF ( ABS( E(K-1) ).LE.TOLABS ) E(K-1) = ZERO ELSE IF ( ABS( E(I) ).LE.TOLABS ) E(I) = ZERO END IF DWORK(K) = Q(K)**2 C DO 160 I1 = I, K - 1 DWORK(I1) = Q(I1)**2 DWORK(P+I1) = E(I1)**2 160 CONTINUE C ITER = ITER + 1 END IF END IF GO TO 120 END IF C END WHILE 120 C IF ( ITER.GE.MAXIT ) THEN INFO = 1 GO TO 200 END IF C IF ( X.LE.TOLABS ) THEN C C Split at negligible diagonal element ABS( Q(I) ) <= TOLABS. C CALL MB02NY( LJOBUA, LJOBVA, M, N, I, K, Q, E, U, LDU, V, $ LDV, DWORK(2*P) ) INUL(I) = .TRUE. RANK = RANK - 1 ELSE C C A negligible superdiagonal element ABS( E(I-1) ) <= TOL C has been found, the corresponding bidiagonal submatrix C belongs to C1 or C2. Treat this bidiagonal submatrix. C IF ( J.GE.2 ) THEN IF ( NUMEIG.EQ.J ) THEN C DO 180 I1 = I, K INUL(I1) = .TRUE. 180 CONTINUE C RANK = RANK - J K = K - J ELSE K = I - 1 END IF ELSE IF ( X.LE.( THETAC + TOLABS ) ) THEN INUL(I) = .TRUE. RANK = RANK - 1 END IF K = K - 1 END IF OLDK = K END IF GO TO 80 END IF C END WHILE 80 C C If matrix was scaled, then rescale Q and E appropriately. C 200 CONTINUE IF( IASCL.EQ.1 ) THEN CALL DSCAL( P, ONE / SIGMA, Q, 1 ) CALL DSCAL( P-1, ONE / SIGMA, E, 1 ) END IF C RETURN C *** Last line of MB04YD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03AB.f0000644000000000000000000000013215012430707016141 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03AB.f0000644000175000017500000002013715012430707017340 0ustar00lilgelilge00000000000000 SUBROUTINE MB03AB( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, W1, $ W2, C1, S1, C2, S2 ) C C PURPOSE C C To compute two Givens rotations (C1,S1) and (C2,S2) such that the C orthogonal matrix C C [ Q 0 ] [ C1 S1 0 ] [ 1 0 0 ] C Z = [ ], Q := [ -S1 C1 0 ] * [ 0 C2 S2 ], C [ 0 I ] [ 0 0 1 ] [ 0 -S2 C2 ] C C makes the first column of the real Wilkinson double shift C polynomial of the product of matrices in periodic upper Hessenberg C form, stored in the array A, parallel to the first unit vector. C Only the rotation defined by C1 and S1 is needed for the real C Wilkinson single shift polynomial (see the SLICOT Library routines C MB03BE or MB03BF). The shifts are defined based on the eigenvalues C (computed externally by the SLICOT Library routine MB03BB) of the C trailing 2-by-2 submatrix of the matrix product. See the C definitions of the arguments W1 and W2. C C ARGUMENTS C C Mode Parameters C C SHFT CHARACTER*1 C Specifies the number and type of shifts employed by the C shift polynomial, as follows: C = 'C': two complex conjugate shifts; C = 'D': two real identical shifts; C = 'R': two real shifts; C = 'S': one real shift. C When the eigenvalues are complex conjugate, this argument C must be set to 'C'. C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of the factors in the array A. C N >= 2, for a single shift polynomial; C N >= 3, for a double shift polynomial. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C AMAP(1) is the pointer to the Hessenberg matrix, defined C by A(:,:,AMAP(1)). C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input) DOUBLE PRECISION array, dimension (LDA1,LDA2,K) C The leading N-by-N-by-K part of this array must contain an C n-by-n product (implicitly represented by its K factors) C in periodic upper Hessenberg form. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= N. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= N. C C W1 (input) DOUBLE PRECISION C The real part of the first eigenvalue. C If SHFT = 'S', this argument is not used. C C W2 (input) DOUBLE PRECISION C The second eigenvalue, if both eigenvalues are real, else C the imaginary part of the complex conjugate pair. C C C1 (output) DOUBLE PRECISION C S1 (output) DOUBLE PRECISION C On exit, C1 and S1 contain the parameters for the first C Givens rotation. C C C2 (output) DOUBLE PRECISION C S2 (output) DOUBLE PRECISION C On exit, C2 and S2 contain the parameters for the second C Givens rotation. If SHFT = 'S', C2 = 1, S2 = 0. C C METHOD C C Givens rotations are properly computed and applied. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Nov. 2019. C C REVISIONS C C V. Sima, Oct. 2020. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER SHFT INTEGER K, LDA1, LDA2, N, SINV DOUBLE PRECISION C1, C2, S1, S2, W1, W2 C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*) C .. Local Scalars .. LOGICAL ISR, SGLE INTEGER AI, I DOUBLE PRECISION ALPHA, BETA, C23, C3, CX, CY, DELTA, DUM, GAMMA, $ P, S3, SX, SY, TEMP, TMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARTG C C .. Executable Statements .. C SGLE = LSAME( SHFT, 'S' ) AI = AMAP(1) CALL DLARTG( A(2,1,AI), ONE, C1, S1, TEMP ) CALL DLARTG( A(1,1,AI), TEMP, C2, S2, TMP ) C DO 10 I = K, 2, -1 AI = AMAP(I) IF ( S(AI).EQ.SINV ) THEN ALPHA = A(1,1,AI)*C2 + A(1,2,AI)*C1*S2 BETA = A(2,2,AI)*C1 GAMMA = S1 CALL DLARTG( BETA, GAMMA, C1, S1, TEMP ) CALL DLARTG( ALPHA, TEMP*S2, C2, S2, DUM ) ELSE ALPHA = S2*A(1,1,AI) BETA = C1*C2*A(2,2,AI) - S2*A(1,2,AI) GAMMA = S1*A(2,2,AI) CX = C1 SX = S1 CALL DLARTG( CX, GAMMA, C1, S1, TEMP ) TEMP = C1*BETA + SX*C2*S1 CALL DLARTG( TEMP, ALPHA, C2, S2, DUM ) END IF 10 CONTINUE C ISR = .NOT.LSAME( SHFT, 'C' ) IF ( ISR ) THEN CALL DLARTG( C2 - W2*S1*S2, C1*S2, C2, S2, TEMP ) IF ( SGLE ) THEN C1 = C2 S1 = S2 C2 = ONE S2 = ZERO C C Return. C GO TO 30 ELSE C C Save C2 and S2 for the final use. C CX = C2 SX = S2 END IF ELSE TEMP = S1*S2 ALPHA = C2 - W1*TEMP BETA = C1*S2 GAMMA = W2*TEMP CALL DLARTG( BETA, GAMMA, C1, S1, TEMP ) CALL DLARTG( ALPHA, TEMP, C2, S2, DUM ) C C Save C1, S1, C2, and S2 for the final use. C CX = C1 SX = S1 CY = C2 SY = S2 S2 = C1*S2 END IF C I = 1 AI = AMAP(I) C ALPHA = A(1,2,AI)*S2 + A(1,1,AI)*C2 BETA = A(2,2,AI)*S2 + A(2,1,AI)*C2 GAMMA = A(3,2,AI)*S2 CALL DLARTG( GAMMA, ONE, C1, S1, TEMP ) CALL DLARTG( BETA, TEMP, C3, S3, DUM ) CALL DLARTG( ALPHA, C3*BETA + S3*TEMP, C2, S2, DUM ) C DO 20 I = K, 2, -1 AI = AMAP(I) IF ( S(AI).EQ.SINV ) THEN TEMP = C1*S3 ALPHA = ( A(1,3,AI)*TEMP + A(1,2,AI)*C3 )*S2 + A(1,1,AI)*C2 BETA = ( A(2,3,AI)*TEMP + A(2,2,AI)*C3 )*S2 GAMMA = A(3,3,AI)*C1 DELTA = S1 CALL DLARTG( GAMMA, DELTA, C1, S1, TEMP ) TEMP = TEMP*S2*S3 CALL DLARTG( BETA, TEMP, C3, S3, TMP ) CALL DLARTG( ALPHA, TMP, C2, S2, DUM ) ELSE C23 = C2*C3 TMP = C2*S3 ALPHA = C1*C3*A(3,3,AI) - S3*A(2,3,AI) BETA = S1*C3 GAMMA = C1*TMP*A(3,3,AI) + C23*A(2,3,AI) - S2*A(1,3,AI) DELTA = S1*TMP TMP = C1 CALL DLARTG( TMP, S1*A(3,3,AI), C1, S1, DUM ) TEMP = ALPHA*C1 + BETA*S1 CALL DLARTG( TEMP, S3*A(2,2,AI), C3, S3, TMP ) TEMP = ( C23*A(2,2,AI) - S2*A(1,2,AI) )*C3 + $ ( GAMMA*C1 + DELTA*S1 )*S3 CALL DLARTG( TEMP, S2*A(1,1,AI), C2, S2, DUM ) END IF 20 CONTINUE C C Last step: let the rotations collap into the first factor. C IF ( ISR ) THEN TEMP = W1*S1*S3 ALPHA = C2 - CX*TEMP*S2 BETA = ( C3 - SX*TEMP )*S2 GAMMA = C1*S2*S3 ELSE P = S1*S3 ALPHA = C2 + ( W2*SX*SY - W1*CY )*P*S2 BETA = C3 - W1*CX*SY*P GAMMA = C1*S3 P = S2 END IF CALL DLARTG( BETA, GAMMA, C2, S2, TEMP ) IF ( .NOT.ISR ) $ TEMP = TEMP*P CALL DLARTG( ALPHA, TEMP, C1, S1, DUM ) C 30 CONTINUE RETURN C *** Last line of MB03AB *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02HD.f0000644000000000000000000000013215012430707016151 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02HD.f0000644000175000017500000004533115012430707017353 0ustar00lilgelilge00000000000000 SUBROUTINE MB02HD( TRIU, K, L, M, ML, N, NU, P, S, TC, LDTC, TR, $ LDTR, RB, LDRB, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute, for a banded K*M-by-L*N block Toeplitz matrix T with C block size (K,L), specified by the nonzero blocks of its first C block column TC and row TR, a LOWER triangular matrix R (in band C storage scheme) such that C T T C T T = R R . (1) C C It is assumed that the first MIN(M*K, N*L) columns of T are C linearly independent. C C By subsequent calls of this routine, the matrix R can be computed C block column by block column. C C ARGUMENTS C C Mode Parameters C C TRIU CHARACTER*1 C Specifies the structure, if any, of the last blocks in TC C and TR, as follows: C = 'N': TC and TR have no special structure; C = 'T': TC and TR are upper and lower triangular, C respectively. Depending on the block sizes, two C different shapes of the last blocks in TC and TR C are possible, as illustrated below: C C 1) TC TR 2) TC TR C C x x x x 0 0 x x x x x 0 0 0 C 0 x x x x 0 0 x x x x x 0 0 C 0 0 x x x x 0 0 x x x x x 0 C 0 0 0 x x x C C Input/Output Parameters C C K (input) INTEGER C The number of rows in the blocks of T. K >= 0. C C L (input) INTEGER C The number of columns in the blocks of T. L >= 0. C C M (input) INTEGER C The number of blocks in the first block column of T. C M >= 1. C C ML (input) INTEGER C The lower block bandwidth, i.e., ML + 1 is the number of C nonzero blocks in the first block column of T. C 0 <= ML < M and (ML + 1)*K >= L and C if ( M*K <= N*L ), ML >= M - INT( ( M*K - 1 )/L ) - 1; C ML >= M - INT( M*K/L ) or C MOD( M*K, L ) >= K; C if ( M*K >= N*L ), ML*K >= N*( L - K ). C C N (input) INTEGER C The number of blocks in the first block row of T. C N >= 1. C C NU (input) INTEGER C The upper block bandwidth, i.e., NU + 1 is the number of C nonzero blocks in the first block row of T. C If TRIU = 'N', 0 <= NU < N and C (M + NU)*L >= MIN( M*K, N*L ); C if TRIU = 'T', MAX(1-ML,0) <= NU < N and C (M + NU)*L >= MIN( M*K, N*L ). C C P (input) INTEGER C The number of previously computed block columns of R. C P*L < MIN( M*K,N*L ) + L and P >= 0. C C S (input) INTEGER C The number of block columns of R to compute. C (P+S)*L < MIN( M*K,N*L ) + L and S >= 0. C C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) C On entry, if P = 0, the leading (ML+1)*K-by-L part of this C array must contain the nonzero blocks in the first block C column of T. C C LDTC INTEGER C The leading dimension of the array TC. C LDTC >= MAX(1,(ML+1)*K), if P = 0. C C TR (input) DOUBLE PRECISION array, dimension (LDTR,NU*L) C On entry, if P = 0, the leading K-by-NU*L part of this C array must contain the 2nd to the (NU+1)-st blocks of C the first block row of T. C C LDTR INTEGER C The leading dimension of the array TR. C LDTR >= MAX(1,K), if P = 0. C C RB (output) DOUBLE PRECISION array, dimension C (LDRB,MIN( S*L,MIN( M*K,N*L )-P*L )) C On exit, if INFO = 0 and TRIU = 'N', the leading C MIN( ML+NU+1,N )*L-by-MIN( S*L,MIN( M*K,N*L )-P*L ) part C of this array contains the (P+1)-th to (P+S)-th block C column of the lower R factor (1) in band storage format. C On exit, if INFO = 0 and TRIU = 'T', the leading C MIN( (ML+NU)*L+1,N*L )-by-MIN( S*L,MIN( M*K,N*L )-P*L ) C part of this array contains the (P+1)-th to (P+S)-th block C column of the lower R factor (1) in band storage format. C For further details regarding the band storage scheme see C the documentation of the LAPACK routine DPBTF2. C C LDRB INTEGER C The leading dimension of the array RB. C LDRB >= MAX( MIN( ML+NU+1,N )*L,1 ), if TRIU = 'N'; C LDRB >= MAX( MIN( (ML+NU)*L+1,N*L ),1 ), if TRIU = 'T'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -17, DWORK(1) returns the minimum C value of LDWORK. C The first 1 + 2*MIN( ML+NU+1,N )*L*(K+L) elements of DWORK C should be preserved during successive calls of the routine. C C LDWORK INTEGER C The length of the array DWORK. C Let x = MIN( ML+NU+1,N ), then C LDWORK >= 1 + MAX( x*L*L + (2*NU+1)*L*K, C 2*x*L*(K+L) + (6+x)*L ), if P = 0; C LDWORK >= 1 + 2*x*L*(K+L) + (6+x)*L, if P > 0. 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 = 1: the full rank condition for the first MIN(M*K, N*L) C columns of T is (numerically) violated. C C METHOD C C Householder transformations and modified hyperbolic rotations C are used in the Schur algorithm [1], [2]. C C REFERENCES C C [1] Kailath, T. and Sayed, A. C Fast Reliable Algorithms for Matrices with Structure. C SIAM Publications, Philadelphia, 1999. C C [2] Kressner, D. and Van Dooren, P. C Factorizations and linear system solvers for matrices with C Toeplitz structure. C SLICOT Working Note 2000-2, 2000. C C NUMERICAL ASPECTS C C The implemented method yields a factor R which has comparable C accuracy with the Cholesky factor of T^T * T. C The algorithm requires C 2 2 C O( L *K*N*( ML + NU ) + N*( ML + NU )*L *( L + K ) ) C C floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, June 2001. C D. Kressner, Technical Univ. Berlin, Germany, July 2002. C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004, C Apr. 2011. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER TRIU INTEGER INFO, K, L, LDRB, LDTC, LDTR, LDWORK, M, ML, N, $ NU, P, S C .. Array Arguments .. DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,*), TC(LDTC,*), $ TR(LDTR,*) C .. Local Scalars .. CHARACTER STRUCT INTEGER COL2, HEAD, I, IERR, J, KK, LEN, LEN2, LENC, $ LENL, LENR, NB, NBMIN, PDC, PDR, PDW, PFR, PNR, $ POSR, PRE, PT, RNK, SIZR, STPS, WRKMIN, WRKOPT, $ X LOGICAL LQUERY, LTRI C .. Local Arrays .. INTEGER IPVT(1) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL ILAENV, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGELQF, DGEQRF, DLACPY, DLASET, $ DORGQR, MA02AD, MB02CU, MB02CV, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, MOD C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 LTRI = LSAME( TRIU, 'T' ) X = MIN( ML + NU + 1, N ) LENR = X*L IF ( LTRI ) THEN SIZR = MIN( ( ML + NU )*L + 1, N*L ) ELSE SIZR = LENR END IF IF ( P.EQ.0 ) THEN WRKMIN = 1 + MAX( LENR*L + ( 2*NU + 1 )*L*K, $ 2*LENR*( K + L ) + ( 6 + X )*L ) ELSE WRKMIN = 1 + 2*LENR*( K + L ) + ( 6 + X )*L END IF POSR = 1 C C Check the scalar input parameters. C IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN INFO = -1 ELSE IF ( K.LT.0 ) THEN INFO = -2 ELSE IF ( L.LT.0 ) THEN INFO = -3 ELSE IF ( M.LT.1 ) THEN INFO = -4 ELSE IF ( ML.GE.M .OR. ( ML + 1 )*K.LT.L .OR. ( M*K.LE.N*L .AND. $ ( ( ML.LT.M - INT( ( M*K - 1 )/L ) - 1 ) .OR. $ ( ML.LT.M - INT( M*K/L ).AND.MOD( M*K, L ).LT.K ) ) ) $ .OR. ( M*K.GE.N*L .AND. ML*K.LT.N*( L - K ) ) ) THEN INFO = -5 ELSE IF ( N.LT.1 ) THEN INFO = -6 ELSE IF ( NU.GE.N .OR. NU.LT.0 .OR. ( LTRI .AND. NU.LT.1-ML ) .OR. $ (M + NU)*L.LT.MIN( M*K, N*L ) ) THEN INFO = -7 ELSE IF ( P.LT.0 .OR. ( P*L - L ).GE.MIN( M*K, N*L ) ) THEN INFO = -8 ELSE IF ( S.LT.0 .OR. ( P + S - 1 )*L.GE.MIN( M*K, N*L ) ) THEN INFO = -9 ELSE IF ( P.EQ.0 .AND. LDTC.LT.MAX( 1, ( ML + 1 )*K ) ) THEN INFO = -11 ELSE IF ( P.EQ.0 .AND. LDTR.LT.MAX( 1, K ) ) THEN INFO = -13 ELSE IF ( LDRB.LT.MAX( SIZR, 1 ) ) THEN INFO = 15 ELSE LQUERY = LDWORK.EQ.-1 IF( P.EQ.0 ) THEN LENC = ( ML + 1 )*K LENL = MAX( ML + 1 + MIN( NU, N - M ), 0 ) PDW = ( LENR + LENC )*L + 1 IF ( LQUERY ) THEN CALL DGEQRF( LENC, L, DWORK, LENC, DWORK, DWORK, -1, $ IERR ) WRKOPT = MAX( 1, INT( DWORK(1) ) + PDW + L ) CALL DORGQR( LENC, L, L, DWORK, LENC, DWORK, DWORK, -1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW + L ) END IF END IF CALL DGELQF( LENR, L, DWORK, MAX( 1, LENR ), DWORK, DWORK, -1, $ IERR ) KK = 2*LENR*( K + L ) + 1 + 6*L WRKOPT = MAX( WRKOPT, KK + INT( DWORK(1) ) ) IF ( LDWORK.LT.WRKMIN .AND. .NOT.LQUERY ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = -17 END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02HD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF ( L*K*S.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C WRKOPT = 1 C C Compute the generator if P = 0. C IF ( P.EQ.0 ) THEN C C 1st column of the generator. C PDC = LENR*L + 1 C C QR decomposition of the nonzero blocks in TC. C CALL DLACPY( 'All', LENC, L, TC, LDTC, DWORK(PDC+1), LENC ) CALL DGEQRF( LENC, L, DWORK(PDC+1), LENC, DWORK(PDW+1), $ DWORK(PDW+L+1), LDWORK-PDW-L, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L+1) ) + PDW + L ) C C The R factor is the transposed of the first block in the C generator. C CALL MA02AD( 'Upper part', L, L, DWORK(PDC+1), LENC, DWORK(2), $ LENR ) C C Get the first block column of the Q factor. C CALL DORGQR( LENC, L, L, DWORK(PDC+1), LENC, DWORK(PDW+1), $ DWORK(PDW+L+1), LDWORK-PDW-L, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L+1) ) + PDW + L ) C C Construct a flipped copy of TC for faster multiplication. C PT = LENC - 2*K + 1 C DO 10 I = PDW + 1, PDW + ML*K*L, K*L CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) PT = PT - K 10 CONTINUE C C Multiply T^T with the first block column of Q. C PDW = I PDR = L + 2 LEN = NU*L CALL DLASET( 'All', LENR-L, L, ZERO, ZERO, DWORK(PDR), LENR ) C DO 20 I = 1, ML + 1 CALL DGEMM( 'Transpose', 'NonTranspose', MIN( I-1, N-1 )*L, $ L, K, ONE, DWORK(PDW), K, DWORK(PDC+1), LENC, $ ONE, DWORK(PDR), LENR ) IF ( LEN.GT.0 ) THEN CALL DGEMM( 'Transpose', 'NonTranspose', LEN, L, K, ONE, $ TR, LDTR, DWORK(PDC+1), LENC, ONE, $ DWORK(PDR+(I-1)*L), LENR ) END IF PDW = PDW - K*L PDC = PDC + K IF ( I.GE.N-NU ) LEN = LEN - L 20 CONTINUE C C Copy the first block column to R. C IF ( LTRI ) THEN C DO 30 I = 1, L CALL DCOPY( MIN( SIZR, N*L - I + 1 ), $ DWORK(( I - 1 )*LENR + I + 1), 1, RB(1,POSR), $ 1 ) POSR = POSR + 1 30 CONTINUE C ELSE C DO 40 I = 1, L CALL DCOPY( LENR-I+1, DWORK(( I - 1 )*LENR + I + 1), 1, $ RB(1,POSR), 1 ) IF ( LENR.LT.N*L .AND. I.GT.1 ) THEN CALL DLASET( 'All', I-1, 1, ZERO, ZERO, $ RB(LENR-I+2,POSR), LDRB ) END IF POSR = POSR + 1 40 CONTINUE C END IF C C Quick return if N = 1. C IF ( N.EQ.1 ) THEN DWORK(1) = DBLE( WRKOPT ) RETURN END IF C C 2nd column of the generator. C PDR = LENR*L + 1 CALL MA02AD( 'All', K, NU*L, TR, LDTR, DWORK(PDR+1), LENR ) CALL DLASET( 'All', LENR-NU*L, K, ZERO, ZERO, $ DWORK(PDR+NU*L+1), LENR ) C C 3rd column of the generator. C PNR = PDR + LENR*K CALL DLACPY( 'All', LENR-L, L, DWORK(L+2), LENR, DWORK(PNR+1), $ LENR ) CALL DLASET( 'All', L, L, ZERO, ZERO, DWORK(PNR+LENR-L+1), $ LENR ) C C 4th column of the generator. C PFR = PNR + LENR*L C PDW = PFR + MOD( ( M - ML - 1 )*L, LENR ) PT = ML*K + 1 DO 50 I = 1, MIN( ML + 1, LENL ) CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW+1), $ LENR ) PT = PT - K PDW = PFR + MOD( PDW + L - PFR, LENR ) 50 CONTINUE PT = 1 DO 60 I = ML + 2, LENL CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW+1), $ LENR ) PT = PT + L PDW = PFR + MOD( PDW + L - PFR, LENR ) 60 CONTINUE PRE = 1 STPS = S - 1 ELSE PDR = LENR*L + 1 PNR = PDR + LENR*K PFR = PNR + LENR*L PRE = P STPS = S END IF C PDW = PFR + LENR*K HEAD = MOD( ( PRE - 1 )*L, LENR ) C C Determine block size for the involved block Householder C transformations. C NB = MIN( INT( ( LDWORK - ( PDW + 6*L ) )/LENR ), L ) NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, L, -1, -1 ) ) IF ( NB.LT.NBMIN ) NB = 0 C C Generator reduction process. C DO 90 I = PRE, PRE + STPS - 1 C C The 4th generator column is not used in the first (M-ML) steps. C IF ( I.LT.M-ML ) THEN COL2 = L ELSE COL2 = K + L END IF C KK = MIN( L, M*K - I*L ) CALL MB02CU( 'Column', KK, KK+K, COL2, NB, DWORK(2), LENR, $ DWORK(PDR+HEAD+1), LENR, DWORK(PNR+HEAD+1), LENR, $ RNK, IPVT, DWORK(PDW+1), ZERO, DWORK(PDW+6*L+1), $ LDWORK-PDW-6*L, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The rank condition is (numerically) not C satisfied. C INFO = 1 RETURN END IF C LEN = MAX( MIN( ( N - I )*L - KK, LENR - HEAD - KK ), 0 ) LEN2 = MAX( MIN( ( N - I )*L - LEN - KK, HEAD ), 0 ) IF ( LEN.EQ.( LENR - KK ) ) THEN STRUCT = TRIU ELSE STRUCT = 'N' END IF CALL MB02CV( 'Column', STRUCT, KK, LEN, KK+K, COL2, NB, -1, $ DWORK(2), LENR, DWORK(PDR+HEAD+1), LENR, $ DWORK(PNR+HEAD+1), LENR, DWORK(KK+2), LENR, $ DWORK(PDR+HEAD+KK+1), LENR, DWORK(PNR+HEAD+KK+1), $ LENR, DWORK(PDW+1), DWORK(PDW+6*L+1), $ LDWORK-PDW-6*L, IERR ) C IF ( ( N - I )*L.GE.LENR ) THEN STRUCT = TRIU ELSE STRUCT = 'N' END IF C CALL MB02CV( 'Column', STRUCT, KK, LEN2, KK+K, COL2, NB, -1, $ DWORK(2), LENR, DWORK(PDR+HEAD+1), LENR, $ DWORK(PNR+HEAD+1), LENR, DWORK(KK+LEN+2), LENR, $ DWORK(PDR+1), LENR, DWORK(PNR+1), LENR, $ DWORK(PDW+1), DWORK(PDW+6*L+1), $ LDWORK-PDW-6*L, IERR ) C CALL DLASET( 'All', L, K+COL2, ZERO, ZERO, DWORK(PDR+HEAD+1), $ LENR ) C C Copy current block column to R. C IF ( LTRI ) THEN C DO 70 J = 1, KK CALL DCOPY( MIN( SIZR, (N-I)*L-J+1 ), $ DWORK(( J - 1 )*LENR + J + 1), 1, $ RB(1,POSR), 1 ) POSR = POSR + 1 70 CONTINUE C ELSE C DO 80 J = 1, KK CALL DCOPY( MIN( SIZR-J+1, (N-I)*L-J+1 ), $ DWORK(( J - 1 )*LENR + J + 1), 1, $ RB(1,POSR), 1 ) IF ( LENR.LT.( N - I )*L .AND. J.GT.1 ) THEN CALL DLASET( 'All', J-1, 1, ZERO, ZERO, $ RB(MIN( SIZR-J+1, (N-I)*L-J+1 )+1,POSR), $ LDRB ) END IF POSR = POSR + 1 80 CONTINUE C END IF C HEAD = MOD( HEAD + L, LENR ) 90 CONTINUE C DWORK(1) = DBLE( WRKOPT ) RETURN C C *** Last line of MB02HD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10WD.f0000644000000000000000000000013215012430707016175 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB10WD.f0000644000175000017500000002176715012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE SB10WD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, $ D, LDD, F, LDF, H, LDH, TU, LDTU, TY, LDTY, $ AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO ) C C PURPOSE C C To compute the matrices of the H2 optimal controller C C | AK | BK | C K = |----|----|, C | CK | DK | C C from the state feedback matrix F and output injection matrix H as C determined by the SLICOT Library routine SB10VD. 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 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. Only the submatrix C B2 = B(:,M-M2+1:M) is used. 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. Only the submatrix C C2 = C(NP-NP2+1:NP,:) is used. 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. Only the submatrix C D22 = D(NP-NP2+1:NP,M-M2+1:M) is used. C C LDD INTEGER C The leading dimension of the array D. LDD >= max(1,NP). C C F (input) DOUBLE PRECISION array, dimension (LDF,N) C The leading NCON-by-N part of this array must contain the C state feedback matrix F. C C LDF INTEGER C The leading dimension of the array F. LDF >= max(1,NCON). C C H (input) DOUBLE PRECISION array, dimension (LDH,NMEAS) C The leading N-by-NMEAS part of this array must contain the C output injection matrix H. C C LDH INTEGER C The leading dimension of the array H. LDH >= max(1,N). C C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) C The leading M2-by-M2 part of this array must contain the C control transformation matrix TU, as obtained by the C SLICOT Library routine SB10UD. C C LDTU INTEGER C The leading dimension of the array TU. LDTU >= max(1,M2). C C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) C The leading NP2-by-NP2 part of this array must contain the C measurement transformation matrix TY, as obtained by the C SLICOT Library routine SB10UD. C C LDTY INTEGER C The leading dimension of the array TY. C LDTY >= max(1,NP2). 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 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 implements the formulas given in [1], [2]. C C REFERENCES C C [1] Zhou, K., Doyle, J.C., and Glover, K. C Robust and Optimal Control. C Prentice-Hall, Upper Saddle River, NJ, 1996. 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 NUMERICAL ASPECTS C C The accuracy of the result depends on the condition numbers of the C input and output transformations. 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 C KEYWORDS C C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal C regulator, robust 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, LDF, LDH, LDTU, LDTY, M, N, NCON, NMEAS, $ NP C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), $ D( LDD, * ), DK( LDDK, * ), F( LDF, * ), $ H( LDH, * ), TU( LDTU, * ), TY( LDTY, * ) C .. C .. Local Scalars .. INTEGER M1, M2, NP1, NP2 C .. C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -11 ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN INFO = -13 ELSE IF( LDF.LT.MAX( 1, M2 ) ) THEN INFO = -15 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN INFO = -19 ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN INFO = -21 ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN INFO = -23 ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN INFO = -25 ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN INFO = -27 ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN INFO = -29 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10WD', -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 ) RETURN C C Compute the transpose of D22*F . BK is used as workspace. C CALL DGEMM( 'T', 'T', N, NP2, M2, ONE, F, LDF, D( NP1+1, M1+1 ), $ LDD, ZERO, BK, LDBK ) C C Find AK = A + H*C2 + B2*F + H*D22*F . C CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, NP2, ONE, H, LDH, C( NP1+1, 1 ), LDC, $ ONE, AK, LDAK ) CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, $ F, LDF, ONE, AK, LDAK ) CALL DGEMM( 'N', 'T', N, N, NP2, ONE, H, LDH, BK, LDBK, ONE, AK, $ LDAK ) C C Find BK = -H*Ty . C CALL DGEMM( 'N', 'N', N, NP2, NP2, -ONE, H, LDH, TY, LDTY, ZERO, $ BK, LDBK ) C C Find CK = Tu*F . C CALL DGEMM( 'N', 'N', M2, N, M2, ONE, TU, LDTU, F, LDF, ZERO, CK, $ LDCK ) C C Find DK . C CALL DLASET( 'Full', M2, NP2, ZERO, ZERO, DK, LDDK ) C RETURN C *** Last line of SB10WD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB08FD.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB08FD.f0000644000175000017500000005362715012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC, $ D, LDD, NQ, NR, CR, LDCR, DR, LDDR, TOL, DWORK, $ LDWORK, IWARN, INFO ) C C PURPOSE C C To construct, for a given system G = (A,B,C,D), a feedback C matrix F and an orthogonal transformation matrix Z, such that C the systems C C Q = (Z'*(A+B*F)*Z, Z'*B, (C+D*F)*Z, D) C and C R = (Z'*(A+B*F)*Z, Z'*B, F*Z, I) C C provide a stable right coprime factorization of G in the form C -1 C G = Q * R , C C where G, Q and R are the corresponding transfer-function matrices. C The resulting state dynamics matrix of the systems Q and R has C eigenvalues lying inside a given stability domain. C The Z matrix is not explicitly computed. C C Note: If the given state-space representation is not stabilizable, C the unstabilizable part of the original system is automatically C deflated and the order of the systems Q and R is accordingly C reduced. 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 matrices C and CR. N >= 0. C C M (input) INTEGER C The dimension of input vector, i.e. the number of columns C of the matrices B, D and DR and the number of rows of the C matrices CR and DR. M >= 0. C C P (input) INTEGER C The dimension of output vector, i.e. the number of rows C of the matrices C and D. P >= 0. C C ALPHA (input) DOUBLE PRECISION array, dimension (2) C ALPHA(1) contains the desired stability degree to be C assigned for the eigenvalues of A+B*F, and ALPHA(2) C the stability margin. The eigenvalues outside the C ALPHA(2)-stability region will be assigned to have the C real parts equal to ALPHA(1) < 0 and unmodified C imaginary parts for a continuous-time system C (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1 C for a discrete-time system (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 NQ-by-NQ part of this array contains C the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the C state dynamics matrix of the numerator factor Q, in a C real Schur form. The trailing NR-by-NR part of this matrix C represents the state dynamics matrix of a minimal C realization of the denominator factor R. 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. C On exit, the leading NQ-by-M part of this array contains C the leading NQ-by-M part of the matrix Z'*B, the C input/state matrix of the numerator factor Q. The last C NR rows of this matrix form the input/state matrix of C a minimal realization of the denominator factor R. 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 C. C On exit, the leading P-by-NQ part of this array contains C the leading P-by-NQ part of the matrix (C+D*F)*Z, C the state/output matrix of the numerator factor Q. 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 input/output matrix. D represents also the input/output C matrix of the numerator factor Q. 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 factors Q and R. C Generally, NQ = N - NS, where NS is the number of C uncontrollable eigenvalues outside the stability region. C C NR (output) INTEGER C The order of the minimal realization of the factor R. C Generally, NR is the number of controllable eigenvalues C of A outside the stability region (the number of modified C eigenvalues). C C CR (output) DOUBLE PRECISION array, dimension (LDCR,N) C The leading M-by-NQ part of this array contains the C leading M-by-NQ part of the feedback matrix F*Z, which C moves the eigenvalues of A lying outside the ALPHA-stable C region to values which are on the ALPHA-stability C boundary. The last NR columns of this matrix form the C state/output matrix of a minimal realization of the C denominator factor R. C C LDCR INTEGER C The leading dimension of array CR. LDCR >= MAX(1,M). C C DR (output) DOUBLE PRECISION array, dimension (LDDR,M) C The leading M-by-M part of this array contains an C identity matrix representing the input/output matrix C of the denominator factor R. C C LDDR INTEGER C The leading dimension of array DR. LDDR >= MAX(1,M). 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 LWORK >= MAX( 1, N*(N+5), 5*M, 4*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 NORM(F) <= 10*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 C METHOD C C The subroutine is based on the factorization algorithm of [1]. C C REFERENCES C C [1] Varga A. C Coprime factors model reduction method based on C square-root balancing-free techniques. C System Analysis, Modelling and Simulation, C vol. 11, pp. 303-311, 1993. C C NUMERICAL ASPECTS C 3 C The algorithm requires no more than 14N floating point C operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, July 1998. C Based on the RASP routine RCFS. C C REVISIONS C C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. C Mar. 2003, May 2003, A. Varga, German Aerospace Center. C May 2003, V. Sima, Research Institute for Informatics, Bucharest. C Sep. 2005, A. Varga, German Aerospace Center. C C KEYWORDS C C Coprime factorization, eigenvalue, eigenvalue assignment, C feedback control, pole placement, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TEN, ZERO PARAMETER ( ONE = 1.0D0, TEN = 1.0D1, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO INTEGER INFO, IWARN, LDA, LDB, LDC, LDCR, LDD, LDDR, $ LDWORK, M, N, NQ, NR, P DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), ALPHA(*), B(LDB,*), C(LDC,*), $ CR(LDCR,*), D(LDD,*), DR(LDDR,*), DWORK(*) C .. Local Scalars .. LOGICAL DISCR INTEGER I, IB, IB1, J, K, KFI, KG, KW, KWI, KWR, KZ, L, $ L1, NB, NCUR, NCUR1, NFP, NLOW, NMOVES, NSUP DOUBLE PRECISION BNORM, CS, PR, RMAX, SM, SN, TOLER, WRKOPT, X, Y C .. Local Arrays .. DOUBLE PRECISION A2(2,2), Z(4,4) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 LOGICAL LSAME EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLAEXC, DLANV2, DLASET, DROT, $ SB01BY, TB01LD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT 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( P.LT.0 ) THEN INFO = -4 ELSE IF( ( DISCR .AND. ( ALPHA(1).LT.ZERO .OR. ALPHA(1).GE.ONE $ .OR. ALPHA(2).LT.ZERO .OR. ALPHA(2).GE.ONE ) ) $ .OR. $ ( .NOT.DISCR .AND. ( ALPHA(1).GE.ZERO .OR. ALPHA(2).GE.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( LDC.LT.MAX( 1, P ) ) THEN INFO = -11 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN INFO = -17 ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN INFO = -19 ELSE IF( LDWORK.LT.MAX( 1, N*(N+5), 5*M, 4*P ) ) THEN INFO = -22 END IF IF( INFO.NE.0 )THEN C C Error return. C CALL XERBLA( 'SB08FD', -INFO ) RETURN END IF C C Set DR = I and quick return if possible. C NR = 0 CALL DLASET( 'Full', M, M, ZERO, ONE, DR, LDDR ) IF( MIN( N, M ).EQ.0 ) THEN NQ = 0 DWORK(1) = ONE RETURN END IF C C Set F = 0 in the array CR. C CALL DLASET( 'Full', M, N, ZERO, ZERO, CR, LDCR ) C C Compute the norm of B and set the default tolerance if necessary. C BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) TOLER = TOL IF( TOLER.LE.ZERO ) $ TOLER = DBLE( N ) * BNORM * DLAMCH( 'Epsilon' ) IF( BNORM.LE.TOLER ) THEN NQ = 0 DWORK(1) = ONE RETURN END IF C C Compute the bound for the numerical stability condition. C RMAX = TEN * DLANGE( '1-norm', N, N, A, LDA, DWORK ) / BNORM C C Allocate working storage. C KZ = 1 KWR = KZ + N*N KWI = KWR + N KW = KWI + N 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 spectrum of A is C performed such that the leading NFP-by-NFP submatrix of A C corresponds to the "stable" eigenvalues which will be not C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A C corresponds to the "unstable" eigenvalues to be modified. C Apply the transformation to B and C: B <- Z'*B and C <- C*Z. C C Workspace needed: N*(N+2); C Additional workspace: need 3*N; C prefer larger. C CALL TB01LD( DICO, 'Stable', 'General', N, M, P, ALPHA(2), A, LDA, $ B, LDB, C, LDC, NFP, DWORK(KZ), N, DWORK(KWR), $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, INFO ) IF( INFO.NE.0 ) $ RETURN C WRKOPT = DWORK(KW) + DBLE( KW-1 ) C C Perform the pole assignment if there exist "unstable" eigenvalues. C NQ = N 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 WHILE (NLOW <= NSUP) DO 10 IF( NLOW.LE.NSUP ) THEN C C Main loop for assigning one or two poles. 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 L = NSUP - IB + 1 C C Save the last IB rows of B in G. C CALL DLACPY( 'Full', IB, M, B(L,1), LDB, DWORK(KG), IB ) C C Check the controllability of the last block. C IF( DLANGE( '1-norm', IB, M, DWORK(KG), IB, DWORK(KW) ) $ .LE.TOLER )THEN C C Deflate the uncontrollable block and resume the C main loop. C NSUP = NSUP - IB ELSE C C Form the IBxIB matrix A2 from the last diagonal block and C set the pole(s) to be assigned. C A2(1,1) = A(L,L) IF( IB.EQ.1 ) THEN SM = ALPHA(1) IF( DISCR ) SM = SIGN( ALPHA(1), A2(1,1) ) PR = ALPHA(1) ELSE A2(1,2) = A(L,NSUP) A2(2,1) = A(NSUP,L) A2(2,2) = A(NSUP,NSUP) SM = ALPHA(1) + ALPHA(1) PR = ALPHA(1)*ALPHA(1) IF( DISCR ) THEN X = A2(1,1) Y = SQRT( ABS( A2(1,2)*A2(2,1) ) ) SM = SM * X / DLAPY2( X, Y ) ELSE PR = PR - A2(1,2)*A2(2,1) END IF END IF C C Determine the M-by-IB feedback matrix FI which assigns C the selected IB poles for the pair (A2,G). C C Workspace needed: 5*M. C CALL SB01BY( IB, M, SM, PR, A2, DWORK(KG), DWORK(KFI), $ TOLER, DWORK(KW), INFO ) IF( INFO.NE.0 ) THEN C C Uncontrollable 2x2 block with double real eigenvalues C which due to roundoff appear as a pair of complex C conjugated eigenvalues. C One of them can be elliminated using the information C in DWORK(KFI) and DWORK(KFI+M). C CS = DWORK(KFI) SN = -DWORK(KFI+M) C C Apply the Givens transformation to A, B, C and F. C L1 = L + 1 CALL DROT( NSUP-L+1, A(L1,L), LDA, A(L,L), $ LDA, CS, SN ) CALL DROT( L1, A(1,L1), 1, A(1,L), 1, CS, SN ) CALL DROT( M, B(L1,1), LDB, B(L,1), LDB, CS, SN ) IF( P.GT.0 ) $ CALL DROT( P, C(1,L1), 1, C(1,L), 1, CS, SN ) CALL DROT( M, CR(1,L1), 1, CR(1,L), 1, CS, SN ) C C Deflate the uncontrollable block and resume the C main loop. C A(L1,L) = ZERO NSUP = NSUP - 1 INFO = 0 GO TO 10 END IF C C Check for possible numerical instability. C IF( DLANGE( '1-norm', M, IB, DWORK(KFI), M, DWORK(KW) ) $ .GT.RMAX ) IWARN = IWARN + 1 C C Update the feedback matrix F <-- F + [0 FI] in CR. C K = KFI DO 30 J = L, L + IB - 1 DO 20 I = 1, M CR(I,J) = CR(I,J) + DWORK(K) K = K + 1 20 CONTINUE 30 CONTINUE C C Update the state matrix A <-- A + B*[0 FI]. C CALL DGEMM( 'NoTranspose', 'NoTranspose', NSUP, IB, M, $ ONE, B, LDB, DWORK(KFI), M, ONE, A(1,L), $ LDA ) IF( IB.EQ.2 ) THEN C C Try to split the 2x2 block and standardize it. C L1 = L + 1 CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), $ X, Y, PR, SM, CS, SN ) C C Apply the transformation to A, B, C and F. C IF( L1.LT.NSUP ) $ CALL DROT( NSUP-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 ) CALL DROT( M, B(L,1), LDB, B(L1,1), LDB, CS, SN ) IF( P.GT.0 ) $ CALL DROT( P, C(1,L), 1, C(1,L1), 1, CS, SN ) CALL DROT( M, CR(1,L), 1, CR(1,L1), 1, CS, SN ) END IF IF( NLOW+IB.LE.NSUP ) THEN C C Move the last block(s) to the leading position(s) of C the bottom block. C C Workspace: need MAX(4*N, 4*M, 4*P). 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 40 IF( NMOVES.GT.0 ) THEN NCUR = NCUR1 C C WHILE (NCUR >= NLOW) DO 50 IF( NCUR.GE.NLOW ) THEN C C Loop for positioning of the last block. C C Determine the dimension of the current block. C IB1 = 1 IF( NCUR.GT.NLOW ) THEN IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 END IF NB = IB1 + IB C C Initialize the local transformation matrix Z. C CALL DLASET( 'Full', NB, NB, ZERO, ONE, Z, 4 ) L = NCUR - IB1 + 1 C C Exchange two adjacent blocks and accumulate the C transformations in Z. C CALL DLAEXC( .TRUE., NB, A(L,L), LDA, Z, 4, 1, $ IB1, IB, DWORK, INFO ) IF( INFO.NE.0 ) THEN INFO = 2 RETURN END IF C C Apply the transformation to the rest of A. C L1 = L + NB IF( L1.LE.NSUP ) THEN CALL DGEMM( 'Transpose', 'NoTranspose', NB, $ NSUP-L1+1, NB, ONE, Z, 4, $ A(L,L1), LDA, ZERO, DWORK, NB ) CALL DLACPY( 'Full', NB, NSUP-L1+1, DWORK, $ NB, A(L,L1), LDA ) END IF CALL DGEMM( 'NoTranspose', 'NoTranspose', L-1, $ NB, NB, ONE, A(1,L), LDA, Z, 4, $ ZERO, DWORK, N ) CALL DLACPY( 'Full', L-1, NB, DWORK, N, A(1,L), $ LDA ) C C Apply the transformation to B, C and F. C CALL DGEMM( 'Transpose', 'NoTranspose', NB, M, $ NB, ONE, Z, 4, B(L,1), LDB, ZERO, $ DWORK, NB ) CALL DLACPY( 'Full', NB, M, DWORK, NB, B(L,1), $ LDB ) C IF( P.GT.0 ) THEN CALL DGEMM( 'NoTranspose', 'NoTranspose', P, $ NB, NB, ONE, C(1,L), LDC, Z, 4, $ ZERO, DWORK, P ) CALL DLACPY( 'Full', P, NB, DWORK, P, $ C(1,L), LDC ) END IF C CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NB, $ NB, ONE, CR(1,L), LDCR, Z, 4, ZERO, $ DWORK, M ) CALL DLACPY( 'Full', M, NB, DWORK, M, CR(1,L), $ LDCR ) C NCUR = NCUR - IB1 GO TO 50 END IF C END WHILE 50 C NMOVES = NMOVES - 1 NCUR1 = NCUR1 + 1 NLOW = NLOW + IB GO TO 40 END IF C END WHILE 40 C ELSE NLOW = NLOW + IB END IF END IF GO TO 10 END IF C END WHILE 10 C NQ = NSUP NR = NSUP - NFP C C Annihilate the elements below the first subdiagonal of A. C IF( NQ.GT.2 ) $ CALL DLASET( 'Lower', NQ-2, NQ-2, ZERO, ZERO, A(3,1), LDA ) END IF C C Compute C <-- CQ = C + D*F. C CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NQ, M, ONE, D, LDD, $ CR, LDCR, ONE, C, LDC ) C DWORK(1) = MAX( WRKOPT, DBLE( MAX( 5*M, 4*P ) ) ) C RETURN C *** Last line of SB08FD *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02GZ.f0000644000000000000000000000013215012430707016175 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02GZ.f0000644000175000017500000001015615012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE MA02GZ( N, A, LDA, K1, K2, IPIV, INCX ) C C PURPOSE C C To perform a series of column interchanges on the matrix A. C One column interchange is initiated for each of columns K1 through C K2 of A. This is useful for solving linear systems X*A = B, when C the matrix A has already been factored by LAPACK Library routine C DGETRF. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix A. N >= 0. C C A (input/output) COMPLEX*16 array, dimension (LDA,*) C On entry, the leading N-by-M part of this array must C contain the matrix A to which the column interchanges will C be applied, where M is the largest element of IPIV(K), for C K = K1, ..., K2. C On exit, the leading N-by-M part of this array contains C the permuted matrix. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C K1 (input) INTEGER C The first element of IPIV for which a column interchange C will be done. C C K2 (input) INTEGER C The last element of IPIV for which a column interchange C will be done. C C IPIV (input) INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) C The vector of interchanging (pivot) indices. Only the C elements in positions K1 through K2 of IPIV are accessed. C IPIV(K) = L implies columns K and L are to be C interchanged. C C INCX (input) INTEGER C The increment between successive values of IPIV. C If INCX is negative, the interchanges are applied in C reverse order. C C METHOD C C The columns IPIV(K) and K are swapped for K = K1, ..., K2, for C INCX = 1 (and similarly, for INCX <> 1). C C FURTHER COMMENTS C C This routine is the column-oriented counterpart of the LAPACK C Library routine DLASWP. The LAPACK Library routine DLAPMT cannot C be used in this context. To solve the system X*A = B, where A and C B are N-by-N and M-by-N, respectively, the following statements C can be used: C C CALL DGETRF( N, N, A, LDA, IPIV, INFO ) C CALL DTRSM( 'R', 'U', 'N', 'N', M, N, ONE, A, LDA, B, LDB ) C CALL DTRSM( 'R', 'L', 'N', 'U', M, N, ONE, A, LDA, B, LDB ) C CALL MA02GZ( M, B, LDB, 1, N, IPIV, -1 ) C C CONTRIBUTOR C C P. Gahinet, The MathWorks, Natick, U.S.A., Mar. 2011. C Based on the SLICOT Library routine MA02GD. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2011. C C KEYWORDS C C Elementary matrix operations, linear algebra. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N C .. C .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ) C .. C .. Local Scalars .. INTEGER J, JP, JX C .. C .. External Subroutines .. EXTERNAL ZSWAP C .. C .. Executable Statements .. C C Quick return if possible. C IF( INCX.EQ.0 .OR. N.EQ.0 ) $ RETURN C C Interchange column J with column IPIV(J) for each of columns K1 C through K2. C IF( INCX.GT.0 ) THEN JX = K1 ELSE JX = 1 + ( 1-K2 )*INCX END IF C IF( INCX.EQ.1 ) THEN C DO 10 J = K1, K2 JP = IPIV( J ) IF( JP.NE.J ) $ CALL ZSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) 10 CONTINUE C ELSE IF( INCX.GT.1 ) THEN C DO 20 J = K1, K2 JP = IPIV( JX ) IF( JP.NE.J ) $ CALL ZSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) JX = JX + INCX 20 CONTINUE C ELSE IF( INCX.LT.0 ) THEN C DO 30 J = K2, K1, -1 JP = IPIV( JX ) IF( JP.NE.J ) $ CALL ZSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) JX = JX + INCX 30 CONTINUE C END IF C RETURN C C *** Last line of MA02GZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01OD.f0000644000000000000000000000013015012430707016156 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MC01OD.f0000644000175000017500000000662115012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE MC01OD( K, REZ, IMZ, REP, IMP, DWORK, INFO ) C C PURPOSE C C To compute the coefficients of a complex polynomial P(x) from its C zeros. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of zeros (and hence the degree) of P(x). C K >= 0. C C REZ (input) DOUBLE PRECISION array, dimension (K) C IMZ (input) DOUBLE PRECISION array, dimension (K) C The real and imaginary parts of the i-th zero of P(x) C must be stored in REZ(i) and IMZ(i), respectively, where C i = 1, 2, ..., K. The zeros may be supplied in any order. C C REP (output) DOUBLE PRECISION array, dimension (K+1) C IMP (output) DOUBLE PRECISION array, dimension (K+1) C These arrays contain the real and imaginary parts, C respectively, of the coefficients of P(x) in increasing C powers of x. If K = 0, then REP(1) is set to one and C IMP(1) is set to zero. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (2*K+2) C If K = 0, this array is not referenced. 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 the coefficients of the complex K-th degree C polynomial P(x) as C C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) C C where r(i) = (REZ(i),IMZ(i)), using real arithmetic. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01CD by Alan Brown and C A.J. Geurts. C C REVISIONS C C V. Sima, May 2002. C C KEYWORDS C C Elementary polynomial operations, polynomial operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, K C .. Array Arguments .. DOUBLE PRECISION DWORK(*), IMP(*), IMZ(*), REP(*), REZ(*) C .. Local Scalars .. INTEGER I, K2 DOUBLE PRECISION U, V C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, XERBLA C .. Executable Statements .. C C Test the input scalar arguments. C IF( K.LT.0 ) THEN INFO = -1 C C Error return. C CALL XERBLA( 'MC01OD', -INFO ) RETURN END IF C C Quick return if possible. C INFO = 0 REP(1) = ONE IMP(1) = ZERO IF ( K.EQ.0 ) $ RETURN C K2 = K + 2 C DO 20 I = 1, K U = REZ(I) V = IMZ(I) DWORK(1) = ZERO DWORK(K2) = ZERO CALL DCOPY( I, REP, 1, DWORK(2), 1 ) CALL DCOPY( I, IMP, 1, DWORK(K2+1), 1 ) C IF ( U.NE.ZERO ) THEN CALL DAXPY( I, -U, REP, 1, DWORK, 1 ) CALL DAXPY( I, -U, IMP, 1, DWORK(K2), 1 ) END IF C IF ( V.NE.ZERO ) THEN CALL DAXPY( I, V, IMP, 1, DWORK, 1 ) CALL DAXPY( I, -V, REP, 1, DWORK(K2), 1 ) END IF C CALL DCOPY( I+1, DWORK, 1, REP, 1 ) CALL DCOPY( I+1, DWORK(K2), 1, IMP, 1 ) 20 CONTINUE C RETURN C *** Last line of MC01OD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03PD.f0000644000000000000000000000013215012430707016162 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03PD.f0000644000175000017500000002702515012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE MB03PD( JOBRQ, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, $ RANK, SVAL, DWORK, INFO ) C C PURPOSE C C To compute (optionally) a rank-revealing RQ factorization of a C real general M-by-N matrix A, which may be rank-deficient, C and estimate its effective rank using incremental condition C estimation. C C The routine uses an RQ factorization with row pivoting: C P * A = R * Q, where R = [ R11 R12 ], C [ 0 R22 ] C with R22 defined as the largest trailing submatrix whose estimated C condition number is less than 1/RCOND. The order of R22, RANK, C is the effective rank of A. C C MB03PD does not perform any scaling of the matrix A. C C ARGUMENTS C C Mode Parameters C C JOBRQ CHARACTER*1 C = 'R': Perform an RQ factorization with row pivoting; C = 'N': Do not perform the RQ factorization (but assume C that it has been done outside). 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 with JOBRQ = 'R', the leading M-by-N part of this C array must contain the given matrix A. C On exit with JOBRQ = 'R', C if M <= N, the upper triangle of the subarray C A(1:M,N-M+1:N) contains the M-by-M upper triangular C matrix R; C if M >= N, the elements on and above the (M-N)-th C subdiagonal contain the M-by-N upper trapezoidal matrix R; C the remaining elements, with the array TAU, represent the C orthogonal matrix Q as a product of min(M,N) elementary C reflectors (see METHOD). C On entry and on exit with JOBRQ = 'N', C if M <= N, the upper triangle of the subarray C A(1:M,N-M+1:N) must contain the M-by-M upper triangular C matrix R; C if M >= N, the elements on and above the (M-N)-th C subdiagonal must contain the M-by-N upper trapezoidal C matrix R; C the remaining elements are not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C JPVT (input/output) INTEGER array, dimension ( M ) C On entry with JOBRQ = 'R', if JPVT(i) <> 0, the i-th row C of A is a final row, otherwise it is a free row. Before C the RQ factorization of A, all final rows are permuted C to the trailing positions; only the remaining free rows C are moved as a result of row pivoting during the C factorization. For rank determination it is preferable C that all rows be free. C On exit with JOBRQ = 'R', if JPVT(i) = k, then the i-th C row of P*A was the k-th row of A. C Array JPVT is not referenced when JOBRQ = 'N'. 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 RCOND >= 0. 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 TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) C On exit with JOBRQ = 'R', the leading min(M,N) elements of C TAU contain the scalar factors of the elementary C reflectors. C Array TAU is not referenced when JOBRQ = 'N'. 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 Workspace C C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) C where LDWORK = max( 1, 3*M ), if JOBRQ = 'R'; C LDWORK = max( 1, 3*min( M, N ) ), if JOBRQ = '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 METHOD C C The routine computes or uses an RQ factorization with row C pivoting of A, P * A = R * Q, with R defined above, and then C finds the largest trailing submatrix whose estimated condition C number is less than 1/RCOND, taking the possible positive value of C SVLMAX into account. This is performed using an adaptation of the C LAPACK incremental condition estimation scheme and a slightly C modified rank decision test. C C The matrix Q is represented as a product of elementary reflectors C C Q = H(1) H(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 stable. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. C C REVISIONS C C Nov. 1997 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 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBRQ INTEGER INFO, LDA, M, N, RANK DOUBLE PRECISION RCOND, SVLMAX C .. Array Arguments .. INTEGER JPVT( * ) DOUBLE PRECISION A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * ) C .. Local Scalars .. LOGICAL LJOBRQ INTEGER I, ISMAX, ISMIN, JWORK, MN DOUBLE PRECISION C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLAIC1, MB04GD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. C .. Executable Statements .. C LJOBRQ = LSAME( JOBRQ, 'R' ) MN = MIN( M, N ) C C Test the input scalar arguments. C INFO = 0 IF( .NOT.LJOBRQ .AND. .NOT.LSAME( JOBRQ, 'N' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( RCOND.LT.ZERO ) THEN INFO = -7 ELSE IF( SVLMAX.LT.ZERO ) THEN INFO = -8 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03PD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MN.EQ.0 ) THEN RANK = 0 SVAL( 1 ) = ZERO SVAL( 2 ) = ZERO SVAL( 3 ) = ZERO RETURN END IF C IF ( LJOBRQ ) THEN C C Compute RQ factorization with row pivoting of A: C P * A = R * Q C Workspace 3*M. Details of Householder rotations stored in TAU. C CALL MB04GD( M, N, A, LDA, JPVT, TAU, DWORK( 1 ), INFO ) END IF C C Determine RANK using incremental condition estimation. C Workspace 3*min(M,N). C SMAX = ABS( A( M, N ) ) IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN RANK = 0 SVAL( 1 ) = SMAX SVAL( 2 ) = ZERO SVAL( 3 ) = ZERO ELSE ISMIN = MN ISMAX = 2*MN JWORK = ISMAX + 1 DWORK( ISMIN ) = ONE DWORK( ISMAX ) = ONE RANK = 1 SMIN = SMAX SMINPR = SMIN C 10 CONTINUE IF( RANK.LT.MN ) THEN CALL DCOPY ( RANK, A( M-RANK, N-RANK+1 ), LDA, $ DWORK( JWORK ), 1 ) CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, $ DWORK( JWORK ), A( M-RANK, N-RANK ), SMINPR, $ S1, C1 ) CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, $ DWORK( JWORK ), A( M-RANK, N-RANK ), SMAXPR, $ S2, C2 ) C IF( SVLMAX*RCOND.LE.SMAXPR ) THEN IF( SVLMAX*RCOND.LE.SMINPR ) THEN IF( SMAXPR*RCOND.LE.SMINPR ) THEN DO 20 I = 1, RANK DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) 20 CONTINUE ISMIN = ISMIN - 1 ISMAX = ISMAX - 1 DWORK( ISMIN ) = C1 DWORK( ISMAX ) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 GO TO 10 END IF END IF END IF END IF SVAL( 1 ) = SMAX SVAL( 2 ) = SMIN SVAL( 3 ) = SMINPR END IF C RETURN C *** Last line of MB03PD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02UD.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02UD.f0000644000175000017500000005260315012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE MB02UD( FACT, SIDE, TRANS, JOBP, M, N, ALPHA, RCOND, $ RANK, R, LDR, Q, LDQ, SV, B, LDB, RP, LDRP, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the minimum norm least squares solution of one of the C following linear systems C C op(R)*X = alpha*B, (1) C X*op(R) = alpha*B, (2) C C where alpha is a real scalar, op(R) is either R or its transpose, C R', R is an L-by-L real upper triangular matrix, B is an M-by-N C real matrix, and L = M for (1), or L = N for (2). Singular value C decomposition, R = Q*S*P', is used, assuming that R is rank C deficient. C C ARGUMENTS C C Mode Parameters C C FACT CHARACTER*1 C Specifies whether R has been previously factored or not, C as follows: C = 'F': R has been factored and its rank and singular C value decomposition, R = Q*S*P', are available; C = 'N': R has not been factored and its singular value C decomposition, R = Q*S*P', should be computed. C C SIDE CHARACTER*1 C Specifies whether op(R) appears on the left or right C of X as follows: C = 'L': Solve op(R)*X = alpha*B (op(R) is on the left); C = 'R': Solve X*op(R) = alpha*B (op(R) is on the right). C C TRANS CHARACTER*1 C Specifies the form of op(R) to be used as follows: C = 'N': op(R) = R; C = 'T': op(R) = R'; C = 'C': op(R) = R'. C C JOBP CHARACTER*1 C Specifies whether or not the pseudoinverse of R is to be C computed or it is available as follows: C = 'P': Compute pinv(R), if FACT = 'N', or C use pinv(R), if FACT = 'F'; C = 'N': Do not compute or use pinv(R). C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrix B. M >= 0. C C N (input) INTEGER C The number of columns of the matrix B. N >= 0. C C ALPHA (input) DOUBLE PRECISION C The scalar alpha. When alpha is zero then B need not be C set before entry. C C RCOND (input) DOUBLE PRECISION C RCOND is used to determine the effective rank of R. C Singular values of R satisfying Sv(i) <= RCOND*Sv(1) are C treated as zero. If RCOND <= 0, then EPS is used instead, C where EPS is the relative machine precision (see LAPACK C Library routine DLAMCH). RCOND <= 1. C RCOND is not used if FACT = 'F'. C C RANK (input or output) INTEGER C The rank of matrix R. C RANK is an input parameter when FACT = 'F', and an output C parameter when FACT = 'N'. L >= RANK >= 0. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,L) C On entry, if FACT = 'F', the leading L-by-L part of this C array must contain the L-by-L orthogonal matrix P' from C singular value decomposition, R = Q*S*P', of the matrix R; C if JOBP = 'P', the first RANK rows of P' are assumed to be C scaled by inv(S(1:RANK,1:RANK)). C On entry, if FACT = 'N', the leading L-by-L upper C triangular part of this array must contain the upper C triangular matrix R. C On exit, if INFO = 0, the leading L-by-L part of this C array contains the L-by-L orthogonal matrix P', with its C first RANK rows scaled by inv(S(1:RANK,1:RANK)), when C JOBP = 'P'. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,L). C C Q (input or output) DOUBLE PRECISION array, dimension C (LDQ,L) C On entry, if FACT = 'F', the leading L-by-L part of this C array must contain the L-by-L orthogonal matrix Q from C singular value decomposition, R = Q*S*P', of the matrix R. C If FACT = 'N', this array need not be set on entry, and C on exit, if INFO = 0, the leading L-by-L part of this C array contains the orthogonal matrix Q. C C LDQ INTEGER C The leading dimension of array Q. LDQ >= MAX(1,L). C C SV (input or output) DOUBLE PRECISION array, dimension (L) C On entry, if FACT = 'F', the first RANK entries of this C array must contain the reciprocal of the largest RANK C singular values of the matrix R, and the last L-RANK C entries of this array must contain the remaining singular C values of R sorted in descending order. C If FACT = 'N', this array need not be set on input, and C on exit, if INFO = 0, the first RANK entries of this array C contain the reciprocal of the largest RANK singular values C of the matrix R, and the last L-RANK entries of this array C contain the remaining singular values of R sorted in C descending order. C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) C On entry, if ALPHA <> 0, the leading M-by-N part of this C array must contain the matrix B. C On exit, if INFO = 0 and RANK > 0, the leading M-by-N part C of this array contains the M-by-N solution matrix X. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,M). C C RP (input or output) DOUBLE PRECISION array, dimension C (LDRP,L) C On entry, if FACT = 'F', JOBP = 'P', and RANK > 0, the C leading L-by-L part of this array must contain the L-by-L C matrix pinv(R), the Moore-Penrose pseudoinverse of R. C On exit, if FACT = 'N', JOBP = 'P', and RANK > 0, the C leading L-by-L part of this array contains the L-by-L C matrix pinv(R), the Moore-Penrose pseudoinverse of R. C If JOBP = 'N', this array is not referenced. C C LDRP INTEGER C The leading dimension of array RP. C LDRP >= MAX(1,L), if JOBP = 'P'. C LDRP >= 1, if JOBP = 'N'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; C if INFO = i, 1 <= i <= L, then DWORK(2:L) contain the C unconverged superdiagonal elements of an upper bidiagonal C matrix D whose diagonal is in SV (not necessarily sorted). C D satisfies R = Q*D*P', so it has the same singular C values as R, and singular vectors related by Q and P'. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1,L), if FACT = 'F'; C LDWORK >= MAX(1,5*L), if FACT = 'N'. C For optimum performance LDWORK should be larger than C MAX(1,L,M*N), if FACT = 'F'; C MAX(1,5*L,M*N), if FACT = 'N'. 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 > 0: if INFO = i, i = 1:L, the SVD algorithm has failed C to converge. In this case INFO specifies how many C superdiagonals did not converge (see the description C of DWORK); this failure is not likely to occur. C C METHOD C C The L-by-L upper triangular matrix R is factored as R = Q*S*P', C if FACT = 'N', using SLICOT Library routine MB03UD, where Q and P C are L-by-L orthogonal matrices and S is an L-by-L diagonal matrix C with non-negative diagonal elements, SV(1), SV(2), ..., SV(L), C ordered decreasingly. Then, the effective rank of R is estimated, C and matrix (or matrix-vector) products and scalings are used to C compute X. If FACT = 'F', only matrix (or matrix-vector) products C and scalings are performed. C C FURTHER COMMENTS C C Option JOBP = 'P' should be used only if the pseudoinverse is C really needed. Usually, it is possible to avoid the use of C pseudoinverse, by computing least squares solutions. C The routine uses BLAS 3 calculations if LDWORK >= M*N, and BLAS 2 C calculations, otherwise. No advantage of any additional workspace C larger than L is taken for matrix products, but the routine can C be called repeatedly for chunks of columns of B, if LDWORK < M*N. C C CONTRIBUTOR C C V. Sima, Research Institute of Informatics, Bucharest, Oct. 1999. C C REVISIONS C C V. Sima, Feb. 2000, Aug. 2011. C C KEYWORDS C C Bidiagonalization, orthogonal transformation, singular value C decomposition, singular values, triangular form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER FACT, JOBP, SIDE, TRANS INTEGER INFO, LDB, LDQ, LDR, LDRP, LDWORK, M, N, RANK DOUBLE PRECISION ALPHA, RCOND C .. Array Arguments .. DOUBLE PRECISION B(LDB,*), DWORK(*), Q(LDQ,*), R(LDR,*), $ RP(LDRP,*), SV(*) C .. Local Scalars .. LOGICAL LEFT, LQUERY, NFCT, PINV, TRAN CHARACTER*1 NTRAN INTEGER I, L, MAXWRK, MINWRK, MN DOUBLE PRECISION TOLL C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, DLASET, MB01SD, $ MB03UD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C C Check the input scalar arguments. C INFO = 0 NFCT = LSAME( FACT, 'N' ) LEFT = LSAME( SIDE, 'L' ) PINV = LSAME( JOBP, 'P' ) TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) IF( LEFT ) THEN L = M ELSE L = N END IF MN = M*N IF( .NOT.NFCT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN INFO = -1 ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -2 ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN INFO = -3 ELSE IF( .NOT.PINV .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( NFCT .AND. RCOND.GT.ONE ) THEN INFO = -8 ELSE IF( .NOT.NFCT .AND. ( RANK.LT.ZERO .OR. RANK.GT.L ) ) THEN INFO = -9 ELSE IF( LDR.LT.MAX( 1, L ) ) THEN INFO = -11 ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN INFO = -13 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -16 ELSE IF( LDRP.LT.1 .OR. ( PINV .AND. LDRP.LT.L ) ) THEN INFO = -18 ELSE C C Compute workspace C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C as well as the preferred amount for good performance.) C LQUERY = LDWORK.EQ.-1 MINWRK = MAX( 1, L ) MAXWRK = MAX( MINWRK, MN ) IF( NFCT ) THEN CALL MB03UD( 'Vectors', 'Vectors', L, R, LDR, Q, LDQ, SV, $ DWORK, -1, INFO ) MINWRK = MAX( 1, 5*L ) MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ), MINWRK ) END IF IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -20 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02UD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = MAXWRK RETURN END IF C C Quick return if possible. C IF( L.EQ.0 ) THEN IF( NFCT ) $ RANK = 0 DWORK(1) = ONE RETURN END IF C IF( NFCT ) THEN C C Compute the SVD of R, R = Q*S*P'. C Matrix Q is computed in the array Q, and P' overwrites R. C Workspace: need 5*L; C prefer larger. C CALL MB03UD( 'Vectors', 'Vectors', L, R, LDR, Q, LDQ, SV, $ DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) $ RETURN C C Use the default tolerance, if required. C TOLL = RCOND IF( TOLL.LE.ZERO ) $ TOLL = DLAMCH( 'Precision' ) TOLL = MAX( TOLL*SV(1), DLAMCH( 'Safe minimum' ) ) C C Estimate the rank of R. C DO 10 I = 1, L IF ( TOLL.GT.SV(I) ) $ GO TO 20 10 CONTINUE C I = L + 1 20 CONTINUE RANK = I - 1 C DO 30 I = 1, RANK SV(I) = ONE / SV(I) 30 CONTINUE C IF( PINV .AND. RANK.GT.0 ) THEN C C Compute pinv(S)'*P' in R. C CALL MB01SD( 'Row scaling', RANK, L, R, LDR, SV, SV ) C C Compute pinv(R) = P*pinv(S)*Q' in RP. C CALL DGEMM( 'Transpose', 'Transpose', L, L, RANK, ONE, R, $ LDR, Q, LDQ, ZERO, RP, LDRP ) END IF END IF C C Return if min(M,N) = 0 or RANK = 0. C IF( MIN( M, N ).EQ.0 .OR. RANK.EQ.0 ) THEN DWORK(1) = MAXWRK RETURN END IF C C Set X = 0 if alpha = 0. C IF( ALPHA.EQ.ZERO ) THEN CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) DWORK(1) = MAXWRK RETURN END IF C IF( PINV ) THEN C IF( LEFT ) THEN C C Compute alpha*op(pinv(R))*B in workspace and save it in B. C Workspace: need M (BLAS 2); C prefer M*N (BLAS 3). C IF( LDWORK.GE.MN ) THEN CALL DGEMM( TRANS, 'NoTranspose', M, N, M, ALPHA, $ RP, LDRP, B, LDB, ZERO, DWORK, M ) CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) ELSE C DO 40 I = 1, N CALL DGEMV( TRANS, M, M, ALPHA, RP, LDRP, B(1,I), 1, $ ZERO, DWORK, 1 ) CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) 40 CONTINUE C END IF ELSE C C Compute alpha*B*op(pinv(R)) in workspace and save it in B. C Workspace: need N (BLAS 2); C prefer M*N (BLAS 3). C IF( LDWORK.GE.MN ) THEN CALL DGEMM( 'NoTranspose', TRANS, M, N, N, ALPHA, B, LDB, $ RP, LDRP, ZERO, DWORK, M ) CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) ELSE C IF( TRAN ) THEN NTRAN = 'N' ELSE NTRAN = 'T' END IF C DO 50 I = 1, M CALL DGEMV( NTRAN, N, N, ALPHA, RP, LDRP, B(I,1), LDB, $ ZERO, DWORK, 1 ) CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) 50 CONTINUE C END IF END IF C ELSE C IF( LEFT ) THEN C C Compute alpha*P*pinv(S)*Q'*B or alpha*Q*pinv(S)'*P'*B. C Workspace: need M (BLAS 2); C prefer M*N (BLAS 3). C IF( LDWORK.GE.MN ) THEN IF( TRAN ) THEN C C Compute alpha*P'*B in workspace. C CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, $ ALPHA, R, LDR, B, LDB, ZERO, DWORK, M ) C C Compute alpha*pinv(S)'*P'*B. C CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, $ SV ) C C Compute alpha*Q*pinv(S)'*P'*B. C CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, $ ONE, Q, LDQ, DWORK, M, ZERO, B, LDB ) ELSE C C Compute alpha*Q'*B in workspace. C CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, $ ALPHA, Q, LDQ, B, LDB, ZERO, DWORK, M ) C C Compute alpha*pinv(S)*Q'*B. C CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, $ SV ) C C Compute alpha*P*pinv(S)*Q'*B. C CALL DGEMM( 'Transpose', 'NoTranspose', M, N, RANK, $ ONE, R, LDR, DWORK, M, ZERO, B, LDB ) END IF ELSE IF( TRAN ) THEN C C Compute alpha*P'*B in B using workspace. C DO 60 I = 1, N CALL DGEMV( 'NoTranspose', M, M, ALPHA, R, LDR, $ B(1,I), 1, ZERO, DWORK, 1 ) CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) 60 CONTINUE C C Compute alpha*pinv(S)'*P'*B. C CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) C C Compute alpha*Q*pinv(S)'*P'*B in B using workspace. C DO 70 I = 1, N CALL DGEMV( 'NoTranspose', M, RANK, ONE, Q, LDQ, $ B(1,I), 1, ZERO, DWORK, 1 ) CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) 70 CONTINUE ELSE C C Compute alpha*Q'*B in B using workspace. C DO 80 I = 1, N CALL DGEMV( 'Transpose', M, M, ALPHA, Q, LDQ, $ B(1,I), 1, ZERO, DWORK, 1 ) CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) 80 CONTINUE C C Compute alpha*pinv(S)*Q'*B. C CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) C C Compute alpha*P*pinv(S)*Q'*B in B using workspace. C DO 90 I = 1, N CALL DGEMV( 'Transpose', RANK, M, ONE, R, LDR, $ B(1,I), 1, ZERO, DWORK, 1 ) CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) 90 CONTINUE END IF END IF ELSE C C Compute alpha*B*P*pinv(S)*Q' or alpha*B*Q*pinv(S)'*P'. C Workspace: need N (BLAS 2); C prefer M*N (BLAS 3). C IF( LDWORK.GE.MN ) THEN IF( TRAN ) THEN C C Compute alpha*B*Q in workspace. C CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, $ ALPHA, B, LDB, Q, LDQ, ZERO, DWORK, M ) C C Compute alpha*B*Q*pinv(S)'. C CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, $ SV ) C C Compute alpha*B*Q*pinv(S)'*P' in B. C CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, $ ONE, DWORK, M, R, LDR, ZERO, B, LDB ) ELSE C C Compute alpha*B*P in workspace. C CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, $ ALPHA, B, LDB, R, LDR, ZERO, DWORK, M ) C C Compute alpha*B*P*pinv(S). C CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, $ SV ) C C Compute alpha*B*P*pinv(S)*Q' in B. C CALL DGEMM( 'NoTranspose', 'Transpose', M, N, RANK, $ ONE, DWORK, M, Q, LDQ, ZERO, B, LDB ) END IF ELSE IF( TRAN ) THEN C C Compute alpha*B*Q in B using workspace. C DO 100 I = 1, M CALL DGEMV( 'Transpose', N, N, ALPHA, Q, LDQ, $ B(I,1), LDB, ZERO, DWORK, 1 ) CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) 100 CONTINUE C C Compute alpha*B*Q*pinv(S)'. C CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, $ SV ) C C Compute alpha*B*Q*pinv(S)'*P' in B using workspace. C DO 110 I = 1, M CALL DGEMV( 'Transpose', RANK, N, ONE, R, LDR, $ B(I,1), LDB, ZERO, DWORK, 1 ) CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) 110 CONTINUE C ELSE C C Compute alpha*B*P in B using workspace. C DO 120 I = 1, M CALL DGEMV( 'NoTranspose', N, N, ALPHA, R, LDR, $ B(I,1), LDB, ZERO, DWORK, 1 ) CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) 120 CONTINUE C C Compute alpha*B*P*pinv(S). C CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, $ SV ) C C Compute alpha*B*P*pinv(S)*Q' in B using workspace. C DO 130 I = 1, M CALL DGEMV( 'NoTranspose', N, RANK, ONE, Q, LDQ, $ B(I,1), LDB, ZERO, DWORK, 1 ) CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) 130 CONTINUE END IF END IF END IF END IF C C Return optimal workspace in DWORK(1). C DWORK(1) = MAXWRK C RETURN C *** Last line of MB02UD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01YD.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01YD.f0000644000175000017500000002370715012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE MB01YD( UPLO, TRANS, N, K, L, ALPHA, BETA, A, LDA, C, $ LDC, INFO ) C C PURPOSE C C To perform the symmetric rank k operations C C C := alpha*op( A )*op( A )' + beta*C, C C where alpha and beta are scalars, C is an n-by-n symmetric matrix, C op( A ) is an n-by-k matrix, and op( A ) is one of C C op( A ) = A or op( A ) = A'. C C The matrix A has l nonzero codiagonals, either upper or lower. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies which triangle of the symmetric matrix C C is given and computed, as follows: C = 'U': the upper triangular part is given/computed; C = 'L': the lower triangular part is given/computed. C UPLO also defines the pattern of the matrix A (see below). C C TRANS CHARACTER*1 C Specifies the form of op( A ) to be used, as follows: C = 'N': op( A ) = A; C = 'T': op( A ) = A'; C = 'C': op( A ) = A'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix C. N >= 0. C C K (input) INTEGER C The number of columns of the matrix op( A ). K >= 0. C C L (input) INTEGER C If UPLO = 'U', matrix A has L nonzero subdiagonals. C If UPLO = 'L', matrix A has L nonzero superdiagonals. C MAX(0,NR-1) >= L >= 0, if UPLO = 'U', C MAX(0,NC-1) >= L >= 0, if UPLO = 'L', C where NR and NC are the numbers of rows and columns of the C matrix A, respectively. C C ALPHA (input) DOUBLE PRECISION C The scalar alpha. When alpha is zero then the array A is C not referenced. C C BETA (input) DOUBLE PRECISION C The scalar beta. When beta is zero then the array C need C not be set before entry. C C A (input) DOUBLE PRECISION array, dimension (LDA,NC), where C NC is K when TRANS = 'N', and is N otherwise. C If TRANS = 'N', the leading N-by-K part of this array must C contain the matrix A, otherwise the leading K-by-N part of C this array must contain the matrix A. C If UPLO = 'U', only the upper triangular part and the C first L subdiagonals are referenced, and the remaining C subdiagonals are assumed to be zero. C If UPLO = 'L', only the lower triangular part and the C first L superdiagonals are referenced, and the remaining C superdiagonals are assumed to be zero. C C LDA INTEGER C The leading dimension of array A. LDA >= max(1,NR), C where NR = N, if TRANS = 'N', and NR = K, otherwise. C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) C On entry with 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 C. C On entry with 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 C. C On exit, the leading N-by-N 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 the updated matrix C. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,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 METHOD C C The calculations are efficiently performed taking the symmetry C and structure into account. C C FURTHER COMMENTS C C The matrix A may have the following patterns, when n = 7, k = 5, C and l = 2 are used for illustration: C C UPLO = 'U', TRANS = 'N' UPLO = 'L', TRANS = 'N' C C [ x x x x x ] [ x x x 0 0 ] C [ x x x x x ] [ x x x x 0 ] C [ x x x x x ] [ x x x x x ] C A = [ 0 x x x x ], A = [ x x x x x ], C [ 0 0 x x x ] [ x x x x x ] C [ 0 0 0 x x ] [ x x x x x ] C [ 0 0 0 0 x ] [ x x x x x ] C C UPLO = 'U', TRANS = 'T' UPLO = 'L', TRANS = 'T' C C [ x x x x x x x ] [ x x x 0 0 0 0 ] C [ x x x x x x x ] [ x x x x 0 0 0 ] C A = [ x x x x x x x ], A = [ x x x x x 0 0 ]. C [ 0 x x x x x x ] [ x x x x x x 0 ] C [ 0 0 x x x x x ] [ x x x x x x x ] C C If N = K, the matrix A is upper or lower triangular, for L = 0, C and upper or lower Hessenberg, for L = 1. C C This routine is a specialization of the BLAS 3 routine DSYRK. C BLAS 1 calls are used when appropriate, instead of in-line code, C in order to increase the efficiency. If the matrix A is full, or C its zero triangle has small order, an optimized DSYRK code could C be faster than MB01YD. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. 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 .. C .. Scalar Arguments .. CHARACTER TRANS, UPLO INTEGER INFO, LDA, LDC, K, L, N DOUBLE PRECISION ALPHA, BETA C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ) C .. C .. Local Scalars .. LOGICAL TRANSP, UPPER INTEGER I, J, M, NCOLA, NROWA DOUBLE PRECISION TEMP C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL DDOT, LSAME C .. C .. External Subroutines .. EXTERNAL DAXPY, DLASCL, DLASET, DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 UPPER = LSAME( UPLO, 'U' ) TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) C IF( TRANSP )THEN NROWA = K NCOLA = N ELSE NROWA = N NCOLA = K END IF C IF( UPPER )THEN M = NROWA ELSE M = NCOLA END IF C IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( K.LT.0 ) THEN INFO = -4 ELSE IF( L.LT.0 .OR. L.GT.MAX( 0, M-1 ) ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, N ) ) THEN INFO = -11 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01YD', -INFO ) RETURN END IF C C Quick return, if possible. C IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN C IF ( ALPHA.EQ.ZERO ) THEN IF ( BETA.EQ.ZERO ) THEN C C Special case when both alpha = 0 and beta = 0. C CALL DLASET( UPLO, N, N, ZERO, ZERO, C, LDC ) ELSE C C Special case alpha = 0. C CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, C, LDC, INFO ) END IF RETURN END IF C C General case: alpha <> 0. C IF ( .NOT.TRANSP ) THEN C C Form C := alpha*A*A' + beta*C. C IF ( UPPER ) THEN C DO 30 J = 1, N IF ( BETA.EQ.ZERO ) THEN C DO 10 I = 1, J C( I, J ) = ZERO 10 CONTINUE C ELSE IF ( BETA.NE.ONE ) THEN CALL DSCAL ( J, BETA, C( 1, J ), 1 ) END IF C DO 20 M = MAX( 1, J-L ), K CALL DAXPY ( MIN( J, L+M ), ALPHA*A( J, M ), $ A( 1, M ), 1, C( 1, J ), 1 ) 20 CONTINUE C 30 CONTINUE C ELSE C DO 60 J = 1, N IF ( BETA.EQ.ZERO ) THEN C DO 40 I = J, N C( I, J ) = ZERO 40 CONTINUE C ELSE IF ( BETA.NE.ONE ) THEN CALL DSCAL ( N-J+1, BETA, C( J, J ), 1 ) END IF C DO 50 M = 1, MIN( J+L, K ) CALL DAXPY ( N-J+1, ALPHA*A( J, M ), A( J, M ), 1, $ C( J, J ), 1 ) 50 CONTINUE C 60 CONTINUE C END IF C ELSE C C Form C := alpha*A'*A + beta*C. C IF ( UPPER ) THEN C DO 80 J = 1, N C DO 70 I = 1, J TEMP = ALPHA*DDOT ( MIN( J+L, K ), A( 1, I ), 1, $ A( 1, J ), 1 ) IF ( BETA.EQ.ZERO ) THEN C( I, J ) = TEMP ELSE C( I, J ) = TEMP + BETA*C( I, J ) END IF 70 CONTINUE C 80 CONTINUE C ELSE C DO 100 J = 1, N C DO 90 I = J, N M = MAX( 1, I-L ) TEMP = ALPHA*DDOT ( K-M+1, A( M, I ), 1, A( M, J ), $ 1 ) IF ( BETA.EQ.ZERO ) THEN C( I, J ) = TEMP ELSE C( I, J ) = TEMP + BETA*C( I, J ) END IF 90 CONTINUE C 100 CONTINUE C END IF C END IF C RETURN C C *** Last line of MB01YD *** END control-4.1.2/src/slicot/src/PaxHeaders/TF01OD.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TF01OD.f0000644000175000017500000001133215012430707017366 0ustar00lilgelilge00000000000000 SUBROUTINE TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) C C PURPOSE C C To construct the block Hankel expansion T of a multivariable C parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k) C is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1). C C ARGUMENTS C C Input/Output Parameters C C NH1 (input) INTEGER C The number of rows in each parameter M(k). NH1 >= 0. C C NH2 (input) INTEGER C The number of columns in each parameter M(k). NH2 >= 0. C C NR (input) INTEGER C The number of parameters required in each column of the C block Hankel expansion matrix T. NR >= 0. C C NC (input) INTEGER C The number of parameters required in each row of the C block Hankel expansion matrix T. NC >= 0. C C H (input) DOUBLE PRECISION array, dimension C (LDH,(NR+NC-1)*NH2) C The leading NH1-by-(NR+NC-1)*NH2 part of this array must C contain the multivariable sequence M(k), where k = 1,2, C ...,(NR+NC-1). Specifically, each parameter M(k) is an C NH1-by-NH2 matrix whose (i,j)-th element must be stored in C H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2. C C LDH INTEGER C The leading dimension of array H. LDH >= MAX(1,NH1). C C T (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC) C The leading NH1*NR-by-NH2*NC part of this array contains C the block Hankel expansion of the multivariable sequence C M(k). C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,NH1*NR). 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 NH1-by-NH2 dimensional parameters M(k) of a multivariable C sequence are arranged into a matrix T in Hankel form such that C C C | M(1) M(2) M(3) . . . M(NC) | C | | C | M(2) M(3) M(4) . . . M(NC+1) | C T = | . . . . |. C | . . . . | C | . . . . | C | | C | M(NR) M(NR+1) M(NR+2) . . . M(NR+NC-1)| C C REFERENCES C C [1] Johvidov, J.S. C Hankel and Toeplitz Matrices and Forms: Algebraic Theory, C (translated by G.P.A. Thijsse, I. Gohberg, ed.). C Birkhaeuser, Boston, 1982. C C NUMERICAL ASPECTS C C The time taken is approximately proportional to C NH1 x NH2 x NR x NC. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TF01CD by S. Van Huffel, Katholieke C Univ. Leuven, Belgium. C C REVISIONS C C - C C KEYWORDS C C Hankel matrix, multivariable system. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INFO, LDH, LDT, NC, NH1, NH2, NR C .. Array Arguments .. DOUBLE PRECISION H(LDH,*), T(LDT,*) C .. Local Scalars .. INTEGER IH, IT, JT, NROW C .. External Subroutines .. EXTERNAL DLACPY, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C IF( NH1.LT.0 ) THEN INFO = -1 ELSE IF( NH2.LT.0 ) THEN INFO = -2 ELSE IF( NR.LT.0 ) THEN INFO = -3 ELSE IF( NC.LT.0 ) THEN INFO = -4 ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN INFO = -6 ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN INFO = -8 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TF01OD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( NH1, NH2, NR, NC ).EQ.0 ) $ RETURN C C Construct the first block column of T. C IH = 1 NROW = (NR-1)*NH1 C DO 10 IT = 1, NROW+NH1, NH1 CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,1), LDT ) IH = IH + NH2 10 CONTINUE C C Construct the remaining block columns of T. C DO 20 JT = NH2+1, NC*NH2, NH2 CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT-NH2), LDT, T(1,JT), $ LDT ) CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT), $ LDT ) IH = IH + NH2 20 CONTINUE C RETURN C *** Last line of TF01OD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04QU.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB04QU.f0000644000175000017500000001312015012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE SB04QU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, $ INFO ) 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 third subdiagonal, C and zero elements on the third subdiagonal with even column C indices. Such systems appear when solving discrete-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+8*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 third subdiagonal and zero elements on C the third subdiagonal with even column indices, 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 [2] Sima, V. C Algorithms for Linear-quadratic Optimization. C Marcel Dekker, Inc., New York, 1996. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C D. Sima, University of Bucharest, May 2000. 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 ONE, ZERO PARAMETER ( ONE = 1.0D0, 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 .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DTRMV, SB04QR C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C IND1 = IND - 1 C IF ( IND.LT.N ) THEN DUM(1) = ZERO CALL DCOPY ( M, DUM, 0, D, 1 ) DO 10 I = IND + 1, N CALL DAXPY ( M, B(IND1,I), C(1,I), 1, D, 1 ) 10 CONTINUE C DO 20 I = 2, M C(I,IND1) = C(I,IND1) - A(I,I-1)*D(I-1) 20 CONTINUE CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, $ D, 1 ) DO 30 I = 1, M C(I,IND1) = C(I,IND1) - D(I) 30 CONTINUE C CALL DCOPY ( M, DUM, 0, D, 1 ) DO 40 I = IND + 1, N CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) 40 CONTINUE C DO 50 I = 2, M C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) 50 CONTINUE CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, $ D, 1 ) DO 60 I = 1, M C(I,IND) = C(I,IND) - D(I) 60 CONTINUE END IF C C Construct the linear algebraic system of order 2*M. C K1 = -1 M2 = 2*M I2 = M2*(M + 3) K = M2 C DO 80 I = 1, M C DO 70 J = MAX( 1, I - 1 ), M K1 = K1 + 2 K2 = K1 + K TEMP = A(I,J) D(K1) = TEMP * B(IND1,IND1) D(K1+1) = TEMP * B(IND1,IND) D(K2) = TEMP * B(IND,IND1) D(K2+1) = TEMP * B(IND,IND) IF ( I.EQ.J ) THEN D(K1) = D(K1) + ONE D(K2+1) = D(K2+1) + ONE END IF 70 CONTINUE C K1 = K2 IF ( I.GT.1 ) K = K - 2 C C Store the right hand side. C I2 = I2 + 2 D(I2) = C(I,IND) D(I2-1) = C(I,IND1) 80 CONTINUE C C Solve the linear algebraic system and store the solution in C. C CALL SB04QR( M2, D, IPR, INFO ) C IF ( INFO.NE.0 ) THEN INFO = IND ELSE I2 = 0 C DO 90 I = 1, M I2 = I2 + 2 C(I,IND1) = D(IPR(I2-1)) C(I,IND) = D(IPR(I2)) 90 CONTINUE C END IF C RETURN C *** Last line of SB04QU *** END control-4.1.2/src/slicot/src/PaxHeaders/UD01CD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/UD01CD.f0000644000175000017500000001130315012430707017347 0ustar00lilgelilge00000000000000 SUBROUTINE UD01CD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) C C PURPOSE C C To read the elements of a sparse matrix polynomial C dp-1 dp C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . C C ARGUMENTS C C Input/Output Parameters C C MP (input) INTEGER C The number of rows of the matrix polynomial P(s). C MP >= 1. C C NP (input) INTEGER C The number of columns of the matrix polynomial P(s). C NP >= 1. C C DP (input) INTEGER C The degree of the matrix polynomial P(s). DP >= 0. C C NIN (input) INTEGER C The input channel from which the elements of P(s) are C read. NIN >= 0. C C P (output) DOUBLE PRECISION array, dimension C (LDP1,LDP2,DP+1) C The leading MP-by-NP-by-(DP+1) part of this array contains C the coefficients of the matrix polynomial P(s). C Specifically, P(i,j,k) contains the coefficient of C s**(k-1) of the polynomial which is the (i,j)-th element C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and C k = 1,2,...,DP+1. C The not assigned elements are set to zero. C C LDP1 INTEGER C The leading dimension of array P. LDP1 >= MP. C C LDP2 INTEGER C The second dimension of array P. LDP2 >= NP. 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 a row index i is read with i < 1 or i > MP or C a column index j is read with j < 1 or j > NP or C a coefficient degree d is read with d < 0 or C d > DP + 1. This is a warning. C C METHOD C C First, the elements P(i,j,k) with 1 <= i <= MP, 1 <= j <= NP and C 1 <= k <= DP + 1 are set to zero. Next the nonzero (polynomial) C elements are read from the input file NIN. Each nonzero element is C given by the values i, j, d, P(i,j,k), k = 1, ..., d+1, where d is C the degree and P(i,j,k) is the coefficient of s**(k-1) in the C (i,j)-th element of P(s), i.e., let C d C P (s) = P (0) + P (1) * s + . . . + P (d) * s C i,j i,j i,j i,j C C be the nonzero (i,j)-th element of the matrix polynomial P(s). C C Then P(i,j,k) corresponds to coefficient P (k-1), k = 1,...,d+1. C i,j C For each nonzero element, the values i, j, and d are read as one C record of the file NIN, and the values P(i,j,k), k = 1,...,d+1, C are read as the following record. C The routine terminates after the last line has been read. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. C Based on routine RDSPOM by A.J. Geurts, Eindhoven University of C Technology, Holland. C C REVISIONS C C - C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER DP, INFO, LDP1, LDP2, MP, NP, NIN C .. Array Arguments .. DOUBLE PRECISION P(LDP1,LDP2,*) C .. Local Scalars .. INTEGER D, I, J, K C .. External Subroutines .. EXTERNAL DLASET, XERBLA C C .. Executable Statements .. C INFO = 0 C C Check the input scalar arguments. C IF( MP.LT.1 ) THEN INFO = -1 ELSE IF( NP.LT.1 ) THEN INFO = -2 ELSE IF( DP.LT.0 ) THEN INFO = -3 ELSE IF( NIN.LT.0 ) THEN INFO = -4 ELSE IF( LDP1.LT.MP ) THEN INFO = -6 ELSE IF( LDP2.LT.NP ) THEN INFO = -7 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'UD01CD', -INFO ) RETURN END IF C DO 10 K = 1, DP+1 CALL DLASET( 'Full', MP, NP, ZERO, ZERO, P(1,1,K), LDP1 ) 10 CONTINUE C C Read (i, j, d, P(i,j,k), k=1,...,d+1) of the nonzero elements one C by one. C 20 READ( NIN, FMT = *, END = 30 ) I, J, D IF ( I.LT.1 .OR. I.GT.MP .OR. J.LT.1 .OR. J.GT.NP .OR. $ D.LT.0 .OR. D.GT.(DP+1) ) THEN INFO = 1 READ ( NIN, FMT = * ) ELSE READ ( NIN, FMT = * ) ( P(I,J,K), K = 1, D+1 ) END IF GO TO 20 C 30 CONTINUE RETURN C *** Last line of UD01CD *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BS.f0000644000000000000000000000013015012430707016164 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/NF01BS.f0000644000175000017500000004630015012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BS( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, $ GNORM, IPVT, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the QR factorization of the Jacobian matrix J, as C received in compressed form from SLICOT Library routine NF01BD, C C / dy(1)/dwb(1) | dy(1)/ dtheta \ C Jc = | : | : | , C \ dy(L)/dwb(L) | dy(L)/ dtheta / C C and to apply the transformation Q on the error vector e (in-situ). C The factorization is J*P = Q*R, where Q is a matrix with C orthogonal columns, P a permutation matrix, and R an upper C trapezoidal matrix with diagonal elements of nonincreasing C magnitude for each block column (see below). The 1-norm of the C scaled gradient is also returned. C C Actually, the Jacobian J has the block form C C dy(1)/dwb(1) 0 ..... 0 dy(1)/dtheta C 0 dy(2)/dwb(2) ..... 0 dy(2)/dtheta C ..... ..... ..... ..... ..... C 0 ..... 0 dy(L)/dwb(L) dy(L)/dtheta C C but the zero blocks are omitted. The diagonal blocks have the C same size and correspond to the nonlinear part. The last block C column corresponds to the linear part. It is assumed that the C Jacobian matrix has at least as many rows as columns. The linear C or nonlinear parts can be empty. If L <= 1, the Jacobian is C represented as a full matrix. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The number of columns of the Jacobian matrix J. C N = BN*BSN + ST >= 0. (See parameter description below.) C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of the C matrix J, as follows: C IPAR(1) must contain ST, the number of parameters C corresponding to the linear part. ST >= 0. C IPAR(2) must contain BN, the number of blocks, BN = L, C for the parameters corresponding to the nonlinear C part. BN >= 0. C IPAR(3) must contain BSM, the number of rows of the blocks C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the C number of rows of the matrix J, if BN <= 1. C BN*BSM >= N, if BN > 0; C BSM >= N, if BN = 0. C IPAR(4) must contain BSN, the number of columns of the C blocks J_k, k = 1:BN. BSN >= 0. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 4. C C FNORM (input) DOUBLE PRECISION C The Euclidean norm of the vector e. FNORM >= 0. C C J (input/output) DOUBLE PRECISION array, dimension (LDJ, NC) C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. C On entry, the leading NR-by-NC part of this array must C contain the (compressed) representation (Jc) of the C Jacobian matrix J, where NR = BSM if BN <= 1, and C NR = BN*BSM, if BN > 1. C On exit, the leading N-by-NC part of this array contains C a (compressed) representation of the upper triangular C factor R of the Jacobian matrix. The matrix R has the same C structure as the Jacobian matrix J, but with an additional C diagonal block. Note that for efficiency of the later C calculations, the matrix R is delivered with the leading C dimension MAX(1,N), possibly much smaller than the value C of LDJ on entry. C C LDJ (input/output) INTEGER C The leading dimension of array J. C On entry, LDJ >= MAX(1,NR). C On exit, LDJ >= MAX(1,N). C C E (input/output) DOUBLE PRECISION array, dimension (NR) C On entry, this array contains the vector e, C e = vec( Y - y ), where Y is set of output samples, and C vec denotes the concatenation of the columns of a matrix. C On exit, this array contains the updated vector Z*Q'*e, C where Z is the block row permutation matrix used in the C QR factorization of J (see METHOD). C C JNORMS (output) DOUBLE PRECISION array, dimension (N) C This array contains the Euclidean norms of the columns C of the Jacobian matrix, considered in the initial order. C C GNORM (output) DOUBLE PRECISION C If FNORM > 0, the 1-norm of the scaled vector J'*e/FNORM, C with each element i further divided by JNORMS(i) (if C JNORMS(i) is nonzero). C If FNORM = 0, the returned value of GNORM is 0. C C IPVT (output) INTEGER array, dimension (N) C This array defines the permutation matrix P such that C J*P = Q*R. Column j of P is column IPVT(j) of the identity C matrix. 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 length of the array DWORK. C LDWORK >= 1, if N = 0 or BN <= 1 and BSM = N = 1; C otherwise, C LDWORK >= 4*N+1, if BN <= 1 or BSN = 0; C LDWORK >= JWORK, if BN > 1 and BSN > 0, where JWORK is C given by the following procedure: C JWORK = BSN + MAX(3*BSN+1,ST); C JWORK = MAX(JWORK,4*ST+1), if BSM > BSN; C JWORK = MAX(JWORK,(BSM-BSN)*(BN-1)), C if BSN < BSM < 2*BSN. 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 C METHOD C C A QR factorization with column pivoting of the matrix J is C computed, J*P = Q*R. C C If l = L > 1, the R factor of the QR factorization has the same C structure as the Jacobian, but with an additional diagonal block. C Denote C C / J_1 0 .. 0 | L_1 \ C | 0 J_2 .. 0 | L_2 | C J = | : : .. : | : | . C | : : .. : | : | C \ 0 0 .. J_l | L_l / C C The algorithm consists in two phases. In the first phase, the C algorithm uses QR factorizations with column pivoting for each C block J_k, k = 1:l, and applies the orthogonal matrix Q'_k to the C corresponding part of the last block column and of e. After all C block rows have been processed, the block rows are interchanged C so that the zeroed submatrices in the first l block columns are C moved to the bottom part. The same block row permutation Z is C also applied to the vector e. At the end of the first phase, C the structure of the processed matrix J is C C / R_1 0 .. 0 | L^1_1 \ C | 0 R_2 .. 0 | L^1_2 | C | : : .. : | : | . C | : : .. : | : | C | 0 0 .. R_l | L^1_l | C | 0 0 .. 0 | L^2_1 | C | : : .. : | : | C \ 0 0 .. 0 | L^2_l / C C In the second phase, the submatrix L^2_1:l is triangularized C using an additional QR factorization with pivoting. (The columns C of L^1_1:l are also permuted accordingly.) Therefore, the column C pivoting is restricted to each such local block column. C C If l <= 1, the matrix J is triangularized in one phase, by one C QR factorization with pivoting. In this case, the column C pivoting is global. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C Feb. 22, 2004. C C KEYWORDS C C Elementary matrix operations, Jacobian matrix, matrix algebra, C matrix operations, Wiener system. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDJ, LDWORK, LIPAR, N DOUBLE PRECISION FNORM, GNORM C .. Array Arguments .. INTEGER IPAR(*), IPVT(*) DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) C .. Local Scalars .. INTEGER BN, BSM, BSN, I, IBSM, IBSN, IBSNI, ITAU, JL, $ JLM, JWORK, K, L, M, MMN, NTHS, ST, WRKOPT DOUBLE PRECISION SUM C .. External Functions .. DOUBLE PRECISION DDOT, DNRM2 EXTERNAL DDOT, DNRM2 C .. External Subroutines .. EXTERNAL DCOPY, DGEQP3, DLACPY, DLAPMT, DORMQR, DSWAP, $ MD03BX, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN C .. C .. Executable Statements .. C INFO = 0 IF ( N.LT.0 ) THEN INFO = -1 ELSEIF( LIPAR.LT.4 ) THEN INFO = -3 ELSEIF ( FNORM.LT.ZERO ) THEN INFO = -4 ELSEIF ( LDJ.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE ST = IPAR(1) BN = IPAR(2) BSM = IPAR(3) BSN = IPAR(4) NTHS = BN*BSN MMN = BSM - BSN IF ( BN.GT.0 ) THEN M = BN*BSM ELSE M = N END IF IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN INFO = -2 ELSEIF ( N.NE.NTHS + ST ) THEN INFO = -1 ELSEIF ( M.LT.N ) THEN INFO = -2 ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF ( N.EQ.0 ) THEN JWORK = 1 ELSEIF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN IF ( BN.LE.1 .AND. BSM.EQ.1 .AND. N.EQ.1 ) THEN JWORK = 1 ELSE JWORK = 4*N + 1 END IF ELSE JWORK = BSN + MAX( 3*BSN + 1, ST ) IF ( BSM.GT.BSN ) THEN JWORK = MAX( JWORK, 4*ST + 1 ) IF ( BSM.LT.2*BSN ) $ JWORK = MAX( JWORK, MMN*( BN - 1 ) ) END IF END IF IF ( LDWORK.LT.JWORK ) $ INFO = -12 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'NF01BS', -INFO ) RETURN END IF C C Quick return if possible. C GNORM = ZERO IF ( N.EQ.0 ) THEN LDJ = 1 DWORK(1) = ONE RETURN END IF C IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN C C Special case, l <= 1 or BSN = 0: the Jacobian is represented C as a full matrix. 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 C Workspace: need: 4*N + 1; C prefer: 3*N + ( N+1 )*NB. C CALL MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, $ DWORK, LDWORK, INFO ) RETURN END IF C C General case: l > 1 and BSN > 0. C Initialize the column pivoting indices. C DO 10 I = 1, N IPVT(I) = 0 10 CONTINUE C C Compute the QR factorization with pivoting of J. C Pivoting is done separately on each block column of J. C WRKOPT = 1 IBSN = 1 JL = LDJ*BSN + 1 JWORK = BSN + 1 C DO 30 IBSM = 1, M, BSM C C Compute the QR factorization with pivoting of J_k, and apply Q' C to the corresponding part of the last block-column and of e. C Workspace: need: 4*BSN + 1; C prefer: 3*BSN + ( BSN+1 )*NB. C CALL DGEQP3( BSM, BSN, J(IBSM), LDJ, IPVT(IBSN), DWORK, $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) IF ( IBSM.GT.1 ) THEN C C Adjust the column pivoting indices. C DO 20 I = IBSN, IBSN + BSN - 1 IPVT(I) = IPVT(I) + IBSN - 1 20 CONTINUE C END IF C IF ( ST.GT.0 ) THEN C C Workspace: need: BSN + ST; C prefer: BSN + ST*NB. C CALL DORMQR( 'Left', 'Transpose', BSM, ST, BSN, J(IBSM), $ LDJ, DWORK, J(JL), LDJ, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) END IF C C Workspace: need: BSN + 1; C prefer: BSN + NB. C CALL DORMQR( 'Left', 'Transpose', BSM, 1, BSN, J(IBSM), LDJ, $ DWORK, E(IBSM), BSM, DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) JL = JL + BSM IBSN = IBSN + BSN 30 CONTINUE C IF ( MMN.GT.0 ) THEN C C Case BSM > BSN. C Compute the original column norms for the first block column C of Jc. C Permute the rows of the first block column to move the zeroed C submatrices to the bottom. In the same loops, reshape the C first block column of R to have the leading dimension N. C L = IPVT(1) JNORMS(L) = ABS( J(1) ) IBSM = BSM + 1 IBSN = BSN + 1 C DO 40 K = 1, BN - 1 J(IBSN) = J(IBSM) L = IPVT(IBSN) JNORMS(L) = ABS( J(IBSN) ) IBSM = IBSM + BSM IBSN = IBSN + BSN 40 CONTINUE C IBSN = IBSN + ST C DO 60 I = 2, BSN IBSM = ( I - 1 )*LDJ + 1 JL = I C DO 50 K = 1, BN C DO 45 L = 0, I - 1 J(IBSN+L) = J(IBSM+L) 45 CONTINUE C L = IPVT(JL) JNORMS(L) = DNRM2( I, J(IBSN), 1 ) IBSM = IBSM + BSM IBSN = IBSN + BSN JL = JL + BSN 50 CONTINUE C IBSN = IBSN + ST 60 CONTINUE C C Permute the rows of the second block column of Jc and of C the vector e. C JL = LDJ*BSN IF ( BSM.GE.2*BSN ) THEN C C A swap operation can be used. C DO 80 I = 1, ST IBSN = BSN + 1 C DO 70 IBSM = BSM + 1, M, BSM CALL DSWAP( MMN, J(JL+IBSM), 1, J(JL+IBSN), 1 ) IBSN = IBSN + BSN 70 CONTINUE C JL = JL + LDJ 80 CONTINUE C C Permute the rows of e. C IBSN = BSN + 1 C DO 90 IBSM = BSM + 1, M, BSM CALL DSWAP( MMN, E(IBSM), 1, E(IBSN), 1 ) IBSN = IBSN + BSN 90 CONTINUE C ELSE C C A swap operation cannot be used. C Workspace: need: ( BSM-BSN )*( BN-1 ). C DO 110 I = 1, ST IBSN = BSN + 1 JLM = JL + IBSN JWORK = 1 C DO 100 IBSM = BSM + 1, M, BSM CALL DCOPY( MMN, J(JLM), 1, DWORK(JWORK), 1 ) C DO 105 K = JL, JL + BSN - 1 J(IBSN+K) = J(IBSM+K) 105 CONTINUE C JLM = JLM + BSM IBSN = IBSN + BSN JWORK = JWORK + MMN 100 CONTINUE C CALL DCOPY( MMN*( BN-1 ), DWORK, 1, J(JL+IBSN), 1 ) JL = JL + LDJ 110 CONTINUE C C Permute the rows of e. C IBSN = BSN + 1 JLM = IBSN JWORK = 1 C DO 120 IBSM = BSM + 1, M, BSM CALL DCOPY( MMN, E(JLM), 1, DWORK(JWORK), 1 ) C DO 115 K = 0, BSN - 1 E(IBSN+K) = E(IBSM+K) 115 CONTINUE C JLM = JLM + BSM IBSN = IBSN + BSN JWORK = JWORK + MMN 120 CONTINUE C CALL DCOPY( MMN*( BN-1 ), DWORK, 1, E(IBSN), 1 ) END IF C IF ( ST.GT.0 ) THEN C C Compute the QR factorization with pivoting of the submatrix C L^2_1:l, and apply Q' to the corresponding part of e. C C Workspace: need: 4*ST + 1; C prefer: 3*ST + ( ST+1 )*NB. C JL = ( LDJ + BN )*BSN + 1 ITAU = 1 JWORK = ITAU + ST CALL DGEQP3( MMN*BN, ST, J(JL), LDJ, IPVT(NTHS+1), $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Permute columns of the upper part of the second block C column of Jc. C CALL DLAPMT( .TRUE., NTHS, ST, J(JL-NTHS), LDJ, $ IPVT(NTHS+1) ) C C Adjust the column pivoting indices. C DO 130 I = NTHS + 1, N IPVT(I) = IPVT(I) + NTHS 130 CONTINUE C C Workspace: need: ST + 1; C prefer: ST + NB. C CALL DORMQR( 'Left', 'Transpose', MMN*BN, 1, ST, J(JL), LDJ, $ DWORK(ITAU), E(IBSN), LDJ, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Reshape the second block column of R to have the leading C dimension N. C IBSN = N*BSN + 1 CALL DLACPY( 'Full', N, ST, J(LDJ*BSN+1), LDJ, J(IBSN), N ) C C Compute the original column norms for the second block C column. C DO 140 I = NTHS + 1, N L = IPVT(I) JNORMS(L) = DNRM2( I, J(IBSN), 1 ) IBSN = IBSN + N 140 CONTINUE C END IF C ELSE C C Case BSM = BSN. C Compute the original column norms for the first block column C of Jc. C IBSN = 1 C DO 160 I = 1, BSN JL = I C DO 150 K = 1, BN L = IPVT(JL) JNORMS(L) = DNRM2( I, J(IBSN), 1 ) IBSN = IBSN + BSN JL = JL + BSN 150 CONTINUE C IBSN = IBSN + ST 160 CONTINUE C DO 170 I = NTHS + 1, N IPVT(I) = I 170 CONTINUE C END IF C C Compute the norm of the scaled gradient. C IF ( FNORM.NE.ZERO ) THEN C DO 190 IBSN = 1, NTHS, BSN IBSNI = IBSN C DO 180 I = 1, BSN L = IPVT(IBSN+I-1) IF ( JNORMS(L).NE.ZERO ) THEN SUM = DDOT( I, J(IBSNI), 1, E(IBSN), 1 )/FNORM GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) END IF IBSNI = IBSNI + N 180 CONTINUE C 190 CONTINUE C IBSNI = N*BSN + 1 C DO 200 I = NTHS + 1, N L = IPVT(I) IF ( JNORMS(L).NE.ZERO ) THEN SUM = DDOT( I, J(IBSNI), 1, E, 1 )/FNORM GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) END IF IBSNI = IBSNI + N 200 CONTINUE C END IF C LDJ = N DWORK(1) = WRKOPT RETURN C C *** Last line of NF01BS *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01XD.f0000644000000000000000000000013215012430707016177 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB01XD.f0000644000175000017500000001750615012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE TB01XD( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC, $ D, LDD, INFO ) C C PURPOSE C C To apply a special transformation to a system given as a triple C (A,B,C), C C A <-- P * A' * P, B <-- P * C', C <-- B' * P, C C where P is a matrix with 1 on the secondary diagonal, and with 0 C in the other entries. Matrix A can be specified as a band matrix. C Optionally, matrix D of the system can be transposed. This C transformation is actually a special similarity transformation of C the dual system. C C ARGUMENTS C C Mode Parameters 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 matrix A, the number of rows of matrix B C and the number of columns of matrix C. C N represents the dimension of the state vector. N >= 0. C C M (input) INTEGER. C The number of columns of matrix B. C M represents the dimension of input vector. M >= 0. C C P (input) INTEGER. C The number of rows of matrix C. C P represents the dimension of output vector. P >= 0. C C KL (input) INTEGER C The number of subdiagonals of A to be transformed. C MAX( 0, N-1 ) >= KL >= 0. C C KU (input) INTEGER C The number of superdiagonals of A to be transformed. C MAX( 0, N-1 ) >= KU >= 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 system state matrix A. C On exit, the leading N-by-N part of this array contains C the transformed (pertransposed) matrix P*A'*P. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,MAX(M,P)) C On entry, the leading N-by-M part of this array must C contain the original input/state matrix B. C On exit, the leading N-by-P part of this array contains C the dual input/state matrix P*C'. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N) if M > 0 or P > 0. C LDB >= 1 if M = 0 and P = 0. 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 original state/output matrix C. C On exit, the leading M-by-N part of this array contains C the dual state/output matrix B'*P. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,M,P) if N > 0. C LDC >= 1 if N = 0. C C D (input/output) DOUBLE PRECISION array, dimension C (LDD,MAX(M,P)) C On entry, if JOBD = 'D', the leading P-by-M part of this C array must contain the original direct transmission C matrix D. C On exit, if JOBD = 'D', the leading M-by-P part of this C array contains the transposed direct transmission matrix C D'. The array D is not referenced if JOBD = 'Z'. C C LDD INTEGER C The leading dimension of array D. C LDD >= MAX(1,M,P) if JOBD = 'D'. C LDD >= 1 if JOBD = 'Z'. 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 rows and/or columns of the matrices of the triplet (A,B,C) C and, optionally, of the matrix D are swapped in a special way. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. C Partly based on routine DMPTR (A. Varga, German Aerospace C Research Establishment, DLR, Aug. 1992). C C C REVISIONS C C 07-31-1998, 04-25-1999, A. Varga. C 03-16-2004, V. Sima. C C KEYWORDS C C Matrix algebra, matrix operations, similarity transformation. C C ********************************************************************* C C .. C .. Scalar Arguments .. CHARACTER JOBD INTEGER INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ) C .. C .. Local Scalars .. LOGICAL LJOBD INTEGER J, J1, LDA1, MAXMP, MINMP, NM1 C .. C .. External functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL DCOPY, DSWAP, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the scalar input arguments. C INFO = 0 LJOBD = LSAME( JOBD, 'D' ) MAXMP = MAX( M, P ) MINMP = MIN( M, P ) NM1 = N - 1 C IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) 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( KL.LT.0 .OR. KL.GT.MAX( 0, NM1 ) ) THEN INFO = -5 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( 0, NM1 ) ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( ( MAXMP.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. $ ( MINMP.EQ.0 .AND. LDB.LT.1 ) ) THEN INFO = -10 ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN INFO = -12 ELSE IF( LDD.LT.1 .OR. ( LJOBD .AND. LDD.LT.MAXMP ) ) THEN INFO = -14 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01XD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( LJOBD ) THEN C C Replace D by D', if non-scalar. C DO 5 J = 1, MAXMP IF ( J.LT.MINMP ) THEN CALL DSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) ELSE IF ( J.GT.P ) THEN CALL DCOPY( P, D(1,J), 1, D(J,1), LDD ) ELSE IF ( J.GT.M ) THEN CALL DCOPY( M, D(J,1), LDD, D(1,J), 1 ) END IF 5 CONTINUE C END IF C IF( N.EQ.0 ) $ RETURN C C Replace matrix A by P*A'*P. C IF ( KL.EQ.NM1 .AND. KU.EQ.NM1 ) THEN C C Full matrix A. C DO 10 J = 1, NM1 CALL DSWAP( N-J, A( 1, J ), 1, A( N-J+1, J+1 ), -LDA ) 10 CONTINUE C ELSE C C Band matrix A. C LDA1 = LDA + 1 C C Pertranspose the KL subdiagonals. C DO 20 J = 1, MIN( KL, N-2 ) J1 = ( N - J )/2 CALL DSWAP( J1, A(J+1,1), LDA1, A(N-J1+1,N-J1+1-J), -LDA1 ) 20 CONTINUE C C Pertranspose the KU superdiagonals. C DO 30 J = 1, MIN( KU, N-2 ) J1 = ( N - J )/2 CALL DSWAP( J1, A(1,J+1), LDA1, A(N-J1+1-J,N-J1+1), -LDA1 ) 30 CONTINUE C C Pertranspose the diagonal. C J1 = N/2 CALL DSWAP( J1, A(1,1), LDA1, A(N-J1+1,N-J1+1), -LDA1 ) C END IF C C Replace matrix B by P*C' and matrix C by B'*P. C DO 40 J = 1, MAXMP IF ( J.LE.MINMP ) THEN CALL DSWAP( N, B(1,J), 1, C(J,1), -LDC ) ELSE IF ( J.GT.P ) THEN CALL DCOPY( N, B(1,J), 1, C(J,1), -LDC ) ELSE CALL DCOPY( N, C(J,1), -LDC, B(1,J), 1 ) END IF 40 CONTINUE C RETURN C *** Last line of TB01XD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09CD.f0000644000000000000000000000013215012430707016137 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09CD.f0000644000175000017500000003175015012430707017341 0ustar00lilgelilge00000000000000 SUBROUTINE AB09CD( DICO, EQUIL, ORDSEL, N, M, P, NR, A, LDA, B, $ LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, $ DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable C original state-space representation (A,B,C,D) by using the C optimal Hankel-norm approximation method in conjunction with C square-root balancing. 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 EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of C the resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. NR is set as follows: C if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN), C where KR is the multiplicity of the Hankel singular value C HSV(NR+1), NR is the desired order on entry, and NMIN is C the order of a minimal realization of the given system; C NMIN is determined as the number of Hankel singular values C greater than N*EPS*HNORM(A,B,C), where EPS is the machine C precision (see LAPACK Library Routine DLAMCH) and C HNORM(A,B,C) is the Hankel norm of the system (computed C in HSV(1)); C if ORDSEL = 'A', NR is equal to the number of Hankel C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). 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, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the C reduced order system in a real Schur 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 N-by-M part of this array must C contain the original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, it contains the Hankel singular values of C the original system ordered decreasingly. HSV(1) is the C Hankel norm of the system. C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL1 = c*HNORM(A,B,C), where c is a constant in the C interval [0.00001,0.001], and HNORM(A,B,C) is the C Hankel-norm of the given system (computed in HSV(1)). C For computing a minimal realization, the recommended C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the C machine precision (see LAPACK Library Routine DLAMCH). C This value is used by default if TOL1 <= 0 on entry. C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the given system. The recommended value is C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default C if TOL2 <= 0 on entry. C If TOL2 > 0, then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = MAX(1,M), if DICO = 'C'; C LIWORK = MAX(1,N,M), if DICO = 'D'. C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of C the computed minimal realization. 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( LDW1, LDW2 ), where C LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2, C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + C MAX( 3*M+1, MIN(N,M)+P ). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than the order of a minimal realization of the C given system. In this case, the resulting NR is set C automatically to a value corresponding to the order C of a minimal realization of the system. 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 the real Schur form failed; C = 2: the state matrix A is not stable (if DICO = 'C') C or not convergent (if DICO = 'D'); C = 3: the computation of Hankel singular values failed; C = 4: the computation of stable projection failed; C = 5: the order of computed stable projection differs C from the order of Hankel-norm approximation. C C METHOD C C Let be the stable linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09CD determines for C the given system (1), the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t) (2) C C such that C C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], C C where G and Gr are transfer-function matrices of the systems C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the C infinity-norm of G. C C The optimal Hankel-norm approximation method of [1], based on the C square-root balancing projection formulas of [2], is employed. C C REFERENCES C C [1] Glover, K. C All optimal Hankel norm approximation of linear C multivariable systems and their L-infinity error bounds. C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. C C [2] Tombs M.S. and Postlethwaite I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C NUMERICAL ASPECTS C C The implemented methods rely on an accuracy enhancing square-root C technique. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C April 1998. C Based on the RASP routine OHNAP. C C REVISIONS C C November 11, 1998, V. Sima, Research Institute for Informatics, C Bucharest. C March 26, 2005, V. Sima, Research Institute for Informatics. C C KEYWORDS C C Balancing, Hankel-norm approximation, model reduction, C multivariable system, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, C100 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, $ M, N, NR, P DOUBLE PRECISION TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), HSV(*) C .. Local Scalars .. LOGICAL FIXORD INTEGER IERR, KI, KL, KT, KW DOUBLE PRECISION MAXRED, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB09CX, TB01ID, TB01WD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C .. Executable Statements .. C INFO = 0 IWARN = 0 FIXORD = LSAME( ORDSEL, 'F' ) C C Check the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN INFO = -18 ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + $ ( N*( N + 1 ) )/2, $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN INFO = -21 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09CD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 IWORK(1) = 0 DWORK(1) = ONE RETURN END IF C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Reduce A to the real Schur form using an orthogonal similarity C transformation A <- T'*A*T and apply the transformation to B C and C: B <- T'*B and C <- C*T. C KT = 1 KL = KT + N*N KI = KL + N KW = KI + N CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, $ DWORK(KL), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF C WRKOPT = DWORK(KW) + DBLE( KW-1 ) C CALL AB09CX( DICO, ORDSEL, N, M, P, NR, A, LDA, B, LDB, C, LDC, $ D, LDD, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, $ IWARN, IERR ) C IF( IERR.NE.0 ) THEN INFO = IERR + 1 RETURN END IF C DWORK(1) = MAX( WRKOPT, DWORK(1) ) C RETURN C *** Last line of AB09CD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB05MD.f0000644000000000000000000000013215012430707016145 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB05MD.f0000644000175000017500000004225115012430707017345 0ustar00lilgelilge00000000000000 SUBROUTINE AB05MD( UPLO, OVER, N1, M1, P1, N2, P2, A1, LDA1, B1, $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, $ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, $ D, LDD, DWORK, LDWORK, INFO ) C C PURPOSE C C To obtain the state-space model (A,B,C,D) for the cascaded C inter-connection of two systems, each given in state-space form. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Indicates whether the user wishes to obtain the matrix A C in the upper or lower block diagonal form, as follows: C = 'U': Obtain A in the upper block diagonal form; C = 'L': Obtain A in the lower block diagonal form. C C OVER CHARACTER*1 C Indicates whether the user wishes to overlap pairs of C arrays, as follows: C = 'N': Do not overlap; C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, C C1 and C, and D1 and D (for UPLO = 'L'), or A2 C and A, B2 and B, C2 and C, and D2 and D (for C UPLO = 'U'), i.e. the same name is effectively C used for each pair (for all pairs) in the routine C call. In this case, setting LDA1 = LDA, C LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD, or C LDA2 = LDA, LDB2 = LDB, LDC2 = LDC, and LDD2 = LDD C will give maximum efficiency. C C Input/Output Parameters C C N1 (input) INTEGER C The number of state variables in the first system, i.e. C the order of the matrix A1. N1 >= 0. C C M1 (input) INTEGER C The number of input variables for the first system. C M1 >= 0. C C P1 (input) INTEGER C The number of output variables from the first system and C the number of input variables for the second system. C P1 >= 0. C C N2 (input) INTEGER C The number of state variables in the second system, i.e. C the order of the matrix A2. N2 >= 0. C C P2 (input) INTEGER C The number of output variables from the second system. C P2 >= 0. C C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) C The leading N1-by-N1 part of this array must contain the C state transition matrix A1 for the first system. C C LDA1 INTEGER C The leading dimension of array A1. LDA1 >= MAX(1,N1). C C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) C The leading N1-by-M1 part of this array must contain the C input/state matrix B1 for the first system. C C LDB1 INTEGER C The leading dimension of array B1. LDB1 >= MAX(1,N1). C C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) C The leading P1-by-N1 part of this array must contain the C state/output matrix C1 for the first system. C C LDC1 INTEGER C The leading dimension of array C1. C LDC1 >= MAX(1,P1) if N1 > 0. C LDC1 >= 1 if N1 = 0. C C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) C The leading P1-by-M1 part of this array must contain the C input/output matrix D1 for the first system. C C LDD1 INTEGER C The leading dimension of array D1. LDD1 >= MAX(1,P1). C C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) C The leading N2-by-N2 part of this array must contain the C state transition matrix A2 for the second system. C C LDA2 INTEGER C The leading dimension of array A2. LDA2 >= MAX(1,N2). C C B2 (input) DOUBLE PRECISION array, dimension (LDB2,P1) C The leading N2-by-P1 part of this array must contain the C input/state matrix B2 for the second system. C C LDB2 INTEGER C The leading dimension of array B2. LDB2 >= MAX(1,N2). C C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) C The leading P2-by-N2 part of this array must contain the C state/output matrix C2 for the second system. C C LDC2 INTEGER C The leading dimension of array C2. C LDC2 >= MAX(1,P2) if N2 > 0. C LDC2 >= 1 if N2 = 0. C C D2 (input) DOUBLE PRECISION array, dimension (LDD2,P1) C The leading P2-by-P1 part of this array must contain the C input/output matrix D2 for the second system. C C LDD2 INTEGER C The leading dimension of array D2. LDD2 >= MAX(1,P2). C C N (output) INTEGER C The number of state variables (N1 + N2) in the resulting C system, i.e. the order of the matrix A, the number of rows C of B and the number of columns of C. C C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) C The leading N-by-N part of this array contains the state C transition matrix A for the cascaded system. C If OVER = 'O', the array A can overlap A1, if UPLO = 'L', C or A2, if UPLO = 'U'. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N1+N2). C C B (output) DOUBLE PRECISION array, dimension (LDB,M1) C The leading N-by-M1 part of this array contains the C input/state matrix B for the cascaded system. C If OVER = 'O', the array B can overlap B1, if UPLO = 'L', C or B2, if UPLO = 'U'. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N1+N2). C C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) C The leading P2-by-N part of this array contains the C state/output matrix C for the cascaded system. C If OVER = 'O', the array C can overlap C1, if UPLO = 'L', C or C2, if UPLO = 'U'. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,P2) if N1+N2 > 0. C LDC >= 1 if N1+N2 = 0. C C D (output) DOUBLE PRECISION array, dimension (LDD,M1) C The leading P2-by-M1 part of this array contains the C input/output matrix D for the cascaded system. C If OVER = 'O', the array D can overlap D1, if UPLO = 'L', C or D2, if UPLO = 'U'. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P2). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C The array DWORK is not referenced if OVER = 'N'. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( 1, P1*MAX(N1, M1, N2, P2) ) if OVER = 'O'. C LDWORK >= 1 if OVER = '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 METHOD C C After cascaded inter-connection of the two systems C C X1' = A1*X1 + B1*U C V = C1*X1 + D1*U C C X2' = A2*X2 + B2*V C Y = C2*X2 + D2*V C C (where ' denotes differentiation with respect to time) C C the following state-space model will be obtained: C C X' = A*X + B*U C Y = C*X + D*U C C where matrix A has the form ( A1 0 ), C ( B2*C1 A2) C C matrix B has the form ( B1 ), C ( B2*D1 ) C C matrix C has the form ( D2*C1 C2 ) and C C matrix D has the form ( D2*D1 ). C C This form is returned by the routine when UPLO = 'L'. Note that C when A1 and A2 are block lower triangular, the resulting state C matrix is also block lower triangular. C C By applying a similarity transformation to the system above, C using the matrix ( 0 I ), where I is the identity matrix of C ( J 0 ) C order N2, and J is the identity matrix of order N1, the C system matrices become C C A = ( A2 B2*C1 ), C ( 0 A1 ) C C B = ( B2*D1 ), C ( B1 ) C C C = ( C2 D2*C1 ) and C C D = ( D2*D1 ). C C This form is returned by the routine when UPLO = 'U'. Note that C when A1 and A2 are block upper triangular (for instance, in the C real Schur form), the resulting state matrix is also block upper C triangular. C C REFERENCES C C None C C NUMERICAL ASPECTS C C The algorithm requires P1*(N1+M1)*(N2+P2) operations. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and C A. Varga, German Aerospace Research Establishment, C Oberpfaffenhofen, Germany, Nov. 1996. C Supersedes Release 2.0 routine AB05AD by C.J.Benson, Kingston C Polytechnic, United Kingdom, January 1982. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 2003, C Feb. 2004. C C KEYWORDS C C Cascade control, continuous-time system, multivariable C system, state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER OVER, UPLO INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, $ LDC1, LDC2, LDD, LDD1, LDD2, LDWORK, M1, N, N1, $ N2, P1, P2 C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*), $ DWORK(*) C .. Local Scalars .. LOGICAL LOVER, LUPLO INTEGER I, I1, I2, J, LDWN2, LDWP1, LDWP2 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C LOVER = LSAME( OVER, 'O' ) LUPLO = LSAME( UPLO, 'L' ) N = N1 + N2 INFO = 0 C C Test the input scalar arguments. C IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -1 ELSE IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN INFO = -2 ELSE IF( N1.LT.0 ) THEN INFO = -3 ELSE IF( M1.LT.0 ) THEN INFO = -4 ELSE IF( P1.LT.0 ) THEN INFO = -5 ELSE IF( N2.LT.0 ) THEN INFO = -6 ELSE IF( P2.LT.0 ) THEN INFO = -7 ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN INFO = -9 ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN INFO = -11 ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN INFO = -13 ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN INFO = -15 ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN INFO = -17 ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN INFO = -19 ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P2 ) ) .OR. $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN INFO = -21 ELSE IF( LDD2.LT.MAX( 1, P2 ) ) THEN INFO = -23 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -26 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -28 ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P2 ) ) .OR. $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN INFO = -30 ELSE IF( LDD.LT.MAX( 1, P2 ) ) THEN INFO = -32 ELSE IF( ( LOVER.AND.LDWORK.LT.MAX( 1, P1*MAX( N1, M1, N2, P2 )) ) $.OR.( .NOT.LOVER.AND.LDWORK.LT.1 ) ) THEN INFO = -34 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB05MD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, MIN( M1, P2 ) ).EQ.0 ) $ RETURN C C Set row/column indices for storing the results. C IF ( LUPLO ) THEN I1 = 1 I2 = MIN( N1 + 1, N ) ELSE I1 = MIN( N2 + 1, N ) I2 = 1 END IF C LDWN2 = MAX( 1, N2 ) LDWP1 = MAX( 1, P1 ) LDWP2 = MAX( 1, P2 ) C C Construct the cascaded system matrices, taking the desired block C structure and possible overwriting into account. C C Form the diagonal blocks of matrix A. C IF ( LUPLO ) THEN C C Lower block diagonal structure. C IF ( LOVER .AND. LDA1.LE.LDA ) THEN IF ( LDA1.LT.LDA ) THEN C DO 20 J = N1, 1, -1 DO 10 I = N1, 1, -1 A(I,J) = A1(I,J) 10 CONTINUE 20 CONTINUE C END IF ELSE CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) END IF IF ( N2.GT.0 ) $ CALL DLACPY( 'F', N2, N2, A2, LDA2, A(I2,I2), LDA ) ELSE C C Upper block diagonal structure. C IF ( LOVER .AND. LDA2.LE.LDA ) THEN IF ( LDA2.LT.LDA ) THEN C DO 40 J = N2, 1, -1 DO 30 I = N2, 1, -1 A(I,J) = A2(I,J) 30 CONTINUE 40 CONTINUE C END IF ELSE CALL DLACPY( 'F', N2, N2, A2, LDA2, A, LDA ) END IF IF ( N1.GT.0 ) $ CALL DLACPY( 'F', N1, N1, A1, LDA1, A(I1,I1), LDA ) END IF C C Form the off-diagonal blocks of matrix A. C IF ( MIN( N1, N2 ).GT.0 ) THEN CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(I1,I2), LDA ) CALL DGEMM ( 'No transpose', 'No transpose', N2, N1, P1, ONE, $ B2, LDB2, C1, LDC1, ZERO, A(I2,I1), LDA ) END IF C IF ( LUPLO ) THEN C C Form the matrix B. C IF ( LOVER .AND. LDB1.LE.LDB ) THEN IF ( LDB1.LT.LDB ) THEN C DO 60 J = M1, 1, -1 DO 50 I = N1, 1, -1 B(I,J) = B1(I,J) 50 CONTINUE 60 CONTINUE C END IF ELSE CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) END IF C IF ( MIN( N2, M1 ).GT.0 ) $ CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, $ ONE, B2, LDB2, D1, LDD1, ZERO, B(I2,1), LDB ) C C Form the matrix C. C IF ( N1.GT.0 ) THEN IF ( LOVER ) THEN C C Workspace: P1*N1. C CALL DLACPY( 'F', P1, N1, C1, LDC1, DWORK, LDWP1 ) CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, $ ONE, D2, LDD2, DWORK, LDWP1, ZERO, C, LDC ) ELSE CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, $ ONE, D2, LDD2, C1, LDC1, ZERO, C, LDC ) END IF END IF C IF ( MIN( P2, N2 ).GT.0 ) $ CALL DLACPY( 'F', P2, N2, C2, LDC2, C(1,I2), LDC ) C C Now form the matrix D. C IF ( LOVER ) THEN C C Workspace: P1*M1. C CALL DLACPY( 'F', P1, M1, D1, LDD1, DWORK, LDWP1 ) CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, $ ONE, D2, LDD2, DWORK, LDWP1, ZERO, D, LDD ) ELSE CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, $ ONE, D2, LDD2, D1, LDD1, ZERO, D, LDD ) END IF C ELSE C C Form the matrix B. C IF ( LOVER ) THEN C C Workspace: N2*P1. C CALL DLACPY( 'F', N2, P1, B2, LDB2, DWORK, LDWN2 ) IF ( MIN( N2, M1 ).GT.0 ) $ CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, $ ONE, DWORK, LDWN2, D1, LDD1, ZERO, B(I2,1), $ LDB ) ELSE CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, $ ONE, B2, LDB2, D1, LDD1, ZERO, B, LDB ) END IF C IF ( MIN( N1, M1 ).GT.0 ) $ CALL DLACPY( 'F', N1, M1, B1, LDB1, B(I1,1), LDB ) C C Form the matrix C. C IF ( LOVER .AND. LDC2.LE.LDC ) THEN IF ( LDC2.LT.LDC ) THEN C DO 80 J = N2, 1, -1 DO 70 I = P2, 1, -1 C(I,J) = C2(I,J) 70 CONTINUE 80 CONTINUE C END IF ELSE CALL DLACPY( 'F', P2, N2, C2, LDC2, C, LDC ) END IF C IF ( MIN( P2, N1 ).GT.0 ) $ CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, $ ONE, D2, LDD2, C1, LDC1, ZERO, C(1,I1), LDC ) C C Now form the matrix D. C IF ( LOVER ) THEN C C Workspace: P2*P1. C CALL DLACPY( 'F', P2, P1, D2, LDD2, DWORK, LDWP2 ) CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, $ ONE, DWORK, LDWP2, D1, LDD1, ZERO, D, LDD ) ELSE CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, $ ONE, D2, LDD2, D1, LDD1, ZERO, D, LDD ) END IF END IF C RETURN C *** Last line of AB05MD *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03BY.f0000644000000000000000000000013215012430707016204 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SG03BY.f0000644000175000017500000000376115012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE SG03BY( XR, XI, YR, YI, CR, CI, SR, SI, Z ) C C PURPOSE C C To compute the parameters for the complex Givens rotation C C ( CR-CI*I SR-SI*I ) ( XR+XI*I ) ( Z ) C ( ) * ( ) = ( ), C ( -SR-SI*I CR+CI*I ) ( YR+YI*I ) ( 0 ) C C where CR, CI, SR, SI, XR, XI, YR, YI are real numbers and I is the C imaginary unit, I = SQRT(-1). Z is a non-negative real number. C C ARGUMENTS C C Input/Output Parameters C C XR, XI, (input) DOUBLE PRECISION C YR, YI (input) DOUBLE PRECISION C The given real scalars XR, XI, YR, YI. C C CR, CI, (output) DOUBLE PRECISION C SR, SI, (output) DOUBLE PRECISION C Z (output) DOUBLE PRECISION C The computed real scalars CR, CI, SR, SI, Z, defining the C complex Givens rotation and Z. C C NUMERICAL ASPECTS C C The subroutine avoids unnecessary overflow. C C FURTHER COMMENTS C C In the interest of speed, this routine does not check the input C for errors. C C CONTRIBUTOR C C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. C C REVISIONS C C Sep. 1998 (V. Sima). C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. Scalar Arguments .. DOUBLE PRECISION CI, CR, SI, SR, XI, XR, YI, YR, Z C .. Intrinsic Functions .. DOUBLE PRECISION ABS, MAX, SQRT C .. Executable Statements .. C Z = MAX( ABS( XR ), ABS( XI ), ABS( YR ), ABS( YI ) ) C IF ( Z .EQ. ZERO ) THEN CR = ONE CI = ZERO SR = ZERO SI = ZERO ELSE Z = Z*SQRT( ( XR/Z )**2 + ( XI/Z )**2 + $ ( YR/Z )**2 + ( YI/Z )**2 ) CR = XR/Z CI = XI/Z SR = YR/Z SI = YI/Z END IF C RETURN C C *** Last line of SG03BY *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09AX.f0000644000000000000000000000013215012430707016161 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09AX.f0000644000175000017500000004545615012430707017373 0ustar00lilgelilge00000000000000 SUBROUTINE AB09AX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, $ C, LDC, HSV, T, LDT, TI, LDTI, TOL, IWORK, $ DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr) for a stable original C state-space representation (A,B,C) by using either the square-root C or the balancing-free square-root Balance & Truncate model C reduction method. The state dynamics matrix A of the original C system is an upper quasi-triangular matrix in real Schur canonical C form. The matrices of the reduced order system are computed using C the truncation formulas: C C Ar = TI * A * T , Br = TI * B , Cr = C * T . 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 JOB CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root Balance & Truncate method; C = 'N': use the balancing-free square-root C Balance & Truncate method. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of the C resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. NR is set as follows: C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR C is the desired order on entry and NMIN is the order of a C minimal realization of the given system; NMIN is C determined as the number of Hankel singular values greater C than N*EPS*HNORM(A,B,C), where EPS is the machine C precision (see LAPACK Library Routine DLAMCH) and C HNORM(A,B,C) is the Hankel norm of the system (computed C in HSV(1)); C if ORDSEL = 'A', NR is equal to the number of Hankel C singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)). 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 in a real Schur C canonical form. C On exit, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the C reduced order system. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, it contains the Hankel singular values of C the original system ordered decreasingly. HSV(1) is the C Hankel norm of the system. C C T (output) DOUBLE PRECISION array, dimension (LDT,N) C If INFO = 0 and NR > 0, the leading N-by-NR part of this C array contains the right truncation matrix T. C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,N). C C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) C If INFO = 0 and NR > 0, the leading NR-by-N part of this C array contains the left truncation matrix TI. C C LDTI INTEGER C The leading dimension of array TI. LDTI >= MAX(1,N). C C Tolerances C C TOL DOUBLE PRECISION C If ORDSEL = 'A', TOL contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL = c*HNORM(A,B,C), where c is a constant in the C interval [0.00001,0.001], and HNORM(A,B,C) is the C Hankel-norm of the given system (computed in HSV(1)). C For computing a minimal realization, the recommended C value is TOL = N*EPS*HNORM(A,B,C), where EPS is the C machine precision (see LAPACK Library Routine DLAMCH). C This value is used by default if TOL <= 0 on entry. C If ORDSEL = 'F', the value of TOL is ignored. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = 0, if JOB = 'B', or C LIWORK = N, if JOB = 'N'. 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,N*(MAX(N,M,P)+5) + N*(N+1)/2). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than the order of a minimal realization of the C given system. In this case, the resulting NR is C set automatically to a value corresponding to the C order of a minimal realization of the system. 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 state matrix A is not stable (if DICO = 'C') C or not convergent (if DICO = 'D'); C = 2: the computation of Hankel singular values failed. C C METHOD C C Let be the stable linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09AX determines for C the given system (1), the matrices of a reduced NR order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) (2) C C such that C C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], C C where G and Gr are transfer-function matrices of the systems C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the C infinity-norm of G. C C If JOB = 'B', the square-root Balance & Truncate method of [1] C is used and, for DICO = 'C', the resulting model is balanced. C By setting TOL <= 0, the routine can be used to compute balanced C minimal state-space realizations of stable systems. C C If JOB = 'N', the balancing-free square-root version of the C Balance & Truncate method [2] is used. C By setting TOL <= 0, the routine can be used to compute minimal C state-space realizations of stable systems. C C REFERENCES C C [1] Tombs M.S. and Postlethwaite I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C [2] Varga A. C Efficient minimal realization procedure based on balancing. C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), C Vol. 2, pp. 42-46. C C NUMERICAL ASPECTS C C The implemented methods rely on accuracy enhancing square-root or C balancing-free square-root techniques. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, March 1998. C Based on the RASP routines SRBT1 and SRBFT1. C C REVISIONS C C May 2, 1998. C November 11, 1998, V. Sima, Research Institute for Informatics, C Bucharest. C December 1998, V. Sima, Katholieke Univ. Leuven, Leuven. C February 14, 1999, A. Varga, German Aerospace Center. C February 22, 1999, V. Sima, Research Institute for Informatics. C February 27, 2000, V. Sima, Research Institute for Informatics. C C KEYWORDS C C Balancing, minimal state-space representation, model reduction, C multivariable system, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOB, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDT, LDTI, LDWORK, $ M, N, NR, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*), $ T(LDT,*), TI(LDTI,*) C .. Local Scalars .. LOGICAL BAL, DISCR, FIXORD, PACKED INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, WRKOPT DOUBLE PRECISION ATOL, RTOL, SCALEC, SCALEO, TEMP C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, DLACPY, $ DORGQR, DSCAL, DTPMV, DTRMM, DTRMV, MA02AD, $ MA02DD, MB03UD, SB03OU, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) BAL = LSAME( JOB, 'B' ) FIXORD = LSAME( ORDSEL, 'F' ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( BAL .OR. LSAME( JOB, 'N') ) ) THEN INFO = -2 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + $ ( N*( N + 1 ) )/2 ) ) THEN INFO = -22 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09AX', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN NR = 0 DWORK(1) = ONE RETURN END IF C RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) C C Allocate N*MAX(N,M,P) and N working storage for the matrices U C and TAU, respectively. C KU = 1 KTAU = KU + N*MAX( N, M, P ) KW = KTAU + N LDW = LDWORK - KW + 1 C C Copy B in U. C CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) C C If DISCR = .FALSE., solve for Su the Lyapunov equation C 2 C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . C C If DISCR = .TRUE., solve for Su the Lyapunov equation C 2 C A*(Su*Su')*A' + scalec *B*B' = Su*Su' . C C Workspace: need N*(MAX(N,M,P) + 5); C prefer larger. C CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, $ DWORK(KTAU), TI, LDTI, SCALEC, DWORK(KW), LDW, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN ENDIF WRKOPT = INT( DWORK(KW) ) + KW - 1 C C Copy C in U. C CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) C C If DISCR = .FALSE., solve for Ru the Lyapunov equation C 2 C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * C'*C = 0 . C C If DISCR = .TRUE., solve for Ru the Lyapunov equation C 2 C A'*(Ru'*Ru)*A + scaleo * C'*C = Ru'*Ru . C C Workspace: need N*(MAX(N,M,P) + 5); C prefer larger. C CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, $ DWORK(KTAU), T, LDT, SCALEO, DWORK(KW), LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Allocate N*(N+1)/2 (or, if possible, N*N) working storage for the C matrix V, a packed (or unpacked) copy of Su, and save Su in V. C (The locations for TAU are reused here.) C KV = KTAU IF ( LDWORK-KV+1.LT.N*( N + 5 ) ) THEN PACKED = .TRUE. CALL MA02DD( 'Pack', 'Upper', N, TI, LDTI, DWORK(KV) ) KW = KV + ( N*( N + 1 ) )/2 ELSE PACKED = .FALSE. CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) KW = KV + N*N END IF C | x x | C Compute Ru*Su in the form | 0 x | in TI. C DO 10 J = 1, N CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, $ TI(1,J), 1 ) 10 CONTINUE C C Compute the singular value decomposition Ru*Su = V*S*UT C of the upper triangular matrix Ru*Su, with UT in TI and V in U. C C Workspace: need N*MAX(N,M,P) + N*(N+1)/2 + 5*N; C prefer larger. C CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 2 RETURN ENDIF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Scale singular values. C CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) C C Partition S, U and V conformally as: C C S = diag(S1,S2), U = [U1,U2] (U' in TI) and V = [V1,V2] (in U). C C Compute the order of reduced system, as the order of S1. C ATOL = RTOL*HSV(1) IF( FIXORD ) THEN IF( NR.GT.0 ) THEN IF( HSV(NR).LE.ATOL ) THEN NR = 0 IWARN = 1 FIXORD = .FALSE. ENDIF ENDIF ELSE ATOL = MAX( TOL, ATOL ) NR = 0 ENDIF IF( .NOT.FIXORD ) THEN DO 20 J = 1, N IF( HSV(J).LE.ATOL ) GO TO 30 NR = NR + 1 20 CONTINUE 30 CONTINUE ENDIF C IF( NR.EQ.0 ) THEN DWORK(1) = WRKOPT RETURN END IF C C Compute the truncation matrices. C C Compute TI' = Ru'*V1 in U. C CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NR, ONE, $ T, LDT, DWORK(KU), N ) C C Compute T = Su*U1 (with Su packed, if not enough workspace). C CALL MA02AD( 'Full', NR, N, TI, LDTI, T, LDT ) IF ( PACKED ) THEN DO 40 J = 1, NR CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(KV), $ T(1,J), 1 ) 40 CONTINUE ELSE CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, NR, $ ONE, DWORK(KV), N, T, LDT ) END IF C IF( BAL ) THEN IJ = KU C C Square-Root B & T method. C C Compute the truncation matrices for balancing C -1/2 -1/2 C T*S1 and TI'*S1 C DO 50 J = 1, NR TEMP = ONE/SQRT( HSV(J) ) CALL DSCAL( N, TEMP, T(1,J), 1 ) CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) IJ = IJ + N 50 CONTINUE ELSE C C Balancing-Free B & T method. C C Compute orthogonal bases for the images of matrices T and TI'. C C Workspace: need N*MAX(N,M,P) + 2*NR; C prefer N*MAX(N,M,P) + NR*(NB+1) C (NB determined by ILAENV for DGEQRF). C KW = KTAU + NR LDW = LDWORK - KW + 1 CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, $ IERR ) CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), $ LDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) END IF C C Transpose TI' to obtain TI. C CALL MA02AD( 'Full', N, NR, DWORK(KU), N, TI, LDTI ) C IF( .NOT.BAL ) THEN C -1 C Compute (TI*T) *TI in TI. C CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, $ LDTI, T, LDT, ZERO, DWORK(KU), N ) CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, $ LDTI, IERR ) END IF C C Compute TI*A*T (A is in RSF). C IJ = KU DO 60 J = 1, N K = MIN( J+1, N ) CALL DGEMV( 'NoTranspose', NR, K, ONE, TI, LDTI, A(1,J), 1, $ ZERO, DWORK(IJ), 1 ) IJ = IJ + N 60 CONTINUE CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) C C Compute TI*B and C*T. C CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, N, ONE, TI, LDTI, $ DWORK(KU), N, ZERO, B, LDB ) C CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, N, ONE, $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) C DWORK(1) = WRKOPT C RETURN C *** Last line of AB09AX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04BD.f0000644000000000000000000000013215012430707016145 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04BD.f0000644000175000017500000014117015012430707017345 0ustar00lilgelilge00000000000000 SUBROUTINE MB04BD( JOB, COMPQ1, COMPQ2, N, A, LDA, DE, LDDE, C1, $ LDC1, VW, LDVW, Q1, LDQ1, Q2, LDQ2, B, LDB, F, $ LDF, C2, LDC2, ALPHAR, ALPHAI, BETA, IWORK, $ LIWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the eigenvalues of a real N-by-N skew-Hamiltonian/ C Hamiltonian pencil aS - bH with C C ( A D ) ( C V ) C S = ( ) and H = ( ). (1) C ( E A' ) ( W -C' ) C C Optionally, if JOB = 'T', decompositions of S and H will be C computed via orthogonal transformations Q1 and Q2 as follows: C C ( Aout Dout ) C Q1' S J Q1 J' = ( ), C ( 0 Aout' ) C C ( Bout Fout ) C J' Q2' J S Q2 = ( ) =: T, (2) C ( 0 Bout' ) C C ( C1out Vout ) ( 0 I ) C Q1' H Q2 = ( ), where J = ( ) C ( 0 C2out' ) ( -I 0 ) C C and Aout, Bout, C1out are upper triangular, C2out is upper quasi- C triangular and Dout and Fout are skew-symmetric. The notation M' C denotes the transpose of the matrix M. C Optionally, if COMPQ1 = 'I' or COMPQ1 = 'U', then the orthogonal C transformation matrix Q1 will be computed. C Optionally, if COMPQ2 = 'I' or COMPQ2 = 'U', then the orthogonal C transformation matrix Q2 will be computed. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; S and H will not C necessarily be transformed as in (2). C = 'T': put S and H into the forms in (2) and return the C eigenvalues in ALPHAR, ALPHAI and BETA. C C COMPQ1 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q1, as follows: C = 'N': Q1 is not computed; C = 'I': the array Q1 is initialized internally to the unit C matrix, and the orthogonal matrix Q1 is returned; C = 'U': the array Q1 contains an orthogonal matrix Q on C entry, and the product Q*Q1 is returned, where Q1 C is the product of the orthogonal transformations C that are applied to the pencil aS - bH to reduce C S and H to the forms in (2), for COMPQ1 = 'I'. C C COMPQ2 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q2, as follows: C = 'N': Q2 is not computed; C = 'I': on exit, the array Q2 contains the orthogonal C matrix Q2; C = 'U': on exit, the array Q2 contains the matrix product C J*Q*J'*Q2, where Q2 is the product of the C orthogonal transformations that are applied to C the pencil aS - bH to reduce S and H to the forms C in (2), for COMPQ2 = 'I'. C Setting COMPQ2 <> 'N' assumes COMPQ2 = COMPQ1. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix A. C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix Aout; otherwise, it contains the C upper triangular matrix A obtained just before the C application of the periodic QZ algorithm. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C DE (input/output) DOUBLE PRECISION array, dimension C (LDDE, N/2+1) C On entry, the leading N/2-by-N/2 strictly lower triangular C part of this array must contain the strictly lower C triangular part of the skew-symmetric matrix E, and the C N/2-by-N/2 strictly upper triangular part of the submatrix C in the columns 2 to N/2+1 of this array must contain the C strictly upper triangular part of the skew-symmetric C matrix D. C The entries on the diagonal and the first superdiagonal of C this array need not be set, but are assumed to be zero. C On exit, if JOB = 'T', the leading N/2-by-N/2 strictly C upper triangular part of the submatrix in the columns 2 to C N/2+1 of this array contains the strictly upper triangular C part of the skew-symmetric matrix Dout. C If JOB = 'E', the leading N/2-by-N/2 strictly upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array contains the strictly upper triangular part C of the skew-symmetric matrix D just before the application C of the periodic QZ algorithm. The remaining entries are C meaningless. C C LDDE INTEGER C The leading dimension of the array DE. C LDDE >= MAX(1, N/2). C C C1 (input/output) DOUBLE PRECISION array, dimension C (LDC1, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix C1 = C. C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix C1out; otherwise, it contains C the upper triangular matrix C1 obtained just before the C application of the periodic QZ algorithm. C C LDC1 INTEGER C The leading dimension of the array C1. C LDC1 >= MAX(1, N/2). C C VW (input/output) DOUBLE PRECISION array, dimension C (LDVW, N/2+1) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C symmetric matrix W, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C symmetric matrix V. C On exit, if JOB = 'T', the N/2-by-N/2 part in the columns C 2 to N/2+1 of this array contains the matrix Vout. C If JOB = 'E', the N/2-by-N/2 part in the columns 2 to C N/2+1 of this array contains the matrix V just before the C application of the periodic QZ algorithm. C C LDVW INTEGER C The leading dimension of the array VW. C LDVW >= MAX(1, N/2). C C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1, N) C On entry, if COMPQ1 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q and the transformation matrix Q1 C used to transform the matrices S and H. C On exit, if COMPQ1 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q1. C If COMPQ1 = 'N', this array is not referenced. C C LDQ1 INTEGER C The leading dimension of the array Q1. C LDQ1 >= 1, if COMPQ1 = 'N'; C LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N) C On exit, if COMPQ2 = 'U', then the leading N-by-N part of C this array contains the product of the matrix J*Q*J' and C the transformation matrix Q2 used to transform the C matrices S and H. C On exit, if COMPQ2 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q2. C If COMPQ2 = 'N', this array is not referenced. C C LDQ2 INTEGER C The leading dimension of the array Q2. C LDQ2 >= 1, if COMPQ2 = 'N'; C LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'. C C B (output) DOUBLE PRECISION array, dimension (LDB, N/2) C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix Bout; otherwise, it contains the C upper triangular matrix B obtained just before the C application of the periodic QZ algorithm. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C F (output) DOUBLE PRECISION array, dimension (LDF, N/2) C On exit, if JOB = 'T', the leading N/2-by-N/2 strictly C upper triangular part of this array contains the strictly C upper triangular part of the skew-symmetric matrix Fout. C If JOB = 'E', the leading N/2-by-N/2 strictly upper C triangular part of this array contains the strictly upper C triangular part of the skew-symmetric matrix F just before C the application of the periodic QZ algorithm. C The entries on the leading N/2-by-N/2 lower triangular C part of this array are not referenced. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1, N/2). C C C2 (output) DOUBLE PRECISION array, dimension (LDC2, N/2) C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix C2out; otherwise, it contains C the upper Hessenberg matrix C2 obtained just before the C application of the periodic QZ algorithm. C C LDC2 INTEGER C The leading dimension of the array C2. C LDC2 >= MAX(1, N/2). C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C Due to the skew-Hamiltonian/Hamiltonian structure of the C pencil, for every eigenvalue lambda, -lambda is also an C eigenvalue, and thus it has only to be saved once in C ALPHAR, ALPHAI and BETA. C Specifically, only eigenvalues with imaginary parts C greater than or equal to zero are stored; their conjugate C eigenvalues are not stored. If imaginary parts are zero C (i.e., for real eigenvalues), only positive eigenvalues C are stored. The remaining eigenvalues have opposite signs. C As a consequence, pairs of complex eigenvalues, stored in C consecutive locations, are not complex conjugate. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = 3, IWORK(1) contains the number of C (pairs of) possibly inaccurate eigenvalues, q <= N/2, and C IWORK(2), ..., IWORK(q+1) indicate their indices. C Specifically, a positive value is an index of a real or C purely imaginary eigenvalue, corresponding to a 1-by-1 C block, while the absolute value of a negative entry in C IWORK is an index to the first eigenvalue in a pair of C consecutively stored eigenvalues, corresponding to a C 2-by-2 block. A 2-by-2 block may have two complex, two C real, two purely imaginary, or one real and one purely C imaginary eigenvalue. C For i = q+2, ..., 2*q+1, IWORK(i) contains a pointer to C the starting location in DWORK of the (i-q-1)-th quadruple C of 1-by-1 blocks, if IWORK(i-q) > 0, or 2-by-2 blocks, C if IWORK(i-q) < 0, defining unreliable eigenvalues. C IWORK(2*q+2) contains the number of the 1-by-1 blocks, and C IWORK(2*q+3) contains the number of the 2-by-2 blocks, C corresponding to unreliable eigenvalues. IWORK(2*q+4) C contains the total number t of the 2-by-2 blocks. C If INFO = 0, then q = 0, therefore IWORK(1) = 0. C C LIWORK INTEGER C The dimension of the array IWORK. LIWORK >= N+12. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or INFO = 3, DWORK(1) returns the C optimal LDWORK, and DWORK(2), ..., DWORK(5) contain the C Frobenius norms of the factors of the formal matrix C product used by the algorithm. In addition, DWORK(6), ..., C DWORK(5+4*s) contain the s quadruple values corresponding C to the 1-by-1 blocks. Their eigenvalues are real or purely C imaginary. Such an eigenvalue is obtained from C -i*sqrt(a1*a3/a2/a4), but always taking a positive sign, C where a1, ..., a4 are the corresponding quadruple values. C Moreover, DWORK(6+4*s), ..., DWORK(5+4*s+16*t) contain the C t groups of quadruple 2-by-2 matrices corresponding to the C 2-by-2 blocks. Their eigenvalue pairs are either complex, C or placed on the real and imaginary axes. Such an C eigenvalue pair is obtained as -1i*sqrt(ev), but taking C positive imaginary parts, where ev are the eigenvalues of C the product A1*inv(A2)*A3*inv(A4), where A1, ..., A4 C define the corresponding 2-by-2 matrix quadruple. C On exit, if INFO = -27, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C If JOB = 'E' and COMPQ1 = 'N' and COMPQ2 = 'N', C LDWORK >= N**2 + MAX(L,36); C if JOB = 'T' or COMPQ1 <> 'N' or COMPQ2 <> 'N', C LDWORK >= 2*N**2 + MAX(L,36); C where C L = 4*N + 4, if N/2 is even, and C L = 4*N, if N/2 is odd. C For good performance LDWORK should generally be larger. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: problem during computation of the eigenvalues; C = 2: periodic QZ algorithm did not converge in the SLICOT C Library subroutine MB03BD; C = 3: some eigenvalues might be inaccurate, and details can C be found in IWORK and DWORK. This is a warning. C C METHOD C C The algorithm uses Givens rotations and Householder reflections to C annihilate elements in S, T, and H such that A, B, and C1 are C upper triangular and C2 is upper Hessenberg. Finally, the periodic C QZ algorithm is applied to transform C2 to upper quasi-triangular C form while A, B, and C1 stay in upper triangular form. C See also page 27 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 16, 2008. C C REVISIONS C C V. Sima, Oct. 2009 (SLICOT version of the routine DHAUTR). C V. Sima, Nov. 2010, Feb. 2011, Oct. 2011. C M. Voigt, Jan. 2012, July 2014. C V. Sima, Oct. 2012, Jan. 2013, Feb. 2013, July 2013, Aug. 2014, C Sep. 2016, Nov. 2016, Jan. 2017, Apr. 2018, Mar. 2019, Mar. 2020, C Apr. 2020, Apr. 2021, July 2022. C C KEYWORDS C C periodic QZ algorithm, upper (quasi-)triangular matrix, C skew-Hamiltonian/Hamiltonian pencil. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO, FIVE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, $ TWO = 2.0D+0, FIVE = 5.0D+0 ) C C .. Scalar Arguments .. CHARACTER COMPQ1, COMPQ2, JOB INTEGER INFO, LDA, LDB, LDC1, LDC2, LDDE, LDF, LDQ1, $ LDQ2, LDVW, LDWORK, LIWORK, N C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), C1( LDC1, * ), $ C2( LDC2, * ), DE( LDDE, * ), DWORK( * ), $ F( LDF, * ), Q1( LDQ1, * ), Q2( LDQ2, * ), $ VW( LDVW, * ) C C .. Local Scalars .. LOGICAL LCMPQ1, LCMPQ2, LINIQ1, LINIQ2, LTRI, LUPDQ1, $ LUPDQ2, UNREL CHARACTER*16 CMPQ, CMPSC INTEGER EMAX, EMIN, I, I11, I22, I2X2, IMAT, IW, IWARN, $ IWRK, J, K, L, M, MJ1, MJ2, MJ3, MK1, MK2, MK3, $ MM, NBETA0, NINF, OPTDW, P DOUBLE PRECISION BASE, CO, MU, NU, SI, TEMP, TMP1, TMP2 COMPLEX*16 EIG C C .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 4 ) C C .. External Functions .. LOGICAL LSAME INTEGER MA02OD DOUBLE PRECISION DDOT, DLAMCH, DLANTR, DLAPY2 EXTERNAL DDOT, DLAMCH, DLANTR, DLAPY2, LSAME, MA02OD C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLARF, DLARFG, $ DLARTG, DLASET, DROT, DSYMV, DSYR2, MA02AD, $ MA02PD, MB01LD, MB01MD, MB01ND, MB03BD, XERBLA C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, $ SQRT C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 MM = M*M LTRI = LSAME( JOB, 'T' ) LINIQ1 = LSAME( COMPQ1, 'I' ) LINIQ2 = LSAME( COMPQ2, 'I' ) LUPDQ1 = LSAME( COMPQ1, 'U' ) LUPDQ2 = LSAME( COMPQ2, 'U' ) LCMPQ1 = LUPDQ1 .OR. LINIQ1 LCMPQ2 = LUPDQ2 .OR. LINIQ2 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ1, 'N' ) .OR. LCMPQ1 ) ) THEN INFO = -2 ELSE IF( .NOT.( LSAME( COMPQ2, 'N' ) .OR. LCMPQ2 ) ) THEN INFO = -3 ELSE IF( ( LINIQ2 .AND. .NOT.LINIQ1 ) .OR. $ ( LUPDQ2 .AND. .NOT.LUPDQ1 ) ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF( LDDE.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDC1.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDVW.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( LDQ1.LT.1 .OR. ( LCMPQ1 .AND. LDQ1.LT.N ) ) THEN INFO = -14 ELSE IF( LDQ2.LT.1 .OR. ( LCMPQ2 .AND. LDQ2.LT.N ) ) THEN INFO = -16 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -18 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -20 ELSE IF( LDC2.LT.MAX( 1, M ) ) THEN INFO = -22 ELSE IF( LIWORK.LT.N+12 ) THEN INFO = -27 ELSE IF( MOD( M, 2 ).EQ.0 ) THEN I = MAX( 4*N, 32 ) + 4 ELSE I = MAX( 4*N, 36 ) END IF IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 ) THEN OPTDW = 8*MM + I ELSE OPTDW = 4*MM + I END IF IF( LDWORK.LT.OPTDW ) $ INFO = -29 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04BD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IWORK( 1 ) = 0 DWORK( 1 ) = FIVE DWORK( 2 ) = ZERO DWORK( 3 ) = ZERO DWORK( 4 ) = ZERO DWORK( 5 ) = ZERO RETURN END IF C C Determine machine constants. C BASE = DLAMCH( 'Base' ) EMIN = INT( DLAMCH( 'Minimum Exponent' ) ) EMAX = INT( DLAMCH( 'Largest Exponent' ) ) C C Find half of the number of infinite eigenvalues if S is diagonal. C Otherwise, find a lower bound of this number. C NINF = 0 IF( M.EQ.1 ) THEN TEMP = ZERO ELSE TEMP = DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, DE( 2, 1 ), $ LDDE, DWORK ) + $ DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, DE( 1, 3 ), $ LDDE, DWORK ) END IF IF( TEMP.EQ.ZERO ) THEN IF( M.EQ.1 ) THEN IF( A( 1, 1 ).EQ.ZERO ) $ NINF = 1 ELSE IF( DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, A( 2, 1 ), $ LDA, DWORK ).EQ.ZERO .AND. $ DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, A( 1, 2 ), $ LDA, DWORK ).EQ.ZERO ) THEN DO 10 J = 1, M IF( A( J, J ).EQ.ZERO ) $ NINF = NINF + 1 10 CONTINUE ELSE CALL MA02PD( M, M, A, LDA, I, J ) NINF = MAX( I, J )/2 END IF END IF ELSE C C Incrementing NINF below is due to even multiplicity of C eigenvalues for real skew-Hamiltonian matrices. C NINF = MA02OD( 'Skew', M, A, LDA, DE, LDDE ) IF( MOD( NINF, 2 ).GT.0 ) $ NINF = NINF + 1 NINF = NINF/2 END IF C C STEP 1: Reduce S to skew-Hamiltonian triangular form. C IF( LINIQ1 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 ) C DUM( 1 ) = ZERO C DO 20 K = 1, M - 1 C C Generate elementary reflector H(k) = I - nu * v * v' to C annihilate E(k+2:m,k). C MK2 = MIN( K+2, M ) MK3 = MK2 + 1 TMP1 = DE( K+1, K ) CALL DLARFG( M-K, TMP1, DE( MK2, K ), 1, NU ) IF( NU.NE.ZERO ) THEN DE( K+1, K ) = ONE C C Apply H(k) from both sides to E(k+1:m,k+1:m). C Compute x := nu * E(k+1:m,k+1:m) * v. C CALL MB01MD( 'Lower', M-K, NU, DE( K+1, K+1 ), LDDE, $ DE( K+1, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v in x. C MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 ) CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C E := E + v * w' - w * v'. C CALL MB01ND( 'Lower', M-K, ONE, DE( K+1, K ), 1, DWORK, 1, $ DE( K+1, K+1 ), LDDE ) C C Apply H(k) to W(k+1:m,1:k) from the left (and implicitly to C W(1:k,k+1:m) from the right). C CALL DLARF( 'Left', M-K, K, DE( K+1, K ), 1, NU, $ VW( K+1, 1 ), LDVW, DWORK ) C C Apply H(k) from both sides to W(k+1:m,k+1:m). C Compute x := nu * W(k+1:m,k+1:m) * v. C CALL DSYMV( 'Lower', M-K, NU, VW( K+1, K+1 ), LDVW, $ DE( K+1, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 ) CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C W := W - v * w' - w * v'. C CALL DSYR2( 'Lower', M-K, -ONE, DE( K+1, K ), 1, DWORK, 1, $ VW( K+1, K+1 ), LDVW ) C C Apply H(k) from the right hand side to A(1:m,k+1:m) and C C1(1:m,k+1:m). C CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU, $ A( 1, K+1 ), LDA, DWORK ) CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU, $ C1( 1, K+1 ), LDC1, DWORK ) C IF( LCMPQ1 ) THEN C C Apply H(k) from the right hand side to Q1(1:n,m+k+1:n). C CALL DLARF( 'Right', N, M-K, DE( K+1, K ), 1, NU, $ Q1( 1, M+K+1 ), LDQ1, DWORK ) END IF DE( K+1, K ) = TMP1 END IF C C Determine a Givens rotation to annihilate E(k+1,k) from the C left. C TMP2 = A( K+1, K ) CALL DLARTG( TMP2, DE( K+1, K ), CO, SI, A( K+1, K ) ) C C Update A, E and D. C CALL DROT( M-K-1, DE( MK2, K+1 ), 1, A( K+1, MK2 ), LDA, CO, $ SI ) CALL DROT( K, A( 1, K+1 ), 1, DE( 1, K+2 ), 1, CO, SI ) CALL DROT( M-K-1, DE( K+1, MK3 ), LDDE, A( MK2, K+1 ), 1, CO, $ SI ) C C Update C1, W and V. C CALL DROT( K, VW( K+1, 1 ), LDVW, C1( K+1, 1 ), LDC1, CO, -SI ) CALL DROT( M-K-1, VW( MK2, K+1 ), 1, C1( K+1, MK2 ), LDC1, CO, $ -SI ) CALL DROT( K, C1( 1, K+1 ), 1, VW( 1, K+2 ), 1, CO, SI ) CALL DROT( M-K-1, VW( K+1, MK3 ), LDVW, C1( MK2, K+1 ), 1, CO, $ -SI ) C C Fix the diagonal part. C TMP1 = C1( K+1, K+1 ) TMP2 = VW( K+1, K+2 ) C1( K+1, K+1 ) = ( CO - SI )*( CO + SI )*TMP1 + $ CO*SI*( VW( K+1, K+1 ) + TMP2 ) TMP1 = TWO*CO*SI*TMP1 VW( K+1, K+2 ) = CO**2*TMP2 - SI**2*VW( K+1, K+1 ) - TMP1 VW( K+1, K+1 ) = CO**2*VW( K+1, K+1 ) - SI**2*TMP2 - TMP1 C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, K+1 ), 1, Q1( 1, M+K+1 ), 1, CO, SI ) END IF C C Generate elementary reflector P(k) to annihilate A(k+1:m,k). C TMP1 = A( K, K ) CALL DLARFG( M-K+1, TMP1, A( K+1, K ), 1, NU ) IF( NU.NE.ZERO ) THEN A( K, K ) = ONE C C Apply P(k) from the left hand side to A(k:m,k+1:m). C CALL DLARF( 'Left', M-K+1, M-K, A( K, K ), 1, NU, $ A( K, K+1 ), LDA, DWORK ) C C Apply P(k) to D(1:k-1,k:m) from the right (and implicitly C to D(k:m,1:k-1) from the left). C CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU, $ DE( 1, K+1 ), LDDE, DWORK ) C C Apply P(k) from both sides to D(k:m,k:m). C Compute x := nu * D(k:m,k:m) * v. C CALL MB01MD( 'Upper', M-K+1, NU, DE( K, K+1 ), LDDE, $ A( K, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v in x. C MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 ) CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C D := D + v * w' - w * v'. C CALL MB01ND( 'Upper', M-K+1, ONE, A( K, K ), 1, DWORK, 1, $ DE( K, K+1 ), LDDE ) C C Apply P(k) from the left hand side to C1(k:m,1:m). C CALL DLARF( 'Left', M-K+1, M, A( K, K ), 1, NU, C1( K, 1 ), $ LDC1, DWORK ) C C Apply P(k) to V(1:k-1,k:m) from the right (and implicitly C to V(k:m,1:k-1) from the left). C CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU, $ VW( 1, K+1 ), LDVW, DWORK ) C C Apply P(k) from both sides to V(k:m,k:m). C Compute x := nu * V(k:m,k:m) * v. C CALL DSYMV( 'Upper', M-K+1, NU, VW( K, K+1 ), LDVW, $ A( K, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 ) CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C V := V - v * w' - w * v'. C CALL DSYR2( 'Upper', M-K+1, -ONE, A( K, K ), 1, DWORK, 1, $ VW( K, K+1 ), LDVW ) C IF( LCMPQ1 ) THEN C C Apply P(k) from the right hand side to Q1(1:n,k:m). C CALL DLARF( 'Right', N, M-K+1, A( K, K ), 1, NU, $ Q1( 1, K ), LDQ1, DWORK ) END IF A( K, K ) = TMP1 END IF C C Set A(k+1:m,k) to zero in order to be able to apply MB03BD. C CALL DCOPY( M-K, DUM, 0, A( K+1, K ), 1 ) 20 CONTINUE C C The following operations do not preserve the Hamiltonian structure C of H. -C1 is copied to C2. The lower triangular part of W(1:m,1:m) C and its transpose are stored in DWORK. Then, the transpose of the C upper triangular part of V(1:m,1:m) is saved in the lower C triangular part of VW(1:m,2:m+1). C CALL DLACPY( 'Full', M, M, A, LDA, B, LDB ) CALL DLACPY( 'Upper', M, M, DE( 1, 2 ), LDDE, F, LDF ) C DO 40 J = 1, M DO 30 I = 1, M C2( I, J ) = -C1( I, J ) 30 CONTINUE 40 CONTINUE C CALL DLACPY( 'Lower', M, M, VW, LDVW, DWORK, M ) CALL MA02AD( 'Lower', M, M, VW, LDVW, DWORK, M ) C CALL MA02AD( 'Upper', M, M, VW( 1, 2 ), LDVW, VW( 1, 2 ), LDVW ) C IF ( LCMPQ2 ) THEN CALL DLACPY( 'Full', M, M, Q1( M+1, M+1 ), LDQ1, Q2, LDQ2 ) C DO 60 J = 1, M DO 50 I = M + 1, N Q2( I, J ) = -Q1( I-M, J+M ) 50 CONTINUE 60 CONTINUE C DO 80 J = M + 1, N DO 70 I = 1, M Q2( I, J ) = -Q1( I+M, J-M ) 70 CONTINUE 80 CONTINUE C CALL DLACPY( 'Full', M, M, Q1, LDQ1, Q2( M+1, M+1 ), LDQ2 ) END IF C C STEP 2: Eliminations in H. C DO 130 K = 1, M MK1 = MIN( K+1, M ) C C I. Annihilate W(k:m-1,k). C DO 90 J = K, M - 1 MJ3 = MIN( J+3, M+1 ) C C Determine a Givens rotation to annihilate W(j,k) from the C left. C CALL DLARTG( DWORK( ( K-1 )*M+J+1 ), DWORK( ( K-1 )*M+J ), $ CO, SI, TMP1 ) C C Update C2 and W. C CALL DROT( M, C2( 1, J+1 ), 1, C2( 1, J ), 1, CO, SI ) DWORK( ( K-1 )*M+J+1 ) = TMP1 DWORK( ( K-1 )*M+J ) = ZERO CALL DROT( M-K, DWORK( K*M+J+1 ), M, DWORK( K*M+J ), M, CO, $ SI ) C C Update A. C CALL DROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO, SI ) TMP1 = -SI*A( J+1, J+1 ) A( J+1, J+1 ) = CO*A( J+1, J+1 ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M+J+1 ), 1, Q1( 1, M+J ), 1, CO, SI $ ) END IF C C Determine a Givens rotation to annihilate A(j+1,j) from the C left. C CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 ) C C Update A and D. C A( J, J ) = TMP2 CALL DROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO, SI $ ) CALL DROT( J-1, DE( 1, J+1 ), 1, DE( 1, J+2 ), 1, CO, SI ) CALL DROT( M-J-1, DE( J, MJ3 ), LDDE, DE( J+1, MJ3 ), LDDE, $ CO, SI ) C C Update C1 and V. C CALL DROT( M-K+1, C1( J, K ), LDC1, C1( J+1, K ), LDC1, CO, $ SI ) CALL DROT( M, VW( J, 2 ), LDVW, VW( J+1, 2 ), LDVW, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, J ), 1, Q1( 1, J+1 ), 1, CO, SI ) END IF 90 CONTINUE C C II. Annihilate W(m,k). C C Determine a Givens rotation to annihilate W(m,k) from the left. C CALL DLARTG( C1( M, K ), DWORK( M*K ), CO, SI, TMP1 ) C C Update C1 and W. C C1( M, K ) = TMP1 DWORK( M*K ) = ZERO CALL DROT( M-K, C1( M, MK1 ), LDC1, DWORK( M*MK1 ), M, CO, SI ) CALL DROT( M, VW( M, 2 ), LDVW, C2( 1, M ), 1, CO, SI ) C C Update A and D. C CALL DROT( M-1, A( 1, M ), 1, DE( 1, M+1 ), 1, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI ) END IF C C III. Annihilate C1(k+1:m,k). C DO 100 J = M, K + 1, -1 MJ2 = MIN( J+2, M+1 ) C C Determine a Givens rotation to annihilate C1(j,k) from the C left. C CALL DLARTG( C1( J-1, K ), C1( J, K ), CO, SI, TMP1 ) C C Update C1 and V. C C1( J-1, K ) = TMP1 C1( J, K ) = ZERO CALL DROT( M-K, C1( J-1, MK1 ), LDC1, C1( J, MK1 ), LDC1, $ CO, SI ) CALL DROT( M, VW( J-1, 2 ), LDVW, VW( J, 2 ), LDVW , CO, SI $ ) C C Update A and D. C TMP1 = -SI*A( J-1, J-1 ) A( J-1, J-1 ) = CO*A( J-1, J-1 ) CALL DROT( M-J+1, A( J-1, J ), LDA, A( J, J ), LDA, CO, SI ) CALL DROT( J-2, DE( 1, J ), 1, DE( 1, J+1 ), 1, CO, SI ) CALL DROT( M-J, DE( J-1, MJ2 ), LDDE, DE( J, MJ2 ), LDDE, $ CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, J-1 ), 1, Q1( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate A(j,j-1) from the C right. C CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 ) C C Update A. C A( J, J ) = TMP2 CALL DROT( J-1, A( 1, J ), 1, A( 1, J-1 ), 1, CO, SI ) C C Update C2 and W. C CALL DROT( M, C2( 1, J ), 1, C2( 1, J-1 ), 1, CO, SI ) CALL DROT( M-K+1, DWORK( ( K-1 )*M+J ), M, $ DWORK( ( K-1)*M+J-1 ), M, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M+J ), 1, Q1( 1, M+J-1 ), 1, CO, SI $ ) END IF 100 CONTINUE C C IV. Annihilate W(k,k+1:m-1). C DO 110 J = K + 1, M - 1 MJ2 = MIN( J+2, M ) C C Determine a Givens rotation to annihilate W(k,j) from the C right. C CALL DLARTG( DWORK( J*M+K ), DWORK( ( J-1 )*M+K ), CO, $ SI, TMP1 ) C C Update C1 and W. C CALL DROT( M, C1( 1, J+1 ), 1, C1( 1, J ), 1, CO, SI ) DWORK( ( J-1 )*M+K ) = ZERO DWORK( J*M+K ) = TMP1 CALL DROT( M-K, DWORK( J*M+MK1 ), 1, DWORK( ( J-1 )*M+K+1 ), $ 1, CO, SI ) C C Update B. C CALL DROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO, SI ) TMP1 = -SI*B( J+1, J+1 ) B( J+1, J+1 ) = CO*B( J+1, J+1 ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, J+1 ), 1, Q2( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate B(j+1,j) from the C left. C CALL DLARTG( B( J, J ), TMP1, CO, SI, TMP2 ) C C Update B and F. C B( J, J ) = TMP2 CALL DROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, CO, SI $ ) CALL DROT( J-1, F( 1, J ), 1, F( 1, J+1 ), 1, CO, SI ) CALL DROT( M-J-1, F( J, MJ2 ), LDF, F( J+1, MJ2 ), LDF, CO, $ SI ) C C Update C2 and V. C CALL DROT( M-K+1, C2( J, K ), LDC2, C2( J+1, K ), LDC2, CO, $ SI ) CALL DROT( M, VW( 1, J+1 ), 1, VW( 1, J+2 ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, M+J ), 1, Q2( 1, M+J+1 ), 1, CO, SI $ ) END IF 110 CONTINUE C C V. Annihilate W(k,m). C IF( K.LT.M ) THEN C C Determine a Givens rotation to annihilate W(k,m) from the C right. C CALL DLARTG( C2( M, K ), DWORK( ( M-1 )*M+K ), CO, SI, TMP1 $ ) C C Update C1, C2, W and V. C CALL DROT( M, VW( 1, M+1 ), 1, C1( 1, M ), 1, CO, SI ) C2( M, K ) = TMP1 DWORK( ( M-1 )*M+K ) = ZERO CALL DROT( M-K, C2( M, K+1 ), LDC2, DWORK( ( M-1 )*M+K+1 ), $ 1, CO, SI ) C C Update B and F. C CALL DROT( M-1, F( 1, M ), 1, B( 1, M ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, N ), 1, Q2( 1, M ), 1, CO, SI ) END IF ELSE C C Determine a Givens rotation to annihilate W(m,m) from the C left. C CALL DLARTG( C1( M, M ), DWORK( MM ), CO, SI, TMP1 ) C C Update C1, C2, W and V. C C1( M, M ) = TMP1 DWORK( MM ) = ZERO CALL DROT( M, VW( M, 2 ), LDVW, C2( 1, M ), 1, CO, SI ) C C Update A and D. C CALL DROT( M-1, A( 1, M ), 1, DE( 1, M+1 ), 1, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI ) END IF END IF C C VI. Annihilate C2(k+2:m,k). C DO 120 J = M, K + 2, -1 MJ1 = MIN( J+1, M ) C C Determine a Givens rotation to annihilate C2(j,k) from the C left. C CALL DLARTG( C2( J-1, K ), C2( J, K ), CO, SI, TMP1 ) C C Update C2 and V. C C2( J-1, K ) = TMP1 C2( J, K ) = ZERO CALL DROT( M-K, C2( J-1, MK1 ), LDC2, C2( J, MK1 ), LDC2, $ CO, SI ) CALL DROT( M, VW( 1, J ), 1, VW( 1, J+1 ), 1, CO, SI ) C C Update B and F. C CALL DROT( M-J+1, B( J-1, J ), LDB, B( J, J ), LDB, CO, SI ) TMP1 = -SI*B( J-1, J-1 ) B( J-1, J-1 ) = CO*B( J-1, J-1 ) CALL DROT( J-2, F( 1, J-1 ), 1, F( 1, J ), 1, CO, SI ) CALL DROT( M-J, F( J-1, MJ1 ), LDF, F( J, MJ1 ), LDF, CO, SI $ ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, M+J-1 ), 1, Q2( 1, M+J ), 1, CO, SI $ ) END IF C C Determine a Givens rotation to annihilate B(j,j-1) from the C right. C CALL DLARTG( B( J, J ), TMP1, CO, SI, TMP2 ) B( J, J ) = TMP2 C C Update B. C CALL DROT( J-1, B( 1, J ), 1, B( 1, J-1 ), 1, CO, SI ) C C Update C1 and W. C CALL DROT( M, C1( 1, J ), 1, C1( 1, J-1 ), 1, CO, SI ) CALL DROT( M-K+1, DWORK( ( J-1 )*M+K ), 1, $ DWORK( ( J-2 )*M+K ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, J ), 1, Q2( 1, J-1 ), 1, CO, SI ) END IF 120 CONTINUE 130 CONTINUE C C ( A1 D1 ) ( B1 F1 ) ( C11 V1 ) C Now we have S = ( ), T = ( ), H = ( ), C ( 0 A1' ) ( 0 B1' ) ( 0 C21' ) C C where A1, B1, and C11 are upper triangular, C21 is upper C Hessenberg, and D1 and F1 are skew-symmetric. C C STEP 3: Apply the periodic QZ algorithm to the generalized matrix C C -1 -1 C product C21 A1 C11 B1 in order to make C21 upper C quasi-triangular. C C Determine the mode of computations. C IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 ) THEN CMPQ = 'Initialize' IMAT = 4*MM + 1 IWRK = 8*MM + 1 ELSE CMPQ = 'No Computation' IMAT = 1 IWRK = 4*MM + 1 END IF C IF( LTRI ) THEN CMPSC = 'Schur Form' ELSE CMPSC = 'Eigenvalues Only' END IF C C Save matrices in the form that is required by MB03BD. C CALL DLACPY( 'Full', M, M, C2, LDC2, DWORK( IMAT ), M ) CALL DLACPY( 'Full', M, M, A, LDA, DWORK( IMAT+MM ), M ) CALL DLACPY( 'Full', M, M, C1, LDC1, DWORK( IMAT+2*MM ), M ) CALL DLACPY( 'Full', M, M, B, LDB, DWORK( IMAT+3*MM ), M ) IWORK( 1 ) = 1 IWORK( 2 ) = -1 IWORK( 3 ) = 1 IWORK( 4 ) = -1 C C Apply periodic QZ algorithm. C Workspace: need IWRK + MAX( N, 32 ) + 3. C CALL MB03BD( CMPSC, 'Careful', CMPQ, IDUM, 4, M, 1, 1, M, IWORK, $ DWORK( IMAT ), M, M, DWORK, M, M, ALPHAR, ALPHAI, $ BETA, IWORK( 5 ), IWORK( M+5 ), LIWORK-( M+4 ), $ DWORK( IWRK ), LDWORK-IWRK+1, IWARN, INFO ) C IF( IWARN.GT.0 .AND. IWARN.LT.M ) THEN INFO = 1 RETURN ELSE IF( IWARN.EQ.M+1 ) THEN INFO = 3 ELSE IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) NBETA0 = 0 I11 = 0 I22 = 0 I2X2 = 0 C C Compute the eigenvalues with nonnegative imaginary parts of the C pencil aS - bH. Also, count the number of 2-by-2 diagonal blocks, C I2X2, and the number of 1-by-1 and 2-by-2 blocks with unreliable C eigenvalues, I11 and I22, respectively. C I = 1 C WHILE( I.LE.M ) DO 140 CONTINUE IF( I.LE.M ) THEN IF( NINF.GT.0 ) THEN IF( BETA( I ).EQ.ZERO ) $ NBETA0 = NBETA0 + 1 END IF IF( IWORK( I+4 ).GE.2*EMIN .AND. IWORK( I+4 ).LE.2*EMAX ) THEN C C B = SQRT(BASE**IWORK(i+4)) is between underflow and overflow C threshold, BETA(i) is divided by B. C BETA( I ) = BETA( I )/BASE**( HALF*IWORK( I+4 ) ) IF( BETA( I ).NE.ZERO ) THEN IF( IWORK( M+I+5 ).LT.0 ) THEN I22 = I22 + 1 ELSE IF( IWORK( M+I+5 ).GT.0 ) THEN I11 = I11 + 1 END IF EIG = SQRT( DCMPLX( ALPHAR( I ), ALPHAI( I ) ) ) ALPHAR( I ) = DIMAG( EIG ) ALPHAI( I ) = DBLE( EIG ) IF( ALPHAR( I ).LT.ZERO ) $ ALPHAR( I ) = -ALPHAR( I ) IF( ALPHAI( I ).LT.ZERO ) $ ALPHAI( I ) = -ALPHAI( I ) IF( ALPHAR( I ).NE.ZERO .AND. ALPHAI( I ).NE.ZERO ) THEN ALPHAR( I+1 ) = -ALPHAR( I ) ALPHAI( I+1 ) = ALPHAI( I ) BETA( I+1 ) = BETA( I ) I2X2 = I2X2 + 1 I = I + 1 ELSE IF( IWORK( M+I+5 ).LT.0 ) THEN I2X2 = I2X2 + 1 END IF END IF ELSE IF( IWORK( I+4 ).LT.2*EMIN ) THEN C C Set to zero the numerator part of the eigenvalue. C ALPHAR( I ) = ZERO ALPHAI( I ) = ZERO I11 = I11 + 1 ELSE C C Set an infinite eigenvalue. C IF( NINF.GT.0 ) $ NBETA0 = NBETA0 + 1 BETA( I ) = ZERO I11 = I11 + 1 END IF I = I + 1 GO TO 140 END IF C END WHILE 140 C IWORK( 1 ) = I11 + I22 C C Set to infinity the largest eigenvalues, if necessary. C L = 0 IF( NINF.GT.0 ) THEN DO 160 J = 1, NINF - NBETA0 TMP1 = ZERO TMP2 = ONE P = 1 DO 150 I = 1, M IF( BETA( I ).GT.ZERO ) THEN TEMP = DLAPY2( ALPHAR( I ), ALPHAI( I ) ) IF( TEMP.GT.TMP1 .AND. TMP2.GE.BETA( I ) ) THEN TMP1 = TEMP TMP2 = BETA( I ) P = I END IF END IF 150 CONTINUE L = L + 1 BETA( P ) = ZERO 160 CONTINUE C IF( L.EQ.IWORK( 1 ) ) THEN C C All unreliable eigenvalues found have been set to infinity. C INFO = 0 I11 = 0 I22 = 0 IWORK( 1 ) = 0 END IF END IF C C Save the norms of the factors. C CALL DCOPY( 4, DWORK( IWRK+1 ), 1, DUM, 1 ) C C Save the quadruples of the 1-by-1 and 2-by-2 diagonal blocks. C All 1-by-1 diagonal blocks come first. C Save also information about blocks with possible loss of accuracy. C C Workspace: IWRK+w-1, where w = 4 if M = 1, or w = 4*N, otherwise. C K = IWRK IW = IWORK( 1 ) I = 1 J = 1 L = 4*( M - 2*I2X2 ) + K C C WHILE( I.LE.N ) DO UNREL = .FALSE. 170 CONTINUE IF( I.LE.M ) THEN IF( J.LE.IW ) $ UNREL = I.EQ.ABS( IWORK( M+I+5 ) ) IF( ALPHAR( I ).NE.ZERO .AND. BETA( I ).NE.ZERO .AND. $ ( ALPHAI( I ).NE.ZERO .OR. IWORK( M+I+5 ).LT.0 ) ) THEN IF( UNREL ) THEN J = J + 1 IWORK( J ) = IWORK( M+I+5 ) IWORK( IW+J ) = L - IWRK + 6 UNREL = .FALSE. END IF CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1) ), M, $ DWORK( L ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+MM ), M, $ DWORK( L+4 ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+2*MM ), $ M, DWORK( L+8 ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+3*MM ), $ M, DWORK( L+12 ), 2 ) L = L + 16 I = I + 2 ELSE IF ( UNREL ) THEN J = J + 1 IWORK( J ) = I IWORK( IW+J ) = K - IWRK + 6 UNREL = .FALSE. END IF CALL DCOPY( 4, DWORK( IMAT+(M+1)*(I-1) ), MM, DWORK( K ), $ 1 ) K = K + 4 I = I + 1 END IF GO TO 170 END IF C END WHILE 170 C IWORK( 2*IW+2 ) = I11 IWORK( 2*IW+3 ) = I22 IWORK( 2*IW+4 ) = I2X2 C IF( LTRI ) THEN C C Update C1 and C2. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+2*MM ), M, C1, LDC1 ) CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, C2, LDC2 ) C C Update V. C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( 2*MM+1 ), M, VW( 1, 2 ), LDVW, ZERO, $ DWORK( IMAT ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IMAT ), M, DWORK, M, ZERO, VW( 1, 2 ), $ LDVW ) C C Update A. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+MM ), M, A, LDA ) C C Skew-symmetric update of D. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, DE( 1, 2 ), $ LDDE, DWORK( 2*MM+1 ), M, DE( 1, 2 ), LDDE, $ DWORK( IMAT ), LDWORK-IMAT+1, IW ) C C Update B. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+3*MM ), M, B, LDB ) C C Skew-symmetric update of F. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, F, LDF, $ DWORK, M, F, LDF, DWORK( IMAT ), LDWORK-IMAT+1, $ IW ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q1, LDQ1, DWORK( 2*MM+1 ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1, LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q1( 1, M+1 ), LDQ1, DWORK( MM+1 ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1( 1, M+1 ), $ LDQ1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q2, LDQ2, DWORK( 3*MM+1 ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q2( 1, M+1 ), LDQ2, DWORK, M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2( 1, M+1 ), $ LDQ2 ) END IF END IF C C Move the norms, and the quadruples of 1-by-1 and 2-by-2 blocks C in front. C K = 4*( M - 2*I2X2 ) + 16*I2X2 CALL DCOPY( K, DWORK( IWRK ), 1, DWORK( 6 ), 1 ) CALL DCOPY( 4, DUM, 1, DWORK( 2 ), 1 ) C DWORK( 1 ) = OPTDW RETURN C *** Last line of MB04BD *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BX.f0000644000000000000000000000013015012430707016171 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/NF01BX.f0000644000175000017500000001060415012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BX( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute (J'*J + c*I)*x, where J is an m-by-n real matrix, c is C a real scalar, I is the n-by-n identity matrix, and x is a real C n-vector. C C NOTE: this routine must have the same arguments as SLICOT Library C routine NF01BW. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The number of columns of the Jacobian matrix J. N >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of the C matrix J, as follows: C IPAR(1) must contain the number of rows M of the Jacobian C matrix J. M >= 0. C IPAR is provided for compatibility with SLICOT Library C routine MD03AD. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 1. C C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) C The real parameters needed for solving the problem. C The entry DPAR(1) must contain the real scalar c. C C LDPAR (input) INTEGER C The length of the array DPAR. LDPAR >= 1. C C J (input) DOUBLE PRECISION array, dimension (LDJ,N) C The leading M-by-N part of this array must contain the C Jacobian matrix J. C C LDJ INTEGER C The leading dimension of the array J. LDJ >= MAX(1,M). C C X (input/output) DOUBLE PRECISION array, dimension C (1+(N-1)*abs(INCX)) C On entry, this incremented array must contain the C vector x. C On exit, this incremented array contains the value of the C matrix-vector product (J'*J + c*I)*x. C C INCX (input) INTEGER C The increment for the elements of X. INCX <> 0. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 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 associativity of matrix multiplications is used; the result C is obtained as: x_out = J'*( J*x ) + c*x. C C CONTRIBUTORS C C A. Riedel, R. Schneider, Chemnitz University of Technology, C Oct. 2000, during a stay at University of Twente, NL. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, C Mar. 2002, Oct. 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 .. INTEGER INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N C .. Array Arguments .. INTEGER IPAR(*) DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), X(*) C .. Local Scalars .. INTEGER M DOUBLE PRECISION C C .. External Subroutines .. EXTERNAL DGEMV, DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C INFO = 0 IF ( N.LT.0 ) THEN INFO = -1 ELSEIF ( LIPAR.LT.1 ) THEN INFO = -3 ELSEIF ( LDPAR.LT.1 ) THEN INFO = -5 ELSEIF ( INCX.EQ.0 ) THEN INFO = -9 ELSE M = IPAR(1) IF ( M.LT.0 ) THEN INFO = -2 ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN INFO = -7 ELSEIF ( LDWORK.LT.M ) THEN INFO = -11 ENDIF ENDIF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'NF01BX', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C C = DPAR(1) IF ( M.EQ.0 ) THEN C C Special case, void J: x <-- c*x. C CALL DSCAL( N, C, X, INCX ) RETURN END IF C CALL DGEMV( 'NoTranspose', M, N, ONE, J, LDJ, X, INCX, ZERO, $ DWORK, 1 ) CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, DWORK, 1, C, X, INCX ) RETURN C C *** Last line of NF01BX *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03SY.f0000644000000000000000000000013215012430707016220 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB03SY.f0000644000175000017500000003324515012430707017423 0ustar00lilgelilge00000000000000 SUBROUTINE SB03SY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, XA, $ LDXA, SEPD, THNORM, IWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To estimate the "separation" between the matrices op(A) and C op(A)', C C sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X) C = 1 / norm(inv(Omega)) C C and/or the 1-norm of Theta, where op(A) = A or A' (A**T), and C Omega and Theta are linear operators associated to the real C discrete-time Lyapunov matrix equation C C op(A)'*X*op(A) - X = C, C C defined by C C Omega(W) = op(A)'*W*op(A) - W, C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). C C The 1-norm condition estimators are used. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'S': Compute the separation only; C = 'T': Compute the norm of Theta only; C = 'B': Compute both the separation and the norm of Theta. 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 LYAPUN CHARACTER*1 C Specifies whether or not the original Lyapunov equations C should be solved, as follows: C = 'O': Solve the original Lyapunov equations, updating C the right-hand sides and solutions with the C matrix U, e.g., X <-- U'*X*U; C = 'R': Solve reduced Lyapunov equations only, without C updating the right-hand sides and solutions. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and X. N >= 0. C C T (input) DOUBLE PRECISION array, dimension (LDT,N) C The leading N-by-N upper Hessenberg part of this array C must contain the upper quasi-triangular matrix T in Schur C canonical form from a Schur factorization of A. C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,N). C C U (input) DOUBLE PRECISION array, dimension (LDU,N) C The leading N-by-N part of this array must contain the C orthogonal matrix U from a real Schur factorization of A. C If LYAPUN = 'R', the array U is not referenced. C C LDU INTEGER C The leading dimension of array U. C LDU >= 1, if LYAPUN = 'R'; C LDU >= MAX(1,N), if LYAPUN = 'O'. C C XA (input) DOUBLE PRECISION array, dimension (LDXA,N) C The leading N-by-N part of this array must contain the C matrix product X*op(A), if LYAPUN = 'O', or U'*X*U*op(T), C if LYAPUN = 'R', in the Lyapunov equation. C If JOB = 'S', the array XA is not referenced. C C LDXA INTEGER C The leading dimension of array XA. C LDXA >= 1, if JOB = 'S'; C LDXA >= MAX(1,N), if JOB = 'T' or 'B'. C C SEPD (output) DOUBLE PRECISION C If JOB = 'S' or JOB = 'B', and INFO >= 0, SEPD contains C the estimated quantity sepd(op(A),op(A)'). C If JOB = 'T' or N = 0, SEPD is not referenced. C C THNORM (output) DOUBLE PRECISION C If JOB = 'T' or JOB = 'B', and INFO >= 0, THNORM contains C the estimated 1-norm of operator Theta. C If JOB = 'S' or N = 0, THNORM is not referenced. C C Workspace C C IWORK INTEGER array, dimension (N*N) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 0, if N = 0; C LDWORK >= MAX(3,2*N*N), if N > 0. 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 = N+1: if T has (almost) reciprocal eigenvalues; C perturbed values were used to solve Lyapunov C equations (but the matrix T is unchanged). C C METHOD C C SEPD is defined as C C sepd( op(A), op(A)' ) = sigma_min( K ) C C where sigma_min(K) is the smallest singular value of the C N*N-by-N*N matrix C C K = kprod( op(A)', op(A)' ) - I(N**2). C C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the C Kronecker product. The routine estimates sigma_min(K) by the C reciprocal of an estimate of the 1-norm of inverse(K), computed as C suggested in [1]. This involves the solution of several discrete- C time Lyapunov equations, either direct or transposed. The true C reciprocal 1-norm of inverse(K) cannot differ from sigma_min(K) by C more than a factor of N. C The 1-norm of Theta is estimated similarly. C C REFERENCES C C [1] Higham, N.J. C FORTRAN codes for estimating the one-norm of a real or C complex matrix, with applications to condition estimation. C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C FURTHER COMMENTS C C When SEPD is zero, the routine returns immediately, with THNORM C (if requested) not set. In this case, the equation is singular. C The option LYAPUN = 'R' may occasionally produce slightly worse C or better estimates, and it is much faster than the option 'O'. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Oct. 1998. Partly based on DDLSVX (and then SB03SD) by P. Petkov, C Tech. University of Sofia, March 1998 (and December 1998). C C REVISIONS C C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004, C May 2020. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) C .. C .. Scalar Arguments .. CHARACTER JOB, LYAPUN, TRANA INTEGER INFO, LDT, LDU, LDWORK, LDXA, N DOUBLE PRECISION SEPD, THNORM C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION DWORK( * ), T( LDT, * ), U( LDU, * ), $ XA( LDXA, * ) C .. C .. Local Scalars .. LOGICAL NOTRNA, UPDATE, WANTS, WANTT CHARACTER TRANAT, UPLO INTEGER INFO2, ITMP, KASE, NN DOUBLE PRECISION BIGNUM, EST, SCALE C .. C .. Local Arrays .. INTEGER ISAVE( 3 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL DLAMCH, DLANSY, LSAME C .. C .. External Subroutines .. EXTERNAL DLACN2, DLACPY, DSCAL, DSYR2K, MA02ED, MB01RU, $ SB03MX, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Decode and Test input parameters. C WANTS = LSAME( JOB, 'S' ) WANTT = LSAME( JOB, 'T' ) NOTRNA = LSAME( TRANA, 'N' ) UPDATE = LSAME( LYAPUN, 'O' ) C NN = N*N INFO = 0 IF( .NOT. ( WANTS .OR. WANTT .OR. LSAME( JOB, 'B' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. $ LSAME( TRANA, 'C' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN INFO = -8 ELSE IF( LDXA.LT.1 .OR. ( .NOT.WANTS .AND. LDXA.LT.N ) ) THEN INFO = -10 ELSE IF( LDWORK.LT.0 .OR. $ ( LDWORK.LT.MAX( 3, 2*NN ) .AND. N.GT.0 ) ) THEN INFO = -15 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03SY', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C ITMP = NN + 1 C IF( NOTRNA ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF C IF( .NOT.WANTT ) THEN C C Estimate sepd(op(A),op(A)'). C Workspace: max(3,2*N*N). C KASE = 0 C C REPEAT 10 CONTINUE CALL DLACN2( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE, ISAVE $ ) IF( KASE.NE.0 ) THEN C C Select the triangular part of symmetric matrix to be used. C IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) $ .GE. $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) $ ) THEN UPLO = 'U' ELSE UPLO = 'L' END IF C IF( UPDATE ) THEN C C Transform the right-hand side: RHS := U'*RHS*U. C CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, $ INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) END IF CALL MA02ED( UPLO, N, DWORK, N ) C IF( KASE.EQ.1 ) THEN C C Solve op(T)'*Y*op(T) - Y = scale*RHS. C CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, $ DWORK( ITMP ), INFO2 ) ELSE C C Solve op(T)*W*op(T)' - W = scale*RHS. C CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, $ DWORK( ITMP ), INFO2 ) END IF C IF( INFO2.GT.0 ) $ INFO = N + 1 C IF( UPDATE ) THEN C C Transform back to obtain the solution: Z := U*Z*U', with C Z = Y or Z = W. C CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), $ NN, INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( UPLO, N, DWORK, N ) END IF C GO TO 10 END IF C UNTIL KASE = 0 C IF( EST.GT.SCALE ) THEN SEPD = SCALE / EST ELSE BIGNUM = ONE / DLAMCH( 'Safe minimum' ) IF( SCALE.LT.EST*BIGNUM ) THEN SEPD = SCALE / EST ELSE SEPD = BIGNUM END IF END IF C C Return if the equation is singular. C IF( SEPD.EQ.ZERO ) $ RETURN END IF C IF( .NOT.WANTS ) THEN C C Estimate norm(Theta). C Workspace: max(3,2*N*N). C KASE = 0 C C REPEAT 20 CONTINUE CALL DLACN2( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE, ISAVE $ ) IF( KASE.NE.0 ) THEN C C Select the triangular part of symmetric matrix to be used. C IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) $ .GE. $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) $ ) THEN UPLO = 'U' ELSE UPLO = 'L' END IF C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( UPLO, N, DWORK, N ) C C Compute RHS = op(W)'*X*op(A) + op(A)'*X*op(W). C CALL DSYR2K( UPLO, TRANAT, N, N, ONE, DWORK, N, XA, LDXA, $ ZERO, DWORK( ITMP ), N ) CALL DLACPY( UPLO, N, N, DWORK( ITMP ), N, DWORK, N ) C IF( UPDATE ) THEN C C Transform the right-hand side: RHS := U'*RHS*U. C CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, $ INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) END IF CALL MA02ED( UPLO, N, DWORK, N ) C IF( KASE.EQ.1 ) THEN C C Solve op(T)'*Y*op(T) - Y = scale*RHS. C CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE, $ DWORK( ITMP ), INFO2 ) ELSE C C Solve op(T)*W*op(T)' - W = scale*RHS. C CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE, $ DWORK( ITMP ), INFO2 ) END IF C IF( INFO2.GT.0 ) $ INFO = N + 1 C IF( UPDATE ) THEN C C Transform back to obtain the solution: Z := U*Z*U', with C Z = Y or Z = W. C CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), $ NN, INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( UPLO, N, DWORK, N ) END IF C GO TO 20 END IF C UNTIL KASE = 0 C IF( EST.LT.SCALE ) THEN THNORM = EST / SCALE ELSE BIGNUM = ONE / DLAMCH( 'Safe minimum' ) IF( EST.LT.SCALE*BIGNUM ) THEN THNORM = EST / SCALE ELSE THNORM = BIGNUM END IF END IF END IF C RETURN C *** Last line of SB03SY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04QY.f0000644000000000000000000000013215012430707016217 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB04QY.f0000644000175000017500000001107115012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE SB04QY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, $ INFO ) 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 discrete-time Sylvester equations using the C 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 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 [2] Sima, V. C Algorithms for Linear-quadratic Optimization. C Marcel Dekker, Inc., New York, 1996. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C D. Sima, University of Bucharest, May 2000. C C REVISIONS C C - 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, 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 .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSCAL, DTRMV, SB04MW C .. Executable Statements .. C IF ( IND.LT.N ) THEN DUM(1) = ZERO CALL DCOPY ( M, DUM, 0, D, 1 ) DO 10 I = IND + 1, N CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) 10 CONTINUE DO 20 I = 2, M C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) 20 CONTINUE CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, $ D, 1 ) DO 30 I = 1, M C(I,IND) = C(I,IND) - D(I) 30 CONTINUE END IF 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 ) CALL DSCAL ( K, B(IND,IND), 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) + ONE 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 50 I = 1, M C(I,IND) = D(IPR(I)) 50 CONTINUE C END IF C RETURN C *** Last line of SB04QY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04RX.f0000644000000000000000000000013215012430707016217 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB04RX.f0000644000175000017500000003161315012430707017417 0ustar00lilgelilge00000000000000 SUBROUTINE SB04RX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) C C PURPOSE C C To solve a system of equations in quasi-Hessenberg form C (Hessenberg form plus two consecutive offdiagonals) with two C right-hand sides. C C ARGUMENTS C C Mode Parameters C C RC CHARACTER*1 C Indicates processing by columns or rows, as follows: C = 'R': Row transformations are applied; C = 'C': Column transformations are applied. C C UL CHARACTER*1 C Indicates whether A is upper or lower Hessenberg matrix, C as follows: C = 'U': A is upper Hessenberg; C = 'L': A is lower Hessenberg. C C Input/Output Parameters C C M (input) INTEGER C The order of the matrix A. M >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,M) C The leading M-by-M part of this array must contain a C matrix A in Hessenberg form. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C LAMBD1, (input) DOUBLE PRECISION C LAMBD2, These variables must contain the 2-by-2 block to be C LAMBD3, multiplied to the elements of A. C LAMBD4 C C D (input/output) DOUBLE PRECISION array, dimension (2*M) C On entry, this array must contain the two right-hand C side vectors of the quasi-Hessenberg system, stored C row-wise. C On exit, if INFO = 0, this array contains the two solution C vectors of the quasi-Hessenberg system, stored row-wise. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used to test for near singularity of C the triangular factor R of the quasi-Hessenberg matrix. C A matrix whose estimated condition number is less C than 1/TOL is considered to be nonsingular. C C Workspace C C IWORK INTEGER array, dimension (2*M) C C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) C The leading 2*M-by-2*M part of this array is used for C computing the triangular factor of the QR decomposition C of the quasi-Hessenberg matrix. The remaining 6*M elements C are used as workspace for the computation of the C reciprocal condition estimate. C C LDDWOR INTEGER C The leading dimension of array DWORK. C LDDWOR >= MAX(1,2*M). C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: if the quasi-Hessenberg matrix is (numerically) C singular. That is, its estimated reciprocal C condition number is less than or equal to TOL. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C D. Sima, University of Bucharest, May 2000. C C REVISIONS C C - C C Note that RC, UL, M, LDA, and LDDWOR must be such that the value C of the LOGICAL variable OK in the following statement is true. C C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) C .AND. C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) C .AND. C ( M.GE.0 ) C .AND. C ( LDA.GE.MAX( 1, M ) ) C .AND. C ( LDDWOR.GE.MAX( 1, 2*M ) ) C C These conditions are not checked by the routine. C C KEYWORDS C C Hessenberg form, orthogonal transformation, real Schur form, C Sylvester equation. C C ****************************************************************** C DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER RC, UL INTEGER INFO, LDA, LDDWOR, M DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) C .. Local Scalars .. CHARACTER TRANS INTEGER J, J1, J2, M2, MJ, ML DOUBLE PRECISION C, R, RCOND, S C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLARTG, DLASET, DROT, DSCAL, DTRCON, $ DTRSV C .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD C .. Executable Statements .. C INFO = 0 C C For speed, no tests on the input scalar arguments are made. C Quick return if possible. C IF ( M.EQ.0 ) $ RETURN C M2 = M*2 IF ( LSAME( UL, 'U' ) ) THEN C DO 20 J = 1, M J2 = J*2 ML = MIN( M, J + 1 ) CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), $ LDDWOR ) CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) CALL DSCAL( ML, LAMBD1, DWORK(1,J2-1), 2 ) CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2-1), 2 ) CALL DSCAL( ML, LAMBD3, DWORK(2,J2-1), 2 ) CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2), 2 ) CALL DSCAL( ML, LAMBD2, DWORK(1,J2), 2 ) CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) CALL DSCAL( ML, LAMBD4, DWORK(2,J2), 2 ) C DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE DWORK(J2,J2) = DWORK(J2,J2) + ONE 20 CONTINUE C IF ( LSAME( RC, 'R' ) ) THEN TRANS = 'N' C C A is an upper Hessenberg matrix, row transformations. C DO 40 J = 1, M2 - 1 MJ = M2 - J IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN IF ( DWORK(J+3,J).NE.ZERO ) THEN CALL DLARTG( DWORK(J+2,J), DWORK(J+3,J), C, S, R ) DWORK(J+2,J) = R DWORK(J+3,J) = ZERO CALL DROT( MJ, DWORK(J+2,J+1), LDDWOR, $ DWORK(J+3,J+1), LDDWOR, C, S ) CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) END IF END IF IF ( J.LT.M2-1 ) THEN IF ( DWORK(J+2,J).NE.ZERO ) THEN CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) DWORK(J+1,J) = R DWORK(J+2,J) = ZERO CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, $ DWORK(J+2,J+1), LDDWOR, C, S ) CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) END IF END IF IF ( DWORK(J+1,J).NE.ZERO ) THEN CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) DWORK(J,J) = R DWORK(J+1,J) = ZERO CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), $ LDDWOR, C, S ) CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) END IF 40 CONTINUE C ELSE TRANS = 'T' C C A is an upper Hessenberg matrix, column transformations. C DO 60 J = 1, M2 - 1 MJ = M2 - J IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN IF ( DWORK(MJ+1,MJ-2).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ+1,MJ-1), DWORK(MJ+1,MJ-2), C, $ S, R ) DWORK(MJ+1,MJ-1) = R DWORK(MJ+1,MJ-2) = ZERO CALL DROT( MJ, DWORK(1,MJ-1), 1, DWORK(1,MJ-2), 1, $ C, S ) CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) END IF END IF IF ( J.LT.M2-1 ) THEN IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, $ S, R ) DWORK(MJ+1,MJ) = R DWORK(MJ+1,MJ-1) = ZERO CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, $ S ) CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) END IF END IF IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, $ R ) DWORK(MJ+1,MJ+1) = R DWORK(MJ+1,MJ) = ZERO CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, $ S ) CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) END IF 60 CONTINUE C END IF ELSE C DO 80 J = 1, M J2 = J*2 J1 = MAX( J - 1, 1 ) ML = MIN( M - J + 2, M ) CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), $ LDDWOR ) CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) CALL DSCAL( ML, LAMBD1, DWORK(J1*2-1,J2-1), 2 ) CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2-1), 2 ) CALL DSCAL( ML, LAMBD3, DWORK(J1*2,J2-1), 2 ) CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2), 2 ) CALL DSCAL( ML, LAMBD2, DWORK(J1*2-1,J2), 2 ) CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) CALL DSCAL( ML, LAMBD4, DWORK(J1*2,J2), 2 ) C DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE DWORK(J2,J2) = DWORK(J2,J2) + ONE 80 CONTINUE C IF ( LSAME( RC, 'R' ) ) THEN TRANS = 'N' C C A is a lower Hessenberg matrix, row transformations. C DO 100 J = 1, M2 - 1 MJ = M2 - J IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN IF ( DWORK(MJ-2,MJ+1).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ-1,MJ+1), DWORK(MJ-2,MJ+1), C, $ S, R ) DWORK(MJ-1,MJ+1) = R DWORK(MJ-2,MJ+1) = ZERO CALL DROT( MJ, DWORK(MJ-1,1), LDDWOR, $ DWORK(MJ-2,1), LDDWOR, C, S ) CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) END IF END IF IF ( J.LT.M2-1 ) THEN IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, $ S, R ) DWORK(MJ,MJ+1) = R DWORK(MJ-1,MJ+1) = ZERO CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), $ LDDWOR, C, S ) CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) END IF END IF IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, $ R ) DWORK(MJ+1,MJ+1) = R DWORK(MJ,MJ+1) = ZERO CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), $ LDDWOR, C, S) CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) END IF 100 CONTINUE C ELSE TRANS = 'T' C C A is a lower Hessenberg matrix, column transformations. C DO 120 J = 1, M2 - 1 MJ = M2 - J IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN IF ( DWORK(J,J+3).NE.ZERO ) THEN CALL DLARTG( DWORK(J,J+2), DWORK(J,J+3), C, S, R ) DWORK(J,J+2) = R DWORK(J,J+3) = ZERO CALL DROT( MJ, DWORK(J+1,J+2), 1, DWORK(J+1,J+3), $ 1, C, S ) CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) END IF END IF IF ( J.LT.M2-1 ) THEN IF ( DWORK(J,J+2).NE.ZERO ) THEN CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) DWORK(J,J+1) = R DWORK(J,J+2) = ZERO CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), $ 1, C, S ) CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) END IF END IF IF ( DWORK(J,J+1).NE.ZERO ) THEN CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) DWORK(J,J) = R DWORK(J,J+1) = ZERO CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, $ S ) CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) END IF 120 CONTINUE C END IF END IF C CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, $ DWORK(1,M2+1), IWORK, INFO ) IF ( RCOND.LE.TOL ) THEN INFO = 1 ELSE CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) END IF C RETURN C *** Last line of SB04RX *** END control-4.1.2/src/slicot/src/PaxHeaders/MC03ND.f0000644000000000000000000000013015012430707016157 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MC03ND.f0000644000175000017500000004217615012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE MC03ND( MP, NP, DP, P, LDP1, LDP2, DK, GAM, NULLSP, $ LDNULL, KER, LDKER1, LDKER2, TOL, IWORK, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To compute the coefficients of a minimal polynomial basis C DK C K(s) = K(0) + K(1) * s + ... + K(DK) * s C C for the right nullspace of the MP-by-NP polynomial matrix of C degree DP, given by C DP C P(s) = P(0) + P(1) * s + ... + P(DP) * s , C C which corresponds to solving the polynomial matrix equation C P(s) * K(s) = 0. C C ARGUMENTS C C Input/Output Parameters C C MP (input) INTEGER C The number of rows of the polynomial matrix P(s). C MP >= 0. C C NP (input) INTEGER C The number of columns of the polynomial matrix P(s). C NP >= 0. C C DP (input) INTEGER C The degree of the polynomial matrix P(s). DP >= 1. C C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) C The leading MP-by-NP-by-(DP+1) part of this array must C contain the coefficients of the polynomial matrix P(s). C Specifically, P(i,j,k) must contain the (i,j)-th element C of P(k-1), which is the cofficient of s**(k-1) of P(s), C where i = 1,2,...,MP, j = 1,2,...,NP and k = 1,2,...,DP+1. C C LDP1 INTEGER C The leading dimension of array P. LDP1 >= MAX(1,MP). C C LDP2 INTEGER C The second dimension of array P. LDP2 >= MAX(1,NP). C C DK (output) INTEGER C The degree of the minimal polynomial basis K(s) for the C right nullspace of P(s) unless DK = -1, in which case C there is no right nullspace. C C GAM (output) INTEGER array, dimension (DP*MP+1) C The leading (DK+1) elements of this array contain C information about the ordering of the right nullspace C vectors stored in array NULLSP. C C NULLSP (output) DOUBLE PRECISION array, dimension C (LDNULL,(DP*MP+1)*NP) C The leading NP-by-SUM(i*GAM(i)) part of this array C contains the right nullspace vectors of P(s) in condensed C form (as defined in METHOD), where i = 1,2,...,DK+1. C C LDNULL INTEGER C The leading dimension of array NULLSP. C LDNULL >= MAX(1,NP). C C KER (output) DOUBLE PRECISION array, dimension C (LDKER1,LDKER2,DP*MP+1) C The leading NP-by-nk-by-(DK+1) part of this array contains C the coefficients of the minimal polynomial basis K(s), C where nk = SUM(GAM(i)) and i = 1,2,...,DK+1. Specifically, C KER(i,j,m) contains the (i,j)-th element of K(m-1), which C is the coefficient of s**(m-1) of K(s), where i = 1,2,..., C NP, j = 1,2,...,nk and m = 1,2,...,DK+1. C C LDKER1 INTEGER C The leading dimension of array KER. LDKER1 >= MAX(1,NP). C C LDKER2 INTEGER C The second dimension of array KER. LDKER2 >= MAX(1,NP). C C Tolerances C C TOL DOUBLE PRECISION C A tolerance below which matrix elements are considered C to be zero. If the user sets TOL to be less than C 10 * EPS * MAX( ||A|| , ||E|| ), then the tolerance is C F F C taken as 10 * EPS * MAX( ||A|| , ||E|| ), where EPS is the C F F C machine precision (see LAPACK Library Routine DLAMCH) and C A and E are matrices (as defined in METHOD). C C Workspace C C IWORK INTEGER array, dimension (m+2*MAX(n,m+1)+n), C where m = DP*MP and n = (DP-1)*MP + NP. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK The length of the array DWORK. C LDWORK >= m*n*n + 2*m*n + 2*n*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 > 0: if incorrect rank decisions were taken during the C computations. This failure is not likely to occur. C The possible values are: C k, 1 <= k <= DK+1, the k-th diagonal submatrix had C not a full row rank; C DK+2, if incorrect dimensions of a full column C rank submatrix; C DK+3, if incorrect dimensions of a full row rank C submatrix. C C METHOD C C The computation of the right nullspace of the MP-by-NP polynomial C matrix P(s) of degree DP given by C DP-1 DP C P(s) = P(0) + P(1) * s + ... + P(DP-1) * s + P(DP) * s C C is performed via the pencil s*E - A, associated with P(s), where C C | I | | 0 -P(DP) | C | . | | I . . | C A = | . | and E = | . . . |. (1) C | . | | . 0 . | C | I | | I 0 -P(2) | C | P(0) | | I -P(1) | C C The pencil s*E - A is transformed by unitary matrices Q and Z such C that C C | sE(eps)-A(eps) | X | X | C |----------------|----------------|------------| C | 0 | sE(inf)-A(inf) | X | C Q'(s*E-A)Z = |=================================|============|. C | | | C | 0 | sE(r)-A(r) | C C Since s*E(inf)-A(inf) and s*E(r)-A(r) have full column rank, the C minimal polynomial basis for the right nullspace of Q'(s*E-A)Z C (and consequently the basis for the right nullspace of s*E - A) is C completely determined by s*E(eps)-A(eps). C C Let Veps(s) be a minimal polynomial basis for the right nullspace C of s*E(eps)-A(eps). Then C C | Veps(s) | C V(s) = Z * |---------| C | 0 | C C is a minimal polynomial basis for the right nullspace of s*E - A. C From the structure of s*E - A it can be shown that if V(s) is C partitioned as C C | Vo(s) | (DP-1)*MP C V(s) = |------ | C | Ve(s) | NP C C then the columns of Ve(s) form a minimal polynomial basis for the C right nullspace of P(s). C C The vectors of Ve(s) are computed and stored in array NULLSP in C the following condensed form: C C || || | || | | || | | C || U1,0 || U2,0 | U2,1 || U3,0 | U3,1 | U3,2 || U4,0 | ... |, C || || | || | | || | | C C where Ui,j is an NP-by-GAM(i) matrix which contains the i-th block C of columns of K(j), the j-th coefficient of the polynomial matrix C representation for the right nullspace C DK C K(s) = K(0) + K(1) * s + . . . + K(DK) * s . C C The coefficients K(0), K(1), ..., K(DK) are NP-by-nk matrices C given by C C K(0) = | U1,0 | U2,0 | U3,0 | . . . | U(DK+1,0) | C C K(1) = | 0 | U2,1 | U3,1 | . . . | U(DK+1,1) | C C K(2) = | 0 | 0 | U3,2 | . . . | U(DK+1,2) | C C . . . . . . . . . . C C K(DK) = | 0 | 0 | 0 | . . . | 0 | U(DK+1,DK)|. C C Note that the degree of K(s) satisfies the inequality DK <= C DP * MIN(MP,NP) and that the dimension of K(s) satisfies the C inequality (NP-MP) <= nk <= NP. C C REFERENCES C C [1] Beelen, Th.G.J. C New Algorithms for Computing the Kronecker structure of a C Pencil with Applications to Systems and Control Theory. C Ph.D.Thesis, Eindhoven University of Technology, 1987. C C [2] Van Den Hurk, G.J.H.H. C New Algorithms for Solving Polynomial Matrix Problems. C Master's Thesis, Eindhoven University of Technology, 1987. C C NUMERICAL ASPECTS C C The algorithm used by the routine involves the construction of a C special block echelon form with pivots considered to be non-zero C when they are larger than TOL. These pivots are then inverted in C order to construct the columns of the kernel of the polynomial C matrix. If TOL is chosen to be too small then these inversions may C be sensitive whereas increasing TOL will make the inversions more C robust but will affect the block echelon form (and hence the C column degrees of the polynomial kernel). Furthermore, if the C elements of the computed polynomial kernel are large relative to C the polynomial matrix, then the user should consider trying C several values of TOL. C C FURTHER COMMENTS C C It also possible to compute a minimal polynomial basis for the C right nullspace of a pencil, since a pencil is a polynomial matrix C of degree 1. Thus for the pencil (s*E - A), the required input is C P(1) = E and P(0) = -A. C C The routine can also be used to compute a minimal polynomial C basis for the left nullspace of a polynomial matrix by simply C transposing P(s). C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC03BD by A.J. Geurts and MC03BZ by C Th.G.J. Beelen, A.J. Geurts, and G.J.H.H. van den Hurk. C C REVISIONS C C Jan. 1998. C C KEYWORDS C C Echelon form, elementary polynomial operations, input output C description, polynomial matrix, polynomial operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TEN PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 ) C .. Scalar Arguments .. INTEGER DK, DP, INFO, LDKER1, LDKER2, LDNULL, LDP1, $ LDP2, LDWORK, MP, NP DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER GAM(*), IWORK(*) DOUBLE PRECISION DWORK(*), KER(LDKER1,LDKER2,*), $ NULLSP(LDNULL,*), P(LDP1,LDP2,*) C .. Local Scalars .. INTEGER GAMJ, H, I, IDIFF, IFIR, J, JWORKA, JWORKE, $ JWORKQ, JWORKV, JWORKZ, K, M, MUK, N, NBLCKS, $ NBLCKI, NCA, NCV, NRA, NUK, RANKE, SGAMK, TAIL, $ VC1, VR2 DOUBLE PRECISION TOLER C .. Local Arrays .. INTEGER MNEI(3) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 EXTERNAL DLAMCH, DLANGE, DLAPY2 C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLASET, MB04UD, MB04VD, MC03NX, $ MC03NY, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, SQRT C .. Executable Statements .. C C Test the input scalar arguments. C M = DP*MP H = M - MP N = H + NP INFO = 0 IF( MP.LT.0 ) THEN INFO = -1 ELSE IF( NP.LT.0 ) THEN INFO = -2 ELSE IF( DP.LE.0 ) THEN INFO = -3 ELSE IF( LDP1.LT.MAX( 1, MP ) ) THEN INFO = -5 ELSE IF( LDP2.LT.MAX( 1, NP ) ) THEN INFO = -6 ELSE IF( LDNULL.LT.MAX( 1, NP ) ) THEN INFO = -10 ELSE IF( LDKER1.LT.MAX( 1, NP ) ) THEN INFO = -12 ELSE IF( LDKER2.LT.MAX( 1, NP ) ) THEN INFO = -13 ELSE IF( LDWORK.LT.( N*( M*N + 2*( M + N ) ) ) ) THEN INFO = -17 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MC03ND', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MP.EQ.0 .OR. NP.EQ.0 ) THEN DK = -1 RETURN END IF C JWORKA = 1 JWORKE = JWORKA + M*N JWORKZ = JWORKE + M*N JWORKV = JWORKZ + N*N JWORKQ = JWORKA C C Construct the matrices A and E in the pencil s*E-A in (1). C Workspace: 2*M*N. C CALL MC03NX( MP, NP, DP, P, LDP1, LDP2, DWORK(JWORKA), M, $ DWORK(JWORKE), M ) C C Computation of the tolerance. C TOLER = MAX( DLANGE( 'F', M, NP, DWORK(JWORKE+H*M), M, DWORK ), $ DLANGE( 'F', MP, NP, P, LDP1, DWORK ) ) TOLER = TEN*DLAMCH( 'Epsilon' ) $ *DLAPY2( TOLER, SQRT( DBLE( H ) ) ) IF ( TOLER.LE.TOL ) TOLER = TOL C C Reduction of E to column echelon form E0 = Q' x E x Z and C transformation of A, A0 = Q' x A x Z. C Workspace: 2*M*N + N*N + max(M,N). C CALL MB04UD( 'No Q', 'Identity Z', M, N, DWORK(JWORKA), M, $ DWORK(JWORKE), M, DWORK(JWORKQ), M, DWORK(JWORKZ), N, $ RANKE, IWORK, TOLER, DWORK(JWORKV), INFO ) C C The contents of ISTAIR is transferred from MB04UD to MB04VD by C IWORK(i), i=1,...,M. C In the sequel the arrays IMUK and INUK are part of IWORK, namely: C IWORK(i), i = M+1,...,M+max(N,M+1), contains IMUK, C IWORK(i), i = M+max(N,M+1)+1,...,M+2*max(N,M+1), contains INUK. C IWORK(i), i = M+2*max(N,M+1)+1,...,M+2*max(N,M+1)+N, contains C IMUK0 (not needed), and is also used as workspace. C MUK = M + 1 NUK = MUK + MAX( N, M+1 ) TAIL = NUK + MAX( N, M+1 ) C CALL MB04VD( 'Separation', 'No Q', 'Update Z', M, N, RANKE, $ DWORK(JWORKA), M, DWORK(JWORKE), M, DWORK(JWORKQ), M, $ DWORK(JWORKZ), N, IWORK, NBLCKS, NBLCKI, IWORK(MUK), $ IWORK(NUK), IWORK(TAIL), MNEI, TOLER, IWORK(TAIL), $ INFO ) IF ( INFO.GT.0 ) THEN C C Incorrect rank decisions. C INFO = INFO + NBLCKS RETURN END IF C C If NBLCKS < 1, or the column dimension of s*E(eps) - A(eps) is C zero, then there is no right nullspace. C IF ( NBLCKS.LT.1 .OR. MNEI(2).EQ.0 ) THEN DK = -1 RETURN END IF C C Start of the computation of the minimal basis. C DK = NBLCKS - 1 NRA = MNEI(1) NCA = MNEI(2) C C Determine a minimal basis VEPS(s) for the right nullspace of the C pencil s*E(eps)-A(eps) associated with the polynomial matrix P(s). C Workspace: 2*M*N + N*N + N*N*(M+1). C CALL MC03NY( NBLCKS, NRA, NCA, DWORK(JWORKA), M, DWORK(JWORKE), M, $ IWORK(MUK), IWORK(NUK), DWORK(JWORKV), N, INFO ) C IF ( INFO.GT.0 ) $ RETURN C NCV = IWORK(MUK) - IWORK(NUK) GAM(1) = NCV IWORK(1) = 0 IWORK(TAIL) = IWORK(MUK) C DO 20 I = 2, NBLCKS IDIFF = IWORK(MUK+I-1) - IWORK(NUK+I-1) GAM(I) = IDIFF IWORK(I) = NCV NCV = NCV + I*IDIFF IWORK(TAIL+I-1) = IWORK(TAIL+I-2) + IWORK(MUK+I-1) 20 CONTINUE C C Determine a basis for the right nullspace of the polynomial C matrix P(s). This basis is stored in array NULLSP in condensed C form. C CALL DLASET( 'Full', NP, NCV, ZERO, ZERO, NULLSP, LDNULL ) C C |VEPS(s)| C The last NP rows of the product matrix Z x |-------| contain the C | 0 | C polynomial basis for the right nullspace of the polynomial matrix C P(s) in condensed form. The multiplication is restricted to the C nonzero submatrices Vij,k of VEPS, the result is stored in the C array NULLSP. C VC1 = 1 C DO 60 I = 1, NBLCKS VR2 = IWORK(TAIL+I-1) C DO 40 J = 1, I C C Multiplication of Z(H+1:N,1:VR2) with V.i,j-1 stored in C VEPS(1:VR2,VC1:VC1+GAM(I)-1). C CALL DGEMM( 'No transpose', 'No transpose', NP, GAM(I), VR2, $ ONE, DWORK(JWORKZ+H), N, $ DWORK(JWORKV+(VC1-1)*N), N, ZERO, NULLSP(1,VC1), $ LDNULL ) VC1 = VC1 + GAM(I) VR2 = VR2 - IWORK(MUK+I-J) 40 CONTINUE C 60 CONTINUE C C Transfer of the columns of NULLSP to KER in order to obtain the C polynomial matrix representation of K(s), the right nullspace C of P(s). C SGAMK = 1 C DO 100 K = 1, NBLCKS CALL DLASET( 'Full', NP, SGAMK-1, ZERO, ZERO, KER(1,1,K), $ LDKER1 ) IFIR = SGAMK C C Copy the appropriate columns of NULLSP into KER(k). C SGAMK = 1 + SUM(i=1,..,k-1) GAM(i), is the first nontrivial C column of KER(k), the first SGAMK - 1 columns of KER(k) are C zero. IFIR denotes the position of the first column in KER(k) C in the set of columns copied for a value of J. C VC1 is the first column of NULLSP to be copied. C DO 80 J = K, NBLCKS GAMJ = GAM(J) VC1 = IWORK(J) + (K-1)*GAMJ + 1 CALL DLACPY( 'Full', NP, GAMJ, NULLSP(1,VC1), LDNULL, $ KER(1,IFIR,K), LDKER1 ) IFIR = IFIR + GAMJ 80 CONTINUE C SGAMK = SGAMK + GAM(K) 100 CONTINUE C RETURN C *** Last line of MC03ND *** END control-4.1.2/src/slicot/src/PaxHeaders/SB16CD.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB16CD.f0000644000175000017500000004674115012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE SB16CD( DICO, JOBD, JOBMR, JOBCF, ORDSEL, N, M, P, NCR, $ A, LDA, B, LDB, C, LDC, D, LDD, F, LDF, G, LDG, $ HSV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute, for a given open-loop model (A,B,C,D), and for C given state feedback gain F and full observer gain G, C such that A+B*F and A+G*C are stable, a reduced order C controller model (Ac,Bc,Cc) using a coprime factorization C based controller reduction approach. For reduction of C coprime factors, a stability enforcing frequency-weighted C model reduction is performed using either the square-root or C the balancing-free square-root versions of the Balance & Truncate C (B&T) model reduction method. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of the open-loop system as follows: C = 'C': continuous-time system; C = 'D': discrete-time system. C C JOBD CHARACTER*1 C Specifies whether or not a non-zero matrix D appears C in the given state space model, as follows: C = 'D': D is present; C = 'Z': D is assumed a zero matrix. C C JOBMR CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root B&T method; C = 'F': use the balancing-free square-root B&T method. C C JOBCF CHARACTER*1 C Specifies whether left or right coprime factorization C of the controller is to be used as follows: C = 'L': use left coprime factorization; C = 'R': use right coprime factorization. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting controller order NCR is fixed; C = 'A': the resulting controller order NCR is C automatically determined on basis of the given C tolerance TOL. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the matrix A. N >= 0. C N also represents the order of the original state-feedback C controller. 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 NCR (input/output) INTEGER C On entry with ORDSEL = 'F', NCR is the desired order of C the resulting reduced order controller. 0 <= NCR <= N. C On exit, if INFO = 0, NCR is the order of the resulting C reduced order controller. NCR is set as follows: C if ORDSEL = 'F', NCR is equal to MIN(NCR,NCRMIN), where C NCR is the desired order on entry, and NCRMIN is the C number of Hankel-singular values greater than N*EPS*S1, C where EPS is the machine precision (see LAPACK Library C Routine DLAMCH) and S1 is the largest Hankel singular C value (computed in HSV(1)); NCR can be further reduced C to ensure HSV(NCR) > HSV(NCR+1); C if ORDSEL = 'A', NCR is equal to the number of Hankel C singular values greater than MAX(TOL,N*EPS*S1). 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 original state dynamics matrix A. C On exit, if INFO = 0, the leading NCR-by-NCR part of this C array contains the state dynamics matrix Ac of the reduced C controller. 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 open-loop system input/state matrix B. C On exit, this array is overwritten with a NCR-by-M C B&T approximation of the matrix B. 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 open-loop system state/output matrix C. C On exit, this array is overwritten with a P-by-NCR C B&T approximation of the matrix C. 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 On entry, if JOBD = 'D', the leading P-by-M part of this C array must contain the system direct input/output C 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 F (input/output) DOUBLE PRECISION array, dimension (LDF,N) C On entry, the leading M-by-N part of this array must C contain a stabilizing state feedback matrix. C On exit, if INFO = 0, the leading M-by-NCR part of this C array contains the output/state matrix Cc of the reduced C controller. C C LDF INTEGER C The leading dimension of array F. LDF >= MAX(1,M). C C G (input/output) DOUBLE PRECISION array, dimension (LDG,P) C On entry, the leading N-by-P part of this array must C contain a stabilizing observer gain matrix. C On exit, if INFO = 0, the leading NCR-by-P part of this C array contains the input/state matrix Bc of the reduced C controller. C C LDG INTEGER C The leading dimension of array G. LDG >= MAX(1,N). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, HSV contains the N frequency-weighted C Hankel singular values ordered decreasingly (see METHOD). C C Tolerances C C TOL DOUBLE PRECISION C If ORDSEL = 'A', TOL contains the tolerance for C determining the order of reduced controller. C The recommended value is TOL = c*S1, where c is a constant C in the interval [0.00001,0.001], and S1 is the largest C Hankel singular value (computed in HSV(1)). C The value TOL = N*EPS*S1 is used by default if C TOL <= 0 on entry, where EPS is the machine precision C (see LAPACK Library Routine DLAMCH). C If ORDSEL = 'F', the value of TOL is ignored. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = 0, if JOBMR = 'B'; C LIWORK = N, if JOBMR = 'F'. 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 >= 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX(M,P), C N*(N + MAX(N,MP) + MIN(N,MP) + 6)), C where MP = M, if JOBCF = 'L'; C MP = P, if JOBCF = 'R'. C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NCR is C greater than the order of a minimal realization C of the controller; C = 2: with ORDSEL = 'F', the selected order NCR C corresponds to repeated singular values, which are C neither all included nor all excluded from the C reduced controller. In this case, the resulting NCR C is set automatically to the largest value such that C HSV(NCR) > HSV(NCR+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: eigenvalue computation failure; C = 2: the matrix A+G*C is not stable; C = 3: the matrix A+B*F is not stable; C = 4: the Lyapunov equation for computing the C observability Grammian is (nearly) singular; C = 5: the Lyapunov equation for computing the C controllability Grammian is (nearly) singular; C = 6: the computation of Hankel singular values failed. C C METHOD C C Let be the linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t), (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system, and let Go(d) be the open-loop C transfer-function matrix C -1 C Go(d) = C*(d*I-A) *B + D . C C Let F and G be the state feedback and observer gain matrices, C respectively, chosen such that A+BF and A+GC are stable matrices. C The controller has a transfer-function matrix K(d) given by C -1 C K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G . C C The closed-loop transfer function matrix is given by C -1 C Gcl(d) = Go(d)(I+K(d)Go(d)) . C C K(d) can be expressed as a left coprime factorization (LCF) C -1 C K(d) = M_left(d) *N_left(d), C C or as a right coprime factorization (RCF) C -1 C K(d) = N_right(d)*M_right(d) , C C where M_left(d), N_left(d), N_right(d), and M_right(d) are C stable transfer-function matrices. C C The subroutine SB16CD determines the matrices of a reduced C controller C C d[z(t)] = Ac*z(t) + Bc*y(t) C u(t) = Cc*z(t), (2) C C with the transfer-function matrix Kr, using the following C stability enforcing approach proposed in [1]: C C (1) If JOBCF = 'L', the frequency-weighted approximation problem C is solved C C min||[M_left(d)-M_leftr(d) N_left(d)-N_leftr(d)][-Y(d)]|| , C [ X(d)] C where C -1 C G(d) = Y(d)*X(d) C C is a RCF of the open-loop system transfer-function matrix. C The B&T model reduction technique is used in conjunction C with the method proposed in [1]. C C (2) If JOBCF = 'R', the frequency-weighted approximation problem C is solved C C min || [ -U(d) V(d) ] [ N_right(d)-N_rightr(d) ] || , C [ M_right(d)-M_rightr(d) ] C where C -1 C G(d) = V(d) *U(d) C C is a LCF of the open-loop system transfer-function matrix. C The B&T model reduction technique is used in conjunction C with the method proposed in [1]. C C If ORDSEL = 'A', the order of the controller is determined by C computing the number of Hankel singular values greater than C the given tolerance TOL. The Hankel singular values are C the square roots of the eigenvalues of the product of C two frequency-weighted Grammians P and Q, defined as follows. C C If JOBCF = 'L', then P is the controllability Grammian of a system C of the form (A+BF,B,*,*), and Q is the observability Grammian of a C system of the form (A+GC,*,F,*). This choice corresponds to an C input frequency-weighted order reduction of left coprime C factors [1]. C C If JOBCF = 'R', then P is the controllability Grammian of a system C of the form (A+BF,G,*,*), and Q is the observability Grammian of a C system of the form (A+GC,*,C,*). This choice corresponds to an C output frequency-weighted order reduction of right coprime C factors [1]. C C For the computation of truncation matrices, the B&T approach C is used in conjunction with accuracy enhancing techniques. C If JOBMR = 'B', the square-root B&T method of [2,4] is used. C If JOBMR = 'F', the balancing-free square-root version of the C B&T method [3,4] is used. C C REFERENCES C C [1] Liu, Y., Anderson, B.D.O. and Ly, O.L. C Coprime factorization controller reduction with Bezout C identity induced frequency weighting. C Automatica, vol. 26, pp. 233-249, 1990. C C [2] Tombs, M.S. and Postlethwaite I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C [3] Varga, A. C Efficient minimal realization procedure based on balancing. C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, C pp. 42-46, 1991. C C [4] Varga, A. C Coprime factors model reduction method based on square-root C balancing-free techniques. C System Analysis, Modelling and Simulation, Vol. 11, C pp. 303-311, 1993. C C NUMERICAL ASPECTS C C The implemented methods rely on accuracy enhancing square-root or C balancing-free square-root techniques. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000. C D. Sima, University of Bucharest, October 2000. C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000. C C REVISIONS C C A. Varga, Australian National University, Canberra, November 2000. C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2001. C C KEYWORDS C C Controller reduction, coprime factorization, frequency weighting, C multivariable system, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOBCF, JOBD, JOBMR, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, $ LDF, LDG, LDWORK, M, N, NCR, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), F(LDF,*), G(LDG,*), HSV(*) C .. Local Scalars .. LOGICAL BAL, DISCR, FIXORD, LEFT, WITHD INTEGER IERR, KT, KTI, KW, LW, MP, NMR, WRKOPT DOUBLE PRECISION SCALEC, SCALEO C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB09IX, DGEMM, DLACPY, SB16CY, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) WITHD = LSAME( JOBD, 'D' ) BAL = LSAME( JOBMR, 'B' ) LEFT = LSAME( JOBCF, 'L' ) FIXORD = LSAME( ORDSEL, 'F' ) IF( LEFT ) THEN MP = M ELSE MP = P END IF LW = 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX( M, P ), $ N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 ) ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( BAL .OR. LSAME( JOBMR, 'F' ) ) ) THEN INFO = -3 ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN INFO = -4 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( P.LT.0 ) THEN INFO = -8 ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN INFO = -9 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN INFO = -17 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -19 ELSE IF( LDG.LT.MAX( 1, N ) ) THEN INFO = -21 ELSE IF( LDWORK.LT.LW ) THEN INFO = -26 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB16CD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 .OR. $ ( FIXORD .AND. NCR.EQ.0 ) ) THEN NCR = 0 DWORK(1) = ONE RETURN END IF C C Allocate working storage. C KT = 1 KTI = KT + N*N KW = KTI + N*N C C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors Su and Ru C of the frequency-weighted controllability and observability C Grammians, respectively. C C Workspace: need 2*N*N + MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)), C if JOBCF = 'L'; C 2*N*N + MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)), C if JOBCF = 'R'. C prefer larger. C CALL SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC, $ F, LDF, G, LDG, SCALEC, SCALEO, DWORK(KTI), N, $ DWORK(KT), N, DWORK(KW), LDWORK-KW+1, INFO ) C IF( INFO.NE.0 ) $ RETURN WRKOPT = INT( DWORK(KW) ) + KW - 1 C C Compute a B&T approximation (Ar,Br,Cr) of (A,B,C) and C the corresponding truncation matrices TI and T. C C Real workspace: need 2*N*N + MAX( 1, 2*N*N+5*N, N*MAX(M,P) ); C prefer larger. C Integer workspace: 0, if JOBMR = 'B'; C N, if JOBMR = 'F'. C CALL AB09IX( DICO, JOBMR, 'NotSchur', ORDSEL, N, M, P, NCR, $ SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD, $ DWORK(KTI), N, DWORK(KT), N, NMR, HSV, TOL, TOL, $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) IF( IERR.NE.0 ) THEN INFO = 6 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Compute reduced gains Bc = Gr = TI*G and Cc = Fr = F*T. C Workspace: need N*(2*N+MAX(M,P)). C CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KW), N ) CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, P, N, ONE, $ DWORK(KTI), N, DWORK(KW), N, ZERO, G, LDG ) C CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KW), M ) CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NCR, N, ONE, $ DWORK(KW), M, DWORK(KT), N, ZERO, F, LDF ) C C Form the reduced controller state matrix, C Ac = Ar + Br*Fr + Gr*Cr + Gr*D*Fr = Ar + Br*Fr + Gr*(Cr+D*Fr) . C C Workspace: need P*N. C CALL DLACPY( 'Full', P, NCR, C, LDC, DWORK, P ) IF( WITHD) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NCR, M, $ ONE, D, LDD, F, LDF, ONE, DWORK, P ) CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, P, ONE, G, $ LDG, DWORK, P, ONE, A, LDA ) CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, M, ONE, B, $ LDB, F, LDF, ONE, A, LDA ) C DWORK(1) = WRKOPT C RETURN C *** Last line of SB16CD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03GZ.f0000644000000000000000000000013215012430707016177 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03GZ.f0000644000175000017500000000704115012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE MB03GZ( Z11, Z12, Z22, H11, H12, CO1, SI1, CO2, SI2 ) C C PURPOSE C C To compute a unitary matrix Q and a unitary symplectic matrix U C for a complex regular 2-by-2 skew-Hamiltonian/Hamiltonian pencil C aS - bH with S = J Z' J' Z, where C C ( Z11 Z12 ) ( H11 H12 ) C Z = ( ) and H = ( ), C ( 0 Z22 ) ( 0 -H11' ) C C such that U' Z Q, (J Q J' )' H Q are both upper triangular, but the C eigenvalues of (J Q J')' ( aS - bH ) Q are in reversed order. C The matrices Q and U are represented by C C ( CO1 SI1 ) ( CO2 SI2 ) C Q = ( ) and U = ( ), respectively. C ( -SI1' CO1 ) ( -SI2' CO2 ) C C The notation M' denotes the conjugate transpose of the matrix M. C C ARGUMENTS C C Input/Output Parameters C C Z11 (input) COMPLEX*16 C Upper left element of the non-trivial factor Z in the C factorization of S. C C Z12 (input) COMPLEX*16 C Upper right element of the non-trivial factor Z in the C factorization of S. C C Z22 (input) COMPLEX*16 C Lower right element of the non-trivial factor Z in the C factorization of S. C C H11 (input) COMPLEX*16 C Upper left element of the Hamiltonian matrix H. C C H12 (input) COMPLEX*16 C Upper right element of the Hamiltonian matrix H. C C CO1 (output) DOUBLE PRECISION C Upper left element of Q. C C SI1 (output) COMPLEX*16 C Upper right element of Q. C C CO2 (output) DOUBLE PRECISION C Upper left element of U. C C SI2 (output) COMPLEX*16 C Upper right element of U. C C METHOD C C The algorithm uses unitary and unitary symplectic transformations C as described on page 37 in [1]. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, April 21, 2009. C C REVISIONS C C V. Sima, Aug. 2009 (SLICOT version of the routine ZHAFEX). C V. Sima, Dec. 2010. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue exchange, skew-Hamiltonian/Hamiltonian pencil, upper C triangular matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D+0 ) C C .. Scalar Arguments .. DOUBLE PRECISION CO1, CO2 COMPLEX*16 H11, H12, SI1, SI2, Z11, Z12, Z22 C C .. Local Scalars .. COMPLEX*16 D, G, TMP C C .. External Subroutines .. EXTERNAL ZLARTG C C .. Intrinsic Functions .. INTRINSIC DBLE, DCONJG C C .. Executable Statements .. C C Computations. C G = TWO*DBLE( H11*DCONJG( Z11 )*Z22 ) D = Z22*DCONJG( Z11 )*H12 + $ ( DCONJG( Z22 )*Z12 - DCONJG( Z12 )*Z22 )*DCONJG( H11 ) CALL ZLARTG( D, G, CO1, SI1, TMP ) D = Z11*CO1 - Z12*DCONJG( SI1 ) G = -Z22*DCONJG( SI1 ) CALL ZLARTG( D, G, CO2, SI2, TMP ) SI2 = -SI2 C RETURN C *** Last line of MB03GZ *** END control-4.1.2/src/slicot/src/PaxHeaders/SB08DD.f0000644000000000000000000000013215012430707016161 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB08DD.f0000644000175000017500000005025615012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ NQ, NR, CR, LDCR, DR, LDDR, TOL, DWORK, LDWORK, $ IWARN, INFO ) C C PURPOSE C C To construct, for a given system G = (A,B,C,D), a feedback matrix C F, an orthogonal transformation matrix Z, and a gain matrix V, C such that the systems C C Q = (Z'*(A+B*F)*Z, Z'*B*V, (C+D*F)*Z, D*V) C and C R = (Z'*(A+B*F)*Z, Z'*B*V, F*Z, V) C C provide a stable right coprime factorization of G in the form C -1 C G = Q * R , C C where G, Q and R are the corresponding transfer-function matrices C and the denominator R is inner, that is, R'(-s)*R(s) = I in the C continuous-time case, or R'(1/z)*R(z) = I in the discrete-time C case. The Z matrix is not explicitly computed. C C Note: G must have no controllable poles on the imaginary axis C for a continuous-time system, or on the unit circle for a C discrete-time system. If the given state-space representation C is not stabilizable, the unstabilizable part of the original C system is automatically deflated and the order of the systems C Q and R is accordingly reduced. 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 matrices C and CR. N >= 0. C C M (input) INTEGER C The dimension of input vector, i.e. the number of columns C of the matrices B, D and DR and the number of rows of the C matrices CR and DR. M >= 0. C C P (input) INTEGER C The dimension of output vector, i.e. the number of rows C of the matrices C and D. 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 A. The matrix A must not C have controllable eigenvalues on the imaginary axis, if C DICO = 'C', or on the unit circle, if DICO = 'D'. C On exit, the leading NQ-by-NQ part of this array contains C the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the C state dynamics matrix of the numerator factor Q, in a C real Schur form. The trailing NR-by-NR part of this matrix C represents the state dynamics matrix of a minimal C realization of the denominator factor R. 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. C On exit, the leading NQ-by-M part of this array contains C the leading NQ-by-M part of the matrix Z'*B*V, the C input/state matrix of the numerator factor Q. The last C NR rows of this matrix form the input/state matrix of C a minimal realization of the denominator factor R. 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 C. C On exit, the leading P-by-NQ part of this array contains C the leading P-by-NQ part of the matrix (C+D*F)*Z, C the state/output matrix of the numerator factor Q. 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. C On exit, the leading P-by-M part of this array contains C the matrix D*V representing the input/output matrix C of the numerator factor Q. 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 factors Q and R. C Generally, NQ = N - NS, where NS is the number of C uncontrollable eigenvalues outside the stability region. C C NR (output) INTEGER C The order of the minimal realization of the factor R. C Generally, NR is the number of controllable eigenvalues C of A outside the stability region (the number of modified C eigenvalues). C C CR (output) DOUBLE PRECISION array, dimension (LDCR,N) C The leading M-by-NQ part of this array contains the C leading M-by-NQ part of the feedback matrix F*Z, which C reflects the eigenvalues of A lying outside the stable C region to values which are symmetric with respect to the C imaginary axis (if DICO = 'C') or the unit circle (if C DICO = 'D'). The last NR columns of this matrix form the C state/output matrix of a minimal realization of the C denominator factor R. C C LDCR INTEGER C The leading dimension of array CR. LDCR >= MAX(1,M). C C DR (output) DOUBLE PRECISION array, dimension (LDDR,M) C The leading M-by-M part of this array contains the upper C triangular matrix V of order M representing the C input/output matrix of the denominator factor R. C C LDDR INTEGER C The leading dimension of array DR. LDDR >= MAX(1,M). 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, N*(N+5), M*(M+2), 4*M, 4*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 NORM(F) <= 10*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: 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 C METHOD C C The subroutine is based on the factorization algorithm of [1]. C C REFERENCES C C [1] Varga A. C A Schur method for computing coprime factorizations with inner C 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 A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, July 1998. C Based on the RASP routine RCFID. C C REVISIONS C C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. C Feb. 1999, May 2003, A. Varga, DLR Oberpfaffenhofen. C C KEYWORDS C C Coprime factorization, eigenvalue, eigenvalue assignment, C feedback control, pole placement, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TEN, ZERO PARAMETER ( ONE = 1.0D0, TEN = 1.0D1, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO INTEGER INFO, IWARN, LDA, LDB, LDC, LDCR, LDD, LDDR, $ LDWORK, M, N, NQ, NR, P DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), CR(LDCR,*), $ D(LDD,*), DR(LDDR,*), DWORK(*) C .. Local Scalars .. LOGICAL DISCR INTEGER I, IB, IB1, J, K, KFI, KV, KW, KWI, KWR, KZ, L, $ L1, NB, NCUR, NFP, NLOW, NSUP DOUBLE PRECISION ALPHA, BNORM, CS, PR, RMAX, SM, SN, TOLER, $ WRKOPT, X, Y C .. Local Arrays .. DOUBLE PRECISION Z(4,4) C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE LOGICAL LSAME EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DGEMM, DLACPY, DLAEXC, DLANV2, DLASET, DROT, $ DTRMM, DTRMV, SB01FY, TB01LD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN 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( 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( LDCR.LT.MAX( 1, M ) ) THEN INFO = -16 ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN INFO = -18 ELSE IF( LDWORK.LT.MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ) ) THEN INFO = -21 END IF IF( INFO.NE.0 )THEN C C Error return. C CALL XERBLA( 'SB08DD', -INFO ) RETURN END IF C C Set DR = I and quick return if possible. C NR = 0 IF( MIN( M, P ).GT.0 ) $ CALL DLASET( 'Full', M, M, ZERO, ONE, DR, LDDR ) IF( MIN( N, M ).EQ.0 ) THEN NQ = 0 DWORK(1) = ONE RETURN END IF C C Set F = 0 in the array CR. C CALL DLASET( 'Full', M, N, ZERO, ZERO, CR, LDCR ) C C Compute the norm of B and set the default tolerance if necessary. C BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) TOLER = TOL IF( TOLER.LE.ZERO ) $ TOLER = DBLE( N ) * BNORM * DLAMCH( 'Epsilon' ) IF( BNORM.LE.TOLER ) THEN NQ = 0 DWORK(1) = ONE RETURN END IF C C Compute the bound for the numerical stability condition. C RMAX = TEN * DLANGE( '1-norm', N, N, A, LDA, DWORK ) / BNORM C C Allocate working storage. C KZ = 1 KWR = KZ + N*N KWI = KWR + N KW = KWI + N 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 spectrum of A is C performed such that the leading NFP-by-NFP submatrix of A C corresponds to the "stable" eigenvalues which will be not C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A C corresponds to the "unstable" eigenvalues to be modified. C Apply the transformation to B and C: B <- Z'*B and C <- C*Z. C C Workspace needed: N*(N+2); C Additional workspace: need 3*N; C prefer larger. C IF( DISCR ) THEN ALPHA = ONE ELSE ALPHA = ZERO END IF CALL TB01LD( DICO, 'Stable', 'General', N, M, P, ALPHA, A, LDA, $ B, LDB, C, LDC, NFP, DWORK(KZ), N, DWORK(KWR), $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, INFO ) IF( INFO.NE.0 ) $ RETURN C WRKOPT = DWORK(KW) + DBLE( KW-1 ) C C Perform the pole assignment if there exist "unstable" eigenvalues. C NQ = N IF( NFP.LT.N ) THEN KV = 1 KFI = KV + M*M KW = KFI + 2*M C C Set the limits for the bottom diagonal block. C NLOW = NFP + 1 NSUP = N C C WHILE (NLOW <= NSUP) DO 10 IF( NLOW.LE.NSUP ) THEN C C Main loop for assigning one or two poles. 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 L = NSUP - IB + 1 C C Check the controllability of the last block. C IF( DLANGE( '1-norm', IB, M, B(L,1), LDB, DWORK(KW) ) $ .LE.TOLER ) THEN C C Deflate the uncontrollable block and resume the main C loop. C NSUP = NSUP - IB ELSE C C Determine the M-by-IB feedback matrix FI which assigns C the selected IB poles for the pair C ( A(L:L+IB-1,L:L+IB-1), B(L:L+IB-1,1:M) ). C C Workspace needed: M*(M+2). C CALL SB01FY( DISCR, IB, M, A(L,L), LDA, B(L,1), LDB, $ DWORK(KFI), M, DWORK(KV), M, INFO ) IF( INFO.EQ.2 ) THEN INFO = 3 RETURN END IF C C Check for possible numerical instability. C IF( DLANGE( '1-norm', M, IB, DWORK(KFI), M, DWORK(KW) ) $ .GT.RMAX ) IWARN = IWARN + 1 C C Update the state matrix A <-- A + B*[0 FI]. C CALL DGEMM( 'NoTranspose', 'NoTranspose', NSUP, IB, M, $ ONE, B, LDB, DWORK(KFI), M, ONE, A(1,L), $ LDA ) C C Update the feedback matrix F <-- F + V*[0 FI] in CR. C IF( DISCR ) $ CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', $ M, IB, ONE, DR, LDDR, DWORK(KFI), M ) K = KFI DO 30 J = L, L + IB - 1 DO 20 I = 1, M CR(I,J) = CR(I,J) + DWORK(K) K = K + 1 20 CONTINUE 30 CONTINUE C IF( DISCR ) THEN C C Update the input matrix B <-- B*V. C CALL DTRMM( 'Right', 'Upper', 'NoTranspose', $ 'NonUnit', N, M, ONE, DWORK(KV), M, B, $ LDB ) C C Update the feedthrough matrix DR <-- DR*V. C K = KV DO 40 I = 1, M CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', $ M-I+1, DWORK(K), M, DR(I,I), LDDR ) K = K + M + 1 40 CONTINUE END IF C IF( IB.EQ.2 ) THEN C C Put the 2x2 block in a standard form. C L1 = L + 1 CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), $ X, Y, PR, SM, CS, SN ) C C Apply the transformation to A, B, C and F. C IF( L1.LT.NSUP ) $ CALL DROT( NSUP-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 ) CALL DROT( M, B(L,1), LDB, B(L1,1), LDB, CS, SN ) IF( P.GT.0 ) $ CALL DROT( P, C(1,L), 1, C(1,L1), 1, CS, SN ) CALL DROT( M, CR(1,L), 1, CR(1,L1), 1, CS, SN ) END IF IF( NLOW+IB.LE.NSUP ) THEN C C Move the last block(s) to the leading position(s) of C the bottom block. C C Workspace: need MAX(4*N, 4*M, 4*P). C NCUR = NSUP - IB C WHILE (NCUR >= NLOW) DO 50 IF( NCUR.GE.NLOW ) THEN C C Loop for positioning of the last block. C C Determine the dimension of the current block. C IB1 = 1 IF( NCUR.GT.NLOW ) THEN IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 END IF NB = IB1 + IB C C Initialize the local transformation matrix Z. C CALL DLASET( 'Full', NB, NB, ZERO, ONE, Z, 4 ) L = NCUR - IB1 + 1 C C Exchange two adjacent blocks and accumulate the C transformations in Z. C CALL DLAEXC( .TRUE., NB, A(L,L), LDA, Z, 4, 1, IB1, $ IB, DWORK, INFO ) IF( INFO.NE.0 ) THEN INFO = 2 RETURN END IF C C Apply the transformation to the rest of A. C L1 = L + NB IF( L1.LE.NSUP ) THEN CALL DGEMM( 'Transpose', 'NoTranspose', NB, $ NSUP-L1+1, NB, ONE, Z, 4, A(L,L1), $ LDA, ZERO, DWORK, NB ) CALL DLACPY( 'Full', NB, NSUP-L1+1, DWORK, NB, $ A(L,L1), LDA ) END IF CALL DGEMM( 'NoTranspose', 'NoTranspose', L-1, NB, $ NB, ONE, A(1,L), LDA, Z, 4, ZERO, $ DWORK, N ) CALL DLACPY( 'Full', L-1, NB, DWORK, N, A(1,L), $ LDA ) C C Apply the transformation to B, C and F. C CALL DGEMM( 'Transpose', 'NoTranspose', NB, M, NB, $ ONE, Z, 4, B(L,1), LDB, ZERO, DWORK, $ NB ) CALL DLACPY( 'Full', NB, M, DWORK, NB, B(L,1), $ LDB ) C IF( P.GT.0 ) THEN CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NB, $ NB, ONE, C(1,L), LDC, Z, 4, ZERO, $ DWORK, P ) CALL DLACPY( 'Full', P, NB, DWORK, P, $ C(1,L), LDC ) END IF C CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NB, $ NB, ONE, CR(1,L), LDCR, Z, 4, ZERO, $ DWORK, M ) CALL DLACPY( 'Full', M, NB, DWORK, M, CR(1,L), $ LDCR ) C NCUR = NCUR - IB1 GO TO 50 END IF C END WHILE 50 C END IF NLOW = NLOW + IB END IF GO TO 10 END IF C END WHILE 10 C NQ = NSUP NR = NSUP - NFP C C Annihilate the elements below the first subdiagonal of A. C IF( NQ.GT.2 ) $ CALL DLASET( 'Lower', NQ-2, NQ-2, ZERO, ZERO, A(3,1), LDA ) END IF C C Compute C <-- CQ = C + D*F and D <-- DQ = D*DR. C CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NQ, M, ONE, D, LDD, $ CR, LDCR, ONE, C, LDC ) IF( DISCR ) $ CALL DTRMM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', P, M, $ ONE, DR, LDDR, D, LDD ) C DWORK(1) = MAX( WRKOPT, DBLE( MAX( M*(M+2), 4*M, 4*P ) ) ) C RETURN C *** Last line of SB08DD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02VD.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02VD.f0000644000175000017500000001246315012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO ) C C PURPOSE C C To compute the solution to a real system of linear equations C X * op(A) = B, C where op(A) is either A or its transpose, A is an N-by-N matrix, C and X and B are M-by-N matrices. C The LU decomposition with partial pivoting and row interchanges, C A = P * L * U, is used, where P is a permutation matrix, L is unit C lower triangular, and U is upper triangular. C C ARGUMENTS C C Mode Parameters C C TRANS CHARACTER*1 C Specifies the form of op(A) to be used 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 number of rows of the matrix B. M >= 0. C C N (input) INTEGER C The number of columns of the matrix B, and the order of C the matrix A. 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 coefficient matrix A. 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; C the unit diagonal elements of L are not stored. 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 that define the permutation matrix P; C row i of the matrix was interchanged with row IPIV(i). 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 right hand side matrix B. C On exit, if INFO = 0, the leading M-by-N part of this C array contains the solution matrix X. C C LDB (input) INTEGER C The leading dimension of the array B. LDB >= max(1,M). C C INFO (output) INTEGER C = 0: successful exit; C < 0: if INFO = -i, the i-th argument had an illegal C value; C > 0: if INFO = i, U(i,i) is exactly zero. The C factorization has been completed, but the factor U C is exactly singular, so the solution could not be C computed. C C METHOD C C The LU decomposition with partial pivoting and row interchanges is C used to factor A as C A = P * L * U, C where P is a permutation matrix, L is unit lower triangular, and C U is upper triangular. The factored form of A is then used to C solve the system of equations X * A = B or X * A' = B. C C FURTHER COMMENTS C C This routine enables to solve the system X * A = B or X * A' = B C as easily and efficiently as possible; it is similar to the LAPACK C Library routine DGESV, which solves A * X = B. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, linear algebra. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDA, LDB, M, N C .. C .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ) C .. C .. Local Scalars .. LOGICAL TRAN C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL DGETRF, DTRSM, MA02GD, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the scalar input parameters. C INFO = 0 TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) C IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -8 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02VD', -INFO ) RETURN END IF C C Compute the LU factorization of A. C CALL DGETRF( N, N, A, LDA, IPIV, INFO ) C IF( INFO.EQ.0 ) THEN IF( TRAN ) THEN C C Compute X = B * A**(-T). C CALL MA02GD( M, B, LDB, 1, N, IPIV, 1 ) CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Unit', M, N, $ ONE, A, LDA, B, LDB ) CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', M, $ N, ONE, A, LDA, B, LDB ) ELSE C C Compute X = B * A**(-1). C CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', M, $ N, ONE, A, LDA, B, LDB ) CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', M, N, $ ONE, A, LDA, B, LDB ) CALL MA02GD( M, B, LDB, 1, N, IPIV, -1 ) END IF END IF RETURN C C *** Last line of MB02VD *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01PD.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/IB01PD.f0000644000175000017500000014114015012430707017351 0ustar00lilgelilge00000000000000 SUBROUTINE IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, $ RY, LDRY, S, LDS, O, LDO, TOL, IWORK, DWORK, $ LDWORK, IWARN, INFO ) C C PURPOSE C C To estimate the matrices A, C, B, and D of a linear time-invariant C (LTI) state space model, using the singular value decomposition C information provided by other routines. Optionally, the system and C noise covariance matrices, needed for the Kalman gain, are also C determined. C C ARGUMENTS C C Mode Parameters C C METH CHARACTER*1 C Specifies the subspace identification method to be used, C as follows: C = 'M': MOESP algorithm with past inputs and outputs; C = 'N': N4SID algorithm. C C JOB CHARACTER*1 C Specifies which matrices should be computed, as follows: C = 'A': compute all system matrices, A, B, C, and D; C = 'C': compute the matrices A and C only; C = 'B': compute the matrix B only; C = 'D': compute the matrices B and D only. C C JOBCV CHARACTER*1 C Specifies whether or not the covariance matrices are to C be computed, as follows: C = 'C': the covariance matrices should be computed; C = 'N': the covariance matrices should not be computed. C C Input/Output Parameters C C NOBR (input) INTEGER C The number of block rows, s, in the input and output C Hankel matrices processed by other routines. NOBR > 1. C C N (input) INTEGER C The order of the system. NOBR > N > 0. C C M (input) INTEGER C The number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L > 0. C C NSMPL (input) INTEGER C If JOBCV = 'C', the total number of samples used for C calculating the covariance matrices. C NSMPL >= 2*(M+L)*NOBR. C This parameter is not meaningful if JOBCV = 'N'. C C R (input/workspace) DOUBLE PRECISION array, dimension C ( LDR,2*(M+L)*NOBR ) C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR part C of this array must contain the relevant data for the MOESP C or N4SID algorithms, as constructed by SLICOT Library C routines IB01AD or IB01ND. Let R_ij, i,j = 1:4, be the C ij submatrix of R (denoted S in IB01AD and IB01ND), C partitioned by M*NOBR, L*NOBR, M*NOBR, and L*NOBR C rows and columns. The submatrix R_22 contains the matrix C of left singular vectors used. Also needed, for C METH = 'N' or JOBCV = 'C', are the submatrices R_11, C R_14 : R_44, and, for METH = 'M' and JOB <> 'C', the C submatrices R_31 and R_12, containing the processed C matrices R_1c and R_2c, respectively, as returned by C SLICOT Library routines IB01AD or IB01ND. C Moreover, if METH = 'N' and JOB = 'A' or 'C', the C block-row R_41 : R_43 must contain the transpose of the C block-column R_14 : R_34 as returned by SLICOT Library C routines IB01AD or IB01ND. C The remaining part of R is used as workspace. C On exit, part of this array is overwritten. Specifically, C if METH = 'M', R_22 and R_31 are overwritten if C JOB = 'B' or 'D', and R_12, R_22, R_14 : R_34, C and possibly R_11 are overwritten if JOBCV = 'C'; C if METH = 'N', all needed submatrices are overwritten. C C LDR INTEGER C The leading dimension of the array R. C LDR >= 2*(M+L)*NOBR. C C A (input or output) DOUBLE PRECISION array, dimension C (LDA,N) C On entry, if METH = 'N' and JOB = 'B' or 'D', the C leading N-by-N part of this array must contain the system C state matrix. C If METH = 'M' or (METH = 'N' and JOB = 'A' or 'C'), C this array need not be set on input. C On exit, if JOB = 'A' or 'C' and INFO = 0, the C leading N-by-N part of this array contains the system C state matrix. C C LDA INTEGER C The leading dimension of the array A. C LDA >= N, if JOB = 'A' or 'C', or METH = 'N' and C JOB = 'B' or 'D'; C LDA >= 1, otherwise. C C C (input or output) DOUBLE PRECISION array, dimension C (LDC,N) C On entry, if METH = 'N' and JOB = 'B' or 'D', the C leading L-by-N part of this array must contain the system C output matrix. C If METH = 'M' or (METH = 'N' and JOB = 'A' or 'C'), C this array need not be set on input. C On exit, if JOB = 'A' or 'C' and INFO = 0, or C INFO = 3 (or INFO >= 0, for METH = 'M'), the leading C L-by-N part of this array contains the system output C matrix. C C LDC INTEGER C The leading dimension of the array C. C LDC >= L, if JOB = 'A' or 'C', or METH = 'N' and C JOB = 'B' or 'D'; C LDC >= 1, otherwise. C C B (output) DOUBLE PRECISION array, dimension (LDB,M) C If M > 0, JOB = 'A', 'B', or 'D' and INFO = 0, the C leading N-by-M part of this array contains the system C input matrix. If M = 0 or JOB = 'C', this array is C not referenced. C C LDB INTEGER C The leading dimension of the array B. C LDB >= N, if M > 0 and JOB = 'A', 'B', or 'D'; C LDB >= 1, if M = 0 or JOB = 'C'. C C D (output) DOUBLE PRECISION array, dimension (LDD,M) C If M > 0, JOB = 'A' or 'D' and INFO = 0, the leading C L-by-M part of this array contains the system input-output C matrix. If M = 0 or JOB = 'C' or 'B', this array is C not referenced. C C LDD INTEGER C The leading dimension of the array D. C LDD >= L, if M > 0 and JOB = 'A' or 'D'; C LDD >= 1, if M = 0 or JOB = 'C' or 'B'. C C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) C If JOBCV = 'C', the leading N-by-N part of this array C contains the positive semidefinite state covariance matrix C to be used as state weighting matrix when computing the C Kalman gain. C This parameter is not referenced if JOBCV = 'N'. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= N, if JOBCV = 'C'; C LDQ >= 1, if JOBCV = 'N'. C C RY (output) DOUBLE PRECISION array, dimension (LDRY,L) C If JOBCV = 'C', the leading L-by-L part of this array C contains the positive (semi)definite output covariance C matrix to be used as output weighting matrix when C computing the Kalman gain. C This parameter is not referenced if JOBCV = 'N'. C C LDRY INTEGER C The leading dimension of the array RY. C LDRY >= L, if JOBCV = 'C'; C LDRY >= 1, if JOBCV = 'N'. C C S (output) DOUBLE PRECISION array, dimension (LDS,L) C If JOBCV = 'C', the leading N-by-L part of this array C contains the state-output cross-covariance matrix to be C used as cross-weighting matrix when computing the Kalman C gain. C This parameter is not referenced if JOBCV = 'N'. C C LDS INTEGER C The leading dimension of the array S. C LDS >= N, if JOBCV = 'C'; C LDS >= 1, if JOBCV = 'N'. C C O (output) DOUBLE PRECISION array, dimension ( LDO,N ) C If METH = 'M' and JOBCV = 'C', or METH = 'N', C the leading L*NOBR-by-N part of this array contains C the estimated extended observability matrix, i.e., the C first N columns of the relevant singular vectors. C If METH = 'M' and JOBCV = 'N', this array is not C referenced. C C LDO INTEGER C The leading dimension of the array O. C LDO >= L*NOBR, if JOBCV = 'C' or METH = 'N'; C LDO >= 1, otherwise. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used for estimating the rank of C matrices. If the user sets TOL > 0, then the given value C of TOL is used as a lower bound for the reciprocal C condition number; an m-by-n matrix whose estimated C condition number is less than 1/TOL is considered to C be of full rank. If the user sets TOL <= 0, then an C implicitly computed, default tolerance, defined by C TOLDEF = m*n*EPS, is used instead, where EPS is the C relative machine precision (see LAPACK Library routine C DLAMCH). C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = N, if METH = 'M' and M = 0 C or JOB = 'C' and JOBCV = 'N'; C LIWORK = M*NOBR+N, if METH = 'M', JOB = 'C', C and JOBCV = 'C'; C LIWORK = max(L*NOBR,M*NOBR), if METH = 'M', JOB <> 'C', C and JOBCV = 'N'; C LIWORK = max(L*NOBR,M*NOBR+N), if METH = 'M', JOB <> 'C', C and JOBCV = 'C'; C LIWORK = max(M*NOBR+N,M*(N+L)), if METH = '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(4), and C DWORK(5) contain the reciprocal condition numbers of the C triangular factors of the matrices, defined in the code, C GaL (GaL = Un(1:(s-1)*L,1:n)), R_1c (if METH = 'M'), C M (if JOBCV = 'C' or METH = 'N'), and Q or T (see C SLICOT Library routines IB01PY or IB01PX), respectively. C If METH = 'N', DWORK(3) is set to one without any C calculations. Similarly, if METH = 'M' and JOBCV = 'N', C DWORK(4) is set to one. If M = 0 or JOB = 'C', C DWORK(3) and DWORK(5) are set to one. C On exit, if INFO = -30, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= max( LDW1,LDW2 ), where, if METH = 'M', C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ), C if JOB = 'C' or JOB = 'A' and M = 0; C LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N, C (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+ C max( L+M*NOBR, L*NOBR + C max( 3*L*NOBR+1, M ) ) ) C if M > 0 and JOB = 'A', 'B', or 'D'; C LDW2 >= 0, if JOBCV = 'N'; C LDW2 >= max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L), C 4*(M*NOBR+N)+1, M*NOBR+2*N+L ), C if JOBCV = 'C', C where Aw = N+N*N, if M = 0 or JOB = 'C'; C Aw = 0, otherwise; C and, if METH = 'N', C LDW1 >= max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L, C 2*(L*NOBR-L)*N+N*N+8*N, N+4*(M*NOBR+N)+1, C M*NOBR+3*N+L ); C LDW2 >= 0, if M = 0 or JOB = 'C'; C LDW2 >= M*NOBR*(N+L)*(M*(N+L)+1)+ C max( (N+L)**2, 4*M*(N+L)+1 ), C if M > 0 and JOB = 'A', 'B', or 'D'. C For good performance, LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 4: a least squares problem to be solved has a C rank-deficient coefficient matrix; C = 5: the computed covariance matrices are too small. C The problem seems to be a deterministic one. 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 = 2: the singular value decomposition (SVD) algorithm did C not converge; C = 3: a singular upper triangular matrix was found. C C METHOD C C In the MOESP approach, the matrices A and C are first C computed from an estimated extended observability matrix [1], C and then, the matrices B and D are obtained by solving an C extended linear system in a least squares sense. C In the N4SID approach, besides the estimated extended C observability matrix, the solutions of two least squares problems C are used to build another least squares problem, whose solution C is needed to compute the system matrices A, C, B, and D. The C solutions of the two least squares problems are also optionally C used by both approaches to find the covariance matrices. C C REFERENCES C C [1] Verhaegen M., and Dewilde, P. C Subspace Model Identification. Part 1: The output-error state- C space model identification class of algorithms. C Int. J. Control, 56, pp. 1187-1210, 1992. C C [2] Van Overschee, P., and De Moor, B. C N4SID: Two Subspace Algorithms for the Identification C of Combined Deterministic-Stochastic Systems. C Automatica, Vol.30, No.1, pp. 75-93, 1994. C C [3] Van Overschee, P. C Subspace Identification : Theory - Implementation - C Applications. C Ph. D. Thesis, Department of Electrical Engineering, C Katholieke Universiteit Leuven, Belgium, Feb. 1995. C C [4] Sima, V. C Subspace-based Algorithms for Multivariable System C Identification. C Studies in Informatics and Control, 5, pp. 335-344, 1996. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C C FURTHER COMMENTS C C In some applications, it is useful to compute the system matrices C using two calls to this routine, the first one with JOB = 'C', C and the second one with JOB = 'B' or 'D'. This is slightly less C efficient than using a single call with JOB = 'A', because some C calculations are repeated. If METH = 'N', all the calculations C at the first call are performed again at the second call; C moreover, it is required to save the needed submatrices of R C before the first call and restore them before the second call. C If the covariance matrices are desired, JOBCV should be set C to 'C' at the second call. If B and D are both needed, they C should be computed at once. C It is possible to compute the matrices A and C using the MOESP C algorithm (METH = 'M'), and the matrices B and D using the N4SID C algorithm (METH = 'N'). This combination could be slightly more C efficient than N4SID algorithm alone and it could be more accurate C than MOESP algorithm. No saving/restoring is needed in such a C combination, provided JOBCV is set to 'N' at the first call. C Recommended usage: either one call with JOB = 'A', or C first call with METH = 'M', JOB = 'C', JOBCV = 'N', C second call with METH = 'M', JOB = 'D', JOBCV = 'C', or C first call with METH = 'M', JOB = 'C', JOBCV = 'N', C second call with METH = 'N', JOB = 'D', JOBCV = 'C'. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 1999. C C REVISIONS C C March 2000, Feb. 2001, Sep. 2001, March 2005. C C KEYWORDS C C Identification methods; least squares solutions; multivariable C systems; QR decomposition; singular value decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDO, LDQ, $ LDR, LDRY, LDS, LDWORK, M, N, NOBR, NSMPL CHARACTER JOB, JOBCV, METH C .. Array Arguments .. DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), $ DWORK(*), O(LDO, *), Q(LDQ, *), R(LDR, *), $ RY(LDRY, *), S(LDS, *) INTEGER IWORK( * ) C .. Local Scalars .. DOUBLE PRECISION EPS, RCOND1, RCOND2, RCOND3, RCOND4, RNRM, $ SVLMAX, THRESH, TOLL, TOLL1 INTEGER I, IAW, ID, IERR, IGAL, IHOUS, ISV, ITAU, $ ITAU1, ITAU2, IU, IUN2, IWARNL, IX, JWORK, $ LDUN2, LDUNN, LDW, LMMNOB, LMMNOL, LMNOBR, $ LNOBR, LNOBRN, MAXWRK, MINWRK, MNOBR, MNOBRN, $ N2, NCOL, NN, NPL, NR, NR2, NR3, NR4, NR4MN, $ NR4PL, NROW, RANK, RANK11, RANKM CHARACTER FACT, JOBP, JOBPY LOGICAL FULLR, MOESP, N4SID, SHIFT, WITHAL, WITHB, $ WITHC, WITHCO, WITHD C .. Local Array .. DOUBLE PRECISION SVAL(3) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLASET, DORMQR, $ DSYRK, DTRCON, DTRSM, DTRTRS, IB01PX, IB01PY, $ MA02AD, MA02ED, MB02QY, MB02UD, MB03OD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C .. Executable Statements .. C C Decode the scalar input parameters. C MOESP = LSAME( METH, 'M' ) N4SID = LSAME( METH, 'N' ) WITHAL = LSAME( JOB, 'A' ) WITHC = LSAME( JOB, 'C' ) .OR. WITHAL WITHD = LSAME( JOB, 'D' ) .OR. WITHAL WITHB = LSAME( JOB, 'B' ) .OR. WITHD WITHCO = LSAME( JOBCV, 'C' ) MNOBR = M*NOBR LNOBR = L*NOBR LMNOBR = LNOBR + MNOBR LMMNOB = LNOBR + 2*MNOBR MNOBRN = MNOBR + N LNOBRN = LNOBR - N LDUN2 = LNOBR - L LDUNN = LDUN2*N LMMNOL = LMMNOB + L NR = LMNOBR + LMNOBR NPL = N + L N2 = N + N NN = N*N MINWRK = 1 IWARN = 0 INFO = 0 C C Check the scalar input parameters. C IF( .NOT.( MOESP .OR. N4SID ) ) THEN INFO = -1 ELSE IF( .NOT.( WITHB .OR. WITHC ) ) THEN INFO = -2 ELSE IF( .NOT.( WITHCO .OR. LSAME( JOBCV, 'N' ) ) ) THEN INFO = -3 ELSE IF( NOBR.LE.1 ) THEN INFO = -4 ELSE IF( N.LE.0 .OR. N.GE.NOBR ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( L.LE.0 ) THEN INFO = -7 ELSE IF( WITHCO .AND. NSMPL.LT.NR ) THEN INFO = -8 ELSE IF( LDR.LT.NR ) THEN INFO = -10 ELSE IF( LDA.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. N4SID ) ) $ .AND. LDA.LT.N ) ) THEN INFO = -12 ELSE IF( LDC.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. N4SID ) ) $ .AND. LDC.LT.L ) ) THEN INFO = -14 ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.N .AND. M.GT.0 ) ) $ THEN INFO = -16 ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) $ THEN INFO = -18 ELSE IF( LDQ.LT.1 .OR. ( WITHCO .AND. LDQ.LT.N ) ) THEN INFO = -20 ELSE IF( LDRY.LT.1 .OR. ( WITHCO .AND. LDRY.LT.L ) ) THEN INFO = -22 ELSE IF( LDS.LT.1 .OR. ( WITHCO .AND. LDS.LT.N ) ) THEN INFO = -24 ELSE IF( LDO.LT.1 .OR. ( ( WITHCO .OR. N4SID ) .AND. $ LDO.LT.LNOBR ) ) THEN INFO = -26 ELSE C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 IAW = 0 MINWRK = LDUNN + 4*N MAXWRK = LDUNN + N + N*ILAENV( 1, 'DGEQRF', ' ', LDUN2, N, -1, $ -1 ) IF( MOESP ) THEN ID = 0 IF( WITHC ) THEN MINWRK = MAX( MINWRK, 2*LDUNN + N2, LDUNN + NN + 7*N ) MAXWRK = MAX( MAXWRK, 2*LDUNN + N + N*ILAENV( 1, $ 'DORMQR', 'LT', LDUN2, N, N, -1 ) ) END IF ELSE ID = N END IF C IF( ( M.GT.0 .AND. WITHB ) .OR. N4SID ) THEN MINWRK = MAX( MINWRK, 2*LDUNN + NN + ID + 7*N ) IF ( MOESP ) $ MINWRK = MAX( MINWRK, LDUNN + N + 6*MNOBR, LDUNN + N + $ MAX( L + MNOBR, LNOBR + $ MAX( 3*LNOBR + 1, M ) ) ) ELSE IF( MOESP ) $ IAW = N + NN END IF C IF( N4SID .OR. WITHCO ) THEN MINWRK = MAX( MINWRK, LDUNN + IAW + N2 + MAX( 5*N, LMMNOL ), $ ID + 4*MNOBRN+1, ID + MNOBRN + NPL ) MAXWRK = MAX( MAXWRK, LDUNN + IAW + N2 + $ MAX( N*ILAENV( 1, 'DGEQRF', ' ', LNOBR, N, -1, $ -1 ), LMMNOB* $ ILAENV( 1, 'DORMQR', 'LT', LNOBR, $ LMMNOB, N, -1 ), LMMNOL* $ ILAENV( 1, 'DORMQR', 'LT', LDUN2, $ LMMNOL, N, -1 ) ), $ ID + N + N*ILAENV( 1, 'DGEQRF', ' ', LMNOBR, $ N, -1, -1 ), $ ID + N + NPL*ILAENV( 1, 'DORMQR', 'LT', $ LMNOBR, NPL, N, -1 ) ) IF( N4SID .AND. ( M.GT.0 .AND. WITHB ) ) $ MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) + $ MAX( NPL**2, 4*M*NPL + 1 ) ) END IF MAXWRK = MAX( MINWRK, MAXWRK ) C IF ( LDWORK.LT.MINWRK ) THEN INFO = -30 DWORK( 1 ) = MINWRK END IF END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB01PD', -INFO ) RETURN END IF C NR2 = MNOBR + 1 NR3 = LMNOBR + 1 NR4 = LMMNOB + 1 C C Set the precision parameters. A threshold value EPS**(2/3) is C used for deciding to use pivoting or not, where EPS is the C relative machine precision (see LAPACK Library routine DLAMCH). C EPS = DLAMCH( 'Precision' ) THRESH = EPS**( TWO/THREE ) SVLMAX = ZERO RCOND4 = ONE C C Let Un be the matrix of left singular vectors (stored in R_22). C Copy un1 = GaL = Un(1:(s-1)*L,1:n) in the workspace. C IGAL = 1 CALL DLACPY( 'Full', LDUN2, N, R(NR2,NR2), LDR, DWORK(IGAL), $ LDUN2 ) C C Factor un1 = Q1*[r1' 0]' (' means transposition). C Workspace: need L*(NOBR-1)*N+2*N, C prefer L*(NOBR-1)*N+N+N*NB. C ITAU1 = IGAL + LDUNN JWORK = ITAU1 + N LDW = JWORK CALL DGEQRF( LDUN2, N, DWORK(IGAL), LDUN2, DWORK(ITAU1), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C C Compute the reciprocal of the condition number of r1. C Workspace: need L*(NOBR-1)*N+4*N. C CALL DTRCON( '1-norm', 'Upper', 'NonUnit', N, DWORK(IGAL), LDUN2, $ RCOND1, DWORK(JWORK), IWORK, INFO ) C TOLL1 = TOL IF( TOLL1.LE.ZERO ) $ TOLL1 = NN*EPS C IF ( ( M.GT.0 .AND. WITHB ) .OR. N4SID ) THEN JOBP = 'P' IF ( WITHAL ) THEN JOBPY = 'D' ELSE JOBPY = JOB END IF ELSE JOBP = 'N' END IF C IF ( MOESP ) THEN NCOL = 0 IUN2 = JWORK IF ( WITHC ) THEN C C Set C = Un(1:L,1:n) and then compute the system matrix A. C C Set un2 = Un(L+1:L*s,1:n) in DWORK(IUN2). C Workspace: need 2*L*(NOBR-1)*N+N. C CALL DLACPY( 'Full', L, N, R(NR2,NR2), LDR, C, LDC ) CALL DLACPY( 'Full', LDUN2, N, R(NR2+L,NR2), LDR, $ DWORK(IUN2), LDUN2 ) C C Note that un1 has already been factored as C un1 = Q1*[r1' 0]' and usually (generically, assuming C observability) has full column rank. C Update un2 <-- Q1'*un2 in DWORK(IUN2) and save its C first n rows in A. C Workspace: need 2*L*(NOBR-1)*N+2*N; C prefer 2*L*(NOBR-1)*N+N+N*NB. C JWORK = IUN2 + LDUNN CALL DORMQR( 'Left', 'Transpose', LDUN2, N, N, DWORK(IGAL), $ LDUN2, DWORK(ITAU1), DWORK(IUN2), LDUN2, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) CALL DLACPY( 'Full', N, N, DWORK(IUN2), LDUN2, A, LDA ) NCOL = N JWORK = IUN2 END IF C IF ( RCOND1.GT.MAX( TOLL1, THRESH ) ) THEN C C The triangular factor r1 is considered to be of full rank. C Solve for A (if requested), r1*A = un2(1:n,:) in A. C IF ( WITHC ) THEN CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, N, $ DWORK(IGAL), LDUN2, A, LDA, IERR ) IF ( IERR.GT.0 ) THEN INFO = 3 RETURN END IF END IF RANK = N ELSE C C Rank-deficient triangular factor r1. Use SVD of r1, C r1 = U*S*V', also for computing A (if requested) from C r1*A = un2(1:n,:). Matrix U is computed in DWORK(IU), C and V' overwrites r1. If B is requested, the C pseudoinverse of r1 and then of GaL are also computed C in R(NR3,NR2). C Workspace: need c*L*(NOBR-1)*N+N*N+7*N, C where c = 1 if B and D are not needed, C c = 2 if B and D are needed; C prefer larger. C IU = IUN2 ISV = IU + NN JWORK = ISV + N IF ( M.GT.0 .AND. WITHB ) THEN C C Save the elementary reflectors used for computing r1, C if B, D are needed. C Workspace: need 2*L*(NOBR-1)*N+2*N+N*N. C IHOUS = JWORK JWORK = IHOUS + LDUNN CALL DLACPY( 'Lower', LDUN2, N, DWORK(IGAL), LDUN2, $ DWORK(IHOUS), LDUN2 ) ELSE IHOUS = IGAL END IF C CALL MB02UD( 'Not factored', 'Left', 'NoTranspose', JOBP, N, $ NCOL, ONE, TOLL1, RANK, DWORK(IGAL), LDUN2, $ DWORK(IU), N, DWORK(ISV), A, LDA, R(NR3,NR2), $ LDR, DWORK(JWORK), LDWORK-JWORK+1, IERR ) IF ( IERR.NE.0 ) THEN INFO = 2 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C IF ( RANK.EQ.0 ) THEN JOBP = 'N' ELSE IF ( M.GT.0 .AND. WITHB ) THEN C C Compute pinv(GaL) in R(NR3,NR2) if B, D are needed. C Workspace: need 2*L*(NOBR-1)*N+N*N+3*N; C prefer 2*L*(NOBR-1)*N+N*N+2*N+N*NB. C CALL DLASET( 'Full', N, LDUN2-N, ZERO, ZERO, $ R(NR3,NR2+N), LDR ) CALL DORMQR( 'Right', 'Transpose', N, LDUN2, N, $ DWORK(IHOUS), LDUN2, DWORK(ITAU1), $ R(NR3,NR2), LDR, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) IF ( WITHCO ) THEN C C Save pinv(GaL) in DWORK(IGAL). C CALL DLACPY( 'Full', N, LDUN2, R(NR3,NR2), LDR, $ DWORK(IGAL), N ) END IF JWORK = IUN2 END IF LDW = JWORK END IF C IF ( M.GT.0 .AND. WITHB ) THEN C C Computation of B and D. C C Compute the reciprocal of the condition number of R_1c. C Workspace: need L*(NOBR-1)*N+N+3*M*NOBR. C CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBR, R(NR3,1), $ LDR, RCOND2, DWORK(JWORK), IWORK, IERR ) C TOLL = TOL IF( TOLL.LE.ZERO ) $ TOLL = MNOBR*MNOBR*EPS C C Compute the right hand side and solve for K (in R_23), C K*R_1c' = u2'*R_2c', C where u2 = Un(:,n+1:L*s), and K is (Ls-n) x ms. C CALL DGEMM( 'Transpose', 'Transpose', LNOBRN, MNOBR, LNOBR, $ ONE, R(NR2,NR2+N), LDR, R(1,NR2), LDR, ZERO, $ R(NR2,NR3), LDR ) C IF ( RCOND2.GT.MAX( TOLL, THRESH ) ) THEN C C The triangular factor R_1c is considered to be of full C rank. Solve for K, K*R_1c' = u2'*R_2c'. C CALL DTRSM( 'Right', 'Upper', 'Transpose', 'Non-unit', $ LNOBRN, MNOBR, ONE, R(NR3,1), LDR, $ R(NR2,NR3), LDR ) ELSE C C Rank-deficient triangular factor R_1c. Use SVD of R_1c C for computing K from K*R_1c' = u2'*R_2c', where C R_1c = U1*S1*V1'. Matrix U1 is computed in R_33, C and V1' overwrites R_1c. C Workspace: need L*(NOBR-1)*N+N+6*M*NOBR; C prefer larger. C ISV = LDW JWORK = ISV + MNOBR CALL MB02UD( 'Not factored', 'Right', 'Transpose', $ 'No pinv', LNOBRN, MNOBR, ONE, TOLL, RANK11, $ R(NR3,1), LDR, R(NR3,NR3), LDR, DWORK(ISV), $ R(NR2,NR3), LDR, DWORK(JWORK), 1, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) IF ( IERR.NE.0 ) THEN INFO = 2 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) JWORK = LDW END IF C C Compute the triangular factor of the structured matrix Q C and apply the transformations to the matrix Kexpand, where C Q and Kexpand are defined in SLICOT Library routine C IB01PY. Compute also the matrices B, D. C Workspace: need L*(NOBR-1)*N+N+max(L+M*NOBR,L*NOBR+ C max(3*L*NOBR+1,M)); C prefer larger. C IF ( WITHCO ) $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, O, LDO ) CALL IB01PY( METH, JOBPY, NOBR, N, M, L, RANK, R(NR2,NR2), $ LDR, DWORK(IGAL), LDUN2, DWORK(ITAU1), $ R(NR3,NR2), LDR, R(NR2,NR3), LDR, R(NR4,NR2), $ LDR, R(NR4,NR3), LDR, B, LDB, D, LDD, TOL, $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARN, $ INFO ) IF ( INFO.NE.0 ) $ RETURN MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) RCOND4 = DWORK(JWORK+1) IF ( WITHCO ) $ CALL DLACPY( 'Full', LNOBR, N, O, LDO, R(NR2,1), LDR ) C ELSE RCOND2 = ONE END IF C IF ( .NOT.WITHCO ) THEN RCOND3 = ONE GO TO 30 END IF ELSE C C For N4SID, set RCOND2 to one. C RCOND2 = ONE END IF C C If needed, save the first n columns, representing Gam, of the C matrix of left singular vectors, Un, in R_21 and in O. C IF ( N4SID .OR. ( WITHC .AND. .NOT.WITHAL ) ) THEN IF ( M.GT.0 ) $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, R(NR2,1), $ LDR ) CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, O, LDO ) END IF C C Computations for covariance matrices, and system matrices (N4SID). C Solve the least squares problems Gam*Y = R4(1:L*s,1:(2*m+L)*s), C GaL*X = R4(L+1:L*s,:), where C GaL = Gam(1:L*(s-1),:), Gam has full column rank, and C R4 = [ R_14' R_24' R_34' R_44L' ], R_44L = R_44(1:L,:), as C returned by SLICOT Library routine IB01ND. C First, find the QR factorization of Gam, Gam = Q*R. C Workspace: need L*(NOBR-1)*N+Aw+3*N; C prefer L*(NOBR-1)*N+Aw+2*N+N*NB, where C Aw = N+N*N, if (M = 0 or JOB = 'C'), rank(r1) < N, C and METH = 'M'; C Aw = 0, otherwise. C ITAU2 = LDW JWORK = ITAU2 + N CALL DGEQRF( LNOBR, N, R(NR2,1), LDR, DWORK(ITAU2), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C C For METH = 'M' or when JOB = 'B' or 'D', transpose C [ R_14' R_24' R_34' ]' in the last block-row of R, obtaining Z, C and for METH = 'N' and JOB = 'A' or 'C', use the matrix Z C already available in the last block-row of R, and then apply C the transformations, Z <-- Q'*Z. C Workspace: need L*(NOBR-1)*N+Aw+2*N+(2*M+L)*NOBR; C prefer L*(NOBR-1)*N+Aw+2*N+(2*M+L)*NOBR*NB. C IF ( MOESP .OR. ( WITHB .AND. .NOT. WITHAL ) ) $ CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), $ LDR ) CALL DORMQR( 'Left', 'Transpose', LNOBR, LMMNOB, N, R(NR2,1), LDR, $ DWORK(ITAU2), R(NR4,1), LDR, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) C C Solve for Y, RY = Z in Z and save the transpose of the C solution Y in the second block-column of R. C CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, LMMNOB, $ R(NR2,1), LDR, R(NR4,1), LDR, IERR ) IF ( IERR.GT.0 ) THEN INFO = 3 RETURN END IF CALL MA02AD( 'Full', N, LMMNOB, R(NR4,1), LDR, R(1,NR2), LDR ) NR4MN = NR4 - N NR4PL = NR4 + L NROW = LMMNOL C C SHIFT is .TRUE. if some columns of R_14 : R_44L should be C shifted to the right, to avoid overwriting useful information. C SHIFT = M.EQ.0 .AND. LNOBR.LT.N2 C IF ( RCOND1.GT.MAX( TOLL1, THRESH ) ) THEN C C The triangular factor r1 of GaL (GaL = Q1*r1) is C considered to be of full rank. C C Transpose [ R_14' R_24' R_34' R_44L' ]'(:,L+1:L*s) in the C last block-row of R (beginning with the (L+1)-th row), C obtaining Z1, and then apply the transformations, C Z1 <-- Q1'*Z1. C Workspace: need L*(NOBR-1)*N+Aw+2*N+ (2*M+L)*NOBR + L; C prefer L*(NOBR-1)*N+Aw+2*N+((2*M+L)*NOBR + L)*NB. C CALL MA02AD( 'Full', LMMNOL, LDUN2, R(1,NR4PL), LDR, $ R(NR4PL,1), LDR ) CALL DORMQR( 'Left', 'Transpose', LDUN2, LMMNOL, N, $ DWORK(IGAL), LDUN2, DWORK(ITAU1), R(NR4PL,1), LDR, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C C Solve for X, r1*X = Z1 in Z1, and copy the transpose of X C into the last part of the third block-column of R. C CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, LMMNOL, $ DWORK(IGAL), LDUN2, R(NR4PL,1), LDR, IERR ) IF ( IERR.GT.0 ) THEN INFO = 3 RETURN END IF C IF ( SHIFT ) THEN NR4MN = NR4 C DO 10 I = L - 1, 0, -1 CALL DCOPY( LMMNOL, R(1,NR4+I), 1, R(1,NR4+N+I), 1 ) 10 CONTINUE C END IF CALL MA02AD( 'Full', N, LMMNOL, R(NR4PL,1), LDR, R(1,NR4MN), $ LDR ) NROW = 0 END IF C IF ( N4SID .OR. NROW.GT.0 ) THEN C C METH = 'N' or rank-deficient triangular factor r1. C For METH = 'N', use SVD of r1, r1 = U*S*V', for computing C X' from X'*GaL' = Z1', if rank(r1) < N. Matrix U is C computed in DWORK(IU) and V' overwrites r1. Then, the C pseudoinverse of GaL is determined in R(NR4+L,NR2). C For METH = 'M', the pseudoinverse of GaL is already available C if M > 0 and B is requested; otherwise, the SVD of r1 is C available in DWORK(IU), DWORK(ISV), and DWORK(IGAL). C Workspace for N4SID: need 2*L*(NOBR-1)*N+N*N+8*N; C prefer larger. C IF ( MOESP ) THEN FACT = 'F' IF ( M.GT.0 .AND. WITHB ) $ CALL DLACPY( 'Full', N, LDUN2, DWORK(IGAL), N, $ R(NR4PL,NR2), LDR ) ELSE C C Save the elementary reflectors used for computing r1. C IHOUS = JWORK CALL DLACPY( 'Lower', LDUN2, N, DWORK(IGAL), LDUN2, $ DWORK(IHOUS), LDUN2 ) FACT = 'N' IU = IHOUS + LDUNN ISV = IU + NN JWORK = ISV + N END IF C CALL MB02UD( FACT, 'Right', 'Transpose', JOBP, NROW, N, ONE, $ TOLL1, RANK, DWORK(IGAL), LDUN2, DWORK(IU), N, $ DWORK(ISV), R(1,NR4PL), LDR, R(NR4PL,NR2), LDR, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) IF ( NROW.GT.0 ) THEN IF ( SHIFT ) THEN NR4MN = NR4 CALL DLACPY( 'Full', LMMNOL, L, R(1,NR4), LDR, $ R(1,NR4-L), LDR ) CALL DLACPY( 'Full', LMMNOL, N, R(1,NR4PL), LDR, $ R(1,NR4MN), LDR ) CALL DLACPY( 'Full', LMMNOL, L, R(1,NR4-L), LDR, $ R(1,NR4+N), LDR ) ELSE CALL DLACPY( 'Full', LMMNOL, N, R(1,NR4PL), LDR, $ R(1,NR4MN), LDR ) END IF END IF C IF ( N4SID ) THEN IF ( IERR.NE.0 ) THEN INFO = 2 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Compute pinv(GaL) in R(NR4+L,NR2). C Workspace: need 2*L*(NOBR-1)*N+3*N; C prefer 2*L*(NOBR-1)*N+2*N+N*NB. C JWORK = IU CALL DLASET( 'Full', N, LDUN2-N, ZERO, ZERO, R(NR4PL,NR2+N), $ LDR ) CALL DORMQR( 'Right', 'Transpose', N, LDUN2, N, $ DWORK(IHOUS), LDUN2, DWORK(ITAU1), $ R(NR4PL,NR2), LDR, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) END IF END IF C C For METH = 'N', find part of the solution (corresponding to A C and C) and, optionally, for both METH = 'M', or METH = 'N', C find the residual of the least squares problem that gives the C covariances, M*V = N, where C ( R_11 ) C M = ( Y' ), N = ( X' R4'(:,1:L) ), V = V(n+m*s, n+L), C ( 0 0 ) C with M((2*m+L)*s+L, n+m*s), N((2*m+L)*s+L, n+L), R4' being C stored in the last block-column of R. The last L rows of M C are not explicitly considered. Note that, for efficiency, the C last m*s columns of M are in the first positions of arrray R. C This permutation does not affect the residual, only the C solution. (The solution is not needed for METH = 'M'.) C Note that R_11 corresponds to the future outputs for both C METH = 'M', or METH = 'N' approaches. (For METH = 'N', the C first two block-columns have been interchanged.) C For METH = 'N', A and C are obtained as follows: C [ A' C' ] = V(m*s+1:m*s+n,:). C C First, find the QR factorization of Y'(m*s+1:(2*m+L)*s,:) C and apply the transformations to the corresponding part of N. C Compress the workspace for N4SID by moving the scalar reflectors C corresponding to Q. C Workspace: need d*N+2*N; C prefer d*N+N+N*NB; C where d = 0, for MOESP, and d = 1, for N4SID. C IF ( MOESP ) THEN ITAU = 1 ELSE CALL DCOPY( N, DWORK(ITAU2), 1, DWORK, 1 ) ITAU = N + 1 END IF C JWORK = ITAU + N CALL DGEQRF( LMNOBR, N, R(NR2,NR2), LDR, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C C Workspace: need d*N+N+(N+L); C prefer d*N+N+(N+L)*NB. C CALL DORMQR( 'Left', 'Transpose', LMNOBR, NPL, N, R(NR2,NR2), LDR, $ DWORK(ITAU), R(NR2,NR4MN), LDR, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) C CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, R(NR4+1,NR4), LDR ) C C Now, matrix M with permuted block-columns has been C triangularized. C Compute the reciprocal of the condition number of its C triangular factor in R(1:m*s+n,1:m*s+n). C Workspace: need d*N+3*(M*NOBR+N). C JWORK = ITAU CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBRN, R, LDR, RCOND3, $ DWORK(JWORK), IWORK, INFO ) C TOLL = TOL IF( TOLL.LE.ZERO ) $ TOLL = MNOBRN*MNOBRN*EPS IF ( RCOND3.GT.MAX( TOLL, THRESH ) ) THEN C C The triangular factor is considered to be of full rank. C Solve for V(m*s+1:m*s+n,:), giving [ A' C' ]. C FULLR = .TRUE. RANKM = MNOBRN IF ( N4SID ) $ CALL DTRSM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, $ NPL, ONE, R(NR2,NR2), LDR, R(NR2,NR4MN), LDR ) ELSE FULLR = .FALSE. C C Use QR factorization (with pivoting). For METH = 'N', save C (and then restore) information about the QR factorization of C Gam, for later use. Note that R_11 could be modified by C MB03OD, but the corresponding part of N is also modified C accordingly. C Workspace: need d*N+4*(M*NOBR+N)+1; C prefer d*N+3*(M*NOBR+N)+(M*NOBR+N+1)*NB. C DO 20 I = 1, MNOBRN IWORK(I) = 0 20 CONTINUE C IF ( N4SID .AND. ( M.GT.0 .AND. WITHB ) ) $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,1), LDR, R(NR4,1), $ LDR ) JWORK = ITAU + MNOBRN CALL DLASET( 'Lower', MNOBRN-1, MNOBRN, ZERO, ZERO, R(2,1), $ LDR ) CALL MB03OD( 'QR', MNOBRN, MNOBRN, R, LDR, IWORK, TOLL, $ SVLMAX, DWORK(ITAU), RANKM, SVAL, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Workspace: need d*N+M*NOBR+N+N+L; C prefer d*N+M*NOBR+N+(N+L)*NB. C CALL DORMQR( 'Left', 'Transpose', MNOBRN, NPL, MNOBRN, $ R, LDR, DWORK(ITAU), R(1,NR4MN), LDR, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) END IF C IF ( WITHCO ) THEN C C The residual (transposed) of the least squares solution C (multiplied by a matrix with orthogonal columns) is stored C in the rows RANKM+1:(2*m+L)*s+L of V, and it should be C squared-up for getting the covariance matrices. (Generically, C RANKM = m*s+n.) C RNRM = ONE/DBLE( NSMPL ) IF ( MOESP ) THEN CALL DSYRK( 'Upper', 'Transpose', NPL, LMMNOL-RANKM, RNRM, $ R(RANKM+1,NR4MN), LDR, ZERO, R, LDR ) CALL DLACPY( 'Upper', N, N, R, LDR, Q, LDQ ) CALL DLACPY( 'Full', N, L, R(1,N+1), LDR, S, LDS ) CALL DLACPY( 'Upper', L, L, R(N+1,N+1), LDR, RY, LDRY ) ELSE CALL DSYRK( 'Upper', 'Transpose', NPL, LMMNOL-RANKM, RNRM, $ R(RANKM+1,NR4MN), LDR, ZERO, DWORK(JWORK), NPL ) CALL DLACPY( 'Upper', N, N, DWORK(JWORK), NPL, Q, LDQ ) CALL DLACPY( 'Full', N, L, DWORK(JWORK+N*NPL), NPL, S, $ LDS ) CALL DLACPY( 'Upper', L, L, DWORK(JWORK+N*(NPL+1)), NPL, RY, $ LDRY ) END IF CALL MA02ED( 'Upper', N, Q, LDQ ) CALL MA02ED( 'Upper', L, RY, LDRY ) C C Check the magnitude of the residual. C RNRM = DLANGE( '1-norm', LMMNOL-RANKM, NPL, R(RANKM+1,NR4MN), $ LDR, DWORK(JWORK) ) IF ( RNRM.LT.THRESH ) $ IWARN = 5 END IF C IF ( N4SID ) THEN IF ( .NOT.FULLR ) THEN IWARN = 4 C C Compute part of the solution of the least squares problem, C M*V = N, for the rank-deficient problem. C Remark: this computation should not be performed before the C symmetric updating operation above. C Workspace: need M*NOBR+3*N+L; C prefer larger. C CALL MB03OD( 'No QR', N, N, R(NR2,NR2), LDR, IWORK, TOLL1, $ SVLMAX, DWORK(ITAU), RANKM, SVAL, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) CALL MB02QY( N, N, NPL, RANKM, R(NR2,NR2), LDR, IWORK, $ R(NR2,NR4MN), LDR, DWORK(ITAU+MNOBR), $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) JWORK = ITAU IF ( M.GT.0 .AND. WITHB ) $ CALL DLACPY( 'Full', LNOBR, N, R(NR4,1), LDR, R(NR2,1), $ LDR ) END IF C IF ( WITHC ) THEN C C Obtain A and C, noting that block-permutations have been C implicitly used. C CALL MA02AD( 'Full', N, N, R(NR2,NR4MN), LDR, A, LDA ) CALL MA02AD( 'Full', N, L, R(NR2,NR4MN+N), LDR, C, LDC ) ELSE C C Use the given A and C. C CALL MA02AD( 'Full', N, N, A, LDA, R(NR2,NR4MN), LDR ) CALL MA02AD( 'Full', L, N, C, LDC, R(NR2,NR4MN+N), LDR ) END IF C IF ( M.GT.0 .AND. WITHB ) THEN C C Obtain B and D. C First, compute the transpose of the matrix K as C N(1:m*s,:) - M(1:m*s,m*s+1:m*s+n)*[A' C'], in the first C m*s rows of R(1,NR4MN). C CALL DGEMM ( 'NoTranspose', 'NoTranspose', MNOBR, NPL, N, $ -ONE, R(1,NR2), LDR, R(NR2,NR4MN), LDR, ONE, $ R(1,NR4MN), LDR ) C C Denote M = pinv(GaL) and construct C C [ [ A ] -1 ] [ R ] C and L = [ [ ] R 0 ] Q', where Gam = Q * [ ]. C [ [ C ] ] [ 0 ] C C Then, solve the least squares problem. C CALL DLACPY( 'Full', N, N, A, LDA, R(NR2,NR4), LDR ) CALL DLACPY( 'Full', L, N, C, LDC, R(NR2+N,NR4), LDR ) CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', $ NPL, N, ONE, R(NR2,1), LDR, R(NR2,NR4), LDR ) CALL DLASET( 'Full', NPL, LNOBRN, ZERO, ZERO, R(NR2,NR4+N), $ LDR ) C C Workspace: need 2*N+L; prefer N + (N+L)*NB. C CALL DORMQR( 'Right', 'Transpose', NPL, LNOBR, N, R(NR2,1), $ LDR, DWORK, R(NR2,NR4), LDR, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) C C Obtain the matrix K by transposition, and find B and D. C Workspace: need NOBR*(M*(N+L))**2+M*NOBR*(N+L)+ C max((N+L)**2,4*M*(N+L)+1); C prefer larger. C CALL MA02AD( 'Full', MNOBR, NPL, R(1,NR4MN), LDR, $ R(NR2,NR3), LDR ) IX = MNOBR*NPL**2*M + 1 JWORK = IX + MNOBR*NPL CALL IB01PX( JOBPY, NOBR, N, M, L, R, LDR, O, LDO, $ R(NR2,NR4), LDR, R(NR4PL,NR2), LDR, R(NR2,NR3), $ LDR, DWORK, MNOBR*NPL, DWORK(IX), B, LDB, D, $ LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, $ IWARNL, INFO ) IF ( INFO.NE.0 ) $ RETURN IWARN = MAX( IWARN, IWARNL ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) RCOND4 = DWORK(JWORK+1) C END IF END IF C 30 CONTINUE C C Return optimal workspace in DWORK(1) and reciprocal condition C numbers in the next locations. C DWORK(1) = MAXWRK DWORK(2) = RCOND1 DWORK(3) = RCOND2 DWORK(4) = RCOND3 DWORK(5) = RCOND4 RETURN C C *** Last line of IB01PD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB08NZ.f0000644000000000000000000000013215012430707016177 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB08NZ.f0000644000175000017500000004470015012430707017400 0ustar00lilgelilge00000000000000 SUBROUTINE AB08NZ( 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, $ ZWORK, LZWORK, INFO ) 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 array, dimension (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) COMPLEX*16 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 (MAX(N,2*MAX(P,M))) C C ZWORK DOUBLE PRECISION array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal value C of LZWORK. C C LZWORK INTEGER C The length of the array ZWORK. C LZWORK >= 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 LZWORK should be larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK 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 ZGGEV with A = A , B = B and N = NU. C f f C If RANK = 0, the routine ZGEEV can be used (since B = I). C f C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, C Apr. 2009, Apr. 2011. C C KEYWORDS C C Generalized eigenvalue problem, Kronecker indices, multivariable C system, unitary transformation, structural invariant. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) DOUBLE PRECISION DZERO PARAMETER ( DZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL INTEGER DINFZ, INFO, LDA, LDAF, LDB, LDBF, LDC, LDD, $ LZWORK, M, N, NKROL, NKROR, NU, P, RANK DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER INFZ(*), IWORK(*), KRONL(*), KRONR(*) COMPLEX*16 A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), $ C(LDC,*), D(LDD,*), ZWORK(*) DOUBLE PRECISION DWORK(*) C .. Local Scalars .. LOGICAL LEQUIL, LQUERY INTEGER I, I1, II, J, MM, MNU, MU, NINFZ, NN, NU1, NUMU, $ NUMU1, PP, RO, SIGMA, WRKOPT DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL DLAMCH, LSAME, ZLANGE C .. External Subroutines .. EXTERNAL AB8NXZ, TB01IZ, XERBLA, ZCOPY, ZLACPY, ZLASET, $ ZTZRZF, ZUNMRZ C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 LEQUIL = LSAME( EQUIL, 'S' ) LQUERY = ( LZWORK.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 = DZERO NINFZ = 0 CALL AB8NXZ( N, M, P, P, 0, SVLMAX, BF, LDBF, NINFZ, INFZ, $ KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, $ ZWORK, -1, INFO ) WRKOPT = MAX( I, INT( ZWORK(1) ) ) CALL AB8NXZ( N, II, M, M-II, II, SVLMAX, AF, LDAF, NINFZ, $ INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, $ ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) CALL ZTZRZF( II, N+II, AF, LDAF, ZWORK, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, II + INT( ZWORK(1) ) ) CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N+II, II, N, $ AF, LDAF, ZWORK, AF, LDAF, ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, II + INT( ZWORK(1) ) ) ELSE IF( LZWORK.LT.I ) THEN INFO = -29 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB08NZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN ZWORK(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 ZWORK(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 "CWorkspace:" and C "RWorkspace:" describe the minimal amount of complex and real C workspace, respectively, needed at that point in the code, as C 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 ZLACPY( 'Full', NN, MM, B, LDB, BF, LDBF ) IF ( PP.GT.0 ) $ CALL ZLACPY( 'Full', PP, MM, D, LDD, BF(1+NN,1), LDBF ) IF ( NN.GT.0 ) THEN CALL ZLACPY( 'Full', NN, NN, A, LDA, BF(1,1+MM), LDBF ) IF ( PP.GT.0 ) $ CALL ZLACPY( 'Full', PP, NN, C, LDC, BF(1+NN,1+MM), LDBF ) END IF C C If required, balance the compound matrix (default MAXRED). C RWorkspace: need N. C IF ( LEQUIL .AND. NN.GT.0 .AND. PP.GT.0 ) THEN MAXRED = DZERO CALL TB01IZ( 'A', NN, MM, PP, MAXRED, BF(1,1+MM), LDBF, BF, $ LDBF, BF(1+NN,1+MM), LDBF, DWORK, INFO ) 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 = ZLANGE( '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 RWorkspace: need 2*MAX(M,P); C CWorkspace: 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 AB8NXZ( NN, MM, PP, RO, SIGMA, SVLMAX, BF, LDBF, NINFZ, INFZ, $ KRONL, MU, NU, NKROL, TOLER, IWORK, DWORK, ZWORK, $ LZWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(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 ZCOPY( 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 RWorkspace: need 2*M. C CWorkspace: 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(M,P). C RO = PP - MM SIGMA = MM CALL AB8NXZ( NN, MM, PP, RO, SIGMA, SVLMAX, AF, LDAF, NINFZ, $ INFZ, KRONR, MU, NU, NKROR, TOLER, IWORK, $ DWORK, ZWORK, LZWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(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 ZLASET( 'Full', NU, MU, ZERO, ZERO, BF, LDBF ) CALL ZLASET( 'Full', NU, NU, ZERO, ONE, BF(1,MU+1), LDBF ) C IF ( RANK.NE.0 ) THEN NU1 = NU + 1 I1 = NU + MU C C CWorkspace: need 2*MIN(M,P); C prefer MIN(M,P) + MIN(M,P)*NB. C CALL ZTZRZF( MU, I1, AF(NU1,1), LDAF, ZWORK, ZWORK(MU+1), $ LZWORK-MU, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(MU+1) ) + MU ) C C CWorkspace: need MIN(M,P) + N; C prefer MIN(M,P) + N*NB. C CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, I1, MU, $ NU, AF(NU1,1), LDAF, ZWORK, AF, LDAF, $ ZWORK(MU+1), LZWORK-MU, INFO ) WRKOPT = MAX( WRKOPT, INT( ZWORK(MU+1) ) + MU ) C CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, I1, MU, $ NU, AF(NU1,1), LDAF, ZWORK, BF, LDBF, $ ZWORK(MU+1), LZWORK-MU, INFO ) C END IF C C Move AF and BF in the first columns. This assumes that C ZLACPY moves column by column. C CALL ZLACPY( 'Full', NU, NU, AF(1,MU+1), LDAF, AF, LDAF ) IF ( RANK.NE.0 ) $ CALL ZLACPY( '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 ZWORK(1) = WRKOPT RETURN C *** Last line of AB08NZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03DZ.f0000644000000000000000000000013215012430707016174 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03DZ.f0000644000175000017500000000643215012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE MB03DZ( A, LDA, B, LDB, CO1, SI1, CO2, SI2 ) C C PURPOSE C C To compute unitary matrices Q1 and Q2 for a complex 2-by-2 regular C pencil aA - bB with A, B upper triangular, such that C Q2' (aA - bB) Q1 is still upper triangular but the eigenvalues are C in reversed order. The matrices Q1 and Q2 are represented by C C ( CO1 SI1 ) ( CO2 SI2 ) C Q1 = ( ), Q2 = ( ). C ( -SI1' CO1 ) ( -SI2' CO2 ) C C The notation M' denotes the conjugate transpose of the matrix M. C C ARGUMENTS C C Input/Output Parameters C C A (input) COMPLEX*16 array, dimension (LDA, 2) C On entry, the leading 2-by-2 upper triangular part of C this array must contain the matrix A of the pencil. C The (2,1) entry is not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= 2. C C B (input) COMPLEX*16 array, dimension (LDB, 2) C On entry, the leading 2-by-2 upper triangular part of C this array must contain the matrix B of the pencil. C The (2,1) entry is not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= 2. C C CO1 (output) DOUBLE PRECISION C The upper left element of the unitary matrix Q1. C C SI1 (output) COMPLEX*16 C The upper right element of the unitary matrix Q1. C C CO2 (output) DOUBLE PRECISION C The upper left element of the unitary matrix Q2. C C SI2 (output) COMPLEX*16 C The upper right element of the unitary matrix Q2. C C METHOD C C The algorithm uses unitary transformations as described on page 42 C in [1]. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, January 26, 2009. C C REVISIONS C C V. Sima, Aug. 2009 (SLICOT version of the routine ZBTUEX). C V. Sima, Nov. 2009, Nov. 2010, Dec. 2010. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue exchange, matrix pencil, upper triangular matrix. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER LDA, LDB DOUBLE PRECISION CO1, CO2 COMPLEX*16 SI1, SI2 C C .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ) C C .. Local Scalars .. COMPLEX*16 D, G, TMP C C .. External Subroutines .. EXTERNAL ZLARTG C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C C Computations. C G = A( 1, 1 )*B( 2, 2 ) - A( 2, 2 )*B( 1, 1 ) D = A( 1, 2 )*B( 2, 2 ) - A( 2, 2 )*B( 1, 2 ) CALL ZLARTG( D, G, CO1, SI1, TMP ) D = A( 1, 2 )*B( 1, 1 ) - A( 1, 1 )*B( 1, 2 ) CALL ZLARTG( D, G, CO2, SI2, TMP ) C RETURN C *** Last line of MB03DZ *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01AD.f0000644000000000000000000000013215012430707016135 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/IB01AD.f0000644000175000017500000007265115012430707017344 0ustar00lilgelilge00000000000000 SUBROUTINE IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, $ L, NSMP, U, LDU, Y, LDY, N, R, LDR, SV, RCOND, $ TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To preprocess the input-output data for estimating the matrices C of a linear time-invariant dynamical system and to find an C estimate of the system order. The input-output data can, C optionally, be processed sequentially. C C ARGUMENTS C C Mode Parameters C C METH CHARACTER*1 C Specifies the subspace identification method to be used, C as follows: C = 'M': MOESP algorithm with past inputs and outputs; C = 'N': N4SID algorithm. C C ALG CHARACTER*1 C Specifies the algorithm for computing the triangular C factor R, as follows: C = 'C': Cholesky algorithm applied to the correlation C matrix of the input-output data; C = 'F': Fast QR algorithm; C = 'Q': QR algorithm applied to the concatenated block C Hankel matrices. C C JOBD CHARACTER*1 C Specifies whether or not the matrices B and D should later C be computed using the MOESP approach, as follows: C = 'M': the matrices B and D should later be computed C using the MOESP approach; C = 'N': the matrices B and D should not be computed using C the MOESP approach. C This parameter is not relevant for METH = 'N'. C C BATCH CHARACTER*1 C Specifies whether or not sequential data processing is to C be used, and, for sequential processing, whether or not C the current data block is the first block, an intermediate C block, or the last block, as follows: C = 'F': the first block in sequential data processing; C = 'I': an intermediate block in sequential data C processing; C = 'L': the last block in sequential data processing; C = 'O': one block only (non-sequential data processing). C NOTE that when 100 cycles of sequential data processing C are completed for BATCH = 'I', a warning is C issued, to prevent for an infinite loop. C C CONCT CHARACTER*1 C Specifies whether or not the successive data blocks in C sequential data processing belong to a single experiment, C as follows: C = 'C': the current data block is a continuation of the C previous data block and/or it will be continued C by the next data block; C = 'N': there is no connection between the current data C block and the previous and/or the next ones. C This parameter is not used if BATCH = 'O'. C C CTRL CHARACTER*1 C Specifies whether or not the user's confirmation of the C system order estimate is desired, as follows: C = 'C': user's confirmation; C = 'N': no confirmation. C If CTRL = 'C', a reverse communication routine, IB01OY, C is indirectly called (by SLICOT Library routine IB01OD), C and, after inspecting the singular values and system order C estimate, n, the user may accept n or set a new value. C IB01OY is not called if CTRL = 'N'. C C Input/Output Parameters C C NOBR (input) INTEGER C The number of block rows, s, in the input and output C block Hankel matrices to be processed. NOBR > 0. C (In the MOESP theory, NOBR should be larger than n, C the estimated dimension of state vector.) C C M (input) INTEGER C The number of system inputs. M >= 0. C When M = 0, no system inputs are processed. C C L (input) INTEGER C The number of system outputs. L > 0. C C NSMP (input) INTEGER C The number of rows of matrices U and Y (number of C samples, t). (When sequential data processing is used, C NSMP is the number of samples of the current data C block.) C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential C processing; C NSMP >= 2*NOBR, for sequential processing. C The total number of samples when calling the routine with C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. C The NSMP argument may vary from a cycle to another in C sequential data processing, but NOBR, M, and L should C be kept constant. For efficiency, it is advisable to use C NSMP as large as possible. C C U (input) DOUBLE PRECISION array, dimension (LDU,M) C The leading NSMP-by-M part of this array must contain the C t-by-m input-data sequence matrix U, C U = [u_1 u_2 ... u_m]. Column j of U contains the C NSMP values of the j-th input component for consecutive C time increments. C If M = 0, this array is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= NSMP, if M > 0; C LDU >= 1, if M = 0. C C Y (input) DOUBLE PRECISION array, dimension (LDY,L) C The leading NSMP-by-L part of this array must contain the C t-by-l output-data sequence matrix Y, C Y = [y_1 y_2 ... y_l]. Column j of Y contains the C NSMP values of the j-th output component for consecutive C time increments. C C LDY INTEGER C The leading dimension of the array Y. LDY >= NSMP. C C N (output) INTEGER C The estimated order of the system. C If CTRL = 'C', the estimated order has been reset to a C value specified by the user. C C R (output or input/output) DOUBLE PRECISION array, dimension C ( LDR,2*(M+L)*NOBR ) C On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this C array contains the current upper triangular part of the C correlation matrix in sequential data processing. C If ALG = 'F' and BATCH = 'F' or 'I', the array R is not C referenced. C On exit, if INFO = 0, ALG = 'Q', and BATCH = 'F' or 'I', C the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular C part of this array contains the current upper triangular C factor R from the QR factorization of the concatenated C block Hankel matrices. Denote R_ij, i,j = 1:4, the C ij submatrix of R, partitioned by M*NOBR, M*NOBR, C L*NOBR, and L*NOBR rows and columns. C On exit, if INFO = 0 and BATCH = 'L' or 'O', the leading C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of C this array contains the matrix S, the processed upper C triangular factor R from the QR factorization of the C concatenated block Hankel matrices, as required by other C subroutines. Specifically, let S_ij, i,j = 1:4, be the C ij submatrix of S, partitioned by M*NOBR, L*NOBR, C M*NOBR, and L*NOBR rows and columns. The submatrix C S_22 contains the matrix of left singular vectors needed C subsequently. Useful information is stored in S_11 and C in the block-column S_14 : S_44. For METH = 'M' and C JOBD = 'M', the upper triangular part of S_31 contains C the upper triangular factor in the QR factorization of the C matrix R_1c = [ R_12' R_22' R_11' ]', and S_12 C contains the corresponding leading part of the transformed C matrix R_2c = [ R_13' R_23' R_14' ]'. For METH = 'N', C the subarray S_41 : S_43 contains the transpose of the C matrix contained in S_14 : S_34. C The details of the contents of R need not be known if this C routine is followed by SLICOT Library routine IB01BD. C On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or C 'L', the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper C triangular part of this array must contain the upper C triangular matrix R computed at the previous call of this C routine in sequential data processing. The array R need C not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'. C C LDR INTEGER C The leading dimension of the array R. C LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ), C for METH = 'M' and JOBD = 'M'; C LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or C for METH = 'N'. C C SV (output) DOUBLE PRECISION array, dimension ( L*NOBR ) C The singular values used to estimate the system order. C C Tolerances C C RCOND DOUBLE PRECISION C The tolerance to be used for estimating the rank of C matrices. If the user sets RCOND > 0, the given value C of RCOND is used as a lower bound for the reciprocal C condition number; an m-by-n matrix whose estimated C condition number is less than 1/RCOND is considered to C be of full rank. If the user sets RCOND <= 0, then an C implicitly computed, default tolerance, defined by C RCONDEF = m*n*EPS, is used instead, where EPS is the C relative machine precision (see LAPACK Library routine C DLAMCH). C This parameter is not used for METH = 'M'. C C TOL DOUBLE PRECISION C Absolute tolerance used for determining an estimate of C the system order. If TOL >= 0, the estimate is C indicated by the index of the last singular value greater C than or equal to TOL. (Singular values less than TOL C are considered as zero.) When TOL = 0, an internally C computed default value, TOL = NOBR*EPS*SV(1), is used, C where SV(1) is the maximal singular value, and EPS is C the relative machine precision (see LAPACK Library routine C DLAMCH). When TOL < 0, the estimate is indicated by the C index of the singular value that has the largest C logarithmic gap to its successor. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK >= MAX(3,(M+L)*NOBR), if METH = 'N'; C LIWORK >= MAX(3,M+L), if METH = 'M' and ALG = 'F'; C LIWORK >= 3, if METH = 'M' and ALG = 'C' or 'Q'. C On entry with BATCH = 'I' or BATCH = 'L', IWORK(1:3) C must contain the values of ICYCLE, MAXWRK, and NSMPSM C set by the previous call of this routine. C On exit with BATCH = 'F' or BATCH = 'I', IWORK(1:3) C contains the values of ICYCLE, MAXWRK, and NSMPSM to be C used by the next call of the routine. C ICYCLE counts the cycles for BATCH = 'I'. C MAXWRK stores the current optimal workspace. C NSMPSM sums up the NSMP values for BATCH <> 'O'. C The first three elements of IWORK should be preserved C during successive calls of the routine with BATCH = 'F' C or BATCH = 'I', till the final call with BATCH = 'L'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK, and, for METH = 'N', and BATCH = 'L' or C 'O', DWORK(2) and DWORK(3) contain the reciprocal C condition numbers of the triangular factors of the C matrices U_f and r_1 [6]. C On exit, if INFO = -23, DWORK(1) returns the minimum C value of LDWORK. C Let C k = 0, if CONCT = 'N' and ALG = 'C' or 'Q'; C k = 2*NOBR-1, if CONCT = 'C' and ALG = 'C' or 'Q'; C k = 2*NOBR*(M+L+1), if CONCT = 'N' and ALG = 'F'; C k = 2*NOBR*(M+L+2), if CONCT = 'C' and ALG = 'F'. C The first (M+L)*k elements of DWORK should be preserved C during successive calls of the routine with BATCH = 'F' C or 'I', till the final call with BATCH = 'L'. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH = 'F' or C 'I' and CONCT = 'C'; C LDWORK >= 1, if ALG = 'C', BATCH = 'F' or 'I' and C CONCT = 'N'; C LDWORK >= max((4*NOBR-2)*(M+L), 5*L*NOBR), if METH = 'M', C ALG = 'C', BATCH = 'L' and CONCT = 'C'; C LDWORK >= max((2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR), C if METH = 'M', JOBD = 'M', ALG = 'C', C BATCH = 'O', or C (BATCH = 'L' and CONCT = 'N'); C LDWORK >= 5*L*NOBR, if METH = 'M', JOBD = 'N', ALG = 'C', C BATCH = 'O', or C (BATCH = 'L' and CONCT = 'N'); C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'C', and C BATCH = 'L' or 'O'; C LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F', C BATCH <> 'O' and CONCT = 'C'; C LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F', C BATCH = 'F', 'I' and CONCT = 'N'; C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F', C BATCH = 'L' and CONCT = 'N', or C BATCH = 'O'; C LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F', and C LDR >= NS = NSMP - 2*NOBR + 1; C LDWORK >= max(4*(M+L)*NOBR, 5*L*NOBR), if METH = 'M', C ALG = 'Q', BATCH = 'O', and LDR >= NS; C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'Q', C BATCH = 'O', and LDR >= NS; C LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', (BATCH = 'F' or 'O', C and LDR < NS), or (BATCH = 'I' or C 'L' and CONCT = 'N'); C LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I' C or 'L' and CONCT = 'C'. C The workspace used for ALG = 'Q' is C LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, C where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended C value LDRWRK = NS, assuming a large enough cache size. C For good performance, LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: the number of 100 cycles in sequential data C processing has been exhausted without signaling C that the last block of data was get; the cycle C counter was reinitialized; C = 2: a fast algorithm was requested (ALG = 'C' or 'F'), C but it failed, and the QR algorithm was then used C (non-sequential data processing); C = 3: all singular values were exactly zero, hence N = 0 C (both input and output were identically zero); C = 4: the least squares problems with coefficient matrix C U_f, used for computing the weighted oblique C projection (for METH = 'N'), have a rank-deficient C coefficient matrix; C = 5: the least squares problem with coefficient matrix C r_1 [6], used for computing the weighted oblique C projection (for METH = 'N'), has a rank-deficient C coefficient matrix. C NOTE: the values 4 and 5 of IWARN have no significance C for the identification problem. 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 fast algorithm was requested (ALG = 'C', or 'F') C in sequential data processing, but it failed; the C routine can be repeatedly called again using the C standard QR algorithm; C = 2: the singular value decomposition (SVD) algorithm did C not converge. C C METHOD C C The procedure consists in three main steps, the first step being C performed by one of the three algorithms included. C C 1.a) For non-sequential data processing using QR algorithm, a C t x 2(m+l)s matrix H is constructed, where C C H = [ Uf' Up' Y' ], for METH = 'M', C s+1,2s,t 1,s,t 1,2s,t C C H = [ U' Y' ], for METH = 'N', C 1,2s,t 1,2s,t C C and Up , Uf , U , and Y are block Hankel C 1,s,t s+1,2s,t 1,2s,t 1,2s,t C matrices defined in terms of the input and output data [3]. C A QR factorization is used to compress the data. C The fast QR algorithm uses a QR factorization which exploits C the block-Hankel structure. Actually, the Cholesky factor of H'*H C is computed. C C 1.b) For sequential data processing using QR algorithm, the QR C decomposition is done sequentially, by updating the upper C triangular factor R. This is also performed internally if the C workspace is not large enough to accommodate an entire batch. C C 1.c) For non-sequential or sequential data processing using C Cholesky algorithm, the correlation matrix of input-output data is C computed (sequentially, if requested), taking advantage of the C block Hankel structure [7]. Then, the Cholesky factor of the C correlation matrix is found, if possible. C C 2) A singular value decomposition (SVD) of a certain matrix is C then computed, which reveals the order n of the system as the C number of "non-zero" singular values. For the MOESP approach, this C matrix is [ R_24' R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s), C where R is the upper triangular factor R constructed by SLICOT C Library routine IB01MD. For the N4SID approach, a weighted C oblique projection is computed from the upper triangular factor R C and its SVD is then found. C C 3) The singular values are compared to the given, or default TOL, C and the estimated order n is returned, possibly after user's C confirmation. C C REFERENCES C C [1] Verhaegen M., and Dewilde, P. C Subspace Model Identification. Part 1: The output-error C state-space model identification class of algorithms. C Int. J. Control, 56, pp. 1187-1210, 1992. C C [2] Verhaegen M. C Subspace Model Identification. Part 3: Analysis of the C ordinary output-error state-space model identification C algorithm. C Int. J. Control, 58, pp. 555-586, 1993. C C [3] Verhaegen M. C Identification of the deterministic part of MIMO state space C models given in innovations form from input-output data. C Automatica, Vol.30, No.1, pp.61-74, 1994. C C [4] Van Overschee, P., and De Moor, B. C N4SID: Subspace Algorithms for the Identification of C Combined Deterministic-Stochastic Systems. C Automatica, Vol.30, No.1, pp. 75-93, 1994. C C [5] Peternell, K., Scherrer, W. and Deistler, M. C Statistical Analysis of Novel Subspace Identification Methods. C Signal Processing, 52, pp. 161-177, 1996. C C [6] Sima, V. C Subspace-based Algorithms for Multivariable System C Identification. C Studies in Informatics and Control, 5, pp. 335-344, 1996. C C [7] Sima, V. C Cholesky or QR Factorization for Data Compression in C Subspace-based Identification ? C Proceedings of the Second NICONET Workshop on ``Numerical C Control Software: SLICOT, a Useful Tool in Industry'', C December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999. C C NUMERICAL ASPECTS C C The implemented method is numerically stable (when QR algorithm is C used), reliable and efficient. The fast Cholesky or QR algorithms C are more efficient, but the accuracy could diminish by forming the C correlation matrix. C The most time-consuming computational step is step 1: C 2 C The QR algorithm needs 0(t(2(m+l)s) ) floating point operations. C 2 3 C The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating C point operations. C 2 3 2 C The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating C point operations. C 3 C Step 2 of the algorithm requires 0(((m+l)s) ) floating point C operations. C C FURTHER COMMENTS C C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the C calculations could be rather inefficient if only minimal workspace C (see argument LDWORK) is provided. It is advisable to provide as C much workspace as possible. Almost optimal efficiency can be C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the C cache size is large enough to accommodate R, U, Y, and DWORK. C C CONTRIBUTOR C C V. Sima, Katholieke Universiteit Leuven, Feb. 2000. C C REVISIONS C C August 2000, March 2005, May 2020. C C KEYWORDS C C Cholesky decomposition, Hankel matrix, identification methods, C multivariable systems, QR decomposition, singular value C decomposition. C C ****************************************************************** C C .. Scalar Arguments .. DOUBLE PRECISION RCOND, TOL INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, N, $ NOBR, NSMP CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION DWORK(*), R(LDR, *), SV(*), U(LDU, *), $ Y(LDY, *) C .. Local Scalars .. INTEGER ICYCLE, IWARNL, LMNOBR, LNOBR, MAXWRK, MINWRK, $ MNOBR, NOBR21, NR, NS, NSMPSM LOGICAL CHALG, CONNEC, CONTRL, FIRST, FQRALG, INTERM, $ JOBDM, LAST, MOESP, N4SID, ONEBCH, QRALG C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL IB01MD, IB01ND, IB01OD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Decode the scalar input parameters. C MOESP = LSAME( METH, 'M' ) N4SID = LSAME( METH, 'N' ) FQRALG = LSAME( ALG, 'F' ) QRALG = LSAME( ALG, 'Q' ) CHALG = LSAME( ALG, 'C' ) JOBDM = LSAME( JOBD, 'M' ) ONEBCH = LSAME( BATCH, 'O' ) FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH INTERM = LSAME( BATCH, 'I' ) LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH CONTRL = LSAME( CTRL, 'C' ) C IF( .NOT.ONEBCH ) THEN CONNEC = LSAME( CONCT, 'C' ) ELSE CONNEC = .FALSE. END IF C MNOBR = M*NOBR LNOBR = L*NOBR LMNOBR = LNOBR + MNOBR NR = LMNOBR + LMNOBR NOBR21 = 2*NOBR - 1 IWARN = 0 INFO = 0 IF( FIRST ) THEN ICYCLE = 1 MAXWRK = 1 NSMPSM = 0 ELSE IF( .NOT.ONEBCH ) THEN ICYCLE = IWORK(1) MAXWRK = IWORK(2) NSMPSM = IWORK(3) END IF NSMPSM = NSMPSM + NSMP C C Check the scalar input parameters. C IF( .NOT.( MOESP .OR. N4SID ) ) THEN INFO = -1 ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN INFO = -2 ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN INFO = -3 ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN INFO = -4 ELSE IF( .NOT. ONEBCH ) THEN IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) $ INFO = -5 END IF IF( INFO.EQ.0 ) THEN IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN INFO = -6 ELSE IF( NOBR.LE.0 ) THEN INFO = -7 ELSE IF( M.LT.0 ) THEN INFO = -8 ELSE IF( L.LE.0 ) THEN INFO = -9 ELSE IF( NSMP.LT.2*NOBR .OR. $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN INFO = -10 ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN INFO = -12 ELSE IF( LDY.LT.NSMP ) THEN INFO = -14 ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND. $ LDR.LT.3*MNOBR ) ) THEN INFO = -17 ELSE C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe C the minimal amount of workspace needed at that point in the C code, as well as the preferred amount for good performance.) C NS = NSMP - NOBR21 IF ( CHALG ) THEN IF ( .NOT.LAST ) THEN IF ( CONNEC ) THEN MINWRK = 2*( NR - M - L ) ELSE MINWRK = 1 END IF ELSE IF ( MOESP ) THEN IF ( CONNEC .AND. .NOT.ONEBCH ) THEN MINWRK = MAX( 2*( NR - M - L ), 5*LNOBR ) ELSE MINWRK = 5*LNOBR IF ( JOBDM ) $ MINWRK = MAX( 2*MNOBR - NOBR, LMNOBR, MINWRK ) END IF ELSE MINWRK = 5*LMNOBR + 1 END IF ELSE IF ( FQRALG ) THEN IF ( .NOT.ONEBCH .AND. CONNEC ) THEN MINWRK = NR*( M + L + 3 ) ELSE IF ( FIRST .OR. INTERM ) THEN MINWRK = NR*( M + L + 1 ) ELSE MINWRK = 2*NR*( M + L + 1 ) + NR END IF ELSE MINWRK = 2*NR IF ( ONEBCH .AND. LDR.GE.NS ) THEN IF ( MOESP ) THEN MINWRK = MAX( MINWRK, 5*LNOBR ) ELSE MINWRK = 5*LMNOBR + 1 END IF END IF IF ( FIRST ) THEN IF ( LDR.LT.NS ) THEN MINWRK = MINWRK + NR END IF ELSE IF ( CONNEC ) THEN MINWRK = MINWRK*( NOBR + 1 ) ELSE MINWRK = MINWRK + NR END IF END IF END IF C MAXWRK = MINWRK C IF( LDWORK.LT.MINWRK ) THEN INFO = -23 DWORK( 1 ) = MINWRK END IF END IF END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN IF( .NOT.ONEBCH ) THEN IWORK(1) = 1 IWORK(2) = MAXWRK IWORK(3) = 0 END IF CALL XERBLA( 'IB01AD', -INFO ) RETURN END IF C C Compress the input-output data. C Workspace: need c*(M+L)*NOBR, where c is a constant depending C on the algorithm and the options used C (see SLICOT Library routine IB01MD); C prefer larger. C CALL IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, Y, $ LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, INFO ) C IF ( INFO.EQ.1 ) THEN C C Error return: A fast algorithm was requested (ALG = 'C', 'F') C in sequential data processing, but it failed. C RETURN END IF C MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ) ) C IF ( .NOT.LAST ) THEN C C Return to get new data. C ICYCLE = ICYCLE + 1 IWORK(1) = ICYCLE IWORK(2) = MAXWRK IWORK(3) = NSMPSM RETURN END IF C C Find the singular value decomposition (SVD) giving the system C order, and perform related preliminary calculations needed for C computing the system matrices. C Workspace: need max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ), C if METH = 'M'; C 5*(M+L)*NOBR+1, if METH = 'N'; C prefer larger. C CALL IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, RCOND, IWORK, $ DWORK, LDWORK, IWARNL, INFO ) IWARN = MAX( IWARN, IWARNL ) C IF ( INFO.EQ.2 ) THEN C C Error return: the singular value decomposition (SVD) algorithm C did not converge. C RETURN END IF C C Estimate the system order. C CALL IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARNL, INFO ) IWARN = MAX( IWARN, IWARNL ) C C Return optimal workspace in DWORK(1). C DWORK( 1 ) = MAX( MAXWRK, INT( DWORK( 1 ) ) ) IF( .NOT.ONEBCH ) THEN IWORK(1) = ICYCLE IWORK(2) = MAXWRK IWORK(3) = NSMPSM END IF RETURN C C *** Last line of IB01AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02GD.f0000644000000000000000000000013215012430707016150 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02GD.f0000644000175000017500000004541615012430707017356 0ustar00lilgelilge00000000000000 SUBROUTINE MB02GD( TYPET, TRIU, K, N, NL, P, S, T, LDT, RB, LDRB, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the Cholesky factor of a banded symmetric positive C definite (s.p.d.) block Toeplitz matrix, defined by either its C first block row, or its first block column, depending on the C routine parameter TYPET. C C By subsequent calls of this routine the Cholesky factor can be C computed block column by block column. C C ARGUMENTS C C Mode Parameters C C TYPET CHARACTER*1 C Specifies the type of T, as follows: C = 'R': T contains the first block row of an s.p.d. block C Toeplitz matrix; the Cholesky factor is upper C triangular; C = 'C': T contains the first block column of an s.p.d. C block Toeplitz matrix; the Cholesky factor is C lower triangular. This choice results in a column C oriented algorithm which is usually faster. C Note: in the sequel, the notation x / y means that C x corresponds to TYPET = 'R' and y corresponds to C TYPET = 'C'. C C TRIU CHARACTER*1 C Specifies the structure of the last block in T, as C follows: C = 'N': the last block has no special structure; C = 'T': the last block is lower / upper triangular. C C Input/Output Parameters C C K (input) INTEGER C The number of rows / columns in T, which should be equal C to the blocksize. K >= 0. C C N (input) INTEGER C The number of blocks in T. N >= 1. C If TRIU = 'N', N >= 1; C if TRIU = 'T', N >= 2. C C NL (input) INTEGER C The lower block bandwidth, i.e., NL + 1 is the number of C nonzero blocks in the first block column of the block C Toeplitz matrix. C If TRIU = 'N', 0 <= NL < N; C if TRIU = 'T', 1 <= NL < N. C C P (input) INTEGER C The number of previously computed block rows / columns of C the Cholesky factor. 0 <= P <= N. C C S (input) INTEGER C The number of block rows / columns of the Cholesky factor C to compute. 0 <= S <= N - P. C C T (input/output) DOUBLE PRECISION array, dimension C (LDT,(NL+1)*K) / (LDT,K) C On entry, if P = 0, the leading K-by-(NL+1)*K / C (NL+1)*K-by-K part of this array must contain the first C block row / column of an s.p.d. block Toeplitz matrix. C On entry, if P > 0, the leading K-by-(NL+1)*K / C (NL+1)*K-by-K part of this array must contain the P-th C block row / column of the Cholesky factor. C On exit, if INFO = 0, then the leading K-by-(NL+1)*K / C (NL+1)*K-by-K part of this array contains the (P+S)-th C block row / column of the Cholesky factor. C C LDT INTEGER C The leading dimension of the array T. C LDT >= MAX(1,K) / MAX(1,(NL+1)*K). C C RB (input/output) DOUBLE PRECISION array, dimension C (LDRB,MIN(P+NL+S,N)*K) / (LDRB,MIN(P+S,N)*K) C On entry, if TYPET = 'R' and TRIU = 'N' and P > 0, C the leading (NL+1)*K-by-MIN(NL,N-P)*K part of this array C must contain the (P*K+1)-st to ((P+NL)*K)-th columns C of the upper Cholesky factor in banded format from a C previous call of this routine. C On entry, if TYPET = 'R' and TRIU = 'T' and P > 0, C the leading (NL*K+1)-by-MIN(NL,N-P)*K part of this array C must contain the (P*K+1)-st to (MIN(P+NL,N)*K)-th columns C of the upper Cholesky factor in banded format from a C previous call of this routine. C On exit, if TYPET = 'R' and TRIU = 'N', the leading C (NL+1)*K-by-MIN(NL+S,N-P)*K part of this array contains C the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the C upper Cholesky factor in banded format. C On exit, if TYPET = 'R' and TRIU = 'T', the leading C (NL*K+1)-by-MIN(NL+S,N-P)*K part of this array contains C the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the C upper Cholesky factor in banded format. C On exit, if TYPET = 'C' and TRIU = 'N', the leading C (NL+1)*K-by-MIN(S,N-P)*K part of this array contains C the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower C Cholesky factor in banded format. C On exit, if TYPET = 'C' and TRIU = 'T', the leading C (NL*K+1)-by-MIN(S,N-P)*K part of this array contains C the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower C Cholesky factor in banded format. C For further details regarding the band storage scheme see C the documentation of the LAPACK routine DPBTF2. C C LDRB INTEGER C The leading dimension of the array RB. C If TRIU = 'N', LDRB >= MAX( (NL+1)*K,1 ); C if TRIU = 'T', LDRB >= NL*K+1. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -13, DWORK(1) returns the minimum C value of LDWORK. C The first 1 + ( NL + 1 )*K*K elements of DWORK should be C preserved during successive calls of the routine. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 1 + ( NL + 1 )*K*K + NL*K. 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 = 1: the reduction algorithm failed. The Toeplitz matrix C associated with T is not (numerically) positive C definite. C C METHOD C C Householder transformations and modified hyperbolic rotations C are used in the Schur algorithm [1], [2]. C C REFERENCES C C [1] Kailath, T. and Sayed, A. C Fast Reliable Algorithms for Matrices with Structure. C SIAM Publications, Philadelphia, 1999. C C [2] Kressner, D. and Van Dooren, P. C Factorizations and linear system solvers for matrices with C Toeplitz structure. C SLICOT Working Note 2000-2, 2000. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C 3 C The algorithm requires O( K *N*NL ) floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, June 2001, C Mar. 2004, Apr. 2011. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER TRIU, TYPET INTEGER INFO, K, LDRB, LDT, LDWORK, N, NL, P, S C .. Array Arguments .. DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,*), T(LDT,*) C .. Local Scalars .. CHARACTER STRUCT LOGICAL ISROW, LQUERY, LTRI INTEGER HEAD, I, IERR, J, JJ, KK, LEN, LEN2, LENR, NB, $ NBMIN, PDW, POSR, PRE, RNK, SIZR, STPS, WRKMIN, $ WRKOPT C .. Local Arrays .. INTEGER IPVT(1) DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL ILAENV, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGELQF, DGEQRF, DLACPY, DLASET, DPOTRF, $ DTRSM, MB02CU, MB02CV, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, MOD C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 LTRI = LSAME( TRIU, 'T' ) LENR = ( NL + 1 )*K IF ( LTRI ) THEN SIZR = NL*K + 1 ELSE SIZR = LENR END IF ISROW = LSAME( TYPET, 'R' ) WRKMIN = 1 + ( LENR + NL )*K C C Check the scalar input parameters. C IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN INFO = -2 ELSE IF ( K.LT.0 ) THEN INFO = -3 ELSE IF ( ( LTRI .AND. N.LT.2 ) .OR. $ ( .NOT.LTRI .AND. N.LT.1 ) ) THEN INFO = -4 ELSE IF ( NL.GE.N .OR. ( LTRI .AND. NL.LT.1 ) .OR. $ ( .NOT.LTRI .AND. NL.LT.0 ) ) THEN INFO = -5 ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN INFO = -6 ELSE IF ( S.LT.0 .OR. S.GT.N-P ) THEN INFO = -7 ELSE IF ( ( ISROW .AND. LDT.LT.MAX( 1, K ) ) .OR. $ ( .NOT.ISROW .AND. LDT.LT.MAX( 1, LENR ) ) ) $ THEN INFO = -9 ELSE IF ( ( LTRI .AND. LDRB.LT.SIZR ) .OR. $ ( .NOT.LTRI .AND. LDRB.LT.MAX( 1, LENR ) ) ) $ THEN INFO = -11 ELSE LQUERY = LDWORK.EQ.-1 PDW = LENR*K + 1 KK = PDW + 4*K IF ( ISROW ) THEN CALL DGEQRF( K, LENR, T, LDT, DWORK, DWORK, -1, INFO ) ELSE CALL DGELQF( LENR, K, T, LDT, DWORK, DWORK, -1, INFO ) END IF WRKOPT = KK + INT( DWORK(1) ) IF ( LDWORK.LT.WRKMIN .AND. .NOT.LQUERY ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = -13 END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02GD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF ( S*K.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Compute the generator if P = 0. C IF ( P.EQ.0 ) THEN IF ( ISROW ) THEN CALL DPOTRF( 'Upper', K, T, LDT, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF IF ( NL.GT.0 ) $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, $ NL*K, ONE, T, LDT, T(1,K+1), LDT ) C C Copy the first block row to RB. C IF ( LTRI ) THEN C DO 10 I = 1, LENR - K CALL DCOPY( MIN( I, K ), T(1,I), 1, $ RB( MAX( SIZR-I+1, 1 ),I ), 1 ) 10 CONTINUE C DO 20 I = K, 1, -1 CALL DCOPY( I, T(K-I+1,LENR-I+1), 1, $ RB( 1,LENR-I+1 ), 1 ) 20 CONTINUE C ELSE C DO 30 I = 1, LENR CALL DCOPY( MIN( I, K ), T(1,I), 1, $ RB( MAX( SIZR-I+1, 1 ),I ), 1 ) 30 CONTINUE C END IF C C Quick return if N = 1. C IF ( N.EQ.1 ) THEN DWORK(1) = ONE RETURN END IF C CALL DLACPY( 'All', K, NL*K, T(1,K+1), LDT, DWORK(2), K ) CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K*K+2), K ) POSR = K + 1 ELSE CALL DPOTRF( 'Lower', K, T, LDT, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF IF ( NL.GT.0 ) $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', $ NL*K, K, ONE, T, LDT, T(K+1,1), LDT ) C C Copy the first block column to RB. C POSR = 1 IF ( LTRI ) THEN C DO 40 I = 1, K CALL DCOPY( SIZR, T(I,I), 1, RB(1,POSR), 1 ) POSR = POSR + 1 40 CONTINUE C ELSE C DO 50 I = 1, K CALL DCOPY( LENR-I+1, T(I,I), 1, RB(1,POSR), 1 ) IF ( LENR.LT.N*K .AND. I.GT.1 ) THEN CALL DLASET( 'All', I-1, 1, ZERO, ZERO, $ RB(LENR-I+2,POSR), LDRB ) END IF POSR = POSR + 1 50 CONTINUE C END IF C C Quick return if N = 1. C IF ( N.EQ.1 ) THEN DWORK(1) = ONE RETURN END IF C CALL DLACPY( 'All', NL*K, K, T(K+1,1), LDT, DWORK(2), LENR ) CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K+2), LENR ) END IF PRE = 1 STPS = S - 1 ELSE PRE = P STPS = S POSR = 1 END IF C HEAD = MOD( ( PRE - 1 )*K, LENR ) C C Determine block size for the involved block Householder C transformations. C NB = MIN( INT( ( LDWORK - KK )/LENR ), K ) IF ( ISROW ) THEN NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', K, LENR, -1, -1 ) ) ELSE NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, K, -1, -1 ) ) END IF IF ( NB.LT.NBMIN ) NB = 0 C C Generator reduction process. C IF ( ISROW ) THEN C DO 90 I = PRE, PRE + STPS - 1 CALL MB02CU( 'Row', K, K, K, NB, T, LDT, DUM, 1, $ DWORK(HEAD*K+2), K, RNK, IPVT, DWORK(PDW+1), $ ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) C IF ( IERR.NE.0 ) THEN C C Error return: The positive definiteness is (numerically) C not satisfied. C INFO = 1 RETURN END IF C LEN = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 ) LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 ) IF ( LEN.EQ.( LENR-K ) ) THEN STRUCT = TRIU ELSE STRUCT = 'N' END IF CALL MB02CV( 'Row', STRUCT, K, LEN, K, K, NB, -1, DUM, 1, $ DUM, 1, DWORK(HEAD*K+2), K, T(1,K+1), LDT, $ DUM, 1, DWORK((HEAD+K)*K+2), K, DWORK(PDW+1), $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) C IF ( ( N - I )*K.GE.LENR ) THEN STRUCT = TRIU ELSE STRUCT = 'N' END IF CALL MB02CV( 'Row', STRUCT, K, LEN2, K, K, NB, -1, DUM, 1, $ DUM, 1, DWORK(HEAD*K+2), K, T(1,K+LEN+1), LDT, $ DUM, 1, DWORK(2), K, DWORK(PDW+1), $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) C CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD*K+2), K ) C C Copy current block row to RB. C IF ( LTRI ) THEN C DO 60 J = 1, MIN( LEN + LEN2 + K, LENR - K ) CALL DCOPY( MIN( J, K ), T(1,J), 1, $ RB(MAX( SIZR-J+1, 1 ),POSR+J-1 ), 1 ) 60 CONTINUE C IF ( LEN+LEN2+K.GE.LENR ) THEN C DO 70 JJ = K, 1, -1 CALL DCOPY( JJ, T(K-JJ+1,LENR-JJ+1), 1, $ RB(1,POSR+LENR-JJ), 1 ) 70 CONTINUE C END IF POSR = POSR + K C ELSE C DO 80 J = 1, LEN + LEN2 + K CALL DCOPY( MIN( J, K ), T(1,J), 1, $ RB(MAX( SIZR-J+1, 1 ),POSR+J-1), 1 ) IF ( J.GT.LENR-K ) THEN CALL DLASET( 'All', SIZR-J, 1, ZERO, ZERO, $ RB(1,POSR+J-1), 1 ) END IF 80 CONTINUE C POSR = POSR + K END IF HEAD = MOD( HEAD + K, LENR ) 90 CONTINUE C ELSE C DO 120 I = PRE, PRE + STPS - 1 C CALL MB02CU( 'Column', K, K, K, NB, T, LDT, DUM, 1, $ DWORK(HEAD+2), LENR, RNK, IPVT, DWORK(PDW+1), $ ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) C IF ( IERR.NE.0 ) THEN C C Error return: The positive definiteness is (numerically) C not satisfied. C INFO = 1 RETURN END IF C LEN = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 ) LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 ) IF ( LEN.EQ.( LENR-K ) ) THEN STRUCT = TRIU ELSE STRUCT = 'N' END IF CALL MB02CV( 'Column', STRUCT, K, LEN, K, K, NB, -1, DUM, $ 1, DUM, 1, DWORK(HEAD+2), LENR, T(K+1,1), LDT, $ DUM, 1, DWORK(HEAD+K+2), LENR, DWORK(PDW+1), $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) C IF ( ( N - I )*K.GE.LENR ) THEN STRUCT = TRIU ELSE STRUCT = 'N' END IF CALL MB02CV( 'Column', STRUCT, K, LEN2, K, K, NB, -1, DUM, $ 1, DUM, 1, DWORK(HEAD+2), LENR, T(K+LEN+1,1), $ LDT, DUM, 1, DWORK(2), LENR, DWORK(PDW+1), $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) C CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD+2), LENR ) C C Copy current block column to RB. C IF ( LTRI ) THEN C DO 100 J = 1, K CALL DCOPY( MIN( SIZR, (N-I)*K-J+1 ), T(J,J), 1, $ RB(1,POSR), 1 ) POSR = POSR + 1 100 CONTINUE C ELSE C DO 110 J = 1, K CALL DCOPY( MIN( SIZR-J+1, (N-I)*K-J+1 ), T(J,J), 1, $ RB(1,POSR), 1 ) IF ( LENR.LT.(N-I)*K ) THEN CALL DLASET( 'All', J-1, 1, ZERO, ZERO, $ RB(MIN( SIZR-J+1, (N-I)*K-J+1 ) + 1, $ POSR), LDRB ) END IF POSR = POSR + 1 110 CONTINUE C END IF HEAD = MOD( HEAD + K, LENR ) 120 CONTINUE C END IF DWORK(1) = DBLE( WRKOPT ) RETURN C C *** Last line of MB02GD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01ZD.f0000644000000000000000000000013215012430707016201 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB01ZD.f0000644000175000017500000003471715012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE TB01ZD( JOBZ, N, P, A, LDA, B, C, LDC, NCONT, Z, LDZ, $ TAU, TOL, DWORK, LDWORK, INFO ) C C PURPOSE C C To find a controllable realization for the linear time-invariant C single-input system C C dX/dt = A * X + B * U, C Y = C * X, C C where A is an N-by-N matrix, B is an N element vector, C is an C P-by-N matrix, and A and B are reduced by this routine to C orthogonal canonical form using (and optionally accumulating) C orthogonal similarity transformations, which are also applied C to C. C C ARGUMENTS C C Mode Parameters C C JOBZ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal similarity transformations for C reducing the system, as follows: C = 'N': Do not form Z and do not store the orthogonal C transformations; C = 'F': Do not form Z, but store the orthogonal C transformations in the factored form; C = 'I': Z is initialized to the unit matrix and the C orthogonal transformation matrix Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e. the order of the matrix A. N >= 0. C C P (input) INTEGER C The number of system outputs, or of rows of C. 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 original state dynamics matrix A. C On exit, the leading NCONT-by-NCONT upper Hessenberg C part of this array contains the canonical form of the C state dynamics matrix, given by Z' * A * Z, of a C controllable realization for the original system. The C elements below 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/output) DOUBLE PRECISION array, dimension (N) C On entry, the original input/state vector B. C On exit, the leading NCONT elements of this array contain C canonical form of the input/state vector, given by Z' * B, C with all elements but B(1) set to zero. 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 output/state matrix C. C On exit, the leading P-by-N part of this array contains C the transformed output/state matrix, given by C * Z, and C the leading P-by-NCONT part contains the output/state C matrix of the controllable realization. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C NCONT (output) INTEGER C The order of the controllable state-space representation. C C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) C If JOBZ = 'I', then the leading N-by-N part of this array C contains the matrix of accumulated orthogonal similarity C transformations which reduces the given system to C orthogonal canonical form. C If JOBZ = 'F', the elements below the diagonal, with the C array TAU, represent the orthogonal transformation matrix C as a product of elementary reflectors. The transformation C matrix can then be obtained by calling the LAPACK Library C routine DORGQR. C If JOBZ = 'N', the array Z is not referenced and can be C supplied as a dummy array (i.e. set parameter LDZ = 1 and C declare this array to be Z(1,1) in the calling program). C C LDZ INTEGER C The leading dimension of array Z. If JOBZ = 'I' or C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. C C TAU (output) DOUBLE PRECISION array, dimension (N) C The elements of TAU contain the scalar factors of the C elementary reflectors used in the reduction of B and A. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in determining the C controllability of (A,B). If the user sets TOL > 0, then C the given value of TOL is used as an absolute tolerance; C elements with absolute value less than TOL are considered C neglijible. If the user sets TOL <= 0, then an implicitly C computed, default tolerance, defined by C TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead, C where EPS is the machine precision (see LAPACK Library C routine DLAMCH). 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 length of the array DWORK. LDWORK >= MAX(1,N,P). 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 C METHOD C C The Householder matrix which reduces all but the first element C of vector B to zero is found and this orthogonal similarity C transformation is applied to the matrix A. The resulting A is then C reduced to upper Hessenberg form by a sequence of Householder C transformations. Finally, the order of the controllable state- C space representation (NCONT) is determined by finding the position C of the first sub-diagonal element of A which is below an C appropriate zero threshold, either TOL or TOLDEF (see parameter C TOL); if NORM(B) is smaller than this threshold, NCONT is set to C zero, and no computations for reducing the system to orthogonal C canonical form are performed. C All orthogonal transformations determined in this process are also C applied to the matrix C, from the right. C C REFERENCES C C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. C Orthogonal Invariants and Canonical Forms for Linear C Controllable Systems. C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. C C [2] Hammarling, S.J. C Notes on the use of orthogonal similarity transformations in C control. C NPL Report DITC 8/82, August 1982. C C [3] Paige, C.C C Properties of numerical algorithms related to computing C controllability. C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations and 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, Oct. 2001, C Sept. 2003. C C KEYWORDS C C Controllability, minimal realization, orthogonal canonical form, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBZ INTEGER INFO, LDA, LDC, LDWORK, LDZ, N, NCONT, P DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(*), C(LDC,*), DWORK(*), TAU(*), $ Z(LDZ,*) C .. Local Scalars .. LOGICAL LJOBF, LJOBI, LJOBZ INTEGER ITAU, J DOUBLE PRECISION ANORM, B1, BNORM, FANORM, FBNORM, H, THRESH, $ TOLDEF, WRKOPT C .. Local Arrays .. DOUBLE PRECISION NBLK(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DGEHRD, DLACPY, DLARF, DLARFG, DLASET, DORGQR, $ DORMHR, MB01PD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX C .. Executable Statements .. C INFO = 0 LJOBF = LSAME( JOBZ, 'F' ) LJOBI = LSAME( JOBZ, 'I' ) LJOBZ = LJOBF.OR.LJOBI C C Test the input scalar arguments. C IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( P.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -8 ELSE IF( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN INFO = -11 ELSE IF( LDWORK.LT.MAX( 1, N, P ) ) THEN INFO = -15 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01ZD', -INFO ) RETURN END IF C C Quick return if possible. C NCONT = 0 DWORK(1) = ONE IF ( N.EQ.0 ) $ RETURN 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 WRKOPT = ONE C C Calculate the absolute norms of A and B (used for scaling). C ANORM = DLANGE( 'Max', N, N, A, LDA, DWORK ) BNORM = DLANGE( 'Max', N, 1, B, N, DWORK ) C C Return if matrix B is zero. C IF( BNORM.EQ.ZERO ) THEN IF( LJOBF ) THEN CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) ELSE IF( LJOBI ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) END IF RETURN END IF C C Scale (if needed) the matrices A and B. C CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) CALL MB01PD( 'S', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) C C Calculate the Frobenius norm of A and the 1-norm of B (used for C controllability test). C FANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) FBNORM = DLANGE( '1-norm', N, 1, B, N, DWORK ) C TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance in controllability determination. C THRESH = DBLE(N)*DLAMCH( 'EPSILON' ) TOLDEF = THRESH*MAX( FANORM, FBNORM ) END IF C ITAU = 1 IF ( FBNORM.GT.TOLDEF ) THEN C C B is not negligible compared with A. C IF ( N.GT.1 ) THEN C C Transform B by a Householder matrix Z1: store vector C describing this temporarily in B and in the local scalar H. C CALL DLARFG( N, B(1), B(2), 1, H ) C B1 = B(1) B(1) = ONE C C Form Z1 * A * Z1. C Workspace: need N. C CALL DLARF( 'Right', N, N, B, 1, H, A, LDA, DWORK ) CALL DLARF( 'Left', N, N, B, 1, H, A, LDA, DWORK ) C C Form C * Z1. C Workspace: need P. C CALL DLARF( 'Right', P, N, B, 1, H, C, LDC, DWORK ) C B(1) = B1 TAU(1) = H ITAU = ITAU + 1 ELSE B1 = B(1) TAU(1) = ZERO END IF C C Reduce modified A to upper Hessenberg form by an orthogonal C similarity transformation with matrix Z2. C Workspace: need N; prefer N*NB. C CALL DGEHRD( N, 1, N, A, LDA, TAU(ITAU), DWORK, LDWORK, INFO ) WRKOPT = DWORK(1) C C Form C * Z2. C Workspace: need P; prefer P*NB. C CALL DORMHR( 'Right', 'No transpose', P, N, 1, N, A, LDA, $ TAU(ITAU), C, LDC, DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, DWORK(1) ) C IF ( LJOBZ ) THEN C C Save the orthogonal transformations used, so that they could C be accumulated by calling DORGQR routine. C IF ( N.GT.1 ) $ CALL DLACPY( 'Full', N-1, 1, B(2), N-1, Z(2,1), LDZ ) IF ( N.GT.2 ) $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, Z(3,2), $ LDZ ) IF ( LJOBI ) THEN C C Form the orthogonal transformation matrix Z = Z1 * Z2. C Workspace: need N; prefer N*NB. C CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, DWORK(1) ) END IF END IF C C Annihilate the lower part of A and B. C IF ( N.GT.2 ) $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) IF ( N.GT.1 ) $ CALL DLASET( 'Full', N-1, 1, ZERO, ZERO, B(2), N-1 ) C C Find NCONT by checking sizes of the sub-diagonal elements of C transformed A. C IF ( TOL.LE.ZERO ) $ TOLDEF = THRESH*MAX( FANORM, ABS( B1 ) ) C J = 1 C C WHILE ( J < N and ABS( A(J+1,J) ) > TOLDEF ) DO C 10 CONTINUE IF ( J.LT.N ) THEN IF ( ABS( A(J+1,J) ).GT.TOLDEF ) THEN J = J + 1 GO TO 10 END IF END IF C C END WHILE 10 C C First negligible sub-diagonal element found, if any: set NCONT. C NCONT = J IF ( J.LT.N ) $ A(J+1,J) = ZERO C C Undo scaling of A and B. C CALL MB01PD( 'U', 'H', NCONT, NCONT, 0, 0, ANORM, 0, NBLK, A, $ LDA, INFO ) CALL MB01PD( 'U', 'G', 1, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) IF ( NCONT.LT.N ) $ CALL MB01PD( 'U', 'G', N, N-NCONT, 0, 0, ANORM, 0, NBLK, $ A(1,NCONT+1), LDA, INFO ) ELSE C C B is negligible compared with A. No computations for reducing C the system to orthogonal canonical form have been performed, C except scaling (which is undoed). C CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, $ INFO ) CALL MB01PD( 'U', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) IF( LJOBF ) THEN CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) ELSE IF( LJOBI ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) END IF END IF C C Set optimal workspace dimension. C DWORK(1) = WRKOPT C RETURN C *** Last line of TB01ZD *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01QD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/IB01QD.f0000644000175000017500000011437515012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE IB01QD( JOBX0, JOB, N, M, L, NSMP, A, LDA, C, LDC, U, $ LDU, Y, LDY, X0, B, LDB, D, LDD, TOL, IWORK, $ DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To estimate the initial state and the system matrices B and D C of a linear time-invariant (LTI) discrete-time system, given the C matrix pair (A,C) and the input and output trajectories of the C system. The model structure is : C C x(k+1) = Ax(k) + Bu(k), k >= 0, C y(k) = Cx(k) + Du(k), C C where x(k) is the n-dimensional state vector (at time k), C u(k) is the m-dimensional input vector, C y(k) is the l-dimensional output vector, C and A, B, C, and D are real matrices of appropriate dimensions. C Matrix A is assumed to be in a real Schur form. C C ARGUMENTS C C Mode Parameters C C JOBX0 CHARACTER*1 C Specifies whether or not the initial state should be C computed, as follows: C = 'X': compute the initial state x(0); C = 'N': do not compute the initial state (x(0) is known C to be zero). C C JOB CHARACTER*1 C Specifies which matrices should be computed, as follows: C = 'B': compute the matrix B only (D is known to be zero); C = 'D': compute the matrices B and D. 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 number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L > 0. C C NSMP (input) INTEGER C The number of rows of matrices U and Y (number of C samples, t). C NSMP >= N*M + a + e, where C a = 0, if JOBX0 = 'N'; C a = N, if JOBX0 = 'X'; C e = 0, if JOBX0 = 'X' and JOB = 'B'; C e = 1, if JOBX0 = 'N' and JOB = 'B'; C e = M, if JOB = 'D'. 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 in a real Schur form. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C The leading L-by-N part of this array must contain the C system output matrix C (corresponding to the real Schur C form of A). C C LDC INTEGER C The leading dimension of the array C. LDC >= L. C C U (input/output) DOUBLE PRECISION array, dimension (LDU,M) C On entry, the leading NSMP-by-M part of this array must C contain the t-by-m input-data sequence matrix U, C U = [u_1 u_2 ... u_m]. Column j of U contains the C NSMP values of the j-th input component for consecutive C time increments. C On exit, if JOB = 'D', the leading NSMP-by-M part of C this array contains details of the QR factorization of C the t-by-m matrix U, possibly computed sequentially C (see METHOD). C If JOB = 'B', this array is unchanged on exit. C If M = 0, this array is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= MAX(1,NSMP), if M > 0; C LDU >= 1, if M = 0. C C Y (input) DOUBLE PRECISION array, dimension (LDY,L) C The leading NSMP-by-L part of this array must contain the C t-by-l output-data sequence matrix Y, C Y = [y_1 y_2 ... y_l]. Column j of Y contains the C NSMP values of the j-th output component for consecutive C time increments. C C LDY INTEGER C The leading dimension of the array Y. LDY >= MAX(1,NSMP). C C X0 (output) DOUBLE PRECISION array, dimension (N) C If JOBX0 = 'X', the estimated initial state of the C system, x(0). C If JOBX0 = 'N', x(0) is set to zero without any C calculations. C C B (output) DOUBLE PRECISION array, dimension (LDB,M) C If N > 0, M > 0, and INFO = 0, the leading N-by-M C part of this array contains the system input matrix B C in the coordinates corresponding to the real Schur form C of A. C If N = 0 or M = 0, this array is not referenced. C C LDB INTEGER C The leading dimension of the array B. C LDB >= N, if N > 0 and M > 0; C LDB >= 1, if N = 0 or M = 0. C C D (output) DOUBLE PRECISION array, dimension (LDD,M) C If M > 0, JOB = 'D', and INFO = 0, the leading C L-by-M part of this array contains the system input-output C matrix D. C If M = 0 or JOB = 'B', this array is not referenced. C C LDD INTEGER C The leading dimension of the array D. C LDD >= L, if M > 0 and JOB = 'D'; C LDD >= 1, if M = 0 or JOB = 'B'. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used for estimating the rank of C matrices. If the user sets TOL > 0, then the given value C of TOL is used as a lower bound for the reciprocal C condition number; a matrix whose estimated condition C number is less than 1/TOL is considered to be of full C rank. If the user sets TOL <= 0, then EPS is used C instead, where EPS is the relative machine precision C (see LAPACK Library routine DLAMCH). TOL <= 1. C C Workspace C C IWORK INTEGER array, dimension (LIWORK), where C LIWORK >= N*M + a, if JOB = 'B', C LIWORK >= max( N*M + a, M ), if JOB = 'D', C with a = 0, if JOBX0 = 'N'; C a = N, if JOBX0 = 'X'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK; DWORK(2) contains the reciprocal condition C number of the triangular factor of the QR factorization of C the matrix W2 (see METHOD); if M > 0 and JOB = 'D', C DWORK(3) contains the reciprocal condition number of the C triangular factor of the QR factorization of U. C On exit, if INFO = -23, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= max( LDW1, min( LDW2, LDW3 ) ), where C LDW1 = 2, if M = 0 or JOB = 'B', C LDW1 = 3, if M > 0 and JOB = 'D', C LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ), C LDW2 = LDWa, if M = 0 or JOB = 'B', C LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ), C if M > 0 and JOB = 'D', C LDWb = (b + r)*(r + 1) + C max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ), C LDW3 = LDWb, if M = 0 or JOB = 'B', C LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ), C if M > 0 and JOB = 'D', C r = N*M + a, C a = 0, if JOBX0 = 'N', C a = N, if JOBX0 = 'X'; C b = 0, if JOB = 'B', C b = L*M, if JOB = 'D'; C c = 0, if JOBX0 = 'N', C c = L*N, if JOBX0 = 'X'; C d = 0, if JOBX0 = 'N', C d = 2*N*N + N, if JOBX0 = 'X'; C f = 2*r, if JOB = 'B' or M = 0, C f = M + max( 2*r, M ), if JOB = 'D' and M > 0; C q = b + r*L. C For good performance, LDWORK should be larger. C If LDWORK >= LDW2 or C LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + C max( d, f ), C then standard QR factorizations of the matrices U and/or C W2 (see METHOD) are used. C Otherwise, the QR factorizations are computed sequentially C by performing NCYCLE cycles, each cycle (except possibly C the last one) processing s < t samples, where s is C chosen from the equation C LDWORK = s*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + C max( d, f ). C (s is at least N*M+a+e, the minimum value of NSMP.) C The computational effort may increase and the accuracy may C decrease with the decrease of s. Recommended value is C LDWORK = LDW2, assuming a large enough cache size, to C also accommodate A, C, U, and Y. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 4: the least squares problem to be solved has a C rank-deficient coefficient matrix. 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 = 2: the singular value decomposition (SVD) algorithm did C not converge. C C METHOD C C An extension and refinement of the method in [1,2] is used. C Specifically, denoting C C X = [ vec(D')' vec(B)' x0' ]', C C where vec(M) is the vector obtained by stacking the columns of C the matrix M, then X is the least squares solution of the C system S*X = vec(Y), with the matrix S = [ diag(U) W ], C defined by C C ( U | | ... | | | ... | | ) C ( U | 11 | ... | n1 | 12 | ... | nm | ) C S = ( : | y | ... | y | y | ... | y | P*Gamma ), C ( : | | ... | | | ... | | ) C ( U | | ... | | | ... | | ) C ij C diag(U) having L block rows and columns. In this formula, y C are the outputs of the system for zero initial state computed C using the following model, for j = 1:m, and for i = 1:n, C ij ij ij C x (k+1) = Ax (k) + e_i u_j(k), x (0) = 0, C C ij ij C y (k) = Cx (k), C C where e_i is the i-th n-dimensional unit vector, Gamma is C given by C C ( C ) C ( C*A ) C Gamma = ( C*A^2 ), C ( : ) C ( C*A^(t-1) ) C C and P is a permutation matrix that groups together the rows of C Gamma depending on the same row of C, namely C [ c_j; c_j*A; c_j*A^2; ... c_j*A^(t-1) ], for j = 1:L. C The first block column, diag(U), is not explicitly constructed, C but its structure is exploited. The last block column is evaluated C using powers of A with exponents 2^k. No interchanges are applied. C A special QR decomposition of the matrix S is computed. Let C U = q*[ r' 0 ]' be the QR decomposition of U, if M > 0, where C r is M-by-M. Then, diag(q') is applied to W and vec(Y). C The block-rows of S and vec(Y) are implicitly permuted so that C matrix S becomes C C ( diag(r) W1 ) C ( 0 W2 ), C C where W1 has L*M rows. Then, the QR decomposition of W2 is C computed (sequentially, if M > 0) and used to obtain B and x0. C The intermediate results and the QR decomposition of U are C needed to find D. If a triangular factor is too ill conditioned, C then singular value decomposition (SVD) is employed. SVD is not C generally needed if the input sequence is sufficiently C persistently exciting and NSMP is large enough. C If the matrix W cannot be stored in the workspace (i.e., C LDWORK < LDW2), the QR decompositions of W2 and U are C computed sequentially. C C REFERENCES C C [1] Verhaegen M., and Varga, A. C Some Experience with the MOESP Class of Subspace Model C Identification Methods in Identifying the BO105 Helicopter. C Report TR R165-94, DLR Oberpfaffenhofen, 1994. C C [2] Sima, V., and Varga, A. C RASP-IDENT : Subspace Model Identification Programs. C Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V., C Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C C FURTHER COMMENTS C C The algorithm for computing the system matrices B and D is C less efficient than the MOESP or N4SID algorithms implemented in C SLICOT Library routine IB01PD, because a large least squares C problem has to be solved, but the accuracy is better, as the C computed matrices B and D are fitted to the input and output C trajectories. However, if matrix A is unstable, the computed C matrices B and D could be inaccurate. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. C C REVISIONS C C - C C KEYWORDS C C Identification methods; least squares solutions; multivariable C systems; QR decomposition; singular value decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, $ LDWORK, LDY, M, N, NSMP CHARACTER JOB, JOBX0 C .. Array Arguments .. DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), $ DWORK(*), U(LDU, *), X0(*), Y(LDY, *) INTEGER IWORK(*) C .. Local Scalars .. DOUBLE PRECISION RCOND, RCONDU, TOLL INTEGER I, I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON, $ IG, IGAM, IGS, INI, INIH, INIR, INIS, INY, $ INYGAM, IQ, IREM, IRHS, ISIZE, ISV, ITAU, $ ITAUU, IUPNT, IX, IXINIT, IXSAVE, IY, IYPNT, J, $ JWORK, K, LDDW, LDR, LDW2, LDW3, LM, LN, LNOB, $ MAXWRK, MINSMP, MINWLS, MINWRK, N2M, NCOL, $ NCP1, NCYCLE, NM, NN, NOBS, NROW, NSMPL, RANK LOGICAL FIRST, NCYC, POWER2, WITHB, WITHD, WITHX0 C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, ILAENV, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY, $ DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSM, $ MA02AD, MB01TD, MB02UD, MB04OD, MB04OY, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD C .. Executable Statements .. C C Check the input parameters. C WITHD = LSAME( JOB, 'D' ) WITHB = LSAME( JOB, 'B' ) .OR. WITHD WITHX0 = LSAME( JOBX0, 'X' ) C IWARN = 0 INFO = 0 LM = L*M LN = L*N NN = N*N NM = N*M N2M = N*NM NCOL = NM IF( WITHX0 ) $ NCOL = NCOL + N MINSMP = NCOL IF( WITHD ) THEN MINSMP = MINSMP + M IQ = MINSMP ELSE IF ( .NOT.WITHX0 ) THEN IQ = MINSMP MINSMP = MINSMP + 1 ELSE IQ = MINSMP END IF C IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.WITHB ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( L.LE.0 ) THEN INFO = -5 ELSE IF( NSMP.LT.MINSMP ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDC.LT.L ) THEN INFO = -10 ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN INFO = -12 ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN INFO = -14 ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) $ THEN INFO = -17 ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) $ THEN INFO = -19 ELSE IF( TOL.GT.ONE ) THEN INFO = -20 END IF C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 NSMPL = NSMP*L IQ = IQ*L NCP1 = NCOL + 1 ISIZE = NSMPL*NCP1 IF ( N.GT.0 .AND. WITHX0 ) THEN IC = 2*NN + N ELSE IC = 0 END IF MINWLS = NCOL*NCP1 IF ( WITHD ) $ MINWLS = MINWLS + LM*NCP1 IF ( M.GT.0 .AND. WITHD ) THEN IA = M + MAX( 2*NCOL, M ) ELSE IA = 2*NCOL END IF ITAU = N2M + MAX( IC, IA ) IF ( WITHX0 ) $ ITAU = ITAU + LN LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) IF ( M.GT.0 .AND. WITHD ) THEN LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) END IF MINWRK = MIN( LDW2, LDW3 ) MINWRK = MAX( MINWRK, 2 ) IF ( M.GT.0 .AND. WITHD ) $ MINWRK = MAX( MINWRK, 3 ) IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN IF ( M.GT.0 .AND. WITHD ) THEN MAXWRK = ISIZE + N + M + $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, M, -1, -1 ), $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMP-M, $ NCOL, -1, -1 ) ) MAXWRK = MAX( MAXWRK, ISIZE + N + M + $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', NSMP, $ NCP1, M, -1 ), $ NCOL + ILAENV( 1, 'DORMQR', 'LT', $ NSMP-M, 1, NCOL, -1 ) ) ) ELSE MAXWRK = ISIZE + N + NCOL + $ MAX( NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMPL, NCOL, $ -1, -1 ), $ ILAENV( 1, 'DORMQR', 'LT',NSMPL, 1, NCOL, $ -1 ) ) END IF MAXWRK = MAX( MAXWRK, MINWRK ) END IF C IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN INFO = -23 DWORK(1) = MINWRK END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB01QD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, M ).EQ.0 ) THEN DWORK(2) = ONE IF ( M.GT.0 .AND. WITHD ) THEN DWORK(1) = THREE DWORK(3) = ONE ELSE DWORK(1) = TWO END IF RETURN END IF C C Set up the least squares problem, either directly, if enough C workspace, or sequentially, otherwise. C IYPNT = 1 IUPNT = 1 LDDW = ( LDWORK - MINWLS - ITAU )/NCP1 NOBS = MIN( NSMP, LDDW/L ) C IF ( LDWORK.GE.LDW2 .OR. NSMP.LE.NOBS ) THEN C C Enough workspace for solving the problem directly. C NCYCLE = 1 NOBS = NSMP LDDW = MAX( 1, NSMPL ) IF ( WITHD ) THEN INIR = M + 1 ELSE INIR = 1 END IF INY = 1 INIS = 1 ELSE C C NCYCLE > 1 cycles are needed for solving the problem C sequentially, taking NOBS samples in each cycle (or the C remaining samples in the last cycle). C LNOB = L*NOBS LDDW = MAX( 1, LNOB ) NCYCLE = NSMP/NOBS IF ( MOD( NSMP, NOBS ).NE.0 ) $ NCYCLE = NCYCLE + 1 INIR = 1 INIH = INIR + NCOL*NCOL INIS = INIH + NCOL IF ( WITHD ) THEN INY = INIS + LM*NCP1 ELSE INY = INIS END IF END IF C NCYC = NCYCLE.GT.1 INYGAM = INY + LDDW*NM IRHS = INY + LDDW*NCOL IXINIT = IRHS + LDDW IF( NCYC ) THEN IC = IXINIT + N2M IF ( WITHX0 ) THEN IA = IC + LN ELSE IA = IC END IF LDR = MAX( 1, NCOL ) IE = INY ELSE IF ( WITHD ) THEN INIH = IRHS + M ELSE INIH = IRHS END IF IA = IXINIT + N LDR = LDDW IE = IXINIT END IF IF ( N.GT.0 .AND. WITHX0 ) $ IAS = IA + NN C ITAUU = IA IF ( WITHD ) THEN ITAU = ITAUU + M ELSE ITAU = ITAUU END IF DUM(1) = ZERO C DO 190 ICYCLE = 1, NCYCLE FIRST = ICYCLE.EQ.1 IF ( .NOT.FIRST ) THEN IF ( ICYCLE.EQ.NCYCLE ) THEN NOBS = NSMP - ( NCYCLE - 1 )*NOBS LNOB = L*NOBS END IF END IF C IY = INY IXSAVE = IXINIT C C Compute the M*N output trajectories for zero initial state C or for the saved final state value of the previous cycle. C This can be performed in parallel. C Workspace: need s*L*(r + 1) + b + w, C where r = M*N + a, s = NOBS, C a = 0, if JOBX0 = 'N'; C a = N, if JOBX0 = 'X'; C b = N, if NCYCLE = 1; C b = N*N*M, if NCYCLE > 1; C w = 0, if NCYCLE = 1; C w = r*(r+1), if NCYCLE > 1, JOB = 'B'; C w = (M*L+r)*(r+1), if NCYCLE > 1, JOB = 'D'. C DO 40 J = 1, M DO 30 I = 1, N C ij C Compute the y trajectory and put the vectorized form C of it in an appropriate column of DWORK. To gain in C efficiency, a specialization of SLICOT Library routine C TF01ND is used. C IF ( FIRST ) $ CALL DCOPY( N, DUM, 0, DWORK(IXSAVE), 1 ) CALL DCOPY( N, DWORK(IXSAVE), 1, X0, 1 ) INI = IY C DO 20 K = 1, NOBS CALL DGEMV( 'No transpose', L, N, ONE, C, LDC, X0, 1, $ ZERO, DWORK(IY), NOBS ) IY = IY + 1 CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, $ A, LDA, X0, 1 ) C DO 10 IX = 2, N X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXSAVE+IX-2) 10 CONTINUE C X0(I) = X0(I) + U(IUPNT+K-1,J) CALL DCOPY( N, X0, 1, DWORK(IXSAVE), 1 ) 20 CONTINUE C IF ( NCYC ) $ IXSAVE = IXSAVE + N IY = INI + LDDW 30 CONTINUE C 40 CONTINUE C IF ( N.GT.0 .AND. WITHX0 ) THEN C C Compute the permuted extended observability matrix Gamma C ij C in the following N columns of DWORK (after the y C trajectories). Gamma is directly constructed in the C required row structure. C Workspace: need s*L*(r + 1) + 2*N*N + N + b + c + w, C where c = 0, if NCYCLE = 1; C c = L*N, if NCYCLE > 1. C JWORK = IAS + NN IG = INYGAM IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) ) IREM = NOBS - 2**IEXPON POWER2 = IREM.EQ.0 IF ( .NOT.POWER2 ) $ IEXPON = IEXPON + 1 C IF ( FIRST ) THEN C DO 50 I = 1, N CALL DCOPY( L, C(1,I), 1, DWORK(IG), NOBS ) IG = IG + LDDW 50 CONTINUE C ELSE C DO 60 I = IC, IC + LN - 1, L CALL DCOPY( L, DWORK(I), 1, DWORK(IG), NOBS ) IG = IG + LDDW 60 CONTINUE C END IF C p C Use powers of the matrix A: A , p = 2**(J-1). C CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N ) IF( N.GT.1 ) $ CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) I2 = 1 NROW = 0 C DO 90 J = 1, IEXPON IGAM = INYGAM IF ( J.LT.IEXPON .OR. POWER2 ) THEN NROW = I2 ELSE NROW = IREM END IF C DO 80 I = 1, L CALL DLACPY( 'Full', NROW, N, DWORK(IGAM), LDDW, $ DWORK(IGAM+I2), LDDW ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', $ 'Non Unit', NROW, N, ONE, DWORK(IA), N, $ DWORK(IGAM+I2), LDDW ) IG = IGAM C p C Compute the contribution of the subdiagonal of A C to the product. C DO 70 IX = 1, N - 1 CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), $ DWORK(IG+LDDW), 1, DWORK(IG+I2), 1 ) IG = IG + LDDW 70 CONTINUE C IGAM = IGAM + NOBS 80 CONTINUE C IF ( J.LT.IEXPON ) THEN CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), $ N ) IF( N.GT.1 ) $ CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1), $ N+1 ) CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N, $ DWORK(JWORK), IERR ) I2 = I2*2 END IF 90 CONTINUE C IF ( NCYC .AND. ICYCLE.LT.NCYCLE ) THEN IG = INYGAM + I2 + NROW - 1 IGS = IG C DO 100 I = IC, IC + LN - 1, L CALL DCOPY( L, DWORK(IG), NOBS, DWORK(I), 1 ) IG = IG + LDDW 100 CONTINUE C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', $ L, N, ONE, A, LDA, DWORK(IC), L ) IG = IGS C C Compute the contribution of the subdiagonal of A to the C product. C DO 110 IX = 1, N - 1 CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), NOBS, $ DWORK(IC+(IX-1)*L), 1 ) IG = IG + LDDW 110 CONTINUE C END IF END IF C C Setup (part of) the right hand side of the least squares C problem. C IY = IRHS C DO 120 K = 1, L CALL DCOPY( NOBS, Y(IYPNT,K), 1, DWORK(IY), 1 ) IY = IY + NOBS 120 CONTINUE C C Compress the data using a special QR factorization. C Workspace: need v + y, C where v = s*L*(r + 1) + b + c + w + x, C x = M, y = max( 2*r, M ), C if JOB = 'D' and M > 0, C x = 0, y = 2*r, if JOB = 'B' or M = 0. C IF ( M.GT.0 .AND. WITHD ) THEN C C Case 1: D is requested. C JWORK = ITAU IF ( FIRST ) THEN INI = INY + M C C Compress the first or single segment of U, U1 = Q1*R1. C Workspace: need v + M; C prefer v + M*NB. C CALL DGEQRF( NOBS, M, U, LDU, DWORK(ITAUU), DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) C ij C Apply diag(Q1') to the matrix [ y Gamma Y ]. C Workspace: need v + r + 1, C prefer v + (r + 1)*NB. C DO 130 K = 1, L CALL DORMQR( 'Left', 'Transpose', NOBS, NCP1, M, U, $ LDU, DWORK(ITAUU), DWORK(INY+(K-1)*NOBS), $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, $ IERR ) 130 CONTINUE C IF ( NCOL.GT.0 ) THEN C C Compress the first part of the first data segment of C ij C [ y Gamma ]. C Workspace: need v + 2*r, C prefer v + r + r*NB. C JWORK = ITAU + NCOL CALL DGEQRF( NOBS-M, NCOL, DWORK(INI), LDDW, $ DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) C C Apply the transformation to the corresponding right C hand side part. C Workspace: need v + r + 1, C prefer v + r + NB. C CALL DORMQR( 'Left', 'Transpose', NOBS-M, 1, NCOL, $ DWORK(INI), LDDW, DWORK(ITAU), $ DWORK(IRHS+M), LDDW, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) C C Compress the remaining parts of the first data segment C ij C of [ y Gamma ]. C Workspace: need v + r - 1. C DO 140 K = 2, L CALL MB04OD( 'Full', NCOL, 1, NOBS-M, DWORK(INI), $ LDDW, DWORK(INI+(K-1)*NOBS), LDDW, $ DWORK(IRHS+M), LDDW, $ DWORK(IRHS+M+(K-1)*NOBS), LDDW, $ DWORK(ITAU), DWORK(JWORK) ) 140 CONTINUE C END IF C IF ( NCYC ) THEN C ij C Save the triangular factor of [ y Gamma ], the C corresponding right hand side, and the first M rows C in each NOBS group of rows. C Workspace: need v. C CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INI), LDDW, $ DWORK(INIR), LDR ) C DO 150 K = 1, L CALL DLACPY( 'Full', M, NCP1, $ DWORK(INY +(K-1)*NOBS), LDDW, $ DWORK(INIS+(K-1)*M), LM ) 150 CONTINUE C END IF ELSE C C Compress the current data segment of U, Ui = Qi*Ri, C i = ICYCLE. C Workspace: need v + r + 1. C CALL MB04OD( 'Full', M, NCP1, NOBS, U, LDU, U(IUPNT,1), $ LDU, DWORK(INIS), LM, DWORK(INY), LDDW, $ DWORK(ITAUU), DWORK(JWORK) ) C C Apply diag(Qi') to the appropriate part of the matrix C ij C [ y Gamma Y ]. C Workspace: need v + r + 1. C DO 170 K = 2, L C DO 160 IX = 1, M CALL MB04OY( NOBS, NCP1, U(IUPNT,IX), $ DWORK(ITAUU+IX-1), $ DWORK(INIS+(K-1)*M+IX-1), LM, $ DWORK(INY+(K-1)*NOBS), LDDW, $ DWORK(JWORK) ) 160 CONTINUE C 170 CONTINUE C IF ( NCOL.GT.0 ) THEN C JWORK = ITAU + NCOL C C Compress the current (but not the first) data segment C ij C of [ y Gamma ]. C Workspace: need v + r - 1. C DO 180 K = 1, L CALL MB04OD( 'Full', NCOL, 1, NOBS, DWORK(INIR), $ LDR, DWORK(INY+(K-1)*NOBS), LDDW, $ DWORK(INIH), LDR, $ DWORK(IRHS+(K-1)*NOBS), LDDW, $ DWORK(ITAU), DWORK(JWORK) ) 180 CONTINUE C END IF END IF C ELSE IF ( NCOL.GT.0 ) THEN C C Case 2: D is known to be zero. C JWORK = ITAU + NCOL IF ( FIRST ) THEN C C Compress the first or single data segment of C ij C [ y Gamma ]. C Workspace: need v + 2*r, C prefer v + r + r*NB. C CALL DGEQRF( LDDW, NCOL, DWORK(INY), LDDW, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C C Apply the transformation to the right hand side. C Workspace: need v + r + 1, C prefer v + r + NB. C CALL DORMQR( 'Left', 'Transpose', LDDW, 1, NCOL, $ DWORK(INY), LDDW, DWORK(ITAU), DWORK(IRHS), $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, IERR ) IF ( NCYC ) THEN C ij C Save the triangular factor of [ y Gamma ] and the C corresponding right hand side. C Workspace: need v. C CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INY), LDDW, $ DWORK(INIR), LDR ) END IF ELSE C C Compress the current (but not the first) data segment. C Workspace: need v + r - 1. C CALL MB04OD( 'Full', NCOL, 1, LNOB, DWORK(INIR), LDR, $ DWORK(INY), LDDW, DWORK(INIH), LDR, $ DWORK(IRHS), LDDW, DWORK(ITAU), $ DWORK(JWORK) ) END IF END IF C IUPNT = IUPNT + NOBS IYPNT = IYPNT + NOBS 190 CONTINUE C C Estimate the reciprocal condition number of the triangular factor C of the QR decomposition. C Workspace: need u + 3*r, where C u = t*L*(r + 1), if NCYCLE = 1; C u = w, if NCYCLE > 1. C CALL DTRCON( '1-norm', 'Upper', 'No Transpose', NCOL, DWORK(INIR), $ LDR, RCOND, DWORK(IE), IWORK, IERR ) C TOLL = TOL IF ( TOLL.LE.ZERO ) $ TOLL = DLAMCH( 'Precision' ) IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN IWARN = 4 C C The least squares problem is ill-conditioned. C Use SVD to solve it. C Workspace: need u + 6*r; C prefer larger. C IF ( NCOL.GT.1 ) $ CALL DLASET( 'Lower', NCOL-1, NCOL-1, ZERO, ZERO, $ DWORK(INIR+1), LDR ) ISV = IE JWORK = ISV + NCOL CALL DGELSS( NCOL, NCOL, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) IF ( IERR.GT.0 ) THEN C C Return if SVD algorithm did not converge. C INFO = 2 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) ELSE C C Find the least squares solution using QR decomposition only. C CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', NCOL, $ 1, ONE, DWORK(INIR), LDR, DWORK(INIH), LDR ) END IF C C Setup the estimated n-by-m input matrix B, and the estimated C initial state of the system x0. C CALL DLACPY( 'Full', N, M, DWORK(INIH), N, B, LDB ) C IF ( N.GT.0 .AND. WITHX0 ) THEN CALL DCOPY( N, DWORK(INIH+NM), 1, X0, 1 ) ELSE CALL DCOPY( N, DUM, 0, X0, 1 ) END IF C IF ( M.GT.0 .AND. WITHD ) THEN C C Compute the estimated l-by-m input/output matrix D. C IF ( NCYC ) THEN IRHS = INIS + LM*NCOL CALL DGEMV( 'No Transpose', LM, NCOL, -ONE, DWORK(INIS), $ LM, DWORK(INIH), 1, ONE, DWORK(IRHS), 1 ) ELSE C DO 200 K = 1, L CALL DGEMV( 'No Transpose', M, NCOL, -ONE, $ DWORK(INIS+(K-1)*NOBS), LDDW, DWORK(INIH), 1, $ ONE, DWORK(IRHS+(K-1)*NOBS), 1 ) 200 CONTINUE C DO 210 K = 2, L CALL DCOPY( M, DWORK(IRHS+(K-1)*NOBS), 1, $ DWORK(IRHS+(K-1)*M), 1 ) 210 CONTINUE C END IF C C Estimate the reciprocal condition number of the triangular C factor of the QR decomposition of the matrix U. C Workspace: need u + 3*M. C CALL DTRCON( '1-norm', 'Upper', 'No Transpose', M, U, LDU, $ RCONDU, DWORK(IE), IWORK, IERR ) IF ( RCONDU.LE.TOLL**( TWO/THREE ) ) THEN IWARN = 4 C C The least squares problem is ill-conditioned. C Use SVD to solve it. (QR decomposition of U is preserved.) C Workspace: need u + 2*M*M + 6*M; C prefer larger. C IQ = IE + M*M ISV = IQ + M*M JWORK = ISV + M CALL DLACPY( 'Upper', M, M, U, LDU, DWORK(IE), M ) CALL MB02UD( 'Not Factored', 'Left', 'No Transpose', $ 'No Pinv', M, L, ONE, TOLL, RANK, DWORK(IE), $ M, DWORK(IQ), M, DWORK(ISV), DWORK(IRHS), M, $ DUM, 1, DWORK(JWORK), LDWORK-JWORK+1, IERR ) IF ( IERR.GT.0 ) THEN C C Return if SVD algorithm did not converge. C INFO = 2 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) ELSE CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', M, $ L, ONE, U, LDU, DWORK(IRHS), M ) END IF CALL MA02AD( 'Full', M, L, DWORK(IRHS), M, D, LDD ) C END IF C DWORK(1) = MAXWRK DWORK(2) = RCOND IF ( M.GT.0 .AND. WITHD ) $ DWORK(3) = RCONDU C RETURN C C *** End of IB01QD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB08NY.f0000644000000000000000000000013215012430707016220 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB08NY.f0000644000175000017500000000337515012430707017424 0ustar00lilgelilge00000000000000 SUBROUTINE SB08NY( DA, A, B, EPSB ) C C PURPOSE C C To compute the coefficients of B(z) = A(1/z) * A(z) and a norm for C the accuracy of the computed coefficients. C C ARGUMENTS C C Input/Output Parameters C C DA (input) INTEGER C The degree of the polynomials A(z) and B(z). DA >= 0. C C A (input) DOUBLE PRECISION array, dimension (DA+1) C This array must contain the coefficients of the polynomial C A(z) in increasing powers of z. C C B (output) DOUBLE PRECISION array, dimension (DA+1) C This array contains the coefficients of the polynomial C B(z). C C EPSB (output) DOUBLE PRECISION C A value used for checking the accuracy of the computed C coefficients. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB08BZ by A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Laplace transform, polynomial operations, spectral factorization. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION THREE PARAMETER ( THREE = 3.0D0 ) C .. Scalar Arguments .. INTEGER DA DOUBLE PRECISION EPSB C .. Array Arguments .. DOUBLE PRECISION A(*), B(*) C .. Local Scalars .. INTEGER I C .. External Functions .. DOUBLE PRECISION DDOT, DLAMCH EXTERNAL DDOT, DLAMCH C .. Executable Statements .. C DO 20 I = 1, DA + 1 B(I) = DDOT( DA-I+2, A(1), 1, A(I), 1 ) 20 CONTINUE C EPSB = THREE*DLAMCH( 'Epsilon' )*B(1) C RETURN C *** Last line of SB08NY *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01CD.f0000644000000000000000000000013215012430707016137 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/IB01CD.f0000644000175000017500000010301315012430707017331 0ustar00lilgelilge00000000000000 SUBROUTINE IB01CD( JOBX0, COMUSE, JOB, N, M, L, NSMP, A, LDA, B, $ LDB, C, LDC, D, LDD, U, LDU, Y, LDY, X0, V, $ LDV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To estimate the initial state and, optionally, the system matrices C B and D of a linear time-invariant (LTI) discrete-time system, C given the system matrices (A,B,C,D), or (when B and D are C estimated) only the matrix pair (A,C), and the input and output C trajectories of the system. The model structure is : C C x(k+1) = Ax(k) + Bu(k), k >= 0, C y(k) = Cx(k) + Du(k), C C where x(k) is the n-dimensional state vector (at time k), C u(k) is the m-dimensional input vector, C y(k) is the l-dimensional output vector, C and A, B, C, and D are real matrices of appropriate dimensions. C The input-output data can internally be processed sequentially. C C ARGUMENTS C C Mode Parameters C C JOBX0 CHARACTER*1 C Specifies whether or not the initial state should be C computed, as follows: C = 'X': compute the initial state x(0); C = 'N': do not compute the initial state (possibly, C because x(0) is known to be zero). C C COMUSE CHARACTER*1 C Specifies whether the system matrices B and D should be C computed or used, as follows: C = 'C': compute the system matrices B and D, as specified C by JOB; C = 'U': use the system matrices B and D, as specified by C JOB; C = 'N': do not compute/use the matrices B and D. C If JOBX0 = 'N' and COMUSE <> 'N', then x(0) is set C to zero. C If JOBX0 = 'N' and COMUSE = 'N', then x(0) is C neither computed nor set to zero. C C JOB CHARACTER*1 C If COMUSE = 'C' or 'U', specifies which of the system C matrices B and D should be computed or used, as follows: C = 'B': compute/use the matrix B only (D is known to be C zero); C = 'D': compute/use the matrices B and D. C The value of JOB is irrelevant if COMUSE = 'N' or if C JOBX0 = 'N' and COMUSE = 'U'. C The combinations of options, the data used, and the C returned results, are given in the table below, where C '*' denotes an irrelevant value. C C JOBX0 COMUSE JOB Data used Returned results C ---------------------------------------------------------- C X C B A,C,u,y x,B C X C D A,C,u,y x,B,D C N C B A,C,u,y x=0,B C N C D A,C,u,y x=0,B,D C ---------------------------------------------------------- C X U B A,B,C,u,y x C X U D A,B,C,D,u,y x C N U * - x=0 C ---------------------------------------------------------- C X N * A,C,y x C N N * - - C ---------------------------------------------------------- C C For JOBX0 = 'N' and COMUSE = 'N', the routine just C sets DWORK(1) to 2 and DWORK(2) to 1, and returns C (see the parameter DWORK). 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 number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L > 0. C C NSMP (input) INTEGER C The number of rows of matrices U and Y (number of C samples, t). C NSMP >= 0, if JOBX0 = 'N' and COMUSE <> 'C'; C NSMP >= N, if JOBX0 = 'X' and COMUSE <> 'C'; C NSMP >= N*M + a + e, if COMUSE = 'C', C where a = 0, if JOBX0 = 'N'; C a = N, if JOBX0 = 'X'; C e = 0, if JOBX0 = 'X' and JOB = 'B'; C e = 1, if JOBX0 = 'N' and JOB = 'B'; C e = M, if JOB = 'D'. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C If JOBX0 = 'X' or COMUSE = 'C', the leading N-by-N C part of this array must contain the system state matrix A. C If N = 0, or JOBX0 = 'N' and COMUSE <> 'C', this C array is not referenced. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,N), if JOBX0 = 'X' or COMUSE = 'C'; C LDA >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. C C B (input or output) DOUBLE PRECISION array, dimension C (LDB,M) C If JOBX0 = 'X' and COMUSE = 'U', B is an input C parameter and, on entry, the leading N-by-M part of this C array must contain the system input matrix B. C If COMUSE = 'C', B is an output parameter and, on exit, C if INFO = 0, the leading N-by-M part of this array C contains the estimated system input matrix B. C If min(N,M) = 0, or JOBX0 = 'N' and COMUSE = 'U', C or COMUSE = 'N', this array is not referenced. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N), if M > 0, COMUSE = 'U', JOBX0 = 'X', C or M > 0, COMUSE = 'C'; C LDB >= 1, if min(N,M) = 0, or COMUSE = 'N', C or JOBX0 = 'N' and COMUSE = 'U'. C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C If JOBX0 = 'X' or COMUSE = 'C', the leading L-by-N C part of this array must contain the system output C matrix C. C If N = 0, or JOBX0 = 'N' and COMUSE <> 'C', this C array is not referenced. C C LDC INTEGER C The leading dimension of the array C. C LDC >= L, if N > 0, and JOBX0 = 'X' or COMUSE = 'C'; C LDC >= 1, if N = 0, or JOBX0 = 'N' and COMUSE <> 'C'. C C D (input or output) DOUBLE PRECISION array, dimension C (LDD,M) C If JOBX0 = 'X', COMUSE = 'U', and JOB = 'D', D is an C input parameter and, on entry, the leading L-by-M part of C this array must contain the system input-output matrix D. C If COMUSE = 'C' and JOB = 'D', D is an output C parameter and, on exit, if INFO = 0, the leading C L-by-M part of this array contains the estimated system C input-output matrix D. C If M = 0, or JOBX0 = 'N' and COMUSE = 'U', or C COMUSE = 'N', or JOB = 'B', this array is not C referenced. C C LDD INTEGER C The leading dimension of the array D. C LDD >= L, if M > 0, JOBX0 = 'X', COMUSE = 'U', and C JOB = 'D', or C if M > 0, COMUSE = 'C', and JOB = 'D'; C LDD >= 1, if M = 0, or JOBX0 = 'N' and COMUSE = 'U', C or COMUSE = 'N', or JOB = 'B'. C C U (input or input/output) DOUBLE PRECISION array, dimension C (LDU,M) C On entry, if COMUSE = 'C', or JOBX0 = 'X' and C COMUSE = 'U', the leading NSMP-by-M part of this array C must contain the t-by-m input-data sequence matrix U, C U = [u_1 u_2 ... u_m]. Column j of U contains the C NSMP values of the j-th input component for consecutive C time increments. C On exit, if COMUSE = 'C' and JOB = 'D', the leading C NSMP-by-M part of this array contains details of the C QR factorization of the t-by-m matrix U, possibly C computed sequentially (see METHOD). C If COMUSE = 'C' and JOB = 'B', or COMUSE = 'U', this C array is unchanged on exit. C If M = 0, or JOBX0 = 'N' and COMUSE = 'U', or C COMUSE = 'N', this array is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= MAX(1,NSMP), if M > 0 and COMUSE = 'C' or C JOBX0 = 'X' and COMUSE = 'U; C LDU >= 1, if M = 0, or COMUSE = 'N', or C JOBX0 = 'N' and COMUSE = 'U'. C C Y (input) DOUBLE PRECISION array, dimension (LDY,L) C On entry, if JOBX0 = 'X' or COMUSE = 'C', the leading C NSMP-by-L part of this array must contain the t-by-l C output-data sequence matrix Y, Y = [y_1 y_2 ... y_l]. C Column j of Y contains the NSMP values of the j-th C output component for consecutive time increments. C If JOBX0 = 'N' and COMUSE <> 'C', this array is not C referenced. C C LDY INTEGER C The leading dimension of the array Y. C LDY >= MAX(1,NSMP), if JOBX0 = 'X' or COMUSE = 'C; C LDY >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. C C X0 (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0 and JOBX0 = 'X', this array contains the C estimated initial state of the system, x(0). C If JOBX0 = 'N' and COMUSE = 'C', this array is used as C workspace and finally it is set to zero. C If JOBX0 = 'N' and COMUSE = 'U', then x(0) is set to C zero without any calculations. C If JOBX0 = 'N' and COMUSE = 'N', this array is not C referenced. C C V (output) DOUBLE PRECISION array, dimension (LDV,N) C On exit, if INFO = 0 or 2, JOBX0 = 'X' or C COMUSE = 'C', the leading N-by-N part of this array C contains the orthogonal matrix V of a real Schur C factorization of the matrix A. C If JOBX0 = 'N' and COMUSE <> 'C', this array is not C referenced. C C LDV INTEGER C The leading dimension of the array V. C LDV >= MAX(1,N), if JOBX0 = 'X' or COMUSE = 'C; C LDV >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used for estimating the rank of C matrices. If the user sets TOL > 0, then the given value C of TOL is used as a lower bound for the reciprocal C condition number; a matrix whose estimated condition C number is less than 1/TOL is considered to be of full C rank. If the user sets TOL <= 0, then EPS is used C instead, where EPS is the relative machine precision C (see LAPACK Library routine DLAMCH). TOL <= 1. C C Workspace C C IWORK INTEGER array, dimension (LIWORK), where C LIWORK >= 0, if JOBX0 = 'N' and COMUSE <> 'C'; C LIWORK >= N, if JOBX0 = 'X' and COMUSE <> 'C'; C LIWORK >= N*M + a, if COMUSE = 'C' and JOB = 'B', C LIWORK >= max(N*M + a,M), if COMUSE = 'C' and JOB = 'D', C with a = 0, if JOBX0 = 'N'; C a = N, if JOBX0 = 'X'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK; DWORK(2) contains the reciprocal condition C number of the triangular factor of the QR factorization of C the matrix W2, if COMUSE = 'C', or of the matrix C Gamma, if COMUSE = 'U' (see METHOD); if JOBX0 = 'N' C and COMUSE <> 'C', DWORK(2) is set to one; C if COMUSE = 'C', M > 0, and JOB = 'D', DWORK(3) C contains the reciprocal condition number of the triangular C factor of the QR factorization of U; denoting C g = 2, if JOBX0 = 'X' and COMUSE <> 'C' or C COMUSE = 'C' and M = 0 or JOB = 'B', C g = 3, if COMUSE = 'C' and M > 0 and JOB = 'D', C then DWORK(i), i = g+1:g+N*N, C DWORK(j), j = g+1+N*N:g+N*N+L*N, and C DWORK(k), k = g+1+N*N+L*N:g+N*N+L*N+N*M, C contain the transformed system matrices At, Ct, and Bt, C respectively, corresponding to the real Schur form of the C given system state matrix A, i.e., C At = V'*A*V, Bt = V'*B, Ct = C*V. C The matrices At, Ct, Bt are not computed if JOBX0 = 'N' C and COMUSE <> 'C'. C On exit, if INFO = -26, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 2, if JOBX0 = 'N' and COMUSE <> 'C', or C if max( N, M ) = 0. C Otherwise, C LDWORK >= LDW1 + N*( N + M + L ) + C max( 5*N, LDW1, min( LDW2, LDW3 ) ), C where, if COMUSE = 'C', then C LDW1 = 2, if M = 0 or JOB = 'B', C LDW1 = 3, if M > 0 and JOB = 'D', C LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ), C LDW2 = LDWa, if M = 0 or JOB = 'B', C LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ), C if M > 0 and JOB = 'D', C LDWb = (b + r)*(r + 1) + C max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ), C LDW3 = LDWb, if M = 0 or JOB = 'B', C LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ), C if M > 0 and JOB = 'D', C r = N*M + a, C a = 0, if JOBX0 = 'N', C a = N, if JOBX0 = 'X'; C b = 0, if JOB = 'B', C b = L*M, if JOB = 'D'; C c = 0, if JOBX0 = 'N', C c = L*N, if JOBX0 = 'X'; C d = 0, if JOBX0 = 'N', C d = 2*N*N + N, if JOBX0 = 'X'; C f = 2*r, if JOB = 'B' or M = 0, C f = M + max( 2*r, M ), if JOB = 'D' and M > 0; C q = b + r*L; C and, if JOBX0 = 'X' and COMUSE <> 'C', then C LDW1 = 2, C LDW2 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ), C LDW3 = N*(N + 1) + 2*N + max( q*(N + 1) + 2*N*N + L*N, C 4*N ), C q = N*L. C For good performance, LDWORK should be larger. C If LDWORK >= LDW2, or if COMUSE = 'C' and C LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + C max( d, f ), C then standard QR factorizations of the matrices U and/or C W2, if COMUSE = 'C', or of the matrix Gamma, if C JOBX0 = 'X' and COMUSE <> 'C' (see METHOD), are used. C Otherwise, the QR factorizations are computed sequentially C by performing NCYCLE cycles, each cycle (except possibly C the last one) processing s < t samples, where s is C chosen by equating LDWORK to the first term of LDWb, C if COMUSE = 'C', or of LDW3, if COMUSE <> 'C', for C q replaced by s*L. (s is larger than or equal to the C minimum value of NSMP.) The computational effort may C increase and the accuracy may slightly decrease with the C decrease of s. Recommended value is LDWORK = LDW2, C assuming a large enough cache size, to also accommodate C A, (B,) C, (D,) U, and Y. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 4: the least squares problem to be solved has a C rank-deficient coefficient matrix; C = 6: the matrix A is unstable; the estimated x(0) C and/or B and D could be inaccurate. C NOTE: the value 4 of IWARN has no significance for the C identification problem. 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 QR algorithm failed to compute all the C eigenvalues of the matrix A (see LAPACK Library C routine DGEES); the locations DWORK(i), for C i = g+1:g+N*N, contain the partially converged C Schur form; C = 2: the singular value decomposition (SVD) algorithm did C not converge. C C METHOD C C Matrix A is initially reduced to a real Schur form, A = V*At*V', C and the given system matrices are transformed accordingly. For the C reduced system, an extension and refinement of the method in [1,2] C is used. Specifically, for JOBX0 = 'X', COMUSE = 'C', and C JOB = 'D', denoting C C X = [ vec(D')' vec(B)' x0' ]', C C where vec(M) is the vector obtained by stacking the columns of C the matrix M, then X is the least squares solution of the C system S*X = vec(Y), with the matrix S = [ diag(U) W ], C defined by C C ( U | | ... | | | ... | | ) C ( U | 11 | ... | n1 | 12 | ... | nm | ) C S = ( : | y | ... | y | y | ... | y | P*Gamma ), C ( : | | ... | | | ... | | ) C ( U | | ... | | | ... | | ) C ij C diag(U) having L block rows and columns. In this formula, y C are the outputs of the system for zero initial state computed C using the following model, for j = 1:m, and for i = 1:n, C ij ij ij C x (k+1) = Ax (k) + e_i u_j(k), x (0) = 0, C C ij ij C y (k) = Cx (k), C C where e_i is the i-th n-dimensional unit vector, Gamma is C given by C C ( C ) C ( C*A ) C Gamma = ( C*A^2 ), C ( : ) C ( C*A^(t-1) ) C C and P is a permutation matrix that groups together the rows of C Gamma depending on the same row of C, namely C [ c_j; c_j*A; c_j*A^2; ... c_j*A^(t-1) ], for j = 1:L. C The first block column, diag(U), is not explicitly constructed, C but its structure is exploited. The last block column is evaluated C using powers of A with exponents 2^k. No interchanges are applied. C A special QR decomposition of the matrix S is computed. Let C U = q*[ r' 0 ]' be the QR decomposition of U, if M > 0, where C r is M-by-M. Then, diag(q') is applied to W and vec(Y). C The block-rows of S and vec(Y) are implicitly permuted so that C matrix S becomes C C ( diag(r) W1 ) C ( 0 W2 ), C C where W1 has L*M rows. Then, the QR decomposition of W2 is C computed (sequentially, if M > 0) and used to obtain B and x0. C The intermediate results and the QR decomposition of U are C needed to find D. If a triangular factor is too ill conditioned, C then singular value decomposition (SVD) is employed. SVD is not C generally needed if the input sequence is sufficiently C persistently exciting and NSMP is large enough. C If the matrix W cannot be stored in the workspace (i.e., C LDWORK < LDW2), the QR decompositions of W2 and U are C computed sequentially. C For JOBX0 = 'N' and COMUSE = 'C', or JOB = 'B', a simpler C problem is solved efficiently. C C For JOBX0 = 'X' and COMUSE <> 'C', a simpler method is used. C Specifically, the output y0(k) of the system for zero initial C state is computed for k = 0, 1, ..., t-1 using the given model. C Then the following least squares problem is solved for x(0) C C ( y(0) - y0(0) ) C ( y(1) - y0(1) ) C Gamma * x(0) = ( : ). C ( : ) C ( y(t-1) - y0(t-1) ) C C The coefficient matrix Gamma is evaluated using powers of A with C exponents 2^k. The QR decomposition of this matrix is computed. C If its triangular factor R is too ill conditioned, then singular C value decomposition of R is used. C If the coefficient matrix cannot be stored in the workspace (i.e., C LDWORK < LDW2), the QR decomposition is computed sequentially. C C C REFERENCES C C [1] Verhaegen M., and Varga, A. C Some Experience with the MOESP Class of Subspace Model C Identification Methods in Identifying the BO105 Helicopter. C Report TR R165-94, DLR Oberpfaffenhofen, 1994. C C [2] Sima, V., and Varga, A. C RASP-IDENT : Subspace Model Identification Programs. C Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V., C Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C C FURTHER COMMENTS C C The algorithm for computing the system matrices B and D is C less efficient than the MOESP or N4SID algorithms implemented in C SLICOT Library routines IB01BD/IB01PD, because a large least C squares problem has to be solved, but the accuracy is better, as C the computed matrices B and D are fitted to the input and C output trajectories. However, if matrix A is unstable, the C computed matrices B and D could be inaccurate. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. C C REVISIONS C C - C C KEYWORDS C C Identification methods; least squares solutions; multivariable C systems; QR decomposition; singular value decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, LDV, $ LDWORK, LDY, M, N, NSMP CHARACTER COMUSE, JOB, JOBX0 C .. Array Arguments .. DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), $ DWORK(*), U(LDU, *), V(LDV, *), X0(*), $ Y(LDY, *) INTEGER IWORK(*) C .. Local Scalars .. DOUBLE PRECISION RCOND, RCONDU INTEGER I, IA, IB, IC, IERR, IQ, ISIZE, ITAU, IWARNL, $ IWI, IWR, JWORK, LDW, LDW2, LDW3, LM, LN, $ MAXWRK, MINSMP, MINWLS, MINWRK, MTMP, N2M, $ NCOL, NCP1, NM, NN, NSMPL LOGICAL COMPBD, USEBD, MAXDIA, MAXDIM, WITHB, WITHD, $ WITHX0 CHARACTER JOBD C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2, ILAENV, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, IB01QD, IB01RD, $ TB01WD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C C Check the input parameters. C WITHX0 = LSAME( JOBX0, 'X' ) COMPBD = LSAME( COMUSE, 'C' ) USEBD = LSAME( COMUSE, 'U' ) WITHD = LSAME( JOB, 'D' ) WITHB = LSAME( JOB, 'B' ) .OR. WITHD MAXDIM = ( WITHX0 .AND. USEBD ) .OR. COMPBD MAXDIA = WITHX0 .OR. COMPBD C IWARN = 0 INFO = 0 LDW = MAX( 1, N ) LM = L*M LN = L*N NN = N*N NM = N*M N2M = N*NM IF( COMPBD ) THEN NCOL = NM IF( WITHX0 ) $ NCOL = NCOL + N MINSMP = NCOL IF( WITHD ) THEN MINSMP = MINSMP + M IQ = MINSMP ELSE IF ( .NOT.WITHX0 ) THEN IQ = MINSMP MINSMP = MINSMP + 1 ELSE IQ = MINSMP END IF ELSE NCOL = N IF( WITHX0 ) THEN MINSMP = N ELSE MINSMP = 0 END IF IQ = MINSMP END IF C IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( COMPBD .OR. USEBD .OR. LSAME( COMUSE, 'N' ) ) ) $ THEN INFO = -2 ELSE IF( .NOT.WITHB ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( L.LE.0 ) THEN INFO = -6 ELSE IF( NSMP.LT.MINSMP ) THEN INFO = -7 ELSE IF( LDA.LT.1 .OR. ( MAXDIA .AND. LDA.LT.LDW ) ) THEN INFO = -9 ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDB.LT.LDW ) ) $ THEN INFO = -11 ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. MAXDIA .AND. LDC.LT.L ) ) $ THEN INFO = -13 ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. WITHD .AND. $ LDD.LT.L ) ) THEN INFO = -15 ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDU.LT.NSMP ) ) $ THEN INFO = -17 ELSE IF( LDY.LT.1 .OR. ( MAXDIA .AND. LDY.LT.NSMP ) ) THEN INFO = -19 ELSE IF( LDV.LT.1 .OR. ( MAXDIA .AND. LDV.LT.LDW ) ) THEN INFO = -22 ELSE IF( TOL.GT.ONE ) THEN INFO = -23 END IF C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN MINWRK = 2 ELSE NSMPL = NSMP*L IQ = IQ*L NCP1 = NCOL + 1 ISIZE = NSMPL*NCP1 IF ( COMPBD ) THEN IF ( N.GT.0 .AND. WITHX0 ) THEN IC = 2*NN + N ELSE IC = 0 END IF ELSE IC = 2*NN END IF MINWLS = NCOL*NCP1 IF ( COMPBD ) THEN IF ( WITHD ) $ MINWLS = MINWLS + LM*NCP1 IF ( M.GT.0 .AND. WITHD ) THEN IA = M + MAX( 2*NCOL, M ) ELSE IA = 2*NCOL END IF ITAU = N2M + MAX( IC, IA ) IF ( WITHX0 ) $ ITAU = ITAU + LN LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) IF ( M.GT.0 .AND. WITHD ) THEN LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) IA = 3 ELSE IA = 2 END IF ELSE ITAU = IC + LN LDW2 = ISIZE + 2*N + MAX( IC, 4*N ) LDW3 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N ) IA = 2 END IF MINWRK = IA + NN + NM + LN + MAX( 5*N, IA, MIN( LDW2, LDW3 ) ) C IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN MAXWRK = MAX( 5*N, IA ) IF ( COMPBD ) THEN IF ( M.GT.0 .AND. WITHD ) THEN MAXWRK = MAX( MAXWRK, ISIZE + N + M + $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, $ M, -1, -1 ), $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', $ ' ', NSMP-M, NCOL, -1, -1 ) ) ) MAXWRK = MAX( MAXWRK, ISIZE + N + M + $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', $ NSMP, NCP1, M, -1 ), $ NCOL + ILAENV( 1, 'DORMQR', 'LT', $ NSMP-M, 1, NCOL, -1 ) ) ) ELSE MAXWRK = MAX( MAXWRK, ISIZE + N + NCOL + $ MAX( NCOL*ILAENV( 1, 'DGEQRF', $ ' ', NSMPL, NCOL, -1, -1 ), $ ILAENV( 1, 'DORMQR', 'LT', $ NSMPL, 1, NCOL, -1 ) ) ) END IF ELSE MAXWRK = MAX( MAXWRK, ISIZE + 2*N + $ MAX( N*ILAENV( 1, 'DGEQRF', ' ', $ NSMPL, N, -1, -1 ), $ ILAENV( 1, 'DORMQR', 'LT', $ NSMPL, 1, N, -1 ) ) ) END IF MAXWRK = IA + NN + NM + LN + MAXWRK MAXWRK = MAX( MAXWRK, MINWRK ) END IF END IF C IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN INFO = -26 DWORK(1) = MINWRK END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB01CD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN DWORK(2) = ONE IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) THEN DWORK(1) = THREE DWORK(3) = ONE ELSE DWORK(1) = TWO END IF IF ( N.GT.0 .AND. USEBD ) THEN DUM(1) = ZERO CALL DCOPY( N, DUM, 0, X0, 1 ) END IF RETURN END IF C C Compute the Schur factorization of A and transform the other C given system matrices accordingly. C Workspace: need g + N*N + L*N + N*M + 5*N, where C g = 2, if M = 0, COMUSE = 'C', or JOB = 'B', C g = 3, if M > 0, COMUSE = 'C', and JOB = 'D', C g = 2, if JOBX0 = 'X' and COMUSE <> 'C'; C prefer larger. C IA = IA + 1 IC = IA + NN IB = IC + LN CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), LDW ) CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IC), L ) C IF ( USEBD ) THEN MTMP = M CALL DLACPY( 'Full', N, M, B, LDB, DWORK(IB), LDW ) ELSE MTMP = 0 END IF IWR = IB + NM IWI = IWR + N JWORK = IWI + N C CALL TB01WD( N, MTMP, L, DWORK(IA), LDW, DWORK(IB), LDW, $ DWORK(IC), L, V, LDV, DWORK(IWR), DWORK(IWI), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) IF( IERR.GT.0 ) THEN INFO = 1 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) C DO 10 I = IWR, IWI - 1 IF( DLAPY2( DWORK(I), DWORK(I+N) ).GE.ONE ) $ IWARN = 6 10 CONTINUE C JWORK = IWR C C Estimate x(0) and/or the system matrices B and D. C Workspace: need g + N*N + L*N + N*M + C max( g, min( LDW2, LDW3 ) ) (see LDWORK); C prefer larger. C IF ( COMPBD ) THEN CALL IB01QD( JOBX0, JOB, N, M, L, NSMP, DWORK(IA), LDW, $ DWORK(IC), L, U, LDU, Y, LDY, X0, DWORK(IB), LDW, $ D, LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, $ IWARNL, INFO ) C IF( INFO.EQ.0 ) THEN IF ( M.GT.0 .AND. WITHD ) $ RCONDU = DWORK(JWORK+2) C C Compute the system input matrix B corresponding to the C original system. C CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, N, ONE, $ V, LDV, DWORK(IB), LDW, ZERO, B, LDB ) END IF ELSE IF ( WITHD ) THEN JOBD = 'N' ELSE JOBD = 'Z' END IF C CALL IB01RD( JOBD, N, MTMP, L, NSMP, DWORK(IA), LDW, DWORK(IB), $ LDW, DWORK(IC), L, D, LDD, U, LDU, Y, LDY, X0, $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARNL, $ INFO ) END IF IWARN = MAX( IWARN, IWARNL ) C IF( INFO.EQ.0 ) THEN RCOND = DWORK(JWORK+1) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) IF( WITHX0 ) THEN C C Transform the initial state estimate to obtain the initial C state corresponding to the original system. C Workspace: need g + N*N + L*N + N*M + N. C CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, X0, 1, ZERO, $ DWORK(JWORK), 1 ) CALL DCOPY( N, DWORK(JWORK), 1, X0, 1 ) END IF C DWORK(1) = MAXWRK DWORK(2) = RCOND IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) $ DWORK(3) = RCONDU END IF RETURN C C *** End of IB01CD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB05ND.f0000644000000000000000000000013215012430707016146 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB05ND.f0000644000175000017500000004330715012430707017351 0ustar00lilgelilge00000000000000 SUBROUTINE AB05ND( OVER, N1, M1, P1, N2, ALPHA, A1, LDA1, B1, $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, $ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, $ D, LDD, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To obtain the state-space model (A,B,C,D) for the feedback C inter-connection of two systems, each given in state-space form. C C ARGUMENTS C C Mode Parameters C C OVER CHARACTER*1 C Indicates whether the user wishes to overlap pairs of C arrays, as follows: C = 'N': Do not overlap; C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, C C1 and C, and D1 and D, i.e. the same name is C effectively used for each pair (for all pairs) C in the routine call. In this case, setting C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD C will give maximum efficiency. C C Input/Output Parameters C C N1 (input) INTEGER C The number of state variables in the first system, i.e. C the order of the matrix A1. N1 >= 0. C C M1 (input) INTEGER C The number of input variables for the first system and the C number of output variables from the second system. C M1 >= 0. C C P1 (input) INTEGER C The number of output variables from the first system and C the number of input variables for the second system. C P1 >= 0. C C N2 (input) INTEGER C The number of state variables in the second system, i.e. C the order of the matrix A2. N2 >= 0. C C ALPHA (input) DOUBLE PRECISION C A coefficient multiplying the transfer-function matrix C (or the output equation) of the second system. C ALPHA = +1 corresponds to positive feedback, and C ALPHA = -1 corresponds to negative feedback. C C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) C The leading N1-by-N1 part of this array must contain the C state transition matrix A1 for the first system. C C LDA1 INTEGER C The leading dimension of array A1. LDA1 >= MAX(1,N1). C C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) C The leading N1-by-M1 part of this array must contain the C input/state matrix B1 for the first system. C C LDB1 INTEGER C The leading dimension of array B1. LDB1 >= MAX(1,N1). C C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) C The leading P1-by-N1 part of this array must contain the C state/output matrix C1 for the first system. C C LDC1 INTEGER C The leading dimension of array C1. C LDC1 >= MAX(1,P1) if N1 > 0. C LDC1 >= 1 if N1 = 0. C C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) C The leading P1-by-M1 part of this array must contain the C input/output matrix D1 for the first system. C C LDD1 INTEGER C The leading dimension of array D1. LDD1 >= MAX(1,P1). C C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) C The leading N2-by-N2 part of this array must contain the C state transition matrix A2 for the second system. C C LDA2 INTEGER C The leading dimension of array A2. LDA2 >= MAX(1,N2). C C B2 (input) DOUBLE PRECISION array, dimension (LDB2,P1) C The leading N2-by-P1 part of this array must contain the C input/state matrix B2 for the second system. C C LDB2 INTEGER C The leading dimension of array B2. LDB2 >= MAX(1,N2). C C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) C The leading M1-by-N2 part of this array must contain the C state/output matrix C2 for the second system. C C LDC2 INTEGER C The leading dimension of array C2. C LDC2 >= MAX(1,M1) if N2 > 0. C LDC2 >= 1 if N2 = 0. C C D2 (input) DOUBLE PRECISION array, dimension (LDD2,P1) C The leading M1-by-P1 part of this array must contain the C input/output matrix D2 for the second system. C C LDD2 INTEGER C The leading dimension of array D2. LDD2 >= MAX(1,M1). C C N (output) INTEGER C The number of state variables (N1 + N2) in the connected C system, i.e. the order of the matrix A, the number of rows C of B and the number of columns of C. C C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) C The leading N-by-N part of this array contains the state C transition matrix A for the connected system. C The array A can overlap A1 if OVER = 'O'. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N1+N2). C C B (output) DOUBLE PRECISION array, dimension (LDB,M1) C The leading N-by-M1 part of this array contains the C input/state matrix B for the connected system. C The array B can overlap B1 if OVER = 'O'. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N1+N2). C C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) C The leading P1-by-N part of this array contains the C state/output matrix C for the connected system. C The array C can overlap C1 if OVER = 'O'. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,P1) if N1+N2 > 0. C LDC >= 1 if N1+N2 = 0. C C D (output) DOUBLE PRECISION array, dimension (LDD,M1) C The leading P1-by-M1 part of this array contains the C input/output matrix D for the connected system. C The array D can overlap D1 if OVER = 'O'. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P1). C C Workspace C C IWORK INTEGER array, dimension (P1) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. If OVER = 'N', C LDWORK >= MAX(1, P1*P1, M1*M1, N1*P1), and if OVER = 'O', C LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*M1, N1*P1) ), C if M1 <= N*N2; C LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*(M1+1), N1*P1) ), C if M1 > N*N2. 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 <= P1, the system is not C completely controllable. That is, the matrix C (I + ALPHA*D1*D2) is exactly singular (the element C U(i,i) of the upper triangular factor of LU C factorization is exactly zero), possibly due to C rounding errors. C C METHOD C C After feedback inter-connection of the two systems, C C X1' = A1*X1 + B1*U1 C Y1 = C1*X1 + D1*U1 C C X2' = A2*X2 + B2*U2 C Y2 = C2*X2 + D2*U2 C C (where ' denotes differentiation with respect to time) C C the following state-space model will be obtained: C C X' = A*X + B*U C Y = C*X + D*U C C where U = U1 + alpha*Y2, X = ( X1 ), C Y = Y1 = U2, ( X2 ) C C matrix A has the form C C ( A1 - alpha*B1*E12*D2*C1 - alpha*B1*E12*C2 ), C ( B2*E21*C1 A2 - alpha*B2*E21*D1*C2 ) C C matrix B has the form C C ( B1*E12 ), C ( B2*E21*D1 ) C C matrix C has the form C C ( E21*C1 - alpha*E21*D1*C2 ), C C matrix D has the form C C ( E21*D1 ), C C E21 = ( I + alpha*D1*D2 )-INVERSE and C E12 = ( I + alpha*D2*D1 )-INVERSE = I - alpha*D2*E21*D1. C C Taking N1 = 0 and/or N2 = 0 on the routine call will solve the C constant plant and/or constant feedback cases. C C REFERENCES C C None C C NUMERICAL ASPECTS C C None C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. C Supersedes Release 2.0 routine AB05BD by C.J.Benson, Kingston C Polytechnic, United Kingdom, January 1982. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 2003, C Feb. 2004. C C KEYWORDS C C Continuous-time system, multivariable system, state-space model, C state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO=0.0D0, ONE=1.0D0 ) C .. Scalar Arguments .. CHARACTER OVER INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, $ LDC1, LDC2, LDD, LDD1, LDD2, LDWORK, M1, N, N1, $ N2, P1 DOUBLE PRECISION ALPHA C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*), $ DWORK(*) C .. Local Scalars .. LOGICAL LOVER INTEGER I, J, LDW, LDWM1 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DGETRF, DGETRS, DLACPY, $ DLASET, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C LOVER = LSAME( OVER, 'O' ) LDWM1 = MAX( 1, M1 ) N = N1 + N2 INFO = 0 C C Test the input scalar arguments. C IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN INFO = -1 ELSE IF( N1.LT.0 ) THEN INFO = -2 ELSE IF( M1.LT.0 ) THEN INFO = -3 ELSE IF( P1.LT.0 ) THEN INFO = -4 ELSE IF( N2.LT.0 ) THEN INFO = -5 ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN INFO = -8 ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN INFO = -10 ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN INFO = -12 ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN INFO = -14 ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN INFO = -16 ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN INFO = -18 ELSE IF( ( N2.GT.0 .AND. LDC2.LT.LDWM1 ) .OR. $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN INFO = -20 ELSE IF( LDD2.LT.LDWM1 ) THEN INFO = -22 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -25 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -27 ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P1 ) ) .OR. $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN INFO = -29 ELSE IF( LDD.LT.MAX( 1, P1 ) ) THEN INFO = -31 ELSE LDW = MAX( P1*P1, M1*M1, N1*P1 ) IF( LOVER ) THEN IF( M1.GT.N*N2 ) $ LDW = MAX( LDW, M1*( M1 + 1 ) ) LDW = N1*P1 + LDW END IF IF( LDWORK.LT.MAX( 1, LDW ) ) $ INFO = -34 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB05ND', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, MIN( M1, P1 ) ).EQ.0 ) $ RETURN C IF ( P1.GT.0 ) THEN C C Form ( I + alpha * D1 * D2 ). C CALL DLASET( 'F', P1, P1, ZERO, ONE, DWORK, P1 ) CALL DGEMM ( 'No transpose', 'No transpose', P1, P1, M1, ALPHA, $ D1, LDD1, D2, LDD2, ONE, DWORK, P1 ) C C Factorize this matrix. C CALL DGETRF( P1, P1, DWORK, P1, IWORK, INFO ) C IF ( INFO.NE.0 ) $ RETURN C C Form E21 * D1. C IF ( LOVER .AND. LDD1.LE.LDD ) THEN IF ( LDD1.LT.LDD ) THEN C DO 20 J = M1, 1, -1 DO 10 I = P1, 1, -1 D(I,J) = D1(I,J) 10 CONTINUE 20 CONTINUE C END IF ELSE CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) END IF C CALL DGETRS( 'No transpose', P1, M1, DWORK, P1, IWORK, D, LDD, $ INFO ) IF ( N1.GT.0 ) THEN C C Form E21 * C1. C IF ( LOVER ) THEN C C First save C1. C LDW = LDW - P1*N1 + 1 CALL DLACPY( 'F', P1, N1, C1, LDC1, DWORK(LDW), P1 ) C IF ( LDC1.NE.LDC ) $ CALL DLACPY( 'F', P1, N1, DWORK(LDW), P1, C, LDC ) ELSE CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) END IF C CALL DGETRS( 'No transpose', P1, N1, DWORK, P1, IWORK, $ C, LDC, INFO ) END IF C C Form E12 = I - alpha * D2 * ( E21 * D1 ). C CALL DLASET( 'F', M1, M1, ZERO, ONE, DWORK, LDWM1 ) CALL DGEMM ( 'No transpose', 'No transpose', M1, M1, P1, $ -ALPHA, D2, LDD2, D, LDD, ONE, DWORK, LDWM1 ) C ELSE CALL DLASET( 'F', M1, M1, ZERO, ONE, DWORK, LDWM1 ) END IF C IF ( LOVER .AND. LDA1.LE.LDA ) THEN IF ( LDA1.LT.LDA ) THEN C DO 40 J = N1, 1, -1 DO 30 I = N1, 1, -1 A(I,J) = A1(I,J) 30 CONTINUE 40 CONTINUE C END IF ELSE CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) END IF C IF ( N1.GT.0 .AND. M1.GT.0 ) THEN C C Form B1 * E12. C IF ( LOVER ) THEN C C Use the blocks (1,2) and (2,2) of A as workspace. C IF ( N1*M1.LE.N*N2 ) THEN C C Use BLAS 3 code. C CALL DLACPY( 'F', N1, M1, B1, LDB1, A(1,N1+1), N1 ) CALL DGEMM ( 'No transpose', 'No transpose', N1, M1, M1, $ ONE, A(1,N1+1), N1, DWORK, LDWM1, ZERO, B, $ LDB ) ELSE IF ( LDB1.LT.LDB ) THEN C DO 60 J = M1, 1, -1 DO 50 I = N1, 1, -1 B(I,J) = B1(I,J) 50 CONTINUE 60 CONTINUE C IF ( M1.LE.N*N2 ) THEN C C Use BLAS 2 code. C DO 70 J = 1, N1 CALL DCOPY( M1, B(J,1), LDB, A(1,N1+1), 1 ) CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, $ A(1,N1+1), 1, ZERO, B(J,1), LDB ) 70 CONTINUE C ELSE C C Use additional workspace. C DO 80 J = 1, N1 CALL DCOPY( M1, B(J,1), LDB, DWORK(M1*M1+1), 1 ) CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, $ DWORK(M1*M1+1), 1, ZERO, B(J,1), LDB ) 80 CONTINUE C END IF C ELSE IF ( M1.LE.N*N2 ) THEN C C Use BLAS 2 code. C DO 90 J = 1, N1 CALL DCOPY( M1, B1(J,1), LDB1, A(1,N1+1), 1 ) CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, $ A(1,N1+1), 1, ZERO, B(J,1), LDB ) 90 CONTINUE C ELSE C C Use additional workspace. C DO 100 J = 1, N1 CALL DCOPY( M1, B1(J,1), LDB1, DWORK(M1*M1+1), 1 ) CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, $ DWORK(M1*M1+1), 1, ZERO, B(J,1), LDB ) 100 CONTINUE C END IF ELSE CALL DGEMM ( 'No transpose', 'No transpose', N1, M1, M1, $ ONE, B1, LDB1, DWORK, LDWM1, ZERO, B, LDB ) END IF END IF C IF ( N2.GT.0 ) THEN C C Complete matrices B and C. C IF ( P1.GT.0 ) THEN CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, $ ONE, B2, LDB2, D, LDD, ZERO, B(N1+1,1), LDB ) CALL DGEMM ( 'No transpose', 'No transpose', P1, N2, M1, $ -ALPHA, D, LDD, C2, LDC2, ZERO, C(1,N1+1), LDC $ ) ELSE IF ( M1.GT.0 ) THEN CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) END IF END IF C IF ( N1.GT.0 .AND. P1.GT.0 ) THEN C C Form upper left quadrant of A. C CALL DGEMM ( 'No transpose', 'No transpose', N1, P1, M1, $ -ALPHA, B, LDB, D2, LDD2, ZERO, DWORK, N1 ) C IF ( LOVER ) THEN CALL DGEMM ( 'No transpose', 'No transpose', N1, N1, P1, $ ONE, DWORK, N1, DWORK(LDW), P1, ONE, A, LDA ) ELSE CALL DGEMM ( 'No transpose', 'No transpose', N1, N1, P1, $ ONE, DWORK, N1, C1, LDC1, ONE, A, LDA ) END IF END IF C IF ( N2.GT.0 ) THEN C C Form lower right quadrant of A. C CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) IF ( M1.GT.0 ) $ CALL DGEMM ( 'No transpose', 'No transpose', N2, N2, M1, $ -ALPHA, B(N1+1,1), LDB, C2, LDC2, ONE, $ A(N1+1,N1+1), LDA ) C C Complete the matrix A. C CALL DGEMM ( 'No transpose', 'No transpose', N2, N1, P1, $ ONE, B2, LDB2, C, LDC, ZERO, A(N1+1,1), LDA ) CALL DGEMM ( 'No transpose', 'No transpose', N1, N2, M1, $ -ALPHA, B, LDB, C2, LDC2, ZERO, A(1,N1+1), LDA ) END IF C RETURN C *** Last line of AB05ND *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04OD.f0000644000000000000000000000013215012430707016162 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04OD.f0000644000175000017500000001764715012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE MB04OD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, $ TAU, DWORK ) C C PURPOSE C C To calculate a QR factorization of the first block column and C apply the orthogonal transformations (from the left) also to the C second block column of a structured matrix, as follows C _ _ C [ R B ] [ R B ] C Q' * [ ] = [ _ ] C [ A C ] [ 0 C ] 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 columns of the matrices B and C. M >= 0. C C P (input) INTEGER C The number of rows 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,N) C On entry, if UPLO = 'F', the leading P-by-N part of this C array must contain the matrix A. If UPLO = 'U', the C leading MIN(P,N)-by-N part of this array must contain the C upper trapezoidal (upper triangular if P >= N) matrix A, C and the elements below the diagonal are not referenced. C On exit, the leading P-by-N part (upper trapezoidal or C triangular, if UPLO = 'U') of this array contains the C trailing components (the vectors v, see Method) of the C elementary reflectors used in the factorization. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,P). 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 matrix B. C On exit, the leading N-by-M 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,N). C C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) C On entry, the leading P-by-M part of this array must C contain the matrix C. C On exit, the leading P-by-M 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,P). 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(i,P)-vector, if C i C UPLO = 'U'. The components of v are stored in the i-th column C i C of A, and tau is stored in TAU(i). C i C In-line code for applying Householder transformations is used C whenever possible (see MB04OY routine). C C NUMERICAL ASPECTS C C The algorithm is backward stable. C C CONTRIBUTORS C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C C REVISIONS C C Dec. 1997. C C KEYWORDS C C Elementary reflector, QR factorization, orthogonal transformation. C C ****************************************************************** C 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 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARFG, MB04OY 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 = 1, N C C Annihilate the I-th column of A and apply the C transformations to the entire block matrix, exploiting C its structure. C IM = MIN( I, P ) CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) C C Compute C [ R(I,I+1:N) ] C w := [ 1 v' ] * [ ], C [ A(1:IM,I+1:N) ] C C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] C [ ] := [ ] - tau * [ ] * w . C [ A(1:IM,I+1:N) ] [ A(1:IM,I+1:N) ] [ v ] C IF ( N-I.GT.0 ) $ CALL MB04OY( IM, N-I, A(1,I), TAU(I), R(I,I+1), LDR, $ A(1,I+1), LDA, DWORK ) C C Compute C [ B(I,:) ] C w := [ 1 v' ] * [ ], C [ C(1:IM,:) ] C C [ B(I,:) ] [ B(I,:) ] [ 1 ] C [ ] := [ ] - tau * [ ] * w. C [ C(1:IM,:) ] [ C(1:IM,:) ] [ v ] C C IF ( M.GT.0 ) $ CALL MB04OY( IM, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, $ DWORK ) 10 CONTINUE C ELSE C DO 20 I = 1, N - 1 C C Annihilate the I-th column of A and apply the C transformations to the first block column, exploiting its C structure. C CALL DLARFG( P+1, R(I,I), A(1,I), 1, TAU(I) ) C C Compute C [ R(I,I+1:N) ] C w := [ 1 v' ] * [ ], C [ A(:,I+1:N) ] C C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] C [ ] := [ ] - tau * [ ] * w . C [ A(:,I+1:N) ] [ A(:,I+1:N) ] [ v ] C CALL MB04OY( P, N-I, A(1,I), TAU(I), R(I,I+1), LDR, $ A(1,I+1), LDA, DWORK ) 20 CONTINUE C CALL DLARFG( P+1, R(N,N), A(1,N), 1, TAU(N) ) IF ( M.GT.0 ) THEN C C Apply the transformations to the second block column. C DO 30 I = 1, N C C Compute C [ B(I,:) ] C w := [ 1 v' ] * [ ], C [ C ] C C [ B(I,:) ] [ B(I,:) ] [ 1 ] C [ ] := [ ] - tau * [ ] * w. C [ C ] [ C ] [ v ] C CALL MB04OY( P, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, $ DWORK ) 30 CONTINUE C END IF END IF RETURN C *** Last line of MB04OD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB13CD.f0000644000000000000000000000013215012430707016132 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB13CD.f0000644000175000017500000004315615012430707017337 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION AB13CD( N, M, NP, A, LDA, B, LDB, C, $ LDC, D, LDD, TOL, IWORK, DWORK, $ LDWORK, CWORK, LCWORK, BWORK, $ INFO ) C C PURPOSE C C To compute the H-infinity norm of the continuous-time stable C system C C | A | B | C G(s) = |---|---| . C | C | D | C C FUNCTION VALUE C C AB13CD DOUBLE PRECISION C If INFO = 0, the H-infinity norm of the system, HNORM, C i.e., the peak gain of the frequency response (as measured C by the largest singular value in the MIMO case). 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 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 Tolerances C C TOL DOUBLE PRECISION C Tolerance used to set the accuracy in determining the C norm. 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, and DWORK(2) contains the frequency where the C gain of the frequency response achieves its peak value C HNORM. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= max(2,4*N*N+2*M*M+3*M*N+M*NP+2*(N+NP)*NP+10*N+ C 6*max(M,NP)). C For good performance, LDWORK must generally be larger. C C CWORK COMPLEX*16 array, dimension (LCWORK) C On exit, if INFO = 0, CWORK(1) contains the optimal value C of LCWORK. C C LCWORK INTEGER C The dimension of the array CWORK. C LCWORK >= max(1,(N+M)*(N+NP)+3*max(M,NP)). C For good performance, LCWORK must generally be larger. 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: the system is unstable; C = 2: the tolerance is too small (the algorithm for C computing the H-infinity norm did not converge); C = 3: errors in computing the eigenvalues of A or of the C Hamiltonian matrix (the QR algorithm did not C converge); C = 4: errors in computing singular values. C C METHOD C C The routine implements the method presented in [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 (INFO = 2), the tolerance must C be increased. C C CONTRIBUTORS C C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 1999. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999, C Oct. 2000. C P.Hr. Petkov, October 2000. C A. Varga, October 2000. C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, C July 2011. C C KEYWORDS C C H-infinity optimal control, robust control, system norm. C C ****************************************************************** C C .. Parameters .. INTEGER MAXIT PARAMETER ( MAXIT = 10 ) COMPLEX*16 CONE, JIMAG PARAMETER ( CONE = ( 1.0D0, 0.0D0 ), $ JIMAG = ( 0.0D0, 1.0D0 ) ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) DOUBLE PRECISION HUGE PARAMETER ( HUGE = 10.0D+0**30 ) C .. C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LCWORK, LDD, LDWORK, M, N, $ NP DOUBLE PRECISION TOL C .. C .. Array Arguments .. INTEGER IWORK( * ) COMPLEX*16 CWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), DWORK( * ) LOGICAL BWORK( * ) C .. C .. Local Scalars .. INTEGER I, ICW2, ICW3, ICW4, ICWRK, INFO2, ITER, IW10, $ IW11, IW12, IW2, IW3, IW4, IW5, IW6, IW7, IW8, $ IW9, IWRK, J, K, L, LCWAMX, LWAMAX, MINCWR, $ MINWRK, SDIM DOUBLE PRECISION DEN, FPEAK, GAMMA, GAMMAL, GAMMAU, OMEGA, RAT, $ RATMAX, TEMP, WIMAX, WRMIN LOGICAL COMPLX C C .. External Functions .. DOUBLE PRECISION DLAPY2 LOGICAL SB02MV, SB02CX EXTERNAL DLAPY2, SB02MV, SB02CX C .. C .. External Subroutines .. EXTERNAL DGEES, DGEMM, DGESV, DGESVD, DLACPY, DPOSV, $ DPOTRF, DPOTRS, DSYRK, MA02ED, MB01RX, XERBLA, $ ZGEMM, ZGESV, ZGESVD C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C C Test the input scalar parameters. 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -9 ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN INFO = -11 END IF C C Compute workspace. C MINWRK = MAX( 2, 4*N*N + 2*M*M + 3*M*N + M*NP + 2*( N + NP )*NP + $ 10*N + 6*MAX( M, NP ) ) IF( LDWORK.LT.MINWRK ) THEN INFO = -15 END IF MINCWR = MAX( 1, ( N + M )*( N + NP ) + 3*MAX( M, NP ) ) IF( LCWORK.LT.MINCWR ) THEN INFO = -17 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'AB13CD', -INFO ) RETURN END IF C C Quick return if possible. C IF( M.EQ.0 .OR. NP.EQ.0 ) THEN AB13CD = ZERO RETURN END IF C C Workspace usage. C IW2 = N IW3 = IW2 + N IW4 = IW3 + N*N IW5 = IW4 + N*M IW6 = IW5 + NP*M IWRK = IW6 + MIN( NP, M ) C C Determine the maximum singular value of G(infinity) = D . C CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IW5+1 ), NP ) CALL DGESVD( 'N', 'N', NP, M, DWORK( IW5+1 ), NP, DWORK( IW6+1 ), $ DWORK, NP, DWORK, M, DWORK( IWRK+1 ), LDWORK-IWRK, $ INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 4 RETURN END IF GAMMAL = DWORK( IW6+1 ) FPEAK = HUGE LWAMAX = INT( DWORK( IWRK+1 ) ) + IWRK C C Quick return if N = 0 . C IF( N.EQ.0 ) THEN AB13CD = GAMMAL DWORK(1) = TWO DWORK(2) = ZERO CWORK(1) = ONE RETURN END IF C C Stability check. C CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW3+1 ), N ) CALL DGEES( 'N', 'S', SB02MV, N, DWORK( IW3+1 ), N, SDIM, DWORK, $ DWORK( IW2+1 ), DWORK, N, DWORK( IWRK+1 ), $ LDWORK-IWRK, BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 3 RETURN END IF IF( SDIM.LT.N ) THEN INFO = 1 RETURN END IF LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) C C Determine the maximum singular value of G(0) = -C*inv(A)*B + D . C CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW3+1 ), N ) CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IW4+1 ), N ) CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IW5+1 ), NP ) CALL DGESV( N, M, DWORK( IW3+1 ), N, IWORK, DWORK( IW4+1 ), N, $ INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF CALL DGEMM( 'N', 'N', NP, M, N, -ONE, C, LDC, DWORK( IW4+1 ), N, $ ONE, DWORK( IW5+1 ), NP ) CALL DGESVD( 'N', 'N', NP, M, DWORK( IW5+1 ), NP, DWORK( IW6+1 ), $ DWORK, NP, DWORK, M, DWORK( IWRK+1 ), LDWORK-IWRK, $ INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 4 RETURN END IF IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN GAMMAL = DWORK( IW6+1 ) FPEAK = ZERO END IF LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) C C Find a frequency which is close to the peak frequency. C COMPLX = .FALSE. DO 10 I = 1, N IF( DWORK( IW2+I ).NE.ZERO ) COMPLX = .TRUE. 10 CONTINUE IF( .NOT.COMPLX ) THEN WRMIN = ABS( DWORK( 1 ) ) DO 20 I = 2, N IF( WRMIN.GT.ABS( DWORK( I ) ) ) WRMIN = ABS( DWORK( I ) ) 20 CONTINUE OMEGA = WRMIN ELSE RATMAX = ZERO DO 30 I = 1, N DEN = DLAPY2( DWORK( I ), DWORK( IW2+I ) ) RAT = ABS( ( DWORK( IW2+I )/DWORK( I ) )/DEN ) IF( RATMAX.LT.RAT ) THEN RATMAX = RAT WIMAX = DEN END IF 30 CONTINUE OMEGA = WIMAX END IF C C Workspace usage. C ICW2 = N*N ICW3 = ICW2 + N*M ICW4 = ICW3 + NP*N ICWRK = ICW4 + NP*M C C Determine the maximum singular value of C G(omega) = C*inv(j*omega*In - A)*B + D . C DO 50 J = 1, N DO 40 I = 1, N CWORK( I+(J-1)*N ) = -A( I, J ) 40 CONTINUE CWORK( J+(J-1)*N ) = JIMAG*OMEGA - A( J, J ) 50 CONTINUE DO 70 J = 1, M DO 60 I = 1, N CWORK( ICW2+I+(J-1)*N ) = B( I, J ) 60 CONTINUE 70 CONTINUE DO 90 J = 1, N DO 80 I = 1, NP CWORK( ICW3+I+(J-1)*NP ) = C( I, J ) 80 CONTINUE 90 CONTINUE DO 110 J = 1, M DO 100 I = 1, NP CWORK( ICW4+I+(J-1)*NP ) = D( I, J ) 100 CONTINUE 110 CONTINUE CALL ZGESV( N, M, CWORK, N, IWORK, CWORK( ICW2+1 ), N, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF CALL ZGEMM( 'N', 'N', NP, M, N, CONE, CWORK( ICW3+1 ), NP, $ CWORK( ICW2+1 ), N, CONE, CWORK( ICW4+1 ), NP ) CALL ZGESVD( 'N', 'N', NP, M, CWORK( ICW4+1 ), NP, DWORK( IW6+1 ), $ CWORK, NP, CWORK, M, CWORK( ICWRK+1 ), LCWORK-ICWRK, $ DWORK( IWRK+1 ), INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 4 RETURN END IF IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN GAMMAL = DWORK( IW6+1 ) FPEAK = OMEGA END IF LCWAMX = INT( CWORK( ICWRK+1 ) ) + ICWRK C C Workspace usage. C IW2 = M*N IW3 = IW2 + M*M IW4 = IW3 + NP*NP IW5 = IW4 + M*M IW6 = IW5 + M*N IW7 = IW6 + M*N IW8 = IW7 + NP*NP IW9 = IW8 + NP*N IW10 = IW9 + 4*N*N IW11 = IW10 + 2*N IW12 = IW11 + 2*N IWRK = IW12 + MIN( NP, M ) C C Compute D'*C . C CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, $ DWORK, M ) C C Compute D'*D . C CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ZERO, DWORK( IW2+1 ), $ M ) C C Compute D*D' . C CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ZERO, DWORK( IW3+1 ), $ NP ) C C Main iteration loop for gamma. C ITER = 0 120 ITER = ITER + 1 IF( ITER.GT.MAXIT ) THEN INFO = 2 RETURN END IF GAMMA = ( ONE + TWO*TOL )*GAMMAL C C Compute R = GAMMA^2*Im - D'*D . C DO 140 J = 1, M DO 130 I = 1, J DWORK( IW4+I+(J-1)*M ) = -DWORK( IW2+I+(J-1)*M ) 130 CONTINUE DWORK( IW4+J+(J-1)*M ) = GAMMA**2 - DWORK( IW2+J+(J-1)*M ) 140 CONTINUE C C Compute inv(R)*D'*C . C CALL DLACPY( 'Full', M, N, DWORK, M, DWORK( IW5+1 ), M ) CALL DPOTRF( 'U', M, DWORK( IW4+1 ), M, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 2 RETURN END IF CALL DPOTRS( 'U', M, N, DWORK( IW4+1 ), M, DWORK( IW5+1 ), M, $ INFO2 ) C C Compute inv(R)*B' . C DO 160 J = 1, N DO 150 I = 1, M DWORK( IW6+I+(J-1)*M ) = B( J, I ) 150 CONTINUE 160 CONTINUE CALL DPOTRS( 'U', M, N, DWORK( IW4+1 ), M, DWORK( IW6+1 ), M, $ INFO2 ) C C Compute S = GAMMA^2*Ip - D*D' . C DO 180 J = 1, NP DO 170 I = 1, J DWORK( IW7+I+(J-1)*NP ) = -DWORK( IW3+I+(J-1)*NP ) 170 CONTINUE DWORK( IW7+J+(J-1)*NP ) = GAMMA**2 - DWORK( IW3+J+(J-1)*NP ) 180 CONTINUE C C Compute inv(S)*C . C CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IW8+1 ), NP ) CALL DPOSV( 'U', NP, N, DWORK( IW7+1 ), NP, DWORK( IW8+1 ), NP, $ INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 2 RETURN END IF C C Construct the Hamiltonian matrix . C CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW9+1 ), 2*N ) CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, DWORK( IW5+1 ), M, $ ONE, DWORK( IW9+1 ), 2*N ) CALL MB01RX( 'Left', 'Upper', 'Transpose', N, NP, ZERO, -GAMMA, $ DWORK( IW9+N+1 ), 2*N, C, LDC, DWORK( IW8+1 ), NP, $ INFO2 ) CALL MA02ED( 'Upper', N, DWORK( IW9+N+1 ), 2*N ) CALL MB01RX( 'Left', 'Upper', 'NoTranspose', N, M, ZERO, GAMMA, $ DWORK( IW9+2*N*N+1 ), 2*N, B, LDB, DWORK( IW6+1 ), M, $ INFO2 ) CALL MA02ED( 'Upper', N, DWORK( IW9+2*N*N+1 ), 2*N ) DO 200 J = 1, N DO 190 I = 1, N DWORK( IW9+2*N*N+N+I+(J-1)*2*N ) = -DWORK( IW9+J+(I-1)*2*N ) 190 CONTINUE 200 CONTINUE C C Compute the eigenvalues of the Hamiltonian matrix. C CALL DGEES( 'N', 'S', SB02CX, 2*N, DWORK( IW9+1 ), 2*N, SDIM, $ DWORK( IW10+1 ), DWORK( IW11+1 ), DWORK, 2*N, $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 3 RETURN END IF LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) C IF( SDIM.EQ.0 ) THEN GAMMAU = GAMMA GO TO 330 END IF C C Store the positive imaginary parts. C J = 0 DO 210 I = 1, SDIM-1, 2 J = J + 1 DWORK( IW10+J ) = DWORK( IW11+I ) 210 CONTINUE K = J C IF( K.GE.2 ) THEN C C Reorder the imaginary parts. C DO 230 J = 1, K-1 DO 220 L = J+1, K IF( DWORK( IW10+J ).LE. DWORK( IW10+L ) ) GO TO 220 TEMP = DWORK( IW10+J ) DWORK( IW10+J ) = DWORK( IW10+L ) DWORK( IW10+L ) = TEMP 220 CONTINUE 230 CONTINUE C C Determine the next frequency. C DO 320 L = 1, K - 1 OMEGA = ( DWORK( IW10+L ) + DWORK( IW10+L+1 ) )/TWO DO 250 J = 1, N DO 240 I = 1, N CWORK( I+(J-1)*N ) = -A( I, J ) 240 CONTINUE CWORK( J+(J-1)*N ) = JIMAG*OMEGA - A( J, J ) 250 CONTINUE DO 270 J = 1, M DO 260 I = 1, N CWORK( ICW2+I+(J-1)*N ) = B( I, J ) 260 CONTINUE 270 CONTINUE DO 290 J = 1, N DO 280 I = 1, NP CWORK( ICW3+I+(J-1)*NP ) = C( I, J ) 280 CONTINUE 290 CONTINUE DO 310 J = 1, M DO 300 I = 1, NP CWORK( ICW4+I+(J-1)*NP ) = D( I, J ) 300 CONTINUE 310 CONTINUE CALL ZGESV( N, M, CWORK, N, IWORK, CWORK( ICW2+1 ), N, $ INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF CALL ZGEMM( 'N', 'N', NP, M, N, CONE, CWORK( ICW3+1 ), NP, $ CWORK( ICW2+1 ), N, CONE, CWORK( ICW4+1 ), NP ) CALL ZGESVD( 'N', 'N', NP, M, CWORK( ICW4+1 ), NP, $ DWORK( IW6+1 ), CWORK, NP, CWORK, M, $ CWORK( ICWRK+1 ), LCWORK-ICWRK, $ DWORK( IWRK+1 ), INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 4 RETURN END IF IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN GAMMAL = DWORK( IW6+1 ) FPEAK = OMEGA END IF LCWAMX = MAX( INT( CWORK( ICWRK+1 ) ) + ICWRK, LCWAMX ) 320 CONTINUE END IF GO TO 120 330 AB13CD = ( GAMMAL + GAMMAU )/TWO C DWORK( 1 ) = LWAMAX DWORK( 2 ) = FPEAK CWORK( 1 ) = LCWAMX RETURN C *** End of AB13CD *** END control-4.1.2/src/slicot/src/PaxHeaders/TD03AD.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TD03AD.f0000644000175000017500000005106215012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE TD03AD( ROWCOL, LERI, EQUIL, M, P, INDEXD, DCOEFF, $ LDDCOE, UCOEFF, LDUCO1, LDUCO2, NR, A, LDA, B, $ LDB, C, LDC, D, LDD, INDEXP, PCOEFF, LDPCO1, $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, $ LDVCO2, TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To find a relatively prime left or right polynomial matrix C representation for a proper transfer matrix T(s) given as either C row or column polynomial vectors over common denominator C polynomials, possibly with uncancelled common terms. C C ARGUMENTS C C Mode Parameters C C ROWCOL CHARACTER*1 C Indicates whether T(s) is to be factorized by rows or by C columns as follows: C = 'R': T(s) is factorized by rows; C = 'C': T(s) is factorized by columns. C C LERI CHARACTER*1 C Indicates whether a left or a right polynomial matrix C representation is required as follows: C = 'L': A left polynomial matrix representation C inv(P(s))*Q(s) is required; C = 'R': A right polynomial matrix representation C Q(s)*inv(P(s)) is required. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to balance the triplet C (A,B,C), before computing a minimal state-space C representation, as follows: C = 'S': Perform balancing (scaling); C = 'N': Do not perform balancing. C C Input/Output Parameters 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 INDEXD (input) INTEGER array, dimension (P), if ROWCOL = 'R', or C dimension (M), if ROWCOL = 'C'. C The leading pormd elements of this array must contain the C row degrees of the denominator polynomials in D(s). C pormd = P if the transfer matrix T(s) is given as row C polynomial vectors over denominator polynomials; C pormd = M if the transfer matrix T(s) is given as column C polynomial vectors over denominator polynomials. C C DCOEFF (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef), C where kdcoef = MAX(INDEXD(I)) + 1. C The leading pormd-by-kdcoef part of this array must C contain the coefficients of each denominator polynomial. C DCOEFF(I,K) is the coefficient in s**(INDEXD(I)-K+1) of C the I-th denominator polynomial in D(s), where K = 1,2, C ...,kdcoef. C C LDDCOE INTEGER C The leading dimension of array DCOEFF. C LDDCOE >= MAX(1,P), if ROWCOL = 'R'; C LDDCOE >= MAX(1,M), if ROWCOL = 'C'. C C UCOEFF (input) DOUBLE PRECISION array, dimension C (LDUCO1,LDUCO2,kdcoef) C The leading P-by-M-by-kdcoef part of this array must C contain the coefficients of the numerator matrix U(s); C if ROWCOL = 'C', this array is modified internally but C restored on exit, and the remainder of the leading C MAX(M,P)-by-MAX(M,P)-by-kdcoef part is used as internal C workspace. C UCOEFF(I,J,K) is the coefficient in s**(INDEXD(iorj)-K+1) C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; C iorj = I if T(s) is given as row polynomial vectors over C denominator polynomials; iorj = J if T(s) is given as C column polynomial vectors over denominator polynomials. C Thus for ROWCOL = 'R', U(s) = C diag(s**INDEXD(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). C C LDUCO1 INTEGER C The leading dimension of array UCOEFF. C LDUCO1 >= MAX(1,P), if ROWCOL = 'R'; C LDUCO1 >= MAX(1,M,P), if ROWCOL = 'C'. C C LDUCO2 INTEGER C The second dimension of array UCOEFF. C LDUCO2 >= MAX(1,M), if ROWCOL = 'R'; C LDUCO2 >= MAX(1,M,P), if ROWCOL = 'C'. C C NR (output) INTEGER C The order of the resulting minimal realization, i.e. the C order of the state dynamics matrix A. C C A (output) DOUBLE PRECISION array, dimension (LDA,N), C pormd C where N = SUM INDEXD(I) C I=1 C The leading NR-by-NR part of this array contains the upper C block Hessenberg state dynamics matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) C The leading NR-by-M part of this array contains the C input/state matrix B; the remainder of the leading C N-by-MAX(M,P) part is used as internal workspace. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C C (output) DOUBLE PRECISION array, dimension (LDC,N) C The leading P-by-NR part of this array contains the C state/output matrix C; the remainder of the leading C MAX(M,P)-by-N part is used as internal workspace. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,M,P). C C D (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) C The leading P-by-M part of this array contains the direct C transmission matrix D; the remainder of the leading C MAX(M,P)-by-MAX(M,P) part is used as internal workspace. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,M,P). C C INDEXP (output) INTEGER array, dimension (P), if ROWCOL = 'R', or C dimension (M), if ROWCOL = 'C'. C The leading pormp elements of this array contain the C row (column if ROWCOL = 'C') degrees of the denominator C matrix P(s). C pormp = P if a left polynomial matrix representation C is requested; pormp = M if a right polynomial matrix C representation is requested. C These elements are ordered so that C INDEXP(1) >= INDEXP(2) >= ... >= INDEXP(pormp). C C PCOEFF (output) DOUBLE PRECISION array, dimension C (LDPCO1,LDPCO2,N+1) C The leading pormp-by-pormp-by-kpcoef part of this array C contains the coefficients of the denominator matrix P(s), C where kpcoef = MAX(INDEXP(I)) + 1. C PCOEFF(I,J,K) is the coefficient in s**(INDEXP(iorj)-K+1) C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; C iorj = I if a left polynomial matrix representation is C requested; iorj = J if a right polynomial matrix C representation is requested. C Thus for a left polynomial matrix representation, P(s) = C diag(s**INDEXP(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). C C LDPCO1 INTEGER C The leading dimension of array PCOEFF. C LDPCO1 >= MAX(1,P), if ROWCOL = 'R'; C LDPCO1 >= MAX(1,M), if ROWCOL = 'C'. C C LDPCO2 INTEGER C The second dimension of array PCOEFF. C LDPCO2 >= MAX(1,P), if ROWCOL = 'R'; C LDPCO2 >= MAX(1,M), if ROWCOL = 'C'. C C QCOEFF (output) DOUBLE PRECISION array, dimension C (LDQCO1,LDQCO2,N+1) C The leading pormp-by-pormd-by-kpcoef part of this array C contains the coefficients of the numerator matrix Q(s). C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). C C LDQCO1 INTEGER C The leading dimension of array QCOEFF. C If LERI = 'L', LDQCO1 >= MAX(1,PM), C where PM = P, if ROWCOL = 'R'; C PM = M, if ROWCOL = 'C'. C If LERI = 'R', LDQCO1 >= MAX(1,M,P). C C LDQCO2 INTEGER C The second dimension of array QCOEFF. C If LERI = 'L', LDQCO2 >= MAX(1,MP), C where MP = M, if ROWCOL = 'R'; C MP = P, if ROWCOL = 'C'. C If LERI = 'R', LDQCO2 >= MAX(1,M,P). C C VCOEFF (output) DOUBLE PRECISION array, dimension C (LDVCO1,LDVCO2,N+1) C The leading pormp-by-NR-by-kpcoef part of this array C contains the coefficients of the intermediate matrix C V(s) as produced by SLICOT Library routine TB03AD. C C LDVCO1 INTEGER C The leading dimension of array VCOEFF. C LDVCO1 >= MAX(1,P), if ROWCOL = 'R'; C LDVCO1 >= MAX(1,M), if ROWCOL = 'C'. C C LDVCO2 INTEGER C The second dimension of array VCOEFF. LDVCO2 >= MAX(1,N). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determination when C transforming (A, B, C). If the user sets TOL > 0, then C the given value of TOL is used as a lower bound for the C reciprocal condition number (see the description of the C argument RCOND in the SLICOT routine MB03OD); a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance C (determined by the SLICOT routine TB01UD) is used instead. C C Workspace C C IWORK INTEGER array, dimension (N+MAX(M,P)) C On exit, if INFO = 0, the first nonzero elements of C IWORK(1:N) return the orders of the diagonal blocks of A. 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, N + MAX(N, 3*M, 3*P), PM*(PM + 2)) C where PM = P, if ROWCOL = 'R'; C PM = M, if ROWCOL = '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 > 0: if INFO = i (i <= k = pormd), then i is the first C integer I for which ABS( DCOEFF(I,1) ) is so small C that the calculations would overflow (see SLICOT C Library routine TD03AY); that is, the leading C coefficient of a polynomial is nearly zero; no C state-space representation or polynomial matrix C representation is calculated; C = k+1: if a singular matrix was encountered during the C computation of V(s); C = k+2: if a singular matrix was encountered during the C computation of P(s). C C METHOD C C The method for transfer matrices factorized by rows will be C described here; T(s) factorized by columns is dealt with by C operating on the dual T'(s). The description for T(s) is actually C the left polynomial matrix representation C C T(s) = inv(D(s))*U(s), C C where D(s) is diagonal with its (I,I)-th polynomial element of C degree INDEXD(I). The first step is to check whether the leading C coefficient of any polynomial element of D(s) is approximately C zero, if so the routine returns with INFO > 0. Otherwise, C Wolovich's Observable Structure Theorem is used to construct a C state-space representation in observable companion form which is C equivalent to the above polynomial matrix representation. The C method is particularly easy here due to the diagonal form of D(s). C This state-space representation is not necessarily controllable C (as D(s) and U(s) are not necessarily relatively left prime), but C it is in theory completely observable; however, its observability C matrix may be poorly conditioned, so it is treated as a general C state-space representation and SLICOT Library routine TB03AD is C used to separate out a minimal realization for T(s) from it by C means of orthogonal similarity transformations and then to C calculate a relatively prime (left or right) polynomial matrix C representation which is equivalent to this. C C REFERENCES C C [1] Patel, R.V. C On Computing Matrix Fraction Descriptions and Canonical C Forms of Linear Time-Invariant Systems. C UMIST Control Systems Centre Report 489, 1980. C C [2] Wolovich, W.A. C Linear Multivariable Systems, (Theorem 4.3.3). C Springer-Verlag, 1974. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. C Supersedes Release 3.0 routine TD01ND. C C REVISIONS C C - C C KEYWORDS C C Coprime matrix fraction, elementary polynomial operations, C polynomial matrix, state-space representation, transfer matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL, LERI, ROWCOL INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDPCO1, $ LDPCO2, LDQCO1, LDQCO2, LDUCO1, LDUCO2, LDVCO1, $ LDVCO2, LDWORK, M, NR, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER INDEXD(*), INDEXP(*), IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DCOEFF(LDDCOE,*), DWORK(*), $ PCOEFF(LDPCO1,LDPCO2,*), $ QCOEFF(LDQCO1,LDQCO2,*), $ UCOEFF(LDUCO1,LDUCO2,*), VCOEFF(LDVCO1,LDVCO2,*) C .. Local Scalars .. LOGICAL LEQUIL, LLERI, LROWCO INTEGER I, IDUAL, ITEMP, J, JSTOP, K, KDCOEF, KPCOEF, $ MAXMP, MPLIM, MWORK, N, PWORK C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB07MD, DLACPY, DSWAP, TB01XD, TB03AD, TC01OD, $ TD03AY, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C INFO = 0 LROWCO = LSAME( ROWCOL, 'R' ) LLERI = LSAME( LERI, 'L' ) LEQUIL = LSAME( EQUIL, 'S' ) C C Test the input scalar arguments. C MAXMP = MAX( M, P ) MPLIM = MAX( 1, MAXMP ) IF ( LROWCO ) THEN C C Initialization for T(s) given as rows over common denominators. C PWORK = P MWORK = M ELSE C C Initialization for T(s) given as columns over common C denominators. C PWORK = M MWORK = P END IF C IF( .NOT.LROWCO .AND. .NOT.LSAME( ROWCOL, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN INFO = -2 ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( P.LT.0 ) THEN INFO = -5 ELSE IF( LDDCOE.LT.MAX( 1, PWORK ) ) THEN INFO = -8 ELSE IF( LDUCO1.LT.MAX( 1, PWORK ) .OR. ( .NOT.LROWCO .AND. $ LDUCO1.LT.MPLIM ) ) THEN INFO = -10 ELSE IF( LDUCO2.LT.MAX( 1, MWORK ) .OR. ( .NOT.LROWCO .AND. $ LDUCO2.LT.MPLIM ) ) THEN INFO = -11 END IF C N = 0 IF ( INFO.EQ.0 ) THEN C C Calculate N, the order of the resulting state-space C representation, and the index kdcoef. C KDCOEF = 0 C DO 10 I = 1, PWORK KDCOEF = MAX( KDCOEF, INDEXD(I) ) N = N + INDEXD(I) 10 CONTINUE C KDCOEF = KDCOEF + 1 C IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LDC.LT.MPLIM ) THEN INFO = -18 ELSE IF( LDD.LT.MPLIM ) THEN INFO = -20 ELSE IF( LDPCO1.LT.PWORK ) THEN INFO = -23 ELSE IF( LDPCO2.LT.PWORK ) THEN INFO = -24 ELSE IF( LDQCO1.LT.MAX( 1, PWORK ) .OR. ( .NOT.LLERI .AND. $ LDQCO1.LT.MPLIM ) ) THEN INFO = -26 ELSE IF( LDQCO2.LT.MAX( 1, MWORK ) .OR. ( .NOT.LLERI .AND. $ LDQCO2.LT.MPLIM ) ) THEN INFO = -27 ELSE IF( LDVCO1.LT.MAX( 1, PWORK ) ) THEN INFO = -29 ELSE IF( LDVCO2.LT.MAX( 1, N ) ) THEN INFO = -30 C ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ), $ PWORK*( PWORK + 2 ) ) ) THEN INFO = -34 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TD03AD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, M, P ).EQ.0 ) THEN NR = 0 DWORK(1) = ONE RETURN END IF C C IDUAL = 1 iff precisely ROWCOL = 'C' or (exclusively) LERI = 'R', C i.e. iff AB07MD call is required before TB03AD. C IDUAL = 0 IF ( .NOT.LROWCO ) IDUAL = 1 IF ( .NOT.LLERI ) IDUAL = IDUAL + 1 C IF ( .NOT.LROWCO ) THEN C C Initialize the remainder of the leading C MPLIM-by-MPLIM-by-KDCOEF part of U(s) to zero. C IF ( P.LT.M ) THEN C DO 20 K = 1, KDCOEF CALL DLACPY( 'Full', M-P, MPLIM, ZERO, ZERO, $ UCOEFF(P+1,1,K), LDUCO1 ) 20 CONTINUE C ELSE IF ( P.GT.M ) THEN C DO 30 K = 1, KDCOEF CALL DLACPY( 'Full', MPLIM, P-M, ZERO, ZERO, $ UCOEFF(1,M+1,K), LDUCO1 ) 30 CONTINUE C END IF C IF ( MPLIM.NE.1 ) THEN C C Non-scalar T(s) factorized by columns: transpose it C (i.e. U(s)). C JSTOP = MPLIM - 1 C DO 50 K = 1, KDCOEF C DO 40 J = 1, JSTOP CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, $ UCOEFF(J,J+1,K), LDUCO1 ) 40 CONTINUE C 50 CONTINUE C END IF END IF C C Construct non-minimal state-space representation (by Wolovich's C Structure Theorem) which has transfer matrix T(s) or T'(s) as C appropriate, C CALL TD03AY( MWORK, PWORK, INDEXD, DCOEFF, LDDCOE, UCOEFF, LDUCO1, $ LDUCO2, N, A, LDA, B, LDB, C, LDC, D, LDD, INFO ) IF ( INFO.GT.0 ) $ RETURN C IF ( IDUAL.EQ.1 ) THEN C C and then obtain (MWORK x PWORK) dual of this system if C appropriate. C CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, $ LDD, INFO ) ITEMP = PWORK PWORK = MWORK MWORK = ITEMP END IF C C Find left polynomial matrix representation (and minimal C state-space representation en route) for the relevant state-space C representation ... C CALL TB03AD( 'Left', EQUIL, N, MWORK, PWORK, A, LDA, B, LDB, C, $ LDC, D, LDD, NR, INDEXP, PCOEFF, LDPCO1, LDPCO2, $ QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, LDVCO2, TOL, $ IWORK, DWORK, LDWORK, INFO ) C IF ( INFO.GT.0 ) THEN INFO = PWORK + INFO RETURN END IF C IF ( .NOT.LLERI ) THEN C C and, if a right polynomial matrix representation is required, C transpose and reorder (to get a block upper Hessenberg C matrix A). C K = IWORK(1) - 1 IF ( N.GE.2 ) $ K = K + IWORK(2) CALL TB01XD( 'D', NR, MWORK, PWORK, K, NR-1, A, LDA, B, LDB, C, $ LDC, D, LDD, INFO ) C KPCOEF = 0 C DO 60 I = 1, PWORK KPCOEF = MAX( KPCOEF, INDEXP(I) ) 60 CONTINUE C KPCOEF = KPCOEF + 1 CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, LDPCO2, $ QCOEFF, LDQCO1, LDQCO2, INFO ) END IF C IF ( ( .NOT.LROWCO ) .AND. ( MPLIM.NE.1 ) ) THEN C C If non-scalar T(s) originally given by columns, C retranspose U(s). C DO 80 K = 1, KDCOEF C DO 70 J = 1, JSTOP CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, UCOEFF(J,J+1,K), $ LDUCO1 ) 70 CONTINUE C 80 CONTINUE C END IF RETURN C *** Last line of TD03AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01PY.f0000644000000000000000000000013015012430707016204 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MC01PY.f0000644000175000017500000000710615012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE MC01PY( K, REZ, IMZ, P, DWORK, INFO ) C C PURPOSE C C To compute the coefficients of a real polynomial P(x) from its C zeros. The coefficients are stored in decreasing order of the C powers of x. C C ARGUMENTS C C Input/Output Parameters C C K (input) INTEGER C The number of zeros (and hence the degree) of P(x). C K >= 0. C C REZ (input) DOUBLE PRECISION array, dimension (K) C IMZ (input) DOUBLE PRECISION array, dimension (K) C The real and imaginary parts of the i-th zero of P(x) C must be stored in REZ(i) and IMZ(i), respectively, where C i = 1, 2, ..., K. The zeros may be supplied in any order, C except that complex conjugate zeros must appear C consecutively. C C P (output) DOUBLE PRECISION array, dimension (K+1) C This array contains the coefficients of P(x) in decreasing C powers of x. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (K) C If K = 0, this array is not referenced. 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, (REZ(i),IMZ(i)) is a complex zero but C (REZ(i-1),IMZ(i-1)) is not its conjugate. C C METHOD C C The routine computes the coefficients of the real K-th degree C polynomial P(x) as C C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) C C where r(i) = (REZ(i),IMZ(i)). C C Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j) C form a complex conjugate pair (where i <> j), and that IMZ(i) = 0 C if r(i) is real. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, May 2002. C C REVISIONS C C - C C KEYWORDS C C Elementary polynomial operations, polynomial operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, K C .. Array Arguments .. DOUBLE PRECISION DWORK(*), IMZ(*), P(*), REZ(*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION U, V C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, XERBLA C .. Executable Statements .. C C Test the input scalar arguments. C IF( K.LT.0 ) THEN INFO = -1 C C Error return. C CALL XERBLA( 'MC01PY', -INFO ) RETURN END IF C C Quick return if possible. C INFO = 0 P(1) = ONE IF ( K.EQ.0 ) $ RETURN C I = 1 C WHILE ( I <= K ) DO 20 IF ( I.LE.K ) THEN U = REZ(I) V = IMZ(I) DWORK(I) = ZERO C IF ( V.EQ.ZERO ) THEN CALL DAXPY( I, -U, P, 1, DWORK, 1 ) C ELSE IF ( I.EQ.K ) THEN INFO = K RETURN ELSE IF ( ( U.NE.REZ(I+1) ) .OR. ( V.NE.-IMZ(I+1) ) ) THEN INFO = I + 1 RETURN END IF C DWORK(I+1) = ZERO CALL DAXPY( I, -(U + U), P, 1, DWORK, 1 ) CALL DAXPY( I, U**2+V**2, P, 1, DWORK(2), 1 ) I = I + 1 END IF C CALL DCOPY( I, DWORK, 1, P(2), 1 ) I = I + 1 GO TO 20 END IF C END WHILE 20 C RETURN C *** Last line of MC01PY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03VD.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03VD.f0000644000175000017500000002403515012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, $ DWORK, INFO ) C C PURPOSE C C To reduce a product of p real general matrices A = A_1*A_2*...*A_p C to upper Hessenberg form, H = H_1*H_2*...*H_p, where H_1 is C upper Hessenberg, and H_2, ..., H_p are upper triangular, by using C orthogonal similarity transformations on A, C C Q_1' * A_1 * Q_2 = H_1, C Q_2' * A_2 * Q_3 = H_2, C ... C Q_p' * A_p * Q_1 = H_p. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the square matrices A_1, A_2, ..., A_p. C N >= 0. C C P (input) INTEGER C The number of matrices in the product A_1*A_2*...*A_p. C P >= 1. C C ILO (input) INTEGER C IHI (input) INTEGER C It is assumed that all matrices A_j, j = 2, ..., p, are C already upper triangular in rows and columns 1:ILO-1 and C IHI+1:N, and A_1 is upper Hessenberg in rows and columns C 1:ILO-1 and IHI+1:N, with A_1(ILO,ILO-1) = 0 (unless C ILO = 1), and A_1(IHI+1,IHI) = 0 (unless IHI = N). C If this is not the case, ILO and IHI should be set to 1 C and N, respectively. C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA1,LDA2,P) C On entry, the leading N-by-N-by-P part of this array must C contain the matrices of factors to be reduced; C specifically, A(*,*,j) must contain A_j, j = 1, ..., p. C On exit, the leading N-by-N upper triangle and the first C subdiagonal of A(*,*,1) contain the upper Hessenberg C matrix H_1, and the elements below the first subdiagonal, C with the first column of the array TAU represent the C orthogonal matrix Q_1 as a product of elementary C reflectors. See FURTHER COMMENTS. C For j > 1, the leading N-by-N upper triangle of A(*,*,j) C contains the upper triangular matrix H_j, and the elements C below the diagonal, with the j-th column of the array TAU C represent the orthogonal matrix Q_j as a product of C elementary reflectors. See FURTHER COMMENTS. C C LDA1 INTEGER C The first leading dimension of the array A. C LDA1 >= max(1,N). C C LDA2 INTEGER C The second leading dimension of the array A. C LDA2 >= max(1,N). C C TAU (output) DOUBLE PRECISION array, dimension (LDTAU,P) C The leading N-1 elements in the j-th column contain the C scalar factors of the elementary reflectors used to form C the matrix Q_j, j = 1, ..., P. See FURTHER COMMENTS. C C LDTAU INTEGER C The leading dimension of the array TAU. C LDTAU >= max(1,N-1). 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 METHOD C C The algorithm consists in ihi-ilo major steps. In each such C step i, ilo <= i <= ihi-1, the subdiagonal elements in the i-th C column of A_j are annihilated using a Householder transformation C from the left, which is also applied to A_(j-1) from the right, C for j = p:-1:2. Then, the elements below the subdiagonal of the C i-th column of A_1 are annihilated, and the Householder C transformation is also applied to A_p from the right. C See FURTHER COMMENTS. C C REFERENCES C C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. C The periodic Schur decomposition: algorithms and applications. C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, C 1992. C C [2] Sreedhar, J. and Van Dooren, P. C Periodic Schur form and some matrix equations. C Proc. of the Symposium on the Mathematical Theory of Networks C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. C C NUMERICAL ASPECTS C C The algorithm is numerically stable. C C FURTHER COMMENTS C C Each matrix Q_j is represented as a product of (ihi-ilo) C elementary reflectors, C C Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). C C Each H_j(i), i = ilo, ..., ihi-1, has the form C C H_j(i) = I - tau_j * v_j * v_j', C C where tau_j is a real scalar, and v_j is a real vector with C v_j(1:i) = 0, v_j(i+1) = 1 and v_j(ihi+1:n) = 0; v_j(i+2:ihi) C is stored on exit in A_j(i+2:ihi,i), and tau_j in TAU(i,j). C C The contents of A_1 are illustrated by the following example C for n = 7, ilo = 2, and ihi = 6: C C on entry on exit C C ( a a a a a a a ) ( a h h h h h a ) C ( 0 a a a a a a ) ( 0 h h h h h a ) C ( 0 a a a a a a ) ( 0 h h h h h h ) C ( 0 a a a a a a ) ( 0 v2 h h h h h ) C ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) C ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) C ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) C C where a denotes an element of the original matrix A_1, h denotes C a modified element of the upper Hessenberg matrix H_1, and vi C denotes an element of the vector defining H_1(i). C C The contents of A_j, j > 1, are illustrated by the following C example for n = 7, ilo = 2, and ihi = 6: C C on entry on exit C C ( a a a a a a a ) ( a h h h h h a ) C ( 0 a a a a a a ) ( 0 h h h h h h ) C ( 0 a a a a a a ) ( 0 v2 h h h h h ) C ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) C ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) C ( 0 a a a a a a ) ( 0 v2 v3 v4 v5 h h ) C ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) C C where a denotes an element of the original matrix A_j, h denotes C a modified element of the upper triangular matrix H_j, and vi C denotes an element of the vector defining H_j(i). (The element C (1,2) in A_p is also unchanged for this example.) C C Note that for P = 1, the LAPACK Library routine DGEHRD could be C more efficient on some computer architectures than this routine C (a BLAS 2 version). C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. C Partly based on the routine PSHESS by A. Varga C (DLR Oberpfaffenhofen), November 26, 1995. C C REVISIONS C C - C C KEYWORDS C C Hessenberg form, orthogonal transformation, periodic systems, C similarity transformation, triangular form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. C .. Scalar Arguments .. INTEGER IHI, ILO, INFO, LDA1, LDA2, LDTAU, N, P C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * ) C .. C .. Local Scalars .. INTEGER I, I1, I2, J, NH C .. C .. Local Arrays .. DOUBLE PRECISION DUMMY( 1 ) C .. C .. External Subroutines .. EXTERNAL DCOPY, DLARFG, MB04PY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( P.LT.1 ) THEN INFO = -2 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -3 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -4 ELSE IF( LDA1.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDA2.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDTAU.LT.MAX( 1, N-1 ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03VD', -INFO ) RETURN END IF C C Quick return if possible. C NH = IHI - ILO + 1 IF ( NH.LE.1 ) $ RETURN C DUMMY( 1 ) = ZERO C DO 20 I = ILO, IHI - 1 I1 = I + 1 I2 = MIN( I+2, N ) C DO 10 J = P, 2, -1 C C Set the elements 1:ILO-1 and IHI:N-1 of TAU(*,J) to zero. C CALL DCOPY( ILO-1, DUMMY, 0, TAU( 1, J ), 1 ) IF ( IHI.LT.N ) $ CALL DCOPY( N-IHI, DUMMY, 0, TAU( IHI, J ), 1 ) C C Compute elementary reflector H_j(i) to annihilate C A_j(i+1:ihi,i). C CALL DLARFG( IHI-I+1, A( I, I, J ), A( I1, I, J ), 1, $ TAU( I, J ) ) C C Apply H_j(i) to A_(j-1)(1:ihi,i:ihi) from the right. C CALL MB04PY( 'Right', IHI, IHI-I+1, A( I1, I, J ), $ TAU( I, J ), A( 1, I, J-1 ), LDA1, DWORK ) C C Apply H_j(i) to A_j(i:ihi,i+1:n) from the left. C CALL MB04PY( 'Left', IHI-I+1, N-I, A( I1, I, J ), $ TAU( I, J ), A( I, I1, J ), LDA1, DWORK ) 10 CONTINUE C C Compute elementary reflector H_1(i) to annihilate C A_1(i+2:ihi,i). C CALL DLARFG( IHI-I, A( I1, I, 1 ), A( I2, I, 1 ), 1, $ TAU( I, 1 ) ) C C Apply H_1(i) to A_p(1:ihi,i+1:ihi) from the right. C CALL MB04PY( 'Right', IHI, IHI-I, A( I2, I, 1 ), TAU( I, 1 ), $ A( 1, I1, P ), LDA1, DWORK ) C C Apply H_1(i) to A_1(i+1:ihi,i+1:n) from the left. C CALL MB04PY( 'Left', IHI-I, N-I, A( I2, I, 1 ), TAU( I, 1 ), $ A( I1, I1, 1 ), LDA1, DWORK ) 20 CONTINUE C RETURN C C *** Last line of MB03VD *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03BT.f0000644000000000000000000000013215012430707016177 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SG03BT.f0000644000175000017500000004572415012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE SG03BT( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, $ ZWORK, INFO ) C C PURPOSE C C To compute the Cholesky factor U of the matrix X, X = U**H * U or C X = U * U**H, which is the solution of the generalized c-stable C continuous-time Lyapunov equation C C H H 2 H C A * X * E + E * X * A = - SCALE * B * B, (1) C C or the conjugate transposed equation C C H H 2 H C A * X * E + E * X * A = - SCALE * B * B , (2) C C respectively, where A, E, B, and U are complex N-by-N matrices. C The Cholesky factor U of the solution is computed without first C finding X. The pencil A - lambda * E must be in complex C generalized Schur form (A and E are upper triangular and the C diagonal elements of E are non-negative real numbers). Moreover, C it must be c-stable, i.e., its eigenvalues must have negative real C parts. B must be an upper triangular matrix with real non-negative C entries on its main diagonal. C C The resulting matrix U is upper triangular. The entries on its C main diagonal are non-negative. SCALE is an output scale factor C set to avoid overflow in U. C C ARGUMENTS C C Mode Parameters C C TRANS CHARACTER*1 C Specifies whether equation (1) or equation (2) is to be C solved: C = 'N': Solve equation (1); C = 'C': Solve equation (2). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices. N >= 0. C C A (input/workspace) COMPLEX*16 array, dimension (LDA,N) C The leading N-by-N upper triangular part of this array C must contain the triangular matrix A. The lower triangular C part is used as workspace, but the diagonal is restored. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C E (input/workspace) COMPLEX*16 array, dimension (LDE,N) C The leading N-by-N upper triangular part of this array C must contain the triangular matrix E. If TRANS = 'N', the C strictly lower triangular part is used as workspace. C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,N). C C B (input/output) COMPLEX*16 array, dimension (LDB,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the matrix B. C On exit, the leading N-by-N upper triangular part of this C array contains the solution matrix U. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,N). C C SCALE (output) DOUBLE PRECISION C The scale factor set to avoid overflow in U. C 0 < SCALE <= 1. C C Workspace C C DWORK DOUBLE PRECISION array, dimension MAX(N-1,0) C C ZWORK COMPLEX*16, dimension MAX(3*N-3,0) 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 = 3: the pencil A - lambda * E is not stable, i.e., there C is an eigenvalue without a negative real part. C C METHOD C C The method used by the routine is an extension of Hammarling's C algorithm [1] to generalized Lyapunov equations. The real case is C described in [2]. C C We present the method for solving equation (1). Equation (2) can C be treated in a similar fashion. For simplicity, assume SCALE = 1. C C Since all matrices A, E, B, and U are upper triangular, we use the C following partitioning C C ( A11 A12 ) ( E11 E12 ) C A = ( ), E = ( ), C ( 0 A22 ) ( 0 E22 ) C C ( B11 B12 ) ( U11 U12 ) C B = ( ), U = ( ), (3) C ( 0 B22 ) ( 0 U22 ) C C where the size of the (1,1)-blocks is 1-by-1. C C We compute U11, U12**H and U22 in three steps. C C Step I: C C From (1) and (3) we get the 1-by-1 equation C C H H H H H C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 = -B11 * B11. C C For brevity, details are omitted here. The technique for C computing U11 is similar to those applied to standard Lyapunov C equations in Hammarling's algorithm ([1], section 5). C C Furthermore, the auxiliary scalars M1 and M2 defined as follows C C M1 = A11 / E11 , M2 = B11 / E11 / U11 , C C are computed in a numerically reliable way. C C Step II: C C We solve for U12**H the linear system of equations, with C scaling to prevent overflow, C C H H H C ( A22 + M1 * E22 ) U12 = C C H H H C = - M2 * B12 - U11 * ( A12 + M1 * E12 ) . C C Step III: C C One can show that C C H H H H C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = C C H H C - B22 * B22 - y * y (4) C C holds, where y is defined as follows C C H H H H C y = B12 - M2 * ( U11 * E12 + E22 * U12 ). C C If B22_tilde is the square triangular matrix arising from the C QR-factorization C C ( B22_tilde ) ( B22 ) C Q * ( ) = ( ), C ( 0 ) ( y**H ) C C then C C H H H C - B22 * B22 - y * y = - B22_tilde * B22_tilde. C C Replacing the right hand side in (4) by the term C - B22_tilde**H * B22_tilde leads to a generalized Lyapunov C equation like (1), but of dimension N-1. C C The solution U of the equation (1) can be obtained by recursive C application of the steps I to III. C C REFERENCES C C [1] Hammarling, S.J. C Numerical solution of the stable, non-negative definite C Lyapunov equation. C IMA J. Num. Anal., 2, pp. 303-323, 1982. 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 The routine requires 2*N**3 flops. Note that we count a single C floating point arithmetic operation as one flop. C C FURTHER COMMENTS C C The Lyapunov equation may be very ill-conditioned. In particular, C if the pencil A - lambda * E has a pair of almost degenerate C eigenvalues, then the Lyapunov equation will be ill-conditioned. C Perturbed values were used to solve the equation. C A condition estimate can be obtained from the routine SG03AD. C C CONTRIBUTOR C C V. Sima, June 2021. C C REVISIONS C C V. Sima, July 2021, Oct. 2021, Nov. 2021. C C KEYWORDS C C Lyapunov equation C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION MONE, ONE, TWO, ZERO PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, $ ZERO = 0.0D+0 ) C .. Scalar Arguments .. CHARACTER TRANS DOUBLE PRECISION SCALE INTEGER INFO, LDA, LDB, LDE, N C .. Array Arguments .. DOUBLE PRECISION DWORK(*) COMPLEX*16 A(LDA,*), B(LDB,*), E(LDE,*), ZWORK(*) C .. Local Scalars .. COMPLEX*16 M1, R, S, X, Z DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, M2, SCALE1, SMLNUM, $ SQTWO, T, UII INTEGER APT, I, J, KL, KL1, UPT, WPT LOGICAL NOTRNS C .. External Functions .. DOUBLE PRECISION DLAMCH LOGICAL LSAME EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DLABAD, MA02EZ, XERBLA, ZAXPY, ZCOPY, ZDSCAL, $ ZLACGV, ZLARTG, ZLASCL, ZLATRS, ZROT, ZTRMV C .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, DCONJG, MAX, SQRT 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, 'C' ) ) ) 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 ( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE INFO = 0 END IF IF ( INFO.NE.0 ) THEN CALL XERBLA( 'SG03BT', -INFO ) RETURN END IF C SCALE = ONE C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C C Set constants to control overflow. C SQTWO = SQRT( TWO ) EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' )/EPS BIGNUM = ONE/SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) C C Set workspace pointers. C UPT = 1 WPT = N APT = 2*N - 1 C IF ( NOTRNS ) THEN C C Solve equation (1). C C Store the last N-1 diagonal elements of A. C Fill-in the strictly lower triangular part of E with the C conjugate transpose of the strictly upper triangular part. C IF ( N.GT.1 ) $ CALL ZCOPY( N-1, A(2,2), LDA+1, ZWORK(APT), 1 ) CALL MA02EZ( 'Upper', 'Conj', 'NoSkew', N, E, LDE ) C C Main Loop. Compute the row elements U(KL,KL:N). C DO 70 KL = 1, N C C STEP I: Compute U(KL,KL) and the auxiliary scalars M1 and C M2. (For the moment the result U(KL,KL) is stored C in UII). C DELTA1 = -DBLE( A(KL,KL) ) IF ( DELTA1.LE.ZERO ) THEN INFO = 3 RETURN END IF DELTA1 = SQRT( DELTA1 )*SQRT( DBLE( E(KL,KL) ) ) T = SQTWO*( DBLE( B(KL,KL) )*SMLNUM ) IF ( T.GT.DELTA1 ) THEN SCALE1 = DELTA1/T SCALE = SCALE1*SCALE CALL ZLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO ) END IF C UII = DBLE( B(KL,KL) )/DELTA1/SQTWO C IF ( KL.LT.N ) THEN C M1 = A(KL,KL)/DBLE( E(KL,KL) ) M2 = ( DELTA1/DBLE( E(KL,KL) ) )*SQTWO C C STEP II: Compute U(KL,KL+1:N) by solving a linear system C of equations. (For the moment the result is C stored in the workspace.) C C Fill-in the lower triangular part of A22 with the C conjugate transpose of the upper triangular part. C CALL MA02EZ( 'Upper', 'Conj', 'General', N-KL+1, $ A(KL,KL), LDA ) C C Form right hand side of the system of equations. C KL1 = KL + 1 CALL ZCOPY( N-KL, A(KL1,KL), 1, ZWORK(UPT), 1 ) CALL ZAXPY( N-KL, M1, E(KL1,KL), 1, ZWORK(UPT), 1 ) I = UPT C DO 10 J = KL1, N ZWORK(I) = -DCMPLX( M2 )*DCONJG( B(KL,J) ) - $ DCMPLX( UII )*ZWORK(I) I = I + 1 10 CONTINUE C C Form the coefficient matrix. C DO 30 J = KL1, N DO 20 I = J, N A(I,J) = A(I,J) + M1*E(I,J) 20 CONTINUE 30 CONTINUE C C Solve the system, with scaling to prevent overflow. C CALL ZLATRS( 'Lower', 'NoConj', 'NoDiag', 'NoNorm', N-KL, $ A(KL1,KL1), LDA, ZWORK(UPT), SCALE1, DWORK, $ INFO ) IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE UII = SCALE1*UII CALL ZLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO ) END IF C C Restore the diagonal of A22. C A(KL,KL) = DCONJG( A(KL,KL) ) CALL ZCOPY( N-KL, ZWORK(APT+KL-1), 1, A(KL1,KL1), LDA+1 ) C C STEP III: Form the right hand side matrix C B(KL+1:N,KL+1:N) of the (smaller) Lyapunov C equation to be solved during the next pass of C the main loop. C C Compute auxiliary vector Y in ZWORK(WPT). C CALL ZCOPY( N-KL, ZWORK(UPT), 1, ZWORK(WPT), 1 ) CALL ZTRMV( 'Lower', 'NoTrans', 'NonUnit', N-KL, $ E(KL1,KL1), LDE, ZWORK(WPT), 1 ) CALL ZAXPY( N-KL, DCMPLX( UII ), E(KL1,KL), 1, $ ZWORK(WPT), 1 ) I = WPT C DO 40 J = KL1, N ZWORK(I) = DCONJG( B(KL,J) ) - M2*ZWORK(I) I = I + 1 40 CONTINUE C CALL ZLACGV( N-KL, ZWORK(WPT), 1 ) C C Overwrite B(KL+1:N,KL+1:N) with the triangular matrix C from the QR-factorization of the (N-KL+1)-by-(N-KL) C matrix C C ( B(KL+1:N,KL+1:N) ) C ( ) . C ( Y**H ) C DO 50 I = 1, N-KL X = B(KL+I,KL+I) Z = ZWORK(WPT+I-1) CALL ZLARTG( X, Z, C, S, R ) B(KL+I,KL+I) = R IF ( I.LT.N-KL ) $ CALL ZROT( N-KL-I, B(KL+I,KL1+I), LDB, $ ZWORK(WPT+I), 1, C, S ) 50 CONTINUE C C Make main diagonal elements of B(KL+1:N,KL+1:N) positive. C DO 60 I = KL1, N IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( N-I+1, MONE, B(I,I), LDB ) 60 CONTINUE C C Overwrite right hand side with the part of the solution C computed in step II. C CALL ZLACGV( N-KL, ZWORK(UPT), 1 ) CALL ZCOPY( N-KL, ZWORK(UPT), 1, B(KL,KL1), LDB ) C END IF C C Overwrite right hand side with the part of the solution C computed in step I. C B(KL,KL) = UII C 70 CONTINUE C ELSE C C Solve equation (2). C C Store the first N-1 diagonal elements of A. C IF ( N.GT.1 ) $ CALL ZCOPY( N-1, A, LDA+1, ZWORK(APT), 1 ) C C Main Loop. Compute the column elements U(1:KL,KL). C DO 120 KL = N, 1, -1 C C STEP I: Compute U(KL,KL) and the auxiliary scalars M1 and C M2. (For the moment the result U(KL,KL) is stored C in UII). C DELTA1 = -DBLE( A(KL,KL) ) IF ( DELTA1.LE.ZERO ) THEN INFO = 3 RETURN END IF DELTA1 = SQRT( DELTA1 )*SQRT( DBLE( E(KL,KL) ) ) T = SQTWO*( DBLE( B(KL,KL) )*SMLNUM ) IF ( T.GT.DELTA1 ) THEN SCALE1 = DELTA1/T SCALE = SCALE1*SCALE CALL ZLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO ) END IF C UII = DBLE( B(KL,KL) )/DELTA1/SQTWO C IF ( KL.GT.1 ) THEN C M1 = DCONJG( A(KL,KL) )/DBLE( E(KL,KL) ) M2 = SQTWO*( DELTA1/DBLE( E(KL,KL) ) ) C C STEP II: Compute U(1:KL,KL) by solving a linear system C of equations. (For the moment the result is C stored in the workspace.) C C Fill-in the strictly lower triangular part of A22 with C the transpose of the strictly upper triangular part. C KL1 = KL - 1 CALL MA02EZ( 'Upper', 'Trans', 'General', KL1, A, LDA ) C C Form right hand side of the system of equations. C CALL ZCOPY( KL1, A(1,KL), 1, ZWORK(UPT), 1 ) CALL ZAXPY( KL1, M1, E(1,KL), 1, ZWORK(UPT), 1 ) CALL ZDSCAL( KL1, -UII, ZWORK(UPT), 1 ) CALL ZAXPY( KL1, -DCMPLX( M2 ), B(1,KL), 1, ZWORK(UPT), $ 1 ) C C Form the coefficient matrix. C DO 90 J = 1, KL1 DO 80 I = 1, J A(I,J) = A(I,J) + M1*E(I,J) 80 CONTINUE 90 CONTINUE C C Solve the system, with scaling to prevent overflow. C CALL ZLATRS( 'Upper', 'NoConj', 'NoDiag', 'NoNorm', KL1, $ A, LDA, ZWORK(UPT), SCALE1, DWORK, INFO ) IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE UII = SCALE1*UII CALL ZLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO ) END IF C C Restore the upper triangular part of A22. C CALL MA02EZ( 'Lower', 'Trans', 'General', KL1, A, LDA ) CALL ZCOPY( KL1, ZWORK(APT), 1, A, LDA+1 ) C C STEP III: Form the right hand side matrix C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov C equation to be solved during the next pass of C the main loop. C C Compute auxiliary vector Y in B(1:KL,KL). C CALL ZCOPY( KL1, ZWORK(UPT), 1, ZWORK(WPT), 1 ) CALL ZTRMV( 'Upper', 'NoTrans', 'NonUnit', KL1, E, LDE, $ ZWORK(WPT), 1 ) CALL ZAXPY( KL1, DCMPLX( UII ), E(1,KL), 1, ZWORK(WPT), $ 1 ) CALL ZAXPY( KL1, -DCMPLX( M2 ), ZWORK(WPT), 1, B(1,KL), $ 1 ) C C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix C from the RQ-factorization of the (KL-1)-by-KL matrix C C ( ) C ( B(1:KL-1,1:KL-1) Y ) . C ( ) C DO 100 I = KL1, 1, -1 X = B(I,I) Z = DCONJG( B(I,KL) ) CALL ZLARTG( X, Z, C, S, R ) B(I,I) = R IF ( I.GT.1 ) $ CALL ZROT( I-1, B(1,I), 1, B(1,KL), 1, C, $ DCONJG( S ) ) 100 CONTINUE C C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. C DO 110 I = 1, KL1 IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( I, MONE, B(1,I), 1 ) 110 CONTINUE C C Overwrite right hand side with the part of the solution C computed in step II. C CALL ZCOPY( KL1, ZWORK(UPT), 1, B(1,KL), 1 ) C END IF C C Overwrite right hand side with the part of the solution C computed in step I. C B(KL,KL) = UII C 120 CONTINUE C END IF C RETURN C *** Last line of SG03BT *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02GD.f0000644000000000000000000000013215012430707016147 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02GD.f0000644000175000017500000001011715012430707017343 0ustar00lilgelilge00000000000000 SUBROUTINE MA02GD( N, A, LDA, K1, K2, IPIV, INCX ) C C PURPOSE C C To perform a series of column interchanges on the matrix A. C One column interchange is initiated for each of columns K1 through C K2 of A. This is useful for solving linear systems X*A = B, when C the matrix A has already been factored by LAPACK Library routine C DGETRF. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix A. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,*) C On entry, the leading N-by-M part of this array must C contain the matrix A to which the column interchanges will C be applied, where M is the largest element of IPIV(K), for C K = K1, ..., K2. C On exit, the leading N-by-M part of this array contains C the permuted matrix. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C K1 (input) INTEGER C The first element of IPIV for which a column interchange C will be done. C C K2 (input) INTEGER C The last element of IPIV for which a column interchange C will be done. C C IPIV (input) INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) C The vector of interchanging (pivot) indices. Only the C elements in positions K1 through K2 of IPIV are accessed. C IPIV(K) = L implies columns K and L are to be C interchanged. C C INCX (input) INTEGER C The increment between successive values of IPIV. C If INCX is negative, the interchanges are applied in C reverse order. C C METHOD C C The columns IPIV(K) and K are swapped for K = K1, ..., K2, for C INCX = 1 (and similarly, for INCX <> 1). C C FURTHER COMMENTS C C This routine is the column-oriented counterpart of the LAPACK C Library routine DLASWP. The LAPACK Library routine DLAPMT cannot C be used in this context. To solve the system X*A = B, where A and C B are N-by-N and M-by-N, respectively, the following statements C can be used: C C CALL DGETRF( N, N, A, LDA, IPIV, INFO ) C CALL DTRSM( 'R', 'U', 'N', 'N', M, N, ONE, A, LDA, B, LDB ) C CALL DTRSM( 'R', 'L', 'N', 'U', M, N, ONE, A, LDA, B, LDB ) C CALL MA02GD( M, B, LDB, 1, N, IPIV, -1 ) C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2008. C C KEYWORDS C C Elementary matrix operations, linear algebra. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N C .. C .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) C .. C .. Local Scalars .. INTEGER J, JP, JX C .. C .. External Subroutines .. EXTERNAL DSWAP C .. C .. Executable Statements .. C C Quick return if possible. C IF( INCX.EQ.0 .OR. N.EQ.0 ) $ RETURN C C Interchange column J with column IPIV(J) for each of columns K1 C through K2. C IF( INCX.GT.0 ) THEN JX = K1 ELSE JX = 1 + ( 1-K2 )*INCX END IF C IF( INCX.EQ.1 ) THEN C DO 10 J = K1, K2 JP = IPIV( J ) IF( JP.NE.J ) $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) 10 CONTINUE C ELSE IF( INCX.GT.1 ) THEN C DO 20 J = K1, K2 JP = IPIV( JX ) IF( JP.NE.J ) $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) JX = JX + INCX 20 CONTINUE C ELSE IF( INCX.LT.0 ) THEN C DO 30 J = K2, K1, -1 JP = IPIV( JX ) IF( JP.NE.J ) $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) JX = JX + INCX 30 CONTINUE C END IF C RETURN C C *** Last line of MA02GD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02PD.f0000644000000000000000000000013015012430707016165 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB02PD.f0000644000175000017500000006056315012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE SB02PD( JOB, TRANA, UPLO, N, A, LDA, G, LDG, Q, LDQ, X, $ LDX, RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To solve the real continuous-time matrix algebraic Riccati C equation C C op(A)'*X + X*op(A) + Q - X*G*X = 0, C C where op(A) = A or A' = A**T and G, Q are symmetric (G = G**T, C Q = Q**T). The matrices A, G and Q are N-by-N and the solution X C is an N-by-N symmetric matrix. C C An error bound on the solution and a condition estimate are also C optionally provided. C C It is assumed that the matrices A, G and Q are such that the C corresponding Hamiltonian matrix has N eigenvalues with negative C real parts. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'X': Compute the solution only; C = 'A': Compute all: the solution, reciprocal condition C number, and the error bound. C C TRANA CHARACTER*1 C Specifies the option op(A): 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 UPLO CHARACTER*1 C Specifies which triangle of the matrices G and Q is C stored, as follows: C = 'U': Upper triangles of G and Q are stored; C = 'L': Lower triangles of G and Q are stored. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, G, Q, and X. N >= 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 coefficient matrix A of the equation. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C G (input) DOUBLE PRECISION array, dimension (LDG,N) C If UPLO = 'U', the leading N-by-N upper triangular part of C this array must contain the upper triangular part of the C matrix G. C If UPLO = 'L', the leading N-by-N lower triangular part of C this array must contain the lower triangular part of the C matrix G. C C LDG INTEGER C The leading dimension of the array G. LDG >= max(1,N). C C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) C If UPLO = 'U', the leading N-by-N upper triangular part of C this array must contain the upper triangular part of the C matrix Q. C If UPLO = 'L', the leading N-by-N lower triangular part of C this array must contain the lower triangular part of the C matrix Q. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= max(1,N). C C X (output) DOUBLE PRECISION array, dimension (LDX,N) C If INFO = 0, INFO = 2, or INFO = 4, the leading N-by-N C part of this array contains the symmetric solution matrix C X of the algebraic Riccati equation. C C LDX INTEGER C The leading dimension of the array X. LDX >= max(1,N). C C RCOND (output) DOUBLE PRECISION C If JOB = 'A', the estimate of the reciprocal condition C number of the Riccati equation. C C FERR (output) DOUBLE PRECISION C If JOB = 'A', the estimated forward error bound for the C solution X. If XTRUE is the true solution, FERR bounds the C magnitude of the largest entry in (X - XTRUE) divided by C the magnitude of the largest entry in X. C C WR (output) DOUBLE PRECISION array, dimension (N) C WI (output) DOUBLE PRECISION array, dimension (N) C If JOB = 'A' and TRANA = 'N', WR and WI contain the real C and imaginary parts, respectively, of the eigenvalues of C the matrix A - G*X, i.e., the closed-loop system poles. C If JOB = 'A' and TRANA = 'T' or 'C', WR and WI contain the C real and imaginary parts, respectively, of the eigenvalues C of the matrix A - X*G, i.e., the closed-loop system poles. C If JOB = 'X', these arrays are not referenced. C C Workspace C C IWORK INTEGER array, dimension (LIWORK), where C LIWORK >= 2*N, if JOB = 'X'; C LIWORK >= max(2*N,N*N), if JOB = 'A'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or INFO = 2, DWORK(1) contains the C optimal value of LDWORK. If JOB = 'A', then DWORK(2:N*N+1) C and DWORK(N*N+2:2*N*N+1) contain a real Schur form of the C closed-loop system matrix, Ac = A - G*X (if TRANA = 'N') C or Ac = A - X*G (if TRANA = 'T' or 'C'), and the C orthogonal matrix which reduced Ac to real Schur form, C respectively. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= 4*N*N + 8*N + 1, if JOB = 'X'; C LDWORK >= max( 4*N*N + 8*N + 1, 6*N*N ), if JOB = 'A'. C For good performance, LDWORK should be larger, e.g., C LDWORK >= 4*N*N + 6*N +( 2*N+1 )*NB, if JOB = 'X', C where NB is the optimal blocksize. 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 = 1: the Hamiltonian matrix has eigenvalues on the C imaginary axis, so the solution and error bounds C could not be computed; C = 2: the iteration for the matrix sign function failed to C converge after 50 iterations, but an approximate C solution and error bounds (if JOB = 'A') have been C computed; C = 3: the system of linear equations for the solution is C singular to working precision, so the solution and C error bounds could not be computed; C = 4: the matrix A-G*X (or A-X*G) cannot be reduced to C Schur canonical form and condition number estimate C and forward error estimate have not been computed. C C METHOD C C The Riccati equation is solved by the matrix sign function C approach [1], [2], implementing a scaling which enhances the C numerical stability [4]. C C REFERENCES C C [1] Bai, Z., Demmel, J., Dongarra, J., Petitet, A., Robinson, H., C and Stanley, K. C The spectral decomposition of nonsymmetric matrices on C distributed memory parallel computers. C SIAM J. Sci. Comput., vol. 18, pp. 1446-1461, 1997. C C [2] Byers, R., He, C., and Mehrmann, V. C The matrix sign function method and the computation of C invariant subspaces. C SIAM J. Matrix Anal. Appl., vol. 18, pp. 615-632, 1997. C C [3] Higham, N.J. C Perturbation theory and backward error for AX-XB=C. C BIT, vol. 33, pp. 124-136, 1993. C C [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V., C DGRSVX and DMSRIC: Fortran 77 subroutines for solving C continuous-time matrix algebraic Riccati equations with C condition and accuracy estimates. C Preprint SFB393/98-16, Fak. f. Mathematik, Technical C University Chemnitz, May 1998. C C NUMERICAL ASPECTS C C The solution accuracy can be controlled by the output parameter C FERR. C C FURTHER COMMENTS C C The condition number of the Riccati equation is estimated as C C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + C norm(Pi)*norm(G) ) / norm(X), C C where Omega, Theta and Pi are linear operators defined by C C Omega(W) = op(Ac)'*W + W*op(Ac), C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), C Pi(W) = inv(Omega(X*W*X)), C C and the matrix Ac (the closed-loop system matrix) is given by C Ac = A - G*X, if TRANA = 'N', or C Ac = A - X*G, if TRANA = 'T' or 'C'. C C The program estimates the quantities C C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), C C norm(Theta) and norm(Pi) using 1-norm condition estimator. C C The forward error bound is estimated using a practical error bound C similar to the one proposed in [3]. C C CONTRIBUTOR C C P. Petkov, Tech. University of Sofia, March 2000. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000; Aug. 2011. C C KEYWORDS C C Algebraic Riccati equation, continuous-time system, C optimal control, optimal regulator. C C ****************************************************************** C C .. Parameters .. INTEGER MAXIT PARAMETER ( MAXIT = 50 ) DOUBLE PRECISION ZERO, HALF, ONE, TWO, TEN PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, $ TWO = 2.0D+0, TEN = 10.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER JOB, TRANA, UPLO INTEGER INFO, LDA, LDG, LDQ, LDWORK, LDX, N DOUBLE PRECISION FERR, RCOND C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), $ Q( LDQ, * ), WI( * ), WR( * ), X( LDX, * ) C .. C .. Local Scalars .. LOGICAL ALL, LOWER, LQUERY, NOTRNA CHARACTER EQUED, LOUP INTEGER I, IAF, IB, IBR, IC, IFR, IJ, IJ1, IJ2, INFO2, $ INI, IR, ISCL, ISV, IT, ITAU, ITER, IU, IWRK, $ J, JI, LWAMAX, MINWRK, N2, SDIM DOUBLE PRECISION CONV, GNORM2, EPS, HNORM, HINNRM, QNORM2, $ SCALE, SEP, TEMP, TOL C .. C .. Local Arrays .. LOGICAL BWORK( 1 ) C .. C .. External Functions .. LOGICAL LSAME, SELECT DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL DLAMCH, DLANSY, LSAME, SELECT C .. C .. External Subroutines .. EXTERNAL DCOPY, DGEES, DGEQP3, DGESVX, DLACPY, DLASCL, $ DLASET, DORMQR, DSCAL, DSWAP, DSYMM, DSYTRF, $ DSYTRI, MA02AD, MA02ED, SB02QD, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, SQRT C .. C .. Executable Statements .. C C Decode and Test input parameters. C ALL = LSAME( JOB, 'A' ) NOTRNA = LSAME( TRANA, 'N' ) LOWER = LSAME( UPLO, 'L' ) LQUERY = LDWORK.EQ.-1 C INFO = 0 IF( .NOT.ALL .AND. .NOT.LSAME( JOB, 'X' ) ) THEN INFO = -1 ELSE IF( .NOT.LSAME( TRANA, 'T' ) .AND. $ .NOT.LSAME( TRANA, 'C' ) .AND. .NOT.NOTRNA ) THEN INFO = -2 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDG.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE C C Compute workspace. C N2 = 2*N IF( ALL ) THEN MINWRK = MAX( N2*N2 + 8*N + 1, 6*N*N ) ELSE MINWRK = N2*N2 + 8*N + 1 END IF ITAU = N2*N2 IWRK = ITAU + N2 IF ( LQUERY ) THEN CALL DSYTRF( UPLO, N2, DWORK, N2, IWORK, DWORK, -1, INFO2 ) LWAMAX = INT( DWORK( 1 ) ) CALL DGEQP3( N2, N2, DWORK, N2, IWORK, DWORK, DWORK, -1, $ INFO2 ) LWAMAX = MAX( INT( DWORK( 1 ) ), LWAMAX ) CALL DORMQR( 'L', 'N', N2, N, N, DWORK, N2, DWORK, DWORK, $ N2, DWORK, -1, INFO2 ) LWAMAX = MAX( IWRK + MAX( INT( DWORK( 1 ) ), LWAMAX ), $ MINWRK ) IF( ALL ) THEN CALL DGEES( 'V', 'N', SELECT, N, DWORK, N, SDIM, WR, WI, $ DWORK, N, DWORK, -1, BWORK, INFO2 ) LWAMAX = MAX( N2*N + INT( DWORK( 1 ) ), LWAMAX ) CALL SB02QD( 'B', 'F', TRANA, UPLO, 'O', N, A, LDA, $ DWORK, N, DWORK, N, G, LDG, Q, LDQ, X, LDX, $ SEP, RCOND, FERR, IWORK, DWORK, -1, INFO2 ) LWAMAX = MAX( N2*N + INT( DWORK( 1 ) ), LWAMAX ) END IF END IF IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) $ INFO = -19 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB02PD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = LWAMAX RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IF( ALL ) THEN RCOND = ONE FERR = ZERO END IF DWORK(1) = ONE RETURN END IF C C Set tol. C EPS = DLAMCH( 'P' ) TOL = TEN*DBLE( N )*EPS C C Compute the square-roots of the norms of the matrices Q and G . C QNORM2 = SQRT( DLANSY( '1', UPLO, N, Q, LDQ, DWORK ) ) GNORM2 = SQRT( DLANSY( '1', UPLO, N, G, LDG, DWORK ) ) C C Construct the lower (if UPLO = 'L') or upper (if UPLO = 'U') C triangle of the symmetric block-permuted Hamiltonian matrix. C During iteration, both the current iterate corresponding to the C Hamiltonian matrix, and its inverse are needed. To reduce the C workspace length, the transpose of the triangle specified by UPLO C of the current iterate H is saved in the opposite triangle, C suitably shifted with one column, and then the inverse of H C overwrites H. The triangles of the saved iterate and its inverse C are stored together in an 2*N-by-(2*N+1) matrix. For instance, if C UPLO = 'U', then the upper triangle is built starting from the C location 2*N+1 of the array DWORK, so that its transpose can be C stored in the lower triangle of DWORK. C Workspace: need 4*N*N, if UPLO = 'L'; C 4*N*N + 2*N, if UPLO = 'U'. C IF ( LOWER ) THEN INI = 0 ISV = N2 LOUP = 'U' C DO 40 J = 1, N IJ = ( J - 1 )*N2 + J C DO 10 I = J, N DWORK(IJ) = -Q(I,J) IJ = IJ + 1 10 CONTINUE C IF( NOTRNA ) THEN C DO 20 I = 1, N DWORK( IJ ) = -A( I, J ) IJ = IJ + 1 20 CONTINUE C ELSE C DO 30 I = 1, N DWORK( IJ ) = -A( J, I ) IJ = IJ + 1 30 CONTINUE C END IF 40 CONTINUE C DO 60 J = 1, N IJ = ( N + J - 1 )*N2 + N + J C DO 50 I = J, N DWORK( IJ ) = G( I, J ) IJ = IJ + 1 50 CONTINUE C 60 CONTINUE C ELSE INI = N2 ISV = 0 LOUP = 'L' C DO 80 J = 1, N IJ = J*N2 + 1 C DO 70 I = 1, J DWORK(IJ) = -Q(I,J) IJ = IJ + 1 70 CONTINUE C 80 CONTINUE C DO 120 J = 1, N IJ = ( N + J )*N2 + 1 C IF( NOTRNA ) THEN C DO 90 I = 1, N DWORK( IJ ) = -A( J, I ) IJ = IJ + 1 90 CONTINUE C ELSE C DO 100 I = 1, N DWORK( IJ ) = -A( I, J ) IJ = IJ + 1 100 CONTINUE C END IF C DO 110 I = 1, J DWORK( IJ ) = G( I, J ) IJ = IJ + 1 110 CONTINUE C 120 CONTINUE C END IF C C Block-scaling. C ISCL = 0 IF( QNORM2.GT.GNORM2 .AND. GNORM2.GT.ZERO ) THEN CALL DLASCL( UPLO, 0, 0, QNORM2, GNORM2, N, N, DWORK( INI+1 ), $ N2, INFO2 ) CALL DLASCL( UPLO, 0, 0, GNORM2, QNORM2, N, N, $ DWORK( N2*N+N+INI+1 ), N2, INFO2 ) ISCL = 1 END IF C C Compute the matrix sign function. C DO 230 ITER = 1, MAXIT C C Save the transpose of the corresponding triangle of the C current iterate in the free locations of the shifted opposite C triangle. C Workspace: need 4*N*N + 2*N. C IF( LOWER ) THEN C DO 130 I = 1, N2 CALL DCOPY( I, DWORK( I ), N2, DWORK( I*N2+1 ), 1 ) 130 CONTINUE C ELSE C DO 140 I = 1, N2 CALL DCOPY( I, DWORK( I*N2+1 ), 1, DWORK( I ), N2 ) 140 CONTINUE C END IF C C Store the norm of the Hamiltonian matrix. C HNORM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK ) C C Compute the inverse of the block-permuted Hamiltonian matrix. C Workspace: need 4*N*N + 2*N + 1; C prefer 4*N*N + 2*N + 2*N*NB. C CALL DSYTRF( UPLO, N2, DWORK( INI+1 ), N2, IWORK, $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 1 RETURN END IF LWAMAX = MAX( LWAMAX, IWRK + INT( DWORK( IWRK+1 ) ) ) C C Workspace: need 4*N*N + 4*N. C CALL DSYTRI( UPLO, N2, DWORK( INI+1 ), N2, IWORK, $ DWORK( IWRK+1 ), INFO2 ) C C Block-permutation of the inverse matrix. C IF( LOWER ) THEN C DO 160 J = 1, N IJ2 = ( N + J - 1 )*N2 + N + J C DO 150 IJ1 = ( J - 1 )*N2 + J, ( J - 1 )*N2 + N TEMP = DWORK( IJ1 ) DWORK( IJ1 ) = -DWORK( IJ2 ) DWORK( IJ2 ) = -TEMP IJ2 = IJ2 + 1 150 CONTINUE C CALL DSWAP( J-1, DWORK( N+J ), N2, DWORK( (J-1)*N2+N+1 ), $ 1 ) 160 CONTINUE C ELSE C DO 180 J = 1, N IJ2 = ( N + J )*N2 + N + 1 C DO 170 IJ1 = J*N2 + 1, J*N2 + J TEMP = DWORK( IJ1 ) DWORK( IJ1 ) = -DWORK( IJ2 ) DWORK( IJ2 ) = -TEMP IJ2 = IJ2 + 1 170 CONTINUE C CALL DSWAP( J-1, DWORK( (N+1)*N2+J ), N2, $ DWORK( (N+J)*N2+1 ), 1 ) 180 CONTINUE C END IF C C Scale the Hamiltonian matrix and its inverse and compute C the next iterate. C HINNRM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK ) SCALE = SQRT( HINNRM / HNORM ) C IF( LOWER ) THEN C DO 200 J = 1, N2 JI = ( J - 1 )*N2 + J C DO 190 IJ = JI, J*N2 JI = JI + N2 DWORK( IJ ) = ( DWORK( IJ ) / SCALE + $ DWORK( JI )*SCALE ) / TWO DWORK( JI ) = DWORK( JI ) - DWORK( IJ ) 190 CONTINUE C 200 CONTINUE C ELSE C DO 220 J = 1, N2 JI = J C DO 210 IJ = J*N2 + 1, J*N2 + J DWORK( IJ ) = ( DWORK( IJ ) / SCALE + $ DWORK( JI )*SCALE ) / TWO DWORK( JI ) = DWORK( JI ) - DWORK( IJ ) JI = JI + N2 210 CONTINUE C 220 CONTINUE C END IF C C Test for convergence. C CONV = DLANSY( 'F', LOUP, N2, DWORK( ISV+1 ), N2, DWORK ) IF( CONV.LE.TOL*HNORM ) GO TO 240 230 CONTINUE C C No convergence after MAXIT iterations, but an approximate solution C has been found. C INFO = 2 C 240 CONTINUE C C If UPLO = 'U', shift the upper triangle one column to the left. C IF( .NOT.LOWER ) $ CALL DLACPY( 'U', N2, N2, DWORK( INI+1 ), N2, DWORK, N2 ) C C Divide the triangle elements by -2 and then fill-in the other C triangle by symmetry. C IF( LOWER ) THEN C DO 250 I = 1, N2 CALL DSCAL( N2-I+1, -HALF, DWORK( (I-1)*N2+I ), 1 ) 250 CONTINUE C ELSE C DO 260 I = 1, N2 CALL DSCAL( I, -HALF, DWORK( (I-1)*N2+1 ), 1 ) 260 CONTINUE C END IF CALL MA02ED( UPLO, N2, DWORK, N2 ) C C Back block-permutation. C DO 280 J = 1, N2 C DO 270 I = ( J - 1 )*N2 + 1, ( J - 1 )*N2 + N TEMP = DWORK( I ) DWORK( I ) = -DWORK( I+N ) DWORK( I+N ) = TEMP 270 CONTINUE C 280 CONTINUE C C Compute the QR decomposition of the projector onto the stable C invariant subspace. C Workspace: need 4*N*N + 8*N + 1. C prefer 4*N*N + 6*N + ( 2*N+1 )*NB. C DO 290 I = 1, N2 IWORK( I ) = 0 DWORK( ( I-1 )*N2 + I ) = DWORK( ( I-1 )*N2 + I ) + HALF 290 CONTINUE C CALL DGEQP3( N2, N2, DWORK, N2, IWORK, DWORK( ITAU+1 ), $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) LWAMAX = MAX( LWAMAX, IWRK + INT( DWORK( IWRK+1 ) ) ) C C Accumulate the orthogonal transformations. Note that only the C first N columns of the array DWORK, returned by DGEQP3, are C needed, so that the last N columns of DWORK are used to get the C orthogonal basis for the stable invariant subspace. C Workspace: need 4*N*N + 3*N. C prefer 4*N*N + 2*N + N*NB. C IB = N*N IAF = N2*N CALL DLASET( 'F', N2, N, ZERO, ONE, DWORK( IAF+1 ), N2 ) CALL DORMQR( 'L', 'N', N2, N, N, DWORK, N2, DWORK( ITAU+1 ), $ DWORK( IAF+1 ), N2, DWORK( IWRK+1 ), LDWORK-IWRK, $ INFO2 ) LWAMAX = MAX( LWAMAX, IWRK + INT( DWORK( IWRK+1 ) ) ) C C Store the matrices V11 and V21' . C CALL DLACPY( 'F', N, N, DWORK( IAF+1 ), N2, DWORK, N ) CALL MA02AD( 'F', N, N, DWORK( IAF+N+1 ), N2, DWORK( IB+1 ), N ) C IR = IAF + IB IC = IR + N IFR = IC + N IBR = IFR + N IWRK = IBR + N C C Compute the solution matrix X . C Workspace: need 3*N*N + 8*N. C CALL DGESVX( 'E', 'T', N, N, DWORK, N, DWORK( IAF+1 ), N, $ IWORK, EQUED, DWORK( IR+1 ), DWORK( IC+1 ), $ DWORK( IB+1 ), N, X, LDX, RCOND, DWORK( IFR+1 ), $ DWORK( IBR+1 ), DWORK( IWRK+1 ), IWORK( N+1 ), $ INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 3 RETURN END IF C C Symmetrize the solution. C DO 310 I = 1, N - 1 C DO 300 J = I + 1, N TEMP = ( X( I, J ) + X( J, I ) ) / TWO X( I, J ) = TEMP X( J, I ) = TEMP 300 CONTINUE C 310 CONTINUE C C Undo scaling for the solution matrix. C IF( ISCL.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, GNORM2, QNORM2, N, N, X, LDX, INFO2 ) END IF C IF( ALL ) THEN C C Compute the estimates of the reciprocal condition number and C error bound. C Workspace usage. C IT = 0 IU = IT + N*N IWRK = IU + N*N C CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IT+1 ), N ) IF( NOTRNA ) THEN C C Compute Ac = A-G*X . C CALL DSYMM( 'L', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, $ DWORK( IT+1 ), N ) ELSE C C Compute Ac = A-X*G . C CALL DSYMM( 'R', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, $ DWORK( IT+1 ), N ) END IF C C Compute the Schur factorization of Ac . C Workspace: need 2*N*N + 5*N; C prefer larger. C CALL DGEES( 'V', 'N', SELECT, N, DWORK( IT+1 ), N, SDIM, WR, $ WI, DWORK( IU+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK, $ BWORK, INFO2 ) IF( INFO2.GT.0 ) THEN INFO = 4 RETURN END IF LWAMAX = MAX( LWAMAX, IWRK + INT( DWORK( IWRK+1 ) ) ) C C Estimate the reciprocal condition number and the forward error. C Workspace: need 6*N*N; C prefer larger. C CALL SB02QD( 'B', 'F', TRANA, UPLO, 'O', N, A, LDA, $ DWORK( IT+1 ), N, DWORK( IU+1 ), N, G, LDG, Q, $ LDQ, X, LDX, SEP, RCOND, FERR, IWORK, $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) LWAMAX = MAX( LWAMAX, IWRK + INT( DWORK( IWRK+1 ) ) ) END IF C DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB02PD END control-4.1.2/src/slicot/src/PaxHeaders/MB03RX.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03RX.f0000644000175000017500000001661615012430707017416 0ustar00lilgelilge00000000000000 SUBROUTINE MB03RX( JOBV, N, KL, KU, A, LDA, X, LDX, WR, WI, $ DWORK ) C C PURPOSE C C To reorder the diagonal blocks of the principal submatrix between C the indices KL and KU (KU >= KL) of a real Schur form matrix A C together with their eigenvalues, using orthogonal similarity C transformations, such that the block specified by KU is moved in C the position KL. The transformations are optionally postmultiplied C in a given matrix X. C C ARGUMENTS C C Mode Parameters C C JOBV CHARACTER*1 C Specifies whether or not the transformations are C accumulated, as follows: C = 'N': The transformations are not accumulated; C = 'V': The transformations are accumulated in X (the C given matrix X is updated). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and X. N >= 0. C C KL (input) INTEGER C The lower boundary index for the rows and columns of the C principal submatrix of A whose diagonal blocks are to be C reordered, and also the target position for the block to C be moved. 1 <= KL <= KU <= N. C C KU (input/output) INTEGER C On entry, KU specifies the upper boundary index for the C rows and columns of the principal submatrix of A whose C diagonal blocks are to be reordered, and also the original C position for the block to be moved. 1 <= KL <= KU <= N. C On exit, KU specifies the upper boundary index for the C rows and columns of the principal submatrix of A whose C diagonal blocks have been reordered. The given value will C be increased by 1 if the moved block was 2-by-2 and it has C been replaced by two 1-by-1 blocks. Otherwise, its input C value is preserved. 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 in real Schur canonical form. C On exit, the leading N-by-N part of this array contains C the ordered real Schur canonical form. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) C On entry, if JOBV = 'V', the leading N-by-N part of this C array must contain a given matrix X. C On exit, if JOBV = 'V', the leading N-by-N part of this C array contains the product of the given matrix X and the C transformation matrix that performed the reordering of A. C If JOBV = 'N', this array is not referenced. C C LDX INTEGER C The leading dimension of array X. C LDX >= 1, if JOBV = 'N'; C LDX >= MAX(1,N), if JOBV = 'V'. C C WR, (input/output) DOUBLE PRECISION arrays, dimension (N) C WI On entry, these arrays must contain the real and imaginary C parts, respectively, of the eigenvalues of the matrix A. C On exit, these arrays contain the real and imaginary C parts, respectively, of the eigenvalues of the matrix A, C possibly reordered. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (N) C C METHOD C C An attempt is made to move the block in the position (KU,KU) to C the position (KL,KL) by a sequence of orthogonal similarity C transformations, each swapping two consecutive blocks. The C standard algorithm [1], [2] usually succeeds to perform this C reordering. A failure of this algorithm means that two consecutive C blocks (one of them being the desired block possibly moved) are C too close to swap. In such a case, the leading block of the two C is tried to be moved in the position (KL,KL) and the procedure is C repeated. 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 [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C The algorithm is numerically stable. If some eigenvalues are C ill-conditioned, their returned values could differ much from C their input values. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. C C REVISIONS C C - C C KEYWORDS C C Eigenvalue, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER JOBV INTEGER KL, KU, LDA, LDX, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*) C .. Local Scalars .. INTEGER IERR, IFST, ILST, L C .. External Subroutines .. EXTERNAL DTREXC C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Executable Statements .. C IF ( KU.GT.KL ) THEN C C Try to move the block in position (KU,KU) to position (KL,KL). C IFST = KU C REPEAT 10 CONTINUE ILST = KL CALL DTREXC( JOBV, N, A, LDA, X, LDX, IFST, ILST, DWORK, IERR ) IF ( IERR.NE.0 ) THEN C C During calculations, two adjacent blocks were too close C to swap; the desired block cannot be moved further, but the C block above it is suitable and is tried for moving. The C number of repeat cycles is usually 1, and at most the number C of blocks between the current position and the position KL. C IFST = ILST - 1 IF ( IFST.GT.1 ) THEN IF ( A(IFST,IFST-1).NE.ZERO ) $ IFST = ILST - 2 END IF IF ( ILST.GT.KL ) $ GO TO 10 END IF C UNTIL ( ILST.EQ.KL on output from DTREXC ) C C Recompute the eigenvalues for the modified part of A. C Note that KU must be incremented if the moved block was 2-by-2 C and it has been replaced by two 1-by-1 blocks. C IF ( WI(KU).NE.ZERO ) THEN IF ( A(KU+1,KU).EQ.ZERO ) $ KU = KU + 1 END IF C L = KL C WHILE ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) DO 20 IF ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) THEN IF ( A(L+1,L).NE.ZERO ) THEN C C A 2x2 block. C WR(L) = A(L,L) WR(L+1) = WR(L) WI(L) = SQRT( ABS( A(L,L+1) ) )* $ SQRT( ABS( A(L+1,L) ) ) WI(L+1) = -WI(L) L = L + 2 ELSE C C An 1x1 block. C WR(L) = A(L,L) WI(L) = ZERO L = L + 1 END IF GO TO 20 ELSE IF ( L.EQ.N ) THEN WR(L) = A(L,L) WI(L) = ZERO END IF C END WHILE 20 END IF C RETURN C *** Last line of MB03RX *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01HX.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01HX.f0000644000175000017500000005622015012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE TG01HX( COMPQ, COMPZ, L, N, M, P, N1, LBE, A, LDA, $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) C C PURPOSE C C Given the descriptor system (A-lambda*E,B,C) with the system C matrices A, E and B of the form C C ( A1 X1 ) ( E1 Y1 ) ( B1 ) C A = ( ) , E = ( ) , B = ( ) , C ( 0 X2 ) ( 0 Y2 ) ( 0 ) C C where C - B is an L-by-M matrix, with B1 an N1-by-M submatrix C - A is an L-by-N matrix, with A1 an N1-by-N1 submatrix C - E is an L-by-N matrix, with E1 an N1-by-N1 submatrix C with LBE nonzero sub-diagonals, C this routine reduces the pair (A1-lambda*E1,B1) to the form C C Qc'*[B1 A1-lambda*E1]*diag(I,Zc) = C C ( Bc Ac-lambda*Ec * ) C ( ) , C ( 0 0 Anc-lambda*Enc ) C C where: C 1) the pencil ( Bc Ac-lambda*Ec ) has full row rank NR for C all finite lambda and is in a staircase form with C _ _ _ _ C ( A1,0 A1,1 ... A1,k-1 A1,k ) C ( _ _ _ ) C ( Bc Ac ) = ( 0 A2,1 ... A2,k-1 A2,k ) , (1) C ( ... _ _ ) C ( 0 0 ... Ak,k-1 Ak,k ) C C _ _ _ C ( E1,1 ... E1,k-1 E1,k ) C ( _ _ ) C Ec = ( 0 ... E2,k-1 E2,k ) , (2) C ( ... _ ) C ( 0 ... 0 Ek,k ) C _ C where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank C _ C matrix (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i) C upper triangular matrix. C C 2) the pencil Anc-lambda*Enc is regular of order N1-NR with Enc C upper triangular; this pencil contains the uncontrollable C finite eigenvalues of the pencil (A1-lambda*E1). C C The transformations are applied to the whole matrices A, E, B C and C. The left and/or right orthogonal transformations Qc and Zc C performed to reduce the pencil can be optionally accumulated C in the matrices Q and Z, respectively. C C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has no C uncontrollable finite eigenvalues and has the same C transfer-function matrix as the original system (A-lambda*E,B,C). C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C = 'N': do not compute Q; C = 'I': Q is initialized to the unit matrix, and the C orthogonal matrix Q is returned; C = 'U': Q must contain an orthogonal matrix Q1 on entry, C and the product Q1*Q is returned. C C COMPZ CHARACTER*1 C = 'N': do not compute Z; C = 'I': Z is initialized to the unit matrix, and the C orthogonal matrix Z is returned; C = 'U': Z must contain an orthogonal matrix Z1 on entry, C and the product Z1*Z is returned. C C Input/Output Parameters C C L (input) INTEGER C The number of descriptor state equations; also the number C of rows of matrices A, E and B. L >= 0. C C N (input) INTEGER C The dimension of the descriptor state vector; also the C number of columns of matrices A, E and C. N >= 0. C C M (input) INTEGER C The dimension of descriptor system input vector; also the C number of columns of matrix B. M >= 0. C C P (input) INTEGER C The dimension of descriptor system output; also the C number of rows of matrix C. P >= 0. C C N1 (input) INTEGER C The order of subsystem (A1-lambda*E1,B1,C1) to be reduced. C MIN(L,N) >= N1 >= 0. C C LBE (input) INTEGER C The number of nonzero sub-diagonals of submatrix E1. C MAX(0,N1-1) >= LBE >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the L-by-N state matrix A in the partitioned C form C ( A1 X1 ) C A = ( ) , C ( 0 X2 ) C C where A1 is N1-by-N1. C On exit, the leading L-by-N part of this array contains C the transformed state matrix, C C ( Ac * * ) C Qc'*A*Zc = ( 0 Anc * ) , C ( 0 0 * ) C C where Ac is NR-by-NR and Anc is (N1-NR)-by-(N1-NR). C The matrix ( Bc Ac ) is in the controllability C staircase form (1). C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,L). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the L-by-N descriptor matrix E in the partitioned C form C ( E1 Y1 ) C E = ( ) , C ( 0 Y2 ) C C where E1 is N1-by-N1 matrix with LBE nonzero C sub-diagonals. C On exit, the leading L-by-N part of this array contains C the transformed descriptor matrix C C ( Ec * * ) C Qc'*E*Zc = ( 0 Enc * ) , C ( 0 0 * ) C C where Ec is NR-by-NR and Enc is (N1-NR)-by-(N1-NR). C Both Ec and Enc are upper triangular and Enc is C nonsingular. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,L). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, the leading L-by-M part of this array must C contain the L-by-M input matrix B in the partitioned C form C ( B1 ) C B = ( ) , C ( 0 ) C C where B1 is N1-by-M. C On exit, the leading L-by-M part of this array contains C the transformed input matrix C C ( Bc ) C Qc'*B = ( ) , C ( 0 ) C C where Bc is NR-by-M. C The matrix ( Bc Ac ) is in the controllability C staircase form (1). C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,L). 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Zc. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) C If COMPQ = 'N': Q is not referenced. C If COMPQ = 'I': on entry, Q need not be set; C on exit, the leading L-by-L part of this C array contains the orthogonal matrix Qc, C where Qc' is the product of transformations C which are applied to A, E, and B on C the left. C If COMPQ = 'U': on entry, the leading L-by-L part of this C array must contain an orthogonal matrix Q; C on exit, the leading L-by-L part of this C array contains the orthogonal matrix C Q*Qc. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C If COMPZ = 'N': Z is not referenced. C If COMPZ = 'I': on entry, Z need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Zc, C which is the product of transformations C applied to A, E, and C on the right. C If COMPZ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix Z; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Z*Zc. C C LDZ INTEGER C The leading dimension of array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. C C NR (output) INTEGER C The order of the reduced matrices Ac and Ec, and the C number of rows of the reduced matrix Bc; also the order of C the controllable part of the pair (B, A-lambda*E). C C NRBLCK (output) INTEGER _ C The number k, of full row rank blocks Ai,i in the C staircase form of the pencil (Bc Ac-lambda*Ec) (see (1) C and (2)). C C RTAU (output) INTEGER array, dimension (N1) C RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of C _ C the full row rank block Ai,i-1 in the staircase form (1). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determinations when C transforming (A-lambda*E, B). If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C reciprocal condition numbers in rank determinations; a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = L*N*EPS, is used instead, where C EPS is the machine precision (see LAPACK Library routine C DLAMCH). TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (M) C C DWORK DOUBLE PRECISION array, dimension (MAX(N,L,2*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 subroutine is based on the reduction algorithm of [1]. C C REFERENCES C C [1] Varga, A. C Computation of Irreducible Generalized State-Space C Realizations. C Kybernetika, vol. 26, pp. 89-106, 1990. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N*N1**2 ) floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C March 1999. Based on the RASP routine RPDS05. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 1999, C May 2003, Nov. 2003. C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. C V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. C V. Sima, Apr. 2017, Mar. 2019. C C KEYWORDS C C Controllability, minimal realization, orthogonal canonical form, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. INTEGER IMAX, IMIN PARAMETER ( IMAX = 1, IMIN = 2 ) DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER COMPQ, COMPZ INTEGER INFO, L, LBE, LDA, LDB, LDC, LDE, LDQ, LDZ, M, $ N, N1, NR, NRBLCK, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK( * ), RTAU( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), $ Z( LDZ, * ) C .. Local Scalars .. LOGICAL ILQ, ILZ, WITHC INTEGER I, IC, ICOL, ICOMPQ, ICOMPZ, IROW, ISMAX, $ ISMIN, J, K, MN, NF, NR1, RANK, TAUIM1 DOUBLE PRECISION C1, C2, CO, NRMA, RCOND, S1, S2, SI, SMAX, $ SMAXPR, SMIN, SMINPR, SVLMAX, T, TOLZ, TT C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DLANGE, DNRM2 EXTERNAL DLAMCH, DLANGE, DNRM2, IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DLACPY, DLAIC1, DLARF, DLARFG, DLARTG, DLASET, $ DROT, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT C C .. Executable Statements .. C C Decode COMPQ. C IF( LSAME( COMPQ, 'N' ) ) THEN ILQ = .FALSE. ICOMPQ = 1 ELSE IF( LSAME( COMPQ, 'U' ) ) THEN ILQ = .TRUE. ICOMPQ = 2 ELSE IF( LSAME( COMPQ, 'I' ) ) THEN ILQ = .TRUE. ICOMPQ = 3 ELSE ICOMPQ = 0 END IF C C Decode COMPZ. C IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'U' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF C C Test the input scalar parameters. C INFO = 0 IF( ICOMPQ.LE.0 ) THEN INFO = -1 ELSE IF( ICOMPZ.LE.0 ) THEN INFO = -2 ELSE IF( L.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( N1.LT.0 .OR. N1.GT.MIN( L, N ) ) THEN INFO = -7 ELSE IF( LBE.LT.0 .OR. LBE.GT.MAX( 0, N1-1 ) ) THEN INFO = -8 ELSE IF( LDA.LT.MAX( 1, L ) ) THEN INFO = -10 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -12 ELSE IF( LDB.LT.MAX( 1, L ) ) THEN INFO = -14 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -16 ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN INFO = -18 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -20 ELSE IF( TOL.GE.ONE ) THEN INFO = -24 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01HX', -INFO ) RETURN END IF C C Initialize Q and Z if necessary. C IF( ICOMPQ.EQ.3 ) $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) IF( ICOMPZ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) C C Initialize output variables. C NR = 0 NRBLCK = 0 C C Quick return if possible. C IF( M.EQ.0 .OR. N1.EQ.0 ) THEN RETURN END IF C TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) WITHC = P.GT.0 SVLMAX = ZERO NRMA = DLANGE( 'F', L, N, A, LDA, DWORK ) RCOND = TOL IF ( RCOND.LE.ZERO ) THEN C C Use the default tolerance in controllability determination. C RCOND = DBLE( L*N )*DLAMCH( 'EPSILON' ) END IF C C Reduce E to upper triangular form if necessary. C IF( LBE.GT.0 ) THEN DO 10 I = 1, N1-1 C C Generate elementary reflector H(i) to annihilate C E(i+1:i+lbe,i). C K = MIN( LBE, N1-I ) + 1 CALL DLARFG( K, E(I,I), E(I+1,I), 1, TT ) T = E(I,I) E(I,I) = ONE C C Apply H(i) to E(i:n1,i+1:n) from the left. C CALL DLARF( 'Left', K, N-I, E(I,I), 1, TT, $ E(I,I+1), LDE, DWORK ) C C Apply H(i) to A(i:n1,1:n) from the left. C CALL DLARF( 'Left', K, N, E(I,I), 1, TT, $ A(I,1), LDA, DWORK ) C C Apply H(i) to B(i:n1,1:m) from the left. C CALL DLARF( 'Left', K, M, E(I,I), 1, TT, $ B(I,1), LDB, DWORK ) IF( ILQ ) THEN C C Apply H(i) to Q(1:l,i:n1) from the right. C CALL DLARF( 'Right', L, K, E(I,I), 1, TT, $ Q(1,I), LDQ, DWORK ) END IF E(I,I) = T 10 CONTINUE CALL DLASET( 'Lower', N1-1, N1-1, ZERO, ZERO, E(2,1), LDE ) END IF C ISMIN = 1 ISMAX = ISMIN + M IC = -M TAUIM1 = M NF = N1 C 20 CONTINUE NRBLCK = NRBLCK + 1 RANK = 0 IF( NF.GT.0 ) THEN C C IROW will point to the current pivot line in B, C ICOL+1 will point to the first active columns of A. C ICOL = IC + TAUIM1 IROW = NR NR1 = NR + 1 IF( NR.GT.0 ) THEN CALL DLACPY( 'Full', NF, TAUIM1, A(NR1,IC+1), LDA, $ B(NR1,1), LDB ) IF( SVLMAX.EQ.ZERO ) $ SVLMAX = NRMA END IF C C Perform QR-decomposition with column pivoting on the current B C while keeping E upper triangular. C The current B is at first iteration B and for subsequent C iterations the NF-by-TAUIM1 matrix delimited by rows C NR + 1 to N1 and columns IC + 1 to IC + TAUIM1 of A. C The rank of current B is computed in RANK. C IF( TAUIM1.GT.1 ) THEN C C Compute column norms. C DO 30 J = 1, TAUIM1 DWORK(J) = DNRM2( NF, B(NR1,J), 1 ) DWORK(M+J) = DWORK(J) IWORK(J) = J 30 CONTINUE END IF C MN = MIN( NF, TAUIM1 ) C 40 CONTINUE IF( RANK.LT.MN ) THEN J = RANK + 1 IROW = IROW + 1 C C Pivot if necessary. C IF( J.NE.TAUIM1 ) THEN K = ( J - 1 ) + IDAMAX( TAUIM1-J+1, DWORK(J), 1 ) IF( K.NE.J ) THEN CALL DSWAP( NF, B(NR1,J), 1, B(NR1,K), 1 ) I = IWORK(K) IWORK(K) = IWORK(J) IWORK(J) = I DWORK(K) = DWORK(J) DWORK(M+K) = DWORK(M+J) END IF END IF C C Zero elements below the current diagonal element of B. C DO 50 I = N1-1, IROW, -1 C C Rotate rows I and I+1 to zero B(I+1,J). C T = B(I,J) CALL DLARTG( T, B(I+1,J), CO, SI, B(I,J) ) B(I+1,J) = ZERO CALL DROT( N-I+1, E(I,I), LDE, E(I+1,I), LDE, CO, SI ) IF( J.LT.TAUIM1 ) $ CALL DROT( TAUIM1-J, B(I,J+1), LDB, $ B(I+1,J+1), LDB, CO, SI ) CALL DROT( N-ICOL, A(I,ICOL+1), LDA, $ A(I+1,ICOL+1), LDA, CO, SI ) IF( ILQ ) CALL DROT( L, Q(1,I), 1, Q(1,I+1), 1, CO, SI ) C C Rotate columns I, I+1 to zero E(I+1,I). C T = E(I+1,I+1) CALL DLARTG( T, E(I+1,I), CO, SI, E(I+1,I+1) ) E(I+1,I) = ZERO CALL DROT( I, E(1,I+1), 1, E(1,I), 1, CO, SI ) CALL DROT( N1, A(1,I+1), 1, A(1,I), 1, CO, SI ) IF( ILZ ) CALL DROT( N, Z(1,I+1), 1, Z(1,I), 1, CO, SI ) IF( WITHC ) $ CALL DROT( P, C(1,I+1), 1, C(1,I), 1, CO, SI ) 50 CONTINUE C IF( RANK.EQ.0 ) THEN C C Initialize; exit if the matrix is negligible (RANK = 0). C SMAX = ABS( B(NR1,1) ) IF ( SMAX.LE.RCOND ) GO TO 80 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, $ B(NR1,J), B(IROW,J), SMINPR, S1, C1 ) CALL DLAIC1( IMAX, RANK, DWORK(ISMAX), SMAX, $ B(NR1,J), B(IROW,J), SMAXPR, S2, C2 ) END IF C C Check the rank; finish the loop if rank loss occurs. C IF( SVLMAX*RCOND.LE.SMAXPR ) THEN IF( SVLMAX*RCOND.LE.SMINPR ) THEN IF( SMAXPR*RCOND.LT.SMINPR ) THEN C C Finish the loop if last row. C IF( IROW.EQ.N1 ) THEN RANK = RANK + 1 GO TO 80 END IF C C Update partial column norms. C DO 60 I = J + 1, TAUIM1 IF( DWORK(I).NE.ZERO ) THEN T = ABS( B(IROW,I) )/DWORK(I) T = MAX( ( ONE + T )*( ONE - T ), ZERO) TT = T*( DWORK(I)/DWORK(M+I) )**2 IF( TT.GT.TOLZ ) THEN DWORK(I) = DWORK(I)*SQRT( T ) ELSE DWORK(I) = DNRM2( NF-J, B(IROW+1,I), 1 ) DWORK(M+I) = DWORK(I) END IF END IF 60 CONTINUE C DO 70 I = 1, RANK DWORK(ISMIN+I-1) = S1*DWORK(ISMIN+I-1) DWORK(ISMAX+I-1) = S2*DWORK(ISMAX+I-1) 70 CONTINUE C DWORK(ISMIN+RANK) = C1 DWORK(ISMAX+RANK) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 GO TO 40 END IF END IF END IF IF( NR.GT.0 ) THEN CALL DLASET( 'Full', N1-IROW+1, TAUIM1-J+1, ZERO, ZERO, $ B(IROW,J), LDB ) END IF GO TO 80 END IF END IF C 80 IF( RANK.GT.0 ) THEN RTAU(NRBLCK) = RANK C C Back permute interchanged columns. C IF( TAUIM1.GT.1 ) THEN DO 100 J = 1, TAUIM1 IF( IWORK(J).GT.0 ) THEN K = IWORK(J) IWORK(J) = -K 90 CONTINUE IF( K.NE.J ) THEN CALL DSWAP( RANK, B(NR1,J), 1, B(NR1,K), 1 ) IWORK(K) = -IWORK(K) K = -IWORK(K) GO TO 90 END IF END IF 100 CONTINUE END IF END IF IF( NR.GT.0 ) $ CALL DLACPY( 'Full', NF, TAUIM1, B(NR1,1), LDB, $ A(NR1,IC+1), LDA ) IF( RANK.GT.0 ) THEN NR = NR + RANK NF = NF - RANK IC = IC + TAUIM1 TAUIM1 = RANK GO TO 20 ELSE NRBLCK = NRBLCK - 1 END IF C IF( NRBLCK.GT.0 ) RANK = RTAU(1) IF( RANK.LT.N1 ) $ CALL DLASET( 'Full', N1-RANK, M, ZERO, ZERO, B(RANK+1,1), LDB ) C RETURN C *** Last line of TG01HX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB05MD.f0000644000000000000000000000013215012430707016161 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB05MD.f0000644000175000017500000003006515012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE MB05MD( BALANC, N, DELTA, A, LDA, V, LDV, Y, LDY, VALR, $ VALI, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute exp(A*delta) where A is a real N-by-N non-defective C matrix with real or complex eigenvalues and delta is a scalar C value. The routine also returns the eigenvalues and eigenvectors C of A as well as (if all eigenvalues are real) the matrix product C exp(Lambda*delta) times the inverse of the eigenvector matrix C of A, where Lambda is the diagonal matrix of eigenvalues. C Optionally, the routine computes a balancing transformation to C improve the conditioning of the eigenvalues and eigenvectors. C C ARGUMENTS C C Mode Parameters C C BALANC CHARACTER*1 C Indicates how the input matrix should be diagonally scaled C to improve the conditioning of its eigenvalues as follows: C = 'N': Do not diagonally scale; C = 'S': Diagonally scale the matrix, i.e. replace A by C D*A*D**(-1), where D is a diagonal matrix chosen C to make the rows and columns of A more equal in C norm. Do not permute. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C DELTA (input) DOUBLE PRECISION C The scalar value delta of the problem. 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 of the problem. C On exit, the leading N-by-N part of this array contains C the solution matrix exp(A*delta). C C LDA INTEGER C The leading dimension of array A. LDA >= max(1,N). C C V (output) DOUBLE PRECISION array, dimension (LDV,N) C The leading N-by-N part of this array contains the C eigenvector matrix for A. C If the k-th eigenvalue is real the k-th column of the C eigenvector matrix holds the eigenvector corresponding C to the k-th eigenvalue. C Otherwise, the k-th and (k+1)-th eigenvalues form a C complex conjugate pair and the k-th and (k+1)-th columns C of the eigenvector matrix hold the real and imaginary C parts of the eigenvectors corresponding to these C eigenvalues as follows. C If p and q denote the k-th and (k+1)-th columns of the C eigenvector matrix, respectively, then the eigenvector C corresponding to the complex eigenvalue with positive C (negative) imaginary value is given by C 2 C p + q*j (p - q*j), where j = -1. C C LDV INTEGER C The leading dimension of array V. LDV >= max(1,N). C C Y (output) DOUBLE PRECISION array, dimension (LDY,N) C The leading N-by-N part of this array contains an C intermediate result for computing the matrix exponential. C Specifically, exp(A*delta) is obtained as the product V*Y, C where V is the matrix stored in the leading N-by-N part of C the array V. If all eigenvalues of A are real, then the C leading N-by-N part of this array contains the matrix C product exp(Lambda*delta) times the inverse of the (right) C eigenvector matrix of A, where Lambda is the diagonal C matrix of eigenvalues. C C LDY INTEGER C The leading dimension of array Y. LDY >= max(1,N). C C VALR (output) DOUBLE PRECISION array, dimension (N) C VALI (output) DOUBLE PRECISION array, dimension (N) C These arrays contain the real and imaginary parts, C respectively, of the eigenvalues of the matrix A. The C eigenvalues are unordered except that complex conjugate C pairs of values appear consecutively with the eigenvalue C having positive imaginary part first. 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) returns the optimal value C of LDWORK, and if N > 0, DWORK(2) returns the reciprocal C condition number of the triangular matrix used to obtain C the inverse of the eigenvector matrix. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= max(1,4*N). C For good performance, LDWORK 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 = i: if INFO = i, the QR algorithm failed to compute all C the eigenvalues; no eigenvectors have been computed; C elements i+1:N of VALR and VALI contain eigenvalues C which have converged; C = N+1: if the inverse of the eigenvector matrix could not C be formed due to an attempt to divide by zero, i.e., C the eigenvector matrix is singular; C = N+2: if the matrix A is defective, possibly due to C rounding errors. C C METHOD C C This routine is an implementation of "Method 15" of the set of C methods described in reference [1], which uses an eigenvalue/ C eigenvector decomposition technique. A modification of LAPACK C Library routine DGEEV is used for obtaining the right eigenvector C matrix. A condition estimate is then employed to determine if the C matrix A is near defective and hence the exponential solution is C inaccurate. In this case the routine returns with the Error C Indicator (INFO) set to N+2, and SLICOT Library routines MB05ND or C MB05OD are the preferred alternative routines to be used. C C REFERENCES C C [1] Moler, C.B. and Van Loan, C.F. C Nineteen dubious ways to compute the exponential of a matrix. C SIAM Review, 20, pp. 801-836, 1978. C C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. C Supersedes Release 2.0 routine MB05AD by M.J. Denham, Kingston C Polytechnic, March 1981. C C REVISIONS C C V. Sima, June 13, 1997, April 25, 2003, Feb. 15, 2004. C C KEYWORDS C C Eigenvalue, eigenvector decomposition, matrix exponential. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER BALANC INTEGER INFO, LDA, LDV, LDWORK, LDY, N DOUBLE PRECISION DELTA C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), DWORK(*), V(LDV,*), VALI(*), VALR(*), $ Y(LDY,*) C .. Local Scalars .. LOGICAL SCALE INTEGER I DOUBLE PRECISION RCOND, TEMPI, TEMPR, WRKOPT C .. Local Arrays .. DOUBLE PRECISION TMP(2,2) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DGEBAK, DGEMM, DLACPY, DSCAL, DSWAP, DTRCON, $ DTRMM, DTRSM, MB05MY, XERBLA C .. Intrinsic Functions .. INTRINSIC COS, EXP, MAX, SIN C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 SCALE = LSAME( BALANC, 'S' ) IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDY.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDWORK.LT.MAX( 1, 4*N ) ) THEN INFO = -14 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB05MD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 C Compute the eigenvalues and right eigenvectors of the real C nonsymmetric matrix A; optionally, compute a balancing C transformation. C Workspace: need: 4*N. C CALL MB05MY( BALANC, N, A, LDA, VALR, VALI, V, LDV, Y, LDY, $ DWORK, LDWORK, INFO ) C IF ( INFO.GT.0 ) $ RETURN WRKOPT = DWORK(1) IF ( SCALE ) THEN DO 10 I = 1, N DWORK(I) = DWORK(I+1) 10 CONTINUE END IF C C Exit with INFO = N + 1 if V is exactly singular. C DO 20 I = 1, N IF ( V(I,I).EQ.ZERO ) THEN INFO = N + 1 RETURN END IF 20 CONTINUE C C Compute the reciprocal condition number of the triangular matrix. C CALL DTRCON( '1-norm', 'Upper', 'Non unit', N, V, LDV, RCOND, $ DWORK(N+1), IWORK, INFO ) C C Return if the matrix is singular to working precision. C IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN DWORK(2) = RCOND INFO = N + 2 RETURN END IF C C Compute the right eigenvector matrix (temporarily) in A. C CALL DLACPY( 'Full', N, N, Y, LDY, A, LDA ) CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non unit', N, N, $ ONE, V, LDV, A, LDA ) IF ( SCALE ) $ CALL DGEBAK( BALANC, 'Right', N, 1, N, DWORK, N, A, LDA, INFO ) C C Compute the inverse of the right eigenvector matrix, by solving C a set of linear systems, V * X = Y' (if BALANC = 'N'). C DO 40 I = 2, N CALL DSWAP( I-1, Y(I,1), LDY, Y(1,I), 1 ) 40 CONTINUE C CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non unit', N, N, $ ONE, V, LDV, Y, LDY ) IF( SCALE ) THEN C DO 60 I = 1, N TEMPR = ONE / DWORK(I) CALL DSCAL( N, TEMPR, Y(1,I), 1 ) 60 CONTINUE C END IF C C Save the right eigenvector matrix in V. C CALL DLACPY( 'Full', N, N, A, LDA, V, LDV ) C C Premultiply the inverse eigenvector matrix by the exponential of C quasi-diagonal matrix Lambda * DELTA, where Lambda is the matrix C of eigenvalues. C Note that only real arithmetic is used, taking the special storing C of eigenvalues/eigenvectors into account. C I = 0 C REPEAT 80 CONTINUE I = I + 1 IF ( VALI(I).EQ.ZERO ) THEN TEMPR = EXP( VALR(I)*DELTA ) CALL DSCAL( N, TEMPR, Y(I,1), LDY ) ELSE TEMPR = VALR(I)*DELTA TEMPI = VALI(I)*DELTA TMP(1,1) = COS( TEMPI )*EXP( TEMPR ) TMP(1,2) = SIN( TEMPI )*EXP( TEMPR ) TMP(2,1) = -TMP(1,2) TMP(2,2) = TMP(1,1) CALL DLACPY( 'Full', 2, N, Y(I,1), LDY, DWORK, 2 ) CALL DGEMM( 'No transpose', 'No transpose', 2, N, 2, ONE, $ TMP, 2, DWORK, 2, ZERO, Y(I,1), LDY ) I = I + 1 END IF IF ( I.LT.N ) GO TO 80 C UNTIL I = N. C C Compute the matrix exponential as the product V * Y. C CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, V, LDV, $ Y, LDY, ZERO, A, LDA ) C C Set optimal workspace dimension and reciprocal condition number. C DWORK(1) = WRKOPT DWORK(2) = RCOND C RETURN C *** Last line of MB05MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02NZ.f0000644000000000000000000000013215012430707016204 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02NZ.f0000644000175000017500000001337215012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE MA02NZ( UPLO, TRANS, SKEW, N, K, L, A, LDA ) C C PURPOSE C C To permute two specified rows and corresponding columns of a C (skew-)symmetric/Hermitian complex matrix. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies whether the upper or lower triangular part of C the (skew-)symmetric/Hermitian matrix A is to be C referenced, as follows: C = 'U': Upper triangular part of A is referenced; C = 'L': Lower triangular part of A is referenced. C C TRANS CHARACTER*1 C Specifies whether to use transposition or conjugate C transposition as follows: C = 'T': Use transposition; C = 'C': Use conjugate transposition. C C SKEW CHARACTER*1 C Specifies whether the matrix is symmetric/Hermitian or C skew-symmetric/Hermitian as follows: C = 'N': The matrix is symmetric/Hermitian; C = 'S': The matrix is skew-symmetric/skew-Hermitian. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C K (input) INTEGER C The smaller index of the pair of rows and columns to be C permuted. 0 <= K <= L. If K = 0, the routine returns. C C L (input) INTEGER C The larger index of the pair of rows and columns to be C permuted. K <= L <= N. C C A (input/output) COMPLEX*16 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 (skew-)symmetric/Hermitian matrix A. C On exit, the leading N-by-N upper or lower triangular part C of this array (depending on UPLO) contains the C corresponding part of the permuted matrix A. C Note that a Hermitian matrix has the imaginary parts of C the diagonal entries zero. Similarly, a skew-Hermitian C matrix has the real parts of the diagonal entries zero. C The routine does not check out this conditions. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(N,1). C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2016. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, skew-symmetric matrix. C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER SKEW, TRANS, UPLO INTEGER K, L, LDA, N C .. Array Arguments .. COMPLEX*16 A(LDA,*) C .. Local Scalars .. INTEGER I COMPLEX*16 T C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL ZSWAP C ..Intrinsic Functions.. INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG C C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked for errors. C IF( N.EQ.0 .OR. K.EQ.0 .OR. K.EQ.L ) $ RETURN C T = A(K,K) A(K,K) = A(L,L) A(L,L) = T C IF( LSAME( UPLO, 'L' ) ) THEN C C Permute the lower triangle of A. C CALL ZSWAP( K-1, A(K,1), LDA, A(L,1), LDA ) C IF( LSAME( TRANS, 'T' ) ) THEN C IF( LSAME( SKEW, 'N' ) ) THEN C CALL ZSWAP( L-K-1, A(K+1,K), 1, A(L,K+1), LDA ) ELSE C A(L,K) = -A(L,K) DO 10 I = K+1, L-1 T = -A(L,I) A(L,I) = -A(I,K) A(I,K) = T 10 CONTINUE C END IF C ELSE C IF( LSAME( SKEW, 'N' ) ) THEN C A(L,K) = DCONJG( A(L,K) ) DO 20 I = K+1, L-1 T = DCONJG( A(L,I) ) A(L,I) = DCONJG( A(I,K) ) A(I,K) = T 20 CONTINUE C ELSE C A(L,K) = DCMPLX( -DBLE( A(L,K) ), DIMAG( A(L,K) ) ) DO 30 I = K+1, L-1 T = DCMPLX( -DBLE( A(L,I) ), DIMAG( A(L,I) ) ) A(L,I) = DCMPLX( -DBLE( A(I,K) ), DIMAG( A(I,K) ) ) A(I,K) = T 30 CONTINUE C END IF C END IF C CALL ZSWAP( N-L, A(L+1,K), 1, A(L+1,L), 1 ) C ELSE IF( LSAME( UPLO, 'U' ) ) THEN C C Permute the upper triangle of A. C CALL ZSWAP( K-1, A(1,K), 1, A(1,L), 1 ) C IF( LSAME( TRANS, 'T' ) ) THEN C IF( LSAME( SKEW, 'N' ) ) THEN C CALL ZSWAP( L-K-1, A(K,K+1), LDA, A(K+1,L), 1 ) ELSE C A(K,L) = -A(K,L) DO 40 I = K+1, L-1 T = -A(I,L) A(I,L) = -A(K,I) A(K,I) = T 40 CONTINUE C END IF C ELSE C IF( LSAME( SKEW, 'N' ) ) THEN C A(K,L) = DCONJG( A(K,L) ) DO 50 I = K+1, L-1 T = DCONJG( A(I,L) ) A(I,L) = DCONJG( A(K,I) ) A(K,I) = T 50 CONTINUE C ELSE C A(K,L) = DCMPLX( -DBLE( A(K,L) ), DIMAG( A(K,L) ) ) DO 60 I = K+1, L-1 T = DCMPLX( -DBLE( A(I,L) ), DIMAG( A(I,L) ) ) A(I,L) = DCMPLX( -DBLE( A(K,I) ), DIMAG( A(K,I) ) ) A(K,I) = T 60 CONTINUE C END IF C END IF C CALL ZSWAP( N-L, A(K,L+1), LDA, A(L,L+1), LDA ) C END IF C RETURN C C *** Last line of MA02NZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04DI.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04DI.f0000644000175000017500000001343415012430707017355 0ustar00lilgelilge00000000000000 SUBROUTINE MB04DI( JOB, SGN, N, ILO, SCALE, M, V1, LDV1, V2, LDV2, $ INFO ) C C PURPOSE C C To apply the inverse of a balancing transformation, computed by C the SLICOT Library routines MB04DD or MB04DS, to a 2*N-by-M matrix C C [ V1 ] C [ ], C [ sgn*V2 ] C C where sgn is either +1 or -1. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the type of inverse transformation required: C = 'N': do nothing, return immediately; C = 'P': do inverse transformation for permutation only; C = 'S': do inverse transformation for scaling only; C = 'B': do inverse transformations for both permutation C and scaling. C JOB must be the same as the argument JOB supplied to C MB04DD or MB04DS. C C SGN CHARACTER*1 C Specifies the sign to use for V2: C = 'P': sgn = +1; C = 'N': sgn = -1. C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrices V1 and V2. N >= 0. C C ILO (input) INTEGER C The integer ILO determined by MB04DD or MB04DS. C 1 <= ILO <= N+1. C C SCALE (input) DOUBLE PRECISION array, dimension (N) C Details of the permutation and scaling factors, as C returned by MB04DD or MB04DS. C C M (input) INTEGER C The number of columns of the matrices V1 and V2. M >= 0. C C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,M) C On entry, the leading N-by-M part of this array must C contain the matrix V1. C On exit, the leading N-by-M part of this array is C overwritten by the updated matrix V1 of the transformed C matrix. C C LDV1 INTEGER C The leading dimension of the array V1. LDV1 >= max(1,N). C C V2 (input/output) DOUBLE PRECISION array, dimension (LDV2,M) C On entry, the leading N-by-M part of this array must C contain the matrix V2. C On exit, the leading N-by-M part of this array is C overwritten by the updated matrix V2 of the transformed C matrix. C C LDV2 INTEGER C The leading dimension of the array V2. LDV2 >= max(1,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 REFERENCES C C [1] Benner, P. C Symplectic balancing of Hamiltonian matrices. C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2001. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHABAK). C V. Sima, April 2015. C C KEYWORDS C C Balancing, Hamiltonian matrix, skew-Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOB, SGN INTEGER ILO, INFO, LDV1, LDV2, M, N C .. Array Arguments .. DOUBLE PRECISION SCALE(*), V1(LDV1,*), V2(LDV2,*) C .. Local Scalars .. LOGICAL LPERM, LSCAL, LSGN, SYSW INTEGER I, K C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) LSGN = LSAME( SGN, 'N' ) IF ( .NOT.LPERM .AND. .NOT.LSCAL $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN INFO = -1 ELSE IF ( .NOT.LSGN .AND. .NOT.LSAME( SGN, 'P' ) ) THEN INFO = -2 ELSE IF ( N.LT.0 ) THEN INFO = -3 ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN INFO = -4 ELSE IF ( M.LT.0 ) THEN INFO = -6 ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN INFO = -10 END IF C C Return if there were illegal values. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04DI', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 .OR. LSAME( JOB, 'N' ) ) $ RETURN C C Inverse scaling. C IF ( LSCAL ) THEN DO 20 I = ILO, N CALL DSCAL( M, SCALE(I), V1(I,1), LDV1 ) 20 CONTINUE DO 30 I = ILO, N CALL DRSCL( M, SCALE(I), V2(I,1), LDV2 ) 30 CONTINUE END IF C C Inverse permutation. C IF ( LPERM ) THEN DO 40 I = ILO-1, 1, -1 K = SCALE( I ) SYSW = ( K.GT.N ) IF ( SYSW ) $ K = K - N C IF ( K.NE.I ) THEN C C Exchange rows k <-> i. C CALL DSWAP( M, V1(I,1), LDV1, V1(K,1), LDV1 ) CALL DSWAP( M, V2(I,1), LDV2, V2(K,1), LDV2 ) END IF C IF ( SYSW ) THEN C C Exchange V1(k,:) <-> V2(k,:). C CALL DSWAP( M, V1(K,1), LDV1, V2(K,1), LDV2 ) IF ( LSGN ) THEN CALL DSCAL( M, -ONE, V1(K,1), LDV1 ) ELSE CALL DSCAL( M, -ONE, V2(K,1), LDV2 ) END IF END IF 40 CONTINUE END IF C RETURN C *** Last line of MB04DI *** END control-4.1.2/src/slicot/src/PaxHeaders/TD05AD.f0000644000000000000000000000013215012430707016156 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TD05AD.f0000644000175000017500000002072115012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI, $ INFO ) C C PURPOSE C C Given a complex valued rational function of frequency (transfer C function) G(jW) this routine will calculate its complex value or C its magnitude and phase for a specified frequency value. C C ARGUMENTS C C Mode Parameters C C UNITF CHARACTER*1 C Indicates the choice of frequency unit as follows: C = 'R': Input frequency W in radians/second; C = 'H': Input frequency W in hertz. C C OUTPUT CHARACTER*1 C Indicates the choice of co-ordinates for output as folows: C = 'C': Cartesian co-ordinates (output real and imaginary C parts of G(jW)); C = 'P': Polar co-ordinates (output magnitude and phase C of G(jW)). C C Input/Output Parameters C C NP1 (input) INTEGER C The order of the denominator + 1, i.e. N + 1. NP1 >= 1. C C MP1 (input) INTEGER C The order of the numerator + 1, i.e. M + 1. MP1 >= 1. C C W (input) DOUBLE PRECISION C The frequency value W for which the transfer function is C to be evaluated. C C A (input) DOUBLE PRECISION array, dimension (NP1) C This array must contain the vector of denominator C coefficients in ascending order of powers. That is, A(i) C must contain the coefficient of (jW)**(i-1) for i = 1, C 2,...,NP1. C C B (input) DOUBLE PRECISION array, dimension (MP1) C This array must contain the vector of numerator C coefficients in ascending order of powers. That is, B(i) C must contain the coefficient of (jW)**(i-1) for i = 1, C 2,...,MP1. C C VALR (output) DOUBLE PRECISION C If OUTPUT = 'C', VALR contains the real part of G(jW). C If OUTPUT = 'P', VALR contains the magnitude of G(jW) C in dBs. C C VALI (output) DOUBLE PRECISION C If OUTPUT = 'C', VALI contains the imaginary part of C G(jW). C If OUTPUT = 'P', VALI contains the phase of G(jW) in C degrees. 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 frequency value W is a pole of G(jW), or all C the coefficients of the A polynomial are zero. C C METHOD C C By substituting the values of A, B and W in the following C formula: C C B(1)+B(2)*(jW)+B(3)*(jW)**2+...+B(MP1)*(jW)**(MP1-1) C G(jW) = ---------------------------------------------------. C A(1)+A(2)*(jW)+A(3)*(jW)**2+...+A(NP1)*(jW)**(NP1-1) C C REFERENCES C C None. C C NUMERICAL ASPECTS C C The algorithm requires 0(N+M) operations. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TD01AD by Control Systems Research C Group, Kingston Polytechnic, United Kingdom, March 1981. C C REVISIONS C C February 1997. C February 22, 1998 (changed the name of TD01MD). C C KEYWORDS C C Elementary polynomial operations, frequency response, matrix C fraction, polynomial matrix, state-space representation, transfer C matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, EIGHT, TWENTY, NINETY, ONE80, THRE60 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, EIGHT=8.0D0, $ TWENTY=20.0D0, NINETY=90.0D0, ONE80 = 180.0D0, $ THRE60=360.0D0 ) C .. Scalar Arguments .. CHARACTER OUTPUT, UNITF INTEGER INFO, MP1, NP1 DOUBLE PRECISION VALI, VALR, W C .. Array Arguments .. DOUBLE PRECISION A(*), B(*) C .. Local Scalars .. LOGICAL LOUTPU, LUNITF INTEGER I, IPHASE, M, M2, N, N2, NPZERO, NZZERO DOUBLE PRECISION BIMAG, BREAL, G, TIMAG, TREAL, TWOPI, W2, WC COMPLEX*16 ZTEMP C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAPY2 COMPLEX*16 ZLADIV EXTERNAL DLAPY2, LSAME, ZLADIV C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, ATAN, DBLE, DCMPLX, DIMAG, LOG10, MAX, MOD, $ SIGN C .. Executable Statements .. C INFO = 0 LUNITF = LSAME( UNITF, 'H' ) LOUTPU = LSAME( OUTPUT, 'P' ) C C Test the input scalar arguments. C IF( .NOT.LUNITF .AND. .NOT.LSAME( UNITF, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.LOUTPU .AND. .NOT.LSAME( OUTPUT, 'C' ) ) THEN INFO = -2 ELSE IF( NP1.LT.1 ) THEN INFO = -3 ELSE IF( MP1.LT.1 ) THEN INFO = -4 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TD05AD', -INFO ) RETURN END IF C M = MP1 - 1 N = NP1 - 1 WC = W TWOPI = EIGHT*ATAN( ONE ) IF ( LUNITF ) WC = WC*TWOPI W2 = WC**2 C C Determine the orders z (NZZERO) and p (NPZERO) of the factors C (jW)**k in the numerator and denominator polynomials, by counting C the zero trailing coefficients. The value of G(jW) will then be C computed as (jW)**(z-p)*m(jW)/n(jW), for appropriate m and n. C I = 0 C 10 CONTINUE I = I + 1 IF ( I.LE.M ) THEN IF ( B(I).EQ.ZERO ) GO TO 10 END IF C NZZERO = I - 1 I = 0 C 20 CONTINUE I = I + 1 IF ( I.LE.N ) THEN IF ( A(I).EQ.ZERO ) GO TO 20 END IF C NPZERO = I - 1 IPHASE = NZZERO - NPZERO C M2 = MOD( M - NZZERO, 2 ) C C Add real parts of the numerator m(jW). C TREAL = B(MP1-M2) C DO 30 I = M - 1 - M2, NZZERO + 1, -2 TREAL = B(I) - W2*TREAL 30 CONTINUE C C Add imaginary parts of the numerator m(jW). C IF ( M.EQ.0 ) THEN TIMAG = ZERO ELSE TIMAG = B(M+M2) C DO 40 I = M + M2 - 2, NZZERO + 2, -2 TIMAG = B(I) - W2*TIMAG 40 CONTINUE C TIMAG = TIMAG*WC END IF C N2 = MOD( N - NPZERO, 2 ) C C Add real parts of the denominator n(jW). C BREAL = A(NP1-N2) C DO 50 I = N - 1 - N2, NPZERO + 1, -2 BREAL = A(I) - W2*BREAL 50 CONTINUE C C Add imaginary parts of the denominator n(jW). C IF ( N.EQ.0 ) THEN BIMAG = ZERO ELSE BIMAG = A(N+N2) C DO 60 I = N + N2 - 2, NPZERO + 2, -2 BIMAG = A(I) - W2*BIMAG 60 CONTINUE C BIMAG = BIMAG*WC END IF C IF ( ( MAX( ABS( BREAL ), ABS( BIMAG ) ).EQ.ZERO ) .OR. $ ( W.EQ.ZERO .AND. IPHASE.LT.0 ) ) THEN C C Error return: The specified frequency W is a pole of G(jW), C or all the coefficients of the A polynomial are zero. C INFO = 1 ELSE C C Evaluate the complex number W**(z-p)*m(jW)/n(jW). C ZTEMP = $ ZLADIV( DCMPLX( TREAL, TIMAG ), DCMPLX( BREAL, BIMAG ) ) VALR = DBLE( ZTEMP )*WC**IPHASE VALI = DIMAG( ZTEMP )*WC**IPHASE C IF ( .NOT.LOUTPU ) THEN C C Cartesian co-ordinates: Update the result for j**(z-p). C I = MOD( ABS( IPHASE ), 4 ) IF ( ( IPHASE.GT.0 .AND. I.GT.1 ) .OR. $ ( IPHASE.LT.0 .AND. ( I.EQ.1 .OR. I.EQ.2) ) ) THEN VALR = -VALR VALI = -VALI END IF C IF ( MOD( I, 2 ).NE.0 ) THEN G = VALR VALR = -VALI VALI = G END IF C ELSE C C Polar co-ordinates: Compute the magnitude and phase. C G = DLAPY2( VALR, VALI ) C IF ( VALR.EQ.ZERO ) THEN VALI = SIGN( NINETY, VALI ) ELSE VALI = ( ATAN( VALI/VALR )/TWOPI )*THRE60 IF ( VALI.EQ.ZERO .AND. NZZERO.EQ.M .AND. NPZERO.EQ.N $ .AND. B(NZZERO+1)*A(NPZERO+1).LT.ZERO ) $ VALI = ONE80 END IF C VALR = TWENTY*LOG10( G ) C IF ( IPHASE.NE.0 ) $ VALI = VALI + DBLE( NZZERO - NPZERO )*NINETY END IF C END IF C RETURN C *** Last line of TD05AD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB13ID.f0000644000000000000000000000013215012430707016140 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB13ID.f0000644000175000017500000010146115012430707017337 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION AB13ID( JOBSYS, JOBEIG, EQUIL, CKSING, RESTOR, $ UPDATE, N, M, P, A, LDA, E, LDE, B, LDB, $ C, LDC, NR, RANKE, TOL, IWORK, DWORK, $ LDWORK, IWARN, INFO ) C C PURPOSE C C To check whether the transfer function C C -1 C G(lambda) := C*( lambda*E - A ) *B C C of a given linear time-invariant descriptor system with C generalized state space realization (lambda*E-A,B,C) is proper. C Optionally, if JOBEIG = 'A', the system (lambda*E-A,B,C) is C reduced to an equivalent one (lambda*Er-Ar,Br,Cr) with only C controllable and observable eigenvalues in order to use it for a C subsequent L_inf-norm computation; if JOBEIG = 'I', the system is C reduced to an equivalent one (lambda*Er-Ar,Br,Cr) without C uncontrollable and unobservable infinite eigenvalues. In this C case, intended mainly for checking the properness, the returned C system is not fully reduced, unless UPDATE = 'U'. C C FUNCTION VALUE C C AB13ID LOGICAL C Indicates whether the transfer function is proper. C If AB13ID = .TRUE., the transfer function is proper; C otherwise, it is improper. C C ARGUMENTS C C Mode Parameters C C JOBSYS CHARACTER*1 C Indicates whether the system (lambda*E-A,B,C) is already C in the reduced form which is obtained as stated in C JOBEIG, as follows. C = 'R': The system is not in a reduced form, the reduction C step is performed; C = 'N': The system is in a reduced form; the reduction step C is omitted. C C JOBEIG CHARACTER*1 C Indicates which kind of eigenvalues of the matrix pencil C lambda*E-A should be removed if JOBSYS = 'R', as follows: C = 'A': All uncontrollable and unobservable eigenvalues C are removed; the reduced system is returned in C the arrays A, E, B, C; C = 'I': Only all uncontrollable and unobservable infinite C eigenvalues are removed; the returned system is not C fully reduced if UPDATE = 'N'. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily scale C the system (lambda*E-A,B,C) as follows: C = 'S': Perform scaling; C = 'N': Do not perform scaling. C C CKSING CHARACTER*1 C Specifies whether the user wishes to check if the pencil C (lambda*E-A) is singular as follows: C = 'C': Check singularity; C = 'N': Do not check singularity. C If the pencil is singular, the reduced system computed for C CKSING = 'N' may have completely different eigenvalues C than the given system. C The test is performed only if JOBSYS = 'R'. C C RESTOR CHARACTER*1 C Specifies whether the user wishes to save the system C matrices before each reduction phase (if JOBSYS = 'R') and C restore them if no order reduction took place as follows: C = 'R': Save and restore; C = 'N': Do not save the matrices. C This option is ineffective if JOBSYS = 'N'. C C UPDATE CHARACTER*1 C Specifies whether the user wishes to update the matrices C A, B, and C if JOBEIG = 'I' as follows: C = 'U': Update the matrices A, B and C; C = 'N': Do not update the matrices A, B and C when C performing URV decomposition of the matrix E C (see METHOD). C C Input/Output Parameters C C N (input) INTEGER C The dimension of the descriptor state vector; also the C order of square matrices A and E, the number of rows of C matrix B, and the number of columns of matrix C. N >= 0. C C M (input) INTEGER C The dimension of the descriptor system input vector; also C the number of columns of matrix B. M >= 0. C C P (input) INTEGER C The dimension of the descriptor system output vector; also C the number of rows of matrix C. 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 matrix A. C On exit, if JOBSYS = 'R' and JOBEIG = 'A', the leading C NR-by-NR part of this array contains the reduced order C state matrix Ar of a fully controllable and observable C realization for the original system. If JOBSYS = 'R' and C JOBEIG = 'I', the leading NR-by-NR part of this array C contains the reduced order state matrix Ar of a C transformed system without uncontrollable and unobservable C infinite poles. In this case, the matrix Ar does not C correspond to the returned matrix Er (obtained after a C URV decomposition), unless UPDATE = 'U' or RANKE < NR. C On exit, if JOBSYS = 'N' and (JOBEIG = 'A' or UPDATE = 'U' C or RANKE < N), the leading N-by-N part of this array C contains the transformed matrix A corresponding to the C URV decomposition of E (see (2) in METHOD), and if C JOBEIG = 'I' and UPDATE = 'N', the submatrix A22 in (2) is C further transformed to estimate its rank. 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, the leading N-by-N part of this array must C contain the descriptor matrix E. C On exit, if JOBSYS = 'R' and JOBEIG = 'A', the leading C NR-by-NR part of this array contains the reduced order C descriptor matrix Er of a completely controllable and C observable realization for the original system. The C reduced matrix Er is in upper triangular form. C If JOBSYS = 'R' and JOBEIG = 'I', the leading NR-by-NR C part of this array contains the reduced order descriptor C matrix Er of a transformed system without uncontrollable C and unobservable infinite poles. The reduced matrix Er is C upper triangular. In both cases, or if JOBSYS = 'N', the C matrix Er results from a URV decomposition of the matrix E C (see METHOD). C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,MAX(M,P)) C On entry, the leading N-by-M part of this array must C contain the input matrix B; the remainder of the leading C N-by-MAX(M,P) part is used as internal workspace. C On exit, if JOBSYS = 'R' and JOBEIG = 'A', the leading C NR-by-M part of this array contains the reduced input C matrix Br of a completely controllable and observable C realization for the original system. If JOBSYS = 'R' and C JOBEIG = 'I', the leading NR-by-M part of this array C contains the transformed input matrix Br obtained after C removing the uncontrollable and unobservable infinite C poles; the transformations for the URV decomposition of C the matrix E are not applied if UPDATE = 'N'. C On exit, if JOBSYS = 'N' and (JOBEIG = 'A' or C UPDATE = 'U'), the leading N-by-M part of this array C contains the transformed matrix B corresponding to the C URV decomposition of E, but if JOBEIG = 'I', EQUIL = 'N' C and UPDATE = 'N', the array B is unchanged on exit. C C LDB INTEGER C The leading dimension of the 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 output matrix C; the remainder of the leading C MAX(M,P)-by-N part is used as internal workspace. C On exit, if JOBSYS = 'R' and JOBEIG = 'A', the leading C P-by-NR part of this array contains the transformed output C matrix Cr of a completely controllable and observable C realization for the original system. If JOBSYS = 'R' and C JOBEIG = 'I', the leading P-by-NR part of this array C contains the transformed output matrix Cr obtained after C removing the uncontrollable and unobservable infinite C poles; the transformations for the URV decomposition of C the matrix E are not applied if UPDATE = 'N'. C On exit, if JOBSYS = 'N' and (JOBEIG = 'A' or C UPDATE = 'U'), the leading P-by-N part of this array C contains the transformed matrix C corresponding to the C URV decomposition of E, but if JOBEIG = 'I', EQUIL = 'N' C and UPDATE = 'N', the array C is unchanged on exit. C C LDC INTEGER C The leading dimension of the array C. C LDC >= MAX(1,M,P) if N > 0; C LDC >= 1 if N = 0. C C NR (output) INTEGER C The order of the reduced generalized state space C representation (lambda*Er-Ar,Br,Cr) as stated in JOBEIG. C If JOBEIG = 'A', NR denotes the order of a reduced system C without any uncontrollable or unobservable eigenvalues; if C JOBEIG = 'I', NR denotes the order of the reduced system C without any uncontrollable or unobservable infinite C eigenvalues. If JOBSYS = 'N', then NR = N. C C RANKE (output) INTEGER C The effective (estimated) rank of the reduced matrix Er. C C Tolerances C C TOL DOUBLE PRECISION array, dimension 3 C TOL(1) is the tolerance to be used in rank determinations C when transforming (lambda*E-A,B,C). If the user sets C TOL(1) > 0, then the given value of TOL(1) is used as a C lower bound for reciprocal condition numbers in rank C determinations; a (sub)matrix whose estimated condition C number is less than 1/TOL(1) is considered to be of full C rank. If the user sets TOL(1) <= 0, then an implicitly C computed, default tolerance, defined by TOLDEF1 = N*N*EPS, C is used instead, where EPS is the machine precision (see C LAPACK Library routine DLAMCH). TOL(1) < 1. C TOL(2) is the tolerance to be used for checking pencil C singularity when CKSING = 'C', or singularity of the C matrices A and E when CKSING = 'N'. If the user sets C TOL(2) > 0, then the given value of TOL(2) is used. C If the user sets TOL(2) <= 0, then an implicitly C computed, default tolerance, defined by TOLDEF2 = 10*EPS, C is used instead. TOL(2) < 1. C TOL(3) is the threshold value for magnitude of the matrix C elements, if EQUIL = 'S': elements with magnitude less C than or equal to TOL(3) are ignored for scaling. If the C user sets TOL(3) >= 0, then the given value of TOL(3) is C used. If the user sets TOL(3) < 0, then an implicitly C computed, default threshold, defined by THRESH = c*EPS, C where c = MAX(norm_1(A,E,B,C)) is used instead. C TOL(3) = 0 is not always a good choice. TOL(3) < 1. C TOL(3) is not used if EQUIL = 'N'. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C If JOBSYS = 'R', LIWORK >= 2*N+MAX(M,P)+7; C If JOBSYS = 'N', LIWORK >= N. C If JOBSYS = 'R', the first 7 elements of IWORK contain C information on performed reduction and on structure of C resulting system matrices after removing the specified C eigenvalues (see the description of the parameter INFRED C of the SLICOT Library routine TG01JY). 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 If JOBSYS = 'R', and EQUIL = 'S', C LDWORK >= MAX(w+4*N+4,8*N,x,y), C where w = N*N, if JOBEIG = 'A', C w = 0, if JOBEIG = 'I', C x = MAX(2*(z+MAX(M,P)+N-1),N*N+4*N), if RESTOR = 'R' C x = MAX( 2*(MAX(M,P)+N-1),N*N+4*N), if RESTOR = 'N' C y = 2*N*N+10*N+MAX(N,23), if CKSING = 'C', C y = 0, if CKSING = 'N', C z = 2*N*N+N*M+N*P; C if JOBSYS = 'R', and EQUIL = 'N', C LDWORK >= MAX(w+4*N+4,x,y); C if JOBSYS = 'N', and JOBEIG = 'A' or UPDATE = 'U', C and EQUIL = 'S', C LDWORK >= MAX(N*N+4*N+4,8*N,N+M,N+P); C if JOBSYS = 'N', and JOBEIG = 'A' or UPDATE = 'U', C and EQUIL = 'N', C LDWORK >= MAX(N*N+4*N+4,N+M,N+P); C if JOBSYS = 'N', and JOBEIG = 'I' and UPDATE = 'N', C and EQUIL = 'S', C LDWORK >= MAX(4*N+4,8*N); C if JOBSYS = 'N', and JOBEIG = 'I' and UPDATE = 'N', C and EQUIL = 'N', C LDWORK >= 4*N+4. C If JOBSYS = 'R' and ( RESTOR = 'R' or C LDWORK >= MAX(1,2*N*N+N*M+N*P+2*(MAX(M,P)+N-1) ), C then more accurate results are to be expected by C considering only those reduction phases in the SLICOT C Library routine TG01JY, where effective order reduction C occurs. This is achieved by saving the system matrices C before each phase (after orthogonally triangularizing the C matrix A or the matrix E, if RESTOR = 'N') and restoring C them if no order reduction took place. However, higher C global accuracy is not guaranteed. C For good performance, LDWORK should be generally 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. The optimal workspace includes the C extra space for improving the accuracy. C C Error/Warning Indicator C C IWARN INTEGER C = 0: When determining the rank of a matrix, the distance C between the tolerance TOL(1) and the estimated C singular values is sufficiently large. The rank can C be safely determined; C = 1: When determining the rank of a matrix, there exist C estimated singular values which are very close to the C tolerance TOL(1). The computed rank is possibly C incorrect. C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: the given pencil A - lambda*E is numerically C singular and the reduced system is not computed. C However, the system is considered improper, and C AB13ID is set to .FALSE. C This error can be returned only if CKSING = 'C'. C C METHOD C C If JOBSYS = 'R', the routine first removes uncontrollable and C unobservable infinite eigenvalues of the pencil lambda*E-A. If, in C addition, JOBEIG = 'A', uncontrollable and unobservable zero C eigenvalues are also removed. Then, or if JOBSYS = 'N', a C URV decomposition of the matrix E is performed, i.e., orthogonal C matrices U and V are computed, such that C C ( T 0 ) C U*E*V = ( ) with a full-rank matrix T. (1) C ( 0 0 ) C C Then the matrix A (or a copy of A if JOBEIG = 'A' or UPDATE = 'U') C is updated and partioned as in (1), i.e., C C ( A11 A12 ) C U*A*V = ( ) , (2) C ( A21 A22 ) C C and the rank of A22 is computed. If A22 is invertible, the C transfer function is proper, otherwise it is improper. If C required (i.e., JOBEIG = 'A' or UPDATE = 'U'), the matrices B and C C are updated as well in order to obtain an equivalent reduced C system with the same transfer function. See also Chapter 3 in [1], C [2] for more details. C C REFERENCES C C [1] Voigt, M. C L_inf-Norm Computation for Descriptor Systems. C Diploma Thesis, Chemnitz University of Technology, Department C of Mathematics, Germany, July 2010. C C [2] Benner, P., Sima, V., Voigt, M. C L_infinity-norm computation for continuous-time descriptor C systems using structured matrix pencils. C IEEE Trans. Automat. Contr., vol. 57, pp. 233-238, 2012. C C NUMERICAL ASPECTS C C The algorithm requires O(N**3) floating point operations. During C the algorithm it is necessary to determine the rank of certain C matrices. Therefore it is crucial to use an appropriate tolerance C TOL(1) to make correct rank decisions. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Jan. 2012. C Based on the subroutine DGEISP by Matthias Voigt, Chemnitz C University of Technology, Department of Mathematics, Feb. 2010. C C REVISIONS C C V. Sima, Feb. 2012, March 2012, April 2012, June 2012, Feb. 2021. C C KEYWORDS C C Descriptor system, proper transfer function, L_inf-norm C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TEN PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1 ) C C .. Scalar Arguments .. CHARACTER CKSING, EQUIL, JOBEIG, JOBSYS, RESTOR, UPDATE INTEGER INFO, IWARN, LDA, LDB, LDC, LDE, LDWORK, M, N, $ NR, P, RANKE C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), TOL( * ) C C .. Local Scalars .. CHARACTER SYSTYP LOGICAL LEQUIL, LQUERY, LREDC, LREMA, LRUPD, LSING, $ LUPD, MAXACC INTEGER I, ISV, ITAU, IWRK, IWS, J, K, MAXMP, MAXWRK, $ MINWRK, N1, NA, RANKA DOUBLE PRECISION PREC, SVLMAX, THRESH, TOLDEF C C .. Local Arrays .. DOUBLE PRECISION DUM( 2 ), TOLV( 3 ) C C .. External Subroutines .. EXTERNAL DLACPY, DLASET, DORMQR, DORMRZ, DSWAP, DTZRZF, $ MB03OD, TG01AD, TG01JY, XERBLA C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN C C .. Executable Statements .. C INFO = 0 IWARN = 0 MAXMP = MAX( M, P ) N1 = MAX( 1, N ) C C Decode the input arguments. C LREDC = LSAME( JOBSYS, 'R' ) LREMA = LSAME( JOBEIG, 'A' ) LEQUIL = LSAME( EQUIL, 'S' ) LSING = LSAME( CKSING, 'C' ) MAXACC = LSAME( RESTOR, 'R' ) LUPD = LSAME( UPDATE, 'U' ) LRUPD = LREMA .OR. LUPD C C Test the input arguments. C IF( .NOT.LREDC .AND. .NOT.LSAME( JOBSYS, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LREMA .AND. .NOT.LSAME( JOBEIG, 'I' ) ) THEN INFO = -2 ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN INFO = -3 ELSE IF( .NOT.LSING .AND. .NOT.LSAME( CKSING, 'N' ) ) THEN INFO = -4 ELSE IF( .NOT.MAXACC .AND. .NOT.LSAME( RESTOR, 'N' ) ) THEN INFO = -5 ELSE IF( .NOT.LUPD .AND. .NOT.LSAME( UPDATE, 'N' ) ) THEN INFO = -6 ELSE IF( N.LT.0 ) THEN INFO = -7 ELSE IF( M.LT.0 ) THEN INFO = -8 ELSE IF( P.LT.0 ) THEN INFO = -9 ELSE IF( LDA.LT.N1 ) THEN INFO = -11 ELSE IF( LDE.LT.N1 ) THEN INFO = -13 ELSE IF( LDB.LT.N1 ) THEN INFO = -15 ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN INFO = -17 ELSE IF( TOL( 1 ).GE.ONE ) THEN INFO = -20 ELSE IF( TOL( 2 ).GE.ONE ) THEN INFO = -20 ELSE IF( LEQUIL ) THEN THRESH = TOL( 3 ) IF( THRESH.GE.ONE ) $ INFO = -20 END IF IF( INFO.EQ.0 ) THEN C C Compute minimal workspace. C IF( LREDC ) THEN K = N*( 2*N + M + P ) IF( MAXACC ) THEN MINWRK = MAX( 1, 2*( K + MAXMP + N - 1 ) ) ELSE MINWRK = MAX( 1, 2*( MAXMP + N - 1 ) ) END IF MINWRK = MAX( MINWRK, N*N + 4*N ) IF( LSING ) $ MINWRK = MAX( MINWRK, 2*N*N + 10*N + MAX( N, 23 ) ) C IF( LREMA ) THEN SYSTYP = 'R' ELSE SYSTYP = 'P' END IF ELSE MINWRK = 0 END IF IF( LRUPD ) THEN MINWRK = MAX( MINWRK, N*N + 4*N + 4, N + MAXMP ) ELSE MINWRK = MAX( MINWRK, 4*N + 4 ) END IF IF( LEQUIL ) $ MINWRK = MAX( MINWRK, 8*N ) C MAXWRK = MINWRK LQUERY = LDWORK.EQ.-1 IF( LQUERY ) THEN C C Compute optimal workspace. C IF( LREDC ) THEN CALL TG01JY( 'Irreducible', SYSTYP, 'No Scaling', CKSING, $ RESTOR, N, M, P, A, LDA, E, LDE, B, LDB, C, $ LDC, NR, IWORK, TOL, IWORK, DWORK, -1, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ) ) END IF CALL MB03OD( 'QR Decomposition', N, N, E, LDE, IWORK, $ TOLDEF, ZERO, DWORK, RANKE, DWORK, DUM, -1, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DUM( 1 ) ) + N + 3 ) CALL DORMQR( 'Left', 'Transpose', N, N, N, E, LDE, DWORK, A, $ LDA, DUM, -1, INFO ) MAXWRK = MAX( MAXWRK, INT( DUM( 1 ) ) + N ) IF( LRUPD ) THEN CALL DORMQR( 'Left', 'Transpose', N, M, N, E, LDE, DWORK, $ B, LDB, DUM( 2 ), -1, INFO ) MAXWRK = MAX( MAXWRK, INT( DUM( 2 ) ) + N ) END IF CALL DTZRZF( N, N, E, LDE, DWORK, DUM, -1, INFO ) CALL DORMRZ( 'Right', 'Transpose', N, N, N, N, E, LDE, $ DWORK, A, LDA, DUM( 2 ), -1, INFO ) MAXWRK = MAX( MAXWRK, MAX( INT( DUM( 1 ) ), $ INT( DUM( 2 ) ) ) + N ) IF( LRUPD ) THEN CALL DORMRZ( 'Right', 'Transpose', P, N, N, N, E, LDE, $ DWORK, C, LDC, DUM, -1, INFO ) MAXWRK = MAX( MAXWRK, INT( DUM( 1 ) ) + N ) END IF ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -23 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB13ID', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK( 1 ) = MAXWRK RETURN END IF C C Quick return if possible. C NR = N IF( N.EQ.0 ) THEN RANKE = 0 AB13ID = .TRUE. DWORK( 1 ) = ONE RETURN END IF C C Set the tolerances. C TOLDEF = TOL( 1 ) IF( TOLDEF.LE.ZERO .OR. LEQUIL ) THEN PREC = DLAMCH( 'Precision' ) IF( LEQUIL ) THEN IF( THRESH.LT.ZERO ) $ THRESH = MAX( DLANGE( '1-norm', N, N, A, LDA, DWORK ), $ DLANGE( '1-norm', N, N, E, LDE, DWORK ), $ DLANGE( '1-norm', N, M, B, LDB, DWORK ), $ DLANGE( '1-norm', P, N, C, LDC, DWORK ) )* $ PREC ELSE TOLDEF = N*N*PREC END IF END IF TOLV( 1 ) = TOLDEF TOLV( 2 ) = TOL( 2 ) TOLV( 3 ) = TOL( 3 ) C C Computations. 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 C Equilibrate the system, if required. C C Workspace: need 8*N. C IF( LEQUIL ) THEN CALL TG01AD( 'All', N, N, M, P, THRESH, A, LDA, E, LDE, B, LDB, $ C, LDC, DWORK, DWORK( N+1 ), DWORK( 2*N+1 ), $ INFO ) MAXWRK = MAX( MAXWRK, 8*N ) END IF C IF( LREDC ) THEN C C Step 1: If JOBEIG = 'A' remove all uncontrollable and C unobservable eigenvalues of the system; otherwise C remove only the uncontrollable and unobservable C infinite eigenvalues explicitely, uncontrollable or C unobservable zero eigenvalues are not removed. C C Workspace: need MAX(2*(MAX(M,P)+N-1),N*N+4*N,y), C prefer MAX(2*N*N+N*M+N*P+2*(MAX(M,P)+N-1),y), or C even larger (see, optimal space above). C IWS = 8 CALL TG01JY( 'Irreducible', SYSTYP, 'No Scaling', CKSING, $ RESTOR, N, M, P, A, LDA, E, LDE, B, LDB, C, LDC, $ NR, IWORK, TOLV, IWORK( IWS ), DWORK, LDWORK, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ) ) IF( INFO.EQ.1 ) THEN AB13ID = .FALSE. RETURN END IF ELSE IWS = 1 END IF C C Step 2: Compute a URV decomposition of E(1:NR,1:NR). C DO 10 I = IWS, IWS + NR - 1 IWORK( I ) = 0 10 CONTINUE C C Perform a rank-revealing QR decomposition of E(1:NR,1:NR) with C respect to the tolerance TOLDEF. C C Workspace: need 4*NR+4, C prefer 3*NR+( NR+1 )*NB+3, with NB for DGEQP3. C SVLMAX = DLANGE( 'Frobenius', N, N, E, LDE, DWORK ) CALL MB03OD( 'QR Decomposition', NR, NR, E, LDE, IWORK( IWS ), $ TOLDEF, SVLMAX, DWORK, RANKE, DWORK( NR+1 ), $ DWORK( NR+4 ), LDWORK-( NR+3 ), INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( NR+4 ) ) + NR + 3 ) C C Check whether there are singular values close to the tolerance C TOLDEF. C IF( MIN( ABS( DWORK( NR+2 ) - TOLDEF ), $ ABS( DWORK( NR+3 ) - TOLDEF ) ) .LT.TOLDEF/TEN ) C C One singular value is close to TOLDEF, warning returned. C $ IWARN = 1 C IF( RANKE.LT.NR .OR. LRUPD ) THEN C C Perform the same transformations on A(1:NR,1:NR). C C Workspace: need 2*NR, C prefer NR+NR*( NB+1 ). C CALL DORMQR( 'Left', 'Transpose', NR, NR, NR, E, LDE, DWORK, A, $ LDA, DWORK( NR+1 ), LDWORK-NR, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( NR+1 ) ) + NR ) C DO 20 I = IWS, IWS + NR - 1 IWORK( I ) = -IWORK( I ) 20 CONTINUE C DO 40 I = IWS, IWS + NR - 1 IF( IWORK( I ).LT.0 ) THEN J = I IWORK( J ) = -IWORK( J ) 30 CONTINUE K = IWORK( J ) + IWS - 1 IF( IWORK( K ).LT.0 ) THEN CALL DSWAP( NR, A( 1, J-IWS+1 ), 1, A( 1, K-IWS+1 ), $ 1 ) IWORK( K ) = -IWORK( K ) J = K GO TO 30 END IF END IF 40 CONTINUE C IF( LRUPD ) THEN C C Update B and C. C C Workspace: need NR+M, C prefer NR+M*NB. C CALL DORMQR( 'Left', 'Transpose', NR, M, NR, E, LDE, DWORK, $ B, LDB, DWORK( NR+1 ), LDWORK-NR, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( NR+1 ) ) + NR ) C DO 50 I = IWS, IWS + NR - 1 IWORK( I ) = -IWORK( I ) 50 CONTINUE C DO 70 I = IWS, IWS + NR - 1 IF( IWORK( I ).LT.0 ) THEN J = I IWORK( J ) = -IWORK( J ) 60 CONTINUE K = IWORK( J ) + IWS - 1 IF( IWORK( K ).LT.0 ) THEN CALL DSWAP( P, C( 1, J-IWS+1 ), 1, C( 1, K-IWS+1 ), $ 1 ) IWORK( K ) = -IWORK( K ) J = K GO TO 60 END IF END IF 70 CONTINUE END IF END IF C C ( R11 R12 ) C Logically partition E(1:NR,1:NR) = ( ), C ( 0 R22 ) C C where R11 = R(1:RANKE,1:RANKE). C C Neglect R22 and annihilate R12. C IF( RANKE.LT.NR ) THEN C C The block R22 is non-empty, further computations required. C C Workspace: need 2*RANKE, C prefer RANKE+RANKE*NB. C CALL DTZRZF( RANKE, NR, E, LDE, DWORK, DWORK( RANKE+1 ), $ LDWORK-RANKE, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( RANKE+1 ) ) + RANKE ) C C Perform the same transformations on A(1:NR,1:NR). C C Workspace: need RANKE+NR, C prefer RANKE+NR*NB. C NA = NR - RANKE CALL DORMRZ( 'Right', 'Transpose', NR, NR, RANKE, NA, E, LDE, $ DWORK, A, LDA, DWORK( RANKE+1 ), LDWORK-RANKE, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( RANKE+1 ) ) + RANKE ) C IF( LRUPD ) THEN C C Update C. C C Workspace: need RANKE+P, C prefer RANKE+P*NB. C CALL DORMRZ( 'Right', 'Transpose', P, NR, RANKE, NA, E, LDE, $ DWORK, C, LDC, DWORK( RANKE+1 ), LDWORK-RANKE, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK( RANKE+1 ) ) + RANKE ) END IF C C Step 3: Determine the rank of A(RANKE+1:NR,RANKE+1:NR). C DO 80 I = IWS, IWS + NA - 1 IWORK( I ) = 0 80 CONTINUE C C Perform a rank-revealing QR decomposition of C A(RANKE+1:NR,RANKE+1:NR) with respect to the tolerance TOLDEF. C SVLMAX = DLANGE( 'Frobenius', NR, NR, A, LDA, DWORK ) C IF( LRUPD ) THEN C C IF JOBEIG = 'A' or UPDATE = 'U', then copy C A(RANKE+1:NR,RANKE+1:NR) to DWORK and perform the operations C on DWORK. C C Workspace: need NA*NA+4*NA+4, C prefer NA*NA+3*NA+( NA+1 )*NB+3. C ITAU = NA*NA + 1 ISV = ITAU + NA IWRK = ISV + 3 CALL DLACPY( 'Full', NA, NA, A( RANKE+1, RANKE+1 ), LDA, $ DWORK, NA ) CALL MB03OD( 'QR Decomposition', NA, NA, DWORK, NA, $ IWORK( IWS ), TOLDEF, SVLMAX, DWORK( ITAU ), $ RANKA, DWORK( ISV ), DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) ELSE C C Workspace: need 4*NA+4, C prefer 3*NA+( NA+1 )*NB+3. C ISV = NA + 1 IWRK = ISV + 3 CALL MB03OD( 'QR Decomposition', NA, NA, $ A( RANKE+1, RANKE+1 ), LDA, IWORK( IWS ), $ TOLDEF, SVLMAX, DWORK, RANKA, DWORK( ISV ), $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) END IF C MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Check whether there are singular values close to the C tolerance TOLDEF. C IF( MIN( ABS( DWORK( ISV+1 ) - TOLDEF ), $ ABS( DWORK( ISV+2 ) - TOLDEF ) ).LT.TOLDEF/TEN ) C C One singular value is close to TOLDEF, warning returned. C $ IWARN = 1 C C Set R12 to 0. C IF( NA.GT.0 ) $ CALL DLASET( 'Full', RANKE, NA, ZERO, ZERO, E( 1, RANKE+1 ), $ LDE ) ELSE C C The block R22 is empty, no computation required. C RANKA = 0 NA = 0 END IF C C Set the lower triangle of T in (1) to 0. C IF( NR.GT.1 ) $ CALL DLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, E( 2, 1 ), LDE ) C C Step 4: Determine if the transfer function is proper. C IF( NA.EQ.RANKA ) THEN C C The transfer function is proper. C AB13ID = .TRUE. ELSE C C The transfer function is improper. C AB13ID = .FALSE. END IF C DWORK( 1 ) = MAXWRK RETURN C *** Last line of AB13ID *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03YT.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03YT.f0000644000175000017500000002237115012430707017414 0ustar00lilgelilge00000000000000 SUBROUTINE MB03YT( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, $ CSR, SNR ) C C PURPOSE C C To compute the periodic Schur factorization of a real 2-by-2 C matrix pair (A,B) where B is upper triangular. This routine C computes orthogonal (rotation) matrices given by CSL, SNL and CSR, C SNR such that C C 1) if the pair (A,B) has two real eigenvalues, then C C [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] C [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] C C [ b11 b12 ] := [ CSR SNR ] [ b11 b12 ] [ CSL -SNL ] C [ 0 b22 ] [ -SNR CSR ] [ 0 b22 ] [ SNL CSL ], C C 2) if the pair (A,B) has a pair of complex conjugate eigenvalues, C then C C [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] C [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] C C [ b11 0 ] := [ CSR SNR ] [ b11 b12 ] [ CSL -SNL ] C [ 0 b22 ] [ -SNR CSR ] [ 0 b22 ] [ SNL CSL ]. C C This is a modified version of the LAPACK routine DLAGV2 for C computing the real, generalized Schur decomposition of a C two-by-two matrix pencil. C C ARGUMENTS C C Input/Output Parameters C C A (input/output) DOUBLE PRECISION array, dimension (LDA,2) C On entry, the leading 2-by-2 part of this array must C contain the matrix A. C On exit, the leading 2-by-2 part of this array contains C the matrix A of the pair in periodic Schur form. C C LDA INTEGER C The leading dimension of the array A. LDA >= 2. C C B (input/output) DOUBLE PRECISION array, dimension (LDB,2) C On entry, the leading 2-by-2 part of this array must C contain the upper triangular matrix B. C On exit, the leading 2-by-2 part of this array contains C the matrix B of the pair in periodic Schur form. C C LDB INTEGER C The leading dimension of the array B. LDB >= 2. C C ALPHAR (output) DOUBLE PRECISION array, dimension (2) C ALPHAI (output) DOUBLE PRECISION array, dimension (2) C BETA (output) DOUBLE PRECISION array, dimension (2) C (ALPHAR(k)+i*ALPHAI(k))*BETA(k) are the eigenvalues of the C pair (A,B), k=1,2, i = sqrt(-1). ALPHAI(1) >= 0. C C CSL (output) DOUBLE PRECISION C The cosine of the first rotation matrix. C C SNL (output) DOUBLE PRECISION C The sine of the first rotation matrix. C C CSR (output) DOUBLE PRECISION C The cosine of the second rotation matrix. C C SNR (output) DOUBLE PRECISION C The sine of the second rotation matrix. C C REFERENCES C C [1] Van Loan, C. C Generalized Singular Values with Algorithms and Applications. C Ph. D. Thesis, University of Michigan, 1973. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPV2). C V. Sima, July 2008, May 2009. C C KEYWORDS C C Eigenvalue, periodic Schur form C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER LDA, LDB DOUBLE PRECISION CSL, CSR, SNL, SNR C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), ALPHAI(2), ALPHAR(2), B(LDB,*), $ BETA(2) C .. Local Scalars .. DOUBLE PRECISION ANORM, BNORM, H1, H2, H3, QQ, R, RR, SAFMIN, $ SCALE1, SCALE2, T, ULP, WI, WR1, WR2 C .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 C .. External Subroutines .. EXTERNAL DLAG2, DLARTG, DLASV2, DROT C .. Intrinsic Functions .. INTRINSIC ABS, MAX C C .. Executable Statements .. C SAFMIN = DLAMCH( 'S' ) ULP = DLAMCH( 'P' ) C C Scale A. C ANORM = MAX( ABS( A(1,1) ) + ABS( A(2,1) ), $ ABS( A(1,2) ) + ABS( A(2,2) ), SAFMIN ) A(1,1) = A(1,1) / ANORM A(1,2) = A(1,2) / ANORM A(2,1) = A(2,1) / ANORM A(2,2) = A(2,2) / ANORM C C Scale B. C BNORM = MAX( ABS( B(1,1) ), ABS( B(1,2) ) + ABS( B(2,2) ), SAFMIN) B(1,1) = B(1,1) / BNORM B(1,2) = B(1,2) / BNORM B(2,2) = B(2,2) / BNORM C C Check if A can be deflated. C IF ( ABS( A(2,1) ).LE.ULP ) THEN CSL = ONE SNL = ZERO CSR = ONE SNR = ZERO WI = ZERO A(2,1) = ZERO B(2,1) = ZERO C C Check if B is singular. C ELSE IF ( ABS( B(1,1) ).LE.ULP ) THEN CALL DLARTG( A(2,2), A(2,1), CSR, SNR, T ) SNR = -SNR CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR ) CSL = ONE SNL = ZERO WI = ZERO A(2,1) = ZERO B(1,1) = ZERO B(2,1) = ZERO ELSE IF( ABS( B(2,2) ).LE.ULP ) THEN CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R ) CSR = ONE SNR = ZERO WI = ZERO CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL ) A(2,1) = ZERO B(2,1) = ZERO B(2,2) = ZERO ELSE C C B is nonsingular, first compute the eigenvalues of A / adj(B). C R = B(1,1) B(1,1) = B(2,2) B(2,2) = R B(1,2) = -B(1,2) CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, $ WI ) C IF( WI.EQ.ZERO ) THEN C C Two real eigenvalues, compute s*A-w*B. C H1 = SCALE1*A(1,1) - WR1*B(1,1) H2 = SCALE1*A(1,2) - WR1*B(1,2) H3 = SCALE1*A(2,2) - WR1*B(2,2) C RR = DLAPY2( H1, H2 ) QQ = DLAPY2( SCALE1*A(2,1), H3 ) C IF ( RR.GT.QQ ) THEN C C Find right rotation matrix to zero 1,1 element of C (sA - wB). C CALL DLARTG( H2, H1, CSR, SNR, T ) C ELSE C C Find right rotation matrix to zero 2,1 element of C (sA - wB). C CALL DLARTG( H3, SCALE1*A(2,1), CSR, SNR, T ) C END IF C SNR = -SNR CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSR, SNR ) C C Compute inf norms of A and B. C H1 = MAX( ABS( A(1,1) ) + ABS( A(1,2) ), $ ABS( A(2,1) ) + ABS( A(2,2) ) ) H2 = MAX( ABS( B(1,1) ) + ABS( B(1,2) ), $ ABS( B(2,1) ) + ABS( B(2,2) ) ) C IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN C C Find left rotation matrix Q to zero out B(2,1). C CALL DLARTG( B(1,1), B(2,1), CSL, SNL, R ) C ELSE C C Find left rotation matrix Q to zero out A(2,1). C CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R ) C END IF C CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSL, SNL ) C A(2,1) = ZERO B(2,1) = ZERO C C Re-adjoint B. C R = B(1,1) B(1,1) = B(2,2) B(2,2) = R B(1,2) = -B(1,2) C ELSE C C A pair of complex conjugate eigenvalues: C first compute the SVD of the matrix adj(B). C R = B(1,1) B(1,1) = B(2,2) B(2,2) = R B(1,2) = -B(1,2) CALL DLASV2( B(1,1), B(1,2), B(2,2), R, T, SNL, CSL, $ SNR, CSR ) C C Form (A,B) := Q(A,adj(B))Z' where Q is left rotation matrix C and Z is right rotation matrix computed from DLASV2. C CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR ) CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL ) C B(2,1) = ZERO B(1,2) = ZERO END IF C END IF C C Unscaling C R = B(1,1) T = B(2,2) A(1,1) = ANORM*A(1,1) A(2,1) = ANORM*A(2,1) A(1,2) = ANORM*A(1,2) A(2,2) = ANORM*A(2,2) B(1,1) = BNORM*B(1,1) B(2,1) = BNORM*B(2,1) B(1,2) = BNORM*B(1,2) B(2,2) = BNORM*B(2,2) C IF( WI.EQ.ZERO ) THEN ALPHAR(1) = A(1,1) ALPHAR(2) = A(2,2) ALPHAI(1) = ZERO ALPHAI(2) = ZERO BETA(1) = B(1,1) BETA(2) = B(2,2) ELSE WR1 = ANORM*WR1 WI = ANORM*WI IF ( ABS( WR1 ).GT.ONE .OR. WI.GT.ONE ) THEN WR1 = WR1*R WI = WI*R R = ONE END IF IF ( ABS( WR1 ).GT.ONE .OR. ABS( WI ).GT.ONE ) THEN WR1 = WR1*T WI = WI*T T = ONE END IF ALPHAR(1) = ( WR1 / SCALE1 )*R*T ALPHAI(1) = ABS( ( WI / SCALE1 )*R*T ) ALPHAR(2) = ALPHAR(1) ALPHAI(2) = -ALPHAI(1) BETA(1) = BNORM BETA(2) = BNORM END IF RETURN C *** Last line of MB03YT *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04DS.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04DS.f0000644000175000017500000003525315012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE MB04DS( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) C C PURPOSE C C To balance a real skew-Hamiltonian matrix C C [ A G ] C S = [ T ] , C [ Q A ] C C where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric C matrices. This involves, first, permuting S by a symplectic C similarity transformation to isolate eigenvalues in the first C 1:ILO-1 elements on the diagonal of A; and second, applying a C diagonal similarity transformation to rows and columns C ILO:N, N+ILO:2*N to make the rows and columns as close in 1-norm C as possible. Both steps are optional. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the operations to be performed on S: C = 'N': none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N; C = 'P': permute only; C = 'S': scale only; C = 'B': both permute and scale. 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 part of this array must C contain the matrix A. C On exit, the leading N-by-N part of this array contains C the matrix A of the balanced skew-Hamiltonian. In C particular, the strictly lower triangular part of the C first ILO-1 columns of A is zero. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input/output) DOUBLE PRECISION array, dimension C (LDQG,N+1) C On entry, the leading N-by-N+1 part of this array must C contain in columns 1:N the strictly lower triangular part C of the matrix Q and in columns 2:N+1 the strictly upper C triangular part of the matrix G. The parts containing the C diagonal and the first supdiagonal of this array are not C referenced. C On exit, the leading N-by-N+1 part of this array contains C the strictly lower and strictly upper triangular parts of C the matrices Q and G, respectively, of the balanced C skew-Hamiltonian. In particular, the strictly lower C triangular part of the first ILO-1 columns of QG is zero. C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C ILO (output) INTEGER C ILO-1 is the number of deflated eigenvalues in the C balanced skew-Hamiltonian matrix. C C SCALE (output) DOUBLE PRECISION array of dimension (N) C Details of the permutations and scaling factors applied to C S. For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N, C then rows and columns P(j) and P(j)+N are interchanged C with rows and columns j and j+N, respectively. If C P(j) > N, then row and column P(j)-N are interchanged with C row and column j+N by a generalized symplectic C permutation. For j = ILO,...,N the j-th element of SCALE C contains the factor of the scaling applied to row and C column j. 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] Benner, P. C Symplectic balancing of Hamiltonian matrices. C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2001. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DSHBAL). C V. Sima, Oct. 2012, Mar. 2016. C C KEYWORDS C C Balancing, skew-Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) DOUBLE PRECISION FACTOR PARAMETER ( FACTOR = 0.95D0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER ILO, INFO, LDA, LDQG, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), QG(LDQG,*), SCALE(*) C .. Local Scalars .. LOGICAL CONV, LPERM, LSCAL INTEGER I, IC, ILOOLD, J DOUBLE PRECISION C, F, G, MAXC, MAXR, R, S, SCLFAC, SFMAX1, $ SFMAX2, SFMIN1, SFMIN2 C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DASUM, DLAMCH EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) C IF ( .NOT.LPERM .AND. .NOT.LSCAL .AND. $ .NOT.LSAME( JOB, 'N' ) ) THEN INFO = -1 ELSE IF ( N.LT.0 ) THEN INFO = -2 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN INFO = -6 END IF C C Return if there were illegal values. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04DS', -INFO ) RETURN END IF C ILO = 1 C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN DO 10 I = 1, N SCALE(I) = ONE 10 CONTINUE RETURN END IF C C Permutations to isolate eigenvalues if possible. C IF ( LPERM ) THEN ILOOLD = 0 C WHILE ( ILO.NE.ILOOLD ) 20 IF ( ILO.NE.ILOOLD ) THEN ILOOLD = ILO C C Scan columns ILO .. N. C I = ILO C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) 30 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN DO 40 J = ILO, I-1 IF ( A(J,I).NE.ZERO ) THEN I = I + 1 GOTO 30 END IF 40 CONTINUE DO 50 J = I+1, N IF ( A(J,I).NE.ZERO ) THEN I = I + 1 GOTO 30 END IF 50 CONTINUE DO 60 J = ILO, I-1 IF ( QG(I,J).NE.ZERO ) THEN I = I + 1 GOTO 30 END IF 60 CONTINUE DO 70 J = I+1, N IF ( QG(J,I).NE.ZERO ) THEN I = I + 1 GOTO 30 END IF 70 CONTINUE C C Exchange columns/rows ILO <-> I. C SCALE(ILO) = DBLE( I ) IF ( ILO.NE.I ) THEN C CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) C IF ( I.LT.N ) $ CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 ) IF ( I.GT.ILO+1 ) THEN CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 ) CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1), $ LDQG ) END IF C CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 ) IF ( N.GT.I ) $ CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2), $ LDQG ) IF ( I.GT.ILO+1 ) THEN CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 ) CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG, $ QG(ILO+1,I+1), 1 ) END IF CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 ) END IF ILO = ILO + 1 END IF C END WHILE 30 C C Scan columns N+ILO .. 2*N. C I = ILO C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) 80 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN DO 90 J = ILO, I-1 IF ( A(I,J).NE.ZERO ) THEN I = I + 1 GOTO 80 END IF 90 CONTINUE DO 100 J = I+1, N IF ( A(I,J).NE.ZERO ) THEN I = I + 1 GOTO 80 END IF 100 CONTINUE DO 110 J = ILO, I-1 IF ( QG(J,I+1).NE.ZERO ) THEN I = I + 1 GOTO 80 END IF 110 CONTINUE DO 120 J = I+1, N IF ( QG(I,J+1).NE.ZERO ) THEN I = I + 1 GOTO 80 END IF 120 CONTINUE SCALE(ILO) = DBLE( N+I ) C C Exchange columns/rows I <-> I+N with a symplectic C generalized permutation. C CALL DSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG ) CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA ) CALL DSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 ) CALL DSCAL( N-I, -ONE, QG(I+1,I), 1 ) CALL DSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 ) CALL DSCAL( I-1, -ONE, A(1,I), 1 ) CALL DSCAL( N-I, -ONE, A(I+1,I), 1 ) CALL DSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG ) C C Exchange columns/rows ILO <-> I. C IF ( ILO.NE.I ) THEN C CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) C IF ( I.LT.N ) $ CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 ) IF ( I.GT.ILO+1 ) THEN CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 ) CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1), $ LDQG ) END IF C CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 ) IF ( N.GT.I ) $ CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2), $ LDQG ) IF ( I.GT.ILO+1 ) THEN CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 ) CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG, $ QG(ILO+1,I+1), 1 ) END IF CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 ) END IF ILO = ILO + 1 END IF C END WHILE 80 GOTO 20 END IF C END WHILE 20 END IF C DO 130 I = ILO, N SCALE(I) = ONE 130 CONTINUE C C Scale to reduce the 1-norm of the remaining blocks. C IF ( LSCAL ) THEN SCLFAC = DLAMCH( 'B' ) SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 C C Scale the rows and columns one at a time to minimize the C 1-norm of the skew-Hamiltonian submatrix. C Stop when the 1-norm is very roughly minimal. C 140 CONTINUE CONV = .TRUE. DO 190 I = ILO, N C C Compute 1-norm of row and column I without diagonal C elements. C R = DASUM( I-ILO, A(I,ILO), LDA ) + $ DASUM( N-I, A(I,I+1), LDA ) + $ DASUM( I-ILO, QG(ILO,I+1), 1 ) + $ DASUM( N-I, QG(I,I+2), LDQG ) C = DASUM( I-ILO, A(ILO,I), 1 ) + $ DASUM( N-I, A(I+1,I), 1 ) + $ DASUM( I-ILO, QG(I,ILO), LDQG ) + $ DASUM( N-I, QG(I+1,I), 1 ) C C Compute inf-norms of row and column I. C IC = IDAMAX( N-ILO+1, A(I,ILO), LDA ) MAXR = ABS( A(I,IC+ILO-1) ) IF ( I.GT.1 ) THEN IC = IDAMAX( I-1, QG(1,I+1), 1 ) MAXR = MAX( MAXR, ABS( QG(IC,I+1) ) ) END IF IF ( N.GT.I ) THEN IC = IDAMAX( N-I, QG(I,I+2), LDQG ) MAXR = MAX( MAXR, ABS( QG(I,IC+I+1) ) ) END IF IC = IDAMAX( N, A(1,I), 1 ) MAXC = ABS( A(IC,I) ) IF ( I.GT.ILO ) THEN IC = IDAMAX( I-ILO, QG(I,ILO), LDQG ) MAXC = MAX( MAXC, ABS( QG(I,IC+ILO-1) ) ) END IF IF ( N.GT.I ) THEN IC = IDAMAX( N-I, QG(I+1,I), 1 ) MAXC = MAX( MAXC, ABS( QG(IC+I,I) ) ) END IF C IF ( C.EQ.ZERO .OR. R.EQ.ZERO ) $ GOTO 190 G = R / SCLFAC F = ONE S = C + R 150 CONTINUE IF ( C.GE.G .OR. MAX( F, C, MAXC ).GE.SFMAX2 .OR. $ MIN( R, G, MAXR ).LE.SFMIN2 ) $ GOTO 160 F = F*SCLFAC G = G / SCLFAC C = C*SCLFAC R = R / SCLFAC MAXC = MAXC*SCLFAC MAXR = MAXR / SCLFAC GOTO 150 C 160 CONTINUE G = C / SCLFAC 170 CONTINUE IF ( G.LT.R .OR. MAX( R, MAXR ).GE.SFMAX2 .OR. $ MIN( F, C, G, MAXC ).LE.SFMIN2 ) $ GOTO 180 F = F / SCLFAC G = G / SCLFAC C = C / SCLFAC R = R*SCLFAC MAXC = MAXC / SCLFAC MAXR = MAXR*SCLFAC GOTO 170 C 180 CONTINUE C C Now balance if necessary. C IF ( ( C+R ).GE.FACTOR*S ) $ GOTO 190 IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN IF ( F*SCALE(I).LE.SFMIN1 ) $ GOTO 190 END IF IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN IF ( SCALE(I).GE.SFMAX1 / F ) $ GOTO 190 END IF CONV = .FALSE. SCALE(I) = SCALE(I)*F CALL DRSCL( I-ILO, F, A(I,ILO), LDA ) CALL DRSCL( N-I, F, A(I,I+1), LDA ) CALL DSCAL( I-1, F, A(1,I), 1 ) CALL DSCAL( N-I, F, A(I+1,I), 1 ) CALL DRSCL( I-1, F, QG(1,I+1), 1 ) CALL DRSCL( N-I, F, QG(I,I+2), LDQG ) CALL DSCAL( I-ILO, F, QG(I,ILO), LDQG ) CALL DSCAL( N-I, F, QG(I+1,I), 1 ) 190 CONTINUE IF ( .NOT.CONV ) GOTO 140 END IF RETURN C *** Last line of MB04DS *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04ND.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB04ND.f0000644000175000017500000003145015012430707017366 0ustar00lilgelilge00000000000000 SUBROUTINE SB04ND( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To solve for X the continuous-time Sylvester equation C C AX + XB = C, C C with at least one of the matrices A or B in Schur form and the C other in Hessenberg or Schur form (both either upper or lower); C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, C respectively. C C ARGUMENTS C C Mode Parameters C C ABSCHU CHARACTER*1 C Indicates whether A and/or B is/are in Schur or C Hessenberg form as follows: C = 'A': A is in Schur form, B is in Hessenberg form; C = 'B': B is in Schur form, A is in Hessenberg form; C = 'S': Both A and B are in Schur form. C C ULA CHARACTER*1 C Indicates whether A is in upper or lower Schur form or C upper or lower Hessenberg form as follows: C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and C upper Schur form otherwise; C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and C lower Schur form otherwise. C C ULB CHARACTER*1 C Indicates whether B is in upper or lower Schur form or C upper or lower Hessenberg form as follows: C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and C upper Schur form otherwise; C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and C lower Schur form otherwise. 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) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must contain the C coefficient matrix A of the equation. 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 M-by-M part of this array must contain the C coefficient matrix B of the equation. 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, if INFO = 0, the leading N-by-M part of this C array contains the solution matrix X of the problem. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,N). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used to test for near singularity in C the Sylvester equation. If the user sets TOL > 0, then the C given value of TOL is used as a lower bound for the C reciprocal condition number; a matrix whose estimated C condition number is less than 1/TOL is considered to be C nonsingular. If the user sets TOL <= 0, then a default C tolerance, defined by TOLDEF = EPS, is used instead, where C EPS is the machine precision (see LAPACK Library routine C DLAMCH). C This parameter is not referenced if ABSCHU = 'S', C ULA = 'U', and ULB = 'U'. C C Workspace C C IWORK INTEGER array, dimension (2*MAX(M,N)) C This parameter is not referenced if ABSCHU = 'S', C ULA = 'U', and ULB = 'U'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C This parameter is not referenced if ABSCHU = 'S', C ULA = 'U', and ULB = 'U'. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK = 0, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. 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 a (numerically) singular matrix T was encountered C during the computation of the solution matrix X. C That is, the estimated reciprocal condition number C of T is less than or equal to TOL. C C METHOD C C Matrices A and B are assumed to be in (upper or lower) Hessenberg C or Schur form (with at least one of them in Schur form). The C solution matrix X is then computed by rows or columns via the back C substitution scheme proposed by Golub, Nash and Van Loan (see C [1]), which involves the solution of triangular systems of C equations that are constructed recursively and which may be nearly C singular if A and -B have close eigenvalues. If near singularity C is detected, then the routine returns with the Error Indicator C (INFO) set to 1. 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 2 2 C The algorithm requires approximately 5M N + 0.5MN operations in C 2 2 C the worst case and 2.5M N + 0.5MN operations in the best case C (where M is the order of the matrix in Hessenberg form and N is C the order of the matrix in Schur form) and is mixed stable (see C [1]). C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB04BD by M. Vanbegin, and C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 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 .. CHARACTER ABSCHU, ULA, ULB INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) C .. Local Scalars .. CHARACTER ABSCHR LOGICAL LABSCB, LABSCS, LULA, LULB INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, $ LDW, MAXMN DOUBLE PRECISION SCALE, TOL1 C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DTRSYL, SB04NV, SB04NW, SB04NX, SB04NY, $ XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C INFO = 0 MAXMN = MAX( M, N ) LABSCB = LSAME( ABSCHU, 'B' ) LABSCS = LSAME( ABSCHU, 'S' ) LULA = LSAME( ULA, 'U' ) LULB = LSAME( ULB, 'U' ) C C Test the input scalar arguments. C IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN INFO = -1 ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN INFO = -2 ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDWORK.LT.0 .OR. ( .NOT.( LABSCS .AND. LULA .AND. LULB ) $ .AND. LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) ) ) THEN INFO = -15 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB04ND', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAXMN.EQ.0 ) $ RETURN C IF ( LABSCS .AND. LULA .AND. LULB ) THEN C C If both matrices are in a real Schur form, use DTRSYL. C CALL DTRSYL( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, B, $ LDB, C, LDC, SCALE, INFO ) IF ( SCALE.NE.ONE ) $ INFO = 1 RETURN END IF C LDW = 2*MAXMN JWORK = LDW*LDW + 3*LDW + 1 TOL1 = TOL IF ( TOL1.LE.ZERO ) $ TOL1 = DLAMCH( 'Epsilon' ) C C Choose the smallest of both matrices as the one in Hessenberg C form when possible. C ABSCHR = ABSCHU IF ( LABSCS ) THEN IF ( N.GT.M ) THEN ABSCHR = 'A' ELSE ABSCHR = 'B' END IF END IF IF ( LSAME( ABSCHR, 'B' ) ) THEN C C B is in Schur form: recursion on the columns of B. C IF ( LULB ) THEN C C B is upper: forward recursion. C IBEG = 1 IEND = M FWD = 1 INCR = 0 ELSE C C B is lower: backward recursion. C IBEG = M IEND = 1 FWD = -1 INCR = -1 END IF I = IBEG C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN C C Test for 1-by-1 or 2-by-2 diagonal block in the Schur C form. C IF ( I.EQ.IEND ) THEN ISTEP = 1 ELSE IF ( B(I+FWD,I).EQ.ZERO ) THEN ISTEP = 1 ELSE ISTEP = 2 END IF END IF C IF ( ISTEP.EQ.1 ) THEN CALL SB04NW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, $ DWORK(JWORK) ) CALL SB04NY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), $ TOL1, IWORK, DWORK, LDW, INFO ) IF ( INFO.EQ.1 ) $ RETURN CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) ELSE IPINCR = I + INCR CALL SB04NV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, $ DWORK(JWORK) ) CALL SB04NX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, $ IWORK, DWORK, LDW, INFO ) IF ( INFO.EQ.1 ) $ RETURN CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) END IF I = I + FWD*ISTEP GO TO 20 END IF C END WHILE 20 ELSE C C A is in Schur form: recursion on the rows of A. C IF ( LULA ) THEN C C A is upper: backward recursion. C IBEG = N IEND = 1 FWD = -1 INCR = -1 ELSE C C A is lower: forward recursion. C IBEG = 1 IEND = N FWD = 1 INCR = 0 END IF I = IBEG C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN C C Test for 1-by-1 or 2-by-2 diagonal block in the Schur C form. C IF ( I.EQ.IEND ) THEN ISTEP = 1 ELSE IF ( A(I,I+FWD).EQ.ZERO ) THEN ISTEP = 1 ELSE ISTEP = 2 END IF END IF C IF ( ISTEP.EQ.1 ) THEN CALL SB04NW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, $ DWORK(JWORK) ) CALL SB04NY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), $ TOL1, IWORK, DWORK, LDW, INFO ) IF ( INFO.EQ.1 ) $ RETURN CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) ELSE IPINCR = I + INCR CALL SB04NV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, $ DWORK(JWORK) ) CALL SB04NX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, $ IWORK, DWORK, LDW, INFO ) IF ( INFO.EQ.1 ) $ RETURN CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) END IF I = I + FWD*ISTEP GO TO 40 END IF C END WHILE 40 END IF C RETURN C *** Last line of SB04ND *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01ND.f0000644000000000000000000000013215012430707016165 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB01ND.f0000644000175000017500000002453315012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE TB01ND( JOBU, UPLO, N, P, A, LDA, C, LDC, U, LDU, $ DWORK, INFO ) C C PURPOSE C C To reduce the pair (A,C) to lower or upper observer Hessenberg C form using (and optionally accumulating) unitary state-space C transformations. C C ARGUMENTS C C Mode Parameters C C JOBU CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix U the unitary state-space transformations for C reducing the system, as follows: C = 'N': Do not form U; C = 'I': U is initialized to the unit matrix and the C unitary transformation matrix U is returned; C = 'U': The given matrix U is updated by the unitary C transformations used in the reduction. C C UPLO CHARACTER*1 C Indicates whether the user wishes the pair (A,C) to be C reduced to upper or lower observer Hessenberg form as C follows: C = 'U': Upper observer Hessenberg form; C = 'L': Lower observer Hessenberg form. C C Input/Output Parameters C C N (input) INTEGER C The actual state dimension, i.e. the order of the C matrix A. N >= 0. C C P (input) INTEGER C The actual output dimension, i.e. the number of rows of C the matrix C. 0 <= P <= 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 state transition matrix A to be transformed. C On exit, the leading N-by-N part of this array contains C the transformed state transition matrix U' * A * U. C The annihilated elements are set to zero. C C LDA INTEGER C The leading dimension of array A. LDA >= 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 output matrix C to be transformed. C On exit, the leading P-by-N part of this array contains C the transformed output matrix C * U. C The annihilated elements are set to zero. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) C On entry, if JOBU = 'U', then the leading N-by-N part of C this array must contain a given matrix U (e.g. from a C previous call to another SLICOT routine), and on exit, the C leading N-by-N part of this array contains the product of C the input matrix U and the state-space transformation C matrix which reduces the given pair to observer Hessenberg C form. C On exit, if JOBU = 'I', then the leading N-by-N part of C this array contains the matrix of accumulated unitary C similarity transformations which reduces the given pair C to observer Hessenberg form. C If JOBU = 'N', the array U is not referenced and can be C supplied as a dummy array (i.e. set parameter LDU = 1 and C declare this array to be U(1,1) in the calling program). C C LDU INTEGER C The leading dimension of array U. If JOBU = 'U' or C JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (MAX(N,P-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 unitary state-space transformation U, which C reduces the pair (A,C) to one of the following observer Hessenberg C forms: C C N C |* . . . . . . *| C |. .| C |. .| C |. .| N C |* .| C |U'AU| | . .| C |----| = | . .| C |CU | | * . . . *| C ------------------- C | * . . *| C | . .| P C | . .| C | *| C C if UPLO = 'U', or C C N C |* | C |. . | C |. . | P C |* . . * | C |CU | ------------------- C |----| = |* . . . * | C |U'AU| |. . | C |. . | C |. *| C |. .| N C |. .| C |. .| C |* . . . . . . *| C C if UPLO = 'L'. C C If P >= N, then the matrix CU is trapezoidal and U'AU is full. C If P = 0, but N > 0, the array A is unchanged on exit. C C REFERENCES C C [1] Van Dooren, P. and Verhaegen, M.H.G. C On the use of unitary state-space transformations. C In : Contemporary Mathematics on Linear Algebra and its Role C in Systems Theory, 47, AMS, Providence, 1985. C C NUMERICAL ASPECTS C C The algorithm requires O((N + P) x N**2) operations and is C backward stable (see [1]). C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TB01BD by M. Vanbegin, and C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. C C REVISIONS C C February 1997, April 2021. C C KEYWORDS C C Controllability, observer Hessenberg form, orthogonal C transformation, unitary transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDC, LDU, N, P CHARACTER JOBU, UPLO C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), C(LDC,*), DWORK(*), U(LDU,*) C .. Local Scalars .. LOGICAL LJOBA, LJOBI, LUPLO INTEGER II, J, N1, NJ, P1, PAR1, PAR2, PAR3, PAR4, PAR5, $ PAR6 DOUBLE PRECISION DZ C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLARFG, DLASET, DLATZM, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C INFO = 0 LUPLO = LSAME( UPLO, 'U' ) LJOBI = LSAME( JOBU, 'I' ) LJOBA = LJOBI.OR.LSAME( JOBU, 'U' ) C C Test the input scalar arguments. C IF( .NOT.LJOBA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( P.LT.0 .OR. P.GT.N ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -8 ELSE IF( .NOT.LJOBA .AND. LDU.LT.1 .OR. $ LJOBA .AND. LDU.LT.MAX( 1, N ) ) THEN INFO = -10 END IF C IF ( INFO.NE.0 ) THEN C C Error return C CALL XERBLA( 'TB01ND', -INFO ) RETURN END IF C IF ( LJOBI ) THEN C C Initialize U to the identity matrix. C CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. P.EQ.0 ) $ RETURN C P1 = P + 1 N1 = N - 1 C C Perform transformations involving both C and A. C DO 20 J = 1, MIN( P, N1 ) NJ = N - J IF ( LUPLO ) THEN PAR1 = P - J + 1 PAR2 = NJ + 1 PAR3 = 1 PAR4 = P - J PAR5 = NJ ELSE PAR1 = J PAR2 = J PAR3 = J + 1 PAR4 = P PAR5 = N END IF C CALL DLARFG( NJ+1, C(PAR1,PAR2), C(PAR1,PAR3), LDC, DZ ) C C Update A. C CALL DLATZM( 'Left', NJ+1, N, C(PAR1,PAR3), LDC, DZ, A(PAR2,1), $ A(PAR3,1), LDA, DWORK ) CALL DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ, $ A(1,PAR2), A(1,PAR3), LDA, DWORK ) C IF ( LJOBA ) THEN C C Update U. C CALL DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ, $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) END IF C IF ( J.NE.P ) THEN C C Update C. C CALL DLATZM( 'Right', PAR4-PAR3+1, NJ+1, C(PAR1,PAR3), LDC, $ DZ, C(PAR3,PAR2), C(PAR3,PAR3), LDC, DWORK ) END IF C DO 10 II = PAR3, PAR5 C(PAR1,II) = ZERO 10 CONTINUE C 20 CONTINUE C DO 40 J = P1, N1 C C Perform next transformations only involving A. C NJ = N - J IF ( LUPLO ) THEN PAR1 = N + P1 - J PAR2 = NJ + 1 PAR3 = 1 PAR4 = NJ PAR5 = 1 PAR6 = N + P - J ELSE PAR1 = J - P PAR2 = J PAR3 = J + 1 PAR4 = N PAR5 = J - P + 1 PAR6 = N END IF C IF ( NJ.GT.0 ) THEN C CALL DLARFG( NJ+1, A(PAR1,PAR2), A(PAR1,PAR3), LDA, DZ ) C C Update A. C CALL DLATZM( 'Left', NJ+1, N, A(PAR1,PAR3), LDA, DZ, $ A(PAR2,1), A(PAR3,1), LDA, DWORK ) CALL DLATZM( 'Right', PAR6-PAR5+1, NJ+1, A(PAR1,PAR3), LDA, $ DZ, A(PAR5,PAR2), A(PAR5,PAR3), LDA, DWORK ) C IF ( LJOBA ) THEN C C Update U. C CALL DLATZM( 'Right', N, NJ+1, A(PAR1,PAR3), LDA, DZ, $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) END IF C DO 30 II = PAR3, PAR4 A(PAR1,II) = ZERO 30 CONTINUE C END IF C 40 CONTINUE C RETURN C *** Last line of TB01ND *** END control-4.1.2/src/slicot/src/PaxHeaders/AB07MD.f0000644000000000000000000000013215012430707016147 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB07MD.f0000644000175000017500000001375215012430707017353 0ustar00lilgelilge00000000000000 SUBROUTINE AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ INFO ) C C PURPOSE C C To find the dual of a given state-space representation. C C ARGUMENTS C C Mode Parameters 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 state-space representation. 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/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the original state dynamics matrix A. C On exit, the leading N-by-N part of this array contains C the dual state dynamics matrix A'. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,MAX(M,P)) C On entry, the leading N-by-M part of this array must C contain the original input/state matrix B. C On exit, the leading N-by-P part of this array contains C the dual input/state matrix C'. 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 original state/output matrix C. C On exit, the leading M-by-N part of this array contains C the dual state/output matrix B'. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,M,P) if N > 0. C LDC >= 1 if N = 0. C C D (input/output) DOUBLE PRECISION array, dimension C (LDD,MAX(M,P)) C On entry, if JOBD = 'D', the leading P-by-M part of this C array must contain the original direct transmission C matrix D. C On exit, if JOBD = 'D', the leading M-by-P part of this C array contains the dual 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,M,P) if JOBD = 'D'. C LDD >= 1 if JOBD = 'Z'. 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 If the given state-space representation is the M-input/P-output C (A,B,C,D), its dual is simply the P-input/M-output (A',C',B',D'). C C REFERENCES C C None C C NUMERICAL ASPECTS C C None C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine AB07AD by T.W.C.Williams, Kingston C Polytechnic, United Kingdom, March 1982. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. C C KEYWORDS C C Dual system, state-space model, state-space representation. C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER JOBD INTEGER INFO, LDA, LDB, LDC, LDD, M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*) C .. Local Scalars .. LOGICAL LJOBD INTEGER J, MINMP, MPLIM C .. External functions .. LOGICAL LSAME EXTERNAL LSAME C .. External subroutines .. EXTERNAL DCOPY, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C INFO = 0 LJOBD = LSAME( JOBD, 'D' ) MPLIM = MAX( M, P ) MINMP = MIN( M, P ) C C Test the input scalar arguments. C IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) 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( ( N.GT.0 .AND. LDC.LT.MAX( 1, MPLIM ) ) .OR. $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN INFO = -10 ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, MPLIM ) ) .OR. $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN INFO = -12 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB07MD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, MINMP ).EQ.0 ) $ RETURN C IF ( N.GT.0 ) THEN C C Transpose A, if non-scalar. C DO 10 J = 1, N - 1 CALL DSWAP( N-J, A(J+1,J), 1, A(J,J+1), LDA ) 10 CONTINUE C C Replace B by C' and C by B'. C DO 20 J = 1, MPLIM IF ( J.LE.MINMP ) THEN CALL DSWAP( N, B(1,J), 1, C(J,1), LDC ) ELSE IF ( J.GT.P ) THEN CALL DCOPY( N, B(1,J), 1, C(J,1), LDC ) ELSE CALL DCOPY( N, C(J,1), LDC, B(1,J), 1 ) END IF 20 CONTINUE C END IF C IF ( LJOBD .AND. MINMP.GT.0 ) THEN C C Transpose D, if non-scalar. C DO 30 J = 1, MPLIM IF ( J.LT.MINMP ) THEN CALL DSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) ELSE IF ( J.GT.P ) THEN CALL DCOPY( P, D(1,J), 1, D(J,1), LDD ) ELSE IF ( J.GT.M ) THEN CALL DCOPY( M, D(J,1), LDD, D(1,J), 1 ) END IF 30 CONTINUE C END IF C RETURN C *** Last line of AB07MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02OD.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02OD.f0000644000175000017500000001012115012430707017346 0ustar00lilgelilge00000000000000 INTEGER FUNCTION MA02OD( SKEW, M, A, LDA, DE, LDDE ) C C PURPOSE C C To compute the number of zero rows (and zero columns) of a real C (skew-)Hamiltonian matrix, C C ( A D ) C H = ( ). C ( E +/-A' ) C C FUNCTION VALUE C C MA02OD INTEGER C The number of zero rows. C C ARGUMENTS C C Mode Parameters C C SKEW CHARACTER*1 C Specifies whether the matrix is Hamiltonian or skew- C Hamiltonian as follows: C = 'H': The matrix is Hamiltonian; C = 'S': The matrix is skew-Hamiltonian. C C Input/Output Parameters C C M (input) INTEGER C The order of the matrices A, D, and E. M >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,M) C The leading M-by-M 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 DE (input) DOUBLE PRECISION array, dimension (LDDE,M+1) C The leading M-by-M lower triangular part of this array C must contain the lower triangular part of the (skew-) C symmetric matrix E, and the M-by-M upper triangular C part of the submatrix in the columns 2 to M+1 of this C array must contain the upper triangular part of the C (skew-)symmetric matrix D. If S is skew-Hamiltonian, the C parts containing the diagonal and the first superdiagonal C of this array, which should be zero, are not referenced. C C LDDE INTEGER C The leading dimension of the array DE. LDDE >= MAX(1,M). C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Sep. 2016. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, skew-Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER SKEW INTEGER LDA, LDDE, M C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), DE( LDDE, * ) C .. C .. Local Scalars .. LOGICAL ISHAM INTEGER I, J, NZ C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked. C NZ = 0 C IF( M.GT.0 ) THEN ISHAM = LSAME( SKEW, 'H' ) C C Scan columns 1 .. M. C I = 0 C WHILE ( I.LE.M ) DO 10 CONTINUE I = I + 1 IF( I.LE.M ) THEN DO 20 J = 1, M IF( A( J, I ).NE.ZERO ) $ GO TO 10 20 CONTINUE DO 30 J = 1, I - 1 IF( DE( I, J ).NE.ZERO ) $ GO TO 10 30 CONTINUE IF( ISHAM ) THEN IF( DE( I, I ).NE.ZERO ) $ GO TO 10 END IF DO 40 J = I + 1, M IF( DE( J, I ).NE.ZERO ) $ GO TO 10 40 CONTINUE C NZ = NZ + 1 GO TO 10 C C END WHILE 10 END IF C C Scan columns M+1 .. 2*M. C I = 0 C WHILE ( I.LE.M ) DO 50 CONTINUE I = I + 1 IF( I.LE.M ) THEN DO 60 J = 1, M IF( A( I, J ).NE.ZERO ) $ GO TO 50 60 CONTINUE DO 70 J = 1, I - 1 IF( DE( J, I+1 ).NE.ZERO ) $ GO TO 50 70 CONTINUE IF( ISHAM ) THEN IF( DE( I, I+1 ).NE.ZERO ) $ GO TO 50 END IF DO 80 J = I + 1, M IF( DE( I, J+1 ).NE.ZERO ) $ GO TO 50 80 CONTINUE C NZ = NZ + 1 GO TO 50 C END IF C END WHILE 50 END IF C MA02OD = NZ RETURN C C *** Last line of MA02OD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB04BD.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB04BD.f0000644000175000017500000005165415012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE TB04BD( JOBD, ORDER, EQUIL, N, M, P, MD, A, LDA, B, $ LDB, C, LDC, D, LDD, IGN, LDIGN, IGD, LDIGD, $ GN, GD, TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the transfer function matrix G of a state-space C representation (A,B,C,D) of a linear time-invariant multivariable C system, using the pole-zeros method. Each element of the transfer C function matrix is returned in a cancelled, minimal form, with C numerator and denominator polynomials stored either in increasing C or decreasing order of the powers of the indeterminate. C C ARGUMENTS C C Mode Parameters 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 to be a zero matrix. C C ORDER CHARACTER*1 C Specifies the order in which the polynomial coefficients C are stored, as follows: C = 'I': Increasing order of powers of the indeterminate; C = 'D': Decreasing order of powers of the indeterminate. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C Input/Output Parameters C C N (input) INTEGER C The order of the system (A,B,C,D). N >= 0. C C M (input) INTEGER C The number of the system inputs. M >= 0. C C P (input) INTEGER C The number of the system outputs. P >= 0. C C MD (input) INTEGER C The maximum degree of the polynomials in G, plus 1. An C upper bound for MD is N+1. MD >= 1. 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 original state dynamics matrix A. C On exit, if EQUIL = 'S', the leading N-by-N part of this C array contains the balanced matrix inv(S)*A*S, as returned C by SLICOT Library routine TB01ID. C If EQUIL = 'N', this array is unchanged on exit. 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 matrix B. C On exit, the contents of B are destroyed: all elements but C those in the first row are set to zero. 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 output matrix C. C On exit, if EQUIL = 'S', the leading P-by-N part of this C array contains the balanced matrix C*S, as returned by C SLICOT Library routine TB01ID. C If EQUIL = 'N', this array is unchanged on exit. 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 If JOBD = 'D', the leading P-by-M part of this array must C contain the matrix D. C If JOBD = 'Z', the array D is not referenced. 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 IGN (output) INTEGER array, dimension (LDIGN,M) C The leading P-by-M part of this array contains the degrees C of the numerator polynomials in the transfer function C matrix G. Specifically, the (i,j) element of IGN contains C the degree of the numerator polynomial of the transfer C function G(i,j) from the j-th input to the i-th output. C C LDIGN INTEGER C The leading dimension of array IGN. LDIGN >= max(1,P). C C IGD (output) INTEGER array, dimension (LDIGD,M) C The leading P-by-M part of this array contains the degrees C of the denominator polynomials in the transfer function C matrix G. Specifically, the (i,j) element of IGD contains C the degree of the denominator polynomial of the transfer C function G(i,j). C C LDIGD INTEGER C The leading dimension of array IGD. LDIGD >= max(1,P). C C GN (output) DOUBLE PRECISION array, dimension (P*M*MD) C This array contains the coefficients of the numerator C polynomials, Num(i,j), of the transfer function matrix G. C The polynomials are stored in a column-wise order, i.e., C Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2), C ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M); C MD memory locations are reserved for each polynomial, C hence, the (i,j) polynomial is stored starting from the C location ((j-1)*P+i-1)*MD+1. The coefficients appear in C increasing or decreasing order of the powers of the C indeterminate, according to ORDER. C C GD (output) DOUBLE PRECISION array, dimension (P*M*MD) C This array contains the coefficients of the denominator C polynomials, Den(i,j), of the transfer function matrix G. C The polynomials are stored in the same way as the C numerator polynomials. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in determining the C controllability of a single-input system (A,b) or (A',c'), C where b and c' are columns in B and C' (C transposed). If C the user sets TOL > 0, then the given value of TOL is used C as an absolute tolerance; elements with absolute value C less than TOL are considered neglijible. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used C instead, where EPS is the machine precision (see LAPACK C Library routine DLAMCH), and bc denotes the currently used C column in B or C' (see METHOD). 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) returns the optimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1, N*(N+P) + C MAX( N + MAX( N,P ), N*(2*N+5))) C If N >= P, N >= 1, the formula above can be written as C LDWORK >= N*(3*N + P + 5). 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: the QR algorithm failed to converge when trying to C compute the zeros of a transfer function; C = 2: the QR algorithm failed to converge when trying to C compute the poles of a transfer function. C The errors INFO = 1 or 2 are unlikely to appear. C C METHOD C C The routine implements the pole-zero method proposed in [1]. C This method is based on an algorithm for computing the transfer C function of a single-input single-output (SISO) system. C Let (A,b,c,d) be a SISO system. Its transfer function is computed C as follows: C C 1) Find a controllable realization (Ac,bc,cc) of (A,b,c). C 2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc). C 3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)). C 4) Compute the zeros of (Ao,bo,co,d). C 5) Compute the gain of (Ao,bo,co,d). C C This algorithm can be implemented using only orthogonal C transformations [1]. However, for better efficiency, the C implementation in TB04BD uses one elementary transformation C in Step 4 and r elementary transformations in Step 5 (to reduce C an upper Hessenberg matrix to upper triangular form). These C special elementary transformations are numerically stable C in practice. C C In the multi-input multi-output (MIMO) case, the algorithm C computes each element (i,j) of the transfer function matrix G, C for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1 C is performed once for each value of j (each column of B). The C matrices Ac and Ao result in Hessenberg form. C C REFERENCES C C [1] Varga, A. and Sima, V. C Numerically Stable Algorithm for Transfer Function Matrix C Evaluation. C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. C C NUMERICAL ASPECTS C C The algorithm is numerically stable in practice and requires about C 20*N**3 floating point operations at most, but usually much less. C C FURTHER COMMENTS C C For maximum efficiency of index calculations, GN and GD are C implemented as one-dimensional arrays. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, May 2002. C Partly based on the BIMASC Library routine TSMT1 by A. Varga. C C REVISIONS C C - C C KEYWORDS C C Eigenvalue, state-space representation, transfer function, zeros. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, C100 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL, JOBD, ORDER DOUBLE PRECISION TOL INTEGER INFO, LDA, LDB, LDC, LDD, LDIGD, LDIGN, LDWORK, $ M, MD, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), GD(*), GN(*) INTEGER IGD(LDIGD,*), IGN(LDIGN,*), IWORK(*) C .. Local Scalars .. DOUBLE PRECISION ANORM, DIJ, EPSN, MAXRED, TOLDEF, X INTEGER I, IA, IAC, IAS, IB, IC, ICC, IERR, IIP, IM, $ IP, IPM1, IRP, ITAU, ITAU1, IZ, J, JJ, JWORK, $ JWORK1, K, L, NCONT, WRKOPT LOGICAL ASCEND, DIJNZ, FNDEIG, WITHD C .. Local Arrays .. DOUBLE PRECISION Z(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DHSEQR, DLACPY, MA02AD, MC01PD, $ MC01PY, TB01ID, TB01ZD, TB04BX, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C C Test the input scalar parameters. C INFO = 0 WITHD = LSAME( JOBD, 'D' ) ASCEND = LSAME( ORDER, 'I' ) IF( .NOT.WITHD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN INFO = -1 ELSE IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN INFO = -2 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( MD.LT.1 ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN INFO = -15 ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN INFO = -17 ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN INFO = -19 ELSE IF( LDWORK.LT.MAX( 1, N*( N + P ) + $ MAX( N + MAX( N, P ), N*( 2*N + 5 ) ) ) $ ) THEN INFO = -25 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB04BD', -INFO ) RETURN END IF C C Initialize GN and GD to zero. C Z(1) = ZERO CALL DCOPY( P*M*MD, Z, 0, GN, 1 ) CALL DCOPY( P*M*MD, Z, 0, GD, 1 ) C C Quick return if possible. C IF( MIN( N, P, M ).EQ.0 ) THEN IF( MIN( P, M ).GT.0 ) THEN K = 1 C DO 20 J = 1, M C DO 10 I = 1, P IGN(I,J) = 0 IGD(I,J) = 0 IF ( WITHD ) $ GN(K) = D(I,J) GD(K) = ONE K = K + MD 10 CONTINUE C 20 CONTINUE C END IF DWORK(1) = ONE RETURN END IF C C Prepare the computation of the default tolerance. C TOLDEF = TOL IF( TOLDEF.LE.ZERO ) THEN EPSN = DBLE( N )*DLAMCH( 'Epsilon' ) ANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) END IF C C Initializations. C IA = 1 IC = IA + N*N ITAU = IC + P*N JWORK = ITAU + N IAC = ITAU C K = 1 DIJ = ZERO 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 IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(S)*A*S, B <- inv(S)*B and C <- C*S, where S is a C diagonal scaling matrix. C Workspace: need N. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, IERR ) END IF C C Compute the transfer function matrix of the system (A,B,C,D). C DO 80 J = 1, M C C Save A and C. C Workspace: need W1 = N*(N+P). C CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) CALL DLACPY( 'Full', P, N, C, LDC, DWORK(IC), P ) C C Remove the uncontrollable part of the system (A,B(J),C). C Workspace: need W1+N+MAX(N,P); C prefer larger. C CALL TB01ZD( 'No Z', N, P, DWORK(IA), N, B(1,J), DWORK(IC), P, $ NCONT, Z, 1, DWORK(ITAU), TOL, DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) IF ( J.EQ.1 ) $ WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 C IB = IAC + NCONT*NCONT ICC = IB + NCONT ITAU1 = ICC + NCONT IRP = ITAU1 IIP = IRP + NCONT IAS = IIP + NCONT JWORK1 = IAS + NCONT*NCONT C DO 70 I = 1, P IF ( WITHD ) $ DIJ = D(I,J) IF ( NCONT.GT.0 ) THEN C C Form the matrices of the state-space representation of C the dual system for the controllable part. C Workspace: need W2 = W1+N*(N+2). C CALL MA02AD( 'Full', NCONT, NCONT, DWORK(IA), N, $ DWORK(IAC), NCONT ) CALL DCOPY( NCONT, B(1,J), 1, DWORK(IB), 1 ) CALL DCOPY( NCONT, DWORK(IC+I-1), P, DWORK(ICC), 1 ) C C Remove the unobservable part of the system (A,B(J),C(I)). C Workspace: need W2+2*N; C prefer larger. C CALL TB01ZD( 'No Z', NCONT, 1, DWORK(IAC), NCONT, $ DWORK(ICC), DWORK(IB), 1, IP, Z, 1, $ DWORK(ITAU1), TOL, DWORK(IIP), LDWORK-IIP+1, $ IERR ) IF ( I.EQ.1 ) $ WRKOPT = MAX( WRKOPT, INT( DWORK(IIP) ) + IIP - 1 ) C IF ( IP.GT.0 ) THEN C C Save the state matrix of the minimal part. C Workspace: need W3 = W2+N*(N+2). C CALL DLACPY( 'Full', IP, IP, DWORK(IAC), NCONT, $ DWORK(IAS), IP ) C C Compute the poles of the transfer function. C Workspace: need W3+N; C prefer larger. C CALL DHSEQR( 'Eigenvalues', 'No vectors', IP, 1, IP, $ DWORK(IAC), NCONT, DWORK(IRP), $ DWORK(IIP), Z, 1, DWORK(JWORK1), $ LDWORK-JWORK1+1, IERR ) IF ( IERR.NE.0 ) THEN INFO = 2 RETURN END IF WRKOPT = MAX( WRKOPT, $ INT( DWORK(JWORK1) ) + JWORK1 - 1 ) C C Compute the zeros of the transfer function. C IPM1 = IP - 1 DIJNZ = WITHD .AND. DIJ.NE.ZERO FNDEIG = DIJNZ .OR. IPM1.GT.0 IF ( .NOT.FNDEIG ) THEN IZ = 0 ELSE IF ( DIJNZ ) THEN C C Add the contribution due to D(i,j). C Note that the matrix whose eigenvalues have to C be computed remains in an upper Hessenberg form. C IZ = IP CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS), IP, $ DWORK(IAC), NCONT ) CALL DAXPY( IZ, -DWORK(ICC)/DIJ, DWORK(IB), 1, $ DWORK(IAC), NCONT ) ELSE IF( TOL.LE.ZERO ) $ TOLDEF = EPSN*MAX( ANORM, $ DLANGE( 'Frobenius', IP, 1, $ DWORK(IB), 1, DWORK ) $ ) C DO 30 IM = 1, IPM1 IF ( ABS( DWORK(IB+IM-1) ).GT.TOLDEF ) GO TO 40 30 CONTINUE C IZ = 0 GO TO 50 C 40 CONTINUE C C Restore (part of) the saved state matrix. C IZ = IP - IM CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS+IM*(IP+1)), $ IP, DWORK(IAC), NCONT ) C C Apply the output injection. C CALL DAXPY( IZ, -DWORK(IAS+IM*(IP+1)-IP)/ $ DWORK(IB+IM-1), DWORK(IB+IM), 1, $ DWORK(IAC), NCONT ) END IF C IF ( FNDEIG ) THEN C C Find the zeros. C Workspace: need W3+N; C prefer larger. C CALL DHSEQR( 'Eigenvalues', 'No vectors', IZ, 1, $ IZ, DWORK(IAC), NCONT, GN(K), GD(K), $ Z, 1, DWORK(JWORK1), LDWORK-JWORK1+1, $ IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 RETURN END IF END IF C C Compute the gain. C 50 CONTINUE IF ( DIJNZ ) THEN X = DIJ ELSE CALL TB04BX( IP, IZ, DWORK(IAS), IP, DWORK(ICC), $ DWORK(IB), DIJ, DWORK(IRP), $ DWORK(IIP), GN(K), GD(K), X, IWORK ) END IF C C Form the numerator coefficients in increasing or C decreasing powers of the indeterminate. C IAS is used here as pointer to the workspace. C IF ( ASCEND ) THEN CALL MC01PD( IZ, GN(K), GD(K), DWORK(IB), $ DWORK(IAS), IERR ) ELSE CALL MC01PY( IZ, GN(K), GD(K), DWORK(IB), $ DWORK(IAS), IERR ) END IF JJ = K C DO 60 L = IB, IB + IZ GN(JJ) = DWORK(L)*X JJ = JJ + 1 60 CONTINUE C C Form the denominator coefficients. C IF ( ASCEND ) THEN CALL MC01PD( IP, DWORK(IRP), DWORK(IIP), GD(K), $ DWORK(IAS), IERR ) ELSE CALL MC01PY( IP, DWORK(IRP), DWORK(IIP), GD(K), $ DWORK(IAS), IERR ) END IF IGN(I,J) = IZ IGD(I,J) = IP ELSE C C Null element. C IGN(I,J) = 0 IGD(I,J) = 0 GN(K) = DIJ GD(K) = ONE END IF C ELSE C C Null element. C IGN(I,J) = 0 IGD(I,J) = 0 GN(K) = DIJ GD(K) = ONE END IF C K = K + MD 70 CONTINUE C 80 CONTINUE C RETURN C *** Last line of TB04BD *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BP.f0000644000000000000000000000013015012430707016161 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/NF01BP.f0000644000175000017500000005501215012430707017362 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BP( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To determine a value for the Levenberg-Marquardt parameter PAR C such that if x solves the system C C J*x = b , sqrt(PAR)*D*x = 0 , C C in the least squares sense, where J is an m-by-n matrix, D is an C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, C then either PAR is zero and C C ( DXNORM - DELTA ) .LE. 0.1*DELTA , C C or PAR is positive and C C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . C C The matrix J is the current Jacobian matrix of a nonlinear least C squares problem, provided in a compressed form by SLICOT Library C routine NF01BD. It is assumed that a block QR factorization, with C column pivoting, of J is available, that is, J*P = Q*R, where P is C a permutation matrix, Q has orthogonal columns, and R is an upper C triangular matrix with diagonal elements of nonincreasing C magnitude for each block, as returned by SLICOT Library C routine NF01BS. The routine NF01BP needs the upper triangle of R C in compressed form, the permutation matrix P, and the first C n components of Q'*b (' denotes the transpose). On output, C NF01BP also provides a compressed representation of an upper C triangular matrix S, such that C C P'*(J'*J + PAR*D*D)*P = S'*S . C C Matrix S is used in the solution process. The matrix R has the C following structure C C / R_1 0 .. 0 | L_1 \ C | 0 R_2 .. 0 | L_2 | C | : : .. : | : | , C | 0 0 .. R_l | L_l | C \ 0 0 .. 0 | R_l+1 / C C where the submatrices R_k, k = 1:l, have the same order BSN, C and R_k, k = 1:l+1, are square and upper triangular. This matrix C is stored in the compressed form C C / R_1 | L_1 \ C | R_2 | L_2 | C Rc = | : | : | , C | R_l | L_l | C \ X | R_l+1 / C C where the submatrix X is irrelevant. The matrix S has the same C structure as R, and its diagonal blocks are denoted by S_k, C k = 1:l+1. C C If l <= 1, then the full upper triangle of the matrix R is stored. C C ARGUMENTS C C Mode Parameters C C COND CHARACTER*1 C Specifies whether the condition of the diagonal blocks R_k C and S_k of the matrices R and S should be estimated, C as follows: C = 'E' : use incremental condition estimation for each C diagonal block of R_k and S_k to find its C numerical rank; C = 'N' : do not use condition estimation, but check the C diagonal entries of R_k and S_k for zero values; C = 'U' : use the ranks already stored in RANKS (for R). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix R. N = BN*BSN + ST >= 0. C (See parameter description below.) C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of the C matrix R, as follows: C IPAR(1) must contain ST, the number of columns of the C submatrices L_k and the order of R_l+1. ST >= 0. C IPAR(2) must contain BN, the number of blocks, l, in the C block diagonal part of R. BN >= 0. C IPAR(3) must contain BSM, the number of rows of the blocks C R_k, k = 1:l. BSM >= 0. C IPAR(4) must contain BSN, the number of columns of the C blocks R_k, k = 1:l. BSN >= 0. C BSM is not used by this routine, but assumed equal to BSN. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 4. C C R (input/output) DOUBLE PRECISION array, dimension (LDR, NC) C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. C On entry, the leading N-by-NC part of this array must C contain the (compressed) representation (Rc) of the upper C triangular matrix R. If BN > 1, the submatrix X in Rc is C not referenced. The zero strict lower triangles of R_k, C k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then C the full upper triangle of R must be stored. C On exit, the full upper triangles of R_k, k = 1:l+1, and C L_k, k = 1:l, are unaltered, and the strict lower C triangles of R_k, k = 1:l+1, contain the corresponding C strict upper triangles (transposed) of the upper C triangular matrix S. C If BN <= 1 or BSN = 0, then the transpose of the strict C upper triangle of S is stored in the strict lower triangle C of R. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C IPVT (input) INTEGER array, dimension (N) C This array must define the permutation matrix P such that C J*P = Q*R. Column j of P is column IPVT(j) of the identity C matrix. C C DIAG (input) DOUBLE PRECISION array, dimension (N) C This array must contain the diagonal elements of the C matrix D. DIAG(I) <> 0, I = 1,...,N. C C QTB (input) DOUBLE PRECISION array, dimension (N) C This array must contain the first n elements of the C vector Q'*b. C C DELTA (input) DOUBLE PRECISION C An upper bound on the Euclidean norm of D*x. DELTA > 0. C C PAR (input/output) DOUBLE PRECISION C On entry, PAR must contain an initial estimate of the C Levenberg-Marquardt parameter. PAR >= 0. C On exit, it contains the final estimate of this parameter. C C RANKS (input or output) INTEGER array, dimension (r), where C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; C r = BN, if ST = 0 and BSN > 0; C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); C r = 0, if ST = 0 and BSN = 0. C On entry, if COND = 'U' and N > 0, this array must contain C the numerical ranks of the submatrices R_k, k = 1:l(+1). C On exit, if N > 0, this array contains the numerical ranks C of the submatrices S_k, k = 1:l(+1). C C X (output) DOUBLE PRECISION array, dimension (N) C This array contains the least squares solution of the C system J*x = b, sqrt(PAR)*D*x = 0. C C RX (output) DOUBLE PRECISION array, dimension (N) C This array contains the matrix-vector product -R*P'*x. C C Tolerances C C TOL DOUBLE PRECISION C If COND = 'E', the tolerance to be used for finding the C ranks of the submatrices R_k and S_k. If the user sets C TOL > 0, then the given value of TOL is used as a lower C bound for the reciprocal condition number; a (sub)matrix C whose estimated condition number is less than 1/TOL is C considered to be of full rank. If the user sets TOL <= 0, C then an implicitly computed, default tolerance, defined by C TOLDEF = N*EPS, is used instead, where EPS is the machine C precision (see LAPACK Library routine DLAMCH). C This parameter is not relevant if COND = 'U' or 'N'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, the first N elements of this array contain the C diagonal elements of the upper triangular matrix S. C If BN > 1 and BSN > 0, the elements N+1 : N+ST*(N-ST) C contain the submatrix (S(1:N-ST,N-ST+1:N))' of the C matrix S. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 2*N, if BN <= 1 or BSN = 0 and C COND <> 'E'; C LDWORK >= 4*N, if BN <= 1 or BSN = 0 and C COND = 'E'; C LDWORK >= ST*(N-ST) + 2*N, if BN > 1 and BSN > 0 and C COND <> 'E'; C LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST), C if BN > 1 and BSN > 0 and C COND = 'E'. 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 algorithm computes the Gauss-Newton direction. An approximate C basic least squares solution is found if the Jacobian is rank C deficient. The computations exploit the special structure and C storage scheme of the matrix R. If one or more of the submatrices C R_k or S_k, k = 1:l+1, is singular, then the computed result is C not the basic least squares solution for the whole problem, but a C concatenation of (least squares) solutions of the individual C subproblems involving R_k or S_k, k = 1:l+1 (with adapted right C hand sides). C C If the Gauss-Newton direction is not acceptable, then an iterative C algorithm obtains improved lower and upper bounds for the C Levenberg-Marquardt parameter PAR. Only a few iterations are C generally needed for convergence of the algorithm. If, however, C the limit of ITMAX = 10 iterations is reached, then the output PAR C will contain the best value obtained so far. If the Gauss-Newton C step is acceptable, it is stored in x, and PAR is set to zero, C hence S = R. C C REFERENCES C C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. C User's Guide for MINPACK-1. C Applied Math. Division, Argonne National Laboratory, Argonne, C Illinois, Report ANL-80-74, 1980. C C NUMERICAL ASPECTS C C The algorithm requires 0(N*(BSN+ST)) operations and is backward C stable, if R is nonsingular. C C FURTHER COMMENTS C C This routine is a structure-exploiting, LAPACK-based modification C of LMPAR from the MINPACK package [1], and with optional condition C estimation. The option COND = 'U' is useful when dealing with C several right-hand side vectors, but RANKS array should be reset. C If COND = 'E', but the matrix S is guaranteed to be nonsingular C and well conditioned relative to TOL, i.e., rank(R) = N, and C min(DIAG) > 0, then its condition is not estimated. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C V. Sima, Feb. 2004. C C KEYWORDS C C Linear system of equations, matrix operations, plane rotations. C C ****************************************************************** C C .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 10 ) DOUBLE PRECISION P1, P001, ZERO, ONE PARAMETER ( P1 = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0, $ ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER COND INTEGER INFO, LDR, LDWORK, LIPAR, N DOUBLE PRECISION DELTA, PAR, TOL C .. Array Arguments .. INTEGER IPAR(*), IPVT(*), RANKS(*) DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) C .. Local Scalars .. INTEGER BN, BSM, BSN, I, IBSN, ITER, J, JW, K, L, LDS, $ N2, NTHS, RANK, ST DOUBLE PRECISION DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL, $ PARU, SUM, TEMP, TOLDEF LOGICAL BADRK, ECOND, NCOND, SING, UCOND CHARACTER CONDL C .. External Functions .. DOUBLE PRECISION DDOT, DLAMCH, DNRM2 LOGICAL LSAME EXTERNAL DDOT, DLAMCH, DNRM2, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DTRMV, MD03BY, NF01BQ, NF01BR, $ XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT C .. C .. Executable Statements .. C C Check the scalar input parameters. C ECOND = LSAME( COND, 'E' ) NCOND = LSAME( COND, 'N' ) UCOND = LSAME( COND, 'U' ) INFO = 0 N2 = 2*N IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN INFO = -1 ELSEIF( N.LT.0 ) THEN INFO = -2 ELSEIF( LIPAR.LT.4 ) THEN INFO = -4 ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN INFO = -6 ELSEIF( DELTA.LE.ZERO ) THEN INFO = -10 ELSEIF( PAR.LT.ZERO ) THEN INFO = -11 ELSE ST = IPAR(1) BN = IPAR(2) BSM = IPAR(3) BSN = IPAR(4) NTHS = BN*BSN IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN INFO = -3 ELSEIF ( N.NE.NTHS + ST ) THEN INFO = -2 ELSE IF ( N.GT.0 ) $ DMINO = DIAG(1) SING = .FALSE. C DO 10 J = 1, N IF ( DIAG(J).LT.DMINO ) $ DMINO = DIAG(J) SING = SING .OR. DIAG(J).EQ.ZERO 10 CONTINUE C IF ( SING ) THEN INFO = -8 ELSEIF ( UCOND ) THEN BADRK = .FALSE. IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN IF ( N.GT.0 ) $ BADRK = RANKS(1).LT.0 .OR. RANKS(1).GT.N ELSE RANK = 0 C DO 20 K = 1, BN BADRK = BADRK .OR. RANKS(K).LT.0 $ .OR. RANKS(K).GT.BSN RANK = RANK + RANKS(K) 20 CONTINUE C IF ( ST.GT.0 ) THEN BADRK = BADRK .OR. RANKS(BN+1).LT.0 .OR. $ RANKS(BN+1).GT.ST RANK = RANK + RANKS(BN+1) END IF END IF IF ( BADRK ) $ INFO = -12 ELSE JW = N2 IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN IF ( ECOND ) $ JW = 4*N ELSE JW = ST*NTHS + JW IF ( ECOND ) $ JW = 2*MAX( BSN, ST ) + JW END IF IF ( LDWORK.LT.JW ) $ INFO = -17 ENDIF ENDIF ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01BP', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( N.EQ.0 ) THEN PAR = ZERO RETURN END IF C IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN C C Special case: R is just an upper triangular matrix. C Workspace: 4*N, if COND = 'E'; C 2*N, if COND <> 'E'. C CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, $ RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO ) RETURN END IF C C General case: l > 1 and BSN > 0. C DWARF is the smallest positive magnitude. C DWARF = DLAMCH( 'Underflow' ) C C Compute and store in x the Gauss-Newton direction. If the C Jacobian is rank-deficient, obtain a least squares solution. C The array RX is used as workspace. C Workspace: 2*MAX(BSN,ST), if COND = 'E'; C 0, if COND <> 'E'. C CALL DCOPY( N, QTB, 1, RX, 1 ) CALL NF01BR( COND, 'Upper', 'No transpose', N, IPAR, LIPAR, R, $ LDR, DWORK, DWORK, 1, RX, RANKS, TOL, DWORK, LDWORK, $ INFO ) C DO 30 J = 1, N L = IPVT(J) X(L) = RX(J) 30 CONTINUE C C Initialize the iteration counter. C Evaluate the function at the origin, and test C for acceptance of the Gauss-Newton direction. C ITER = 0 C DO 40 J = 1, N DWORK(J) = DIAG(J)*X(J) 40 CONTINUE C DXNORM = DNRM2( N, DWORK, 1 ) FP = DXNORM - DELTA IF ( FP.GT.P1*DELTA ) THEN C C Set an appropriate option for estimating the condition of C the matrix S. C LDS = MAX( 1, ST ) JW = N2 + ST*NTHS IF ( UCOND ) THEN IF ( LDWORK.GE.JW + 2*MAX( BSN, ST ) ) THEN CONDL = 'E' TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) ELSE CONDL = 'N' TOLDEF = TOL END IF ELSE RANK = 0 C DO 50 K = 1, BN RANK = RANK + RANKS(K) 50 CONTINUE C IF ( ST.GT.0 ) $ RANK = RANK + RANKS(BN+1) CONDL = COND TOLDEF = TOL END IF C C If the Jacobian is not rank deficient, the Newton C step provides a lower bound, PARL, for the zero of C the function. Otherwise set this bound to zero. C IF ( RANK.EQ.N ) THEN C DO 60 J = 1, N L = IPVT(J) RX(J) = DIAG(L)*( DWORK(L)/DXNORM ) 60 CONTINUE C CALL NF01BR( 'Use ranks', 'Upper', 'Transpose', N, IPAR, $ LIPAR, R, LDR, DWORK, DWORK, 1, RX, RANKS, TOL, $ DWORK, LDWORK, INFO ) TEMP = DNRM2( N, RX, 1 ) PARL = ( ( FP/DELTA )/TEMP )/TEMP C C For efficiency, use CONDL = 'U', if possible. C IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO ) $ CONDL = 'U' ELSE PARL = ZERO END IF C IBSN = 0 K = 1 C C Calculate an upper bound, PARU, for the zero of the function. C DO 70 J = 1, N IBSN = IBSN + 1 IF ( J.LT.NTHS ) THEN SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 ) IF ( IBSN.EQ.BSN ) THEN IBSN = 0 K = K + BSN END IF ELSE IF ( J.EQ.NTHS ) THEN SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 ) ELSE SUM = DDOT( J, R(1,IBSN), 1, QTB, 1 ) END IF L = IPVT(J) RX(J) = SUM/DIAG(L) 70 CONTINUE C GNORM = DNRM2( N, RX, 1 ) PARU = GNORM/DELTA IF ( PARU.EQ.ZERO ) $ PARU = DWARF/MIN( DELTA, P1 )/P001 C C If the input PAR lies outside of the interval (PARL,PARU), C set PAR to the closer endpoint. C PAR = MAX( PAR, PARL ) PAR = MIN( PAR, PARU ) IF ( PAR.EQ.ZERO ) $ PAR = GNORM/DXNORM C C Beginning of an iteration. C 80 CONTINUE ITER = ITER + 1 C C Evaluate the function at the current value of PAR. C IF ( PAR.EQ.ZERO ) $ PAR = MAX( DWARF, P001*PARU ) TEMP = SQRT( PAR ) C DO 90 J = 1, N RX(J) = TEMP*DIAG(J) 90 CONTINUE C C Solve the system J*x = b , sqrt(PAR)*D*x = 0 , in a least C square sense. C The first N elements of DWORK contain the diagonal elements C of the upper triangular matrix S, and the next N elements C contain the the vector z, so that x = P*z (see NF01BQ). C The vector z is not preserved, to reduce the workspace. C The elements 2*N+1 : 2*N+ST*(N-ST) contain the C submatrix (S(1:N-ST,N-ST+1:N))' of the matrix S. C Workspace: ST*(N-ST) + 2*N, if CONDL <> 'E'; C ST*(N-ST) + 2*N + 2*MAX(BSN,ST), if CONDL = 'E'. C CALL NF01BQ( CONDL, N, IPAR, LIPAR, R, LDR, IPVT, RX, QTB, $ RANKS, X, TOLDEF, DWORK, LDWORK, INFO ) C DO 100 J = 1, N DWORK(N+J) = DIAG(J)*X(J) 100 CONTINUE C DXNORM = DNRM2( N, DWORK(N+1), 1 ) TEMP = FP FP = DXNORM - DELTA C C If the function is small enough, accept the current value C of PAR. Also test for the exceptional cases where PARL C is zero or the number of iterations has reached ITMAX. C IF ( ABS( FP ).GT.P1*DELTA .AND. $ ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND. $ ITER.LT.ITMAX ) THEN C C Compute the Newton correction. C DO 110 J = 1, N L = IPVT(J) RX(J) = DIAG(L)*( DWORK(N+L)/DXNORM ) 110 CONTINUE C CALL NF01BR( 'Use ranks', 'Lower', 'Transpose', N, IPAR, $ LIPAR, R, LDR, DWORK, DWORK(N2+1), LDS, RX, $ RANKS, TOL, DWORK(JW), LDWORK-JW, INFO ) TEMP = DNRM2( N, RX, 1 ) PARC = ( ( FP/DELTA )/TEMP )/TEMP C C Depending on the sign of the function, update PARL C or PARU. C IF ( FP.GT.ZERO ) THEN PARL = MAX( PARL, PAR ) ELSE IF ( FP.LT.ZERO ) THEN PARU = MIN( PARU, PAR ) END IF C C Compute an improved estimate for PAR. C PAR = MAX( PARL, PAR + PARC ) C C End of an iteration. C GO TO 80 END IF END IF C C Compute -R*P'*x = -R*z. C DO 120 J = 1, N L = IPVT(J) RX(J) = -X(L) 120 CONTINUE C DO 130 I = 1, NTHS, BSN CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', BSN, R(I,1), $ LDR, RX(I), 1 ) 130 CONTINUE C IF ( ST.GT.0 ) THEN CALL DGEMV( 'NoTranspose', NTHS, ST, ONE, R(1,BSN+1), LDR, $ RX(NTHS+1), 1, ONE, RX, 1 ) CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', ST, $ R(NTHS+1,BSN+1), LDR, RX(NTHS+1), 1 ) END IF C C Termination. If PAR = 0, set S. C IF ( ITER.EQ.0 ) THEN PAR = ZERO I = 1 C DO 150 K = 1, BN C DO 140 J = 1, BSN DWORK(I) = R(I,J) CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) I = I + 1 140 CONTINUE C 150 CONTINUE C IF ( ST.GT.0 ) THEN C DO 160 J = BSN + 1, BSN + ST CALL DCOPY( NTHS, R(1,J), 1, DWORK(N+J-BSN), ST ) DWORK(I) = R(I,J) CALL DCOPY( BSN+ST-J+1, R(I,J), LDR, R(I,J), 1 ) I = I + 1 160 CONTINUE C END IF ELSE C DO 170 K = N + 1, N + ST*NTHS DWORK(K) = DWORK(K+N) 170 CONTINUE C END IF C RETURN C C *** Last line of NF01BP *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02OY.f0000644000000000000000000000013015012430707016211 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB02OY.f0000644000175000017500000006220415012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE SB02OY( TYPE, DICO, JOBB, FACT, UPLO, JOBL, JOBE, N, M, $ P, A, LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, E, $ LDE, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To construct the extended matrix pairs for the computation of the C solution of the algebraic matrix Riccati equations arising in the C problems of optimal control, both discrete and continuous-time, C and of spectral factorization, both discrete and continuous-time. C These matrix pairs, of dimension 2N + M, are given by C C discrete-time continuous-time C C |A 0 B| |E 0 0| |A 0 B| |E 0 0| C |Q -E' L| - z |0 -A' 0|, |Q A' L| - s |0 -E' 0|. (1) C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| C C After construction, these pencils are compressed to a form C (see [1]) C C lambda x A - B , C f f C C where A and B are 2N-by-2N matrices. C f f C -1 C Optionally, matrix G = BR B' may be given instead of B and R; C then, for L = 0, 2N-by-2N matrix pairs are directly constructed as C C discrete-time continuous-time C C |A 0 | |E G | |A -G | |E 0 | C | | - z | |, | | - s | |. (2) C |Q -E'| |0 -A'| |Q A'| |0 -E'| C C Similar pairs are obtained for non-zero L, if SLICOT Library C routine SB02MT is called before SB02OY. C Other options include the case with E identity matrix, L a zero C matrix, or Q and/or R given in a factored form, Q = C'C, R = D'D. C For spectral factorization problems, there are minor differences C (e.g., B is replaced by C'). C The second matrix in (2) is not constructed in the continuous-time C case if E is specified as being an identity matrix. C C ARGUMENTS C C Mode Parameters C C TYPE CHARACTER*1 C Specifies the type of problem to be addressed as follows: C = 'O': Optimal control problem; C = 'S': Spectral factorization problem. C C DICO CHARACTER*1 C Specifies the type of linear system considered as follows: C = 'C': Continuous-time system; C = 'D': Discrete-time system. C C JOBB CHARACTER*1 C Specifies whether or not the matrix G is given, instead C of the matrices B and R, as follows: C = 'B': B and R are given; C = 'G': G is given. C For JOBB = 'G', a 2N-by-2N matrix pair is directly C obtained assuming L = 0 (see the description of JOBL). C C FACT CHARACTER*1 C Specifies whether or not the matrices Q and/or R (if C JOBB = 'B') are factored, as follows: C = 'N': Not factored, Q and R are given; C = 'C': C is given, and Q = C'C; C = 'D': D is given, and R = D'D (if TYPE = 'O'), or C R = D + D' (if TYPE = 'S'); C = 'B': Both factors C and D are given, Q = C'C, R = D'D C (or R = D + D'). C C UPLO CHARACTER*1 C If JOBB = 'G', or FACT = 'N', specifies which triangle of C the matrices G and Q (if FACT = 'N'), or Q and R (if C JOBB = 'B'), is stored, as follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. C C JOBL CHARACTER*1 C Specifies whether or not the matrix L is zero, as follows: C = 'Z': L is zero; C = 'N': L is nonzero. C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. C Using SLICOT Library routine SB02MT to compute the C corresponding A and Q in this case, before calling SB02OY, C enables to obtain 2N-by-2N matrix pairs directly. C C JOBE CHARACTER*1 C Specifies whether or not the matrix E is identity, as C follows: C = 'I': E is the identity matrix; C = 'N': E is a general matrix. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, Q, and E, and the number C of rows of the matrices B and L. N >= 0. C C M (input) INTEGER C If JOBB = 'B', M is the order of the matrix R, and the C number of columns of the matrix B. M >= 0. C M is not used if JOBB = 'G'. C C P (input) INTEGER C If FACT = 'C' or 'D' or 'B', or if TYPE = 'S', P is the C number of rows of the matrix C and/or D, respectively. C P >= 0, and if JOBB = 'B' and TYPE = 'S', then P = M. C Otherwise, P is not used. 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 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,*) C If JOBB = 'B', the leading N-by-M part of this array must C contain the input matrix B of the system. C If JOBB = 'G', 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 upper triangular part or C lower triangular part, respectively, of the matrix C -1 C G = BR B'. The strictly lower triangular part (if C UPLO = 'U') or strictly upper triangular part (if C UPLO = 'L') is not referenced. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) C If FACT = 'N' or 'D', the leading N-by-N upper triangular C part (if UPLO = 'U') or lower triangular part (if UPLO = C 'L') of this array must contain the upper triangular part C or lower triangular part, respectively, of the symmetric C output weighting matrix Q. The strictly lower triangular C part (if UPLO = 'U') or strictly upper triangular part (if C UPLO = 'L') is not referenced. C If FACT = 'C' or 'B', the leading P-by-N part of this C array must contain the output matrix C of the system. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= MAX(1,N) if FACT = 'N' or 'D', C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. C C R (input) DOUBLE PRECISION array, dimension (LDR,M) C If FACT = 'N' or 'C', the leading M-by-M upper triangular C part (if UPLO = 'U') or lower triangular part (if UPLO = C 'L') of this array must contain the upper triangular part C or lower triangular part, respectively, of the symmetric C input weighting matrix R. The strictly lower triangular C part (if UPLO = 'U') or strictly upper triangular part (if C UPLO = 'L') is not referenced. C If FACT = 'D' or 'B', the leading P-by-M part of this C array must contain the direct transmission matrix D of the C system. C If JOBB = 'G', this array is not referenced. C C LDR INTEGER C The leading dimension of array R. C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; C LDR >= 1 if JOBB = 'G'. C C L (input) DOUBLE PRECISION array, dimension (LDL,M) C If JOBL = 'N' (and JOBB = 'B'), the leading N-by-M part of C this array must contain the cross weighting matrix L. C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. C C LDL INTEGER C The leading dimension of array L. C LDL >= MAX(1,N) if JOBL = 'N'; C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. C C E (input) DOUBLE PRECISION array, dimension (LDE,N) C If JOBE = 'N', the leading N-by-N part of this array must C contain the matrix E of the descriptor system. C If JOBE = 'I', E is taken as identity and this array is C not referenced. C C LDE INTEGER C The leading dimension of array E. C LDE >= MAX(1,N) if JOBE = 'N'; C LDE >= 1 if JOBE = 'I'. C C AF (output) DOUBLE PRECISION array, dimension (LDAF,*) C The leading 2N-by-2N part of this array contains the C matrix A in the matrix pencil. C f C Array AF must have 2*N+M columns if JOBB = 'B', and 2*N C columns, otherwise. C C LDAF INTEGER C The leading dimension of array AF. C LDAF >= MAX(1,2*N+M) if JOBB = 'B', C LDAF >= MAX(1,2*N) if JOBB = 'G'. C C BF (output) DOUBLE PRECISION array, dimension (LDBF,2*N) C If DICO = 'D' or JOBB = 'B' or JOBE = 'N', the leading C 2N-by-2N part of this array contains the matrix B in the C f C matrix pencil. C The last M zero columns are never constructed. C If DICO = 'C' and JOBB = 'G' and JOBE = 'I', this array C is not referenced. C C LDBF INTEGER C The leading dimension of array BF. C LDBF >= MAX(1,2*N+M) if JOBB = 'B', C LDBF >= MAX(1,2*N) if JOBB = 'G' and ( DICO = 'D' or C JOBE = 'N' ), C LDBF >= 1 if JOBB = 'G' and ( DICO = 'C' and C JOBE = 'I' ). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used to test for near singularity of C the original matrix pencil, specifically of the triangular C factor obtained during the reduction process. If the user C sets TOL > 0, then the given value of TOL is used as a C lower bound for the reciprocal condition number of that C matrix; a matrix whose estimated condition number is less C than 1/TOL is considered to be nonsingular. If the user C sets TOL <= 0, then a default tolerance, defined by C TOLDEF = EPS, is used instead, where EPS is the machine C precision (see LAPACK Library routine DLAMCH). C This parameter is not referenced if JOBB = 'G'. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK >= M if JOBB = 'B', C LIWORK >= 1 if JOBB = 'G'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK. If JOBB = 'B', DWORK(2) returns the reciprocal C of the condition number of the M-by-M lower triangular C matrix obtained after compression. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 1 if JOBB = 'G', C LDWORK >= MAX(1,2*N + M,3*M) if JOBB = 'B'. 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: if the computed extended matrix pencil is singular, C possibly due to rounding errors. C C METHOD C C The extended matrix pairs are constructed, taking various options C into account. If JOBB = 'B', the problem order is reduced from C 2N+M to 2N (see [1]). C C REFERENCES C C [1] Van Dooren, P. C A Generalized Eigenvalue Approach for Solving Riccati C Equations. C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. C C [2] Mehrmann, V. C The Autonomous Linear Quadratic Control Problem. Theory and C Numerical Solution. C Lect. Notes in Control and Information Sciences, vol. 163, C Springer-Verlag, Berlin, 1991. C C [3] Sima, V. C Algorithms for Linear-Quadratic Optimization. C Pure and Applied Mathematics: A Series of Monographs and C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. C C NUMERICAL ASPECTS C C The algorithm is backward stable. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. C Supersedes Release 2.0 routine SB02CY by T.G.J. Beelen, Philips, C Eindhoven, Holland, M. Vanbegin, and P. Van Dooren, Philips C Research Laboratory, Brussels, Belgium. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002. C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, discrete-time system, optimal regulator, Schur form. C C ****************************************************************** C DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, FACT, JOBB, JOBE, JOBL, TYPE, UPLO INTEGER INFO, LDA, LDAF, LDB, LDBF, LDE, LDL, LDQ, LDR, $ LDWORK, M, N, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), $ DWORK(*), E(LDE,*), L(LDL,*), Q(LDQ,*), R(LDR,*) C .. Local Scalars .. LOGICAL DISCR, LFACB, LFACN, LFACQ, LFACR, LJOBB, LJOBE, $ LJOBL, LUPLO, OPTC INTEGER I, ITAU, J, JWORK, N2, N2P1, NM, NNM, NP1, $ WRKOPT DOUBLE PRECISION RCOND, TOLDEF C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEQLF, DLACPY, DLASET, DORMQL, DSYRK, $ DTRCON, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C INFO = 0 OPTC = LSAME( TYPE, 'O' ) DISCR = LSAME( DICO, 'D' ) LJOBB = LSAME( JOBB, 'B' ) LFACN = LSAME( FACT, 'N' ) LFACQ = LSAME( FACT, 'C' ) LFACR = LSAME( FACT, 'D' ) LFACB = LSAME( FACT, 'B' ) LUPLO = LSAME( UPLO, 'U' ) LJOBE = LSAME( JOBE, 'I' ) N2 = N + N IF ( LJOBB ) THEN LJOBL = LSAME( JOBL, 'Z' ) NM = N + M NNM = N2 + M ELSE NM = N NNM = N2 END IF NP1 = N + 1 N2P1 = N2 + 1 C C Test the input scalar arguments. C IF( .NOT.OPTC .AND. .NOT.LSAME( TYPE, 'S' ) ) THEN INFO = -1 ELSE IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN INFO = -3 ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB $ .AND. .NOT.LFACN ) THEN INFO = -4 ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) $ INFO = -5 ELSE IF( LJOBB ) THEN IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'N' ) ) $ INFO = -6 ELSE IF( .NOT.LJOBE .AND. .NOT.LSAME( JOBE, 'N' ) ) THEN INFO = -7 ELSE IF( N.LT.0 ) THEN INFO = -8 ELSE IF( LJOBB ) THEN IF( M.LT.0 ) $ INFO = -9 ELSE IF( .NOT.LFACN .OR. .NOT.OPTC ) THEN IF( P.LT.0 ) THEN INFO = -10 ELSE IF( LJOBB ) THEN IF( .NOT.OPTC .AND. P.NE.M ) $ INFO = -10 END IF ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN INFO = -16 ELSE IF( LDR.LT.1 ) THEN INFO = -18 ELSE IF( LJOBB ) THEN IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.M .OR. $ ( LFACR.OR.LFACB ) .AND. LDR.LT.P ) THEN INFO = -18 ELSE IF( ( .NOT.LJOBL .AND. LDL.LT.MAX( 1, N ) ) .OR. $ ( LJOBL .AND. LDL.LT.1 ) ) THEN INFO = -20 END IF END IF IF( ( .NOT.LJOBE .AND. LDE.LT.MAX( 1, N ) ) .OR. $ ( LJOBE .AND. LDE.LT.1 ) ) THEN INFO = -22 ELSE IF( LDAF.LT.MAX( 1, NNM ) ) THEN INFO = -24 ELSE IF( ( ( LJOBB .OR. DISCR .OR. .NOT.LJOBE ) .AND. $ LDBF.LT.NNM ) .OR. ( LDBF.LT.1 ) ) THEN INFO = -26 ELSE IF( ( LJOBB .AND. LDWORK.LT.MAX( NNM, 3*M ) ) .OR. $ LDWORK.LT.1 ) THEN INFO = -30 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB02OY', -INFO ) RETURN END IF C C Quick return if possible. C DWORK(1) = ONE IF ( N.EQ.0 ) $ RETURN C C Construct the extended matrices in AF and BF, by block-columns. C CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) C IF ( .NOT.LFACQ .AND. .NOT.LFACB ) THEN CALL DLACPY( UPLO, N, N, Q, LDQ, AF(NP1,1), LDAF ) IF ( LUPLO ) THEN C C Construct the lower triangle of Q. C DO 20 J = 1, N - 1 CALL DCOPY( N-J, Q(J,J+1), LDQ, AF(NP1+J,J), 1 ) 20 CONTINUE C ELSE C C Construct the upper triangle of Q. C DO 40 J = 2, N CALL DCOPY( J-1, Q(J,1), LDQ, AF(NP1,J), 1 ) 40 CONTINUE C END IF ELSE CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, Q, LDQ, ZERO, $ AF(NP1,1), LDAF ) C DO 60 J = 2, N CALL DCOPY( J-1, AF(NP1,J), 1, AF(N+J,1), LDAF ) 60 CONTINUE C END IF C IF ( LJOBB ) THEN IF ( LJOBL ) THEN CALL DLASET( 'Full', M, N, ZERO, ZERO, AF(N2P1,1), LDAF ) ELSE C DO 80 I = 1, N CALL DCOPY( M, L(I,1), LDL, AF(N2P1,I), 1 ) 80 CONTINUE C END IF END IF C IF ( DISCR.OR.LJOBB ) THEN CALL DLASET( 'Full', N, N, ZERO, ZERO, AF(1,NP1), LDAF ) ELSE IF ( LUPLO ) THEN C C Construct (1,2) block of AF using the upper triangle of G. C DO 140 J = 1, N C DO 100 I = 1, J AF(I,N+J)= -B(I,J) 100 CONTINUE C DO 120 I = J + 1, N AF(I,N+J)= -B(J,I) 120 CONTINUE C 140 CONTINUE C ELSE C C Construct (1,2) block of AF using the lower triangle of G. C DO 200 J = 1, N C DO 160 I = 1, J - 1 AF(I,N+J)= -B(J,I) 160 CONTINUE C DO 180 I = J, N AF(I,N+J)= -B(I,J) 180 CONTINUE C 200 CONTINUE C END IF END IF C IF ( DISCR ) THEN IF ( LJOBE ) THEN CALL DLASET( 'Full', NM, N, ZERO, -ONE, AF(NP1,NP1), LDAF ) ELSE C DO 240 J = 1, N C DO 220 I = 1, N AF(N+I,N+J)= -E(J,I) 220 CONTINUE C 240 CONTINUE C IF ( LJOBB ) $ CALL DLASET( 'Full', M, N, ZERO, ZERO, AF(N2P1,NP1), $ LDAF ) END IF ELSE C DO 280 J = 1, N C DO 260 I = 1, N AF(N+I,N+J)= A(J,I) 260 CONTINUE C 280 CONTINUE C IF ( LJOBB ) THEN IF ( OPTC ) THEN C DO 300 J = 1, N CALL DCOPY ( M, B(J,1), LDB, AF(N2P1,N+J), 1 ) 300 CONTINUE C ELSE CALL DLACPY( 'Full', P, N, Q, LDQ, AF(N2P1,NP1), LDAF ) END IF END IF END IF C IF ( LJOBB ) THEN C IF ( OPTC ) THEN CALL DLACPY( 'Full', N, M, B, LDB, AF(1,N2P1), LDAF ) ELSE C DO 320 I = 1, P CALL DCOPY( N, Q(I,1), LDQ, AF(1,N2+I), 1 ) 320 CONTINUE C END IF C IF ( LJOBL ) THEN CALL DLASET( 'Full', N, M, ZERO, ZERO, AF(NP1,N2P1), LDAF ) ELSE CALL DLACPY( 'Full', N, M, L, LDL, AF(NP1,N2P1), LDAF ) END IF C IF ( .NOT.LFACR .AND. .NOT.LFACB ) THEN CALL DLACPY( UPLO, M, M, R, LDR, AF(N2P1,N2P1), LDAF ) IF ( LUPLO ) THEN C C Construct the lower triangle of R. C DO 340 J = 1, M - 1 CALL DCOPY( M-J, R(J,J+1), LDR, AF(N2P1+J,N2+J), 1 ) 340 CONTINUE C ELSE C C Construct the upper triangle of R. C DO 360 J = 2, M CALL DCOPY( J-1, R(J,1), LDR, AF(N2P1,N2+J), 1 ) 360 CONTINUE C END IF ELSE IF ( OPTC ) THEN CALL DSYRK( 'Upper', 'Transpose', M, P, ONE, R, LDR, ZERO, $ AF(N2P1,N2P1), LDAF ) C DO 380 J = 2, M CALL DCOPY( J-1, AF(N2P1,N2+J), 1, AF(N2+J,N2P1), LDAF ) 380 CONTINUE C ELSE C DO 420 J = 1, M C DO 400 I = 1, P AF(N2+I,N2+J) = R(I,J) + R(J,I) 400 CONTINUE C 420 CONTINUE C END IF END IF C IF ( .NOT.LJOBB .AND. .NOT.DISCR .AND. LJOBE ) $ RETURN C C Construct the first two block columns of BF. C IF ( LJOBE ) THEN CALL DLASET( 'Full', N+NM, N, ZERO, ONE, BF, LDBF ) ELSE CALL DLACPY( 'Full', N, N, E, LDE, BF, LDBF ) CALL DLASET( 'Full', NM, N, ZERO, ZERO, BF(NP1,1), LDBF ) END IF C IF ( .NOT.DISCR.OR.LJOBB ) THEN CALL DLASET( 'Full', N, N, ZERO, ZERO, BF(1,NP1), LDBF ) ELSE IF ( LUPLO ) THEN C C Construct (1,2) block of BF using the upper triangle of G. C DO 480 J = 1, N C DO 440 I = 1, J BF(I,N+J)= B(I,J) 440 CONTINUE C DO 460 I = J + 1, N BF(I,N+J)= B(J,I) 460 CONTINUE C 480 CONTINUE C ELSE C C Construct (1,2) block of BF using the lower triangle of G. C DO 540 J = 1, N C DO 500 I = 1, J - 1 BF(I,N+J)= B(J,I) 500 CONTINUE C DO 520 I = J, N BF(I,N+J)= B(I,J) 520 CONTINUE C 540 CONTINUE C END IF END IF C IF ( DISCR ) THEN C DO 580 J = 1, N C DO 560 I = 1, N BF(N+I,N+J)= -A(J,I) 560 CONTINUE C 580 CONTINUE C IF ( LJOBB ) THEN C IF ( OPTC ) THEN C DO 620 J = 1, N C DO 600 I = 1, M BF(N2+I,N+J)= -B(J,I) 600 CONTINUE C 620 CONTINUE C ELSE C DO 660 J = 1, N C DO 640 I = 1, P BF(N2+I,N+J) = -Q(I,J) 640 CONTINUE C 660 CONTINUE C END IF END IF C ELSE IF ( LJOBE ) THEN CALL DLASET( 'Full', NM, N, ZERO, -ONE, BF(NP1,NP1), LDBF ) ELSE C DO 700 J = 1, N C DO 680 I = 1, N BF(N+I,N+J)= -E(J,I) 680 CONTINUE C 700 CONTINUE C IF ( LJOBB ) $ CALL DLASET( 'Full', M, N, ZERO, ZERO, BF(N2P1,NP1), $ LDBF ) END IF END IF C IF ( .NOT.LJOBB ) $ RETURN C C Compress the pencil lambda x BF - AF, using QL factorization. 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 C Workspace: need 2*M; prefer M + M*NB. C ITAU = 1 JWORK = ITAU + M CALL DGEQLF( NNM, M, AF(1,N2P1), LDAF, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = DWORK(JWORK) C C Workspace: need 2*N+M; prefer M + 2*N*NB. C CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF, $ DWORK(ITAU), AF, LDAF, DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C CALL DORMQL( 'Left', 'Transpose', NNM, N2, M, AF(1,N2P1), LDAF, $ DWORK(ITAU), BF, LDBF, DWORK(JWORK), LDWORK-JWORK+1, $ INFO ) C C Check the singularity of the L factor in the QL factorization: C if singular, then the extended matrix pencil is also singular. C Workspace 3*M. C TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) $ TOLDEF = DLAMCH( 'Epsilon' ) C CALL DTRCON( '1-norm', 'Lower', 'Non unit', M, AF(N2P1,N2P1), $ LDAF, RCOND, DWORK, IWORK, INFO ) WRKOPT = MAX( WRKOPT, 3*M ) C IF ( RCOND.LE.TOLDEF ) $ INFO = 1 C DWORK(1) = WRKOPT DWORK(2) = RCOND C RETURN C *** Last line of SB02OY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB01MD.f0000644000000000000000000000013015012430707016161 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB01MD.f0000644000175000017500000002563215012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK, $ INFO ) C C PURPOSE C C To determine the one-dimensional state feedback matrix G of the C linear time-invariant single-input system C C dX/dt = A * X + B * U, C C where A is an NCONT-by-NCONT matrix and B is an NCONT element C vector such that the closed-loop system C C dX/dt = (A - B * G) * X C C has desired poles. The system must be preliminarily reduced C to orthogonal canonical form using the SLICOT Library routine C AB01MD. C C ARGUMENTS C C Input/Output Parameters C C NCONT (input) INTEGER C The order of the matrix A as produced by SLICOT Library C routine AB01MD. NCONT >= 0. C C N (input) INTEGER C The order of the matrix Z. N >= NCONT. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA,NCONT) C On entry, the leading NCONT-by-NCONT part of this array C must contain the canonical form of the state dynamics C matrix A as produced by SLICOT Library routine AB01MD. C On exit, the leading NCONT-by-NCONT part of this array C contains the upper quasi-triangular form S of the closed- C loop system matrix (A - B * G), that is triangular except C for possible 2-by-2 diagonal blocks. C (To reconstruct the closed-loop system matrix see C FURTHER COMMENTS below.) C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,NCONT). C C B (input/output) DOUBLE PRECISION array, dimension (NCONT) C On entry, this array must contain the canonical form of C the input/state vector B as produced by SLICOT Library C routine AB01MD. C On exit, this array contains the transformed vector Z * B C of the closed-loop system. C C WR (input) DOUBLE PRECISION array, dimension (NCONT) C WI (input) DOUBLE PRECISION array, dimension (NCONT) C These arrays must contain the real and imaginary parts, C respectively, of the desired poles of the closed-loop C system. The poles can be unordered, except that complex C conjugate pairs of poles must appear consecutively. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C On entry, the leading N-by-N part of this array must C contain the orthogonal transformation matrix as produced C by SLICOT Library routine AB01MD, which reduces the system C to canonical form. C On exit, the leading NCONT-by-NCONT part of this array C contains the orthogonal matrix Z which reduces the closed- C loop system matrix (A - B * G) to upper quasi-triangular C form. C C LDZ INTEGER C The leading dimension of array Z. LDZ >= MAX(1,N). C C G (output) DOUBLE PRECISION array, dimension (NCONT) C This array contains the one-dimensional state feedback C matrix G of the original system. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (3*NCONT) 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 method is based on the orthogonal reduction of the closed-loop C system matrix (A - B * G) to upper quasi-triangular form S whose C 1-by-1 and 2-by-2 diagonal blocks correspond to the desired poles. C That is, S = Z'*(A - B * G)*Z, where Z is an orthogonal matrix. C C REFERENCES C C [1] Petkov, P. Hr. C A Computational Algorithm for Pole Assignment of Linear C Single Input Systems. C Internal Report 81/2, Control Systems Research Group, School C of Electronic Engineering and Computer Science, Kingston C Polytechnic, 1981. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(NCONT ) operations and is backward C stable. C C FURTHER COMMENTS C C If required, the closed-loop system matrix (A - B * G) can be C formed from the matrix product Z * S * Z' (where S and Z are the C matrices output in arrays A and Z respectively). C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB01AD by Control Systems Research C Group, Kingston Polytechnic, United Kingdom, May 1981. C C REVISIONS C C - C C KEYWORDS C C Closed loop spectrum, closed loop systems, eigenvalue assignment, C orthogonal canonical form, orthogonal transformation, pole C placement, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDZ, N, NCONT C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(*), DWORK(*), G(*), WI(*), WR(*), $ Z(LDZ,*) C .. Local Scalars .. LOGICAL COMPL INTEGER I, IM1, K, L, LL, LP1, NCONT2, NI, NJ DOUBLE PRECISION B1, P, Q, R, S, T C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLARTG, DLASET, DROT, $ DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C IF( NCONT.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.NCONT ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, NCONT ) ) THEN INFO = -4 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -9 END IF C IF ( INFO.NE.0 ) THEN C C Error return C CALL XERBLA( 'SB01MD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( NCONT.EQ.0 .OR. N.EQ.0 ) $ RETURN C C Return if the system is not complete controllable. C IF ( B(1).EQ.ZERO ) $ RETURN C IF ( NCONT.EQ.1 ) THEN C C 1-by-1 case. C P = A(1,1) - WR(1) A(1,1) = WR(1) G(1) = P/B(1) Z(1,1) = ONE RETURN END IF C C General case. Save the contents of WI in DWORK. C NCONT2 = 2*NCONT CALL DCOPY( NCONT, WI, 1, DWORK(NCONT2+1), 1 ) C B1 = B(1) B(1) = ONE L = 0 LL = 0 20 CONTINUE L = L + 1 LL = LL + 1 COMPL = DWORK(NCONT2+L).NE.ZERO IF ( L.NE.NCONT ) THEN LP1 = L + 1 IF ( LL.NE.2 ) THEN IF ( COMPL ) THEN C C Compute complex eigenvector. C DWORK(NCONT) = ONE DWORK(NCONT2) = ONE P = WR(L) T = DWORK(NCONT2+L) Q = T*DWORK(NCONT2+LP1) DWORK(NCONT2+L) = ONE DWORK(NCONT2+LP1) = Q C DO 40 I = NCONT, LP1, -1 IM1 = I - 1 DWORK(IM1) = ( P*DWORK(I) + Q*DWORK(NCONT+I) - $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) ) $ /A(I,IM1) DWORK(NCONT+IM1) = ( P*DWORK(NCONT+I) + DWORK(I) - $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(NCONT+I), 1 ) ) $ /A(I,IM1) 40 CONTINUE C ELSE C C Compute real eigenvector. C DWORK(NCONT) = ONE P = WR(L) C DO 60 I = NCONT, LP1, -1 IM1 = I - 1 DWORK(IM1) = ( P*DWORK(I) - $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) ) $ /A(I,IM1) 60 CONTINUE C END IF END IF C C Transform eigenvector. C DO 80 K = NCONT - 1, L, -1 IF ( LL.NE.2 ) THEN R = DWORK(K) S = DWORK(K+1) ELSE R = DWORK(NCONT+K) S = DWORK(NCONT+K+1) END IF CALL DLARTG( R, S, P, Q, T ) DWORK(K) = T IF ( LL.NE.2 ) THEN NJ = MAX( K-1, L ) ELSE DWORK(NCONT+K) = T NJ = L - 1 END IF C C Transform A. C CALL DROT( NCONT-NJ+1, A(K,NJ), LDA, A(K+1,NJ), LDA, P, Q ) C IF ( COMPL .AND. LL.EQ.1 ) THEN NI = NCONT ELSE NI = MIN( K+2, NCONT ) END IF CALL DROT( NI, A(1,K), 1, A(1,K+1), 1, P, Q ) C IF ( K.EQ.L ) THEN C C Transform B. C T = B(K) B(K) = P*T B(K+1) = -Q*T END IF C C Accumulate transformations. C CALL DROT( NCONT, Z(1,K), 1, Z(1,K+1), 1, P, Q ) C IF ( COMPL .AND. LL.NE.2 ) THEN T = DWORK(NCONT+K) DWORK(NCONT+K) = P*T + Q*DWORK(NCONT+K+1) DWORK(NCONT+K+1) = P*DWORK(NCONT+K+1) - Q*T END IF 80 CONTINUE C END IF C IF ( .NOT.COMPL ) THEN C C Find one element of G. C K = L R = B(L) IF ( L.NE.NCONT ) THEN IF ( ABS( B(LP1) ).GT.ABS( B(L) ) ) THEN K = LP1 R = B(LP1) END IF END IF P = A(K,L) IF ( K.EQ.L ) P = P - WR(L) P = P/R C CALL DAXPY( LP1, -P, B, 1, A(1,L), 1 ) C G(L) = P/B1 IF ( L.NE.NCONT ) THEN LL = 0 GO TO 20 END IF ELSE IF ( LL.EQ.1 ) THEN GO TO 20 ELSE C C Find two elements of G. C K = L R = B(L) IF ( L.NE.NCONT ) THEN IF ( ABS( B(LP1)).GT.ABS( B(L) ) ) THEN K = LP1 R = B(LP1) END IF END IF P = A(K,L-1) Q = A(K,L) IF ( K.EQ.L ) THEN P = P - ( DWORK(NCONT+L)/DWORK(L-1) )*DWORK(NCONT2+L) Q = Q - WR(L) + $ ( DWORK(NCONT+L-1)/DWORK(L-1) )*DWORK(NCONT2+L) END IF P = P/R Q = Q/R C CALL DAXPY( LP1, -P, B, 1, A(1,L-1), 1 ) CALL DAXPY( LP1, -Q, B, 1, A(1,L), 1 ) C G(L-1) = P/B1 G(L) = Q/B1 IF ( L.NE.NCONT ) THEN LL = 0 GO TO 20 END IF END IF C C Transform G. C CALL DGEMV( 'No transpose', NCONT, NCONT, ONE, Z, LDZ, G, 1, $ ZERO, DWORK, 1 ) CALL DCOPY( NCONT, DWORK, 1, G, 1 ) CALL DSCAL( NCONT, B1, B, 1 ) C C Annihilate A after the first subdiagonal. C IF ( NCONT.GT.2 ) $ CALL DLASET( 'Lower', NCONT-2, NCONT-2, ZERO, ZERO, A(3,1), $ LDA ) C RETURN C *** Last line of SB01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB4DPZ.f0000644000000000000000000000013015012430707016233 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB4DPZ.f0000644000175000017500000012265215012430707017441 0ustar00lilgelilge00000000000000 SUBROUTINE MB4DPZ( JOB, N, THRESH, A, LDA, DE, LDDE, C, LDC, VW, $ LDVW, ILO, LSCALE, RSCALE, DWORK, IWARN, INFO ) C C PURPOSE C C To balance the 2*N-by-2*N complex skew-Hamiltonian/Hamiltonian C pencil aS - bH, with C C ( A D ) ( C V ) C S = ( ) and H = ( ), A, C N-by-N, (1) C ( E A' ) ( W -C' ) C C where D and E are skew-Hermitian, V and W are Hermitian matrices, C and ' denotes conjugate transpose. This involves, first, permuting C aS - bH by a symplectic equivalence transformation to isolate C eigenvalues in the first 1:ILO-1 elements on the diagonal of A C and C; and second, applying a diagonal equivalence transformation C to make the pairs of rows and columns ILO:N and N+ILO:2*N as close C in 1-norm as possible. Both steps are optional. Balancing may C reduce the 1-norms of the matrices S and H. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the operations to be performed on S and H: C = 'N': none: simply set ILO = 1, LSCALE(I) = 1.0 and C RSCALE(I) = 1.0 for i = 1,...,N. C = 'P': permute only; C = 'S': scale only; C = 'B': both permute and scale. C C Input/Output Parameters C C N (input) INTEGER C The order of matrices A, D, E, C, V, and W. N >= 0. C C THRESH (input) DOUBLE PRECISION C If JOB = 'S' or JOB = 'B', and THRESH >= 0, threshold C value for magnitude of the elements to be considered in C the scaling process: elements with magnitude less than or C equal to THRESH*MXNORM are ignored for scaling, where C MXNORM is the maximum of the 1-norms of the original C submatrices S(s,s) and H(s,s), with s = [ILO:N,N+ILO:2*N]. C If THRESH < 0, the subroutine finds the scaling factors C for which some conditions, detailed below, are fulfilled. C A sequence of increasing strictly positive threshold C values is used. C If THRESH = -1, the condition is that C max( norm(H(s,s),1)/norm(S(s,s),1), C norm(S(s,s),1)/norm(H(s,s),1) ) (1) C has the smallest value, for the threshold values used, C where S(s,s) and H(s,s) are the scaled submatrices. C If THRESH = -2, the norm ratio reduction (1) is tried, but C the subroutine may return IWARN = 1 and reset the scaling C factors to 1, if this seems suitable. See the description C of the argument IWARN and FURTHER COMMENTS. C If THRESH = -3, the condition is that C norm(H(s,s),1)*norm(S(s,s),1) (2) C has the smallest value for the scaled submatrices. C If THRESH = -4, the norm reduction in (2) is tried, but C the subroutine may return IWARN = 1 and reset the scaling C factors to 1, as for THRESH = -2 above. C If THRESH = -VALUE, with VALUE >= 10, the condition C numbers of the left and right scaling transformations will C be bounded by VALUE, i.e., the ratios between the largest C and smallest entries in [LSCALE(ILO:N); RSCALE(ILO:N)] C will be at most VALUE. VALUE should be a power of 10. C If JOB = 'N' or JOB = 'P', the value of THRESH is C irrelevant. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the matrix A. C On exit, the leading N-by-N part of this array contains C the matrix A of the balanced skew-Hamiltonian matrix S. C In particular, the strictly lower triangular part of the C first ILO-1 columns of A is zero. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C DE (input/output) COMPLEX*16 array, dimension (LDDE, N+1) C On entry, the leading N-by-N lower triangular part of C this array must contain the lower triangular part of the C skew-Hermitian matrix E, and the N-by-N upper triangular C part of the submatrix in the columns 2 to N+1 of this C array must contain the upper triangular part of the C skew-Hermitian matrix D. The real parts of the entries on C the diagonal and the first superdiagonal of this array C should be zero. C On exit, the leading N-by-N lower triangular part of this C array contains the lower triangular part of the balanced C matrix E, and the N-by-N upper triangular part of the C submatrix in the columns 2 to N+1 of this array contains C the upper triangular part of the balanced matrix D. C In particular, the lower triangular part of the first C ILO-1 columns of DE is zero. C C LDDE INTEGER C The leading dimension of the array DE. LDDE >= MAX(1, N). C C C (input/output) COMPLEX*16 array, dimension (LDC, N) C On entry, the leading N-by-N part of this array must C contain the matrix C. C On exit, the leading N-by-N part of this array contains C the matrix C of the balanced Hamiltonian matrix H. C In particular, the strictly lower triangular part of the C first ILO-1 columns of C is zero. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1, N). C C VW (input/output) COMPLEX*16 array, dimension (LDVW, N+1) C On entry, the leading N-by-N lower triangular part of C this array must contain the lower triangular part of the C Hermitian matrix W, and the N-by-N upper triangular C part of the submatrix in the columns 2 to N+1 of this C array must contain the upper triangular part of the C Hermitian matrix V. The imaginary parts of the entries on C the diagonal and the first superdiagonal of this array C should be zero. C On exit, the leading N-by-N lower triangular part of this C array contains the lower triangular part of the balanced C matrix W, and the N-by-N upper triangular part of the C submatrix in the columns 2 to N+1 of this array contains C the upper triangular part of the balanced matrix V. In C particular, the lower triangular part of the first ILO-1 C columns of VW is zero. C C LDVW INTEGER C The leading dimension of the array VW. LDVW >= MAX(1, N). C C ILO (output) INTEGER C ILO-1 is the number of deflated eigenvalues in the C balanced skew-Hamiltonian/Hamiltonian matrix pencil. C ILO is set to 1 if JOB = 'N' or JOB = 'S'. C C LSCALE (output) DOUBLE PRECISION array, dimension (N) C Details of the permutations of S and H and scaling applied C to A, D, C, and V from the left. For j = 1,...,ILO-1 let C P(j) = LSCALE(j). If P(j) <= N, then rows and columns P(j) C and P(j)+N are interchanged with rows and columns j and C j+N, respectively. If P(j) > N, then row and column P(j)-N C are interchanged with row and column j+N by a generalized C symplectic permutation. For j = ILO,...,N the j-th element C of LSCALE contains the factor of the scaling applied to C row j of the matrices A, D, C, and V. C C RSCALE (output) DOUBLE PRECISION array, dimension (N) C Details of the permutations of S and H and scaling applied C to A, E, C, and W from the right. For j = 1,...,ILO-1 let C P(j) = RSCALE(j). If P(j) <= N, then rows and columns P(j) C and P(j)+N are interchanged with rows and columns j and C j+N, respectively. If P(j) > N, then row and column P(j)-N C are interchanged with row and column j+N by a generalized C symplectic permutation. For j = ILO,...,N the j-th element C of RSCALE contains the factor of the scaling applied to C column j of the matrices A, E, C, and W. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) where C LDWORK = 0, if JOB = 'N' or JOB = 'P', or N = 0; C LDWORK = 6*N, if (JOB = 'S' or JOB = 'B') and THRESH >= 0; C LDWORK = 8*N, if (JOB = 'S' or JOB = 'B') and THRESH < 0. C On exit, if JOB = 'S' or JOB = 'B', DWORK(1) and DWORK(2) C contain the initial 1-norms of S(s,s) and H(s,s), and C DWORK(3) and DWORK(4) contain their final 1-norms, C respectively. Moreover, DWORK(5) contains the THRESH value C used (irrelevant if IWARN = 1 or ILO = N). C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: scaling has been requested, for THRESH = -2 or C THRESH = -4, but it most probably would not improve C the accuracy of the computed solution for a related C eigenproblem (since maximum norm increased C significantly compared to the original pencil C matrices and (very) high and/or small scaling C factors occurred). The returned scaling factors have C been reset to 1, but information about permutations, C if requested, has been preserved. 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 Balancing consists of applying a (symplectic) equivalence C transformation to isolate eigenvalues and/or to make the 1-norms C of each pair of rows and columns indexed by s of S and H nearly C equal. If THRESH < 0, a search is performed to find those scaling C factors giving the smallest norm ratio or product defined above C (see the description of the parameter THRESH). C C Assuming JOB = 'S', let Dl and Dr be diagonal matrices containing C the vectors LSCALE and RSCALE, respectively. The returned matrices C are obtained using the equivalence transformation C C ( Dl 0 ) ( A D ) ( Dr 0 ) ( Dl 0 ) ( C V ) ( Dr 0 ) C ( ) ( ) ( ), ( ) ( ) ( ). C ( 0 Dr ) ( E A' ) ( 0 Dl ) ( 0 Dr ) ( W -C' ) ( 0 Dl ) C C For THRESH = 0, the routine returns essentially the same results C as the LAPACK subroutine ZGGBAL [1]. Setting THRESH < 0, usually C gives better results than ZGGBAL for badly scaled matrix pencils. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C [2] Benner, P. C Symplectic balancing of Hamiltonian matrices. C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2001. C C NUMERICAL ASPECTS C C The transformations used preserve the skew-Hamiltonian/Hamiltonian C structure and do not introduce significant rounding errors. C No rounding errors appear if JOB = 'P'. If T is the global C transformation matrix applied to the right, then J'*T*J is the C global transformation matrix applied to the left, where C J = [ 0 I; -I 0 ], with blocks of order N. C C FURTHER COMMENTS C C If THRESH = -2, the increase of the maximum norm of the scaled C submatrices, compared to the maximum norm of the initial C submatrices, is bounded by MXGAIN = 100. C If THRESH = -2, or THRESH = -4, the maximum condition number of C the scaling transformations is bounded by MXCOND = 1/SQRT(EPS), C where EPS is the machine precision (see LAPACK Library routine C DLAMCH). C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2015. C C REVISIONS C C V. Sima, Jan. 2016, Jan. 2017, Feb. 2017. C C KEYWORDS C C Balancing, eigenvalue, equivalence transformation, matrix algebra, C matrix operations, symplectic equivalence transformation. C C ********************************************************************* C C .. Parameters .. DOUBLE PRECISION HALF, ONE, TEN, TWO, ZERO PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, TEN = 1.0D+1, $ TWO = 2.0D+0, ZERO = 0.0D+0 ) DOUBLE PRECISION MXGAIN, SCLFAC PARAMETER ( MXGAIN = 1.0D+2, SCLFAC = 1.0D+1 ) CHARACTER LOW, NSKEW, NTRAN, SKEW, UPP PARAMETER ( LOW = 'Lower', NSKEW = 'Not Skew', $ NTRAN = 'No transpose', SKEW = 'Skew', $ UPP = 'Upper' ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. CHARACTER JOB INTEGER ILO, INFO, IWARN, LDA, LDC, LDDE, LDVW, N DOUBLE PRECISION THRESH C .. Array Arguments .. DOUBLE PRECISION DWORK(*), LSCALE(*), RSCALE(*) COMPLEX*16 A(LDA,*), C(LDC,*), DE(LDDE,*), VW(LDVW,*) C .. Local Scalars .. LOGICAL EVNORM, LOOP, LPERM, LSCAL, STORMN INTEGER I, ICAB, ILOOLD, IR, IRAB, IT, ITER, ITH, J, $ JC, K, KOUNT, KS, KW1, KW2, KW3, KW4, KW5, KW6, $ KW7, LRAB, LSFMAX, LSFMIN, NR, NRP2 DOUBLE PRECISION AB, ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, DENOM, EPS, EW, GAMMA, GAP, MINPRO, $ MINRAT, MN, MX, MXCOND, MXNORM, MXS, NH, NH0, $ NHS, NS, NS0, NSS, PGAMMA, PROD, RAB, RATIO, $ SFMAX, SFMIN, SUM, T, TA, TC, TD, TE, TH, TH0, $ THS, TV, TW C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, IZAMAX DOUBLE PRECISION DDOT, DLAMCH, MA02IZ EXTERNAL DDOT, DLAMCH, IDAMAX, IZAMAX, LSAME, MA02IZ C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSCAL, MA02NZ, XERBLA, ZDSCAL, $ ZSWAP C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, DIMAG, INT, LOG10, MAX, MIN, $ SIGN, SQRT C C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IWARN = 0 LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) C IF( .NOT.LPERM .AND. .NOT.LSCAL .AND. .NOT.LSAME( JOB, 'N' ) ) $ THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA .LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDDE.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC .LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDVW.LT.MAX( 1, N ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB4DPZ', -INFO ) RETURN END IF C ILO = 1 C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN IF( ( .NOT.LPERM .AND. .NOT.LSCAL ) .OR. N.EQ.1 ) THEN DUM(1) = ONE CALL DCOPY( N, DUM, 0, LSCALE, 1 ) CALL DCOPY( N, DUM, 0, RSCALE, 1 ) IF( N.EQ.1 .AND. LSCAL ) THEN NS0 = MA02IZ( 'skew-Hamiltonian', '1-norm', N, A, LDA, DE, $ LDDE, DWORK ) NH0 = MA02IZ( 'Hamiltonian', '1-norm', N, C, LDC, VW, LDVW, $ DWORK ) DWORK(1) = NS0 DWORK(2) = NH0 DWORK(3) = NS0 DWORK(4) = NH0 DWORK(5) = THRESH END IF RETURN END IF C IF( LPERM ) THEN C C Permute the matrices S and H to isolate the eigenvalues. C ILOOLD = 0 C WHILE ( ILO.NE.ILOOLD ) 10 CONTINUE IF( ILO.NE.ILOOLD ) THEN ILOOLD = ILO C C Scan columns ILO .. N. C I = ILO C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) 20 CONTINUE IF( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN DO 30 J = ILO, I-1 IF( A(J,I).NE.CZERO .OR. C(J,I).NE.CZERO ) THEN I = I + 1 GOTO 20 END IF 30 CONTINUE DO 40 J = I+1, N IF( A(J,I).NE.CZERO .OR. C(J,I).NE.CZERO ) THEN I = I + 1 GOTO 20 END IF 40 CONTINUE DO 50 J = ILO, I-1 IF( DE(I,J).NE.CZERO .OR. VW(I,J).NE.CZERO ) THEN I = I + 1 GOTO 20 END IF 50 CONTINUE IF( DIMAG( DE(I,I) ).NE.ZERO ) THEN I = I + 1 GOTO 20 END IF IF( DBLE( VW(I,I) ).NE.ZERO ) THEN I = I + 1 GOTO 20 END IF DO 60 J = I+1, N IF( DE(J,I).NE.CZERO .OR. VW(J,I).NE.CZERO ) THEN I = I + 1 GOTO 20 END IF 60 CONTINUE C C Exchange columns/rows ILO <-> I. C LSCALE(ILO) = I RSCALE(ILO) = I C IF( ILO.NE.I ) THEN C CALL ZSWAP( N, A(1,ILO), 1, A(1,I), 1 ) CALL ZSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) C CALL MA02NZ( LOW, NTRAN, SKEW, N, ILO, I, DE, LDDE ) CALL MA02NZ( UPP, NTRAN, SKEW, N, ILO, I, DE(1,2), $ LDDE ) C CALL ZSWAP( N, C(1,ILO), 1, C(1,I), 1 ) CALL ZSWAP( N-ILO+1, C(ILO,ILO), LDC, C(I,ILO), LDC ) C CALL MA02NZ( LOW, NTRAN, NSKEW, N, ILO, I, VW, LDVW ) CALL MA02NZ( UPP, NTRAN, NSKEW, N, ILO, I, VW(1,2), $ LDVW ) END IF ILO = ILO + 1 END IF C END WHILE 20 C C Scan columns N+ILO .. 2*N. C I = ILO C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) 70 CONTINUE IF( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN DO 80 J = ILO, I-1 IF( A(I,J).NE.CZERO .OR. C(I,J).NE.CZERO ) THEN I = I + 1 GOTO 70 END IF 80 CONTINUE DO 90 J = I+1, N IF( A(I,J).NE.CZERO .OR. C(I,J).NE.CZERO ) THEN I = I + 1 GOTO 70 END IF 90 CONTINUE DO 100 J = ILO, I-1 IF( DE(J,I+1).NE.CZERO .OR. VW(J,I+1).NE.CZERO ) THEN I = I + 1 GOTO 70 END IF 100 CONTINUE IF( DIMAG( DE(I,I+1) ).NE.ZERO ) THEN I = I + 1 GOTO 70 END IF IF( DBLE( VW(I,I+1) ).NE.ZERO ) THEN I = I + 1 GOTO 70 END IF DO 110 J = I+1, N IF( DE(I,J+1).NE.CZERO .OR. VW(I,J+1).NE.CZERO ) THEN I = I + 1 GOTO 70 END IF 110 CONTINUE C C Exchange columns/rows I <-> I+N with a symplectic C generalized permutation. C LSCALE(ILO) = N + I RSCALE(ILO) = N + I C CALL ZSWAP( I-ILO, A(I,ILO), LDA, DE(I,ILO), LDDE ) CALL ZDSCAL( I-ILO, -ONE, A(I,ILO), LDA ) IF( N.GT.I ) THEN CALL ZSWAP( N-I, A(I,I+1), LDA, DE(I+1,I), 1 ) DO 120 J = I+1, N A( I,J) = DCONJG( A(I,J) ) DE(J,I) = DCMPLX( -DBLE( DE(J,I) ), $ DIMAG( DE(J,I) ) ) 120 CONTINUE END IF CALL ZSWAP( I-1, A(1,I), 1, DE(1,I+1), 1 ) CALL ZDSCAL( I-1, -ONE, A(1,I), 1 ) IF( N.GT.I ) THEN CALL ZSWAP( N-I, A(I+1,I), 1, DE(I,I+2), LDDE ) DO 130 J = I+1, N A( J,I) = DCONJG( A(J,I) ) DE(I,J+1) = DCMPLX( -DBLE( DE(I,J+1) ), $ DIMAG( DE(I,J+1) ) ) 130 CONTINUE END IF A(I,I) = DCONJG( A(I,I) ) T = DE(I,I) DE(I,I) = -DE(I,I+1) DE(I,I+1) = -T C CALL ZSWAP( I-ILO, C(I,ILO), LDC, VW(I,ILO), LDVW ) CALL ZDSCAL( I-ILO, -ONE, C(I,ILO), LDC ) IF( N.GT.I ) THEN CALL ZSWAP( N-I, C(I,I+1), LDC, VW(I+1,I), 1 ) DO 140 J = I+1, N VW(J,I) = DCONJG( VW(J,I) ) C( I,J) = DCMPLX( -DBLE( C(I,J) ), $ DIMAG( C(I,J) ) ) 140 CONTINUE END IF CALL ZSWAP( I-1, C(1,I), 1, VW(1,I+1), 1 ) CALL ZDSCAL( I-1, -ONE, C(1,I), 1 ) IF( N.GT.I ) THEN CALL ZSWAP( N-I, C(I+1,I), 1, VW(I,I+2), LDVW ) DO 150 J = I+1, N VW(I,J+1) = DCONJG( VW(I,J+1) ) C( J,I) = DCMPLX( -DBLE( C(J,I) ), $ DIMAG( C(J,I) ) ) 150 CONTINUE END IF C(I,I) = -DCONJG( C(I,I) ) T = VW(I,I) VW(I,I) = -VW(I,I+1) VW(I,I+1) = -T C C Exchange columns/rows ILO <-> I. C IF( ILO.NE.I ) THEN C CALL ZSWAP( N, A(1,ILO), 1, A(1,I), 1 ) CALL ZSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) C CALL MA02NZ( LOW, NTRAN, SKEW, N, ILO, I, DE, LDDE ) CALL MA02NZ( UPP, NTRAN, SKEW, N, ILO, I, DE(1,2), $ LDDE ) C CALL ZSWAP( N, C(1,ILO), 1, C(1,I), 1 ) CALL ZSWAP( N-ILO+1, C(ILO,ILO), LDC, C(I,ILO), LDC ) C CALL MA02NZ( LOW, NTRAN, NSKEW, N, ILO, I, VW, LDVW ) CALL MA02NZ( UPP, NTRAN, NSKEW, N, ILO, I, VW(1,2), $ LDVW ) END IF ILO = ILO + 1 END IF C END WHILE 70 GOTO 10 END IF C END WHILE 10 C DO 160 I = ILO, N LSCALE( I ) = ONE RSCALE( I ) = ONE 160 CONTINUE IF( .NOT.LSCAL ) $ RETURN END IF C NR = N - ILO + 1 C C Compute initial 1-norms and return if ILO = N. C NS0 = MA02IZ( 'skew-Hamiltonian', '1-norm', NR, A(ILO,ILO), LDA, $ DE(ILO,ILO), LDDE, DWORK ) NH0 = MA02IZ( 'Hamiltonian', '1-norm', NR, C(ILO,ILO), LDC, $ VW(ILO,ILO), LDVW, DWORK ) C IF( ILO.EQ.N ) THEN DWORK(1) = NS0 DWORK(2) = NH0 DWORK(3) = NS0 DWORK(4) = NH0 DWORK(5) = THRESH RETURN END IF C C Balance the submatrices in rows ILO to N. C C Initialize balancing and allocate work storage. C KW1 = N KW2 = KW1 + N KW3 = KW2 + N KW4 = KW3 + N KW5 = KW4 + N DUM(1) = ZERO C C Prepare for scaling. C SFMIN = DLAMCH( 'Safe minimum' ) SFMAX = ONE / SFMIN BASL = LOG10( SCLFAC ) LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) MXNORM = MAX( NS0, NH0 ) LOOP = THRESH.LT.ZERO C IF( LOOP ) THEN C C Compute relative threshold. C NS = NS0 NSS = NS0 NH = NH0 NHS = NH0 C ITH = THRESH MXS = MXNORM MX = ZERO MN = SFMAX IF( ITH.GE.-2 ) THEN IF( NS.LT.NH ) THEN RATIO = MIN( NH/NS, SFMAX ) ELSE RATIO = MIN( NS/NH, SFMAX ) END IF MINRAT = RATIO ELSE IF( ITH.LE.-10 ) THEN MXCOND = -THRESH ELSE DENOM = MAX( ONE, MXNORM ) PROD = ( NS/DENOM )*( NH/DENOM ) MINPRO = PROD END IF STORMN = .FALSE. EVNORM = .FALSE. C C Find maximum order of magnitude of the differences in sizes of C the nonzero entries, not considering diag(A) and diag(C). C DO 180 J = ILO, N DO 170 I = ILO, N IF( I.NE.J ) THEN AB = ABS( A(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) END IF 170 CONTINUE 180 CONTINUE C DO 200 J = ILO, N DO 190 I = ILO, N AB = ABS( DE(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) AB = ABS( DE(I,J+1) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) 190 CONTINUE 200 CONTINUE C DO 220 J = ILO, N DO 210 I = ILO, N IF( I.NE.J ) THEN AB = ABS( C(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) END IF 210 CONTINUE 220 CONTINUE C DO 240 J = ILO, N DO 230 I = ILO, N AB = ABS( VW(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) AB = ABS( VW(I,J+1) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) 230 CONTINUE 240 CONTINUE C IF( MX*SFMIN.LE.MN ) THEN GAP = MX/MN ELSE GAP = SFMAX END IF EPS = DLAMCH( 'Precision' ) ITER = MIN( INT( LOG10( GAP ) ), -INT( LOG10( EPS ) ) ) + 1 TH = MAX( MN, MX*EPS )/MAX( MXNORM, SFMIN ) THS = TH KW6 = KW5 + N + ILO KW7 = KW6 + N CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) C C Set the maximum condition number of the transformations. C IF( ITH.GT.-10 ) $ MXCOND = ONE/SQRT( EPS ) ELSE TH = MXNORM*THRESH ITER = 1 EVNORM = .TRUE. END IF TH0 = TH C COEF = HALF / DBLE( 2*NR ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = NR + 2 BETA = ZERO C C If THRESH < 0, use a loop to reduce the norm ratio. C DO 490 K = 1, ITER C C Compute right side vector in resulting linear equations. C CALL DCOPY( 6*N, DUM, 0, DWORK, 1 ) CALL DCOPY( NR, DUM, 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM, 0, RSCALE(ILO), 1 ) DO 260 I = ILO, N DO 250 J = ILO, N TA = ABS( A(I,J) ) TC = ABS( C(I,J) ) IF( J.GT.I ) THEN TD = ABS( DE(I,J+1) ) TE = ABS( DE(J,I) ) TV = ABS( VW(I,J+1) ) TW = ABS( VW(J,I) ) ELSE TD = ABS( DE(J,I+1) ) TE = ABS( DE(I,J) ) TV = ABS( VW(J,I+1) ) TW = ABS( VW(I,J) ) END IF IF( TA.GT.TH ) THEN TA = LOG10( TA ) / BASL ELSE TA = ZERO END IF IF( TC.GT.TH ) THEN TC = LOG10( TC ) / BASL ELSE TC = ZERO END IF IF( TD.GT.TH ) THEN TD = LOG10( TD ) / BASL ELSE TD = ZERO END IF IF( TE.GT.TH ) THEN TE = LOG10( TE ) / BASL ELSE TE = ZERO END IF IF( TV.GT.TH ) THEN TV = LOG10( TV ) / BASL ELSE TV = ZERO END IF IF( TW.GT.TH ) THEN TW = LOG10( TW ) / BASL ELSE TW = ZERO END IF DWORK(I+KW4) = DWORK(I+KW4) - TA - TC - TD - TV DWORK(J+KW5) = DWORK(J+KW5) - TA - TC - TE - TW 250 CONTINUE 260 CONTINUE C IT = 1 C C Start generalized conjugate gradient iteration. C 270 CONTINUE C GAMMA = ( DDOT( NR, DWORK(ILO+KW4), 1, DWORK(ILO+KW4), 1 ) + $ DDOT( NR, DWORK(ILO+KW5), 1, DWORK(ILO+KW5), 1 ) )* $ TWO C EW = ZERO DO 280 I = ILO, N EW = EW + DWORK(I+KW4) + DWORK(I+KW5) 280 CONTINUE C GAMMA = COEF*GAMMA - TWO*COEF2*EW**2 IF( GAMMA.EQ.ZERO ) $ GO TO 350 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = -TWO*COEF5*EW C CALL DSCAL( NR, BETA, DWORK(ILO), 1 ) CALL DSCAL( NR, BETA, DWORK(ILO+KW1), 1 ) C CALL DAXPY( NR, COEF, DWORK(ILO+KW4), 1, DWORK(ILO+KW1), 1 ) CALL DAXPY( NR, COEF, DWORK(ILO+KW5), 1, DWORK(ILO), 1 ) C DO 290 J = ILO, N DWORK(J) = DWORK(J) + T DWORK(J+KW1) = DWORK(J+KW1) + T 290 CONTINUE C C Apply matrix to vector. C DO 310 I = ILO, N KOUNT = 0 SUM = ZERO DO 300 J = ILO, N KS = KOUNT IF( A(I,J).NE.CZERO ) $ KOUNT = KOUNT + 1 IF( C(I,J).NE.CZERO ) $ KOUNT = KOUNT + 1 SUM = SUM + DBLE( KOUNT - KS )*DWORK(J) C KS = KOUNT IF( J.GE.I ) THEN IF( DE(I,J+1).NE.CZERO ) $ KOUNT = KOUNT + 1 IF( VW(I,J+1).NE.CZERO ) $ KOUNT = KOUNT + 1 ELSE IF( DE(J,I+1).NE.CZERO ) $ KOUNT = KOUNT + 1 IF( VW(J,I+1).NE.CZERO ) $ KOUNT = KOUNT + 1 END IF SUM = SUM + DBLE( KOUNT - KS )*DWORK(J+KW1) 300 CONTINUE DWORK(I+KW2) = DBLE( KOUNT )*DWORK(I+KW1) + SUM 310 CONTINUE C DO 330 J = ILO, N KOUNT = 0 SUM = ZERO DO 320 I = ILO, N KS = KOUNT IF( A(I,J).NE.CZERO ) $ KOUNT = KOUNT + 1 IF( C(I,J).NE.CZERO ) $ KOUNT = KOUNT + 1 SUM = SUM + DBLE( KOUNT - KS )*DWORK(I+KW1) C KS = KOUNT IF( J.GE.I ) THEN IF( DE(J,I).NE.CZERO ) $ KOUNT = KOUNT + 1 IF( VW(J,I).NE.CZERO ) $ KOUNT = KOUNT + 1 ELSE IF( DE(I,J).NE.CZERO ) $ KOUNT = KOUNT + 1 IF( VW(I,J).NE.CZERO ) $ KOUNT = KOUNT + 1 END IF SUM = SUM + DBLE( KOUNT - KS )*DWORK(I) 320 CONTINUE DWORK(J+KW3) = DBLE( KOUNT )*DWORK(J) + SUM 330 CONTINUE C SUM = ( DDOT( NR, DWORK(ILO+KW1), 1, DWORK(ILO+KW2), 1 ) + $ DDOT( NR, DWORK(ILO), 1, DWORK(ILO+KW3), 1 ) )*TWO ALPHA = GAMMA / SUM C C Determine correction to current iteration. C CMAX = ZERO DO 340 I = ILO, N COR = ALPHA*DWORK(I+KW1) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE(I) = LSCALE(I) + COR COR = ALPHA*DWORK(I) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE(I) = RSCALE(I) + COR 340 CONTINUE C IF( CMAX.GE.HALF ) THEN C CALL DAXPY( N, -ALPHA, DWORK(ILO+KW2), 1, DWORK(ILO+KW4), 1) CALL DAXPY( N, -ALPHA, DWORK(ILO+KW3), 1, DWORK(ILO+KW5), 1) C PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 270 END IF C C End generalized conjugate gradient iteration. C 350 CONTINUE C C Compute diagonal scaling matrices. C DO 360 I = ILO, N IRAB = IZAMAX( NR, A(I,ILO), LDA ) RAB = ABS( A(I,ILO+IRAB-1) ) IRAB = IZAMAX( NR, C(I,ILO), LDC ) RAB = MAX( RAB, ABS( C(I,ILO+IRAB-1) ) ) IRAB = IZAMAX( I, DE(1,I+1), 1 ) RAB = MAX( RAB, ABS( DE(IRAB,I+1) ) ) IF( N.GT.I ) THEN IRAB = IZAMAX( N-I, DE(I,I+2), LDDE ) RAB = MAX( RAB, ABS( DE(I,I+IRAB+1) ) ) END IF IRAB = IZAMAX( I, VW(1,I+1), 1 ) RAB = MAX( RAB, ABS( VW(IRAB,I+1) ) ) IF( N.GT.I ) THEN IRAB = IZAMAX( N-I, VW(I,I+2), LDVW ) RAB = MAX( RAB, ABS( VW(I,I+IRAB+1) ) ) END IF C LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) IR = LSCALE(I) + SIGN( HALF, LSCALE(I) ) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE(I) = SCLFAC**IR C ICAB = IZAMAX( N, A(1,I), 1 ) CAB = ABS( A(ICAB,I) ) ICAB = IZAMAX( N, C(1,I), 1 ) CAB = MAX( CAB, ABS( C(ICAB,I) ) ) ICAB = IZAMAX( I, DE(I,1), LDDE ) CAB = MAX( CAB, ABS( DE(I,ICAB) ) ) IF( N.GT.I ) THEN ICAB = IZAMAX( N-I, DE(I+1,I), 1 ) CAB = MAX( CAB, ABS( DE(I+ICAB,I) ) ) END IF ICAB = IZAMAX( I, VW(I,1), LDVW ) CAB = MAX( CAB, ABS( VW(I,ICAB) ) ) IF( N.GT.I ) THEN ICAB = IZAMAX( N-I, VW(I+1,I), 1 ) CAB = MAX( CAB, ABS( VW(I+ICAB,I) ) ) END IF C LRAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) JC = RSCALE(I) + SIGN( HALF, RSCALE(I) ) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LRAB ) RSCALE(I) = SCLFAC**JC 360 CONTINUE C DO 370 I = ILO, N IF( LSCALE(I).NE.ONE .OR. RSCALE(I).NE.ONE ) $ GO TO 380 370 CONTINUE C C Finish the procedure for all scaling factors equal to 1. C NSS = NS0 NHS = NH0 THS = TH0 GO TO 550 C 380 CONTINUE C IF( LOOP ) THEN IF( ITH.LE.-10 ) THEN C C Compute the reciprocal condition number of the left and C right transformations. Continue the loop if it is too C small. C IR = IDAMAX( NR, LSCALE(ILO), 1 ) JC = IDAMAX( NR, RSCALE(ILO), 1 ) T = MAX( LSCALE(ILO+IR-1), RSCALE(ILO+JC-1) ) MN = T DO 390 I = ILO, N IF( LSCALE(I).LT.MN ) $ MN = LSCALE(I) 390 CONTINUE DO 400 I = ILO, N IF( RSCALE(I).LT.MN ) $ MN = RSCALE(I) 400 CONTINUE T = MN/T IF( T.LT.ONE/MXCOND ) THEN TH = TH*TEN GO TO 490 ELSE THS = TH EVNORM = .TRUE. GO TO 520 END IF END IF C C Compute the 1-norms of the scaled submatrices, C without actually scaling them. C NS = ZERO DO 420 J = ILO, N T = ZERO DO 410 I = ILO, N T = T + ABS( A(I,J) )*LSCALE(I)*RSCALE(J) IF( I.LT.J ) THEN T = T + ABS( DE(J,I) )*RSCALE(I)*RSCALE(J) ELSE T = T + ABS( DE(I,J) )*RSCALE(I)*RSCALE(J) END IF 410 CONTINUE IF( T.GT.NS ) $ NS = T 420 CONTINUE C DO 440 J = ILO, N T = ZERO DO 430 I = ILO, N T = T + ABS( A(J,I) )*LSCALE(J)*RSCALE(I) IF( I.LE.J ) THEN T = T + ABS( DE(I,J+1) )*LSCALE(I)*LSCALE(J) ELSE T = T + ABS( DE(J,I+1) )*LSCALE(I)*LSCALE(J) END IF 430 CONTINUE IF( T.GT.NS ) $ NS = T 440 CONTINUE C NH = ZERO DO 460 J = ILO, N T = ZERO DO 450 I = ILO, N T = T + ABS( C(I,J) )*LSCALE(I)*RSCALE(J) IF( I.LT.J ) THEN T = T + ABS( VW(J,I) )*RSCALE(I)*RSCALE(J) ELSE T = T + ABS( VW(I,J) )*RSCALE(I)*RSCALE(J) END IF 450 CONTINUE IF( T.GT.NH ) $ NH = T 460 CONTINUE C DO 480 J = ILO, N T = ZERO DO 470 I = ILO, N T = T + ABS( C(J,I) )*LSCALE(J)*RSCALE(I) IF( I.LE.J ) THEN T = T + ABS( VW(I,J+1) )*LSCALE(I)*LSCALE(J) ELSE T = T + ABS( VW(J,I+1) )*LSCALE(I)*LSCALE(J) END IF 470 CONTINUE IF( T.GT.NH ) $ NH = T 480 CONTINUE C IF( ITH.GE.-4 .AND. ITH.LT.-2 ) THEN PROD = ( NS/DENOM )*( NH/DENOM ) IF( MINPRO.GT.PROD ) THEN MINPRO = PROD STORMN = .TRUE. CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) NSS = NS NHS = NH THS = TH END IF ELSE IF( ITH.GE.-2 ) THEN IF( NS.LT.NH ) THEN RATIO = MIN( NH/NS, SFMAX ) ELSE RATIO = MIN( NS/NH, SFMAX ) END IF IF( MINRAT.GT.RATIO ) THEN MINRAT = RATIO STORMN = .TRUE. CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) MXS = MAX( NS, NH ) NSS = NS NHS = NH THS = TH END IF END IF TH = TH*TEN END IF 490 CONTINUE C C Prepare for scaling. C IF( LOOP ) THEN IF( ITH.LE.-10 ) THEN C C Could not find enough well conditioned transformations C for THRESH <= -10. Set scaling factors to 1 and return. C DUM(1) = ONE CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 ) IWARN = 1 GO TO 550 END IF C C Check if scaling might reduce the accuracy when solving related C eigenproblems, and set the scaling factors to 1 in this case, C if THRESH = -2 or THRESH = -4. C IF( ( MXNORM.LT.MXS .AND. MXNORM.LT.MXS/MXGAIN .AND. ITH.EQ.-2) $ .OR. ITH.EQ.-4 ) THEN IR = IDAMAX( NR, DWORK(KW6), 1 ) JC = IDAMAX( NR, DWORK(KW7), 1 ) T = MAX( DWORK(KW6+IR-1), DWORK(KW7+JC-1) ) MN = T DO 500 I = KW6, KW6+NR-1 IF( DWORK(I).LT.MN ) $ MN = DWORK(I) 500 CONTINUE DO 510 I = KW7, KW7+NR-1 IF( DWORK(I).LT.MN ) $ MN = DWORK(I) 510 CONTINUE T = MN/T IF( T.LT.ONE/MXCOND ) THEN DUM(1) = ONE CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 ) IWARN = 1 NSS = NS0 NHS = NH0 THS = TH0 GO TO 550 END IF END IF IF( STORMN ) THEN CALL DCOPY( NR, DWORK(KW6), 1, LSCALE(ILO), 1 ) CALL DCOPY( NR, DWORK(KW7), 1, RSCALE(ILO), 1 ) ELSE NSS = NS NHS = NH THS = TH END IF END IF C 520 CONTINUE C C Row scaling. C DO 530 I = ILO, N CALL ZDSCAL( NR, LSCALE(I), A(I,ILO), LDA ) CALL ZDSCAL( NR, LSCALE(I), C(I,ILO), LDC ) CALL ZDSCAL( I, LSCALE(I), DE(1,I+1), 1 ) CALL ZDSCAL( N-I+1, LSCALE(I), DE(I,I+1), LDDE ) CALL ZDSCAL( I, LSCALE(I), VW(1,I+1), 1 ) CALL ZDSCAL( N-I+1, LSCALE(I), VW(I,I+1), LDVW ) 530 CONTINUE C C Column scaling. C DO 540 J = ILO, N CALL ZDSCAL( N, RSCALE(J), A(1,J), 1 ) CALL ZDSCAL( N, RSCALE(J), C(1,J), 1 ) CALL ZDSCAL( J, RSCALE(J), DE(J,1), LDDE ) CALL ZDSCAL( N-J+1, RSCALE(J), DE(J,J), 1 ) CALL ZDSCAL( J, RSCALE(J), VW(J,1), LDVW ) CALL ZDSCAL( N-J+1, RSCALE(J), VW(J,J), 1 ) 540 CONTINUE C C Set DWORK(1:5). C 550 CONTINUE IF( EVNORM ) THEN NSS = MA02IZ( 'skew-Hamiltonian', '1-norm', NR, A(ILO,ILO), $ LDA, DE(ILO,ILO), LDDE, DWORK ) NHS = MA02IZ( 'Hamiltonian', '1-norm', NR, C(ILO,ILO), LDC, $ VW(ILO,ILO), LDVW, DWORK ) END IF C DWORK(1) = NS0 DWORK(2) = NH0 DWORK(3) = NSS DWORK(4) = NHS IF( LOOP ) THEN DWORK(5) = THS/MAX( MXNORM, SFMIN ) ELSE DWORK(5) = THRESH END IF C RETURN C *** Last line of MB4DPZ *** END control-4.1.2/src/slicot/src/PaxHeaders/UE01MD.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/UE01MD.f0000644000175000017500000002056315012430707017372 0ustar00lilgelilge00000000000000 INTEGER FUNCTION UE01MD( ISPEC, NAME, OPTS, N1, N2, N3 ) C C PURPOSE C C To provide an extension of the LAPACK routine ILAENV to C machine-specific parameters for SLICOT routines. C C The default values in this version aim to give good performance on C a wide range of computers. For optimal performance, however, the C user is advised to modify this routine. Note that an optimized C BLAS is a crucial prerequisite for any speed gains. For further C details, see ILAENV. C C FUNCTION VALUE C C UE01MD INTEGER C The function value set according to ISPEC. C C ARGUMENTS C C Input/Output Parameters C C ISPEC (input) INTEGER C Specifies the parameter to be returned as the value of C UE01MD, as follows: C = 1: the optimal blocksize; if the returned value is 1, an C unblocked algorithm will give the best performance; C = 2: the minimum block size for which the block routine C should be used; if the usable block size is less than C this value, an unblocked routine should be used; C = 3: the crossover point (in a block routine, for N less C than this value, an unblocked routine should be used) C = 4: the number of shifts, used in the product eigenvalue C routine; C = 8: the crossover point for the multishift QR method for C product eigenvalue problems. C C NAME (input) CHARACTER*(*) C The name of the calling subroutine, in either upper case C or lower case. C C OPTS (input) CHARACTER*(*) C The character options to the subroutine NAME, concatenated C into a single character string. C C N1 (input) INTEGER C N2 (input) INTEGER C N3 (input) INTEGER C Problem dimensions for the subroutine NAME; these may not C all be required. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine ILAHAP). C V. Sima, Aug. 2011, Nov. 2011. C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3 C C .. Local Scalars .. CHARACTER*1 C3 CHARACTER*2 C2 CHARACTER*6 SUBNAM INTEGER I, IC, IZ, NB, NBMIN, NX C .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV C .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, MAX C C .. Executable Statements .. C IF ( ISPEC.EQ.1 .OR. ISPEC.EQ.2 .OR. ISPEC.EQ.3 ) THEN C C Convert NAME to upper case if the first character is lower C case. C UE01MD = 1 SUBNAM = NAME IC = ICHAR( SUBNAM( 1:1 ) ) IZ = ICHAR( 'Z' ) IF ( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN C C ASCII character set. C IF ( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 10 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 10 CONTINUE END IF C ELSE IF ( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN C C EBCDIC character set. C IF ( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1:1 ) = CHAR( IC+64 ) DO 20 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF ( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) $ SUBNAM( I:I ) = CHAR( IC+64 ) 20 CONTINUE END IF C ELSE IF ( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN C C Prime machines: ASCII+128. C IF ( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 30 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF ( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 30 CONTINUE END IF END IF C C2 = SUBNAM( 4:5 ) C3 = SUBNAM( 6:6 ) C IF ( ISPEC.EQ.1 ) THEN C C Block size. C NB = 1 IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN IF ( C3.EQ.'B' ) THEN NB = ILAENV( 1, 'DGEQRF', ' ', N1, N2, -1, -1 ) / 2 ELSE IF ( C3.EQ.'T' ) THEN NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 4 END IF ELSE IF ( C2.EQ.'4P' ) THEN IF ( C3.EQ.'B' ) THEN NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 END IF ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN IF ( C3.EQ.'D' ) THEN NB = ILAENV( 1, 'DORGQR', ' ', N1, N2, N3, -1 ) / 2 ELSE IF ( C3.EQ.'B' ) THEN NB = ILAENV( 1, 'DORMQR', ' ', N1, N2, N3, -1 ) / 2 END IF ELSE IF ( C2.EQ.'4R' ) THEN IF ( C3.EQ.'B' ) THEN NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 END IF END IF UE01MD = NB ELSE IF ( ISPEC.EQ.2 ) THEN C C Minimum block size. C NBMIN = 2 IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN IF ( C3.EQ.'B' ) THEN NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', N1, N2, -1, $ -1 ) / 2 ) ELSE IF ( C3.EQ.'T' ) THEN NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, $ -1 ) / 4 ) END IF ELSE IF ( C2.EQ.'4P' ) THEN IF ( C3.EQ.'B' ) THEN NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, $ -1 ) / 4 ) END IF ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN IF ( C3.EQ.'D' ) THEN NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', N1, N2, N3, $ -1 ) / 2 ) ELSE IF ( C3.EQ.'B' ) THEN NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', ' ', N1, N2, N3, $ -1 ) / 2 ) END IF ELSE IF ( C2.EQ.'4R' ) THEN IF ( C3.EQ.'B' ) THEN NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, $ -1 ) / 4 ) END IF END IF UE01MD = NBMIN ELSE IF ( ISPEC.EQ.3 ) THEN C C Crossover point. C NX = 0 IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN IF ( C3.EQ.'B' ) THEN NX = ILAENV( 3, 'DGEQRF', ' ', N1, N2, -1, -1 ) ELSE IF ( C3.EQ.'T' ) THEN NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 END IF ELSE IF ( C2.EQ.'4P' ) THEN IF ( C3.EQ.'B' ) THEN NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 END IF ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN IF ( C3.EQ.'D' ) THEN NX = ILAENV( 3, 'DORGQR', ' ', N1, N2, N3, -1 ) ELSE IF ( C3.EQ.'B' ) THEN NX = ILAENV( 3, 'DORGQR', ' ', N1, N2, N3, -1 ) END IF ELSE IF ( C2.EQ.'4R' ) THEN IF ( C3.EQ.'B' ) THEN NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 END IF END IF UE01MD = NX END IF ELSE IF ( ISPEC.EQ.4 ) THEN C C Number of shifts (used by MB03XP). C UE01MD = ILAENV( 4, 'DHSEQR', OPTS, N1, N2, N3, -1 ) ELSE IF ( ISPEC.EQ.8 ) THEN C C Crossover point for multishift (used by MB03XP). C UE01MD = ILAENV( 8, 'DHSEQR', OPTS, N1, N2, N3, -1 ) ELSE C C Invalid value for ISPEC. C UE01MD = -1 END IF RETURN C *** Last line of UE01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10TD.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB10TD.f0000644000175000017500000002517015012430707017373 0ustar00lilgelilge00000000000000 SUBROUTINE SB10TD( N, M, NP, NCON, NMEAS, D, LDD, TU, LDTU, TY, $ LDTY, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, $ RCOND, TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the matrices of the H2 optimal discrete-time controller C C | AK | BK | C K = |----|----|, C | CK | DK | C C from the matrices of the controller for the normalized system, C as determined by the SLICOT Library routine SB10SD. 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 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. Only the trailing C NMEAS-by-NCON submatrix D22 is used. C C LDD INTEGER C The leading dimension of the array D. LDD >= max(1,NP). C C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) C The leading M2-by-M2 part of this array must contain the C control transformation matrix TU, as obtained by the C SLICOT Library routine SB10PD. C C LDTU INTEGER C The leading dimension of the array TU. LDTU >= max(1,M2). C C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) C The leading NP2-by-NP2 part of this array must contain the C measurement transformation matrix TY, as obtained by the C SLICOT Library routine SB10PD. C C LDTY INTEGER C The leading dimension of the array TY. C LDTY >= max(1,NP2). C C AK (input/output) DOUBLE PRECISION array, dimension (LDAK,N) C On entry, the leading N-by-N part of this array must C contain controller state matrix for the normalized system C as obtained by the SLICOT Library routine SB10SD. C On exit, the leading N-by-N part of this array contains C controller state matrix AK. C C LDAK INTEGER C The leading dimension of the array AK. LDAK >= max(1,N). C C BK (input/output) DOUBLE PRECISION array, dimension C (LDBK,NMEAS) C On entry, the leading N-by-NMEAS part of this array must C contain controller input matrix for the normalized system C as obtained by the SLICOT Library routine SB10SD. C On exit, the leading N-by-NMEAS part of this array C contains controller input matrix BK. C C LDBK INTEGER C The leading dimension of the array BK. LDBK >= max(1,N). C C CK (input/output) DOUBLE PRECISION array, dimension (LDCK,N) C On entry, the leading NCON-by-N part of this array must C contain controller output matrix for the normalized C system as obtained by the SLICOT Library routine SB10SD. C On exit, the leading NCON-by-N part of this array contains 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 (input/output) DOUBLE PRECISION array, dimension C (LDDK,NMEAS) C On entry, the leading NCON-by-NMEAS part of this array C must contain controller matrix DK for the normalized C system as obtained by the SLICOT Library routine SB10SD. C On exit, the leading NCON-by-NMEAS part of this array C contains 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 C RCOND contains an estimate of the reciprocal condition C number of the matrix Im2 + DKHAT*D22 which must be C inverted in the computation of the controller. C C Tolerances C C TOL DOUBLE PRECISION C Tolerance used in determining the nonsingularity of the C matrix which must be inverted. If TOL <= 0, then a default C value equal to sqrt(EPS) is used, where EPS is the C relative machine precision. C C Workspace C C IWORK INTEGER array, dimension (2*M2) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= max(N*M2,N*NP2,M2*NP2,M2*M2+4*M2). 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 Im2 + DKHAT*D22 is singular, or the C estimated condition number is larger than or equal C to 1/TOL. C C METHOD C C The routine implements the formulas given in [1]. C C REFERENCES C C [1] Zhou, K., Doyle, J.C., and Glover, K. C Robust and Optimal Control. C Prentice-Hall, Upper Saddle River, NJ, 1996. 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 The accuracy of the result depends on the condition numbers of the C input and output transformations and of the matrix Im2 + C DKHAT*D22. 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, May 1999, C Jan. 2000. C C KEYWORDS C C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal C regulator, robust 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, LDAK, LDBK, LDCK, LDD, LDDK, LDTU, LDTY, $ LDWORK, M, N, NCON, NMEAS, NP DOUBLE PRECISION RCOND, TOL C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION AK( LDAK, * ), BK( LDBK, * ), CK( LDCK, * ), $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), $ TU( LDTU, * ), TY( LDTY, * ) C .. C .. Local Scalars .. INTEGER INFO2, IWRK, M1, M2, MINWRK, NP1, NP2 DOUBLE PRECISION ANORM, TOLL C .. C .. External Functions DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE C .. C .. External Subroutines .. EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, DLACPY, DLASET, $ XERBLA C .. C .. Intrinsic Functions .. INTRINSIC 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( LDD.LT.MAX( 1, NP ) ) THEN INFO = -7 ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN INFO = -9 ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN INFO = -11 ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN INFO = -17 ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN INFO = -19 ELSE C C Compute workspace. C MINWRK = MAX ( N*M2, N*NP2, M2*NP2, M2*( M2 + 4 ) ) IF( LDWORK.LT.MINWRK ) $ INFO = -24 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10TD', -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 = ONE RETURN END IF C TOLL = TOL IF( TOLL.LE.ZERO ) THEN C C Set the default value of the tolerance for nonsingularity test. C TOLL = SQRT( DLAMCH( 'Epsilon' ) ) END IF C C Find BKHAT . C CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO, $ DWORK, N ) CALL DLACPY ('Full', N, NP2, DWORK, N, BK, LDBK ) C C Find CKHAT . C CALL DGEMM( 'N', 'N', M2, N, M2, ONE, TU, LDTU, CK, LDCK, ZERO, $ DWORK, M2 ) CALL DLACPY ('Full', M2, N, DWORK, M2, CK, LDCK ) C C Compute DKHAT . C CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DK, LDDK, ZERO, $ DWORK, M2 ) CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK, M2, TY, LDTY, $ ZERO, DK, LDDK ) C C Compute Im2 + DKHAT*D22 . C IWRK = M2*M2 + 1 CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 ) CALL DGEMM( 'N', 'N', 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 = 1 RETURN END IF CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND, DWORK( IWRK ), $ IWORK( M2+1 ), INFO2 ) C C Return if the matrix is singular to working precision. C IF( RCOND.LT.TOLL ) THEN INFO = 1 RETURN END IF C C Compute CK . C CALL DGETRS( 'N', M2, N, DWORK, M2, IWORK, CK, LDCK, INFO2 ) C C Compute DK . C CALL DGETRS( 'N', M2, NP2, DWORK, M2, IWORK, DK, LDDK, INFO2 ) C C Compute AK . C CALL DGEMM( 'N', 'N', N, M2, NP2, ONE, BK, LDBK, D( NP1+1, M1+1 ), $ LDD, ZERO, DWORK, N ) CALL DGEMM( 'N', 'N', N, N, M2, -ONE, DWORK, N, CK, LDCK, ONE, AK, $ LDAK ) C C Compute BK . C CALL DGEMM( 'N', 'N', N, NP2, M2, -ONE, DWORK, N, DK, LDDK, $ ONE, BK, LDBK ) RETURN C *** Last line of SB10TD *** END control-4.1.2/src/slicot/src/PaxHeaders/DG01NY.f0000644000000000000000000000013215012430707016177 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/DG01NY.f0000644000175000017500000000373315012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE DG01NY( INDI, N, XR, XI ) C C PURPOSE C C Auxiliary routine called only by DG01ND. C C For efficiency, no tests of the input scalar parameters are C performed. C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO, EIGHT PARAMETER ( ZERO=0.0D0, HALF=0.5D0, ONE = 1.0D0, $ TWO=2.0D0, EIGHT=8.0D0 ) C .. Scalar Arguments .. CHARACTER INDI INTEGER N C .. Array Arguments .. DOUBLE PRECISION XI(*), XR(*) C .. Local Scalars .. LOGICAL LINDI INTEGER I, J, N2 DOUBLE PRECISION AI, AR, BI, BR, HELPI, HELPR, PI2, WHELP, WI, $ WR, WSTPI, WSTPR C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. Intrinsic Functions .. INTRINSIC ATAN, DBLE, SIN C .. Executable Statements .. C LINDI = LSAME( INDI, 'D' ) C C Initialisation. C PI2 = EIGHT*ATAN( ONE ) IF ( LINDI ) PI2 = -PI2 C WHELP = PI2/DBLE( 2*N ) WSTPI = SIN( WHELP ) WHELP = SIN( HALF*WHELP ) WSTPR = -TWO*WHELP*WHELP WI = ZERO C IF ( LINDI ) THEN WR = ONE XR(N+1) = XR(1) XI(N+1) = XI(1) ELSE WR = -ONE END IF C C Recursion. C N2 = N/2 + 1 DO 10 I = 1, N2 J = N + 2 - I AR = XR(I) + XR(J) AI = XI(I) - XI(J) BR = XI(I) + XI(J) BI = XR(J) - XR(I) IF ( LINDI ) THEN AR = HALF*AR AI = HALF*AI BR = HALF*BR BI = HALF*BI END IF HELPR = WR*BR - WI*BI HELPI = WR*BI + WI*BR XR(I) = AR + HELPR XI(I) = AI + HELPI XR(J) = AR - HELPR XI(J) = HELPI - AI WHELP = WR WR = WR + WR*WSTPR - WI*WSTPI WI = WI + WI*WSTPR + WHELP*WSTPI 10 CONTINUE C RETURN C *** Last line of DG01NY *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03BW.f0000644000000000000000000000013215012430707016202 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SG03BW.f0000644000175000017500000003317615012430707017410 0ustar00lilgelilge00000000000000 SUBROUTINE SG03BW( TRANS, M, N, A, LDA, C, LDC, E, LDE, D, LDD, X, $ LDX, SCALE, INFO ) C C PURPOSE C C To solve for X the generalized Sylvester equation C C T T C A * X * C + E * X * D = SCALE * Y, (1) C C or the transposed equation C C T T C A * X * C + E * X * D = SCALE * Y, (2) C C where A and E are real M-by-M matrices, C and D are real N-by-N C matrices, X and Y are real M-by-N matrices. N is either 1 or 2. C The pencil A - lambda * E must be in generalized real Schur form C (A upper quasitriangular, E upper triangular). SCALE is an output C scale factor, set to avoid 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 M (input) INTEGER C The order of the matrices A and E. M >= 0. C C N (input) INTEGER C The order of the matrices C and D. N = 1 or N = 2. C C A (input) DOUBLE PRECISION array, dimension (LDA,M) C The leading M-by-M part of this array must contain the C upper quasitriangular matrix A. The elements below the C upper Hessenberg part are not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,M). C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C The leading N-by-N part of this array must contain the C matrix C. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,N). C C E (input) DOUBLE PRECISION array, dimension (LDE,M) C The leading M-by-M part of this array must contain the C upper triangular matrix E. The elements below the main C diagonal are not referenced. C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,M). C C D (input) DOUBLE PRECISION array, dimension (LDD,N) C The leading N-by-N part of this array must contain the C matrix D. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1,N). C C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) C On entry, the leading M-by-N part of this array must C contain the right hand side matrix Y. C On exit, the leading M-by-N part of this array contains C the solution matrix X. C C LDX INTEGER C The leading dimension of the array X. LDX >= MAX(1,M). 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: the generalized Sylvester equation is (nearly) C singular to working precision; perturbed values C were used to solve the equation (but the matrices C A, C, D, and E are unchanged). C C METHOD C C The method used by the routine is based on a generalization of the C algorithm due to Bartels and Stewart [1]. See also [2] and [3] for C 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] Gardiner, J.D., Laub, A.J., Amato, J.J., Moler, C.B. C Solution of the Sylvester Matrix Equation C A X B**T + C X D**T = E. C A.C.M. Trans. Math. Soft., vol. 18, no. 2, pp. 223-231, 1992. 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 routine requires about 2 * N * M**2 flops. Note that we count C a 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 FURTHER COMMENTS C C When near singularity is detected, perturbed values are used C to solve the equation (but the given matrices are unchanged). C C CONTRIBUTOR C C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. C C REVISIONS C C Sep. 1998, Dec. 2021 (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, LDC, LDD, LDE, LDX, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), C(LDC,*), D(LDD,*), E(LDE,*), X(LDX,*) C .. Local Scalars .. DOUBLE PRECISION SCALE1 INTEGER DIMMAT, I, INFO1, J, MA, MAI, MAJ, MB, ME 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 DCOPY, DGEMM, DGESC2, DGETC2, DLASCL, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C Decode input parameters. C NOTRNS = LSAME( TRANS, 'N' ) C C Check the scalar input parameters. C IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN INFO = -1 ELSEIF ( M.LT.0 ) THEN INFO = -2 ELSEIF ( N.NE.1 .AND. N.NE.2 ) THEN INFO = -3 ELSEIF ( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSEIF ( LDC.LT.MAX( 1, N ) ) THEN INFO = -7 ELSEIF ( LDE.LT.MAX( 1, M ) ) THEN INFO = -9 ELSEIF ( LDD.LT.MAX( 1, N ) ) THEN INFO = -11 ELSEIF ( LDX.LT.MAX( 1, M ) ) THEN INFO = -13 ELSE INFO = 0 END IF IF ( INFO.NE.0 ) THEN CALL XERBLA( 'SG03BW', -INFO ) RETURN END IF C SCALE = ONE C C Quick return if possible. C IF ( M.EQ.0 ) $ RETURN C IF ( NOTRNS ) THEN C C Solve equation (1). C C Compute block row X(MA:ME,:). MB denotes the number of rows in C this block row. C ME = 0 C WHILE ( ME.NE.M ) DO 20 CONTINUE IF ( ME.NE.M ) THEN MA = ME + 1 IF ( MA.EQ.M ) THEN ME = M MB = 1 ELSE IF ( A(MA+1,MA).EQ.ZERO ) THEN ME = MA MB = 1 ELSE ME = MA + 1 MB = 2 END IF END IF C C Assemble Kronecker product system of linear equations with C matrix C C MAT = kron(C',A(MA:ME,MA:ME)') + kron(D',E(MA:ME,MA:ME)') C C and right hand side C C RHS = vec(X(MA:ME,:)). C IF ( N.EQ.1 ) THEN DIMMAT = MB DO 60 I = 1, MB MAI = MA + I - 1 DO 40 J = 1, MB MAJ = MA + J - 1 MAT(I,J) = C(1,1)*A(MAJ,MAI) IF ( MAJ.LE.MAI ) $ MAT(I,J) = MAT(I,J) + D(1,1)*E(MAJ,MAI) 40 CONTINUE RHS(I) = X(MAI,1) 60 CONTINUE ELSE DIMMAT = 2*MB DO 100 I = 1, MB MAI = MA + I - 1 DO 80 J = 1, MB MAJ = MA + J - 1 MAT(I,J) = C(1,1)*A(MAJ,MAI) MAT(MB+I,J) = C(1,2)*A(MAJ,MAI) MAT(I,MB+J) = C(2,1)*A(MAJ,MAI) MAT(MB+I,MB+J) = C(2,2)*A(MAJ,MAI) IF ( MAJ.LE.MAI ) THEN MAT(I,J) = MAT(I,J) + D(1,1)*E(MAJ,MAI) MAT(MB+I,J) = MAT(MB+I,J) + D(1,2)*E(MAJ,MAI) MAT(I,MB+J) = MAT(I,MB+J) + D(2,1)*E(MAJ,MAI) MAT(MB+I,MB+J) = MAT(MB+I,MB+J) + $ D(2,2)*E(MAJ,MAI) END IF 80 CONTINUE RHS(I) = X(MAI,1) RHS(MB+I) = X(MAI,2) 100 CONTINUE END IF C C Solve the system of linear equations. C CALL DGETC2( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) IF ( INFO1.NE.0 ) $ INFO = 1 CALL DGESC2( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE CALL DLASCL( 'G', 0, 0, ONE, SCALE1, M, N, X, LDX, INFO1) END IF C CALL DCOPY( MB, RHS, 1, X(MA,1), 1 ) IF ( N.EQ.2 ) $ CALL DCOPY( MB, RHS(MB+1), 1, X(MA,2), 1 ) C C Update right hand sides. C C X(ME+1:M,:) = X(ME+1:M,:) - A(MA:ME,ME+1:M)'*X(MA:ME,:)*C C C X(ME+1:M,:) = X(ME+1:M,:) - E(MA:ME,ME+1:M)'*X(MA:ME,:)*D C IF ( ME.LT.M ) THEN CALL DGEMM( 'N', 'N', MB, N, N, ONE, X(MA,1), LDX, C, $ LDC, ZERO, TM, 2 ) CALL DGEMM( 'T', 'N', M-ME, N, MB, MONE, A(MA,ME+1), LDA, $ TM, 2, ONE, X(ME+1,1), LDX ) CALL DGEMM( 'N', 'N', MB, N, N, ONE, X(MA,1), LDX, D, $ LDD, ZERO, TM, 2 ) CALL DGEMM( 'T', 'N', M-ME, N, MB, MONE, E(MA,ME+1), LDE, $ TM, 2, ONE, X(ME+1,1), LDX ) END IF C GOTO 20 END IF C END WHILE 20 C ELSE C C Solve equation (2). C C Compute block row X(MA:ME,:). MB denotes the number of rows in C this block row. C MA = M + 1 C WHILE ( MA.NE.1 ) DO 120 CONTINUE IF ( MA.NE.1 ) THEN ME = MA - 1 IF ( ME.EQ.1 ) THEN MA = 1 MB = 1 ELSE IF ( A(ME,ME-1).EQ.ZERO ) THEN MA = ME MB = 1 ELSE MA = ME - 1 MB = 2 END IF END IF C C Assemble Kronecker product system of linear equations with C matrix C C MAT = kron(C,A(MA:ME,MA:ME)) + kron(D,E(MA:ME,MA:ME)) C C and right hand side C C RHS = vec(X(MA:ME,:)). C IF ( N.EQ.1 ) THEN DIMMAT = MB DO 160 I = 1, MB MAI = MA + I - 1 DO 140 J = 1, MB MAJ = MA + J - 1 MAT(I,J) = C(1,1)*A(MAI,MAJ) IF ( MAJ.GE.MAI ) $ MAT(I,J) = MAT(I,J) + D(1,1)*E(MAI,MAJ) 140 CONTINUE RHS(I) = X(MAI,1) 160 CONTINUE ELSE DIMMAT = 2*MB DO 200 I = 1, MB MAI = MA + I - 1 DO 180 J = 1, MB MAJ = MA + J - 1 MAT(I,J) = C(1,1)*A(MAI,MAJ) MAT(MB+I,J) = C(2,1)*A(MAI,MAJ) MAT(I,MB+J) = C(1,2)*A(MAI,MAJ) MAT(MB+I,MB+J) = C(2,2)*A(MAI,MAJ) IF ( MAJ.GE.MAI ) THEN MAT(I,J) = MAT(I,J) + D(1,1)*E(MAI,MAJ) MAT(MB+I,J) = MAT(MB+I,J) + D(2,1)*E(MAI,MAJ) MAT(I,MB+J) = MAT(I,MB+J) + D(1,2)*E(MAI,MAJ) MAT(MB+I,MB+J) = MAT(MB+I,MB+J) + $ D(2,2)*E(MAI,MAJ) END IF 180 CONTINUE RHS(I) = X(MAI,1) RHS(MB+I) = X(MAI,2) 200 CONTINUE END IF C C Solve the system of linear equations. C CALL DGETC2( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) IF ( INFO1.NE.0 ) $ INFO = 1 CALL DGESC2( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE CALL DLASCL( 'G', 0, 0, ONE, SCALE1, M, N, X, LDX, INFO1) END IF C CALL DCOPY( MB, RHS, 1, X(MA,1), 1 ) IF ( N.EQ.2 ) $ CALL DCOPY( MB, RHS(MB+1), 1, X(MA,2), 1 ) C C Update right hand sides. C C X(1:MA-1,:) = X(1:MA-1,:) - A(1:MA-1,MA:ME)*X(MA:ME,:)*C' C C X(1:MA-1,:) = X(1:MA-1,:) - E(1:MA-1,MA:ME)*X(MA:ME,:)*D' C IF ( MA.GT.1 ) THEN CALL DGEMM( 'N', 'T', MB, N, N, ONE, X(MA,1), LDX, C, $ LDC, ZERO, TM, 2 ) CALL DGEMM( 'N', 'N', MA-1, N, MB, MONE, A(1,MA), LDA, $ TM, 2, ONE, X, LDX ) CALL DGEMM( 'N', 'T', MB, N, N, ONE, X(MA,1), LDX, D, $ LDD, ZERO, TM, 2 ) CALL DGEMM( 'N', 'N', MA-1, N, MB, MONE, E(1,MA), LDE, $ TM, 2, ONE, X, LDX ) END IF C GOTO 120 END IF C END WHILE 120 C END IF C RETURN C *** Last line of SG03BW *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03RD.f0000644000000000000000000000013215012430707016164 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03RD.f0000644000175000017500000005234015012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE MB03RD( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS, $ BLSIZE, WR, WI, TOL, DWORK, INFO ) C C PURPOSE C C To reduce a matrix A in real Schur form to a block-diagonal form C using well-conditioned non-orthogonal similarity transformations. C The condition numbers of the transformations used for reduction C are roughly bounded by PMAX, where PMAX is a given value. C The transformations are optionally postmultiplied in a given C matrix X. The real Schur form is optionally ordered, so that C clustered eigenvalues are grouped in the same block. C C ARGUMENTS C C Mode Parameters C C JOBX CHARACTER*1 C Specifies whether or not the transformations are C accumulated, as follows: C = 'N': The transformations are not accumulated; C = 'U': The transformations are accumulated in X (the C given matrix X is updated). C C SORT CHARACTER*1 C Specifies whether or not the diagonal blocks of the real C Schur form are reordered, as follows: C = 'N': The diagonal blocks are not reordered; C = 'S': The diagonal blocks are reordered before each C step of reduction, so that clustered eigenvalues C appear in the same block; C = 'C': The diagonal blocks are not reordered, but the C "closest-neighbour" strategy is used instead of C the standard "closest to the mean" strategy C (see METHOD); C = 'B': The diagonal blocks are reordered before each C step of reduction, and the "closest-neighbour" C strategy is used (see METHOD). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and X. N >= 0. C C PMAX (input) DOUBLE PRECISION C An upper bound for the infinity norm of elementary C submatrices of the individual transformations used for C reduction (see METHOD). PMAX >= 1.0D0. 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 block-diagonalized, in real C Schur form. C On exit, the leading N-by-N part of this array contains C the computed block-diagonal matrix, in real Schur C canonical form. The non-diagonal blocks are set to zero. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) C On entry, if JOBX = 'U', the leading N-by-N part of this C array must contain a given matrix X. C On exit, if JOBX = 'U', the leading N-by-N part of this C array contains the product of the given matrix X and the C transformation matrix that reduced A to block-diagonal C form. The transformation matrix is itself a product of C non-orthogonal similarity transformations having elements C with magnitude less than or equal to PMAX. C If JOBX = 'N', this array is not referenced. C C LDX INTEGER C The leading dimension of array X. C LDX >= 1, if JOBX = 'N'; C LDX >= MAX(1,N), if JOBX = 'U'. C C NBLCKS (output) INTEGER C The number of diagonal blocks of the matrix A. C C BLSIZE (output) INTEGER array, dimension (N) C The first NBLCKS elements of this array contain the orders C of the resulting diagonal blocks of the matrix A. C C WR, (output) DOUBLE PRECISION arrays, dimension (N) C WI These arrays contain the real and imaginary parts, C respectively, of the eigenvalues of the matrix A. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in the ordering of the diagonal C blocks of the real Schur form matrix. C If the user sets TOL > 0, then the given value of TOL is C used as an absolute tolerance: a block i and a temporarily C fixed block 1 (the first block of the current trailing C submatrix to be reduced) are considered to belong to the C same cluster if their eigenvalues satisfy C C | lambda_1 - lambda_i | <= TOL. C C If the user sets TOL < 0, then the given value of TOL is C used as a relative tolerance: a block i and a temporarily C fixed block 1 are considered to belong to the same cluster C if their eigenvalues satisfy, for j = 1, ..., N, C C | lambda_1 - lambda_i | <= | TOL | * max | lambda_j |. C C If the user sets TOL = 0, then an implicitly computed, C default tolerance, defined by TOL = SQRT( SQRT( EPS ) ) C is used instead, as a relative tolerance, where EPS is C the machine precision (see LAPACK Library routine DLAMCH). C If SORT = 'N' or 'C', this parameter is not referenced. 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 METHOD C C Consider first that SORT = 'N'. Let C C ( A A ) C ( 11 12 ) C A = ( ), C ( 0 A ) C ( 22 ) C C be the given matrix in real Schur form, where initially A is the C 11 C first diagonal block of dimension 1-by-1 or 2-by-2. An attempt is C made to compute a transformation matrix X of the form C C ( I P ) C X = ( ) (1) C ( 0 I ) C C (partitioned as A), so that C C ( A 0 ) C -1 ( 11 ) C X A X = ( ), C ( 0 A ) C ( 22 ) C C and the elements of P do not exceed the value PMAX in magnitude. C An adaptation of the standard method for solving Sylvester C equations [1], which controls the magnitude of the individual C elements of the computed solution [2], is used to obtain matrix P. C When this attempt failed, an 1-by-1 (or 2-by-2) diagonal block of C A , whose eigenvalue(s) is (are) the closest to the mean of those C 22 C of A is selected, and moved by orthogonal similarity C 11 C transformations in the leading position of A ; the moved diagonal C 22 C block is then added to the block A , increasing its order by 1 C 11 C (or 2). Another attempt is made to compute a suitable C transformation matrix X with the new definitions of the blocks A C 11 C and A . After a successful transformation matrix X has been C 22 C obtained, it postmultiplies the current transformation matrix C (if JOBX = 'U'), and the whole procedure is repeated for the C matrix A . C 22 C C When SORT = 'S', the diagonal blocks of the real Schur form are C reordered before each step of the reduction, so that each cluster C of eigenvalues, defined as specified in the definition of TOL, C appears in adjacent blocks. The blocks for each cluster are merged C together, and the procedure described above is applied to the C larger blocks. Using the option SORT = 'S' will usually provide C better efficiency than the standard option (SORT = 'N'), proposed C in [2], because there could be no or few unsuccessful attempts C to compute individual transformation matrices X of the form (1). C However, the resulting dimensions of the blocks are usually C larger; this could make subsequent calculations less efficient. C C When SORT = 'C' or 'B', the procedure is similar to that for C SORT = 'N' or 'S', respectively, but the block of A whose C 22 C eigenvalue(s) is (are) the closest to those of A (not to their C 11 C mean) is selected and moved to the leading position of A . This C 22 C is called the "closest-neighbour" strategy. C C REFERENCES C C [1] 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 [2] Bavely, C. and Stewart, G.W. C An Algorithm for Computing Reducing Subspaces by Block C Diagonalization. C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. C C [3] Demmel, J. C The Condition Number of Equivalence Transformations that C Block Diagonalize Matrix Pencils. C SIAM J. Numer. Anal., 20, pp. 599-610, 1983. C C NUMERICAL ASPECTS C 3 4 C The algorithm usually requires 0(N ) operations, but 0(N ) are C possible in the worst case, when all diagonal blocks in the real C Schur form of A are 1-by-1, and the matrix cannot be diagonalized C by well-conditioned transformations. C C FURTHER COMMENTS C C The individual non-orthogonal transformation matrices used in the C reduction of A to a block-diagonal form have condition numbers C of the order PMAX. This does not guarantee that their product C is well-conditioned enough. The routine can be easily modified to C provide estimates for the condition numbers of the clusters of C eigenvalues. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. C Partly based on the RASP routine BDIAG by A. Varga, German C Aerospace Center, DLR Oberpfaffenhofen. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003, C Feb. 2022. C C KEYWORDS C C Diagonalization, 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 JOBX, SORT INTEGER INFO, LDA, LDX, N, NBLCKS DOUBLE PRECISION PMAX, TOL C .. Array Arguments .. INTEGER BLSIZE(*) DOUBLE PRECISION A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*) C .. Local Scalars .. LOGICAL LJOBX, LSORN, LSORS, LSORT CHARACTER JOBV INTEGER DA11, DA22, I, IERR, J, K, L, L11, L22, L22M1 DOUBLE PRECISION C, CAV, D, EDIF, EMAX, RAV, SAFEMN, SC, THRESH C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2, LSAME C .. External Subroutines .. EXTERNAL DGEMM, DLABAD, DLASET, DSCAL, MA02AD, MB03QX, $ MB03RX, MB03RY, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 LJOBX = LSAME( JOBX, 'U' ) LSORN = LSAME( SORT, 'N' ) LSORS = LSAME( SORT, 'S' ) LSORT = LSAME( SORT, 'B' ) .OR. LSORS IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LSORN .AND. .NOT.LSORT .AND. $ .NOT.LSAME( SORT, 'C' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( PMAX.LT.ONE ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( ( LDX.LT.1 ) .OR. ( LJOBX .AND. LDX.LT.N ) ) THEN INFO = -8 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB03RD', -INFO ) RETURN END IF C C Quick return if possible. C NBLCKS = 0 IF( N.EQ.0 ) $ RETURN C C Set the "safe" minimum positive number with representable C reciprocal, and set JOBV parameter for MB03RX routine. C SAFEMN = DLAMCH( 'Safe minimum' ) SC = ONE / SAFEMN CALL DLABAD( SAFEMN, SC ) SAFEMN = SAFEMN / DLAMCH( 'Precision' ) JOBV = JOBX IF ( LJOBX ) $ JOBV = 'V' C C Compute the eigenvalues of A and set the tolerance for reordering C the eigenvalues in clusters, if needed. C CALL MB03QX( N, A, LDA, WR, WI, INFO ) C IF ( LSORT ) THEN THRESH = ABS( TOL ) IF ( THRESH.EQ.ZERO ) THEN C C Use the default tolerance in ordering the blocks. C THRESH = SQRT( SQRT( DLAMCH( 'Epsilon' ) ) ) END IF C IF ( TOL.LE.ZERO ) THEN C C Use a relative tolerance. Find max | lambda_j |, j = 1 : N. C EMAX = ZERO L = 1 C WHILE ( L.LE.N ) DO 10 IF ( L.LE.N ) THEN IF ( WI(L).EQ.ZERO ) THEN EMAX = MAX( EMAX, ABS( WR(L) ) ) L = L + 1 ELSE EMAX = MAX( EMAX, DLAPY2( WR(L), WI(L) ) ) L = L + 2 END IF GO TO 10 END IF C END WHILE 10 THRESH = THRESH * EMAX END IF END IF C C Define the following submatrices of A: C A11, the DA11-by-DA11 block in position (L11,L11); C A22, the DA22-by-DA22 block in position (L22,L22); C A12, the DA11-by-DA22 block in position (L11,L22); C A21, the DA22-by-DA11 block in position (L22,L11) (null initially C and finally). C The following loop uses L11 as loop variable and try to separate a C block in position (L11,L11), with possibly clustered eigenvalues, C separated by the other eigenvalues (in the block A22). C L11 = 1 C WHILE ( L11.LE.N ) DO 20 IF ( L11.LE.N ) THEN NBLCKS = NBLCKS + 1 IF ( WI(L11).EQ.ZERO ) THEN DA11 = 1 ELSE DA11 = 2 END IF C IF ( LSORT ) THEN C C The following loop, using K as loop variable, finds the C blocks whose eigenvalues are close to those of A11 and C moves these blocks (if any) to the leading position of A22. C L22 = L11 + DA11 K = L22 C WHILE ( K.LE.N ) DO 30 IF ( K.LE.N ) THEN EDIF = DLAPY2( WR(L11) - WR(K), WI(L11) - WI(K) ) IF ( EDIF.LE.THRESH ) THEN C C An 1x1 or a 2x2 block of A22 has been found so that C C abs( lambda_1 - lambda_k ) <= THRESH C C where lambda_1 and lambda_k denote an eigenvalue C of A11 and of that block in A22, respectively. C Try to move that block to the leading position of A22. C CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI, $ DWORK ) C C Extend A11 with the leading block of A22. C IF ( WI(L22).EQ.ZERO ) THEN DA11 = DA11 + 1 ELSE DA11 = DA11 + 2 END IF L22 = L11 + DA11 END IF IF ( WI(K).EQ.ZERO ) THEN K = K + 1 ELSE K = K + 2 END IF GO TO 30 END IF C END WHILE 30 END IF C C The following loop uses L22 as loop variable and forms a C separable DA11-by-DA11 block A11 in position (L11,L11). C L22 = L11 + DA11 L22M1 = L22 - 1 C WHILE ( L22.LE.N ) DO 40 IF ( L22.LE.N ) THEN DA22 = N - L22M1 C C Try to separate the block A11 of order DA11 by using a C well-conditioned similarity transformation. C C First save A12' in the block A21. C CALL MA02AD( 'Full', DA11, DA22, A(L11,L22), LDA, $ A(L22,L11), LDA ) C C Solve -A11*P + P*A22 = A12. C CALL MB03RY( DA11, DA22, PMAX, A(L11,L11), LDA, A(L22,L22), $ LDA, A(L11,L22), LDA, IERR ) C IF ( IERR.EQ.1 ) THEN C C The annihilation of A12 failed. Restore A12 and A21. C CALL MA02AD( 'Full', DA22, DA11, A(L22,L11), LDA, $ A(L11,L22), LDA ) CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11), $ LDA ) C IF ( LSORN .OR. LSORS ) THEN C C Extend A11 with an 1x1 or 2x2 block of A22 having the C nearest eigenvalues to the mean of eigenvalues of A11 C and resume the loop. C First compute the mean of eigenvalues of A11. C RAV = ZERO CAV = ZERO C DO 50 I = L11, L22M1 RAV = RAV + WR(I) CAV = CAV + ABS( WI(I) ) 50 CONTINUE C RAV = RAV/DA11 CAV = CAV/DA11 C C Loop to find the eigenvalue of A22 nearest to the C above computed mean. C D = DLAPY2( RAV-WR(L22), CAV-WI(L22) ) K = L22 IF ( WI(L22).EQ.ZERO ) THEN L = L22 + 1 ELSE L = L22 + 2 END IF C WHILE ( L.LE.N ) DO 60 IF ( L.LE.N ) THEN C = DLAPY2( RAV-WR(L), CAV-WI(L) ) IF ( C.LT.D ) THEN D = C K = L END IF IF ( WI(L).EQ.ZERO ) THEN L = L + 1 ELSE L = L + 2 END IF GO TO 60 END IF C END WHILE 60 C ELSE C C Extend A11 with an 1x1 or 2x2 block of A22 having the C nearest eigenvalues to the cluster of eigenvalues of C A11 and resume the loop. C C Loop to find the eigenvalue of A22 of minimum distance C to the cluster. C D = SC L = L22 K = L22 C WHILE ( L.LE.N ) DO 70 IF ( L.LE.N ) THEN I = L11 C WHILE ( I.LE.L22M1 ) DO 80 IF ( I.LE.L22M1 ) THEN C = DLAPY2( WR(I)-WR(L), WI(I)-WI(L) ) IF ( C.LT.D ) THEN D = C K = L END IF IF ( WI(I).EQ.ZERO ) THEN I = I + 1 ELSE I = I + 2 END IF GO TO 80 END IF C END WHILE 80 IF ( WI(L).EQ.ZERO ) THEN L = L + 1 ELSE L = L + 2 END IF GO TO 70 END IF C END WHILE 70 END IF C C Try to move block found to the leading position of A22. C CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI, $ DWORK ) C C Extend A11 with the leading block of A22. C IF ( WI(L22).EQ.ZERO ) THEN DA11 = DA11 + 1 ELSE DA11 = DA11 + 2 END IF L22 = L11 + DA11 L22M1 = L22 - 1 GO TO 40 END IF END IF C END WHILE 40 C IF ( LJOBX ) THEN C C Accumulate the transformation in X. C Only columns L22, ..., N are modified. C IF ( L22.LE.N ) $ CALL DGEMM( 'No transpose', 'No transpose', N, DA22, $ DA11, ONE, X(1,L11), LDX, A(L11,L22), LDA, $ ONE, X(1,L22), LDX ) C C Scale to unity the (non-zero) columns of X which will be C no more modified and transform A11 accordingly. C DO 90 J = L11, L22M1 SC = DNRM2( N, X(1,J), 1 ) IF ( SC.GT.SAFEMN ) THEN CALL DSCAL( DA11, SC, A(J,L11), LDA ) SC = ONE/SC CALL DSCAL( N, SC, X(1,J), 1 ) CALL DSCAL( DA11, SC, A(L11,J), 1 ) END IF 90 CONTINUE C END IF IF ( L22.LE.N ) THEN C C Set A12 and A21 to zero. C CALL DLASET( 'Full', DA11, DA22, ZERO, ZERO, A(L11,L22), $ LDA ) CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11), $ LDA ) END IF C C Store the orders of the diagonal blocks in BLSIZE. C BLSIZE(NBLCKS) = DA11 L11 = L22 GO TO 20 END IF C END WHILE 20 C RETURN C *** Last line of MB03RD *** END control-4.1.2/src/slicot/src/PaxHeaders/MD03BY.f0000644000000000000000000000013015012430707016171 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MD03BY.f0000644000175000017500000003733415012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, $ RANK, X, RX, TOL, DWORK, LDWORK, INFO ) C C PURPOSE C C To determine a value for the parameter PAR such that if x solves C the system C C A*x = b , sqrt(PAR)*D*x = 0 , C C in the least squares sense, where A is an m-by-n matrix, D is an C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, C then either PAR is zero and C C ( DXNORM - DELTA ) .LE. 0.1*DELTA , C C or PAR is positive and C C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . C C It is assumed that a QR factorization, with column pivoting, of A C is available, that is, A*P = Q*R, where P is a permutation matrix, C Q has orthogonal columns, and R is an upper triangular matrix C with diagonal elements of nonincreasing magnitude. C The routine needs the full upper triangle of R, the permutation C matrix P, and the first n components of Q'*b (' denotes the C transpose). On output, MD03BY also provides an upper triangular C matrix S such that C C P'*(A'*A + PAR*D*D)*P = S'*S . C C Matrix S is used in the solution process. C C ARGUMENTS C C Mode Parameters C C COND CHARACTER*1 C Specifies whether the condition of the matrices R and S C should be estimated, as follows: C = 'E' : use incremental condition estimation for R and S; C = 'N' : do not use condition estimation, but check the C diagonal entries of R and S for zero values; C = 'U' : use the rank already stored in RANK (for R). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix R. N >= 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 full upper triangle is unaltered, and the C strict lower triangle contains the strict upper triangle C (transposed) of the upper triangular matrix S. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C IPVT (input) INTEGER array, dimension (N) C This array must define the permutation matrix P such that C A*P = Q*R. Column j of P is column IPVT(j) of the identity C matrix. C C DIAG (input) DOUBLE PRECISION array, dimension (N) C This array must contain the diagonal elements of the C matrix D. DIAG(I) <> 0, I = 1,...,N. C C QTB (input) DOUBLE PRECISION array, dimension (N) C This array must contain the first n elements of the C vector Q'*b. C C DELTA (input) DOUBLE PRECISION C An upper bound on the Euclidean norm of D*x. DELTA > 0. C C PAR (input/output) DOUBLE PRECISION C On entry, PAR must contain an initial estimate of the C Levenberg-Marquardt parameter. PAR >= 0. C On exit, it contains the final estimate of this parameter. C C RANK (input or output) INTEGER C On entry, if COND = 'U', this parameter must contain the C (numerical) rank of the matrix R. C On exit, this parameter contains the numerical rank of C the matrix S. C C X (output) DOUBLE PRECISION array, dimension (N) C This array contains the least squares solution of the C system A*x = b, sqrt(PAR)*D*x = 0. C C RX (output) DOUBLE PRECISION array, dimension (N) C This array contains the matrix-vector product -R*P'*x. C C Tolerances C C TOL DOUBLE PRECISION C If COND = 'E', the tolerance to be used for finding the C rank of the matrices R and S. If the user sets TOL > 0, C then the given value of TOL is used as a lower bound for C the reciprocal condition number; a (sub)matrix whose C estimated condition number is less than 1/TOL is C considered to be of full rank. If the user sets TOL <= 0, C then an implicitly computed, default tolerance, defined by C TOLDEF = N*EPS, is used instead, where EPS is the machine C precision (see LAPACK Library routine DLAMCH). C This parameter is not relevant if COND = 'U' or 'N'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, the first N elements of this array contain the C diagonal elements of the upper triangular matrix S. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 4*N, if COND = 'E'; C LDWORK >= 2*N, if COND <> 'E'. 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 algorithm computes the Gauss-Newton direction. A least squares C solution is found if the Jacobian is rank deficient. If the Gauss- C Newton direction is not acceptable, then an iterative algorithm C obtains improved lower and upper bounds for the parameter PAR. C Only a few iterations are generally needed for convergence of the C algorithm. If, however, the limit of ITMAX = 10 iterations is C reached, then the output PAR will contain the best value obtained C so far. If the Gauss-Newton step is acceptable, it is stored in x, C and PAR is set to zero, hence S = R. C C REFERENCES C C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. C User's Guide for MINPACK-1. C Applied Math. Division, Argonne National Laboratory, Argonne, C Illinois, Report ANL-80-74, 1980. C C NUMERICAL ASPECTS C 2 C The algorithm requires 0(N ) operations and is backward stable. C C FURTHER COMMENTS C C This routine is a LAPACK-based modification of LMPAR from the C MINPACK package [1], and with optional condition estimation. C The option COND = 'U' is useful when dealing with several C right-hand side vectors, but RANK should be reset. C If COND = 'E', but the matrix S is guaranteed to be nonsingular C and well conditioned relative to TOL, i.e., rank(R) = N, and C min(DIAG) > 0, then its condition is not estimated. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. C C KEYWORDS C C Linear system of equations, matrix operations, plane rotations. C C ****************************************************************** C C .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 10 ) DOUBLE PRECISION P1, P001, ZERO, SVLMAX PARAMETER ( P1 = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0, $ SVLMAX = 0.0D0 ) C .. Scalar Arguments .. CHARACTER COND INTEGER INFO, LDR, LDWORK, N, RANK DOUBLE PRECISION DELTA, PAR, TOL C .. Array Arguments .. INTEGER IPVT(*) DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) C .. Local Scalars .. INTEGER ITER, J, L, N2 DOUBLE PRECISION DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL, $ PARU, TEMP, TOLDEF LOGICAL ECOND, NCOND, SING, UCOND CHARACTER CONDL C .. Local Arrays .. DOUBLE PRECISION DUM(3) C .. External Functions .. DOUBLE PRECISION DDOT, DLAMCH, DNRM2 LOGICAL LSAME EXTERNAL DDOT, DLAMCH, DNRM2, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSWAP, DTRMV, DTRSV, MB02YD, $ MB03OD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT C .. C .. Executable Statements .. C C Check the scalar input parameters. C ECOND = LSAME( COND, 'E' ) NCOND = LSAME( COND, 'N' ) UCOND = LSAME( COND, 'U' ) INFO = 0 IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN INFO = -1 ELSEIF( N.LT.0 ) THEN INFO = -2 ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN INFO = -4 ELSEIF ( DELTA.LE.ZERO ) THEN INFO = -8 ELSEIF( PAR.LT.ZERO ) THEN INFO = -9 ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN INFO = -10 ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN INFO = -15 ELSEIF ( N.GT.0 ) THEN DMINO = DIAG(1) SING = .FALSE. C DO 10 J = 1, N IF ( DIAG(J).LT.DMINO ) $ DMINO = DIAG(J) SING = SING .OR. DIAG(J).EQ.ZERO 10 CONTINUE C IF ( SING ) $ INFO = -6 END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MD03BY', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN PAR = ZERO RANK = 0 RETURN END IF C C DWARF is the smallest positive magnitude. C DWARF = DLAMCH( 'Underflow' ) N2 = N C C Estimate the rank of R, if required. C IF ( ECOND ) THEN N2 = 2*N TEMP = TOL IF ( TEMP.LE.ZERO ) THEN C C Use the default tolerance in rank determination. C TEMP = DBLE( N )*DLAMCH( 'Epsilon' ) END IF C C Estimate the reciprocal condition number of R and set the rank. C Workspace: 2*N. C CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TEMP, SVLMAX, DWORK, $ RANK, DUM, DWORK, LDWORK, INFO ) C ELSEIF ( NCOND ) THEN J = 1 C 20 CONTINUE IF ( R(J,J).NE.ZERO ) THEN J = J + 1 IF ( J.LE.N ) $ GO TO 20 END IF C RANK = J - 1 END IF C C Compute and store in x the Gauss-Newton direction. If the C Jacobian is rank-deficient, obtain a least squares solution. C The array RX is used as workspace. C CALL DCOPY( RANK, QTB, 1, RX, 1 ) DUM(1) = ZERO IF ( RANK.LT.N ) $ CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 ) CALL DTRSV( 'Upper', 'No transpose', 'Non unit', RANK, R, LDR, $ RX, 1 ) C DO 30 J = 1, N L = IPVT(J) X(L) = RX(J) 30 CONTINUE C C Initialize the iteration counter. C Evaluate the function at the origin, and test C for acceptance of the Gauss-Newton direction. C ITER = 0 C DO 40 J = 1, N DWORK(J) = DIAG(J)*X(J) 40 CONTINUE C DXNORM = DNRM2( N, DWORK, 1 ) FP = DXNORM - DELTA IF ( FP.GT.P1*DELTA ) THEN C C Set an appropriate option for estimating the condition of C the matrix S. C IF ( UCOND ) THEN IF ( LDWORK.GE.4*N ) THEN CONDL = 'E' TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) ELSE CONDL = 'N' TOLDEF = TOL END IF ELSE CONDL = COND TOLDEF = TOL END IF C C If the Jacobian is not rank deficient, the Newton C step provides a lower bound, PARL, for the zero of C the function. Otherwise set this bound to zero. C IF ( RANK.EQ.N ) THEN C DO 50 J = 1, N L = IPVT(J) RX(J) = DIAG(L)*( DWORK(L)/DXNORM ) 50 CONTINUE C CALL DTRSV( 'Upper', 'Transpose', 'Non unit', N, R, LDR, $ RX, 1 ) TEMP = DNRM2( N, RX, 1 ) PARL = ( ( FP/DELTA )/TEMP )/TEMP C C For efficiency, use CONDL = 'U', if possible. C IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO ) $ CONDL = 'U' ELSE PARL = ZERO END IF C C Calculate an upper bound, PARU, for the zero of the function. C DO 60 J = 1, N L = IPVT(J) RX(J) = DDOT( J, R(1,J), 1, QTB, 1 )/DIAG(L) 60 CONTINUE C GNORM = DNRM2( N, RX, 1 ) PARU = GNORM/DELTA IF ( PARU.EQ.ZERO ) $ PARU = DWARF/MIN( DELTA, P1 )/P001 C C If the input PAR lies outside of the interval (PARL,PARU), C set PAR to the closer endpoint. C PAR = MAX( PAR, PARL ) PAR = MIN( PAR, PARU ) IF ( PAR.EQ.ZERO ) $ PAR = GNORM/DXNORM C C Beginning of an iteration. C 70 CONTINUE ITER = ITER + 1 C C Evaluate the function at the current value of PAR. C IF ( PAR.EQ.ZERO ) $ PAR = MAX( DWARF, P001*PARU ) TEMP = SQRT( PAR ) C DO 80 J = 1, N RX(J) = TEMP*DIAG(J) 80 CONTINUE C C Solve the system A*x = b , sqrt(PAR)*D*x = 0 , in a least C square sense. The first N elements of DWORK contain the C diagonal elements of the upper triangular matrix S, and C the next N elements contain the vector z, so that x = P*z. C The vector z is preserved if COND = 'E'. C Workspace: 4*N, if CONDL = 'E'; C 2*N, if CONDL <> 'E'. C CALL MB02YD( CONDL, N, R, LDR, IPVT, RX, QTB, RANK, X, $ TOLDEF, DWORK, LDWORK, INFO ) C DO 90 J = 1, N DWORK(N2+J) = DIAG(J)*X(J) 90 CONTINUE C DXNORM = DNRM2( N, DWORK(N2+1), 1 ) TEMP = FP FP = DXNORM - DELTA C C If the function is small enough, accept the current value C of PAR. Also test for the exceptional cases where PARL C is zero or the number of iterations has reached ITMAX. C IF ( ABS( FP ).GT.P1*DELTA .AND. $ ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND. $ ITER.LT.ITMAX ) THEN C C Compute the Newton correction. C DO 100 J = 1, RANK L = IPVT(J) RX(J) = DIAG(L)*( DWORK(N2+L)/DXNORM ) 100 CONTINUE C IF ( RANK.LT.N ) $ CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 ) CALL DSWAP( N, R, LDR+1, DWORK, 1 ) CALL DTRSV( 'Lower', 'No transpose', 'Non Unit', RANK, $ R, LDR, RX, 1 ) CALL DSWAP( N, R, LDR+1, DWORK, 1 ) TEMP = DNRM2( RANK, RX, 1 ) PARC = ( ( FP/DELTA )/TEMP )/TEMP C C Depending on the sign of the function, update PARL C or PARU. C IF ( FP.GT.ZERO ) THEN PARL = MAX( PARL, PAR ) ELSE IF ( FP.LT.ZERO ) THEN PARU = MIN( PARU, PAR ) END IF C C Compute an improved estimate for PAR. C PAR = MAX( PARL, PAR + PARC ) C C End of an iteration. C GO TO 70 END IF END IF C C Compute -R*P'*x = -R*z. C IF ( ECOND .AND. ITER.GT.0 ) THEN C DO 110 J = 1, N RX(J) = -DWORK(N+J) 110 CONTINUE C CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', N, R, LDR, $ RX, 1 ) ELSE C DO 120 J = 1, N RX(J) = ZERO L = IPVT(J) CALL DAXPY( J, -X(L), R(1,J), 1, RX, 1 ) 120 CONTINUE C END IF C C Termination. If PAR = 0, set S. C IF ( ITER.EQ.0 ) THEN PAR = ZERO C DO 130 J = 1, N - 1 DWORK(J) = R(J,J) CALL DCOPY( N-J, R(J,J+1), LDR, R(J+1,J), 1 ) 130 CONTINUE C DWORK(N) = R(N,N) END IF C RETURN C C *** Last line of MD03BY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03QW.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03QW.f0000644000175000017500000001466615012430707017417 0ustar00lilgelilge00000000000000 SUBROUTINE MB03QW( N, L, A, LDA, E, LDE, U, LDU, V, LDV, $ ALPHAR, ALPHAI, BETA, INFO ) C C PURPOSE C C To compute the eigenvalues of a selected 2-by-2 diagonal block C pair of an upper quasi-triangular pencil, to reduce the selected C block pair to the standard form and to split it in the case of C real eigenvalues, by constructing orthogonal matrices UT and VT. C The transformations UT and VT are applied to the pair (A,E) by C computing (UT'*A*VT, UT'*E*VT ), to the matrices U and V, C by computing U*UT and V*VT. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, E, UT and VT. 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 split and/or put in the LAPACK standard C form. C C LDA INTEGER C The leading dimension of the array A. LDA >= N. C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the upper triangular matrix E whose selected C 2-by-2 diagonal block is to be processed. C On exit, the leading N-by-N part of this array contains C the transformed upper triangular matrix E (in the LAPACK C standard form). C C LDE INTEGER C The leading dimension of the array E. LDE >= 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 pair. C C LDU INTEGER C The leading dimension of the array U. LDU >= N. C C V (input/output) DOUBLE PRECISION array, dimension (LDV,N) C On entry, the leading N-by-N part of this array must C contain a transformation matrix V. C On exit, the leading N-by-N part of this array contains C V*VT, where VT is the transformation matrix used to C split and/or standardize the selected block pair. C C LDV INTEGER C The leading dimension of the array V. LDV >= N. C C ALPHAR (output) DOUBLE PRECISION array, dimension (2) C ALPHAI (output) DOUBLE PRECISION array, dimension (2) C BETA (output) DOUBLE PRECISION array, dimension (2) C (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the C block pair of the pencil (A,B), k=1,2, i = sqrt(-1). C Note that BETA(k) may be zero. 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) ), E1 = ( E(L,L) E(L,L+1) ), C ( A(L+1,L) A(L+1,L+1) ) ( E(L+1,L) E(L+1,L+1) ) C be the specified 2-by-2 diagonal block pair of the pencil (A,B). C If the eigenvalues of (A1,E1) are complex, then they are computed C and stored in ER and EI, where the real part is stored in ER and C the positive imaginary part in EI. The 2-by-2 block pair is C reduced if necessary to the standard form, such that C A(L,L) = A(L+1,L+1), and A(L,L+1) and A(L+1,L) have oposite signs. C If the eigenvalues are real, the 2-by-2 block pair is reduced to C upper triangular form such 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 and E are replaced by UT'*A*UT and UT'*E*UT, and the contents of C the arrays U and V are U * UT and V * VT, respectively. 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 V. Sima, Dec. 2016. C C KEYWORDS C C Eigenvalues, orthogonal transformation, real Schur form, C equivalence transformation. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INFO, L, LDA, LDE, LDU, LDV, N DOUBLE PRECISION ALPHAI(*), ALPHAR(*), BETA(*) C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), E(LDE,*), U(LDU,*), V(LDV,*) C .. Local Scalars .. INTEGER L1 DOUBLE PRECISION CSL, CSR, SNL, SNR C .. External Subroutines .. EXTERNAL DLAGV2, 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( LDE.LT.N ) THEN INFO = -6 ELSE IF( LDU.LT.N ) THEN INFO = -8 ELSE IF( LDV.LT.N ) THEN INFO = -10 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB03QW', -INFO ) RETURN END IF C C Compute the generalized eigenvalues and the elements of the Givens C transformations. C L1 = L + 1 CALL DLAGV2( A(L,L), LDA, E(L,L), LDE, ALPHAR, ALPHAI, BETA, $ CSL, SNL, CSR, SNR ) C C Apply the transformations to A and E. C IF( L1.LT.N ) THEN CALL DROT( N-L1, A(L,L1+1), LDA, A(L1,L1+1), LDA, CSL, SNL ) CALL DROT( N-L1, E(L,L1+1), LDE, E(L1,L1+1), LDE, CSL, SNL ) END IF CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CSR, SNR ) CALL DROT( L-1, E(1,L), 1, E(1,L1), 1, CSR, SNR ) C C Accumulate the transformations in U and V. C CALL DROT( N, U(1,L), 1, U(1,L1), 1, CSL, SNL ) CALL DROT( N, V(1,L), 1, V(1,L1), 1, CSR, SNR ) C RETURN C *** Last line of MB03QW *** END control-4.1.2/src/slicot/src/PaxHeaders/AB13AX.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB13AX.f0000644000175000017500000002157715012430707017364 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION AB13AX( DICO, N, M, P, A, LDA, B, LDB, $ C, LDC, HSV, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute the Hankel-norm of the transfer-function matrix G of C a stable state-space system (A,B,C). The state dynamics matrix A C of the given system is an upper quasi-triangular matrix in C real Schur form. C C FUNCTION VALUE C C AB13AX DOUBLE PRECISION C The Hankel-norm of G (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 Input/Output Parameters C C N (input) INTEGER C The order of the state-space representation, i.e. the C order of the 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 in a real Schur canonical form. 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. 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. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, this array contains the Hankel singular C values of the given system ordered decreasingly. C HSV(1) is the Hankel norm of the given system. 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 length of the array DWORK. C LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2). 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: the state matrix A is not stable (if DICO = 'C') C or not convergent (if DICO = 'D'); C = 2: the computation of Hankel singular values failed. C C METHOD C C Let be the stable linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system, and let G be the corresponding C transfer-function matrix. The Hankel-norm of G is computed as the C the maximum Hankel singular value of the system (A,B,C). C The computation of the Hankel singular values is performed C by using the square-root method of [1]. C C REFERENCES C C [1] Tombs M.S. and Postlethwaite I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C NUMERICAL ASPECTS C C The implemented method relies on a square-root technique. C 3 C The algorithms require about 17N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, July 1998. C Based on the RASP routine SHANRM. C C REVISIONS C C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. C Feb. 2000, V. Sima, Research Institute for Informatics, Bucharest. C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. C C KEYWORDS C C Multivariable system, 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 INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) C .. Local Scalars .. LOGICAL DISCR INTEGER I, IERR, J, KR, KS, KTAU, KU, KW, MNMP DOUBLE PRECISION SCALEC, SCALEO, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLACPY, DSCAL, DTPMV, MA02DD, MB03UD, SB03OU, $ XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C .. Executable Statements .. C INFO = 0 DISCR = LSAME( DICO, 'D' ) C C Test the input scalar arguments. 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( 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( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + $ ( N*( N + 1 ) )/2 ) ) THEN INFO = -13 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB13AX', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN AB13AX = ZERO DWORK(1) = ONE RETURN END IF C C Allocate N*MAX(N,M,P), N, and N*(N+1)/2 working storage for the C matrices S, TAU, and R, respectively. S shares the storage with U. C KU = 1 KS = 1 MNMP = MAX( N, M, P ) KTAU = KS + N*MNMP KR = KTAU + N KW = KR C C Copy C in U. C CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), MNMP ) C C If DISCR = .FALSE., solve for R the Lyapunov equation C 2 C A'*(R'*R) + (R'*R)*A + scaleo * C'*C = 0 . C C If DISCR = .TRUE., solve for R the Lyapunov equation C 2 C A'*(R'*R)*A + scaleo * C'*C = R'*R . C C Workspace needed: N*(MAX(N,M,P)+1); C Additional workspace: need 4*N; C prefer larger. C CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), MNMP, $ DWORK(KTAU), DWORK(KU), N, SCALEO, DWORK(KW), $ LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN ENDIF C WRKOPT = DWORK(KW) + DBLE( KW-1 ) C C Pack the upper triangle of R in DWORK(KR). C Workspace needed: N*(MAX(N,M,P) + 1) + N*(N+1)/2. C CALL MA02DD( 'Pack', 'Upper', N, DWORK(KU), N, DWORK(KR) ) C KW = KR + ( N*( N + 1 ) )/2 C C Copy B in S (over U). C CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KS), N ) C C If DISCR = .FALSE., solve for S the Lyapunov equation C 2 C A*(S*S') + (S*S')*A' + scalec *B*B' = 0 . C C If DISCR = .TRUE., solve for S the Lyapunov equation C 2 C A*(S*S')*A' + scalec *B*B' = S*S' . C C Workspace needed: N*(MAX(N,M,P) + 1) + N*(N+1)/2; C Additional workspace: need 4*N; C prefer larger. C CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KS), N, $ DWORK(KTAU), DWORK(KS), N, SCALEC, DWORK(KW), $ LDWORK-KW+1, IERR ) C WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) C C | x x | C Compute R*S in the form | 0 x | in S. Note that R is packed. C J = KS DO 10 I = 1, N CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', I, DWORK(KR), $ DWORK(J), 1 ) J = J + N 10 CONTINUE C C Compute the singular values of the upper triangular matrix R*S. C C Workspace needed: N*MAX(N,M,P); C Additional workspace: need MAX(1,5*N); C prefer larger. C KW = KTAU CALL MB03UD( 'NoVectors', 'NoVectors', N, DWORK(KS), N, DWORK, 1, $ HSV, DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 2 RETURN ENDIF C C Scale singular values. C CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) AB13AX = HSV(1) C DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) C RETURN C *** Last line of AB13AX *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01UY.f0000644000000000000000000000013215012430707016221 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB01UY.f0000644000175000017500000005276415012430707017433 0ustar00lilgelilge00000000000000 SUBROUTINE TB01UY( JOBZ, N, M1, M2, P, A, LDA, B, LDB, C, LDC, $ NCONT, INDCON, NBLK, Z, LDZ, TAU, TOL, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To find a controllable realization for the linear time-invariant C multi-input system C C dX/dt = A * X + B1 * U1 + B2 * U2, C Y = C * X, C C where A, B1, B2 and C are N-by-N, N-by-M1, N-by-M2, and P-by-N C matrices, respectively, and A and [B1,B2] are reduced by this C routine to orthogonal canonical form using (and optionally C accumulating) orthogonal similarity transformations, which are C also applied to C. Specifically, the system (A, [B1,B2], C) is C reduced to the triplet (Ac, [Bc1,Bc2], Cc), where C Ac = Z' * A * Z, [Bc1,Bc2] = Z' * [B1,B2], Cc = C * Z, with C C [ Acont * ] [ Bcont1, Bcont2 ] C Ac = [ ], [Bc1,Bc1] = [ ], C [ 0 Auncont ] [ 0 0 ] C C and C C [ A11 A12 . . . A1,p-2 A1,p-1 A1p ] C [ A21 A22 . . . A2,p-2 A2,p-1 A2p ] C [ A31 A32 . . . A3,p-2 A3,p-1 A3p ] C [ 0 A42 . . . A4,p-2 A4,p-1 A4p ] C Acont = [ . . . . . . . . ], C [ . . . . . . . ] C [ . . . . . . ] C [ 0 0 . . . Ap,p-2 Ap,p-1 App ] C C [ B11 B12 ] C [ 0 B22 ] C [ 0 0 ] C [ 0 0 ] C [Bc1,Bc2] = [ . . ], C [ . . ] C [ . . ] C [ 0 0 ] C C where the blocks B11, B22, A31, ..., Ap,p-2 have full row ranks and C p is the controllability index of the pair (A,[B1,B2]). The size of the C block Auncont is equal to the dimension of the uncontrollable C subspace of the pair (A,[B1,B2]). C C ARGUMENTS C C Mode Parameters C C JOBZ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal similarity transformations for C reducing the system, as follows: C = 'N': Do not form Z and do not store the orthogonal C transformations; C = 'F': Do not form Z, but store the orthogonal C transformations in the factored form; C = 'I': Z is initialized to the unit matrix and the C orthogonal transformation matrix Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e., the order of the matrix A. N >= 0. C C M1 (input) INTEGER C The number of system inputs in U1, or of columns of B1. C M1 >= 0. C C M2 (input) INTEGER C The number of system inputs in U2, or of columns of B2. C M2 >= 0. C C P (input) INTEGER C The number of system outputs, or of rows of C. 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 original state dynamics matrix A. C On exit, the leading N-by-N part of this array contains C the transformed state dynamics matrix Ac = Z'*A*Z. The C leading NCONT-by-NCONT diagonal block of this matrix, C Acont, is the state dynamics matrix of a controllable C realization for the original system. The elements below C the second block-subdiagonal are set to zero. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,M1+M2) C On entry, the leading N-by-(M1+M2) part of this array must C contain the compound input matrix B = [B1,B2], where B1 is C N-by-M1 and B2 is N-by-M2. C On exit, the leading N-by-(M1+M2) part of this array C contains the transformed compound input matrix [Bc1,Bc2] = C Z'*[B1,B2]. The leading NCONT-by-(M1+M2) part of this C array, [Bcont1, Bcont2], is the compound input matrix of C a controllable realization for the original system. C All elements below the first block-diagonal are set to C zero. C C LDB INTEGER C The leading dimension of the 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 output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed output matrix Cc, given by C * Z. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C NCONT (output) INTEGER C The order of the controllable state-space representation. C C INDCON (output) INTEGER C The controllability index of the controllable part of the C system representation. C C NBLK (output) INTEGER array, dimension (2*N) C The leading INDCON elements of this array contain the C orders of the diagonal blocks of Acont. INDCON is always C an even number, and the INDCON/2 odd and even components C of NBLK have decreasing values, respectively. C Note that some elements of NBLK can be zero. C C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) C If JOBZ = 'I', then the leading N-by-N part of this C array contains the matrix of accumulated orthogonal C similarity transformations which reduces the given system C to orthogonal canonical form. C If JOBZ = 'F', the elements below the diagonal, with the C array TAU, represent the orthogonal transformation matrix C as a product of elementary reflectors. The transformation C matrix can then be obtained by calling the LAPACK Library C routine DORGQR. C If JOBZ = 'N', the array Z is not referenced and can be C supplied as a dummy array (i.e., set parameter LDZ = 1 and C declare this array to be Z(1,1) in the calling program). C C LDZ INTEGER C The leading dimension of the array Z. If JOBZ = 'I' or C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. C C TAU (output) DOUBLE PRECISION array, dimension (MIN(N,M1+M2)) C The elements of TAU contain the scalar factors of the C elementary reflectors used in the reduction of [B1,B2] C and A. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in rank determinations when C transforming (A, [B1,B2]). If the user sets TOL > 0, then C the given value of TOL is used as a lower bound for the C reciprocal condition number (see the description of the C argument RCOND in the SLICOT routine MB03OD); a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*N*EPS, is used instead, where EPS C is the machine precision (see LAPACK Library routine C DLAMCH). C C Workspace C C IWORK INTEGER array, dimension (MAX(M1,M2)) 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. LDWORK >= 1, and C LDWORK >= MAX(N, 3*MAX(M1,M2), P), if MIN(N,M1+M2) > 0. C For optimum performance LDWORK should be larger. C C If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 implemented algorithm [1] represents a specialization of the C controllability staircase algorithm of [2] to the special structure C of the input matrix B = [B1,B2]. C C REFERENCES C C [1] Varga, A. C Reliable algorithms for computing minimal dynamic covers. C Proc. CDC'2003, Hawaii, 2003. C C [2] Varga, A. C Numerically stable algorithm for standard controllability C form determination. C Electronics Letters, vol. 17, pp. 74-75, 1981. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations and is backward stable. C C FURTHER COMMENTS C C If the system matrices A and B are badly scaled, it would be C useful to scale them with SLICOT routine TB01ID, before calling C the routine. C C CONTRIBUTOR C C A. Varga, DLR Oberpfaffenhofen, March 2003. C C REVISIONS C C A. Varga, DLR Oberpfaffenhofen, April 2003, December 2006. C V. Sima, December 2016, April 2017. C C KEYWORDS C C Controllability, minimal realization, orthogonal canonical form, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBZ INTEGER INDCON, INFO, LDA, LDB, LDC, LDWORK, LDZ, M1, $ M2, N, NCONT, P DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), TAU(*), $ Z(LDZ,*) INTEGER IWORK(*), NBLK(*) C .. Local Scalars .. LOGICAL B1RED, LJOBF, LJOBI, LJOBZ, LQUERY INTEGER IQR, ITAU, J, JB2, JQR, M, MCRT, MCRT1, $ MCRT2, MINWRK, NCRT, NI, NJ, RANK, WRKOPT DOUBLE PRECISION ANORM, BNORM, FNRM, FNRM2, FNRMA, TOLDEF C .. Local Arrays .. DOUBLE PRECISION SVAL(3) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR, $ MB01PD, MB03OY, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C .. C .. Executable Statements .. C INFO = 0 LJOBF = LSAME( JOBZ, 'F' ) LJOBI = LSAME( JOBZ, 'I' ) LJOBZ = LJOBF.OR.LJOBI M = M1 + M2 C C Test the input scalar arguments. C IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( M1.LT.0 ) THEN INFO = -3 ELSE IF( M2.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( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN INFO = -16 ELSE IF( MIN( N, M ).EQ.0 ) THEN MINWRK = 1 ELSE MINWRK = MAX( N, 3*MAX( M1, M2 ), P ) END IF C LQUERY = LDWORK.LT.0 IF( LQUERY ) THEN MCRT = MAX( M1, M2 ) RANK = MIN( N, MCRT ) CALL DORMQR( 'Left', 'Transpose', N, MCRT, RANK, B, LDB, $ TAU, B, LDB, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) CALL DORMQR( 'Left', 'Transpose', N, N, RANK, B, LDB, TAU, $ A, LDA, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) CALL DORMQR( 'Right', 'No transpose', P, N, RANK, B, LDB, $ TAU, C, LDC, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) IF( LJOBI .AND. N.GT.0 ) THEN CALL DORGQR( N, N, N-1, Z, LDZ, TAU, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -21 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01UY', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C NCONT = 0 INDCON = 0 C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Calculate the absolute norms of A and B (used for scaling). C ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) BNORM = DLANGE( 'M', N, M, B, LDB, DWORK ) C C Return if matrix B is zero. C IF( BNORM.EQ.ZERO ) THEN IF( LJOBI ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) ELSE IF( LJOBF .AND. N.GT.1 ) THEN CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, Z(2,1), LDZ ) CALL DLASET( 'Full', MIN( N, M ), 1, ZERO, ZERO, TAU, N ) END IF DWORK(1) = ONE RETURN END IF C C Scale (if needed) the matrices A and B. C CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) CALL MB01PD( 'S', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, INFO ) C C Compute the Frobenius norm of B1 (used for rank estimation of B1). C In the loop, then use the Frobenius norm of B2 and then of A. C FNRM = DLANGE( 'F', N, M1, B, LDB, DWORK ) FNRMA = DLANGE( 'F', N, N, A, LDA, DWORK ) IF( M2.GT.0 ) THEN FNRM2 = DLANGE( 'F', N, M2, B(1,M1+1), LDB, DWORK ) ELSE FNRM2 = ZERO END IF C TOLDEF = TOL IF( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance in controllability determination. C TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) END IF C WRKOPT = 1 NI = 0 NJ = 0 ITAU = 1 NCRT = N MCRT1 = M1 MCRT2 = M2 MCRT = MCRT1 IQR = 1 JQR = 1 B1RED = .TRUE. JB2 = MIN( M1+1, M ) 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 10 CONTINUE C C Rank-revealing QR decomposition with column pivoting. C The calculation is performed in NCRT rows of B starting from C the row IQR. C Workspace: 3*MAX(MCRT1,MCRT2). C CALL MB03OY( NCRT, MCRT, B(IQR,JQR), LDB, TOLDEF, FNRM, RANK, $ SVAL, IWORK, TAU(ITAU), DWORK, INFO ) C IF( RANK.EQ.0 ) THEN IF( B1RED ) THEN IF( MCRT2.GT.0 ) THEN B1RED = .NOT.B1RED INDCON = INDCON + 1 NBLK(INDCON) = 0 IF( INDCON.EQ.1 ) THEN FNRM = FNRM2 ELSE IF( INDCON.GT.2 ) THEN NJ = NJ + MCRT END IF MCRT1 = 0 MCRT = MCRT2 JQR = JB2 IF( INDCON.GE.2 ) THEN IF( INDCON.EQ.2 ) $ FNRM = FNRMA CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NJ+1), $ LDA, B(IQR,JQR), LDB ) CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, $ A(NCONT+1,NJ+1), LDA ) END IF GO TO 10 END IF ELSE IF( MCRT1.GT.0 ) THEN B1RED = .NOT.B1RED INDCON = INDCON + 1 NBLK(INDCON) = 0 MCRT2 = 0 MCRT = MCRT1 JQR = 1 IF( INDCON.GE.2 ) THEN IF( INDCON.EQ.2 ) THEN FNRM = FNRMA ELSE IF( INDCON.GT.2 ) THEN NJ = NJ + MCRT END IF CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NJ+1), $ LDA, B(IQR,JQR), LDB ) CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, $ A(NCONT+1,NJ+1), LDA ) END IF GO TO 10 END IF INDCON = INDCON - 1 END IF ELSE NI = NCONT NCONT = NCONT + RANK INDCON = INDCON + 1 NBLK(INDCON) = RANK C C Premultiply the appropriate block row of B2 by Q'. C Workspace: need MCRT2; C prefer MCRT2*NB. C IF( INDCON.LT.2 ) THEN FNRM = FNRM2 CALL DORMQR( 'Left', 'Transpose', NCRT, MCRT2, RANK, $ B(IQR,JQR), LDB, TAU(ITAU), $ B(NI+1,JB2), LDB, DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF C C Premultiply and postmultiply the appropriate block row C and block column of A by Q' and Q, respectively. C Workspace: need N; C prefer N*NB. C CALL DORMQR( 'Left', 'Transpose', NCRT, N-NJ, RANK, $ B(IQR,JQR), LDB, TAU(ITAU), A(NI+1,NJ+1), LDA, $ DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Workspace: need N; C prefer N*NB. C CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK, $ B(IQR,JQR), LDB, TAU(ITAU), A(1,NI+1), LDA, $ DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Postmultiply the appropriate block column of C by Q. C Workspace: need P; C prefer P*NB. C CALL DORMQR( 'Right', 'No transpose', P, NCRT, RANK, $ B(IQR,JQR), LDB, TAU(ITAU), C(1,NI+1), LDC, $ DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C If required, save transformations. C IF( LJOBZ .AND. NCRT.GT.1 ) THEN CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ), $ B(IQR+1,JQR), LDB, Z(NI+2,ITAU), LDZ ) END IF C C Zero the subdiagonal elements of the current matrix. C IF( RANK.GT.1 ) $ CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO, $ B(IQR+1,JQR), LDB ) C C Backward permutation of the columns of B or A. C IF( INDCON.LE.2 ) THEN IF( INDCON.EQ.2 ) $ FNRM = FNRMA CALL DLAPMT( .FALSE., RANK, MCRT, B(IQR,JQR), LDB, $ IWORK ) IQR = IQR + RANK ELSE DO 20 J = 1, MCRT CALL DCOPY( RANK, B(IQR,JQR+J-1), 1, $ A(NI+1,NJ+IWORK(J)), 1 ) 20 CONTINUE END IF C ITAU = ITAU + RANK IF( RANK.NE.NCRT ) THEN IF( INDCON.GT.2 ) $ NJ = NJ + MCRT IF( B1RED ) THEN MCRT1 = RANK MCRT = MCRT2 JQR = JB2 ELSE MCRT2 = RANK MCRT = MCRT1 JQR = 1 END IF NCRT = NCRT - RANK IF( INDCON.GE.2 ) THEN CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NJ+1), LDA, $ B(IQR,JQR), LDB ) CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, $ A(NCONT+1,NJ+1), LDA ) END IF B1RED = .NOT.B1RED GO TO 10 ELSE IF( B1RED ) THEN INDCON = INDCON + 1 NBLK(INDCON) = 0 END IF END IF END IF C End loop 10. C C If required, accumulate transformations. C Workspace: need N; prefer N*NB. C IF( LJOBI ) THEN CALL DORGQR( N, N, MAX( 1, ITAU-1 ), Z, LDZ, TAU, DWORK, $ LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF C C Annihilate the trailing blocks of B1 and B2. C IF( NBLK(1).LT.N ) $ CALL DLASET( 'G', N-NBLK(1), M1, ZERO, ZERO, $ B(NBLK(1)+1,1), LDB ) IF( IQR.LE.N ) $ CALL DLASET( 'G', N-IQR+1, M2, ZERO, ZERO, B(IQR,JB2), LDB ) C C Annihilate the trailing elements of TAU, if JOBZ = 'F'. C IF( LJOBF ) THEN DO 30 J = ITAU, MIN( N, M ) TAU(J) = ZERO 30 CONTINUE END IF C C Undo scaling of A and B. C CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) CALL MB01PD( 'U', 'G', NBLK(1)+NBLK(2), M, 0, 0, BNORM, 0, NBLK, $ B, LDB, INFO ) C C Set optimal workspace dimension. C DWORK(1) = WRKOPT RETURN C *** Last line of TB01UY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10UD.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB10UD.f0000644000175000017500000003226715012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE SB10UD( N, M, NP, NCON, NMEAS, B, LDB, C, LDC, D, LDD, $ TU, LDTU, TY, LDTY, RCOND, TOL, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To reduce the matrices D12 and D21 of the linear time-invariant C system C C | A | B1 B2 | | A | B | C P = |----|---------| = |---|---| C | C1 | 0 D12 | | C | D | C | C2 | D21 D22 | C C to unit diagonal form, and to transform the matrices B and C to C satisfy the formulas in the computation of the H2 optimal C controller. 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 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 system input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed system input matrix B. C C LDB INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) C On entry, the leading NP-by-N part of this array must C contain the system output matrix C. C On exit, the leading NP-by-N part of this array contains C the transformed system output matrix C. C C LDC INTEGER C The leading dimension of the array C. LDC >= max(1,NP). C C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) C On entry, the leading NP-by-M part of this array must C contain the system input/output matrix D. C The (NP-NMEAS)-by-(M-NCON) leading submatrix D11 is not C referenced. C On exit, the trailing NMEAS-by-NCON part (in the leading C NP-by-M part) of this array contains the transformed C submatrix D22. C The transformed submatrices D12 = [ 0 Im2 ]' and C D21 = [ 0 Inp2 ] are not stored. The corresponding part C of this array contains no useful information. C C LDD INTEGER C The leading dimension of the array D. LDD >= max(1,NP). C C TU (output) DOUBLE PRECISION array, dimension (LDTU,M2) C The leading M2-by-M2 part of this array contains the C control transformation matrix TU. C C LDTU INTEGER C The leading dimension of the array TU. LDTU >= max(1,M2). C C TY (output) DOUBLE PRECISION array, dimension (LDTY,NP2) C The leading NP2-by-NP2 part of this array contains the C measurement transformation matrix TY. C C LDTY INTEGER C The leading dimension of the array TY. C LDTY >= max(1,NP2). C C RCOND (output) DOUBLE PRECISION array, dimension (2) C RCOND(1) contains the reciprocal condition number of the C control transformation matrix TU; C RCOND(2) contains the reciprocal condition number of the C measurement transformation matrix TY. C RCOND is set even if INFO = 1 or INFO = 2; if INFO = 1, C then RCOND(2) was not computed, but it is set to 0. C C Tolerances C C TOL DOUBLE PRECISION C Tolerance used for controlling the accuracy of the applied C transformations. Transformation matrices TU and TY whose C reciprocal condition numbers are less than TOL are not C 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 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( M2 + NP1*NP1 + MAX(NP1*N,3*M2+NP1,5*M2), C NP2 + M1*M1 + MAX(M1*N,3*NP2+M1,5*NP2), C N*M2, NP2*N, NP2*M2, 1 ) C where M1 = M - M2 and NP1 = NP - NP2. C For good performance, LDWORK must generally be larger. C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is C MAX(1,Q*(Q+MAX(N,5)+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: if the matrix D12 had not full column rank in C respect to the tolerance TOL; C = 2: if the matrix D21 had not full row rank in respect C to the tolerance TOL; C = 3: if the singular value decomposition (SVD) algorithm C did not converge (when computing the SVD of D12 or C D21). C C METHOD C C The routine performs the transformations described in [1], [2]. C C REFERENCES C C [1] Zhou, K., Doyle, J.C., and Glover, K. C Robust and Optimal Control. C Prentice-Hall, Upper Saddle River, NJ, 1996. 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 NUMERICAL ASPECTS C C The precision of the transformations can be controlled by the C condition numbers of the matrices TU and TY as given by the C values of RCOND(1) and RCOND(2), respectively. An error return C with INFO = 1 or INFO = 2 will be obtained if the condition C number of TU or TY, respectively, would exceed 1/TOL. 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 Feb. 2000. C C KEYWORDS C C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal C regulator, robust 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, LDB, LDC, LDD, LDTU, LDTY, LDWORK, M, N, $ NCON, NMEAS, NP DOUBLE PRECISION TOL C .. C .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), C( LDC, * ), D( LDD, * ), $ DWORK( * ), RCOND( 2 ), TU( LDTU, * ), $ TY( LDTY, * ) C .. C .. Local Scalars .. INTEGER INFO2, IQ, IWRK, J, 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 DGEMM, DGESVD, DLACPY, DSCAL, DSWAP, 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( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -9 ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN INFO = -11 ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN INFO = -13 ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN INFO = -15 ELSE C C Compute workspace. C MINWRK = MAX( 1, M2 + NP1*NP1 + MAX( NP1*N, 3*M2 + NP1, $ 5*M2 ), $ NP2 + M1*M1 + MAX( M1*N, 3*NP2 + M1, 5*NP2 ), $ N*M2, NP2*N, NP2*M2 ) IF( LDWORK.LT.MINWRK ) $ INFO = -19 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10UD', -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 DWORK( 1 ) = ONE RETURN END IF C ND1 = NP1 - M2 ND2 = M1 - NP2 TOLL = TOL IF( TOLL.LE.ZERO ) THEN C C Set the default value of the tolerance for condition tests. C TOLL = SQRT( DLAMCH( 'Epsilon' ) ) END IF C C Determine SVD of D12, D12 = U12 S12 V12', and check if D12 has C full column rank. V12' is stored in TU. C Workspace: need M2 + NP1*NP1 + max(3*M2+NP1,5*M2); C prefer larger. C IQ = M2 + 1 IWRK = IQ + NP1*NP1 C CALL DGESVD( 'A', 'A', NP1, M2, D( 1, M1+1 ), LDD, DWORK, $ DWORK( IQ ), NP1, TU, LDTU, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF C RCOND( 1 ) = DWORK( M2 )/DWORK( 1 ) IF( RCOND( 1 ).LE.TOLL ) THEN RCOND( 2 ) = ZERO INFO = 1 RETURN END IF LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 C C Determine Q12. C IF( ND1.GT.0 ) THEN CALL DLACPY( 'Full', NP1, M2, DWORK( IQ ), NP1, D( 1, M1+1 ), $ LDD ) CALL DLACPY( 'Full', NP1, ND1, DWORK( IQ+NP1*M2 ), NP1, $ DWORK( IQ ), NP1 ) CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, $ DWORK( IQ+NP1*ND1 ), NP1 ) END IF C C Determine Tu by transposing in-situ and scaling. C DO 10 J = 1, M2 - 1 CALL DSWAP( J, TU( J+1, 1 ), LDTU, TU( 1, J+1 ), 1 ) 10 CONTINUE C DO 20 J = 1, M2 CALL DSCAL( M2, ONE/DWORK( J ), TU( 1, J ), 1 ) 20 CONTINUE C C Determine C1 =: Q12'*C1. C Workspace: M2 + NP1*NP1 + NP1*N. C CALL DGEMM( 'T', 'N', NP1, N, NP1, ONE, DWORK( IQ ), NP1, C, LDC, $ ZERO, DWORK( IWRK ), NP1 ) CALL DLACPY( 'Full', NP1, N, DWORK( IWRK ), NP1, C, LDC ) LWAMAX = MAX( IWRK + NP1*N - 1, LWAMAX ) C C Determine SVD of D21, D21 = U21 S21 V21', and check if D21 has C full row rank. U21 is stored in TY. C Workspace: need NP2 + M1*M1 + max(3*NP2+M1,5*NP2); C prefer larger. C IQ = NP2 + 1 IWRK = IQ + M1*M1 C CALL DGESVD( 'A', 'A', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, TY, $ LDTY, DWORK( IQ ), M1, DWORK( IWRK ), LDWORK-IWRK+1, $ INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 3 RETURN END IF C RCOND( 2 ) = DWORK( NP2 )/DWORK( 1 ) IF( RCOND( 2 ).LE.TOLL ) THEN INFO = 2 RETURN END IF LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) C C Determine Q21. C IF( ND2.GT.0 ) THEN CALL DLACPY( 'Full', NP2, M1, DWORK( IQ ), M1, D( NP1+1, 1 ), $ LDD ) CALL DLACPY( 'Full', ND2, M1, DWORK( IQ+NP2 ), M1, DWORK( IQ ), $ M1 ) CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, $ DWORK( IQ+ND2 ), M1 ) END IF C C Determine Ty by scaling and transposing in-situ. C DO 30 J = 1, NP2 CALL DSCAL( NP2, ONE/DWORK( J ), TY( 1, J ), 1 ) 30 CONTINUE C DO 40 J = 1, NP2 - 1 CALL DSWAP( J, TY( J+1, 1 ), LDTY, TY( 1, J+1 ), 1 ) 40 CONTINUE C C Determine B1 =: B1*Q21'. C Workspace: NP2 + M1*M1 + N*M1. C CALL DGEMM( 'N', 'T', N, M1, M1, ONE, B, LDB, DWORK( IQ ), M1, $ ZERO, DWORK( IWRK ), N ) CALL DLACPY( 'Full', N, M1, DWORK( IWRK ), N, B, LDB ) LWAMAX = MAX( IWRK + N*M1 - 1, LWAMAX ) C C Determine B2 =: B2*Tu. C Workspace: N*M2. C CALL DGEMM( 'N', 'N', N, M2, M2, ONE, B( 1, M1+1 ), LDB, TU, LDTU, $ ZERO, DWORK, N ) CALL DLACPY( 'Full', N, M2, DWORK, N, B( 1, M1+1 ), LDB ) C C Determine C2 =: Ty*C2. C Workspace: NP2*N. C CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, TY, LDTY, $ C( NP1+1, 1 ), LDC, ZERO, DWORK, NP2 ) CALL DLACPY( 'Full', NP2, N, DWORK, NP2, C( NP1+1, 1 ), LDC ) C C Determine D22 =: Ty*D22*Tu. C Workspace: NP2*M2. C CALL DGEMM( 'N', 'N', NP2, M2, NP2, ONE, TY, LDTY, $ D( NP1+1, M1+1 ), LDD, ZERO, DWORK, NP2 ) CALL DGEMM( 'N', 'N', NP2, M2, M2, ONE, DWORK, NP2, TU, LDTU, $ ZERO, D( NP1+1, M1+1 ), LDD ) C LWAMAX = MAX( N*MAX( M2, NP2 ), NP2*M2, LWAMAX ) DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10UD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03LF.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03LF.f0000644000175000017500000010772615012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE MB03LF( COMPQ, COMPU, ORTH, N, Z, LDZ, B, LDB, FG, $ LDFG, NEIG, Q, LDQ, U, LDU, ALPHAR, ALPHAI, $ BETA, IWORK, LIWORK, DWORK, LDWORK, BWORK, $ IWARN, INFO ) C C PURPOSE C C To compute the relevant eigenvalues of a real N-by-N skew- C Hamiltonian/Hamiltonian pencil aS - bH, with C C ( B F ) ( 0 I ) C S = T Z = J Z' J' Z and H = ( ), J = ( ), (1) C ( G -B' ) ( -I 0 ) C C where the notation M' denotes the transpose of the matrix M. C Optionally, if COMPQ = 'C', an orthogonal basis of the right C deflating subspace of aS - bH corresponding to the eigenvalues C with strictly negative real part is computed. Optionally, if C COMPU = 'C', an orthonormal basis of the companion subspace, C range(P_U) [1], which corresponds to the eigenvalues with strictly C negative real part, is computed. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether to compute the right deflating subspace C corresponding to the eigenvalues of aS - bH with strictly C negative real part. C = 'N': do not compute the deflating subspace; C = 'C': compute the deflating subspace and store it in the C leading subarray of Q. C C COMPU CHARACTER*1 C Specifies whether to compute the companion subspace C corresponding to the eigenvalues of aS - bH with strictly C negative real part. C = 'N': do not compute the companion subspace; C = 'C': compute the companion subspace and store it in the C leading subarray of U. C C ORTH CHARACTER*1 C If COMPQ = 'C' and/or COMPU = 'C', specifies the technique C for computing the orthogonal basis of the deflating C subspace, and/or of the companion subspace, as follows: C = 'P': QR factorization with column pivoting; C = 'S': singular value decomposition. C If COMPQ = 'N' and COMPU = 'N', the ORTH value is not C used. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) C On entry, the leading N-by-N part of this array must C contain the non-trivial factor Z in the factorization C S = J Z' J' Z of the skew-Hamiltonian matrix S. C On exit, if COMPQ = 'C' or COMPU = 'C', the leading C N-by-N part of this array contains the transformed upper C ~ C triangular matrix Z11 (see METHOD), after moving the C eigenvalues with strictly negative real part to the top C of the pencil (3). The strictly lower triangular part is C not zeroed. C If COMPQ = 'N' and COMPU = 'N', the leading N-by-N part of C this array contains the matrix Z obtained by the SLICOT C Library routine MB04AD just before the application of the C periodic QZ algorithm. The elements of the (2,1) block, C i.e., in the rows N/2+1 to N and in the columns 1 to N/2 C are not set to zero, but are unchanged on exit. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1, N). C C B (input) DOUBLE PRECISION array, dimension (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix B. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C FG (input) DOUBLE PRECISION array, dimension (LDFG, N/2+1) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C symmetric matrix G, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C symmetric matrix F. C C LDFG INTEGER C The leading dimension of the array FG. C LDFG >= MAX(1, N/2). C C NEIG (output) INTEGER C If COMPQ = 'C' or COMPU = 'C', the number of eigenvalues C in aS - bH with strictly negative real part. C C Q (output) DOUBLE PRECISION array, dimension (LDQ, 2*N) C On exit, if COMPQ = 'C', the leading N-by-NEIG part of C this array contains an orthogonal basis of the right C deflating subspace corresponding to the eigenvalues of C aS - bH with strictly negative real part. The remaining C part of this array is used as workspace. C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, 2*N), if COMPQ = 'C'. C C U (output) DOUBLE PRECISION array, dimension (LDU, 2*N) C On exit, if COMPU = 'C', the leading N-by-NEIG part of C this array contains an orthogonal basis of the companion C subspace corresponding to the eigenvalues of aS - bH with C strictly negative real part. The remaining part of this C array is used as workspace. C If COMPU = 'N', this array is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= 1, if COMPU = 'N'; C LDU >= MAX(1, N), if COMPU = 'C'. C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C Due to the skew-Hamiltonian/Hamiltonian structure of the C pencil, for every eigenvalue lambda, -lambda is also an C eigenvalue, and thus it has only to be saved once in C ALPHAR, ALPHAI and BETA. C Specifically, only eigenvalues with imaginary parts C greater than or equal to zero are stored; their conjugate C eigenvalues are not stored. If imaginary parts are zero C (i.e., for real eigenvalues), only positive eigenvalues C are stored. The remaining eigenvalues have opposite signs. C As a consequence, pairs of complex eigenvalues, stored in C consecutive locations, are not complex conjugate. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = -20, IWORK(1) returns the minimum value C of LIWORK. C C LIWORK INTEGER C The dimension of the array IWORK. C LIWORK >= N + 18, if COMPQ = 'N' and COMPU = 'N'; C LIWORK >= MAX( 2*N+1, 48 ), otherwise. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK. C On exit, if INFO = -22, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= b*N*N + 3*N*N/2 + MAX( 6*N, 54 ), C if COMPQ = 'N' and COMPU = 'N'; C LDWORK >= d*N*N + MAX( N/2+252, 432 ), otherwise, where C b = a, d = c, if COMPU = 'N', C b = a+1, d = c+1, if COMPU = 'C', and C a = 2, c = 7, if COMPQ = 'N', C a = 4, c = 10, if COMPQ = 'C'. C For good performance LDWORK should be generally larger. C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C BWORK LOGICAL array, dimension (N/2) C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: some eigenvalues might be unreliable. More details C can be obtained by running the SLICOT routine MB04AD. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: periodic QZ iteration failed in the SLICOT Library C routines MB04AD, MB04CD or MB03BB (QZ iteration did C not converge or computation of the shifts failed); C = 2: standard QZ iteration failed in the SLICOT Library C routines MB04CD or MB03CD (called by MB03ID); C = 3: a numerically singular matrix was found in the SLICOT C Library routine MB03GD (called by MB03ID); C = 4: the singular value decomposition failed in the LAPACK C routine DGESVD (for ORTH = 'S'). C C METHOD C C First, the decompositions of S and H are computed via orthogonal C matrices Q1 and Q2 and orthogonal symplectic matrices U1 and U2, C such that C C ( T11 T12 ) C Q1' T U1 = Q1' J Z' J' U1 = ( ), C ( 0 T22 ) C C ( Z11 Z12 ) C U2' Z Q2 = ( ), (2) C ( 0 Z22 ) C C ( H11 H12 ) C Q1' H Q2 = ( ), C ( 0 H22 ) C C where T11, T22', Z11, Z22', H11 are upper triangular and H22' is C upper quasi-triangular. C C Then, orthogonal matrices Q3, Q4 and U3 are found, for the C matrices C C ~ ( T22' 0 ) ~ ( T11' 0 ) ~ ( 0 H11 ) C Z11 = ( ), Z22 = ( ), H = ( ), C ( 0 Z11 ) ( 0 Z22 ) ( -H22' 0 ) C C ~ ~ ~ ~ C such that Z11 := U3' Z11 Q4, Z22 := U3' Z22 Q3 are upper C ~ ~ C triangular and H11 := Q3' H Q4 is upper quasi-triangular. The C following matrices are computed: C C ~ ( -T12' 0 ) ~ ( 0 H12 ) C Z12 := U3' ( ) Q3 and H12 := Q3' ( ) Q3. C ( 0 Z12 ) ( H12' 0 ) C C Then, an orthogonal matrix Q and an orthogonal symplectic matrix U C are found such that the eigenvalues with strictly negative real C parts of the pencil C C ~ ~ ~ ~ ~ ~ C ( Z11 Z12 )' ( Z11 Z12 ) ( H11 H12 ) C a J ( ~ ) J' ( ~ ) - b ( ~ ) (3) C ( 0 Z22 ) ( 0 Z22 ) ( 0 -H11' ) C C are moved to the top of this pencil. C C Finally, an orthogonal basis of the right deflating subspace C and an orthogonal basis of the companion subspace corresponding to C the eigenvalues with strictly negative real part are computed. C See also page 11 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C floating point operations. C C FURTHER COMMENTS C C This routine does not perform any scaling of the matrices. Scaling C might sometimes be useful, and it should be done externally. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Jan. 2011. C C REVISIONS C C V. Sima, Feb. 2011, Aug. 2011, Nov. 2011, Oct. 2012, July 2013, C July 2014, May 2020. C M. Voigt, Jan. 2012, July 2013. C C KEYWORDS C C Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian C pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) C C .. Scalar Arguments .. CHARACTER COMPQ, COMPU, ORTH INTEGER INFO, IWARN, LDB, LDFG, LDQ, LDU, LDWORK, LDZ, $ LIWORK, N, NEIG C C .. Array Arguments .. LOGICAL BWORK( * ) INTEGER IWORK( * ) DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), B( LDB, * ), $ BETA( * ), DWORK( * ), FG( LDFG, * ), $ Q( LDQ, * ), U( LDU, * ), Z( LDZ, * ) C C .. Local Scalars .. LOGICAL LCMP, LCMPQ, LCMPU, LQUERY, QR, QRP, SVD CHARACTER*14 CMPI, CMQI, CMUI, JOB INTEGER I, IH, IH12, IQ1, IQ2, IQ3, IQ4, IS, IT, IU11, $ IU12, IU21, IU22, IU3, IW, IWRK, IZ12, J, M, $ MINDB, MINDW, MINIW, MM, MP1, N2, NM, NMM, NN, $ NP1, OPTDW C C .. Local Arrays .. DOUBLE PRECISION DUM( 7 ) C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEQP3, DGEQRF, DGESVD, $ DLACPY, DORGQR, DSWAP, MA02ED, MB03ID, MB04AD, $ MB04CD, XERBLA C C .. Intrinsic Functions .. INTRINSIC INT, MAX, MOD, SQRT C C .. Executable Statements .. C C Decode the input arguments. C Using ORTH = 'Q' is not safe, but sometimes gives better results. C M = N/2 N2 = N*2 NN = N*N C NEIG = 0 LCMPQ = LSAME( COMPQ, 'C' ) LCMPU = LSAME( COMPU, 'C' ) LCMP = LCMPQ .OR. LCMPU IF( LCMP ) THEN QR = LSAME( ORTH, 'Q' ) QRP = LSAME( ORTH, 'P' ) SVD = LSAME( ORTH, 'S' ) MINIW = MAX( N2 + 1, 48 ) ELSE QR = .FALSE. QRP = .FALSE. SVD = .FALSE. MINIW = N + 18 END IF IF( N.EQ.0 ) THEN MINIW = 1 MINDW = 1 ELSE IF( LCMPQ ) THEN I = 4 J = 10 ELSE I = 2 J = 7 END IF IF( LCMPU ) THEN I = I + 1 J = J + 1 END IF MINDB = I*NN IF( LCMP ) THEN MINDW = J*NN + MAX( M + 252, 432 ) ELSE MINDW = MINDB + 3*( NN/2 ) + MAX( 6*N, 54 ) END IF END IF LQUERY = LDWORK.EQ.-1 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) THEN INFO = -2 ELSE IF( LCMP .AND. .NOT. ( QR .OR. QRP .OR. SVD ) ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -4 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDFG.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N2 ) ) THEN INFO = -13 ELSE IF( LDU.LT.1 .OR. ( LCMPU .AND. LDU.LT.N ) ) THEN INFO = -15 ELSE IF( LIWORK.LT.MINIW ) THEN IWORK( 1 ) = MINIW INFO = -20 ELSE IF( .NOT.LQUERY ) THEN IF( LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -22 END IF END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03LF', -INFO ) RETURN ELSE IF( N.GT.0 ) THEN C C Compute optimal workspace. C CMPI = 'Initialize' IF( LCMPQ ) THEN CMQI = CMPI ELSE CMQI = 'No Computation' END IF C IF( LCMPU ) THEN CMUI = CMPI ELSE CMUI = 'No Computation' END IF C IF( LCMP ) THEN JOB = 'Triangularize' ELSE JOB = 'Eigenvalues' END IF C IF( LQUERY ) THEN CALL MB04AD( JOB, CMQI, CMQI, CMUI, CMUI, N, DWORK, N, $ DWORK, N, DWORK, N, DWORK, N, DWORK, M, DWORK, $ M, DWORK, M, DWORK, M, DWORK, N, DWORK, DWORK, $ DWORK, IWORK, LIWORK, DUM, -1, INFO ) C IF( LCMP ) THEN IW = MINDB MINDB = MINDB + 2*NN IF( LCMPQ ) THEN IW = IW + NN MINDB = MINDB + NN ELSE IW = 0 END IF CALL MB04CD( CMQI, CMPI, CMPI, N, DWORK, N, DWORK, N, $ DWORK, N, DWORK, N, DWORK, N, DWORK, N, $ IWORK, LIWORK, DUM( 2 ), -1, BWORK, INFO ) IF( SVD ) THEN CALL DGESVD( 'O', 'N', N, N, Q, LDQ, DWORK, DWORK, $ LDQ, DWORK, 1, DUM( 3 ), -1, INFO ) J = N + INT( DUM( 3 ) ) ELSE I = MAX( LDQ, LDU ) IF( QR ) THEN CALL DGEQRF( N, M, Q, I, DWORK, DUM( 3 ), -1, $ INFO ) J = M ELSE CALL DGEQP3( N, N, Q, I, IWORK, DWORK, DUM( 3 ), $ -1, INFO ) J = N END IF CALL DORGQR( N, J, J, Q, I, DWORK, DUM( 4 ), -1, $ INFO ) J = J + IW + MAX( INT( DUM( 3 ) ), INT( DUM( 4 ) ) ) END IF OPTDW = MAX( MINDB + INT( DUM( 2 ) ), J ) ELSE OPTDW = 0 END IF OPTDW = MAX( MINDW, OPTDW, MINDB + INT( DUM( 1 ) ) ) DWORK( 1 ) = OPTDW RETURN END IF END IF C C Quick return if possible. C IWARN = 0 IF( N.EQ.0 ) THEN DWORK( 1 ) = ONE RETURN END IF C C STEP 1: Apply MB04AD to compute the generalized symplectic C URV decomposition. C C Set the pointers for the inputs and outputs of MB04AD. C C Real workspace: need w1 + w, where C w1 = 2*N**2, if COMPQ = 'N' and COMPU = 'N'; C w1 = 3*N**2, if COMPQ = 'N' and COMPU = 'C'; C w1 = 4*N**2, if COMPQ = 'C' and COMPU = 'N'; C w1 = 5*N**2, if COMPQ = 'C' and COMPU = 'C'; C w = 3/2*N**2+MAX(6*N, 54), if COMPQ = 'N' C and COMPU = 'N'; C w = 3*N**2+MAX(6*N, 54), otherwise; C prefer larger. C Integer workspace: need N + 18. C MM = M*M NM = N*M NMM = NM + M NP1 = N + 1 MP1 = M + 1 IQ1 = 1 IF( LCMPQ ) THEN IQ2 = IQ1 + NN IU11 = IQ2 + NN IH = IU11 ELSE IQ2 = 1 IU11 = 1 IH = 1 END IF C IF( LCMPU ) THEN IU12 = IU11 + MM IU21 = IU12 + MM IU22 = IU21 + MM IH = IU22 + MM ELSE IU12 = 1 IU21 = 1 IU22 = 1 END IF C C Build the matrix H. C IW = IH IS = IH + M + N DO 10 J = 1, M CALL DCOPY( M, B( 1, J ), 1, DWORK( IW ), 1 ) IW = IW + M + J - 1 CALL DCOPY( M-J+1, FG( J, J ), 1, DWORK( IW ), 1 ) CALL DCOPY( M-J, DWORK( IW+1 ), 1, DWORK( IS ), N ) IW = IW + MP1 - J IS = IS + NP1 10 CONTINUE C IW = IH + NM IS = IW DO 30 J = 1, M CALL DCOPY( J, FG( 1, J+1 ), 1, DWORK( IW ), 1 ) CALL DCOPY( J-1, DWORK( IW ), 1, DWORK( IS ), N ) IW = IW + M IS = IS + 1 DO 20 I = 1, M DWORK( IW ) = -B( J, I ) IW = IW + 1 20 CONTINUE 30 CONTINUE C IT = IH + NN IWRK = IT + NN C CALL MB04AD( JOB, CMQI, CMQI, CMUI, CMUI, N, Z, LDZ, DWORK( IH ), $ N, DWORK( IQ1 ), N, DWORK( IQ2 ), N, DWORK( IU11 ), $ M, DWORK( IU12 ), M, DWORK( IU21 ), M, DWORK( IU22 ), $ M, DWORK( IT ), N, ALPHAR, ALPHAI, BETA, IWORK, $ LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) C IF( INFO.EQ.3 ) THEN IWARN = 1 ELSE IF( INFO.GT.0 ) THEN INFO = 1 RETURN END IF OPTDW = MAX( MINDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C IF( .NOT.LCMP ) THEN DWORK( 1 ) = OPTDW RETURN END IF C ~ ~ ~ C STEP 2: Build the needed parts of the matrices Z11, Z22' and H, C and compute the transformed matrices and the orthogonal matrices C Q3, Q4 and U3. (Q4 might not be required.) C C Real workspace: need w1 + w2 + 3*N*N + MAX( M+252, 432 ), C w2 = 2*N**2, if COMPQ = 'N'; C w2 = 3*N**2, if COMPQ = 'C'; C prefer larger. C Integer workspace: need MAX( N/2+1, 48 ). C Logical workspace: need M. C C Save Z12, T12, and H12, since they are overwritten by MB04CD. C IW = IT + NM IS = IH + NM IF( LCMPU ) THEN DO 40 J = 1, M CALL DCOPY( M, Z( 1, M+J ), 1, U( 1, J ), 1 ) CALL DCOPY( M, DWORK( IW ), 1, U( MP1, J ), 1 ) IW = IW + N 40 CONTINUE DO 50 J = 1, M CALL DCOPY( M, DWORK( IS ), 1, U( 1, M+J ), 1 ) IS = IS + N 50 CONTINUE ELSE DO 60 J = 1, M CALL DCOPY( M, Z( 1, M+J ), 1, Q( 1, J ), 1 ) CALL DCOPY( M, DWORK( IW ), 1, Q( MP1, J ), 1 ) IW = IW + N 60 CONTINUE DO 70 J = 1, M CALL DCOPY( M, DWORK( IS ), 1, Q( 1, M+J ), 1 ) IS = IS + N 70 CONTINUE END IF C IU3 = IWRK IQ3 = IU3 + NN IQ4 = IQ3 + NN IF( LCMPQ ) THEN IWRK = IQ4 + NN ELSE IWRK = IQ4 END IF C IW = IH DO 90 J = 1, M IS = IW + NM CALL DCOPY( M, DWORK( IW ), 1, DWORK( IS ), 1 ) IW = IW + M IS = IH + NMM + J - 1 DO 80 I = 1, M DWORK( IW ) = -DWORK( IS ) IW = IW + 1 IS = IS + N 80 CONTINUE 90 CONTINUE C IS = IT + NMM DO 100 J = 1, M CALL DSWAP( M, Z( 1, J ), 1, Z( MP1, M+J ), 1 ) CALL DSWAP( M, Z( 1, J ), 1, DWORK( IS ), N ) IS = IS + 1 100 CONTINUE C CALL MB04CD( CMQI, CMPI, CMPI, N, DWORK( IT ), N, Z, LDZ, $ DWORK( IH ), N, DWORK( IQ4 ), N, DWORK( IU3 ), N, $ DWORK( IQ3 ), N, IWORK, LIWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, BWORK, INFO ) IF( INFO.GT.0 ) THEN IF( INFO.GT.2 ) $ INFO = 2 RETURN END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C ~ ~ C STEP 3: Compute Z12 and the upper triangular part of H12, C exploiting the structure. C C Real workspace: need w1 + w2 + w3, where C w3 = 2*N**2. C IZ12 = IWRK IH12 = IZ12 + NN IWRK = IH12 + NN C C ~ [ -T12' 0 ] [ Qa Qc ] C Compute Z12 = U3' * [ ] * Q3, where Q3 =: [ ]. C [ 0 Z12 ] [ Qb Qd ] C C Part of the arrays U or Q and DWORK(IH12) are used as workspace. C IF( LCMPU ) THEN CALL DGEMM( 'Transpose', 'No Transpose', M, N, M, -ONE, $ U( MP1, 1 ), LDU, DWORK( IQ3 ), N, ZERO, $ DWORK( IH12 ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', M, N, M, ONE, $ U, LDU, DWORK( IQ3+M ), N, ZERO, DWORK( IH12+M ), $ N ) ELSE CALL DGEMM( 'Transpose', 'No Transpose', M, N, M, -ONE, $ Q( MP1, 1 ), LDQ, DWORK( IQ3 ), N, ZERO, $ DWORK( IH12 ), N ) CALL DGEMM( 'No Transpose', 'No Transpose', M, N, M, ONE, $ Q, LDQ, DWORK( IQ3+M ), N, ZERO, DWORK( IH12+M ), $ N ) END IF CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, $ DWORK( IU3 ), N, DWORK( IH12 ), N, ZERO, $ DWORK( IZ12 ), N ) C C ~ [ 0 H12 ] C Compute H12 = Q3' * [ ] * Q3. C [ H12' 0 ] C C The (2,1) block of Z is used as workspace. C C Compute Qb'*H12'*Qa + Qa'*H12*Qb. C IF( LCMPU ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U( 1, MP1 ), LDU, DWORK( IQ3+M ), N, ZERO, $ Z( MP1, 1 ), LDZ ) ELSE CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q( 1, MP1 ), LDQ, DWORK( IQ3+M ), N, ZERO, $ Z( MP1, 1 ), LDZ ) END IF CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ3 ), N, Z( MP1, 1 ), LDZ, ZERO, $ DWORK( IH12 ), N ) IS = 0 DO 110 J = 0, M - 1 CALL DAXPY( J+1, ONE, DWORK( IH12+J ), N, DWORK( IH12+IS ), 1 ) IS = IS + N 110 CONTINUE C C Compute Qb'*H12'*Qc + Qa'*H12*Qd. C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ Z( MP1, 1 ), LDZ, DWORK( IQ3+NM ), N, ZERO, $ DWORK( IH12+NM ), N ) IF( LCMPU ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ U( 1, MP1 ), LDU, DWORK( IQ3+NMM ), N, ZERO, $ Z( MP1, 1 ), LDZ ) ELSE CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ Q( 1, MP1 ), LDQ, DWORK( IQ3+NMM ), N, ZERO, $ Z( MP1, 1 ), LDZ ) END IF CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IQ3 ), N, Z( MP1, 1 ), LDZ, ONE, $ DWORK( IH12+NM ), N ) C C Compute Qd'*H12'*Qc + Qc'*H12*Qd. C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ Z( MP1, 1 ), LDZ, DWORK( IQ3+NM ), N, ZERO, $ DWORK( IH12+NMM ), N ) IS = 0 DO 120 J = 0, M - 1 CALL DAXPY( J+1, ONE, DWORK( IH12+NMM+J ), N, $ DWORK( IH12+NMM+IS ), 1 ) IS = IS + N 120 CONTINUE C C STEP 4: Apply MB03ID to reorder the eigenvalues with strictly C negative real part to the top. C C Real workspace: need w1 + w2 + w3 + w4; C w4 = MAX(4*N+48,171), if COMPQ = 'N'; C w4 = MAX(8*N+48,171), if COMPQ = 'C'. C Integer workspace: need 2*N + 1. C CALL MA02ED( 'Upper', N, DWORK( IT ), N ) C CALL MB03ID( CMQI, CMUI, N2, Z, LDZ, DWORK( IT ), N, $ DWORK( IZ12 ), N, DWORK( IH ), N, DWORK( IH12 ), N, $ Q, LDQ, U, LDU, U( 1, NP1 ), LDU, NEIG, IWORK, $ LIWORK, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) $ RETURN C IF( QR ) $ NEIG = NEIG/2 C IWRK = IZ12 C IF( LCMPQ ) THEN C C STEP 5: Compute the deflating subspace corresponding to the C eigenvalues with strictly negative real part. C C Real workspace: need w1 + w2 + N**2, if ORTH = 'QR'. C w1 + w2 + 2*N**2, otherwise. C C The workspace used before for storing H and T is reused. C C Compute [ J*Q1*J' Q2 ]. C CALL DLACPY( 'Full', M, M, DWORK( IQ1+NMM ), N, DWORK( IH ), $ N ) IW = IH + M IS = IQ1 + NM DO 140 J = 1, M DO 130 I = 1, M DWORK( IW ) = -DWORK( IS ) IW = IW + 1 IS = IS + 1 130 CONTINUE IW = IW + M IS = IS + M 140 CONTINUE C IW = IH + NM IS = IQ1 + M DO 160 J = 1, M DO 150 I = 1, M DWORK( IW ) = -DWORK( IS ) IW = IW + 1 IS = IS + 1 150 CONTINUE IW = IW + M IS = IS + M 160 CONTINUE CALL DLACPY( 'Full', M, M, DWORK( IQ1 ), N, DWORK( IH+NMM ), $ N ) C CALL DLACPY( 'Full', N, N, DWORK( IQ2 ), N, DWORK( IT ), N ) C C Compute the first NEIG columns of P*[ Q4 0; 0 Q3 ]*Q. C CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ4 ), N, Q, LDQ, ZERO, DWORK( IWRK ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ3 ), N, Q( NP1, 1 ), LDQ, ZERO, $ DWORK( IWRK+M ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ4+M ), N, Q, LDQ, ZERO, DWORK( IWRK+N ), $ N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IQ3+M ), N, Q( NP1, 1 ), LDQ, ZERO, $ DWORK( IWRK+N+M ), N2 ) C C Compute the deflating subspace. C CALL DGEMM( 'No Transpose', 'No Transpose', N, NEIG, N2, $ SQRT( TWO )/TWO, DWORK( IH ), N, DWORK( IWRK ), N2, $ ZERO, Q, LDQ ) C C Orthogonalize the basis given in Q(1:n,1:neig). C IF( LCMPU ) THEN IWRK = IQ3 ELSE IWRK = NEIG + 1 END IF IF( SVD ) THEN C C Real workspace: need w5 + N + MAX(1,5*N); C w5 = 0, if COMPU = 'N'; C w5 = w1 + N*N, if COMPU = 'C'. C prefer larger. C CALL DGESVD( 'Overwrite', 'No V', N, NEIG, Q, LDQ, DWORK, $ DWORK, 1, DWORK, 1, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 4 RETURN END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) IF( .NOT.LCMPU ) $ NEIG = NEIG/2 C ELSE IF( QR ) THEN C C Real workspace: need w5 + N; C prefer w5 + M + M*NB, where NB is the C optimal blocksize. C CALL DGEQRF( N, NEIG, Q, LDQ, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) ELSE C C Real workspace: need w5 + 4*N + 1; C prefer w5 + 3*N + (N+1)*NB. C DO 170 J = 1, NEIG IWORK( J ) = 0 170 CONTINUE CALL DGEQP3( N, NEIG, Q, LDQ, IWORK, DWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Real workspace: need w5 + 2*NEIG; C prefer w5 + NEIG + NEIG*NB. C CALL DORGQR( N, NEIG, NEIG, Q, LDQ, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) IF( QRP .AND. .NOT.LCMPU ) $ NEIG = NEIG/2 END IF C END IF C IF( LCMPU ) THEN C C STEP 6: Compute the companion subspace corresponding to the C eigenvalues with strictly negative real part. C C Real workspace: need w1 + w2 + N**2, if ORTH = 'QR'. C w1 + w2 + 2*N**2, otherwise. C C The workspace used before for storing H and T is reused. C C Set [ U1 U2 ]. C CALL DLACPY( 'Full', M, N, DWORK( IU11 ), M, DWORK( IH ), N ) IW = IH + M IS = IU12 DO 190 J = 1, M DO 180 I = 1, M DWORK( IW ) = -DWORK( IS ) IW = IW + 1 IS = IS + 1 180 CONTINUE IW = IW + M 190 CONTINUE CALL DLACPY( 'Full', M, M, DWORK( IU11 ), M, DWORK( IH+NMM ), $ N ) CALL DLACPY( 'Full', M, N, DWORK( IU21 ), M, DWORK( IT ), N ) IW = IT + M IS = IU22 DO 210 J = 1, M DO 200 I = 1, M DWORK( IW ) = -DWORK( IS ) IW = IW + 1 IS = IS + 1 200 CONTINUE IW = IW + M 210 CONTINUE CALL DLACPY( 'Full', M, M, DWORK( IU21 ), M, DWORK( IT+NMM ), $ N ) C C Compute the first NEIG columns of P*[ U3 0; 0 U3 ]*U. C CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IU3 ), N, U, LDU, ZERO, DWORK( IWRK ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, -ONE, $ DWORK( IU3 ), N, U( 1, NP1 ), LDU, ZERO, $ DWORK( IWRK+M ), N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, ONE, $ DWORK( IU3+M ), N, U, LDU, ZERO, DWORK( IWRK+N ), $ N2 ) CALL DGEMM( 'No Transpose', 'No Transpose', M, NEIG, N, -ONE, $ DWORK( IU3+M ), N, U( 1, NP1 ), LDU, ZERO, $ DWORK( IWRK+N+M ), N2 ) C C Compute the companion subspace. C CALL DGEMM( 'No Transpose', 'No Transpose', N, NEIG, N2, $ SQRT( TWO )/TWO, DWORK( IH ), N, DWORK( IWRK ), N2, $ ZERO, U, LDU ) C C Orthogonalize the basis given in U(1:n,1:neig). C IWRK = NEIG + 1 IF( SVD ) THEN C C Real workspace: need N + MAX(1,5*N); C prefer larger. C CALL DGESVD( 'Overwrite', 'No V', N, NEIG, U, LDU, DWORK, $ DWORK, 1, DWORK, 1, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) IF( INFO.GT.0 ) THEN INFO = 4 RETURN END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) NEIG = NEIG/2 C ELSE IF( QR ) THEN C C Real workspace: need N; C prefer M + M*NB, where NB is the C optimal blocksize. C CALL DGEQRF( N, NEIG, U, LDU, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) ELSE C C Real workspace: need 4*N + 1; C prefer 3*N + (N+1)*NB. C DO 220 J = 1, NEIG IWORK( J ) = 0 220 CONTINUE CALL DGEQP3( N, NEIG, U, LDU, IWORK, DWORK, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) C C Real workspace: need 2*NEIG; C prefer NEIG + NEIG*NB. C CALL DORGQR( N, NEIG, NEIG, U, LDU, DWORK, DWORK( IWRK ), $ LDWORK-IWRK+1, INFO ) OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) IF( QRP ) $ NEIG = NEIG/2 END IF C END IF C DWORK( 1 ) = OPTDW RETURN C *** Last line of MB03LF *** END control-4.1.2/src/slicot/src/PaxHeaders/SB16AY.f0000644000000000000000000000013215012430707016202 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB16AY.f0000644000175000017500000007474115012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS, $ A, LDA, B, LDB, C, LDC, D, LDD, $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, $ SCALEC, SCALEO, S, LDS, R, LDR, $ IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute for given state-space representations (A,B,C,D) and C (Ac,Bc,Cc,Dc) of the transfer-function matrices of the C open-loop system G and feedback controller K, respectively, C the Cholesky factors of the frequency-weighted C controllability and observability Grammians corresponding C to a frequency-weighted model reduction problem. C The controller must stabilize the closed-loop system. C The state matrix Ac must be in a block-diagonal real Schur form C Ac = diag(Ac1,Ac2), where Ac1 contains the unstable eigenvalues C of Ac and Ac2 contains the stable eigenvalues of Ac. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of the systems as follows: C = 'C': G and K are continuous-time systems; C = 'D': G and K are discrete-time systems. C C JOBC CHARACTER*1 C Specifies the choice of frequency-weighted controllability C Grammian as follows: C = 'S': choice corresponding to standard Enns' method [1]; C = 'E': choice corresponding to the stability enhanced C modified Enns' method of [2]. C C JOBO CHARACTER*1 C Specifies the choice of frequency-weighted observability C Grammian as follows: C = 'S': choice corresponding to standard Enns' method [1]; C = 'E': choice corresponding to the stability enhanced C modified combination method of [2]. C C WEIGHT CHARACTER*1 C Specifies the type of frequency-weighting, as follows: C = 'N': no weightings are used (V = I, W = I); C = 'O': stability enforcing left (output) weighting C -1 C V = (I-G*K) *G is used (W = I); C = 'I': stability enforcing right (input) weighting C -1 C W = (I-G*K) *G is used (V = I); C = 'P': stability and performance enforcing weightings C -1 -1 C V = (I-G*K) *G , W = (I-G*K) are used. C C Input/Output Parameters C C N (input) INTEGER C The order of the open-loop system state-space C representation, i.e., the order of the 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 NC (input) INTEGER C The order of the controller state-space representation, C i.e., the order of the matrix AC. NC >= 0. C C NCS (input) INTEGER C The dimension of the stable part of the controller, i.e., C the order of matrix Ac2. NC >= NCS >= 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 matrix A of the system with the transfer-function C matrix G. 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. 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. 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 input/output matrix D of the open-loop system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C AC (input) DOUBLE PRECISION array, dimension (LDAC,NC) C The leading NC-by-NC part of this array must contain C the state dynamics matrix Ac of the controller in a C block diagonal real Schur form Ac = diag(Ac1,Ac2), where C Ac1 is (NC-NCS)-by-(NC-NCS) and contains the unstable C eigenvalues of Ac, and Ac2 is NCS-by-NCS and contains C the stable eigenvalues of Ac. C C LDAC INTEGER C The leading dimension of array AC. LDAC >= MAX(1,NC). C C BC (input) DOUBLE PRECISION array, dimension (LDBC,P) C The leading NC-by-P part of this array must contain C the input/state matrix Bc of the controller. C C LDBC INTEGER C The leading dimension of array BC. LDBC >= MAX(1,NC). C C CC (input) DOUBLE PRECISION array, dimension (LDCC,NC) C The leading M-by-NC part of this array must contain C the state/output matrix Cc of the controller. C C LDCC INTEGER C The leading dimension of array CC. LDCC >= MAX(1,M). C C DC (input) DOUBLE PRECISION array, dimension (LDDC,P) C The leading M-by-P part of this array must contain C the input/output matrix Dc of the controller. C C LDDC INTEGER C The leading dimension of array DC. LDDC >= MAX(1,M). C C SCALEC (output) DOUBLE PRECISION C Scaling factor for the controllability Grammian. C See METHOD. C C SCALEO (output) DOUBLE PRECISION C Scaling factor for the observability Grammian. See METHOD. C C S (output) DOUBLE PRECISION array, dimension (LDS,NCS) C The leading NCS-by-NCS upper triangular part of this array C contains the Cholesky factor S of the frequency-weighted C controllability Grammian P = S*S'. See METHOD. C C LDS INTEGER C The leading dimension of array S. LDS >= MAX(1,NCS). C C R (output) DOUBLE PRECISION array, dimension (LDR,NCS) C The leading NCS-by-NCS upper triangular part of this array C contains the Cholesky factor R of the frequency-weighted C observability Grammian Q = R'*R. See METHOD. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,NCS). C C Workspace C C IWORK INTEGER array, dimension (LIWRK) C LIWRK = 0, if WEIGHT = 'N'; C LIWRK = 2(M+P), if WEIGHT = 'O', 'I', or '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, LFREQ ), C where C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4)) C if WEIGHT = 'I' or 'O' or 'P'; C LFREQ = NCS*(MAX(M,P)+5) if WEIGHT = 'N'. 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: the closed-loop system is not well-posed; C its feedthrough matrix is (numerically) singular; C = 2: the computation of the real Schur form of the C closed-loop state matrix failed; C = 3: the closed-loop state matrix is not stable; C = 4: the solution of a symmetric eigenproblem failed; C = 5: the NCS-by-NCS trailing part Ac2 of the state C matrix Ac is not stable or not in a real Schur form. C C METHOD C C If JOBC = 'S', the controllability Grammian P is determined as C follows: C C - if WEIGHT = 'O' or 'N', P satisfies for a continuous-time C controller the Lyapunov equation C C Ac2*P + P*Ac2' + scalec^2*Bc*Bc' = 0 C C and for a discrete-time controller C C Ac2*P*Ac2' - P + scalec^2*Bc*Bc' = 0; C C - if WEIGHT = 'I' or 'P', let Pi be the solution of the C continuous-time Lyapunov equation C C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0 C C or of the discrete-time Lyapunov equation C C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0, C C where Ai and Bi are the state and input matrices of a special C state-space realization of the input frequency weight (see [2]); C P results as the trailing NCS-by-NCS part of Pi partitioned as C C Pi = ( * * ). C ( * P ) C C If JOBC = 'E', a modified controllability Grammian P1 >= P is C determined to guarantee stability for a modified Enns' method [2]. C C If JOBO = 'S', the observability Grammian Q is determined as C follows: C C - if WEIGHT = 'I' or 'N', Q satisfies for a continuous-time C controller the Lyapunov equation C C Ac2'*Q + Q*Ac2 + scaleo^2*Cc'*Cc = 0 C C and for a discrete-time controller C C Ac2'*Q*Ac2 - Q + scaleo^2*Cc'*Cc = 0; C C - if WEIGHT = 'O' or 'P', let Qo be the solution of the C continuous-time Lyapunov equation C C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0 C C or of the discrete-time Lyapunov equation C C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0, C C where Ao and Co are the state and output matrices of a C special state-space realization of the output frequency weight C (see [2]); if WEIGHT = 'O', Q results as the leading NCS-by-NCS C part of Qo partitioned as C C Qo = ( Q * ) C ( * * ) C C while if WEIGHT = 'P', Q results as the trailing NCS-by-NCS C part of Qo partitioned as C C Qo = ( * * ). C ( * Q ) C C If JOBO = 'E', a modified observability Grammian Q1 >= Q is C determined to guarantee stability for a modified Enns' method [2]. C C The routine computes directly the Cholesky factors S and R C such that P = S*S' and Q = R'*R according to formulas C developed in [2]. C C REFERENCES C C [1] Enns, D. C Model reduction with balanced realizations: An error bound C and a frequency weighted generalization. C Proc. CDC, Las Vegas, pp. 127-132, 1984. C C [2] Varga, A. and Anderson, B.D.O. C Frequency-weighted balancing related controller reduction. C Proceedings of the 15th IFAC World Congress, July 21-26, 2002, C Barcelona, Spain, Vol.15, Part 1, 2002-07-21. C C CONTRIBUTORS C C A. Varga, Australian National University, Canberra, November 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, C May 2009. C A. Varga, DLR Oberpfafenhofen, June 2001. C C C KEYWORDS C C Controller reduction, frequency weighting, multivariable system, C state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOBC, JOBO, WEIGHT INTEGER INFO, LDA, LDAC, LDB, LDBC, LDC, LDCC, LDD, LDDC, $ LDR, LDS, LDWORK, M, N, NC, NCS, P DOUBLE PRECISION SCALEC, SCALEO C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*), $ C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*), $ DWORK(*), R(LDR,*), S(LDS,*) C .. Local Scalars .. CHARACTER JOBFAC LOGICAL DISCR, FRWGHT, LEFTW, PERF, RIGHTW INTEGER I, IERR, J, JJ, KI, KL, KQ, KR, KTAU, KU, KW, $ KWA, KWB, KWC, KWD, LDU, LW, MBBAR, ME, MP, $ NCU, NCU1, NE, NNC, NNCU, PCBAR, PE, WRKOPT DOUBLE PRECISION RCOND, T, TOL C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB05PD, AB05QD, AB07ND, DCOPY, DLACPY, DLASET, $ DSCAL, DSYEV, MB01WD, MB04OD, SB03OD, SB03OU, $ XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, SQRT C .. Executable Statements .. C DISCR = LSAME( DICO, 'D' ) LEFTW = LSAME( WEIGHT, 'O' ) RIGHTW = LSAME( WEIGHT, 'I' ) PERF = LSAME( WEIGHT, 'P' ) FRWGHT = LEFTW .OR. RIGHTW .OR. PERF C INFO = 0 NNC = N + NC MP = M + P IF( FRWGHT ) THEN LW = NNC*( NNC + 2*MP ) + $ MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) ) ELSE LW = NCS*( MAX( M, P ) + 5 ) END IF LW = MAX( 1, LW ) C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) $ THEN INFO = -2 ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) $ THEN INFO = -3 ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) 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( NC.LT.0 ) THEN INFO = -8 ELSE IF( NCS.LT.0 .OR. NCS.GT.NC ) THEN INFO = -9 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -17 ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN INFO = -19 ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN INFO = -21 ELSE IF( LDCC.LT.MAX( 1, M ) ) THEN INFO = -23 ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN INFO = -25 ELSE IF( LDS.LT.MAX( 1, NCS ) ) THEN INFO = -29 ELSE IF( LDR.LT.MAX( 1, NCS ) ) THEN INFO = -31 ELSE IF( LDWORK.LT.LW ) THEN INFO = -34 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB16AY', -INFO ) RETURN END IF C C Quick return if possible. C SCALEC = ONE SCALEO = ONE IF( MIN( NCS, M, P ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C WRKOPT = 1 NCU = NC - NCS NCU1 = NCU + 1 C IF( .NOT.PERF ) THEN C C Compute the Grammians in the case of no weighting or C one-sided weighting. C IF( LEFTW .OR. LSAME( WEIGHT, 'N' ) ) THEN C C Compute the standard controllability Grammian. C C Solve for the Cholesky factor S of P, P = S*S', C the continuous-time Lyapunov equation (if DICO = 'C') C C Ac2*P + P*Ac2' + scalec^2*Bc2*Bc2' = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C C Ac2*P*Ac2' - P + scalec^2*Bc2*Bc2' = 0, C C where Bc2 is the matrix formed from the last NCS rows of Bc. C C Workspace: need NCS*(P+5); C prefer larger. KU = 1 KTAU = KU + NCS*P KW = KTAU + NCS C CALL DLACPY( 'Full', NCS, P, BC(NCU1,1), LDBC, $ DWORK(KU), NCS ) CALL SB03OU( DISCR, .TRUE., NCS, P, AC(NCU1,NCU1), LDAC, $ DWORK(KU), NCS, DWORK(KTAU), S, LDS, SCALEC, $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 5 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) END IF C IF( RIGHTW .OR. LSAME( WEIGHT, 'N' ) ) THEN C C Compute the standard observability Grammian. C C Solve for the Cholesky factor R of Q, Q = R'*R, C the continuous-time Lyapunov equation (if DICO = 'C') C C Ac2'*Q + Q*Ac2 + scaleo^2*Cc2'*Cc2 = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C C Ac2'*Q*Ac2 - Q + scaleo^2*Cc2'*Cc2 = 0, C C where Cc2 is the matrix formed from the last NCS columns C of Cc. C C Workspace: need NCS*(M + 5); C prefer larger. KU = 1 KTAU = KU + M*NCS KW = KTAU + NCS C CALL DLACPY( 'Full', M, NCS, CC(1,NCU1), LDCC, $ DWORK(KU), M ) CALL SB03OU( DISCR, .FALSE., NCS, M, AC(NCU1,NCU1), LDAC, $ DWORK(KU), M, DWORK(KTAU), R, LDR, SCALEO, $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 5 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) END IF C C Finish if there are no weights. C IF( LSAME( WEIGHT, 'N' ) ) THEN DWORK(1) = WRKOPT RETURN END IF END IF C IF( FRWGHT ) THEN C C Allocate working storage for computing the weights. C C Real workspace: need MAX(1,NNC*NNC+2*NNC*MP+MP*(MP+4)); C Integer workspace: need 2*MP. C KWA = 1 KWB = KWA + NNC*NNC KWC = KWB + NNC*MP KWD = KWC + NNC*MP KW = KWD + MP*MP KL = KWD C IF( LEFTW ) THEN C C Build the extended matrices C C Ao = ( Ac+Bc*inv(R)*D*Cc Bc*inv(R)*C ), C ( B*inv(Rt)*Cc A+B*Dc*inv(R)*C ) C C Co = ( -inv(R)*D*Cc -inv(R)*C ) , C C where R = I-D*Dc and Rt = I-Dc*D. C -1 C Method: Compute Ge = ( Ge11 Ge12 ), where Ge = ( K -Im ). C ( Ge21 Ge22 ) ( -Ip G ) C C -1 C Then Ge11 = -(I-G*K) *G . C C Construct first Ge = ( K -Im ) such that the stable part C ( -Ip G ) C of K is in the leading position (to avoid updating of C QR factorization). C CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KWD), MP ) CALL AB05PD( 'N', NCS, P, M, NCU, ONE, $ AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC, $ CC(1,NCU1), LDCC, DWORK(KWD), MP, $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, $ NE, DWORK(KWA), NNC, DWORK(KWB), NNC, $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) CALL AB05QD( 'Over', NC, P, M, N, M, P, DWORK(KWA), NNC, $ DWORK(KWB), NNC, DWORK(KWC), MP, DWORK(KWD), $ MP, A, LDA, B, LDB, C, LDC, D, LDD, $ NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC, $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+MP*P), MP ) CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+M), MP ) C ELSE C C Build the extended matrices C C Ai = ( A+B*Dc*inv(R)*C B*inv(Rt)*Cc ) , C ( Bc*inv(R)*C Ac+Bc*inv(R)*D*Cc ) C C Bi = ( B*Dc*inv(R) B*inv(Rt) ) , C ( Bc*inv(R) Bc*D*inv(Rt) ) C C Ci = ( -inv(R)*C -inv(R)*D*Cc ) , where C C R = I-D*Dc and Rt = I-Dc*D. C C -1 C Method: Compute Ge = ( Ge11 Ge12 ), where Ge = ( G -Ip ). C ( Ge21 Ge22 ) ( -Im K ) C C -1 -1 C Then Ge22 = -(I-G*K) *G and Ge21 = -(I-G*K) . C C Construct first Ge = ( G -Ip ). C ( -Im K ) C CALL AB05QD( 'N', N, M, P, NC, P, M, A, LDA, B, LDB, C, LDC, $ D, LDD, AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, $ NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC, $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+MP*M), MP ) CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+P), MP ) END IF C -1 C Compute Ge = ( Ge11 Ge12 ). C ( Ge21 Ge22 ) C C Additional real workspace: need 4*MP; C Integer workspace: need 2*MP. C CALL AB07ND( NNC, MP, DWORK(KWA), NNC, DWORK(KWB), NNC, $ DWORK(KWC), MP, DWORK(KWD), MP, RCOND, $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C -1 ( A1 | B1 B2 ) C Partition Ge = (--------------) and select appropriate C ( C1 | D11 D12 ) C ( C2 | D21 D22 ) C C pointers to matrices and column dimensions to define weights. C IF( RIGHTW ) THEN C C Define B2 for Ge22. C ME = M KWB = KWB + NNC*P ELSE IF( PERF ) THEN C C Define B1 and C2 for Ge21. C ME = P KWC = KWC + M END IF END IF C IF( LEFTW .OR. PERF ) THEN C C Compute the frequency-weighted observability Grammian. C C Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro, C the continuous-time Lyapunov equation (if DICO = 'C') C C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0. C C Additional workspace: need NNC*(NNC+MAX(NNC,P)+7); C prefer larger. C LDU = MAX( NNC, P ) KU = KL KQ = KU + NNC*LDU KR = KQ + NNC*NNC KI = KR + NNC KW = KI + NNC C JOBFAC = 'N' CALL DLACPY( 'Full', P, NNC, DWORK(KWC), MP, DWORK(KU), LDU ) CALL SB03OD( DICO, JOBFAC, 'No-transpose', NNC, P, $ DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), LDU, $ SCALEO, DWORK(KR), DWORK(KI), DWORK(KW), $ LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.6 ) THEN INFO = 2 ELSE INFO = 3 END IF RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Partition Ro as Ro = ( R11 R12 ). C ( 0 R22 ) C IF( LEFTW ) THEN C C R = R11 (NCS-by-NCS). C CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU), LDU, R, LDR ) ELSE C C Compute R such that R'*R = R22'*R22 + R12'*R12, where C R22 is NCS-by-NCS and R12 is (N+NCU)-by-NCS. C R22 corresponds to the stable part of the controller. C NNCU = N + NCU CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(LDU+1)*NNCU), LDU, $ R, LDR ) KTAU = KU CALL MB04OD( 'Full', NCS, 0, NNCU, R, LDR, $ DWORK(KU+LDU*NNCU), LDU, DUM, 1, DUM, 1, $ DWORK(KTAU), DWORK(KW) ) C DO 10 J = 1, NCS IF( R(J,J).LT.ZERO ) $ CALL DSCAL( NCS-J+1, -ONE, R(J,J), LDR ) 10 CONTINUE END IF END IF C IF( RIGHTW .OR. PERF ) THEN C C Compute the frequency-weighted controllability Grammian. C C Solve for the Cholesky factor Si of Pi, Pi = Si*Si', C the continuous-time Lyapunov equation (if DICO = 'C') C C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0. C C Additional workspace: need NNC*(NNC+MAX(NNC,P,M)+7); C prefer larger. C KU = KL KQ = KU + NNC*MAX( NNC, ME ) KR = KQ + NNC*NNC KI = KR + NNC KW = KI + NNC C CALL DLACPY( 'Full', NNC, ME, DWORK(KWB), NNC, DWORK(KU), NNC ) JOBFAC = 'F' IF( RIGHTW ) JOBFAC = 'N' CALL SB03OD( DICO, JOBFAC, 'Transpose', NNC, ME, $ DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), NNC, $ SCALEC, DWORK(KR), DWORK(KI), DWORK(KW), $ LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.6 ) THEN INFO = 2 ELSE INFO = 3 END IF RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Partition Si as Si = ( S11 S12 ) with S22 NCS-by-NCS and C ( 0 S22 ) C set S = S22. C NNCU = N + NCU CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(NNC+1)*NNCU), NNC, $ S, LDS ) END IF C KU = 1 IF( LEFTW .OR. PERF ) THEN IF( LSAME( JOBO, 'E' ) ) THEN C C Form Y = -Ac2'*(R'*R)-(R'*R)*Ac2 if DICO = 'C', or C Y = -Ac2'*(R'*R)*Ac2+(R'*R) if DICO = 'D'. C C Workspace: need 2*NCS*NCS. C CALL DLACPY( 'Upper', NCS, NCS, R, LDR, DWORK(KU), NCS ) CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC, $ DWORK(KU+NCS*NCS), NCS ) CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg', $ NCS, -ONE, ZERO, R, LDR, DWORK(KU+NCS*NCS), $ NCS, DWORK(KU), NCS, IERR ) C C Compute the eigendecomposition of Y as Y = Z*Sigma*Z'. C KW = KU + NCS CALL DSYEV( 'Vectors', 'Upper', NCS, R, LDR, DWORK(KU), $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.GT.0 ) THEN INFO = 4 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Partition Sigma = (Sigma1,Sigma2), such that C Sigma1 <= 0, Sigma2 > 0. C Partition correspondingly Z = [Z1 Z2]. C TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) ) $ * DLAMCH( 'Epsilon') C _ C Form Cc = [ sqrt(Sigma2)*Z2' ] C PCBAR = 0 JJ = KU DO 20 J = 1, NCS IF( DWORK(JJ).GT.TOL ) THEN CALL DSCAL( NCS, SQRT( DWORK(JJ) ), R(1,J), 1 ) CALL DCOPY( NCS, R(1,J), 1, DWORK(KW+PCBAR), NCS ) PCBAR = PCBAR + 1 END IF JJ = JJ + 1 20 CONTINUE C C Solve for the Cholesky factor R of Q, Q = R'*R, C the continuous-time Lyapunov equation (if DICO = 'C') C _ _ C Ac2'*Q + Q*Ac2 + scaleo^2*Cc'*Cc = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C _ _ C Ac2'*Q*Ac2 - Q + scaleo^2*Cc'*Cc = 0. C C Workspace: need NCS*(NCS + 6); C prefer larger. C KU = KW KTAU = KU + NCS*NCS KW = KTAU + NCS C CALL SB03OU( DISCR, .FALSE., NCS, PCBAR, AC(NCU1,NCU1), $ LDAC, DWORK(KU), NCS, DWORK(KTAU), R, LDR, T, $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 5 RETURN END IF SCALEO = SCALEO*T WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) END IF C END IF C IF( RIGHTW .OR. PERF ) THEN IF( LSAME( JOBC, 'E' ) ) THEN C C Form X = -A2c*(S*S')-(S*S')*Ac2' if DICO = 'C', or C X = -Ac2*(S*S')*Ac2'+(S*S') if DICO = 'D'. C C Workspace: need 2*NCS*NCS. C CALL DLACPY( 'Upper', NCS, NCS, S, LDS, DWORK(KU), NCS ) CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC, $ DWORK(KU+NCS*NCS), NCS ) CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', NCS, $ -ONE, ZERO, S, LDS, DWORK(KU+NCS*NCS), NCS, $ DWORK(KU), NCS, IERR ) C C Compute the eigendecomposition of X as X = Z*Sigma*Z'. C KW = KU + NCS CALL DSYEV( 'Vectors', 'Upper', NCS, S, LDS, DWORK(KU), $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.GT.0 ) THEN INFO = 4 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Partition Sigma = (Sigma1,Sigma2), such that C Sigma1 =< 0, Sigma2 > 0. C Partition correspondingly Z = [Z1 Z2]. C TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) ) $ * DLAMCH( 'Epsilon') C _ C Form Bc = [ Z2*sqrt(Sigma2) ] C MBBAR = 0 I = KW JJ = KU DO 30 J = 1, NCS IF( DWORK(JJ).GT.TOL ) THEN MBBAR = MBBAR + 1 CALL DSCAL( NCS, SQRT( DWORK(JJ) ), S(1,J), 1 ) CALL DCOPY( NCS, S(1,J), 1, DWORK(I), 1 ) I = I + NCS END IF JJ = JJ + 1 30 CONTINUE C C Solve for the Cholesky factor S of P, P = S*S', C the continuous-time Lyapunov equation (if DICO = 'C') C _ _ C Ac2*P + P*Ac2' + scalec^2*Bc*Bc' = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C _ _ C Ac2*P*Ac2' - P + scalec^2*Bc*Bc' = 0. C C Workspace: need maximum NCS*(NCS + 6); C prefer larger. C KU = KW KTAU = KU + MBBAR*NCS KW = KTAU + NCS C CALL SB03OU( DISCR, .TRUE., NCS, MBBAR, AC(NCU1,NCU1), LDAC, $ DWORK(KU), NCS, DWORK(KTAU), S, LDS, T, $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 5 RETURN END IF SCALEC = SCALEC*T WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) END IF C END IF C C Save optimal workspace. C DWORK(1) = WRKOPT C RETURN C *** Last line of SB16AY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03RZ.f0000644000000000000000000000013215012430707016212 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03RZ.f0000644000175000017500000004767415012430707017430 0ustar00lilgelilge00000000000000 SUBROUTINE MB03RZ( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS, $ BLSIZE, W, TOL, INFO ) C PURPOSE C C To reduce an upper triangular complex matrix A (Schur form) to a C block-diagonal form using well-conditioned non-unitary similarity C transformations. The condition numbers of the transformations used C for reduction are roughly bounded by PMAX, where PMAX is a given C value. The transformations are optionally postmultiplied in a C given matrix X. The Schur form is optionally ordered, so that C clustered eigenvalues are grouped in the same block. C C ARGUMENTS C C Mode Parameters C C JOBX CHARACTER*1 C Specifies whether or not the transformations are C accumulated, as follows: C = 'N': The transformations are not accumulated; C = 'U': The transformations are accumulated in X (the C given matrix X is updated). C C SORT CHARACTER*1 C Specifies whether or not the diagonal elements of the C Schur form are reordered, as follows: C = 'N': The diagonal elements are not reordered; C = 'S': The diagonal elements are reordered before each C step of reduction, so that clustered eigenvalues C appear in the same block; C = 'C': The diagonal elements are not reordered, but the C "closest-neighbour" strategy is used instead of C the standard "closest to the mean" strategy (see C METHOD); C = 'B': The diagonal elements are reordered before each C step of reduction, and the "closest-neighbour" C strategy is used (see METHOD). C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and X. N >= 0. C C PMAX (input) DOUBLE PRECISION C An upper bound for the absolute value of the elements of C the individual transformations used for reduction C (see METHOD). PMAX >= 1.0D0. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the upper triangular matrix A to be C block-diagonalized. C On exit, the leading N-by-N upper triangular part of this C array contains the computed block-diagonal matrix, in C Schur form. C The strictly lower triangular part is used as workspace, C but it is set to zero before exit. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C X (input/output) COMPLEX*16 array, dimension (LDX,*) C On entry, if JOBX = 'U', the leading N-by-N part of this C array must contain a given matrix X. C On exit, if JOBX = 'U', the leading N-by-N part of this C array contains the product of the given matrix X and the C transformation matrix that reduced A to block-diagonal C form. The transformation matrix is itself a product of C non-unitary similarity transformations having elements C with magnitude less than or equal to PMAX. C If JOBX = 'N', this array is not referenced. C C LDX INTEGER C The leading dimension of array X. C LDX >= 1, if JOBX = 'N'; C LDX >= MAX(1,N), if JOBX = 'U'. C C NBLCKS (output) INTEGER C The number of diagonal blocks of the matrix A. C C BLSIZE (output) INTEGER array, dimension (N) C The first NBLCKS elements of this array contain the orders C of the resulting diagonal blocks of the matrix A. C C W (output) COMPLEX*16 array, dimension (N) C This array contains the eigenvalues of the matrix A. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in the ordering of the diagonal C elements of the upper triangular matrix. C If the user sets TOL > 0, then the given value of TOL is C used as an absolute tolerance: an eigenvalue i and a C temporarily fixed eigenvalue 1 (the first element of the C current trailing submatrix to be reduced) are considered C to belong to the same cluster if they satisfy C C | lambda_1 - lambda_i | <= TOL. C C If the user sets TOL < 0, then the given value of TOL is C used as a relative tolerance: an eigenvalue i and a C temporarily fixed eigenvalue 1 are considered to belong to C the same cluster if they satisfy, for j = 1, ..., N, C C | lambda_1 - lambda_i | <= | TOL | * max | lambda_j |. C C If the user sets TOL = 0, then an implicitly computed, C default tolerance, defined by TOL = SQRT( SQRT( EPS ) ) C is used instead, as a relative tolerance, where EPS is C the machine precision (see LAPACK Library routine DLAMCH). C If SORT = 'N' or 'C', this parameter is not referenced. 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 Consider first that SORT = 'N'. Let C C ( A A ) C ( 11 12 ) C A = ( ), C ( 0 A ) C ( 22 ) C C be the given matrix in Schur form, where initially A is the C 11 C first diagonal element. An attempt is made to compute a C transformation matrix X of the form C C ( I P ) C X = ( ) (1) C ( 0 I ) C C (partitioned as A), so that C C ( A 0 ) C -1 ( 11 ) C X A X = ( ), C ( 0 A ) C ( 22 ) C C and the elements of P do not exceed the value PMAX in magnitude. C An adaptation of the standard method for solving Sylvester C equations [1], which controls the magnitude of the individual C elements of the computed solution [2], is used to obtain matrix P. C When this attempt failed, a diagonal element of A , closest to C 22 C the mean of those of A is selected, and moved by unitary C 11 C similarity transformations in the leading position of A ; the C 22 C moved diagonal element is then added to the block A , increasing C 11 C its order by 1. Another attempt is made to compute a suitable C transformation matrix X with the new definitions of the blocks A C 11 C and A . After a successful transformation matrix X has been C 22 C obtained, it postmultiplies the current transformation matrix C (if JOBX = 'U'), and the whole procedure is repeated for the C block A . C 22 C C When SORT = 'S', the diagonal elements of the Schur form are C reordered before each step of the reduction, so that each cluster C of eigenvalues, defined as specified in the definition of TOL, C appears in adjacent elements. The elements for each cluster are C merged together, and the procedure described above is applied to C the larger blocks. Using the option SORT = 'S' will usually C provide better efficiency than the standard option (SORT = 'N'), C proposed in [2], because there could be no or few unsuccessful C attempts to compute individual transformation matrices X of the C form (1). However, the resulting dimensions of the blocks are C usually larger; this could make subsequent calculations less C efficient. C C When SORT = 'C' or 'B', the procedure is similar to that for C SORT = 'N' or 'S', respectively, but the block of A whose C 22 C eigenvalue(s) is (are) the closest to those of A (not to their C 11 C mean) is selected and moved to the leading position of A . This C 22 C is called the "closest-neighbour" strategy. C C REFERENCES C C [1] 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 [2] Bavely, C. and Stewart, G.W. C An Algorithm for Computing Reducing Subspaces by Block C Diagonalization. C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. C C [3] Demmel, J. C The Condition Number of Equivalence Transformations that C Block Diagonalize Matrix Pencils. C SIAM J. Numer. Anal., 20, pp. 599-610, 1983. C C NUMERICAL ASPECTS C 3 4 C The algorithm usually requires 0(N ) operations, but 0(N ) are C possible in the worst case, when the matrix cannot be diagonalized C by well-conditioned transformations. C C FURTHER COMMENTS C C The individual non-unitary transformation matrices used in the C reduction of A to a block-diagonal form have condition numbers of C the order PMAX. This does not guarantee that their product is C well-conditioned enough. The routine can be easily modified to C provide estimates for the condition numbers of the clusters of C eigenvalues. C C CONTRIBUTOR C C V. Sima, June 2021. C C REVISIONS C C V. Sima, Feb. 2022. C C KEYWORDS C C Diagonalization, unitary transformation, Schur form, Sylvester C equation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. CHARACTER JOBX, SORT INTEGER INFO, LDA, LDX, N, NBLCKS DOUBLE PRECISION PMAX, TOL C .. Array Arguments .. INTEGER BLSIZE(*) COMPLEX*16 A(LDA,*), W(*), X(LDX,*) C .. Local Scalars .. LOGICAL LJOBX, LSORN, LSORS, LSORT CHARACTER JOBV INTEGER DA11, DA22, I, IERR, J, K, L, L11, L22, L22M1 DOUBLE PRECISION BIGNUM, C, D, EDIF, SAFEMN, THRESH COMPLEX*16 AV, SC C .. External Functions .. INTEGER IZAMAX LOGICAL LSAME DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL DLAMCH, DZNRM2, IZAMAX, LSAME C .. External Subroutines .. EXTERNAL DLABAD, MA02AZ, MB03RW, XERBLA, ZCOPY, ZGEMM, $ ZLASET, ZSCAL, ZTREXC C .. Intrinsic Functions .. INTRINSIC ABS, DCMPLX, MAX, SQRT C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 LJOBX = LSAME( JOBX, 'U' ) LSORN = LSAME( SORT, 'N' ) LSORS = LSAME( SORT, 'S' ) LSORT = LSAME( SORT, 'B' ) .OR. LSORS IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LSORN .AND. .NOT.LSORT .AND. $ .NOT.LSAME( SORT, 'C' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( PMAX.LT.ONE ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( ( LDX.LT.1 ) .OR. ( LJOBX .AND. LDX.LT.N ) ) THEN INFO = -8 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB03RZ', -INFO ) RETURN END IF C C Quick return if possible. C NBLCKS = 0 IF( N.EQ.0 ) $ RETURN C C Set the "safe" minimum positive number with representable C reciprocal, and set JOBV parameter for ZTREXC routine. C SAFEMN = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SAFEMN CALL DLABAD( SAFEMN, BIGNUM ) SAFEMN = SAFEMN / DLAMCH( 'Precision' ) JOBV = JOBX IF( LJOBX ) $ JOBV = 'V' C C Set the eigenvalues of A and the tolerance for reordering the C eigenvalues in clusters, if needed. C CALL ZCOPY( N, A, LDA+1, W, 1 ) C IF( LSORT ) THEN THRESH = ABS( TOL ) IF( THRESH.EQ.ZERO ) THEN C C Use the default tolerance in ordering the elements. C THRESH = SQRT( SQRT( DLAMCH( 'Epsilon' ) ) ) END IF C IF( TOL.LE.ZERO ) THEN C C Use a relative tolerance. Find max | lambda_j |, j = 1 : N. C L = IZAMAX( N, W, 1 ) THRESH = THRESH * ABS( W(L) ) END IF END IF C C Define the following submatrices of A: C A11, the DA11-by-DA11 block in position (L11,L11); C A22, the DA22-by-DA22 block in position (L22,L22); C A12, the DA11-by-DA22 block in position (L11,L22); C A21, the DA22-by-DA11 block in position (L22,L11) (null initially C and finally). C The following loop uses L11 as loop variable and try to separate a C block in position (L11,L11), with possibly clustered eigenvalues, C separated by the other eigenvalues (in the block A22). C L11 = 1 C C WHILE ( L11.LE.N ) DO C 10 CONTINUE IF( L11.LE.N ) THEN NBLCKS = NBLCKS + 1 DA11 = 1 C IF( LSORT ) THEN C C The following loop, using K as loop variable, finds the C diagonal elements which are close to those of A11 and moves C these elements (if any) to the leading position of A22. C L22 = L11 + DA11 K = L22 C C WHILE ( K.LE.N ) DO C 20 CONTINUE IF( K.LE.N ) THEN EDIF = ABS( W(L11) - W(K) ) IF( EDIF.LE.THRESH ) THEN C C A diagonal element of A22 has been found so that C C abs( lambda_1 - lambda_k ) <= THRESH C C where lambda_1 and lambda_k denote an eigenvalue of C A11 and of the leading element in A22, respectively. C Move that element to the leading position of A22. C IF( K.GT.L22 ) THEN CALL ZTREXC( JOBV, N, A, LDA, X, LDX, K, L22, IERR) CALL ZCOPY ( K-L22+1, A(L22,L22), LDA+1, W(L22), 1) END IF C C Extend A11 with the leading element of A22. C DA11 = DA11 + 1 L22 = L11 + DA11 END IF K = K + 1 GO TO 20 END IF C C END WHILE 20 C END IF C C The following loop uses L22 as loop variable and forms a C separable DA11-by-DA11 block A11 in position (L11,L11). C L22 = L11 + DA11 L22M1 = L22 - 1 C C WHILE ( L22.LE.N ) DO C 30 CONTINUE IF( L22.LE.N ) THEN DA22 = N - L22M1 C C Try to separate the block A11 of order DA11 by using a C well-conditioned similarity transformation. C C First save A12' in the block A21, containing zeros only. C CALL MA02AZ( 'Transpose', 'Full', DA11, DA22, A(L11,L22), $ LDA, A(L22,L11), LDA ) C C Solve -A11*P + P*A22 = A12. C CALL MB03RW( DA11, DA22, PMAX, A(L11,L11), LDA, A(L22,L22), $ LDA, A(L11,L22), LDA, IERR ) C IF( IERR.EQ.1 ) THEN C C The annihilation of A12 failed. Restore A12 and A21. C CALL MA02AZ( 'Transpose', 'Full', DA22, DA11, A(L22,L11), $ LDA, A(L11,L22), LDA ) CALL ZLASET( 'Full', DA22, DA11, CZERO, CZERO, $ A(L22,L11), LDA ) C IF( LSORN .OR. LSORS ) THEN C C Extend A11 with an element of A22 having the nearest C eigenvalues to the mean of eigenvalues of A11 and C resume the loop. C First compute the mean of eigenvalues of A11. C AV = CZERO C DO 40 I = L11, L22M1 AV = AV + W(I) 40 CONTINUE C AV = AV/DA11 C C Loop to find the eigenvalue of A22 nearest to the C above computed mean. C D = ABS( AV - W(L22) ) K = L22 L = L22 + 1 C C WHILE ( L.LE.N ) DO C 50 CONTINUE IF( L.LE.N ) THEN C = ABS( AV - W(L) ) IF( C.LT.D ) THEN D = C K = L END IF L = L + 1 GO TO 50 END IF C C END WHILE 50 C ELSE C C Extend A11 with an element of A22 having the nearest C eigenvalues to the cluster of eigenvalues of A11 and C resume the loop. C C Loop to find the eigenvalue of A22 of minimum distance C to the cluster. C D = BIGNUM L = L22 K = L22 C C WHILE ( L.LE.N ) DO C 60 CONTINUE IF( L.LE.N ) THEN I = L11 C C WHILE ( I.LE.L22M1 ) DO C 70 CONTINUE IF( I.LE.L22M1 ) THEN C = ABS( W(I) - W(L) ) IF( C.LT.D ) THEN D = C K = L END IF I = I + 1 GO TO 70 END IF C C END WHILE 70 C L = L + 1 GO TO 60 END IF C C END WHILE 60 C END IF C C Try to move element found to the leading position of A22. C IF( K.GT.L22 ) THEN CALL ZTREXC( JOBV, N, A, LDA, X, LDX, K, L22, IERR ) CALL ZCOPY ( K-L22+1, A(L22,L22), LDA+1, W(L22), 1 ) END IF C C Extend A11 with the leading element of A22. C DA11 = DA11 + 1 L22 = L11 + DA11 L22M1 = L22 - 1 GO TO 30 END IF END IF C C END WHILE 30 C IF( LJOBX ) THEN C C Accumulate the transformation in X. C Only columns L22, ..., N are modified. C IF( L22.LE.N ) $ CALL ZGEMM( 'No transpose', 'No transpose', N, DA22, $ DA11, CONE, X(1,L11), LDX, A(L11,L22), LDA, $ CONE, X(1,L22), LDX ) C C Scale to unity the (non-zero) columns of X which will be C no more modified and transform A11 accordingly. C DO 80 J = L11, L22M1 C = DZNRM2( N, X(1,J), 1 ) SC = DCMPLX( C, ZERO ) IF( C.GT.SAFEMN ) THEN CALL ZSCAL( DA11, SC, A(J,L11), LDA ) SC = CONE/SC CALL ZSCAL( N, SC, X(1,J), 1 ) CALL ZSCAL( DA11, SC, A(L11,J), 1 ) END IF 80 CONTINUE C END IF C IF( L22.LE.N ) THEN C C Set A12 and A21 to zero. C CALL ZLASET( 'Full', DA11, DA22, CZERO, CZERO, A(L11,L22), $ LDA ) CALL ZLASET( 'Full', DA22, DA11, CZERO, CZERO, A(L22,L11), $ LDA ) END IF C C Store the orders of the diagonal blocks in BLSIZE. C BLSIZE(NBLCKS) = DA11 L11 = L22 GO TO 10 END IF C C END WHILE 10 C RETURN C *** Last line of MB03RZ *** END control-4.1.2/src/slicot/src/PaxHeaders/select.f0000644000000000000000000000013215012430707016554 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/select.f0000644000175000017500000000027215012430707017751 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION SELECT( PAR1, PAR2 ) C C PURPOSE C C Void logical function for DGEES. C DOUBLE PRECISION PAR1, PAR2 C SELECT = .TRUE. RETURN END control-4.1.2/src/slicot/src/PaxHeaders/SG02ND.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SG02ND.f0000644000175000017500000013415215012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE SG02ND( DICO, JOBE, JOB, JOBX, FACT, UPLO, JOBL, TRANS, $ N, M, P, A, LDA, E, LDE, B, LDB, R, LDR, IPIV, $ L, LDL, X, LDX, RNORM, K, LDK, H, LDH, XE, $ LDXE, OUFACT, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the optimal gain matrix K for the problem of optimal C control given by C C -1 C K = (R + B'XB) (B'Xop(A) + L') (1) C C in the discrete-time case and C C -1 C K = R (B'Xop(E) + L') (2) C C in the continuous-time case, where A, E, B and L are N-by-N, C N-by-N, N-by-M, and N-by-M matrices, respectively; R and X are C M-by-M and N-by-N symmetric matrices, respectively, and op(W) is C either W or W'. Matrix op(K) defines the feedback gain matrix, if C op(W) = W, and the estimator matrix, if op(W) = W'. The formulas C above are also useful in Newton's algorithms for solving algebraic C Riccati equations, when X is the current iterate. C C Optionally, matrix R may be specified in a factored form, and L C may be zero. If R or R + B'XB (for DICO = 'C', or DICO = 'D', C respectively), is positive definite, let C be its Cholesky factor C (denoted, e.g., C = chol(R), for DICO = 'C'). Optionally, the C matrix H, defined by C C H = op(E)'XB + L, if DICO = 'C', or C H = op(A)'XB + L, if DICO = 'D', (3) C C is returned on exit, besides K; if C exists, the matrix F, defined C by FC = H may be optionally returned, instead of K and H. The C matrix F or the pair of matrices H and K may be used for computing C the residual matrix for an (approximate) solution of an algebraic C Riccati equation (see SLICOT Library routine SG02CW). C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the equation from which K is to be determined, C as follows: C = 'D': Equation (1), discrete-time case; C = 'C': Equation (2), continuous-time case. C C JOBE CHARACTER*1 C Specifies whether E is a general or an identity matrix, C as follows: C = 'G': The matrix E is general and is given; C = 'I': The matrix E is assumed identity and is not given. C This parameter is not relevant for DICO = 'D'. C C JOB CHARACTER*1 C Specifies what should be computed, as follows: C = 'K': Compute and return the matrix K only; C = 'H': Compute and return both matrices H and K; C = 'F': Compute the matrix F, if possible; otherwise, C compute and return H and K; C = 'D': Compute and return both matrices H and K, when C B and L have previously been transformed using C SLICOT Library routines SB02MT or SB02MX, which C returned OUFACT = 1. This is useful for computing C K in (2), since then K is the solution of CK = H'. C In this case, FACT should be set to 'C', and the C array R must contain the Cholesky factor of C R + B'XB, if DICO = 'D'; C = 'C': Compute and return the matrix F, when B and L have C previously been transformed using SB02MT or C SB02MX, which returned OUFACT = 1. In this case, C FACT should be set to 'C', and the array R must C contain the Cholesky factor of R + B'XB, if C DICO = 'D'. C JOB should not be set to 'F' if FACT = 'U'. C C JOBX CHARACTER*1 C Specifies whether the matrix op(Xop(E)), if DICO = 'C', or C op(Xop(A)), if DICO = 'D', must be computed, as follows: C = 'C': Compute and return the coresponding matrix; C = 'N': Do not compute that matrix. C This parameter is not relevant for DICO = 'C' and C JOBE = 'I'. C C FACT CHARACTER*1 C Specifies how the matrix R is given (factored or not), as C follows: C = 'N': Array R contains the matrix R; C = 'D': Array R contains a P-by-M matrix D, where R = D'D; C = 'C': Array R contains the Cholesky factor of R; C = 'U': Array R contains the symmetric indefinite UdU' or C LdL' factorization of R. This option is not C available for DICO = 'D'. C C UPLO CHARACTER*1 C Specifies which triangle of the possibly factored matrix R C (or R + B'XB, on exit) is or should be stored, as follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. C C JOBL CHARACTER*1 C Specifies whether or not the matrix L is zero, as follows: C = 'Z': L is zero; C = 'N': L is nonzero. C C TRANS CHARACTER*1 C Specifies the form of op(W) to be used in the matrix C multiplication, as follows: C = 'N': op(W) = W; C = 'T': op(W) = W'; C = 'C': op(W) = W'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and X. N >= 0. C No computations are performed if MIN(N,M) = 0. C C M (input) INTEGER C The order of the matrix R and the number of columns of the C matrices B and L. M >= 0. C C P (input) INTEGER C The number of rows of the matrix D. C P >= M for DICO = 'C'; C P >= 0 for DICO = 'D'. C This parameter is relevant only for FACT = 'D'. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C If DICO = 'D', the leading N-by-N part of this array must C contain the state matrix A of the system. C If DICO = 'C', this array is not referenced. C C LDA INTEGER C The leading dimension of array A. C LDA >= MAX(1,N) if DICO = 'D'; C LDA >= 1 if DICO = 'C'. C C E (input) DOUBLE PRECISION array, dimension (LDE,*) C If JOBE = 'G' and DICO = 'C', the leading N-by-N part of C this array must contain the matrix E. C If JOBE = 'I' or DICO = 'D', this array is not referenced. C C LDE INTEGER C The leading dimension of array E. C LDE >= MAX(1,N), if JOBE = 'G' and DICO = 'C'; C LDE >= 1, if JOBE = 'I' or DICO = 'D'. C C B (input/worksp.) DOUBLE PRECISION array, dimension (LDB,M) C The leading N-by-M part of this array must contain the C input matrix B of the system, transformed by SB02MT or C SB02MX, if JOB = 'D' or JOB = 'C'. C If DICO = 'D' and FACT = 'D' or 'C', the contents of this C array is destroyed. Specifically, if, on exit, C OUFACT(2) = 1, this array contains chol(X)*B, and if C OUFACT(2) = 2 and INFO < M+2, but INFO >= 0, its trailing C part (in the first N rows) contains the submatrix of C sqrt(V)*U'B corresponding to the non-negligible, positive C eigenvalues of X, where V and U are the matrices with the C eigenvalues and eigenvectors of X. C Otherwise, B is unchanged on exit. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) C On entry, if FACT = 'N', the leading M-by-M upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the upper C triangular part or lower triangular part, respectively, C of the symmetric input weighting matrix R. C On entry, if FACT = 'D', the leading P-by-M part of this C array must contain the direct transmission matrix D of the C system. C On entry, if FACT = 'C', the leading M-by-M upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the Cholesky C factor of the positive definite input weighting matrix R C (as produced by LAPACK routine DPOTRF). C On entry, if DICO = 'C' and FACT = 'U', the leading M-by-M C upper triangular part (if UPLO = 'U') or lower triangular C part (if UPLO = 'L') of this array must contain the C factors of the UdU' or LdL' factorization, respectively, C of the symmetric indefinite input weighting matrix R (as C produced by LAPACK routine DSYTRF). C The strictly lower triangular part (if UPLO = 'U') or C strictly upper triangular part (if UPLO = 'L') of this C array is used as workspace (filled in by symmetry with the C other strictly triangular part of R, of R+B'XB, or of the C result, if DICO = 'C', DICO = 'D' (if FACT = 'N', in both C cases), or (DICO = 'D' and (FACT = 'D' or FACT = 'C') and C UPLO = 'L'), respectively. C On exit, if OUFACT(1) = 1, and INFO = 0 (or INFO = M+1), C the leading M-by-M upper triangular part (if UPLO = 'U') C or lower triangular part (if UPLO = 'L') of this array C contains the Cholesky factor of the given input weighting C matrix R (for DICO = 'C'), or that of the matrix R + B'XB C (for DICO = 'D'). C On exit, if OUFACT(1) = 2, and INFO = 0 (or INFO = M+1), C the leading M-by-M upper triangular part (if UPLO = 'U') C or lower triangular part (if UPLO = 'L') of this array C contains the factors of the UdU' or LdL' factorization, C respectively, of the given input weighting matrix C (for DICO = 'C'), or that of the matrix R + B'XB C (for DICO = 'D' and FACT = 'N'). C On exit R is unchanged if FACT = 'U' or N = 0. C C LDR INTEGER. C The leading dimension of the array R. C LDR >= MAX(1,M) if FACT <> 'D'; C LDR >= MAX(1,M,P) if FACT = 'D'. C C IPIV (input/output) INTEGER array, dimension (M) C On entry, if FACT = 'U', this array must contain details C of the interchanges performed and the block structure of C the d factor in the UdU' or LdL' factorization of matrix R C (as produced by LAPACK routine DSYTRF). C On exit, if OUFACT(1) = 2, this array contains details of C the interchanges performed and the block structure of the C d factor in the UdU' or LdL' factorization of matrix R or C R + B'XB, as produced by LAPACK routine DSYTRF. C This array is not referenced if FACT = 'D', or FACT = 'C', C or N = 0. C C L (input) DOUBLE PRECISION array, dimension (LDL,M) C If JOBL = 'N', the leading N-by-M part of this array must C contain the cross weighting matrix L, transformed by C SB02MT or SB02MX, if JOB = 'D' or JOB = 'C'. C If JOBL = 'Z', this array is not referenced. C C LDL INTEGER C The leading dimension of array L. C LDL >= MAX(1,N) if JOBL = 'N'; C LDL >= 1 if JOBL = 'Z'. 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 (approximate) solution matrix X of the C algebraic Riccati equation as produced by SLICOT Library C routines SB02MD or SB02OD (or SG02CD). Matrix X is assumed C non-negative definite if DICO = 'D', FACT <> 'N', C JOB <> 'D' and JOB <> 'C'. The full matrix X must be given C on input in this case. C For minimal workspace, full matrix X must also be given if C ((JOBX = 'C', DICO = 'D', FACT = 'N', and M > N), or C (JOBX = 'N', ((DICO = 'C' or FACT = 'N'), (DICO = 'D' or C JOBE = 'I') or N >= M, or LDWORK < N*N) and (DICO = 'D' C or JOBE = 'G' or JOB = 'K'))) and LDWORK < N*M. C (Simpler, but more demanding conditions are the following: C ((JOBX = 'C', DICO = 'D', FACT = 'N', and M > N), or C (JOBX = 'N', (DICO = 'D' or ((DICO = 'C', JOBE = 'G') or C JOB = 'K'))), LDWORK < N*N.) C For optimal workspace, full matrix X is not needed in any C of the cases described above for minimal workspace. C On exit, if DICO = 'D', FACT = 'D' or FACT = 'C', and C OUFACT(2) = 1, the N-by-N upper triangular part C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') C of this array contains the Cholesky factor of the given C matrix X, which is found to be positive definite. C On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 2, C and INFO <> M+2 (but INFO >= 0), the leading N-by-N part C of this array contains the matrix of orthonormal C eigenvectors of X. C On exit X is unchanged if DICO = 'C' or FACT = 'N'. C C LDX INTEGER C The leading dimension of array X. LDX >= MAX(1,N). C C RNORM (input) DOUBLE PRECISION C If FACT = 'U', this parameter must contain the 1-norm of C the original matrix R (before factoring it). C Otherwise, this parameter is not used. C C K (output) DOUBLE PRECISION array, dimension (LDK,N) C If JOB = 'K' or JOB = 'H' or JOB = 'D' or OUFACT(1) = 2, C the leading M-by-N part of this array contains the gain C matrix K. C C LDK INTEGER C The leading dimension of array K. LDK >= MAX(1,M). C C H (output) DOUBLE PRECISION array, dimension (LDH,*) C If JOB = 'H' or JOB = 'D' or (JOB = 'F' and C OUFACT(1) = 2), the leading N-by-M part of this array C contains the matrix H. C If JOB = 'C' or (JOB = 'F' and OUFACT(1) = 1), the leading C N-by-M part of this array contains the matrix F. C If JOB = 'K', this array is not referenced. C C LDH INTEGER C The leading dimension of array H. C LDH >= MAX(1,N), if JOB <> 'K'; C LDH >= 1, if JOB = 'K'. C C XE (output) DOUBLE PRECISION array, dimension (LDXE,*) C If JOBX = 'C', DICO = 'C', and JOBE = 'G', the leading C N-by-N part of this array contains the matrix product X*E, C if TRANS = 'N', or E*X, if TRANS = 'T' or TRANS = 'C'. C If JOBX = 'C' and DICO = 'D', the leading N-by-N part of C this array contains the matrix product X*A, if C TRANS = 'N', or A*X, if TRANS = 'T' or TRANS = 'C'. C These matrix products may be needed for computing the C residual matrix for an (approximate) solution of a Riccati C equation (see SLICOT Library routine SG02CW). C If JOBX = 'N' or (DICO = 'C' and JOBE = 'I'), this array C is not referenced. C C LDXE INTEGER C The leading dimension of array XE. C LDXE >= MAX(1,N), if JOBX = 'C', and either DICO = 'C' and C JOBE = 'G', or DICO = 'D'; C LDXE >= 1, if JOBX = 'N' or (DICO = 'C' and C JOBE = 'I'). C C OUFACT (output) INTEGER array, dimension (2) C Information about the factorization finally used. C OUFACT(1) = 1: Cholesky factorization of R (or R + B'XB) C has been used; C OUFACT(1) = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = C 'L') factorization of R (or R + B'XB) C has been used; C OUFACT(2) = 1: Cholesky factorization of X has been used; C OUFACT(2) = 2: Spectral factorization of X has been used. C The value of OUFACT(2) is not set for DICO = 'C' or for C DICO = 'D' and FACT = 'N'. C This array is not set if N = 0 or M = 0. C C Workspace C C IWORK INTEGER array, dimension (M) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or LDWORK = -1, DWORK(1) returns the C optimal value of LDWORK, and for LDWORK set as specified C below, DWORK(2) contains the reciprocal condition number C of the matrix R (for DICO = 'C') or of R + B'XB (for C DICO = 'D'), if FACT = 'N' or FACT = 'U' or OUFACT(1) = 2, C or of its Cholesky factor, if FACT = 'C' or FACT = 'D' and C OUFACT(1) = 1; DWORK(2) is set to 1 if N = 0. C On exit, if LDWORK = -2 on input or INFO = -35, then C DWORK(1) returns the minimal value of LDWORK. C If on exit INFO = 0, and OUFACT(2) = 2, then DWORK(3),..., C DWORK(N+2) contain the eigenvalues of X, in ascending C order. C C LDWORK INTEGER C Dimension of working array DWORK. C Let a = N, if JOBX = 'N' and (DICO = 'D' or JOBE = 'G'); C a = 0, otherwise. Then C LDWORK >= max(2,2*M,a) if FACT = 'U'; C LDWORK >= max(2,3*M,4*N+1) if FACT = 'D' or C (FACT = 'C' and JOB <> 'C' C and JOB <> 'D'), DICO = 'D'; C LDWORK >= max(2,3*M,a) otherwise. C For optimum performance LDWORK should be larger. C C If LDWORK = -1, an optimal workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C If LDWORK = -2, a minimal workspace query is assumed; the C routine only calculates the minimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message 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 = i: if the i-th element of the d factor is exactly zero; C the UdU' (or LdL') factorization has been completed, C but the block diagonal matrix d is exactly singular; C = M+1: if the matrix R (if DICO = 'C'), or R + B'XB C (if DICO = 'D') is numerically singular (to working C precision); C = M+2: if one or more of the eigenvalues of X has not C converged; C = M+3: if the matrix X is indefinite and updating the C triangular factorization failed. C If INFO > M+1, call the routine again with an appropriate, C unfactored matrix R. C C METHOD C C The (optimal) gain matrix K is obtained as the solution to the C system of linear equations C C (R + B'XB) * K = B'Xop(A) + L' C C in the discrete-time case and C C R * K = B'Xop(E) + L' C C in the continuous-time case, with R replaced by D'D if FACT = 'D'. C If FACT = 'N', Cholesky factorization is tried first, but C if the coefficient matrix is not positive definite, then UdU' (or C LdL') factorization is used. If FACT <> 'N', the factored form C of R is taken into account. The discrete-time case then involves C updating of a triangular factorization of R (or D'D); Cholesky or C symmetric spectral factorization of X is employed to avoid C squaring of the condition number of the matrix. When D is given, C its QR factorization is determined, and the triangular factor is C used as described above. C C NUMERICAL ASPECTS C C The algorithm consists of numerically stable steps. C 3 2 C For DICO = 'C' and JOBE = 'I', it requires O(m + mn ) floating C 2 C point operations if FACT = 'N' and O(mn ) floating point C operations, otherwise. C For DICO = 'D' or JOBE = 'G', the operation counts are similar, C 3 C but additional O(n ) floating point operations may be needed in C the worst case. C These estimates assume that M <= N. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2014. C C REVISIONS C C V. Sima, Feb. 2014, July 2017, Dec. 2017. C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, discrete-time system, matrix algebra, optimal control, C optimal regulator. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, FACT, JOB, JOBE, JOBL, JOBX, TRANS, UPLO INTEGER INFO, LDA, LDB, LDE, LDH, LDK, LDL, LDR, LDWORK, $ LDX, LDXE, M, N, P DOUBLE PRECISION RNORM C .. Array Arguments .. INTEGER IPIV(*), IWORK(*), OUFACT(2) DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*), $ H(LDH,*), K(LDK,*), L(LDL,*), R(LDR,*), $ X(LDX,*), XE(LDXE,*) C .. Local Scalars .. LOGICAL DISCR, LASTCS, LFACTA, LFACTC, LFACTD, LFACTU, $ LJOBE, LNFACT, LTRANS, LUPLOU, SUFWRK, WITHC, $ WITHCD, WITHD, WITHF, WITHH, WITHL, WITHXE CHARACTER NT, NTRANS, NUPLO, SIDE, TR, TRL INTEGER I, IFAIL, JW, JZ, MS, NM, NR, WRKMIN, WRKOPT DOUBLE PRECISION EPS, RCOND, RNORMP, TEMP, TMP C .. Local Arrays .. DOUBLE PRECISION DUMMY(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL DLAMCH, DLANSY, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DLACPY, DLASET, $ DPOCON, DPOTRF, DPOTRS, DSCAL, DSYCON, DSYEV, $ DSYMM, DSYTRF, DSYTRS, DTRCON, DTRMM, DTRSM, $ MA02AD, MA02ED, MB01RB, MB01RU, MB04KD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 DISCR = LSAME( DICO, 'D' ) LFACTC = LSAME( FACT, 'C' ) LFACTD = LSAME( FACT, 'D' ) LFACTU = LSAME( FACT, 'U' ) LJOBE = LSAME( JOBE, 'G' ) LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) LUPLOU = LSAME( UPLO, 'U' ) WITHC = LSAME( JOB, 'C' ) WITHD = LSAME( JOB, 'D' ) WITHF = LSAME( JOB, 'F' ) WITHH = LSAME( JOB, 'H' ) WITHL = LSAME( JOBL, 'N' ) WITHXE = LSAME( JOBX, 'C' ) LFACTA = LFACTC .OR. LFACTD .OR. LFACTU WITHCD = WITHC .OR. WITHD WITHH = WITHH .OR. WITHF .OR. WITHCD LNFACT = .NOT.LFACTA C C Test the input scalar arguments. C IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.LJOBE .AND. .NOT.LSAME( JOBE, 'I' ) .AND. $ .NOT.DISCR ) THEN INFO = -2 ELSE IF( .NOT.WITHH .AND. .NOT.LSAME( JOB, 'K' ) ) THEN INFO = -3 ELSE IF( .NOT.WITHXE .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN IF( DISCR .OR. LJOBE ) $ INFO = -4 ELSE IF( ( LNFACT .AND. .NOT.LSAME( FACT, 'N' ) ) .OR. $ ( DISCR .AND. LFACTU ) .OR. $ ( .NOT.LFACTC .AND. WITHCD ) ) THEN INFO = -5 ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -6 ELSE IF( .NOT.WITHL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN INFO = -7 ELSE IF( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN INFO = -8 ELSE IF( N.LT.0 ) THEN INFO = -9 ELSE IF( M.LT.0 ) THEN INFO = -10 ELSE IF( LFACTD .AND. ( P.LT.0 .OR. ( .NOT.DISCR .AND. P.LT.M ) ) $ ) THEN INFO = -11 ELSE IF( LDA.LT.1 .OR. ( LDA.LT.N .AND. DISCR ) ) THEN INFO = -13 ELSE IF( LDE.LT.1 .OR. ( LDE.LT.N .AND. .NOT.DISCR $ .AND. LJOBE ) ) THEN INFO = -15 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDR.LT.MAX( 1, M ) .OR. ( LFACTD .AND. LDR.LT.P ) ) THEN INFO = -19 ELSE IF( LDL.LT.1 .OR. ( WITHL .AND. LDL.LT.N ) ) THEN INFO = -22 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -24 ELSE IF( LFACTU ) THEN IF( RNORM.LT.ZERO ) $ INFO = -25 END IF IF ( INFO.EQ.0 ) THEN IF( LDK.LT.MAX( 1, M ) ) THEN INFO = -27 ELSE IF( LDH.LT.1 .OR. ( WITHH .AND. LDH.LT.N ) ) THEN INFO = -29 ELSE IF( LDXE.LT.1 .OR. ( WITHXE .AND. ( DISCR .OR. LJOBE ) $ .AND. LDXE.LT.N ) ) THEN INFO = -31 ELSE IF ( LUPLOU ) THEN NUPLO = 'Lower' ELSE NUPLO = 'Upper' END IF NM = N*M IF ( DISCR .AND. LFACTA .AND. .NOT.WITHCD ) THEN WRKMIN = MAX( 2, 3*M, 4*N + 1 ) ELSE IF ( .NOT.WITHXE .AND. ( DISCR .OR. LJOBE ) ) THEN WRKMIN = MAX( 2, N ) ELSE WRKMIN = 2 END IF IF( LFACTU ) THEN WRKMIN = MAX( WRKMIN, 2*M ) ELSE WRKMIN = MAX( WRKMIN, 3*M ) END IF END IF IF( LDWORK.EQ.-1 ) THEN IF ( WITHXE .AND. ( DISCR .OR. LJOBE ) ) THEN IF ( DISCR .AND. LNFACT .AND. M.GT.N ) THEN WRKOPT = NM ELSE WRKOPT = 0 END IF ELSE IF ( ( ( DISCR .AND. LFACTA ) .OR. ( .NOT.DISCR $ .AND. LJOBE ) ) .AND. N.LT.M ) THEN WRKOPT = N*N ELSE IF ( .NOT.( DISCR .OR. LJOBE ) .AND. WITHH ) THEN WRKOPT = 0 ELSE WRKOPT = NM END IF C IF( LFACTA ) THEN IF ( LFACTD ) THEN CALL DGEQRF( P, M, R, LDR, DWORK, DWORK, -1, IFAIL) WRKOPT = MAX( WRKOPT, INT( DWORK(1) )+MIN( P, M ) ) END IF IF( DISCR .AND. .NOT.WITHCD ) THEN CALL DSYEV( 'Vectors', NUPLO, N, X, LDX, DWORK, $ DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + N + 2, $ NM + N + 2 ) END IF ELSE CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF DWORK(1) = MAX( WRKMIN, WRKOPT ) RETURN ELSE IF( LDWORK.EQ.-2 ) THEN DWORK(1) = WRKMIN RETURN ELSE IF( LDWORK.LT.WRKMIN ) THEN INFO = -35 DWORK(1) = WRKMIN RETURN END IF END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SG02ND', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 ) THEN DWORK(1) = TWO IF ( N.EQ.0 ) THEN DWORK(2) = ONE ELSE DWORK(2) = ZERO END IF RETURN END IF C EPS = DLAMCH( 'Precision' ) C C Determine the right-hand side of the matrix equation, and R+B'XB, C if needed. C 1. If JOBX = 'N' or (DICO = 'C' and JOBE = 'I'), compute B'X C in K or XB either in H, if JOB <> 'K', or in the workspace, if C enough space. If JOB <> 'K', compute H in (3), otherwise compute C H' in K. The same formulas for H are used for JOB = 'D' or C JOB = 'C', but B and L on entry are transformed matrices; however, C the returned results correspond to the original matrices. C 2. If JOBX = 'C', compute op(Xop(E)) or op(Xop(A)) in XE, for C DICO = 'C' (and JOBE = 'G') or DICO = 'D', respectively. C Then, use XE in computations similar to those described above. 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 C Workspace: need 0; C prefer N*N, if M > N and ((DICO = 'D' and FACT <> 'N') C or (DICO = 'C' and JOBE = 'G')) C and JOBX = 'N'; C M*N, otherwise. C Only a triangle of X is needed when using the preferred length. C SUFWRK = LDWORK.GE.NM C NT = 'No transpose' TR = 'Transpose' IF ( LTRANS ) THEN NTRANS = NT SIDE = 'Right' ELSE NTRANS = TR SIDE = 'Left' END IF C IF ( WITHL ) THEN TEMP = ONE ELSE TEMP = ZERO END IF C IF ( WITHXE .AND. ( DISCR .OR. LJOBE ) ) THEN LASTCS = .FALSE. IF ( DISCR ) THEN IF ( LNFACT ) THEN C C Discrete-time case. Compute a triangle of R + B'XB. C IF ( M.LE.N ) THEN CALL MB01RU( UPLO, TR, M, N, ONE, ONE, R, LDR, B, LDB, $ X, LDX, XE, NM, INFO ) WRKOPT = 0 ELSE IF ( SUFWRK ) THEN CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, B, LDB, $ ZERO, DWORK, N ) CALL MB01RB( 'Left', UPLO, TR, M, N, ONE, ONE, R, LDR, $ B, LDB, DWORK, N, IFAIL ) WRKOPT = NM ELSE C C This case needs a full matrix X. C CALL DGEMM( TR, NT, M, N, N, ONE, B, LDB, X, LDX, $ ZERO, K, LDK ) CALL MB01RB( 'Left', UPLO, NT, M, N, ONE, ONE, R, LDR, $ K, LDK, B, LDB, IFAIL ) WRKOPT = 0 END IF END IF CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, A, LDA, ZERO, XE, $ LDXE ) ELSE CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, E, LDE, ZERO, XE, $ LDXE ) WRKOPT = 0 END IF IF ( WITHH ) THEN IF ( WITHL ) $ CALL DLACPY( 'All', N, M, L, LDL, H, LDH ) CALL DGEMM( NTRANS, NT, N, M, N, ONE, XE, LDXE, B, LDB, $ TEMP, H, LDH ) CALL MA02AD( 'All', N, M, H, LDH, K, LDK ) ELSE IF ( WITHL ) $ CALL MA02AD( 'All', N, M, L, LDL, K, LDK ) CALL DGEMM( TR, TRANS, M, N, N, ONE, B, LDB, XE, LDXE, TEMP, $ K, LDK ) END IF C ELSE IF ( (( DISCR .AND. LFACTA ) .OR. ( .NOT.DISCR .AND. LJOBE )) $ .AND. N.LT.M .AND. LDWORK.GE.N*N ) THEN LASTCS = .FALSE. IF ( DISCR ) THEN CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, A, LDA, ZERO, $ DWORK, N ) ELSE CALL DSYMM( SIDE, UPLO, N, N, ONE, X, LDX, E, LDE, ZERO, $ DWORK, N ) END IF C IF ( WITHH ) THEN IF ( WITHL ) $ CALL DLACPY( 'All', N, M, L, LDL, H, LDH ) CALL DGEMM( NTRANS, NT, N, M, N, ONE, DWORK, N, B, LDB, $ TEMP, H, LDH ) CALL MA02AD( 'All', N, M, H, LDH, K, LDK ) ELSE IF ( WITHL ) $ CALL MA02AD( 'All', N, M, L, LDL, K, LDK ) CALL DGEMM( TR, TRANS, M, N, N, ONE, B, LDB, DWORK, N, TEMP, $ K, LDK ) END IF WRKOPT = N*N C ELSE IF ( .NOT.( DISCR .OR. LJOBE ) .AND. WITHH ) THEN C C Continuous-time case, with E identity, JOB <> 'K'. C LASTCS = .FALSE. C IF ( WITHH ) THEN IF ( WITHL ) $ CALL DLACPY( 'All', N, M, L, LDL, H, LDH ) CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, B, LDB, TEMP, $ H, LDH ) CALL MA02AD( 'All', N, M, H, LDH, K, LDK ) WRKOPT = 0 END IF C ELSE IF ( SUFWRK ) THEN LASTCS = .FALSE. IF ( DISCR .OR. LJOBE ) THEN CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, B, LDB, ZERO, $ DWORK, N ) IF ( WITHH ) THEN IF ( WITHL ) $ CALL DLACPY( 'All', N, M, L, LDL, H, LDH ) IF ( DISCR ) THEN CALL DGEMM( NTRANS, NT, N, M, N, ONE, A, LDA, DWORK, $ N, TEMP, H, LDH ) ELSE CALL DGEMM( NTRANS, NT, N, M, N, ONE, E, LDE, DWORK, $ N, TEMP, H, LDH ) END IF CALL MA02AD( 'All', N, M, H, LDH, K, LDK ) ELSE IF ( WITHL ) $ CALL MA02AD( 'All', N, M, L, LDL, K, LDK ) IF ( DISCR ) THEN CALL DGEMM( TR, TRANS, M, N, N, ONE, DWORK, N, A, LDA, $ TEMP, K, LDK ) ELSE CALL DGEMM( TR, TRANS, M, N, N, ONE, DWORK, N, E, LDE, $ TEMP, K, LDK ) END IF END IF WRKOPT = NM C ELSE IF ( .NOT.WITHH .OR. LDWORK.GE.NM ) THEN C C Continuous-time case, E identity. C IF ( WITHH ) THEN IF ( WITHL ) $ CALL DLACPY( 'All', N, M, L, LDL, H, LDH ) CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, B, LDB, $ TEMP, H, LDH ) CALL MA02AD( 'All', N, M, H, LDH, K, LDK ) WRKOPT = 0 ELSE IF ( WITHL ) $ CALL DLACPY( 'All', N, M, L, LDL, DWORK, N ) CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, B, LDB, $ TEMP, DWORK, N ) CALL MA02AD( 'All', N, M, DWORK, N, K, LDK ) WRKOPT = NM END IF END IF C ELSE C C This case needs a full matrix X. C LASTCS = .TRUE. C IF( WITHH ) THEN CALL DGEMM( NT, NT, N, M, N, ONE, X, LDX, B, LDB, ZERO, H, $ LDH ) ELSE CALL DGEMM( TR, NT, M, N, N, ONE, B, LDB, X, LDX, ZERO, K, $ LDK ) END IF WRKOPT = 0 END IF C IF ( LNFACT ) THEN C C R not factored. C IF ( DISCR .AND. .NOT.WITHXE ) THEN C C Discrete-time case. Compute a triangle of R + B'XB. C IF ( SUFWRK ) THEN CALL MB01RB( 'Left', UPLO, TR, M, N, ONE, ONE, R, LDR, $ DWORK, N, B, LDB, IFAIL ) ELSE IF( WITHH ) THEN CALL MB01RB( 'Left', UPLO, TR, M, N, ONE, ONE, R, LDR, B, $ LDB, H, LDH, IFAIL ) ELSE CALL MB01RB( 'Left', UPLO, NT, M, N, ONE, ONE, R, LDR, K, $ LDK, B, LDB, IFAIL ) END IF END IF C C Compute the 1-norm of the matrix R or R + B'XB. C Workspace: need M. C RNORMP = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) END IF C IF ( LASTCS ) THEN MS = MAX( INT( LDWORK/N ), 1 ) C C Workspace (for DICO = 'D' or JOBE = 'G'): need N; C prefer N*M. IF ( WITHH ) THEN C C Premultiply XB by op(A)' or by op(E)' (on block-columns). C Add L if needed. C IF ( DISCR ) THEN C DO 10 I = 1, M, MS NR = MIN( MS, M-I+1 ) CALL DLACPY( 'All', N, NR, H(1,I), LDH, DWORK, N ) IF ( WITHL ) $ CALL DLACPY( 'All', N, NR, L(1,I), LDL, H(1,I), $ LDH ) CALL DGEMM( NTRANS, NT, N, NR, N, ONE, A, LDA, DWORK, $ N, TEMP, H(1,I), LDH ) 10 CONTINUE C ELSE IF ( LJOBE ) THEN C DO 20 I = 1, M, MS NR = MIN( MS, M-I+1 ) CALL DLACPY( 'All', N, NR, H(1,I), LDH, DWORK, N ) IF ( WITHL ) $ CALL DLACPY( 'All', N, NR, L(1,I), LDL, H(1,I), $ LDH ) CALL DGEMM( NTRANS, NT, N, NR, N, ONE, E, LDE, DWORK, $ N, TEMP, H(1,I), LDH ) 20 CONTINUE C ELSE IF ( WITHL ) THEN C DO 30 I = 1, M CALL DAXPY( N, ONE, L(1,I), 1, K(I,1), LDK ) 30 CONTINUE C END IF CALL MA02AD( 'All', N, M, H, LDH, K, LDK ) C ELSE C C Postmultiply B'X by op(A) or by op(E) (on block-rows). C Add L if needed. C IF ( DISCR ) THEN C DO 40 I = 1, M, MS NR = MIN( MS, M-I+1 ) CALL DLACPY( 'All', NR, N, K(I,1), LDK, DWORK, NR ) IF ( WITHL ) $ CALL MA02AD( 'All', N, NR, L(1,I), LDL, K(I,1), $ LDK ) CALL DGEMM( NT, TRANS, NR, N, N, ONE, DWORK, NR, A, $ LDA, TEMP, K(I,1), LDK ) 40 CONTINUE C ELSE IF ( LJOBE ) THEN C DO 50 I = 1, M, MS NR = MIN( MS, M-I+1 ) CALL DLACPY( 'All', NR, N, K(I,1), LDK, DWORK, NR ) IF ( WITHL ) $ CALL MA02AD( 'All', N, NR, L(1,I), LDL, K(I,1), $ LDK ) CALL DGEMM( NT, TRANS, NR, N, N, ONE, DWORK, NR, E, $ LDE, TEMP, K(I,1), LDK ) 50 CONTINUE C ELSE IF ( WITHL ) THEN C DO 60 I = 1, M CALL DAXPY( N, ONE, L(1,I), 1, K(I,1), LDK ) 60 CONTINUE C END IF END IF C END IF C WRKOPT = MAX( WRKMIN, WRKOPT ) C C Solve the matrix equation. C IF ( LUPLOU ) THEN TRL = NT ELSE TRL = TR END IF C IF ( LFACTA ) THEN C C Case 1: Matrix R is given in a factored form. C IF ( LFACTD ) THEN C C Use QR factorization of D. C Workspace: need min(P,M) + M, C prefer min(P,M) + M*NB. C JW = MIN( P, M ) + 1 CALL DGEQRF( P, M, R, LDR, DWORK, DWORK(JW), LDWORK-JW+1, $ IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 ) IF ( P.LT.M ) $ CALL DLASET( 'Full', M-P, M, ZERO, ZERO, R(P+1,1), LDR ) C C Make positive the diagonal elements of the triangular C factor. Construct the strictly lower triangle, if requested. C DO 70 I = 1, M IF ( .NOT.LUPLOU ) $ CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) IF ( R(I,I).LT.ZERO ) $ CALL DSCAL( M-I+1, -ONE, R(I,I), LDR ) 70 CONTINUE C END IF C IF ( DISCR .AND. .NOT.WITHCD ) THEN JZ = 0 C C Discrete-time case. Update the factorization for B'XB. C Try first the Cholesky factorization of X, saving the C diagonal of X, in order to recover it, if X is not positive C definite. In the later case, use spectral factorization. C Workspace: need N. C CALL DCOPY( N, X, LDX+1, DWORK, 1 ) CALL DPOTRF( UPLO, N, X, LDX, IFAIL ) C IF ( IFAIL.EQ.0 ) THEN C C Use Cholesky factorization of X to compute chol(X)*B. C OUFACT(2) = 1 CALL DTRMM( 'Left', UPLO, TRL, 'Non unit', N, M, ONE, X, $ LDX, B, LDB ) ELSE C C Use spectral factorization of X, X = UVU'. C Workspace: need 4*N+1, C prefer N*(NB+2)+N+2. C JW = N + 3 OUFACT(2) = 2 CALL DCOPY( N, DWORK, 1, X, LDX+1 ) CALL DSYEV( 'Vectors', NUPLO, N, X, LDX, DWORK(3), $ DWORK(JW), LDWORK-JW+1, IFAIL ) IF ( IFAIL.GT.0 ) THEN INFO = M + 2 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 ) TEMP = ABS( DWORK(N+2) )*EPS*DBLE( N ) C C Check out the positive (semi-)definiteness of X. C First, count the negligible eigenvalues. C 80 CONTINUE IF ( ABS( DWORK(JZ+3) ).LE.TEMP ) THEN JZ = JZ + 1 IF ( JZ.LT.N ) $ GO TO 80 END IF C IF ( LFACTD .AND. N-JZ+P.LT.M ) THEN C C The coefficient matrix is (numerically) singular. C OUFACT(1) = 1 DWORK(2) = ZERO INFO = M + 1 RETURN END IF C IF ( DWORK(JZ+3).LT.ZERO ) THEN C C X is not positive (semi-)definite. Updating fails. C INFO = M + 3 RETURN ELSE C C Compute sqrt(V)U'B. C Workspace: need 2*N+2; C prefer N*M+N+2. C WRKOPT = MAX( WRKOPT, NM + JW - 1 ) MS = MAX( INT( ( LDWORK - JW + 1 )/N ), 1 ) C DO 90 I = 1, M, MS NR = MIN( MS, M-I+1 ) CALL DLACPY( 'All', N, NR, B(1,I), LDB, DWORK(JW), $ N ) CALL DGEMM( TR, NT, N-JZ, NR, N, ONE, X(1,JZ+1), $ LDX, DWORK(JW), N, ZERO, B(JZ+1,I), $ LDB ) 90 CONTINUE C DO 100 I = JZ + 1, N CALL DSCAL( M, SQRT( DWORK(I+2) ), B(I,1), LDB ) 100 CONTINUE C END IF C END IF C C Update the triangular factorization. C IF ( .NOT.LUPLOU ) C C Transpose the lower triangle for using MB04KD. C $ CALL MA02ED( UPLO, M, R, LDR ) C C Workspace: need 2*M. C CALL MB04KD( 'Full', M, 0, N-JZ, R, LDR, B(JZ+1,1), LDB, $ DUMMY, N, DUMMY, M, DWORK, DWORK(M+1) ) C C Make positive the diagonal elements of the triangular C factor. C DO 110 I = 1, M IF ( R(I,I).LT.ZERO ) $ CALL DSCAL( M-I+1, -ONE, R(I,I), LDR ) 110 CONTINUE C IF ( .NOT.LUPLOU ) C C Construct the lower triangle. C $ CALL MA02ED( NUPLO, M, R, LDR ) C END IF C C Compute the condition number of the coefficient matrix. C IF ( .NOT.LFACTU ) THEN C C Workspace: need 3*M. C CALL DTRCON( '1-norm', UPLO, 'Non unit', M, R, LDR, RCOND, $ DWORK, IWORK, IFAIL ) OUFACT(1) = 1 ELSE C C Workspace: need 2*M. C CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, $ IWORK, IFAIL ) OUFACT(1) = 2 END IF C ELSE C C Case 2: Matrix R is given in an unfactored form. C C Save the given triangle of R or R + B'XB in the other C strict triangle and the diagonal in the workspace, and try C Cholesky factorization. C Workspace: need M. C CALL DCOPY( M, R, LDR+1, DWORK, 1 ) CALL MA02ED( UPLO, M, R, LDR ) CALL DPOTRF( UPLO, M, R, LDR, IFAIL ) IF( IFAIL.EQ.0 ) THEN OUFACT(1) = 1 C C Compute the reciprocal of the condition number of R C or R + B'XB. C Workspace: need 3*M. C CALL DPOCON( UPLO, M, R, LDR, RNORMP, RCOND, DWORK, IWORK, $ IFAIL ) ELSE OUFACT(1) = 2 C C Use UdU' or LdL' factorization, first restoring the saved C triangle. C CALL DCOPY( M, DWORK, 1, R, LDR+1 ) CALL MA02ED( NUPLO, M, R, LDR ) C C Workspace: need 1, C prefer M*NB. C CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) IF( INFO.GT.0 ) $ RETURN WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Compute the reciprocal of the condition number of R. C Workspace: need 2*M. C CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORMP, RCOND, DWORK, $ IWORK, IFAIL ) END IF END IF C C Return if the matrix is singular to working precision. C DWORK(2) = RCOND IF( RCOND.LT.EPS ) THEN INFO = M + 1 RETURN END IF C IF ( OUFACT(1).EQ.1 ) THEN C C Solve the positive definite linear system. C IF ( WITHF ) THEN CALL DTRSM( 'Right', UPLO, TRL, 'Non-unit', N, M, ONE, R, $ LDR, H, LDH ) ELSE IF ( WITHD ) THEN CALL DTRMM( 'Right', UPLO, TRL, 'Non-unit', N, M, ONE, R, $ LDR, H, LDH ) CALL DTRSM( 'Left', UPLO, TRL, 'Non-unit', M, N, ONE, R, $ LDR, K, LDK ) ELSE IF ( .NOT.WITHC ) THEN CALL DPOTRS( UPLO, M, N, R, LDR, K, LDK, IFAIL ) END IF ELSE C C Solve the indefinite linear system. C CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, K, LDK, IFAIL ) END IF C C Set the optimal workspace. C DWORK(1) = WRKOPT C RETURN C *** Last line of SG02ND *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09JX.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09JX.f0000644000175000017500000001673015012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE AB09JX( DICO, STDOM, EVTYPE, N, ALPHA, ER, EI, ED, $ TOLINF, INFO ) C C PURPOSE C C To check stability/antistability of finite eigenvalues with C respect to a given stability domain. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of the stability domain as follows: C = 'C': for a continuous-time system; C = 'D': for a discrete-time system. 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 EVTYPE CHARACTER*1 C Specifies whether the eigenvalues arise from a standard C or a generalized eigenvalue problem as follows: C = 'S': standard eigenvalue problem; C = 'G': generalized eigenvalue problem; C = 'R': reciprocal generalized eigenvalue problem. C C Input/Output Parameters C C N (input) INTEGER C The dimension of vectors ER, EI and ED. N >= 0. C C ALPHA (input) DOUBLE PRECISION C Specifies the boundary of the domain of interest for the C eigenvalues. For a continuous-time system C (DICO = 'C'), ALPHA is the boundary value for the real C parts of eigenvalues, while for a discrete-time system C (DICO = 'D'), ALPHA >= 0 represents the boundary value for C the moduli of eigenvalues. C C ER, EI, (input) DOUBLE PRECISION arrays, dimension (N) C ED If EVTYPE = 'S', ER(j) + EI(j)*i, j = 1,...,N, are C the eigenvalues of a real matrix. C ED is not referenced and is implicitly considered as C a vector having all elements equal to one. C If EVTYPE = 'G' or EVTYPE = 'R', (ER(j) + EI(j)*i)/ED(j), C j = 1,...,N, are the generalized eigenvalues of a pair of C real matrices. If ED(j) is zero, then the j-th generalized C eigenvalue is infinite. C Complex conjugate pairs of eigenvalues must appear C consecutively. C C Tolerances C C TOLINF DOUBLE PRECISION C If EVTYPE = 'G' or 'R', TOLINF contains the tolerance for C detecting infinite generalized eigenvalues. C 0 <= TOLINF < 1. C C Error Indicator C C INFO INTEGER C = 0: successful exit, i.e., all eigenvalues lie within C the domain of interest defined by DICO, STDOM C and ALPHA; C < 0: if INFO = -i, the i-th argument had an illegal C value; C = 1: some eigenvalues lie outside the domain of interest C defined by DICO, STDOM and ALPHA. C METHOD C C The domain of interest for an eigenvalue lambda is defined by the C parameters ALPHA, DICO and STDOM as follows: C - for a continuous-time system (DICO = 'C'): C Real(lambda) < ALPHA if STDOM = 'S'; C Real(lambda) > ALPHA if STDOM = 'U'; C - for a discrete-time system (DICO = 'D'): C Abs(lambda) < ALPHA if STDOM = 'S'; C Abs(lambda) > ALPHA if STDOM = 'U'. C If EVTYPE = 'R', the same conditions apply for 1/lambda. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, June 2001, C July 2020. C C KEYWORDS C C Stability. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EVTYPE, STDOM INTEGER INFO, N DOUBLE PRECISION ALPHA, TOLINF C .. Array Arguments .. DOUBLE PRECISION ED(*), EI(*), ER(*) C .. Local Scalars LOGICAL DISCR, RECEVP, STAB, STDEVP DOUBLE PRECISION ABSEV, RPEV, SCALE INTEGER I C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAPY2 EXTERNAL DLAPY2, LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC ABS C .. Executable Statements .. C INFO = 0 DISCR = LSAME( DICO, 'D' ) STAB = LSAME( STDOM, 'S' ) STDEVP = LSAME( EVTYPE, 'S' ) RECEVP = LSAME( EVTYPE, 'R' ) C C Check the scalar input arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( STAB .OR. LSAME( STDOM, 'U' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( STDEVP .OR. LSAME( EVTYPE, 'G' ) .OR. $ RECEVP ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN INFO = -5 ELSE IF( TOLINF.LT.ZERO .OR. TOLINF.GE.ONE ) THEN INFO = -9 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09JX', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C SCALE = ONE C IF( STAB ) THEN C C Check the stability of finite eigenvalues. C IF( DISCR ) THEN DO 10 I = 1, N ABSEV = DLAPY2( ER(I), EI(I) ) IF( RECEVP ) THEN SCALE = ABSEV ABSEV = ABS( ED(I) ) ELSE IF( .NOT.STDEVP ) THEN SCALE = ED(I) END IF IF( ABS( SCALE ).GT.TOLINF .AND. $ ABSEV.GE.ALPHA*SCALE ) THEN INFO = 1 RETURN END IF 10 CONTINUE ELSE DO 20 I = 1, N RPEV = ER(I) IF( RECEVP ) THEN SCALE = RPEV RPEV = ED(I) ELSE IF( .NOT.STDEVP ) THEN SCALE = ED(I) END IF IF( ABS( SCALE ).GT.TOLINF .AND. $ RPEV.GE.ALPHA*SCALE ) THEN INFO = 1 RETURN END IF 20 CONTINUE END IF ELSE C C Check the anti-stability of finite eigenvalues. C IF( DISCR ) THEN DO 30 I = 1, N ABSEV = DLAPY2( ER(I), EI(I) ) IF( RECEVP ) THEN SCALE = ABSEV ABSEV = ABS( ED(I) ) ELSE IF( .NOT.STDEVP ) THEN SCALE = ED(I) END IF IF( ABS( SCALE ).GT.TOLINF .AND. $ ABSEV.LE.ALPHA*SCALE ) THEN INFO = 1 RETURN END IF 30 CONTINUE ELSE DO 40 I = 1, N RPEV = ER(I) IF( RECEVP ) THEN SCALE = RPEV RPEV = ED(I) ELSE IF( .NOT.STDEVP ) THEN SCALE = ED(I) END IF IF( ABS( SCALE ).GT.TOLINF .AND. $ RPEV.LE.ALPHA*SCALE ) THEN INFO = 1 RETURN END IF 40 CONTINUE END IF END IF C RETURN C *** Last line of AB09JX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03WA.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03WA.f0000644000175000017500000004572315012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE MB03WA( WANTQ, WANTZ, N1, N2, A, LDA, B, LDB, Q, LDQ, $ Z, LDZ, INFO ) C C PURPOSE C C To swap adjacent diagonal blocks A11*B11 and A22*B22 of size C 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix product C A*B by an orthogonal equivalence transformation. C C (A, B) must be in periodic real Schur canonical form (as returned C by SLICOT Library routine MB03XP), i.e., A is block upper C triangular with 1-by-1 and 2-by-2 diagonal blocks, and B is upper C triangular. C C Optionally, the matrices Q and Z of generalized Schur vectors are C updated. C C Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)', C Z(in) * B(in) * Q(in)' = Z(out) * B(out) * Q(out)'. C C This routine is largely based on the LAPACK routine DTGEX2 C developed by Bo Kagstrom and Peter Poromaa. C C ARGUMENTS C C Mode Parameters C C WANTQ LOGICAL C Indicates whether or not the user wishes to accumulate C the matrix Q as follows: C = .TRUE. : The matrix Q is updated; C = .FALSE.: the matrix Q is not required. C C WANTZ LOGICAL C Indicates whether or not the user wishes to accumulate C the matrix Z as follows: C = .TRUE. : The matrix Z is updated; C = .FALSE.: the matrix Z is not required. C C Input/Output Parameters C C N1 (input) INTEGER C The order of the first block A11*B11. N1 = 0, 1 or 2. C C N2 (input) INTEGER C The order of the second block A22*B22. N2 = 0, 1 or 2. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA,N1+N2) C On entry, the leading (N1+N2)-by-(N1+N2) part of this C array must contain the matrix A. C On exit, the leading (N1+N2)-by-(N1+N2) part of this array C contains the matrix A of the reordered pair. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N1+N2). C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,N1+N2) C On entry, the leading (N1+N2)-by-(N1+N2) part of this C array must contain the matrix B. C On exit, the leading (N1+N2)-by-(N1+N2) part of this array C contains the matrix B of the reordered pair. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,N1+N2). C C Q (input/output) DOUBLE PRECISION array, dimension C (LDQ,N1+N2) C On entry, if WANTQ = .TRUE., the leading C (N1+N2)-by-(N1+N2) part of this array must contain the C orthogonal matrix Q. C On exit, the leading (N1+N2)-by-(N1+N2) part of this array C contains the updated matrix Q. Q will be a rotation C matrix for N1=N2=1. C This array is not referenced if WANTQ = .FALSE.. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= 1. C If WANTQ = .TRUE., LDQ >= N1+N2. C C Z (input/output) DOUBLE PRECISION array, dimension C (LDZ,N1+N2) C On entry, if WANTZ = .TRUE., the leading C (N1+N2)-by-(N1+N2) part of this array must contain the C orthogonal matrix Z. C On exit, the leading (N1+N2)-by-(N1+N2) part of this array C contains the updated matrix Z. Z will be a rotation C matrix for N1=N2=1. C This array is not referenced if WANTZ = .FALSE.. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= 1. C If WANTZ = .TRUE., LDZ >= N1+N2. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: the transformed matrix (A, B) would be C too far from periodic Schur form; the blocks are C not swapped and (A,B) and (Q,Z) are unchanged. C C METHOD C C In the current code both weak and strong stability tests are C performed. The user can omit the strong stability test by changing C the internal logical parameter WANDS to .FALSE.. See ref. [2] for C details. C C REFERENCES C C [1] Kagstrom, B. C A direct method for reordering eigenvalues in the generalized C real Schur form of a regular matrix pair (A,B), in M.S. Moonen C et al (eds.), Linear Algebra for Large Scale and Real-Time C Applications, Kluwer Academic Publ., 1993, pp. 195-218. C C [2] Kagstrom, B., and Poromaa, P. C Computing eigenspaces with specified eigenvalues of a regular C matrix pair (A, B) and condition estimation: Theory, C algorithms and software, Numer. Algorithms, 1996, vol. 12, C pp. 369-407. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, May 2008 (SLICOT version of the HAPACK routine DTGPX2). C C KEYWORDS C C Eigenvalue, periodic Schur form, reordering C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION TEN PARAMETER ( TEN = 1.0D+01 ) INTEGER LDST PARAMETER ( LDST = 4 ) LOGICAL WANDS PARAMETER ( WANDS = .TRUE. ) C .. Scalar Arguments .. LOGICAL WANTQ, WANTZ INTEGER INFO, LDA, LDB, LDQ, LDZ, N1, N2 C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. LOGICAL DTRONG, WEAK INTEGER I, LINFO, M DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS, $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS C .. Local Arrays .. INTEGER IWORK( LDST ) DOUBLE PRECISION AI(2), AR(2), BE(2), DWORK(32), IR(LDST,LDST), $ IRCOP(LDST,LDST), LI(LDST,LDST), $ LICOP(LDST,LDST), S(LDST,LDST), $ SCPY(LDST,LDST), T(LDST,LDST), TAUL(LDST), $ TAUR(LDST), TCPY(LDST,LDST) C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. External Subroutines .. EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLARTG, DLASET, $ DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2, DROT, $ DSCAL, MB03YT, SB04OW C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C C .. Executable Statements .. C INFO = 0 C C Quick return if possible. C For efficiency, the arguments are not checked. C IF ( N1.LE.0 .OR. N2.LE.0 ) $ RETURN M = N1 + N2 C WEAK = .FALSE. DTRONG = .FALSE. C C Make a local copy of selected block. C CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, LI, LDST ) CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, IR, LDST ) CALL DLACPY( 'Full', M, M, A, LDA, S, LDST ) CALL DLACPY( 'Full', M, M, B, LDB, T, LDST ) C C Compute threshold for testing acceptance of swapping. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS DSCALE = ZERO DSUM = ONE CALL DLACPY( 'Full', M, M, S, LDST, DWORK, M ) CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM ) CALL DLACPY( 'Full', M, M, T, LDST, DWORK, M ) CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM ) DNORM = DSCALE*SQRT( DSUM ) THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) C IF ( M.EQ.2 ) THEN C C CASE 1: Swap 1-by-1 and 1-by-1 blocks. C C Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks C using Givens rotations and perform the swap tentatively. C F = S(2,2)*T(2,2) - T(1,1)*S(1,1) G = -S(2,2)*T(1,2) - T(1,1)*S(1,2) SB = ABS( T(1,1) ) SA = ABS( S(2,2) ) CALL DLARTG( F, G, IR(1,2), IR(1,1), DDUM ) IR(2,1) = -IR(1,2) IR(2,2) = IR(1,1) CALL DROT( 2, S(1,1), 1, S(1,2), 1, IR(1,1), IR(2,1) ) CALL DROT( 2, T(1,1), LDST, T(2,1), LDST, IR(1,1), IR(2,1) ) IF( SA.GE.SB ) THEN CALL DLARTG( S(1,1), S(2,1), LI(1,1), LI(2,1), DDUM ) ELSE CALL DLARTG( T(2,2), T(2,1), LI(1,1), LI(2,1), DDUM ) LI(2,1) = -LI(2,1) END IF CALL DROT( 2, S(1,1), LDST, S(2,1), LDST, LI(1,1), LI(2,1) ) CALL DROT( 2, T(1,1), 1, T(1,2), 1, LI(1,1), LI(2,1) ) LI(2,2) = LI(1,1) LI(1,2) = -LI(2,1) C C Weak stability test: C |S21| + |T21| <= O(EPS * F-norm((S, T))). C WS = ABS( S(2,1) ) + ABS( T(2,1) ) WEAK = WS.LE.THRESH IF ( .NOT.WEAK ) $ GO TO 50 C IF ( WANDS ) THEN C C Strong stability test: C F-norm((A-QL'*S*QR, B-QR'*T*QL)) <= O(EPS*F-norm((A,B))). C CALL DLACPY( 'Full', M, M, A, LDA, DWORK(M*M+1), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ LI, LDST, S, LDST, ZERO, DWORK, M ) CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, $ DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M ) DSCALE = ZERO DSUM = ONE CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) C CALL DLACPY( 'Full', M, M, B, LDB, DWORK(M*M+1), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ IR, LDST, T, LDST, ZERO, DWORK, M ) CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, $ DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M ) CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) SS = DSCALE*SQRT( DSUM ) DTRONG = SS.LE.THRESH IF( .NOT.DTRONG ) $ GO TO 50 END IF C C Update A and B. C CALL DLACPY( 'All', M, M, S, LDST, A, LDA ) CALL DLACPY( 'All', M, M, T, LDST, B, LDB ) C C Set N1-by-N2 (2,1) - blocks to ZERO. C A(2,1) = ZERO B(2,1) = ZERO C C Accumulate transformations into Q and Z if requested. C IF ( WANTQ ) $ CALL DROT( 2, Q(1,1), 1, Q(1,2), 1, LI(1,1), LI(2,1) ) IF ( WANTZ ) $ CALL DROT( 2, Z(1,1), 1, Z(1,2), 1, IR(1,1), IR(2,1) ) C C Exit with INFO = 0 if swap was successfully performed. C RETURN C ELSE C C CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 C and 2-by-2 blocks. C C Solve the periodic Sylvester equation C S11 * R - L * S22 = SCALE * S12 C T11 * L - R * T22 = SCALE * T12 C for R and L. Solutions in IR and LI. C CALL DLACPY( 'Full', N1, N2, T(1,N1+1), LDST, LI, LDST ) CALL DLACPY( 'Full', N1, N2, S(1,N1+1), LDST, IR(N2+1,N1+1), $ LDST ) CALL SB04OW( N1, N2, S, LDST, S(N1+1,N1+1), LDST, $ IR(N2+1,N1+1), LDST, T, LDST, T(N1+1,N1+1), LDST, $ LI, LDST, SCALE, IWORK, LINFO ) IF ( LINFO.NE.0 ) $ GO TO 50 C C Compute orthogonal matrix QL: C C QL' * LI = [ TL ] C [ 0 ] C where C LI = [ -L ]. C [ SCALE * identity(N2) ] C DO 10 I = 1, N2 CALL DSCAL( N1, -ONE, LI(1,I), 1 ) LI(N1+I,I) = SCALE 10 CONTINUE CALL DGEQR2( M, N2, LI, LDST, TAUL, DWORK, LINFO ) CALL DORG2R( M, M, N2, LI, LDST, TAUL, DWORK, LINFO ) C C Compute orthogonal matrix RQ: C C IR * RQ' = [ 0 TR], C C where IR = [ SCALE * identity(N1), R ]. C DO 20 I = 1, N1 IR(N2+I,I) = SCALE 20 CONTINUE CALL DGERQ2( N1, M, IR(N2+1,1), LDST, TAUR, DWORK, LINFO ) CALL DORGR2( M, M, N1, IR, LDST, TAUR, DWORK, LINFO ) C C Perform the swapping tentatively: C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, LI, $ LDST, S, LDST, ZERO, DWORK, M ) CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, DWORK, $ M, IR, LDST, ZERO, S, LDST ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, IR, $ LDST, T, LDST, ZERO, DWORK, M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK, M, LI, LDST, ZERO, T, LDST ) CALL DLACPY( 'All', M, M, S, LDST, SCPY, LDST ) CALL DLACPY( 'All', M, M, T, LDST, TCPY, LDST ) CALL DLACPY( 'All', M, M, IR, LDST, IRCOP, LDST ) CALL DLACPY( 'All', M, M, LI, LDST, LICOP, LDST ) C C Triangularize the B-part by a QR factorization. C Apply transformation (from left) to A-part, giving S. C CALL DGEQR2( M, M, T, LDST, TAUR, DWORK, LINFO ) CALL DORM2R( 'Right', 'No Transpose', M, M, M, T, LDST, TAUR, $ S, LDST, DWORK, LINFO ) CALL DORM2R( 'Left', 'Transpose', M, M, M, T, LDST, TAUR, $ IR, LDST, DWORK, LINFO ) C C Compute F-norm(S21) in BRQA21. (T21 is 0.) C DSCALE = ZERO DSUM = ONE DO 30 I = 1, N2 CALL DLASSQ( N1, S(N2+1,I), 1, DSCALE, DSUM ) 30 CONTINUE BRQA21 = DSCALE*SQRT( DSUM ) C C Triangularize the B-part by an RQ factorization. C Apply transformation (from right) to A-part, giving S. C CALL DGERQ2( M, M, TCPY, LDST, TAUL, DWORK, LINFO ) CALL DORMR2( 'Left', 'No Transpose', M, M, M, TCPY, LDST, $ TAUL, SCPY, LDST, DWORK, LINFO ) CALL DORMR2( 'Right', 'Transpose', M, M, M, TCPY, LDST, $ TAUL, LICOP, LDST, DWORK, LINFO ) C C Compute F-norm(S21) in BQRA21. (T21 is 0.) C DSCALE = ZERO DSUM = ONE DO 40 I = 1, N2 CALL DLASSQ( N1, SCPY(N2+1,I), 1, DSCALE, DSUM ) 40 CONTINUE BQRA21 = DSCALE*SQRT( DSUM ) C C Decide which method to use. C Weak stability test: C F-norm(S21) <= O(EPS * F-norm((S, T))) C IF ( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN CALL DLACPY( 'All', M, M, SCPY, LDST, S, LDST ) CALL DLACPY( 'All', M, M, TCPY, LDST, T, LDST ) CALL DLACPY( 'All', M, M, IRCOP, LDST, IR, LDST ) CALL DLACPY( 'All', M, M, LICOP, LDST, LI, LDST ) ELSE IF ( BRQA21.GE.THRESH ) THEN GO TO 50 END IF C C Set lower triangle of B-part to zero C CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST ) C IF ( WANDS ) THEN C C Strong stability test: C F-norm((A-QL*S*QR', B-QR*T*QL')) <= O(EPS*F-norm((A,B))) C CALL DLACPY( 'All', M, M, A, LDA, DWORK(M*M+1), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ LI, LDST, S, LDST, ZERO, DWORK, M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, -ONE, $ DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M ) DSCALE = ZERO DSUM = ONE CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) C CALL DLACPY( 'All', M, M, B, LDB, DWORK(M*M+1), M ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ IR, LDST, T, LDST, ZERO, DWORK, M ) CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, $ DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M ) CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) SS = DSCALE*SQRT( DSUM ) DTRONG = ( SS.LE.THRESH ) IF( .NOT.DTRONG ) $ GO TO 50 C END IF C C If the swap is accepted ("weakly" and "strongly"), apply the C transformations and set N1-by-N2 (2,1)-block to zero. C CALL DLASET( 'All', N1, N2, ZERO, ZERO, S(N2+1,1), LDST ) C C Copy (S,T) to (A,B). C CALL DLACPY( 'All', M, M, S, LDST, A, LDA ) CALL DLACPY( 'All', M, M, T, LDST, B, LDB ) CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, T, LDST ) C C Standardize existing 2-by-2 blocks. C CALL DLASET( 'All', M, M, ZERO, ZERO, DWORK, M ) DWORK(1) = ONE T(1,1) = ONE IF ( N2.GT.1 ) THEN CALL MB03YT( A, LDA, B, LDB, AR, AI, BE, DWORK(1), DWORK(2), $ T(1,1), T(2,1) ) DWORK(M+1) = -DWORK(2) DWORK(M+2) = DWORK(1) T(N2,N2) = T(1,1) T(1,2) = -T(2,1) END IF DWORK(M*M) = ONE T(M,M) = ONE C IF ( N1.GT.1 ) THEN CALL MB03YT( A(N2+1,N2+1), LDA, B(N2+1,N2+1), LDB, TAUR, $ TAUL, DWORK(M*M+1), DWORK(N2*M+N2+1), $ DWORK(N2*M+N2+2), T(N2+1,N2+1), T(M,M-1) ) DWORK(M*M) = DWORK(N2*M+N2+1) DWORK(M*M-1 ) = -DWORK(N2*M+N2+2) T(M,M) = T(N2+1,N2+1) T(M-1,M) = -T(M,M-1) END IF C CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE, $ DWORK, M, A(1,N2+1), LDA, ZERO, DWORK(M*M+1), N2 ) CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, A(1,N2+1), LDA ) CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE, $ T(1,1), LDST, B(1,N2+1), LDB, ZERO, $ DWORK(M*M+1), N2 ) CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, B(1,N2+1), LDB ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, LI, $ LDST, DWORK, M, ZERO, DWORK(M*M+1), M ) CALL DLACPY( 'All', M, M, DWORK(M*M+1), M, LI, LDST ) CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE, $ A(1,N2+1), LDA, T(N2+1,N2+1), LDST, ZERO, $ DWORK(M*M+1), M ) CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, A(1,N2+1), LDA ) CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE, $ B(1,N2+1), LDB, DWORK(N2*M+N2+1), M, ZERO, $ DWORK(M*M+1), M ) CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, B(1,N2+1), LDB ) CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, T, $ LDST, IR, LDST, ZERO, DWORK, M ) CALL DLACPY( 'All', M, M, DWORK, M, IR, LDST ) C C Accumulate transformations into Q and Z if requested. C IF( WANTQ ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, Q, $ LDQ, LI, LDST, ZERO, DWORK, M ) CALL DLACPY( 'All', M, M, DWORK, M, Q, LDQ ) END IF C IF( WANTZ ) THEN CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, Z, $ LDZ, IR, LDST, ZERO, DWORK, M ) CALL DLACPY( 'Full', M, M, DWORK, M, Z, LDZ ) C END IF C C Exit with INFO = 0 if swap was successfully performed. C RETURN C END IF C C Exit with INFO = 1 if swap was rejected. C 50 CONTINUE C INFO = 1 RETURN C *** Last line of MB03WA *** END control-4.1.2/src/slicot/src/PaxHeaders/MA01BD.f0000644000000000000000000000013215012430707016141 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA01BD.f0000644000175000017500000000660315012430707017342 0ustar00lilgelilge00000000000000 SUBROUTINE MA01BD( BASE, LGBAS, K, S, A, INCA, ALPHA, BETA, SCAL ) C C PURPOSE C C To compute the general product of K real scalars without over- C or underflow. C C ARGUMENTS C C Input/Output Parameters C C BASE (input) DOUBLE PRECISION C Machine base. C C LGBAS (input) DOUBLE PRECISION C Logarithm of BASE. C C K (input) INTEGER C The number of scalars. K >= 1. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C A (input) DOUBLE PRECISION array, dimension (K) C Vector of real scalars. C C INCA (input) INTEGER C Increment for the array A. INCA <> 0. C C ALPHA (output) DOUBLE PRECISION C ALPHA is a real scalar such that C C ALPHA / BETA * BASE**(SCAL) C C is the general product of the scalars in the array A. C C BETA (output) DOUBLE PRECISION C BETA is either 0.0 or 1.0. C See also the description of ALPHA. C C SCAL (output) INTEGER C Scaling factor exponent, see ALPHA. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, June 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C July 2009, SLICOT Library version of the routine PLAPR1. C V. Sima, Aug. 2011, Apr. 2020. C C KEYWORDS C C Computer arithmetic, overflow, underflow. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INCA, K, SCAL DOUBLE PRECISION ALPHA, BASE, BETA, LGBAS C .. Array Arguments .. INTEGER S(*) DOUBLE PRECISION A(*) C .. Local Scalars .. INTEGER I, SL DOUBLE PRECISION TEMP C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG, MOD C C .. Executable Statements .. C ALPHA = ONE BETA = ONE SCAL = 0 C DO 10 I = 1, K TEMP = A( 1 + ( I - 1 )*INCA ) IF ( TEMP.NE.ZERO ) THEN SL = INT( LOG( ABS( TEMP ) ) / LGBAS ) TEMP = TEMP / BASE / ( BASE**DBLE( SL-1 ) ) ELSE SL = 0 END IF IF ( S(I).EQ.1 ) THEN ALPHA = ALPHA * TEMP SCAL = SCAL + SL ELSE BETA = BETA * TEMP SCAL = SCAL - SL END IF IF ( MOD( I, 10 ).EQ.0 ) THEN IF ( ALPHA.NE.ZERO ) THEN SL = INT( LOG( ABS( ALPHA ) ) / LGBAS ) SCAL = SCAL + SL ALPHA = ALPHA / BASE / ( BASE**DBLE( SL-1 ) ) END IF IF ( BETA.NE.ZERO ) THEN SL = INT( LOG( ABS( BETA ) ) / LGBAS ) SCAL = SCAL - SL BETA = BETA / BASE / ( BASE**DBLE( SL-1 ) ) END IF END IF 10 CONTINUE C IF ( BETA.NE.ZERO ) THEN ALPHA = ALPHA / BETA BETA = ONE END IF IF ( ALPHA.EQ.ZERO ) THEN SCAL = 0 ELSE SL = INT( LOG( ABS( ALPHA ) ) / LGBAS ) ALPHA = ALPHA / BASE / ( BASE**DBLE( SL-1 ) ) SCAL = SCAL + SL END IF C RETURN C *** Last line of MA01BD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01OB.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01OB.f0000644000175000017500000001271615012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE TG01OB( JOBE, N, DCBA, LDDCBA, E, LDE, INFO ) C C PURPOSE C C To compute for a single-input single-output descriptor system, C given by the system matrix C C [ D C ] C [ B A - s*E ], C C with E upper triangular, a transformed system, (Q'*A*Z, Q'*E*Z, C Q'*B, C*Z), via an orthogonal equivalence transformation, so that C Q'*B has only the first element nonzero and Q'*E*Z remains upper C triangular. The matrices have complex elements. C C ARGUMENTS C C Mode Parameters C C JOBE CHARACTER*1 C Specifies whether E is an upper triangular or an identity C matrix, as follows: C = 'U': The matrix E is an upper triangular matrix; C = 'I': The matrix E is assumed identity and is not given. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the descriptor state vector; also the C order of square matrices A and E, the number of rows of C matrix B, and the number of columns of matrix C. N >= 0. C C DCBA (input/output) COMPLEX*16 array, dimension (LDDCBA,N+1) C On entry, the leading (N+1)-by-(N+1) part of this array C must contain the original system matrices A, B, C, and D, C stored as follows C C [ D C ] C [ B A ]. C C On exit, the leading (N+1)-by-(N+1) part of this array C contains the transformed matrices C*Z, Q'*B, and Q'*A*Z, C replacing C, B, and A. The scalar D is unchanged. C C LDDCBA INTEGER C The leading dimension of the array DCBA. C LDDCBA >= N+1. C C E (input/output) COMPLEX*16 array, dimension (LDE,*) C On entry, if JOBE = 'U', the leading N-by-N upper C triangular part of this array must contain the upper C triangular part of the descriptor matrix E. The lower C triangular part under the first subdiagonal is not C referenced. C On exit, if JOBE = 'U', the leading N-by-N upper C triangular part of this array contains the upper C triangular part of the transformed descriptor matrix, C Q'*E*Z. C If JOBE = 'I', this array is not referenced. C C LDE INTEGER C The leading dimension of the array E. C LDE >= MAX(1,N), if JOBE = 'U'; C LDE >= 1, if JOBE = '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 METHOD C C Givens rotations are used to annihilate the last N-1 elements of B C in reverse order, but preserve the form of E. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C V. Sima, May 2021. C C REVISIONS C C - C C KEYWORDS C C Controllability, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. CHARACTER JOBE INTEGER INFO, LDDCBA, LDE, N C .. Array Arguments .. COMPLEX*16 DCBA(LDDCBA,*), E(LDE,*) C .. Local Scalars .. LOGICAL UNITE INTEGER K, N1 DOUBLE PRECISION CS COMPLEX*16 SN, TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA, ZLARTG, ZROT C .. Intrinsic Functions .. INTRINSIC DCONJG, MAX C .. Executable Statements .. C UNITE = LSAME( JOBE, 'I' ) INFO = 0 N1 = N + 1 C C Test the input scalar arguments. C IF ( .NOT.UNITE .AND. .NOT.LSAME( JOBE, 'U' ) ) THEN INFO = -1 ELSE IF ( N.LT.0 ) THEN INFO = -2 ELSE IF ( LDDCBA.LT.N1 ) THEN INFO = -4 ELSE IF ( LDE.LT.1 .OR. ( .NOT.UNITE .AND. LDE.LT.MAX( 1, N ) ) ) $ THEN INFO = -6 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01OB', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.LE.1 ) $ RETURN C DO 10 K = N, 2, -1 IF ( DCBA(K+1,1).NE.ZERO ) THEN CALL ZLARTG( DCBA(K,1), DCBA(K+1,1), CS, SN, TEMP ) DCBA(K,1) = TEMP DCBA(K+1,1) = ZERO CALL ZROT( N, DCBA(K,2), LDDCBA, DCBA(K+1,2), LDDCBA, CS, SN $ ) IF ( UNITE ) THEN CALL ZROT( N1, DCBA(1,K), 1, DCBA(1,K+1), 1, CS, $ DCONJG( SN ) ) ELSE E(K,K-1) = DCONJG( SN )*E(K-1,K-1) E(K-1,K-1) = CS*E(K-1,K-1) CALL ZROT( N-K+1, E(K-1,K), LDE, E(K,K), LDE, CS, SN ) IF ( E(K,K-1).NE.ZERO ) THEN CALL ZLARTG( E(K,K), E(K,K-1), CS, SN, TEMP ) E(K,K) = TEMP E(K,K-1) = ZERO CALL ZROT( K-1, E(1,K-1), 1, E(1,K), 1, CS, $ DCONJG( SN ) ) CALL ZROT( N1, DCBA(1,K), 1, DCBA(1,K+1), 1, CS, $ DCONJG( SN ) ) END IF END IF END IF 10 CONTINUE C RETURN C *** Last line of TG01OB *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03ED.f0000644000000000000000000000013215012430707016147 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03ED.f0000644000175000017500000003036315012430707017350 0ustar00lilgelilge00000000000000 SUBROUTINE MB03ED( N, PREC, A, LDA, B, LDB, D, LDD, Q1, LDQ1, Q2, $ LDQ2, Q3, LDQ3, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute orthogonal matrices Q1, Q2, Q3 for a real 2-by-2 or C 4-by-4 regular pencil C C ( A11 0 ) ( B11 0 ) ( 0 D12 ) C aAB - bD = a ( ) ( ) - b ( ), (1) C ( 0 A22 ) ( 0 B22 ) ( D21 0 ) C C such that Q3' A Q2 and Q2' B Q1 are upper triangular, Q3' D Q1 is C upper quasi-triangular, and the eigenvalues with negative real C parts (if there are any) are allocated on the top. The notation M' C denotes the transpose of the matrix M. The submatrices A11, A22, C B11, B22 and D12 are upper triangular. If D21 is 2-by-2, then all C other blocks are nonsingular and the product C -1 -1 -1 -1 C A22 D21 B11 A11 D12 B22 has a pair of complex conjugate C eigenvalues. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the input pencil, N = 2 or N = 4. C C PREC (input) DOUBLE PRECISION C The machine precision, (relative machine precision)*base. C See the LAPACK Library routine DLAMCH. C C A (input) DOUBLE PRECISION array, dimension (LDA, N) C The leading N-by-N upper triangular part of this array C must contain the upper triangular matrix A of the pencil C aAB - bD. The strictly lower triangular part and the C entries of the (1,2) block are not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= N. C C B (input) DOUBLE PRECISION array, dimension (LDB, N) C The leading N-by-N upper triangular part of this array C must contain the upper triangular matrix B of the pencil C aAB - bD. The strictly lower triangular part and the C entries of the (1,2) block are not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= N. C C D (input/output) DOUBLE PRECISION array, dimension (LDD, N) C On entry, the leading N-by-N part of this array must C contain the matrix D of the pencil aAB - bD. C On exit, if N = 4, the leading N-by-N part of this array C contains the transformed matrix D in real Schur form. C If N = 2, this array is unchanged on exit. C C LDD INTEGER C The leading dimension of the array D. LDD >= N. C C Q1 (output) DOUBLE PRECISION array, dimension (LDQ1, N) C The leading N-by-N part of this array contains the first C orthogonal transformation matrix. C C LDQ1 INTEGER C The leading dimension of the array Q1. LDQ1 >= N. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N) C The leading N-by-N part of this array contains the second C orthogonal transformation matrix. C C LDQ2 INTEGER C The leading dimension of the array Q2. LDQ2 >= N. C C Q3 (output) DOUBLE PRECISION array, dimension (LDQ3, N) C The leading N-by-N part of this array contains the third C orthogonal transformation matrix. C C LDQ3 INTEGER C The leading dimension of the array Q3. LDQ3 >= N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C If N = 2, then DWORK is not referenced. C C LDWORK INTEGER C The dimension of the array DWORK. C If N = 4, then LDWORK >= 79. For good performance LDWORK C should be generally larger. C If N = 2, then LDWORK >= 0. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 1: the QZ iteration failed in the LAPACK routine DGGES; C = 2: another error occured during execution of DGGES. C C METHOD C C The algorithm uses orthogonal transformations as described on page C 20 in [2]. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical computation of deflating subspaces of skew- C Hamiltonian/Hamiltonian pencils. C SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002. C C [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 22, 2008. C C REVISIONS C C V. Sima, Aug. 2009 (SLICOT version of the routine DBTFSX). C V. Sima, Oct. 2009, Nov. 2009, Oct. 2010, Nov. 2010. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue exchange, matrix pencil, upper (quasi-)triangular C matrix. 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, LDB, LDD, LDQ1, LDQ2, LDQ3, LDWORK, $ N DOUBLE PRECISION PREC C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( LDD, * ), $ DWORK( * ), Q1( LDQ1, * ), Q2( LDQ2, * ), $ Q3( LDQ3, * ) C C .. Local Scalars .. LOGICAL COMPG INTEGER IDUM, IEVS, IWRK DOUBLE PRECISION A11, A22, B11, B22, CO, D12, D21, SI, TMP C C .. Local Arrays .. LOGICAL BWORK( 4 ) DOUBLE PRECISION DUM( 1 ) C C .. External Functions .. LOGICAL SB02OW EXTERNAL SB02OW C C .. External Subroutines .. EXTERNAL DCOPY, DGEQR2, DGGES, DLACPY, DLARTG, DORG2R, $ DTRMM C C .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT C C .. Executable Statements .. C C For efficiency, the input arguments are not tested. C INFO = 0 C C Computations. C IF( N.EQ.4 ) THEN DUM( 1 ) = ZERO CALL DCOPY( 16, DUM, 0, DWORK, 1 ) DWORK( 1 ) = B( 1, 1 ) DWORK( 5 ) = B( 1, 2 ) DWORK( 6 ) = B( 2, 2 ) DWORK( 11 ) = B( 3, 3 ) DWORK( 15 ) = B( 3, 4 ) DWORK( 16 ) = B( 4, 4 ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 4, $ ONE, A, LDA, DWORK, N ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 2, $ ONE, A( 3, 3 ), LDA, DWORK( 11 ), N ) IEVS = N*N + 1 IWRK = IEVS + 3*N CALL DGGES( 'Vector Computation', 'Vector Computation', $ 'Sorted', SB02OW, N, D, LDD, DWORK, N, IDUM, $ DWORK( IEVS ), DWORK( IEVS+N ), DWORK( IEVS+2*N ), $ Q3, LDQ3, Q1, LDQ1, DWORK( IWRK ), LDWORK-IWRK+1, $ BWORK, INFO ) IF( INFO.NE.0 ) THEN IF( INFO.GE.1 .AND. INFO.LE.4 ) THEN INFO = 1 RETURN ELSE IF ( INFO.NE.6 ) THEN INFO = 2 RETURN ELSE INFO = 0 END IF END IF CALL DLACPY( 'Full', N, N, Q1, LDQ1, Q2, LDQ2 ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 4, $ ONE, B, LDB, Q2, LDQ2 ) CALL DTRMM( 'Left', 'Upper', 'No Transpose', 'NonUnit', 2, 4, $ ONE, B( 3, 3 ), LDB, Q2( 3, 1 ), LDQ2 ) CALL DGEQR2( N, N, Q2, LDQ2, DWORK, DWORK( N+1 ), INFO ) CALL DORG2R( N, N, N, Q2, LDQ2, DWORK, DWORK( N+1 ), INFO ) ELSE C C The pencil has infinite eigenvalues. The code decides this when C A or B is (numerically) singular. Although the numerical C singularity of A*B with respect to PREC is detected, the C eigenvalues will not be infinite, but large, when neither A C nor B is (numerically) singular. This allows a more accurate C computation of the transformed A and B (using Q1, Q2, and Q3), C as well as of the eigenvalues. C A11 = ABS( A( 1, 1 ) ) A22 = ABS( A( 2, 2 ) ) B11 = ABS( B( 1, 1 ) ) B22 = ABS( B( 2, 2 ) ) D21 = ABS( D( 2, 1 ) ) D12 = ABS( D( 1, 2 ) ) COMPG = .FALSE. IF( A11*B11.LE.PREC*A22*B22 ) THEN IF( A11.LE.PREC*A22 ) THEN Q1( 1, 1 ) = ONE Q1( 2, 1 ) = ZERO Q1( 1, 2 ) = ZERO Q1( 2, 2 ) = ONE Q2( 1, 1 ) = ONE Q2( 2, 1 ) = ZERO Q2( 1, 2 ) = ZERO Q2( 2, 2 ) = ONE Q3( 1, 1 ) = ZERO Q3( 2, 1 ) = -ONE Q3( 1, 2 ) = -ONE Q3( 2, 2 ) = ZERO ELSE IF( B11.LE.PREC*B22 ) THEN Q1( 1, 1 ) = -ONE Q1( 2, 1 ) = ZERO Q1( 1, 2 ) = ZERO Q1( 2, 2 ) = -ONE Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO Q3( 1, 1 ) = ZERO Q3( 2, 1 ) = ONE Q3( 1, 2 ) = ONE Q3( 2, 2 ) = ZERO ELSE COMPG = .TRUE. END IF ELSE IF( A22*B22.LE.PREC*A11*B11 ) THEN IF( A22.LE.PREC*A11 ) THEN Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO Q3( 1, 1 ) = -ONE Q3( 2, 1 ) = ZERO Q3( 1, 2 ) = ZERO Q3( 2, 2 ) = -ONE ELSE IF( B22.LE.PREC*B11 ) THEN Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = -ONE Q1( 1, 2 ) = -ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ONE Q2( 2, 1 ) = ZERO Q2( 1, 2 ) = ZERO Q2( 2, 2 ) = ONE Q3( 1, 1 ) = ONE Q3( 2, 1 ) = ZERO Q3( 1, 2 ) = ZERO Q3( 2, 2 ) = ONE ELSE COMPG = .TRUE. END IF C C The pencil has a double zero eigenvalue. C ELSE IF( D21.LE.PREC*D12 ) THEN Q1( 1, 1 ) = ONE Q1( 2, 1 ) = ZERO Q1( 1, 2 ) = ZERO Q1( 2, 2 ) = ONE Q2( 1, 1 ) = ONE Q2( 2, 1 ) = ZERO Q2( 1, 2 ) = ZERO Q2( 2, 2 ) = ONE Q3( 1, 1 ) = ONE Q3( 2, 1 ) = ZERO Q3( 1, 2 ) = ZERO Q3( 2, 2 ) = ONE ELSE IF( D12.LE.PREC*D21 ) THEN Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO Q3( 1, 1 ) = ZERO Q3( 2, 1 ) = ONE Q3( 1, 2 ) = ONE Q3( 2, 2 ) = ZERO ELSE COMPG = .TRUE. END IF C IF( COMPG ) THEN C C The pencil has real eigenvalues. C CALL DLARTG( SIGN( ONE, A( 1, 1 )*B( 1, 1 )*A( 2, 2 )* $ B( 2, 2 ) )*SQRT( A22*B22*D12 ), $ SQRT( A11*B11*D21 ), CO, SI, TMP ) Q1( 1, 1 ) = CO Q1( 2, 1 ) = -SI Q1( 1, 2 ) = SI Q1( 2, 2 ) = CO CALL DLARTG( SIGN( ONE, A( 1, 1 )*A( 2, 2 ) )* $ SQRT( A22*B11*D12 ), SQRT( A11*B22*D21 ), CO, $ SI, TMP ) Q2( 1, 1 ) = CO Q2( 2, 1 ) = -SI Q2( 1, 2 ) = SI Q2( 2, 2 ) = CO CALL DLARTG( SQRT( A11*B11*D12 ), SQRT( A22*B22*D21 ), CO, $ SI, TMP ) Q3( 1, 1 ) = CO Q3( 2, 1 ) = -SI Q3( 1, 2 ) = SI Q3( 2, 2 ) = CO END IF END IF C RETURN C *** Last line of MB03ED *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02CD.f0000644000000000000000000000013215012430707016143 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02CD.f0000644000175000017500000000540715012430707017345 0ustar00lilgelilge00000000000000 SUBROUTINE MA02CD( N, KL, KU, A, LDA ) C C PURPOSE C C To compute the pertranspose of a central band of a square matrix. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the square matrix A. N >= 0. C C KL (input) INTEGER C The number of subdiagonals of A to be pertransposed. C 0 <= KL <= N-1. C C KU (input) INTEGER C The number of superdiagonals of A to be pertransposed. C 0 <= KU <= N-1. 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 square matrix whose central band formed from C the KL subdiagonals, the main diagonal and the KU C superdiagonals will be pertransposed. C On exit, the leading N-by-N part of this array contains C the matrix A with its central band (the KL subdiagonals, C the main diagonal and the KU superdiagonals) pertransposed C (that is the elements of each antidiagonal appear in C reversed order). This is equivalent to forming P*B'*P, C where B is the matrix formed from the central band of A C and P is a permutation matrix with ones down the secondary C diagonal. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, March 1998. C Based on the RASP routine DMPTR. C C REVISIONS C C A. Varga, December 2001. C V. Sima, March 2004. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER KL, KU, LDA, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*) C .. Local Scalars .. INTEGER I, I1, LDA1 C .. External Subroutines .. EXTERNAL DSWAP C .. Intrinsic Functions .. INTRINSIC MIN C .. Executable Statements .. C C Quick return if possible. C IF( N.LE.1 ) $ RETURN C LDA1 = LDA + 1 C C Pertranspose the KL subdiagonals. C DO 10 I = 1, MIN( KL, N-2 ) I1 = (N-I) / 2 IF( I1.GT.0 ) $ CALL DSWAP( I1, A(I+1,1), LDA1, A(N-I1+1,N-I1+1-I), -LDA1 ) 10 CONTINUE C C Pertranspose the KU superdiagonals. C DO 20 I = 1, MIN( KU, N-2 ) I1 = (N-I) / 2 IF( I1.GT.0 ) $ CALL DSWAP( I1, A(1,I+1), LDA1, A(N-I1+1-I,N-I1+1), -LDA1 ) 20 CONTINUE C C Pertranspose the diagonal. C I1 = N / 2 IF( I1.GT.0 ) $ CALL DSWAP( I1, A(1,1), LDA1, A(N-I1+1,N-I1+1), -LDA1 ) C RETURN C *** Last line of MA02CD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04VD.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04VD.f0000644000175000017500000004600015012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE MB04VD( MODE, JOBQ, JOBZ, M, N, RANKE, A, LDA, E, LDE, $ Q, LDQ, Z, LDZ, ISTAIR, NBLCKS, NBLCKI, IMUK, $ INUK, IMUK0, MNEI, TOL, IWORK, INFO ) C C PURPOSE C C To compute orthogonal transformations Q and Z such that the C transformed pencil Q'(sE-A)Z is in upper block triangular form, C where E is an M-by-N matrix in column echelon form (see SLICOT C Library routine MB04UD) and A is an M-by-N matrix. C C If MODE = 'B', then the matrices A and E are transformed into the C following generalized Schur form by unitary transformations Q1 C and Z1 : C C | sE(eps,inf)-A(eps,inf) | X | C Q1'(sE-A)Z1 = |------------------------|------------|. (1) C | O | sE(r)-A(r) | C C The pencil sE(eps,inf)-A(eps,inf) is in staircase form, and it C contains all Kronecker column indices and infinite elementary C divisors of the pencil sE-A. The pencil sE(r)-A(r) contains all C Kronecker row indices and elementary divisors of sE-A. C Note: X is a pencil. C C If MODE = 'T', then the submatrices having full row and column C rank in the pencil sE(eps,inf)-A(eps,inf) in (1) are C triangularized by applying unitary transformations Q2 and Z2 to C Q1'*(sE-A)*Z1. C C If MODE = 'S', then the pencil sE(eps,inf)-A(eps,inf) in (1) is C separated into sE(eps)-A(eps) and sE(inf)-A(inf) by applying C unitary transformations Q3 and Z3 to Q2'*Q1'*(sE-A)*Z1*Z2. C C This gives C C | sE(eps)-A(eps) | X | X | C |----------------|----------------|------------| C | O | sE(inf)-A(inf) | X | C Q'(sE-A)Z =|=================================|============| (2) C | | | C | O | sE(r)-A(r) | C C where Q = Q1*Q2*Q3 and Z = Z1*Z2*Z3. C Note: the pencil sE(r)-A(r) is not reduced further. C C ARGUMENTS C C Mode Parameters C C MODE CHARACTER*1 C Specifies the desired structure of the transformed C pencil Q'(sE-A)Z to be computed as follows: C = 'B': Basic reduction given by (1); C = 'T': Further reduction of (1) to triangular form; C = 'S': Further separation of sE(eps,inf)-A(eps,inf) C in (1) into the two pencils in (2). C C JOBQ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Q the orthogonal row transformations, as follows: C = 'N': Do not form Q; C = 'I': Q is initialized to the unit matrix and the C orthogonal transformation matrix Q is returned; C = 'U': The given matrix Q is updated by the orthogonal C row transformations used in the reduction. C C JOBZ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal column transformations, as C follows: C = 'N': Do not form Z; C = 'I': Z is initialized to the unit matrix and the C orthogonal transformation matrix Z is returned; C = 'U': The given matrix Z is updated by the orthogonal C transformations used in the reduction. C C Input/Output Parameters C C M (input) INTEGER C The number of rows in the matrices A, E and the order of C the matrix Q. M >= 0. C C N (input) INTEGER C The number of columns in the matrices A, E and the order C of the matrix Z. N >= 0. C C RANKE (input) INTEGER C The rank of the matrix E in column echelon form. C RANKE >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading M-by-N part of this array must C contain the matrix to be row compressed. C On exit, the leading M-by-N part of this array contains C the matrix that has been row compressed while keeping C matrix E in column echelon form. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,M). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading M-by-N part of this array must C contain the matrix in column echelon form to be C transformed equivalent to matrix A. C On exit, the leading M-by-N part of this array contains C the matrix that has been transformed equivalent to matrix C A. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,M). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) C On entry, if JOBQ = 'U', then the leading M-by-M part of C this array must contain a given matrix Q (e.g. from a C previous call to another SLICOT routine), and on exit, the C leading M-by-M part of this array contains the product of C the input matrix Q and the row transformation matrix used C to transform the rows of matrices A and E. C On exit, if JOBQ = 'I', then the leading M-by-M part of C this array contains the matrix of accumulated orthogonal C row transformations performed. C If JOBQ = 'N', the array Q is not referenced and can be C supplied as a dummy array (i.e. set parameter LDQ = 1 and C declare this array to be Q(1,1) in the calling program). C C LDQ INTEGER C The leading dimension of array Q. If JOBQ = 'U' or C JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) C On entry, if JOBZ = 'U', then the leading N-by-N part of C this array must contain a given matrix Z (e.g. from a C previous call to another SLICOT routine), and on exit, the C leading N-by-N part of this array contains the product of C the input matrix Z and the column transformation matrix C used to transform the columns of matrices A and E. C On exit, if JOBZ = 'I', then the leading N-by-N part of C this array contains the matrix of accumulated orthogonal C column transformations performed. C If JOBZ = 'N', the array Z is not referenced and can be C supplied as a dummy array (i.e. set parameter LDZ = 1 and C declare this array to be Z(1,1) in the calling program). C C LDZ INTEGER C The leading dimension of array Z. If JOBZ = 'U' or C JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. C C ISTAIR (input/output) INTEGER array, dimension (M) C On entry, this array must contain information on the C column echelon form of the unitary transformed matrix E. C Specifically, ISTAIR(i) must be set to +j if the first C non-zero element E(i,j) is a corner point and -j C otherwise, for i = 1,2,...,M. C On exit, this array contains no useful information. C C NBLCKS (output) INTEGER C The number of submatrices having full row rank greater C than or equal to 0 detected in matrix A in the pencil C sE(x)-A(x), C where x = eps,inf if MODE = 'B' or 'T', C or x = eps if MODE = 'S'. C C NBLCKI (output) INTEGER C If MODE = 'S', the number of diagonal submatrices in the C pencil sE(inf)-A(inf). If MODE = 'B' or 'T' then C NBLCKI = 0. C C IMUK (output) INTEGER array, dimension (MAX(N,M+1)) C The leading NBLCKS elements of this array contain the C column dimensions mu(1),...,mu(NBLCKS) of the submatrices C having full column rank in the pencil sE(x)-A(x), C where x = eps,inf if MODE = 'B' or 'T', C or x = eps if MODE = 'S'. C C INUK (output) INTEGER array, dimension (MAX(N,M+1)) C The leading NBLCKS elements of this array contain the C row dimensions nu(1),...,nu(NBLCKS) of the submatrices C having full row rank in the pencil sE(x)-A(x), C where x = eps,inf if MODE = 'B' or 'T', C or x = eps if MODE = 'S'. C C IMUK0 (output) INTEGER array, dimension (limuk0), C where limuk0 = N if MODE = 'S' and 1, otherwise. C If MODE = 'S', then the leading NBLCKI elements of this C array contain the dimensions mu0(1),...,mu0(NBLCKI) C of the square diagonal submatrices in the pencil C sE(inf)-A(inf). C Otherwise, IMUK0 is not referenced and can be supplied C as a dummy array. C C MNEI (output) INTEGER array, dimension (3) C If MODE = 'B' or 'T' then C MNEI(1) contains the row dimension of C sE(eps,inf)-A(eps,inf); C MNEI(2) contains the column dimension of C sE(eps,inf)-A(eps,inf); C MNEI(3) = 0. C If MODE = 'S', then C MNEI(1) contains the row dimension of sE(eps)-A(eps); C MNEI(2) contains the column dimension of sE(eps)-A(eps); C MNEI(3) contains the order of the regular pencil C sE(inf)-A(inf). C C Tolerances C C TOL DOUBLE PRECISION C A tolerance below which matrix elements are considered C to be zero. If the user sets TOL to be less than (or C equal to) zero then the tolerance is taken as C EPS * MAX( ABS(A(I,J)), ABS(E(I,J)) ), where EPS is the C machine precision (see LAPACK Library routine DLAMCH), C I = 1,2,...,M and J = 1,2,...,N. C C Workspace C C IWORK INTEGER 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 > 0: if incorrect rank decisions were revealed during the C triangularization phase. This failure is not likely C to occur. The possible values are: C = 1: if incorrect dimensions of a full column rank C submatrix; C = 2: if incorrect dimensions of a full row rank C submatrix. C C METHOD C C Let sE - A be an arbitrary pencil. Prior to calling the routine, C this pencil must be transformed into a pencil with E in column C echelon form. This may be accomplished by calling the SLICOT C Library routine MB04UD. Depending on the value of MODE, C submatrices of A and E are then reduced to one of the forms C described above. Further details can be found in [1]. C C REFERENCES C C [1] Beelen, Th. and Van Dooren, P. C An improved algorithm for the computation of Kronecker's C canonical form of a singular pencil. C Linear Algebra and Applications, 105, pp. 9-65, 1988. C C NUMERICAL ASPECTS C C It is shown in [1] that the algorithm is numerically backward C stable. The operations count is proportional to (MAX(M,N))**3. C C FURTHER COMMENTS C C The difference mu(k)-nu(k), for k = 1,2,...,NBLCKS, is the number C of elementary Kronecker blocks of size k x (k+1). C C If MODE = 'B' or 'T' on entry, then the difference nu(k)-mu(k+1), C for k = 1,2,...,NBLCKS, is the number of infinite elementary C divisors of degree k (with mu(NBLCKS+1) = 0). C C If MODE = 'S' on entry, then the difference mu0(k)-mu0(k+1), C for k = 1,2,...,NBLCKI, is the number of infinite elementary C divisors of degree k (with mu0(NBLCKI+1) = 0). C In the pencil sE(r)-A(r), the pencils sE(f)-A(f) and C sE(eta)-A(eta) can be separated by pertransposing the pencil C sE(r)-A(r) and calling the routine with MODE set to 'B'. The C result has got to be pertransposed again. (For more details see C [1]). C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. C Based on Release 3.0 routine MB04TD modified by A. Varga, C German Aerospace Research Establishment, Oberpfaffenhofen, C Germany, Nov. 1997, as follows: C 1) NBLCKI is added; C 2) the significance of IMUK0 and MNEI is changed; C 3) INUK0 is removed. C C REVISIONS C C V. Sima, Aug. 2011. C A. Varga, May 2017 C C KEYWORDS C C Generalized eigenvalue problem, orthogonal transformation, C staircase form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBQ, JOBZ, MODE INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKI, NBLCKS, $ RANKE DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IMUK(*), IMUK0(*), INUK(*), ISTAIR(*), IWORK(*), $ MNEI(*) DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. LOGICAL FIRST, FIRSTI, LJOBQI, LJOBZI, LMODEB, LMODES, $ LMODET, UPDATQ, UPDATZ INTEGER I, IFICA, IFIRA, ISMUK, ISNUK, JK, K, NCA, RANKA DOUBLE PRECISION TOLER C .. Local Arrays .. DOUBLE PRECISION DWORK(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DLASET, MB04TT, MB04TY, MB04VX, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. Executable Statements .. C INFO = 0 LMODEB = LSAME( MODE, 'B' ) LMODET = LSAME( MODE, 'T' ) LMODES = LSAME( MODE, 'S' ) LJOBQI = LSAME( JOBQ, 'I' ) UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' ) LJOBZI = LSAME( JOBZ, 'I' ) UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' ) C C Test the input scalar arguments. C IF( .NOT.LMODEB .AND. .NOT.LMODET .AND. .NOT.LMODES ) THEN INFO = -1 ELSE IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN INFO = -2 ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( RANKE.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -8 ELSE IF( LDE.LT.MAX( 1, M ) ) THEN INFO = -10 ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR. $ UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN INFO = -12 ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR. $ UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN INFO = -14 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB04VD', -INFO ) RETURN END IF C C Initialize Q and Z to the identity matrices, if needed. C IF ( LJOBQI ) $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) IF ( LJOBZI ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) C C Quick return if possible. C NBLCKS = 0 NBLCKI = 0 C IF ( N.EQ.0 ) THEN MNEI(1) = 0 MNEI(2) = 0 MNEI(3) = 0 RETURN END IF C IF ( M.EQ.0 ) THEN NBLCKS = 1 IMUK(1) = N INUK(1) = 0 MNEI(1) = 0 MNEI(2) = N MNEI(3) = 0 RETURN END IF C TOLER = TOL IF ( TOLER.LE.ZERO ) $ TOLER = DLAMCH( 'Epsilon' )* $ MAX( DLANGE( 'M', M, N, A, LDA, DWORK ), $ DLANGE( 'M', M, N, E, LDE, DWORK ) ) C C A(k) is the submatrix in A that will be row compressed. C C ISMUK = sum(i=1,..,k) MU(i), ISNUK = sum(i=1,...,k) NU(i), C IFIRA, IFICA: first row and first column index of A(k) in A. C NCA: number of columns in A(k). C IFIRA = 1 IFICA = 1 NCA = N - RANKE ISNUK = 0 ISMUK = 0 K = 0 C C Initialization of the arrays INUK and IMUK. C DO 20 I = 1, M + 1 INUK(I) = -1 20 CONTINUE C C Note: it is necessary that array INUK has DIMENSION M+1 since it C is possible that M = 1 and NBLCKS = 2. C Example sE-A = (0 0 s -1). C DO 40 I = 1, N IMUK(I) = -1 40 CONTINUE C C Compress the rows of A while keeping E in column echelon form. C C REPEAT C 60 K = K + 1 CALL MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A, LDA, $ E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANKA, TOLER, $ IWORK ) IMUK(K) = NCA ISMUK = ISMUK + NCA C INUK(K) = RANKA ISNUK = ISNUK + RANKA NBLCKS = NBLCKS + 1 C C If the rank of A(k) is nra then A has full row rank; C JK = the first column index (in A) after the right most column C of matrix A(k+1). (In case A(k+1) is empty, then JK = N+1.) C IFIRA = 1 + ISNUK IFICA = 1 + ISMUK IF ( IFIRA.GT.M ) THEN JK = N + 1 ELSE JK = ABS( ISTAIR(IFIRA) ) END IF NCA = JK - 1 - ISMUK C C If NCA > 0 then there can be done some more row compression C of matrix A while keeping matrix E in column echelon form. C IF ( NCA.GT.0 ) GO TO 60 C UNTIL NCA <= 0 C C Matrix E(k+1) has full column rank since NCA = 0. C Reduce A and E by ignoring all rows and columns corresponding C to E(k+1). Ignoring these columns in E changes the ranks of the C submatrices E(i), (i=1,...,k-1). C MNEI(1) = ISNUK MNEI(2) = ISMUK MNEI(3) = 0 C IF ( LMODEB ) $ RETURN C C Triangularization of the submatrices in A and E. C CALL MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E, $ LDE, Q, LDQ, Z, LDZ, INFO ) C IF ( INFO.GT.0 .OR. LMODET ) $ RETURN C C Save the row dimensions of the diagonal submatrices in pencil C sE(eps,inf)-A(eps,inf). C DO 80 I = 1, NBLCKS IMUK0(I) = INUK(I) 80 CONTINUE C C Reduction to square submatrices E(k)'s in E. C CALL MB04VX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E, $ LDE, Q, LDQ, Z, LDZ, MNEI ) C C Determine the dimensions of the inf diagonal submatrices and C update block numbers if necessary. C FIRST = .TRUE. FIRSTI = .TRUE. NBLCKI = NBLCKS K = NBLCKS C DO 100 I = K, 1, -1 IMUK0(I) = IMUK0(I) - INUK(I) IF ( FIRSTI .AND. IMUK0(I).EQ.0 ) THEN NBLCKI = NBLCKI - 1 ELSE FIRSTI = .FALSE. END IF IF ( FIRST .AND. IMUK(I).EQ.0 ) THEN NBLCKS = NBLCKS - 1 ELSE FIRST = .FALSE. END IF 100 CONTINUE C RETURN C *** Last line of MB04VD *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02AD.f0000644000000000000000000000013215012430707016141 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02AD.f0000644000175000017500000000457515012430707017350 0ustar00lilgelilge00000000000000 SUBROUTINE MA02AD( JOB, M, N, A, LDA, B, LDB ) C C PURPOSE C C To transpose all or part of a two-dimensional matrix A into C another matrix B. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the part of the matrix A to be transposed into B C as follows: C = 'U': Upper triangular part; C = 'L': Lower triangular part; C Otherwise: All of the matrix A. 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) DOUBLE PRECISION array, dimension (LDA,N) C The m-by-n matrix A. If JOB = 'U', only the upper C triangle or trapezoid is accessed; if JOB = 'L', only the C lower triangle or trapezoid is accessed. 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,M) C B = A' in the locations specified by JOB. C C LDB INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, March 1998. C Based on the RASP routine DMTRA. C C REVISIONS C C - C C ****************************************************************** C C .. Scalar Arguments .. CHARACTER JOB INTEGER LDA, LDB, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*) C .. Local Scalars .. INTEGER I, J C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. Intrinsic Functions .. INTRINSIC MIN C C .. Executable Statements .. C IF( LSAME( JOB, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B(J,I) = A(I,J) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( JOB, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B(J,I) = A(I,J) 30 CONTINUE 40 CONTINUE ELSE DO 60 J = 1, N DO 50 I = 1, M B(J,I) = A(I,J) 50 CONTINUE 60 CONTINUE END IF C RETURN C *** Last line of MA02AD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01KD.f0000644000000000000000000000013215012430707016162 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB01KD.f0000644000175000017500000002705015012430707017362 0ustar00lilgelilge00000000000000 SUBROUTINE TB01KD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, $ LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To compute an additive spectral decomposition of the transfer- C function matrix of the system (A,B,C) by reducing the system C state-matrix A to a block-diagonal form. C The system matrices are transformed as C A <-- inv(U)*A*U, B <--inv(U)*B and C <-- C*U. C The leading diagonal block of the resulting A has eigenvalues C in a suitably defined domain of interest. 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 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 JOBA CHARACTER*1 C Specifies the shape of the state dynamics matrix on entry C as follows: C = 'S': A is in an upper real Schur form; C = 'G': A is a general square dense matrix. C C Input/Output Parameters C C N (input) INTEGER C The order of the state-space representation, C i.e. the order of the matrix A. N >= 0. C C M (input) INTEGER C The number of system inputs, or of columns of B. M >= 0. C C P (input) INTEGER C The number of system outputs, or of rows of C. P >= 0. C C ALPHA (input) DOUBLE PRECISION. C Specifies the boundary of the domain of interest for the C eigenvalues of A. For a continuous-time system C (DICO = 'C'), ALPHA is the boundary value for the real C parts of eigenvalues, while for a discrete-time system C (DICO = 'D'), ALPHA >= 0 represents the boundary value for C the moduli of 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 the unreduced state dynamics matrix A. C If JOBA = 'S' then A must be a matrix in real Schur form. C On exit, the leading N-by-N part of this array contains a C block diagonal matrix inv(U) * A * U with two diagonal C blocks in real Schur form with the elements below the C first subdiagonal set to zero. C The leading NDIM-by-NDIM block of A has eigenvalues in the C domain of interest and the trailing (N-NDIM)-by-(N-NDIM) C block has eigenvalues outside the domain of interest. C The domain of interest for lambda(A), the eigenvalues C of A, is defined by the parameters ALPHA, DICO and STDOM C as follows: C For a continuous-time system (DICO = 'C'): C Real(lambda(A)) < ALPHA if STDOM = 'S'; C Real(lambda(A)) > ALPHA if STDOM = 'U'; C For a discrete-time system (DICO = 'D'): C Abs(lambda(A)) < ALPHA if STDOM = 'S'; C Abs(lambda(A)) > ALPHA if STDOM = 'U'. 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 matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix inv(U) * B. 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 output matrix C. C On exit, the leading P-by-N part of this array contains C the transformed output matrix C * U. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C NDIM (output) INTEGER C The number of eigenvalues of A lying inside the domain of C interest for eigenvalues. C C U (output) DOUBLE PRECISION array, dimension (LDU,N) C The leading N-by-N part of this array contains the C transformation matrix used to reduce A to the block- C diagonal form. The first NDIM columns of U span the C invariant subspace of A corresponding to the eigenvalues C of its leading diagonal block. The last N-NDIM columns C of U span the reducing subspace of A corresponding to C the eigenvalues of the trailing diagonal block of A. C C LDU INTEGER C The leading dimension of array U. LDU >= max(1,N). C C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) C WR and WI contain the real and imaginary parts, C respectively, of the computed eigenvalues of A. The C eigenvalues will be in the same order that they appear on C the diagonal of the output real Schur form of A. Complex C conjugate pairs of eigenvalues will appear consecutively C with the eigenvalue having the positive imaginary part C first. 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,N) if JOBA = 'S'; C LDWORK >= MAX(1,3*N) if JOBA = 'G'. 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: the QR algorithm failed to compute all the C eigenvalues of A; C = 2: a failure occured during the ordering of the real C Schur form of A; C = 3: the separation of the two diagonal blocks failed C because of very close eigenvalues. C C METHOD C C A similarity transformation U is determined that reduces the C system state-matrix A to a block-diagonal form (with two diagonal C blocks), so that the leading diagonal block of the resulting A has C eigenvalues in a specified domain of the complex plane. The C determined transformation is applied to the system (A,B,C) as C A <-- inv(U)*A*U, B <-- inv(U)*B and C <-- C*U. C C REFERENCES C C [1] Safonov, M.G., Jonckheere, E.A., Verma, M., Limebeer, D.J.N. C Synthesis of positive real multivariable feedback systems. C Int. J. Control, pp. 817-842, 1987. C C NUMERICAL ASPECTS C 3 C The algorithm requires about 14N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, March 1998. C Based on the RASP routine SADSDC. C C REVISIONS C C - C C KEYWORDS C C Invariant subspace, real Schur form, similarity transformation, C spectral factorization. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOBA, STDOM INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, NDIM, P DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), $ WI(*), WR(*) C .. Local Scalars .. LOGICAL DISCR, LJOBG INTEGER NDIM1, NR DOUBLE PRECISION SCALE C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEMM, DLASET, DTRSYL, TB01LD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C INFO = 0 DISCR = LSAME( DICO, 'D' ) LJOBG = LSAME( JOBA, 'G' ) C C Check input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR. $ LSAME( STDOM, 'U' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( LSAME( JOBA, 'S' ) .OR. LJOBG ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN INFO = -7 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDU.LT.MAX( 1, N ) ) THEN INFO = -16 ELSE IF( LDWORK.LT.MAX( 1, N ) .OR. $ LDWORK.LT.MAX( 1, 3*N ) .AND. LJOBG ) THEN INFO = -20 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01KD', -INFO ) RETURN END IF C C Quick return if possible. C NDIM = 0 IF( N.EQ.0 ) $ RETURN C C Reduce A to an ordered real Schur form using an orthogonal C similarity transformation A <- U'*A*U and accumulate the C transformations in U. The reordering of the real Schur form of A C is performed in accordance with the values of the parameters DICO, C STDOM and ALPHA. Apply the transformation to B and C: B <- U'*B C and C <- C*U. The eigenvalues of A are computed in (WR,WI). C C Workspace: need 3*N (if JOBA = 'G'), or N (if JOBA = 'S'); C prefer larger. C CALL TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, LDB, C, $ LDC, NDIM, U, LDU, WR, WI, DWORK, LDWORK, INFO ) C IF ( INFO.NE.0 ) $ RETURN C IF ( NDIM.GT.0 .AND. NDIM.LT.N ) THEN C C Reduce A to a block-diagonal form by a similarity C transformation of the form C -1 ( I -X ) C A <- T AT, where T = ( ) and X satisfies the C ( 0 I ) C Sylvester equation C C A11*X - X*A22 = A12. C NR = N - NDIM NDIM1 = NDIM + 1 CALL DTRSYL( 'N', 'N', -1, NDIM, NR, A, LDA, A(NDIM1,NDIM1), $ LDA, A(1,NDIM1), LDA, SCALE, INFO ) IF ( INFO.NE.0 ) THEN INFO = 3 RETURN END IF C -1 C Compute B <- T B, C <- CT, U <- UT. C SCALE = ONE/SCALE CALL DGEMM( 'N', 'N', NDIM, M, NR, SCALE, A(1,NDIM1), LDA, $ B(NDIM1,1), LDB, ONE, B, LDB ) CALL DGEMM( 'N', 'N', P, NR, NDIM, -SCALE, C, LDC, A(1,NDIM1), $ LDA, ONE, C(1,NDIM1), LDC ) CALL DGEMM( 'N', 'N', N, NR, NDIM, -SCALE, U, LDU, A(1,NDIM1), $ LDA, ONE, U(1,NDIM1), LDU ) C C Set A12 to zero. C CALL DLASET( 'Full', NDIM, NR, ZERO, ZERO, A(1,NDIM1), LDA ) END IF C C Set to zero the lower triangular part under the first subdiagonal C of A. C IF ( N.GT.2 ) $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA ) RETURN C *** Last line of TB01KD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02SZ.f0000644000000000000000000000013215012430707016212 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02SZ.f0000644000175000017500000001015415012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE MB02SZ( N, H, LDH, IPIV, INFO ) C C PURPOSE C C To compute an LU factorization of a complex n-by-n upper C Hessenberg matrix H using partial pivoting with row interchanges. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix H. N >= 0. C C H (input/output) COMPLEX*16 array, dimension (LDH,N) C On entry, the n-by-n upper Hessenberg matrix to be C factored. C On exit, the factors L and U from the factorization C H = P*L*U; the unit diagonal elements of L are not stored, C and L is lower bidiagonal. C C LDH INTEGER C The leading dimension of the array H. LDH >= max(1,N). C C IPIV (output) INTEGER array, dimension (N) C The pivot indices; for 1 <= i <= N, row i of the matrix C was interchanged with row IPIV(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 > 0: if INFO = i, U(i,i) is exactly zero. The C factorization has been completed, but the factor U C is exactly singular, and division by zero will occur C if it is used to solve a system of equations. C C METHOD C C The factorization has the form C H = P * L * U C where P is a permutation matrix, L is lower triangular with unit C diagonal elements (and one nonzero subdiagonal), and U is upper C triangular. C C This is the right-looking Level 2 BLAS version of the algorithm C (adapted after ZGETF2). C C REFERENCES C C - C C NUMERICAL ASPECTS C 2 C The algorithm requires 0( N ) complex operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TB01FX by A.J. Laub, University of C Southern California, United States of America, May 1980. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, C Jan. 2005. C C KEYWORDS C C Frequency response, Hessenberg form, matrix algebra. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. INTEGER INFO, LDH, N C .. Array Arguments .. INTEGER IPIV(*) COMPLEX*16 H(LDH,*) C .. Local Scalars .. INTEGER J, JP C .. External Functions .. DOUBLE PRECISION DCABS1 EXTERNAL DCABS1 C .. External Subroutines .. EXTERNAL XERBLA, ZAXPY, ZSWAP C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDH.LT.MAX( 1, N ) ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02SZ', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C DO 10 J = 1, N C C Find pivot and test for singularity. C JP = J IF ( J.LT.N ) THEN IF ( DCABS1( H( J+1, J ) ).GT.DCABS1( H( J, J ) ) ) $ JP = J + 1 END IF IPIV( J ) = JP IF( H( JP, J ).NE.ZERO ) THEN C C Apply the interchange to columns J:N. C IF( JP.NE.J ) $ CALL ZSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH ) C C Compute element J+1 of J-th column. C IF( J.LT.N ) $ H( J+1, J ) = H( J+1, J )/H( J, J ) C ELSE IF( INFO.EQ.0 ) THEN C INFO = J END IF C IF( J.LT.N ) THEN C C Update trailing submatrix. C CALL ZAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH, $ H( J+1, J+1 ), LDH ) END IF 10 CONTINUE RETURN C *** Last line of MB02SZ *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02OW.f0000644000000000000000000000013015012430707016207 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB02OW.f0000644000175000017500000000323215012430707017405 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION SB02OW( ALPHAR, ALPHAI, BETA ) C C PURPOSE C C To select the stable generalized eigenvalues for solving the C continuous-time algebraic Riccati equation. C C ARGUMENTS C C Input/Output Parameters C C ALPHAR (input) DOUBLE PRECISION C The real part of the numerator of the current eigenvalue C considered. C C ALPHAI (input) DOUBLE PRECISION C The imaginary part of the numerator of the current C eigenvalue considered. C C BETA (input) DOUBLE PRECISION C The (real) denominator of the current eigenvalue C considered. It is assumed that BETA <> 0 (regular case). C C METHOD C C The function value SB02OW is set to .TRUE. for a stable eigenvalue C and to .FALSE., otherwise. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. C Supersedes Release 2.0 routine SB02CW by P. Van Dooren, Philips C Research Laboratory, Brussels, Belgium. C C REVISIONS C C - C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, optimal regulator, Schur form. C C ****************************************************************** C DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION ALPHAR, ALPHAI, BETA C .. Executable Statements .. C SB02OW = ( ALPHAR.LT.ZERO .AND. BETA.GT.ZERO ) .OR. $ ( ALPHAR.GT.ZERO .AND. BETA.LT.ZERO ) C RETURN C *** Last line of SB02OW *** END control-4.1.2/src/slicot/src/PaxHeaders/MD03BX.f0000644000000000000000000000013015012430707016170 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MD03BX.f0000644000175000017500000001632015012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the QR factorization with column pivoting of an C m-by-n matrix J (m >= n), that is, J*P = Q*R, where Q is a matrix C with orthogonal columns, P a permutation matrix, and R an upper C trapezoidal matrix with diagonal elements of nonincreasing C magnitude, and to apply the transformation Q' on the error C vector e (in-situ). The 1-norm of the scaled gradient is also C returned. The matrix J could be the Jacobian of a nonlinear least C squares problem. C C ARGUMENTS C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the Jacobian matrix J. M >= 0. C C N (input) INTEGER C The number of columns of the Jacobian matrix J. C M >= N >= 0. C C FNORM (input) DOUBLE PRECISION C The Euclidean norm of the vector e. FNORM >= 0. C C J (input/output) DOUBLE PRECISION array, dimension (LDJ, N) C On entry, the leading M-by-N part of this array must C contain the Jacobian matrix J. C On exit, the leading N-by-N upper triangular part of this C array contains the upper triangular factor R of the C Jacobian matrix. Note that for efficiency of the later C calculations, the matrix R is delivered with the leading C dimension MAX(1,N), possibly much smaller than the value C of LDJ on entry. C C LDJ (input/output) INTEGER C The leading dimension of array J. C On entry, LDJ >= MAX(1,M). C On exit, LDJ >= MAX(1,N). C C E (input/output) DOUBLE PRECISION array, dimension (M) C On entry, this array must contain the error vector e. C On exit, this array contains the updated vector Q'*e. C C JNORMS (output) DOUBLE PRECISION array, dimension (N) C This array contains the Euclidean norms of the columns of C the Jacobian matrix, considered in the initial order. C C GNORM (output) DOUBLE PRECISION C If FNORM > 0, the 1-norm of the scaled vector C J'*Q'*e/FNORM, with each element i further divided by C JNORMS(i) (if JNORMS(i) is nonzero). C If FNORM = 0, the returned value of GNORM is 0. C C IPVT (output) INTEGER array, dimension (N) C This array defines the permutation matrix P such that C J*P = Q*R. Column j of P is column IPVT(j) of the identity C matrix. 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 length of the array DWORK. C LDWORK >= 1, if N = 0 or M = 1; C LDWORK >= 4*N+1, if N > 1. 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 C METHOD C C The algorithm uses QR factorization with column pivoting of the C matrix J, J*P = Q*R, and applies the orthogonal matrix Q' to the C vector e. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, Jacobian matrix, matrix algebra, C matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDJ, LDWORK, M, N DOUBLE PRECISION FNORM, GNORM C .. Array Arguments .. INTEGER IPVT(*) DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) C .. Local Scalars .. INTEGER I, ITAU, JWORK, L, WRKOPT DOUBLE PRECISION SUM C .. External Functions .. DOUBLE PRECISION DDOT, DNRM2 EXTERNAL DDOT, DNRM2 C .. External Subroutines .. EXTERNAL DGEQP3, DLACPY, DORMQR, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX C .. C .. Executable Statements .. C INFO = 0 IF ( M.LT.0 ) THEN INFO = -1 ELSEIF ( N.LT.0.OR. M.LT.N ) THEN INFO = -2 ELSEIF ( FNORM.LT.ZERO ) THEN INFO = -3 ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF ( N.EQ.0 .OR. M.EQ.1 ) THEN JWORK = 1 ELSE JWORK = 4*N + 1 END IF IF ( LDWORK.LT.JWORK ) $ INFO = -11 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MD03BX', -INFO ) RETURN END IF C C Quick return if possible. C GNORM = ZERO IF ( N.EQ.0 ) THEN LDJ = 1 DWORK(1) = ONE RETURN ELSEIF ( M.EQ.1 ) THEN JNORMS(1) = ABS( J(1) ) IF ( FNORM*J(1).NE.ZERO ) $ GNORM = ABS( E(1)/FNORM ) LDJ = 1 IPVT(1) = 1 DWORK(1) = ONE RETURN END IF C C Initialize the column pivoting indices. C DO 10 I = 1, N IPVT(I) = 0 10 CONTINUE 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 ITAU = 1 JWORK = ITAU + N WRKOPT = 1 C C Compute the QR factorization with pivoting of J, and apply Q' to C the vector e. C C Workspace: need: 4*N + 1; C prefer: 3*N + ( N+1 )*NB. C CALL DGEQP3( M, N, J, LDJ, IPVT, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Workspace: need: N + 1; C prefer: N + NB. C CALL DORMQR( 'Left', 'Transpose', M, 1, N, J, LDJ, DWORK(ITAU), E, $ M, DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C IF ( LDJ.GT.N ) THEN C C Reshape the array J to have the leading dimension N. C This destroys the details of the orthogonal matrix Q. C CALL DLACPY( 'Upper', N, N, J, LDJ, J, N ) LDJ = N END IF C C Compute the norm of the scaled gradient and original column norms. C IF ( FNORM.NE.ZERO ) THEN C DO 20 I = 1, N L = IPVT(I) JNORMS(L) = DNRM2( I, J((I-1)*LDJ+1), 1 ) IF ( JNORMS(L).NE.ZERO ) THEN SUM = DDOT( I, J((I-1)*LDJ+1), 1, E, 1 )/FNORM GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) END IF 20 CONTINUE C ELSE C DO 30 I = 1, N L = IPVT(I) JNORMS(L) = DNRM2( I, J((I-1)*LDJ+1), 1 ) 30 CONTINUE C END IF C DWORK(1) = WRKOPT RETURN C C *** Last line of MD03BX *** END control-4.1.2/src/slicot/src/PaxHeaders/DE01PD.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/DE01PD.f0000644000175000017500000001364515012430707017357 0ustar00lilgelilge00000000000000 SUBROUTINE DE01PD( CONV, WGHT, N, A, B, W, INFO ) C C PURPOSE C C To compute the convolution or deconvolution of two real signals C A and B using the Hartley transform. C C ARGUMENTS C C Mode Parameters C C CONV CHARACTER*1 C Indicates whether convolution or deconvolution is to be C performed as follows: C = 'C': Convolution; C = 'D': Deconvolution. C C WGHT CHARACTER*1 C Indicates whether the precomputed weights are available C or not, as follows: C = 'A': available; C = 'N': not available. C Note that if N > 1 and WGHT = 'N' on entry, then WGHT is C set to 'A' on exit. C C Input/Output Parameters C C N (input) INTEGER C The number of samples. N must be a power of 2. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the first signal. C On exit, this array contains the convolution (if C CONV = 'C') or deconvolution (if CONV = 'D') of the two C signals. C C B (input) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain the second signal. C NOTE that this array is overwritten. C C W (input/output) DOUBLE PRECISION array, C dimension (N - LOG2(N)) C On entry with WGHT = 'A', this array must contain the long C weight vector computed by a previous call of this routine C or of the SLICOT Library routine DG01OD.f, with the same C value of N. If WGHT = 'N', the contents of this array on C entry is ignored. C On exit, this array contains the long weight vector. 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 This routine computes the convolution or deconvolution of two C real signals A and B using three scrambled Hartley transforms C (SLICOT Library routine DG01OD). C C REFERENCES C C [1] Van Loan, Charles. C Computational frameworks for the fast Fourier transform. C SIAM, 1992. C C NUMERICAL ASPECTS C C The algorithm requires O(N log(N)) floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, April 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. C C KEYWORDS C C Convolution, deconvolution, digital signal processing, C fast Hartley transform, real signals. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION HALF, TWO PARAMETER ( HALF = 0.5D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER CONV, WGHT INTEGER INFO, N C .. Array Arguments .. DOUBLE PRECISION A(*), B(*), W(*) C .. Local Scalars .. LOGICAL LCONV, LWGHT INTEGER J, L, LEN, M, P1, R1 DOUBLE PRECISION T1, T2, T3 C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DG01OD, DLADIV, DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MOD C .. Executable Statements .. C INFO = 0 LCONV = LSAME( CONV, 'C' ) LWGHT = LSAME( WGHT, 'A' ) C C Test the input scalar arguments. C IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN INFO = -1 ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN INFO = -2 ELSE M = 0 J = 0 IF( N.GE.1 ) THEN J = N C WHILE ( MOD( J, 2 ).EQ.0 ) DO 10 CONTINUE IF ( MOD( J, 2 ).EQ.0 ) THEN J = J/2 M = M + 1 GO TO 10 END IF C END WHILE 10 IF ( J.NE.1 ) INFO = -3 ELSE IF ( N.LT.0 ) THEN INFO = -3 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'DE01PD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.LE.0 ) THEN RETURN ELSE IF ( N.EQ.1 ) THEN IF ( LCONV ) THEN A(1) = A(1)*B(1) ELSE A(1) = A(1)/B(1) END IF RETURN END IF C C Scrambled Hartley transforms of A and B. C CALL DG01OD( 'OutputScrambled', WGHT, N, A, W, INFO ) CALL DG01OD( 'OutputScrambled', WGHT, N, B, W, INFO ) C C Something similar to a Hadamard product/quotient. C LEN = 1 IF( LCONV ) THEN A(1) = TWO*A(1)*B(1) A(2) = TWO*A(2)*B(2) C DO 30 L = 1, M - 1 LEN = 2*LEN R1 = 2*LEN C DO 20 P1 = LEN + 1, LEN + LEN/2 T1 = B(P1) + B(R1) T2 = B(P1) - B(R1) T3 = T2*A(P1) A(P1) = T1*A(P1) + T2*A(R1) A(R1) = T1*A(R1) - T3 R1 = R1 - 1 20 CONTINUE C 30 CONTINUE C ELSE C A(1) = HALF*A(1)/B(1) A(2) = HALF*A(2)/B(2) C DO 50 L = 1, M - 1 LEN = 2*LEN R1 = 2*LEN C DO 40 P1 = LEN + 1, LEN + LEN/2 CALL DLADIV( A(P1), A(R1), B(P1)+B(R1), B(R1)-B(P1), T1, $ T2 ) A(P1) = T1 A(R1) = T2 R1 = R1 - 1 40 CONTINUE C 50 CONTINUE C END IF C C Transposed Hartley transform of A. C CALL DG01OD( 'InputScrambled', WGHT, N, A, W, INFO ) IF ( LCONV ) THEN CALL DSCAL( N, HALF/DBLE( N ), A, 1 ) ELSE CALL DSCAL( N, TWO/DBLE( N ), A, 1 ) END IF C RETURN C *** Last line of DE01PD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03QX.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB03QX.f0000644000175000017500000002753515012430707017425 0ustar00lilgelilge00000000000000 SUBROUTINE SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To estimate a forward error bound for the solution X of a real C continuous-time Lyapunov matrix equation, C C op(A)'*X + X*op(A) = C, C C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The C matrix A, the right hand side C, and the solution X are N-by-N. C An absolute residual matrix, which takes into account the rounding C errors in forming it, is given in the array R. C C ARGUMENTS C C Mode Parameters 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 UPLO CHARACTER*1 C Specifies which part of the symmetric matrix R is to be C used, as follows: C = 'U': Upper triangular part; C = 'L': Lower triangular part. C C LYAPUN CHARACTER*1 C Specifies whether or not the original Lyapunov equations C should be solved, as follows: C = 'O': Solve the original Lyapunov equations, updating C the right-hand sides and solutions with the C matrix U, e.g., X <-- U'*X*U; C = 'R': Solve reduced Lyapunov equations only, without C updating the right-hand sides and solutions. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and R. N >= 0. C C XANORM (input) DOUBLE PRECISION C The absolute (maximal) norm of the symmetric solution C matrix X of the Lyapunov equation. XANORM >= 0. C C T (input) DOUBLE PRECISION array, dimension (LDT,N) C The leading N-by-N upper Hessenberg part of this array C must contain the upper quasi-triangular matrix T in Schur C canonical form from a Schur factorization of A. C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,N). C C U (input) DOUBLE PRECISION array, dimension (LDU,N) C The leading N-by-N part of this array must contain the C orthogonal matrix U from a real Schur factorization of A. C If LYAPUN = 'R', the array U is not referenced. C C LDU INTEGER C The leading dimension of array U. C LDU >= 1, if LYAPUN = 'R'; C LDU >= MAX(1,N), if LYAPUN = 'O'. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,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 absolute residual matrix R, with C bounds on rounding errors added. 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 absolute residual matrix R, with C bounds on rounding errors added. C On exit, the leading N-by-N part of this array contains C the symmetric absolute residual matrix R (with bounds on C rounding errors added), fully stored. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C FERR (output) DOUBLE PRECISION C An estimated forward error bound for the solution X. C If XTRUE is the true solution, FERR bounds the magnitude C of the largest entry in (X - XTRUE) divided by the C magnitude of the largest entry in X. C If N = 0 or XANORM = 0, FERR is set to 0, without any C calculations. C C Workspace C C IWORK INTEGER array, dimension (N*N) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 2*N*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 = N+1: if the matrices T and -T' have common or very C close eigenvalues; perturbed values were used to C solve Lyapunov equations (but the matrix T is C unchanged). C C METHOD C C The forward error bound is estimated using a practical error bound C similar to the one proposed in [1], based on the 1-norm estimator C in [2]. C C REFERENCES C C [1] Higham, N.J. C Perturbation theory and backward error for AX-XB=C. C BIT, vol. 33, pp. 124-136, 1993. C C [2] Higham, N.J. C FORTRAN codes for estimating the one-norm of a real or C complex matrix, with applications to condition estimation. C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C FURTHER COMMENTS C C The option LYAPUN = 'R' may occasionally produce slightly worse C or better estimates, and it is much faster than the option 'O'. C The routine can be also used as a final step in estimating a C forward error bound for the solution of a continuous-time C algebraic matrix Riccati equation. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Oct. 1998. Partly based on DGLSVX (and then SB03QD) by P. Petkov, C Tech. University of Sofia, March 1998 (and December 1998). C C REVISIONS C C February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004, C May 2020 C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) C .. C .. Scalar Arguments .. CHARACTER LYAPUN, TRANA, UPLO INTEGER INFO, LDR, LDT, LDU, LDWORK, N DOUBLE PRECISION FERR, XANORM C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION DWORK( * ), R( LDR, * ), T( LDT, * ), $ U( LDU, * ) C .. C .. Local Scalars .. LOGICAL LOWER, NOTRNA, UPDATE CHARACTER TRANAT, UPLOW INTEGER I, IJ, INFO2, ITMP, J, KASE, NN DOUBLE PRECISION EST, SCALE, TEMP C .. C .. Local Arrays .. INTEGER ISAVE( 3 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANSY EXTERNAL DLANSY, LSAME C .. C .. External Subroutines .. EXTERNAL DLACN2, DSCAL, MA02ED, MB01RU, SB03MY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Decode and Test input parameters. C NOTRNA = LSAME( TRANA, 'N' ) UPDATE = LSAME( LYAPUN, 'O' ) C NN = N*N INFO = 0 IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. $ LSAME( TRANA, 'C' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) $ THEN INFO = -2 ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( XANORM.LT.ZERO ) THEN INFO = -5 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN INFO = -9 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDWORK.LT.2*NN ) THEN INFO = -15 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03QX', -INFO ) RETURN END IF C C Quick return if possible. C FERR = ZERO IF( N.EQ.0 .OR. XANORM.EQ.ZERO ) $ RETURN C ITMP = NN + 1 C IF( NOTRNA ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF C C Fill in the remaining triangle of the symmetric residual matrix. C CALL MA02ED( UPLO, N, R, LDR ) C KASE = 0 C C REPEAT 10 CONTINUE CALL DLACN2( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE, ISAVE ) IF( KASE.NE.0 ) THEN C C Select the triangular part of symmetric matrix to be used. C IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) $ .GE. $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) $ ) THEN UPLOW = 'U' LOWER = .FALSE. ELSE UPLOW = 'L' LOWER = .TRUE. END IF C IF( KASE.EQ.2 ) THEN IJ = 0 IF( LOWER ) THEN C C Scale the lower triangular part of symmetric matrix C by the residual matrix. C DO 30 J = 1, N DO 20 I = J, N IJ = IJ + 1 DWORK( IJ ) = DWORK( IJ )*R( I, J ) 20 CONTINUE IJ = IJ + J 30 CONTINUE ELSE C C Scale the upper triangular part of symmetric matrix C by the residual matrix. C DO 50 J = 1, N DO 40 I = 1, J IJ = IJ + 1 DWORK( IJ ) = DWORK( IJ )*R( I, J ) 40 CONTINUE IJ = IJ + N - J 50 CONTINUE END IF END IF C IF( UPDATE ) THEN C C Transform the right-hand side: RHS := U'*RHS*U. C CALL MB01RU( UPLOW, 'Transpose', N, N, ZERO, ONE, DWORK, N, $ U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) END IF CALL MA02ED( UPLOW, N, DWORK, N ) C IF( KASE.EQ.2 ) THEN C C Solve op(T)'*Y + Y*op(T) = scale*RHS. C CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) ELSE C C Solve op(T)*W + W*op(T)' = scale*RHS. C CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) END IF C IF( INFO2.GT.0 ) $ INFO = N + 1 C IF( UPDATE ) THEN C C Transform back to obtain the solution: Z := U*Z*U', with C Z = Y or Z = W. C CALL MB01RU( UPLOW, 'No transpose', N, N, ZERO, ONE, DWORK, $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) END IF C IF( KASE.EQ.1 ) THEN IJ = 0 IF( LOWER ) THEN C C Scale the lower triangular part of symmetric matrix C by the residual matrix. C DO 70 J = 1, N DO 60 I = J, N IJ = IJ + 1 DWORK( IJ ) = DWORK( IJ )*R( I, J ) 60 CONTINUE IJ = IJ + J 70 CONTINUE ELSE C C Scale the upper triangular part of symmetric matrix C by the residual matrix. C DO 90 J = 1, N DO 80 I = 1, J IJ = IJ + 1 DWORK( IJ ) = DWORK( IJ )*R( I, J ) 80 CONTINUE IJ = IJ + N - J 90 CONTINUE END IF END IF C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( UPLOW, N, DWORK, N ) GO TO 10 END IF C C UNTIL KASE = 0 C C Compute the estimate of the relative error. C TEMP = XANORM*SCALE IF( TEMP.GT.EST ) THEN FERR = EST / TEMP ELSE FERR = ONE END IF C RETURN C C *** Last line of SB03QX *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02ND.f0000644000000000000000000000013015012430707016163 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB02ND.f0000644000175000017500000007365715012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE SB02ND( DICO, FACT, UPLO, JOBL, N, M, P, A, LDA, B, $ LDB, R, LDR, IPIV, L, LDL, X, LDX, RNORM, F, $ LDF, OUFACT, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the optimal feedback matrix F for the problem of C optimal control given by C C -1 C F = (R + B'XB) (B'XA + L') (1) C C in the discrete-time case and C C -1 C F = R (B'X + L') (2) C C in the continuous-time case, where A, B and L are N-by-N, N-by-M C and N-by-M matrices respectively; R and X are M-by-M and N-by-N C symmetric matrices respectively. C C Optionally, matrix R may be specified in a factored form, and L C may be zero. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the equation from which F is to be determined, C as follows: C = 'D': Equation (1), discrete-time case; C = 'C': Equation (2), continuous-time case. C C FACT CHARACTER*1 C Specifies how the matrix R is given (factored or not), as C follows: C = 'N': Array R contains the matrix R; C = 'D': Array R contains a P-by-M matrix D, where R = D'D; C = 'C': Array R contains the Cholesky factor of R; C = 'U': Array R contains the symmetric indefinite UdU' or C LdL' factorization of R. This option is not C available for DICO = 'D'. C C UPLO CHARACTER*1 C Specifies which triangle of the possibly factored matrix R C (or R + B'XB, on exit) is or should be stored, as follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. C C JOBL CHARACTER*1 C Specifies whether or not the matrix L is zero, as follows: C = 'Z': L is zero; C = 'N': L is nonzero. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and X. N >= 0. C No computations are performed if MIN(N,M) = 0. C C M (input) INTEGER C The number of system inputs. M >= 0. C C P (input) INTEGER C The number of rows of the matrix D. C P >= M for DICO = 'C'; C P >= 0 for DICO = 'D'. C This parameter must be specified only for FACT = 'D'. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C If DICO = 'D', the leading N-by-N part of this array must C contain the state matrix A of the system. C If DICO = 'C', this array is not referenced. C C LDA INTEGER C The leading dimension of array A. C LDA >= MAX(1,N) if DICO = 'D'; C LDA >= 1 if DICO = 'C'. C C B (input/worksp.) DOUBLE PRECISION array, dimension (LDB,M) C The leading N-by-M part of this array must contain the C input matrix B of the system. C If DICO = 'D' and FACT = 'D' or 'C', the contents of this C array is destroyed. Specifically, if, on exit, C OUFACT(2) = 1, this array contains chol(X)*B, and if C OUFACT(2) = 2 and INFO < M+2, but INFO >= 0, its trailing C part (in the first N rows) contains the submatrix of C sqrt(V)*U'B corresponding to the non-negligible, positive C eigenvalues of X, where V and U are the matrices with the C eigenvalues and eigenvectors of X. C Otherwise, B is unchanged on exit. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) C On entry, if FACT = 'N', the leading M-by-M upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the upper C triangular part or lower triangular part, respectively, C of the symmetric input weighting matrix R. C On entry, if FACT = 'D', the leading P-by-M part of this C array must contain the direct transmission matrix D of the C system. C On entry, if FACT = 'C', the leading M-by-M upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the Cholesky C factor of the positive definite input weighting matrix R C (as produced by LAPACK routine DPOTRF). C On entry, if DICO = 'C' and FACT = 'U', the leading M-by-M C upper triangular part (if UPLO = 'U') or lower triangular C part (if UPLO = 'L') of this array must contain the C factors of the UdU' or LdL' factorization, respectively, C of the symmetric indefinite input weighting matrix R (as C produced by LAPACK routine DSYTRF). C The strictly lower triangular part (if UPLO = 'U') or C strictly upper triangular part (if UPLO = 'L') of this C array is used as workspace (filled in by symmetry with the C other strictly triangular part of R, of R+B'XB, or of the C result, if DICO = 'C', DICO = 'D', or (DICO = 'D' and C (FACT = 'D' or FACT = 'C') and UPLO = 'L'), respectively. C On exit, if OUFACT(1) = 1, and INFO = 0 (or INFO = M+1), C the leading M-by-M upper triangular part (if UPLO = 'U') C or lower triangular part (if UPLO = 'L') of this array C contains the Cholesky factor of the given input weighting C matrix R (for DICO = 'C'), or that of the matrix R + B'XB C (for DICO = 'D'). C On exit, if OUFACT(1) = 2, and INFO = 0 (or INFO = M+1), C the leading M-by-M upper triangular part (if UPLO = 'U') C or lower triangular part (if UPLO = 'L') of this array C contains the factors of the UdU' or LdL' factorization, C respectively, of the given input weighting matrix C (for DICO = 'C'), or that of the matrix R + B'XB C (for DICO = 'D' and FACT = 'N'). C On exit R is unchanged if FACT = 'U' or N = 0. C C LDR INTEGER. C The leading dimension of the array R. C LDR >= MAX(1,M) if FACT <> 'D'; C LDR >= MAX(1,M,P) if FACT = 'D'. C C IPIV (input/output) INTEGER array, dimension (M) C On entry, if FACT = 'U', this array must contain details C of the interchanges performed and the block structure of C the d factor in the UdU' or LdL' factorization of matrix R C (as produced by LAPACK routine DSYTRF). C On exit, if OUFACT(1) = 2, this array contains details of C the interchanges performed and the block structure of the C d factor in the UdU' or LdL' factorization of matrix R or C R + B'XB, as produced by LAPACK routine DSYTRF. C This array is not referenced if FACT = 'D', or FACT = 'C', C or N = 0. C C L (input) DOUBLE PRECISION array, dimension (LDL,M) C If JOBL = 'N', the leading N-by-M part of this array must C contain the cross weighting matrix L. C If JOBL = 'Z', this array is not referenced. C C LDL INTEGER C The leading dimension of array L. C LDL >= MAX(1,N) if JOBL = 'N'; C LDL >= 1 if JOBL = 'Z'. 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 solution matrix X of the algebraic Riccati C equation as produced by SLICOT Library routines SB02MD or C SB02OD. Matrix X is assumed non-negative definite if C DICO = 'D' and (FACT = 'D' or FACT = 'C'). C The full matrix X must be given on input if LDWORK < N*M C or if DICO = 'D' and (FACT = 'D' or FACT = 'C'). C On exit, if DICO = 'D', FACT = 'D' or FACT = 'C', and C OUFACT(2) = 1, the N-by-N upper triangular part C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') C of this array contains the Cholesky factor of the given C matrix X, which is found to be positive definite. C On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 2, C and INFO < M+2 (but INFO >= 0), the leading N-by-N part of C this array contains the matrix of orthonormal eigenvectors C of X. C On exit X is unchanged if DICO = 'C' or FACT = 'N'. C C LDX INTEGER C The leading dimension of array X. LDX >= MAX(1,N). C C RNORM (input) DOUBLE PRECISION C If FACT = 'U', this parameter must contain the 1-norm of C the original matrix R (before factoring it). C Otherwise, this parameter is not used. C C F (output) DOUBLE PRECISION array, dimension (LDF,N) C The leading M-by-N part of this array contains the C optimal feedback matrix F. C This array is not referenced if DICO = 'C' and FACT = 'D' C and P < M. C C LDF INTEGER C The leading dimension of array F. LDF >= MAX(1,M). C C OUFACT (output) INTEGER array, dimension (2) C Information about the factorization finally used. C OUFACT(1) = 1: Cholesky factorization of R (or R + B'XB) C has been used; C OUFACT(1) = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = C 'L') factorization of R (or R + B'XB) C has been used; C OUFACT(2) = 1: Cholesky factorization of X has been used; C OUFACT(2) = 2: Spectral factorization of X has been used. C The value of OUFACT(2) is not set for DICO = 'C' or for C DICO = 'D' and FACT = 'N'. C This array is not set if N = 0 or M = 0. C C Workspace C C IWORK INTEGER array, dimension (M) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or LDWORK = -1, DWORK(1) returns the C optimal value of LDWORK, and for LDWORK set as specified C below, DWORK(2) contains the reciprocal condition number C of the matrix R (for DICO = 'C') or of R + B'XB (for C DICO = 'D'); DWORK(2) is set to 1 if N = 0. C On exit, if LDWORK = -2 on input or INFO = -25, then C DWORK(1) returns the minimal value of LDWORK. C If on exit INFO = 0, and OUFACT(2) = 2, then DWORK(3),..., C DWORK(N+2) contain the eigenvalues of X, in ascending C order. C C LDWORK INTEGER C Dimension of working array DWORK. C LDWORK >= max(2,2*M) if FACT = 'U'; C LDWORK >= max(2,3*M) if FACT <> 'U', DICO = 'C'; C LDWORK >= max(2,3*M,N) if FACT = 'N', DICO = 'D'; C LDWORK >= max(N+3*M+2,4*N+1) if FACT <> 'N', DICO = 'D'. C For optimum performance LDWORK should be larger. C C If LDWORK = -1, an optimal workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C If LDWORK = -2, a minimal workspace query is assumed; the C routine only calculates the minimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message 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 = i: if the i-th element of the d factor is exactly zero; C the UdU' (or LdL') factorization has been completed, C but the block diagonal matrix d is exactly singular; C = M+1: if the matrix R (if DICO = 'C'), or R + B'XB C (if DICO = 'D') is numerically singular (to working C precision); C = M+2: if one or more of the eigenvalues of X has not C converged; C = M+3: if the matrix X is indefinite and updating the C triangular factorization failed. C If INFO > M+1, call the routine again with an appropriate, C unfactored matrix R. C C METHOD C C The optimal feedback matrix F is obtained as the solution to the C system of linear equations C C (R + B'XB) * F = B'XA + L' C C in the discrete-time case and C C R * F = B'X + L' C C in the continuous-time case, with R replaced by D'D if FACT = 'D'. C If FACT = 'N', Cholesky factorization is tried first, but C if the coefficient matrix is not positive definite, then UdU' (or C LdL') factorization is used. If FACT <> 'N', the factored form C of R is taken into account. The discrete-time case then involves C updating of a triangular factorization of R (or D'D); Cholesky or C symmetric spectral factorization of X is employed to avoid C squaring of the condition number of the matrix. When D is given, C its QR factorization is determined, and the triangular factor is C used as described above. C C NUMERICAL ASPECTS C C The algorithm consists of numerically stable steps. C 3 2 C For DICO = 'C', it requires O(m + mn ) floating point operations C 2 C if FACT = 'N' and O(mn ) floating point operations, otherwise. C For DICO = 'D', the operation counts are similar, but additional C 3 C O(n ) floating point operations may be needed in the worst case. C These estimates assume that M <= N. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. C Supersedes Release 2.0 routine SB02BD by M. Vanbegin, and C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2013, C Jan. 2014. C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, discrete-time system, matrix algebra, optimal control, C optimal regulator. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, FACT, JOBL, UPLO INTEGER INFO, LDA, LDB, LDF, LDL, LDR, LDWORK, LDX, M, $ N, P DOUBLE PRECISION RNORM C .. Array Arguments .. INTEGER IPIV(*), IWORK(*), OUFACT(2) DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), $ L(LDL,*), R(LDR,*), X(LDX,*) C .. Local Scalars .. LOGICAL DISCR, LFACTA, LFACTC, LFACTD, LFACTU, LNFACT, $ LUPLOU, SUFWRK, WITHL CHARACTER NT, NUPLO, TR, TRL INTEGER I, IFAIL, JW, JZ, MS, NR, WRKMIN, WRKOPT DOUBLE PRECISION EPS, RCOND, RNORMP, TEMP C .. Local Arrays .. DOUBLE PRECISION DUMMY(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL DLAMCH, DLANSY, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DLACPY, DLASET, $ DPOCON, DPOTRF, DPOTRS, DSCAL, DSYCON, DSYEV, $ DSYMM, DSYTRF, DSYTRS, DTRCON, DTRMM, MA02AD, $ MA02ED, MB01RB, MB04KD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 DISCR = LSAME( DICO, 'D' ) LFACTC = LSAME( FACT, 'C' ) LFACTD = LSAME( FACT, 'D' ) LFACTU = LSAME( FACT, 'U' ) LUPLOU = LSAME( UPLO, 'U' ) WITHL = LSAME( JOBL, 'N' ) LFACTA = LFACTC .OR. LFACTD .OR. LFACTU LNFACT = .NOT.LFACTA C C Test the input scalar arguments. C IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN INFO = -1 ELSE IF( ( LNFACT .AND. .NOT.LSAME( FACT, 'N' ) ) .OR. $ ( DISCR .AND. LFACTU ) ) THEN INFO = -2 ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -3 ELSE IF( .NOT.WITHL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( LFACTD .AND. ( P.LT.0 .OR. ( .NOT.DISCR .AND. P.LT.M ) ) $ ) THEN INFO = -7 ELSE IF( LDA.LT.1 .OR. ( DISCR .AND. LDA.LT.N ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDR.LT.MAX( 1, M ) .OR. ( LFACTD .AND. $ LDR.LT.MAX( 1, P ) ) ) THEN INFO = -13 ELSE IF( LDL.LT.1 .OR. ( WITHL .AND. LDL.LT.N ) ) THEN INFO = -16 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -18 ELSE IF( LFACTU ) THEN IF( RNORM.LT.ZERO ) $ INFO = -19 END IF IF ( INFO.EQ.0 ) THEN IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -21 ELSE IF ( DISCR ) THEN IF( LNFACT ) THEN WRKMIN = MAX( 2, 3*M, N ) ELSE WRKMIN = MAX( N + 3*M + 2, 4*N + 1 ) END IF ELSE IF( LFACTU ) THEN WRKMIN = MAX( 2, 2*M ) ELSE WRKMIN = MAX( 2, 3*M ) END IF END IF IF( LDWORK.EQ.-1 ) THEN WRKOPT = MAX( WRKMIN, N*M ) IF ( LFACTD ) THEN CALL DGEQRF( P, M, R, LDR, DWORK, DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) )+MIN( P, M ) ) END IF IF( LFACTA ) THEN IF( DISCR ) THEN CALL DSYEV( 'Vectors', 'Lower', N, X, LDX, DWORK, $ DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) )+N+2, $ N*M+2*N+2 ) END IF ELSE CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF DWORK(1) = WRKOPT RETURN ELSE IF( LDWORK.EQ.-2 ) THEN DWORK(1) = WRKMIN RETURN ELSE IF( LDWORK.LT.WRKMIN ) THEN INFO = -25 DWORK(1) = WRKMIN RETURN END IF END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB02ND', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 ) THEN DWORK(1) = TWO IF ( N.EQ.0 ) THEN DWORK(2) = ONE ELSE DWORK(2) = ZERO END IF RETURN END IF C NT = 'No transpose' TR = 'Transpose' C EPS = DLAMCH( 'Precision' ) C C Determine the right-hand side of the matrix equation, and R+B'XB, C if needed. C Compute B'X in F or XB in the workspace, if enough space. In the C first case and for DICO = 'D' and FACT = 'N', compute R+B'XB in R. C Then, compute in F C B'XA + L', if DICO = 'D'; C B'X + L', if DICO = 'C'. C In the second case, reverse the order of the last two steps. 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 C Workspace: need 0; C prefer M*N. This will need only a triangle of X. C WRKOPT = MAX( WRKMIN, N*M ) SUFWRK = LDWORK.GE.N*M IF ( SUFWRK ) THEN IF ( DISCR .OR. .NOT.WITHL ) THEN CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, B, LDB, ZERO, $ DWORK, N ) IF ( WITHL ) THEN CALL MA02AD( 'All', N, M, L, LDL, F, LDF ) CALL DGEMM( TR, NT, M, N, N, ONE, DWORK, N, A, LDA, ONE, $ F, LDF ) ELSE IF ( DISCR ) THEN CALL DGEMM( TR, NT, M, N, N, ONE, DWORK, N, A, LDA, $ ZERO, F, LDF ) ELSE CALL MA02AD( 'All', N, M, DWORK, N, F, LDF ) END IF ELSE CALL DLACPY( 'All', N, M, L, LDL, DWORK, N ) CALL DSYMM( 'Left', UPLO, N, M, ONE, X, LDX, B, LDB, ONE, $ DWORK, N ) CALL MA02AD( 'All', N, M, DWORK, N, F, LDF ) END IF ELSE CALL DGEMM( TR, NT, M, N, N, ONE, B, LDB, X, LDX, ZERO, $ F, LDF ) END IF C IF ( LNFACT ) THEN C C R not factored. C IF ( DISCR ) THEN C C Discrete-time case. Compute a triangle of R + B'XB. C IF ( SUFWRK ) THEN CALL MB01RB( 'Left', UPLO, TR, M, N, ONE, ONE, R, LDR, $ DWORK, N, B, LDB, IFAIL ) ELSE CALL MB01RB( 'Left', UPLO, NT, M, N, ONE, ONE, R, LDR, F, $ LDF, B, LDB, IFAIL ) END IF END IF C C Compute the 1-norm of the matrix R or R + B'XB. C Workspace: need M. C RNORMP = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) END IF C IF ( DISCR .AND. .NOT.SUFWRK ) THEN MS = MAX( LDWORK/N, 1 ) C C Postmultiply B'X by A. C Workspace: need N; C prefer N*M. C DO 10 I = 1, M, MS NR = MIN( MS, M-I+1 ) CALL DLACPY( 'All', NR, N, F(I,1), LDF, DWORK, NR ) CALL DGEMM( NT, NT, NR, N, N, ONE, DWORK, NR, A, LDA, ZERO, $ F(I,1), LDF ) 10 CONTINUE C END IF C IF( WITHL .AND. .NOT.SUFWRK ) THEN C C Add L'. C DO 20 I = 1, M CALL DAXPY( N, ONE, L(1,I), 1, F(I,1), LDF ) 20 CONTINUE C END IF C C Solve the matrix equation. C IF ( LFACTA ) THEN C C Case 1: Matrix R is given in a factored form. C IF ( LFACTD ) THEN C C Use QR factorization of D. C Workspace: need min(P,M) + M, C prefer min(P,M) + M*NB. C JW = MIN( P, M ) + 1 CALL DGEQRF( P, M, R, LDR, DWORK, DWORK(JW), LDWORK-JW+1, $ IFAIL ) WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 ) IF ( P.LT.M ) $ CALL DLASET( 'Full', M-P, M, ZERO, ZERO, R(P+1,1), LDR ) C C Make positive the diagonal elements of the triangular C factor. Construct the strictly lower triangle, if requested. C DO 30 I = 1, M IF ( R(I,I).LT.ZERO ) $ CALL DSCAL( M-I+1, -ONE, R(I,I), LDR ) IF ( .NOT.LUPLOU ) $ CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) 30 CONTINUE C END IF C IF ( DISCR ) THEN JZ = 0 C IF ( LUPLOU ) THEN NUPLO = 'Lower' ELSE NUPLO = 'Upper' END IF C C Discrete-time case. Update the factorization for B'XB. C Try first the Cholesky factorization of X, saving the C diagonal of X, in order to recover it, if X is not positive C definite. In the later case, use spectral factorization. C Workspace: need N. C Define JW = 1 for Cholesky factorization of X, C JW = N+3 for spectral factorization of X. C CALL DCOPY( N, X, LDX+1, DWORK, 1 ) CALL DPOTRF( UPLO, N, X, LDX, IFAIL ) C IF ( IFAIL.EQ.0 ) THEN C C Use Cholesky factorization of X to compute chol(X)*B. C JW = 1 OUFACT(2) = 1 IF ( LUPLOU ) THEN TRL = NT ELSE TRL = TR END IF CALL DTRMM( 'Left', UPLO, TRL, 'Non unit', N, M, ONE, X, $ LDX, B, LDB ) ELSE C C Use spectral factorization of X, X = UVU'. C Workspace: need 4*N+1, C prefer N*(NB+2)+N+2. C JW = N + 3 OUFACT(2) = 2 CALL DCOPY( N, DWORK, 1, X, LDX+1 ) CALL DSYEV( 'Vectors', NUPLO, N, X, LDX, DWORK(3), $ DWORK(JW), LDWORK-JW+1, IFAIL ) IF ( IFAIL.GT.0 ) THEN INFO = M + 2 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 ) TEMP = ABS( DWORK(N+2) )*EPS*DBLE( N ) C C Check out the positive (semi-)definiteness of X. C First, count the negligible eigenvalues. C 40 CONTINUE IF ( ABS( DWORK(JZ+3) ).LE.TEMP ) THEN JZ = JZ + 1 IF ( JZ.LT.N ) GO TO 40 END IF C IF ( LFACTD .AND. N-JZ+P.LT.M ) THEN C C The coefficient matrix is (numerically) singular. C OUFACT(1) = 1 DWORK(2) = ZERO INFO = M + 1 RETURN END IF C IF ( DWORK(JZ+3).LT.ZERO ) THEN C C X is not positive (semi-)definite. Updating fails. C INFO = M + 3 RETURN ELSE C C Compute sqrt(V)U'B. C Workspace: need 2*N+2; C prefer N*M+N+2. C WRKOPT = MAX( WRKOPT, N*M + JW - 1 ) MS = MAX( ( LDWORK - JW + 1 )/N, 1 ) C DO 50 I = 1, M, MS NR = MIN( MS, M-I+1 ) CALL DLACPY( 'All', N, NR, B(1,I), LDB, DWORK(JW), $ N ) CALL DGEMM( TR, NT, N-JZ, NR, N, ONE, X(1,JZ+1), $ LDX, DWORK(JW), N, ZERO, B(JZ+1,I), $ LDB ) 50 CONTINUE C DO 60 I = JZ + 1, N CALL DSCAL( M, SQRT( DWORK(I+2) ), B(I,1), LDB ) 60 CONTINUE C END IF C END IF C C Update the triangular factorization. C IF ( .NOT.LUPLOU ) C C Transpose the lower triangle for using MB04KD. C $ CALL MA02ED( UPLO, M, R, LDR ) C C Workspace: need JW+2*M-1. C CALL MB04KD( 'Full', M, 0, N-JZ, R, LDR, B(JZ+1,1), LDB, $ DUMMY, N, DUMMY, M, DWORK(JW), DWORK(JW+M) ) C C Make positive the diagonal elements of the triangular C factor. C DO 70 I = 1, M IF ( R(I,I).LT.ZERO ) $ CALL DSCAL( M-I+1, -ONE, R(I,I), LDR ) 70 CONTINUE C IF ( .NOT.LUPLOU ) C C Construct the lower triangle. C $ CALL MA02ED( NUPLO, M, R, LDR ) C ELSE JW = 1 END IF C C Compute the condition number of the coefficient matrix. C IF ( .NOT.LFACTU ) THEN C C Workspace: need JW+3*M-1. C CALL DTRCON( '1-norm', UPLO, 'Non unit', M, R, LDR, RCOND, $ DWORK(JW), IWORK, IFAIL ) OUFACT(1) = 1 ELSE C C Workspace: need 2*M. C CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, $ IWORK, IFAIL ) OUFACT(1) = 2 END IF C ELSE C C Case 2: Matrix R is given in an unfactored form. C C Save the given triangle of R or R + B'XB in the other C strict triangle and the diagonal in the workspace, and try C Cholesky factorization. C Workspace: need M. C CALL DCOPY( M, R, LDR+1, DWORK, 1 ) CALL MA02ED( UPLO, M, R, LDR ) CALL DPOTRF( UPLO, M, R, LDR, IFAIL ) IF( IFAIL.EQ.0 ) THEN OUFACT(1) = 1 C C Compute the reciprocal of the condition number of R. C Workspace: need 3*M. C CALL DPOCON( UPLO, M, R, LDR, RNORMP, RCOND, DWORK, IWORK, $ IFAIL ) ELSE OUFACT(1) = 2 C C Use UdU' or LdL' factorization, first restoring the saved C triangle. C CALL DCOPY( M, DWORK, 1, R, LDR+1 ) IF ( LUPLOU ) THEN NUPLO = 'Lower' ELSE NUPLO = 'Upper' END IF C CALL MA02ED( NUPLO, M, R, LDR ) C C Workspace: need 1, C prefer M*NB. C CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) IF( INFO.GT.0 ) $ RETURN WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Compute the reciprocal of the condition number of R. C Workspace: need 2*M. C CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORMP, RCOND, DWORK, $ IWORK, IFAIL ) END IF END IF C C Return if the matrix is singular to working precision. C DWORK(2) = RCOND IF( RCOND.LT.EPS ) THEN INFO = M + 1 RETURN END IF C IF ( OUFACT(1).EQ.1 ) THEN C C Solve the positive definite linear system. C CALL DPOTRS( UPLO, M, N, R, LDR, F, LDF, IFAIL ) ELSE C C Solve the indefinite linear system. C CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, F, LDF, IFAIL ) END IF C C Set the optimal workspace. C DWORK(1) = WRKOPT C RETURN C *** Last line of SB02ND *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04WP.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04WP.f0000644000175000017500000001606515012430707017412 0ustar00lilgelilge00000000000000 SUBROUTINE MB04WP( N, ILO, U1, LDU1, U2, LDU2, CS, TAU, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To generate an orthogonal symplectic matrix U, which is defined as C a product of symplectic reflectors and Givens rotations C C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). C C as returned by MB04PU. The matrix U is returned in terms of its C first N rows C C [ U1 U2 ] C U = [ ]. C [ -U2 U1 ] C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices U1 and U2. N >= 0. C C ILO (input) INTEGER C ILO must have the same value as in the previous call of C MB04PU. U is equal to the unit matrix except in the C submatrix C U([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]). C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. C C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) C On entry, the leading N-by-N part of this array must C contain in its i-th column the vector which defines the C elementary reflector F(i). C On exit, the leading N-by-N part of this array contains C the matrix U1. C C LDU1 INTEGER C The leading dimension of the array U1. LDU1 >= MAX(1,N). C C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) C On entry, the leading N-by-N part of this array must C contain in its i-th column the vector which defines the C elementary reflector H(i) and, on the subdiagonal, the C scalar factor of H(i). C On exit, the leading N-by-N part of this array contains C the matrix U2. C C LDU2 INTEGER C The leading dimension of the array U2. LDU2 >= MAX(1,N). C C CS (input) DOUBLE PRECISION array, dimension (2N-2) C On entry, the first 2N-2 elements of this array must C contain the cosines and sines of the symplectic Givens C rotations G(i). C C TAU (input) DOUBLE PRECISION array, dimension (N-1) C On entry, the first N-1 elements of this array must C contain the scalar factors of the elementary reflectors C F(i). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -10, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,2*(N-ILO)). C For optimum performance LDWORK should be larger. (See C SLICOT Library routine MB04WD). 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 NUMERICAL ASPECTS C C The algorithm requires O(N**3) floating point operations and is C strongly backward stable. C C REFERENCES C C [1] C. F. VAN LOAN: C A symplectic method for approximating all the eigenvalues of C a Hamiltonian matrix. C Linear Algebra and its Applications, 61, pp. 233-251, 1984. C C [2] D. KRESSNER: C Block algorithms for orthogonal symplectic factorizations. C BIT, 43 (4), pp. 775-790, 2003. C C CONTRIBUTORS C C D. Kressner (Technical Univ. Berlin, Germany) and C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. C C REVISIONS C C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DOSGPV). C V. Sima, Aug. 2011. C C KEYWORDS C C Elementary matrix operations, orthogonal symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. Scalar Arguments .. INTEGER ILO, INFO, LDU1, LDU2, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION CS(*), DWORK(*), U1(LDU1,*), U2(LDU2,*), TAU(*) C .. Local Scalars .. LOGICAL LQUERY INTEGER I, IERR, J, MINWRK, NH, WRKOPT C .. External Subroutines .. EXTERNAL DLASET, MB04WD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 NH = N - ILO IF ( N.LT.0 ) THEN INFO = -1 ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF ( LDU1.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF ( LDU2.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE LQUERY = LDWORK.EQ.-1 MINWRK = MAX( 1, 2*NH ) IF ( LQUERY ) THEN IF ( N.EQ.0 ) THEN WRKOPT = ONE ELSE CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH, $ U1, LDU1, U2, LDU2, CS, TAU, DWORK, -1, $ IERR ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) END IF DWORK(1) = DBLE( WRKOPT ) RETURN ELSE IF ( LDWORK.LT.MINWRK ) THEN DWORK(1) = DBLE( MINWRK ) INFO = -10 END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04WP', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Shift the vectors which define the elementary reflectors one C column to the right, and set the first ilo rows and columns to C those of the unit matrix. C DO 30 J = N, ILO + 1, -1 DO 10 I = 1, J-1 U1(I,J) = ZERO 10 CONTINUE DO 20 I = J+1, N U1(I,J) = U1(I,J-1) 20 CONTINUE 30 CONTINUE CALL DLASET( 'All', N, ILO, ZERO, ONE, U1, LDU1 ) DO 60 J = N, ILO + 1, -1 DO 40 I = 1, J-1 U2(I,J) = ZERO 40 CONTINUE DO 50 I = J, N U2(I,J) = U2(I,J-1) 50 CONTINUE 60 CONTINUE CALL DLASET( 'All', N, ILO, ZERO, ZERO, U2, LDU2 ) IF ( NH.GT.0 ) THEN CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH, $ U1(ILO+1,ILO+1), LDU1, U2(ILO+1,ILO+1), LDU2, $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) ELSE DWORK(1) = ONE END IF RETURN C *** Last line of MB04WP *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01KZ.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01KZ.f0000644000175000017500000002630115012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE TG01KZ( JOBE, COMPC, COMPQ, COMPZ, N, A, LDA, E, LDE, $ B, C, INCC, Q, LDQ, Z, LDZ, INFO ) C C PURPOSE C C To compute for a single-input single-output descriptor system, C (A, E, B, C), with E upper triangular, a transformed system, C (Q'*A*Z, Q'*E*Z, Q'*B, C*Z), via an orthogonal equivalence C transformation, so that Q'*B has only the first element nonzero C and Q'*E*Z remains upper triangular. C C ARGUMENTS C C Mode Parameters C C JOBE CHARACTER*1 C Specifies whether E is an upper triangular or an identity C matrix, as follows: C = 'U': The matrix E is an upper triangular matrix; C = 'I': The matrix E is assumed identity and is not given. C C COMPC CHARACTER*1 C Indicates whether the user wishes to transform the system C output matrix C, as follows: C = 'C': Transform the system output matrix C; C = 'N': Do not transform the system output matrix C. C C COMPQ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Q the orthogonal row transformations, as follows: C = 'N': Do not form Q; C = 'I': Q is initialized to the unit matrix and the C orthogonal transformation matrix Q is returned; C = 'U': The given matrix Q is updated by the orthogonal C transformations used. C C COMPZ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal column transformations, as C follows: C = 'N': Do not form Z; C = 'I': Z is initialized to the unit matrix and the C orthogonal transformation matrix Z is returned; C = 'U': The given matrix Z is updated by the orthogonal C transformations used. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the descriptor state vector; also the C order of square matrices A and E, the number of rows of C matrix B, and the number of columns of matrix C. N >= 0. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the original state matrix A. C On exit, the leading N-by-N part of this array contains C the transformed state matrix Q'*A*Z. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C E (input/output) COMPLEX*16 array, dimension (LDE,*) C On entry, if JOBE = 'U', the leading N-by-N upper C triangular part of this array must contain the upper C triangular part of the descriptor matrix E. The lower C triangular part under the first subdiagonal is not C referenced. C On exit, if JOBE = 'U', the leading N-by-N upper C triangular part of this array contains the upper C triangular part of the transformed descriptor matrix, C Q'*E*Z. C If JOBE = 'I', this array is not referenced. C C LDE INTEGER C The leading dimension of the array E. C LDE >= MAX(1,N), if JOBE = 'U'; C LDE >= 1, if JOBE = 'I'. C C B (input/output) COMPLEX*16 array, dimension (N) C On entry, the leading N part of this array must contain C the original input matrix B. C On exit, the leading N part of this array contains the C transformed input matrix Q'*B with all elements but the C first set to zero. C C C (input/output) COMPLEX*16 array, dimension C ((N-1)*INCC+1) C On entry, if COMPC = 'C', the elements 1, INCC+1, ..., C (N-1)*INCC+1 of this array must contain the original C output vector C. C On exit, if COMPC = 'C', the elements 1, INCC+1, ..., C (N-1)*INCC+1 of this array contain the transformed output C vector C*Z. C If COMPC = 'N', this array is not referenced. C C INCC INTEGER C If COMPC = 'C', the increment between successive values C of C. INCC > 0. C If COMPC = 'N', INCC is not used. C C Q (input/output) COMPLEX*16 array, dimension (LDQ,*) C On entry, if COMPQ = 'U', the leading N-by-N part of this C array must contain the given matrix Q1. Otherwise, this C array need not be set on input. C On exit, if COMPU <> 'N', the leading N-by-N part of this C array contains the orthogonal transformation matrix used C (Q1*Q if COMPQ = 'U'). C If COMPQ = 'N', this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= max(1,N), if COMPQ <> 'N'. C C Z (input/output) COMPLEX*16 array, dimension (LDZ,*) C On entry, if COMPZ = 'U', the leading N-by-N part of this C array must contain the given matrix Z1. Otherwise, this C array need not be set on input. C On exit, if COMPZ <> 'N', the leading N-by-N part of this C array contains the orthogonal transformation matrix used C (Z1*Z if COMPZ = 'U'). C If COMPZ = 'N', this array is not referenced. C C LDZ INTEGER C The leading dimension of the array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= max(1,N), if COMPZ <> '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 METHOD C C Givens rotations are used to annihilate the last N-1 elements of B C in reverse order, but preserve the form of E. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2020. C C REVISIONS C C V. Sima, April 2021, May 2021. C C KEYWORDS C C Controllability, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. CHARACTER COMPC, COMPQ, COMPZ, JOBE INTEGER INCC, INFO, LDA, LDE, LDQ, LDZ, N C .. Array Arguments .. COMPLEX*16 A(LDA,*), B(*), C(*), E(LDE,*), Q(LDQ,*), $ Z(LDZ,*) C .. Local Scalars .. LOGICAL LINIQ, LINIZ, LUPDQ, LUPDZ, UNITE, WITHC, WITHQ, $ WITHZ INTEGER IC, K DOUBLE PRECISION CS COMPLEX*16 SN, TEMP C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA, ZLACPY, ZLARTG, ZLASET, ZROT C .. Intrinsic Functions .. INTRINSIC DCONJG, MAX C .. Executable Statements .. C UNITE = LSAME( JOBE, 'I' ) WITHC = LSAME( COMPC, 'C' ) LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LINIZ = LSAME( COMPZ, 'I' ) LUPDZ = LSAME( COMPZ, 'U' ) WITHQ = LINIQ .OR. LUPDQ WITHZ = LINIZ .OR. LUPDZ INFO = 0 C C Test the input scalar arguments. C IF ( .NOT.UNITE .AND. .NOT.LSAME( JOBE, 'U' ) ) THEN INFO = -1 ELSE IF ( .NOT.WITHC .AND. .NOT.LSAME( COMPC, 'N' ) ) THEN INFO = -2 ELSE IF ( .NOT.WITHQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN INFO = -3 ELSE IF ( .NOT.WITHZ .AND. .NOT.LSAME( COMPZ, 'N' ) ) THEN INFO = -4 ELSE IF ( N.LT.0 ) THEN INFO = -5 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF ( LDE.LT.1 .OR. ( .NOT.UNITE .AND. LDE.LT.MAX( 1, N ) ) ) $ THEN INFO = -9 ELSE IF ( WITHC .AND. INCC.LE.0 ) THEN INFO = -12 ELSE IF ( LDQ.LT.1 .OR. ( WITHQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -14 ELSE IF ( LDZ.LT.1 .OR. ( WITHZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN INFO = -16 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01KZ', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C IF ( LINIQ .OR. ( N.EQ.1 .AND. .NOT.LUPDQ ) ) $ CALL ZLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) IF ( LINIZ .OR. ( N.EQ.1 .AND. .NOT.LUPDZ ) ) $ CALL ZLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) IF( N.EQ.1 ) $ RETURN C IF ( WITHC ) $ IC = ( N - 1 )*INCC + 1 C DO 10 K = N, 2, -1 IF ( B(K).NE.ZERO ) THEN CALL ZLARTG( B(K-1), B(K), CS, SN, TEMP ) B(K-1) = TEMP B(K) = ZERO CALL ZROT( N, A(K-1,1), LDA, A(K,1), LDA, CS, SN ) IF ( WITHQ ) $ CALL ZROT( N, Q(1,K-1), 1, Q(1,K), 1, CS, DCONJG( SN ) ) IF ( UNITE ) THEN CALL ZROT( N, A(1,K-1), 1, A(1,K), 1, CS, DCONJG( SN ) ) IF ( WITHC ) THEN TEMP = C(IC)*DCONJG( SN ) + C(IC-INCC)*CS C(IC) = C(IC)*CS - C(IC-INCC)*SN IC = IC - INCC C(IC) = TEMP END IF IF ( WITHZ ) THEN IF ( WITHQ .AND. ( LINIQ.EQV.LINIZ .OR. $ LUPDQ.EQV.LUPDZ ) ) THEN CALL ZLACPY( 'Full', N, 2, Q(1,K-1), LDQ, Z(1,K-1), $ LDZ ) ELSE CALL ZROT( N, Z(1,K-1), 1, Z(1,K), 1, CS, $ DCONJG( SN ) ) END IF END IF ELSE E(K,K-1) = DCONJG( SN )*E(K-1,K-1) E(K-1,K-1) = CS*E(K-1,K-1) CALL ZROT( N-K+1, E(K-1,K), LDE, E(K,K), LDE, CS, SN ) IF ( E(K,K-1).NE.ZERO ) THEN CALL ZLARTG( E(K,K), E(K,K-1), CS, SN, TEMP ) E(K,K) = TEMP E(K,K-1) = ZERO TEMP = E(K-1,K)*DCONJG( SN ) + E(K-1,K-1)*CS E(K-1,K) = E(K-1,K)*CS - E(K-1,K-1)*SN E(K-1,K-1) = TEMP CALL ZROT( K-2, E(1,K-1), 1, E(1,K), 1, CS, $ DCONJG( SN ) ) CALL ZROT( N, A(1,K-1), 1, A(1,K), 1, CS, $ DCONJG( SN ) ) IF ( WITHC ) THEN TEMP = C(IC)*DCONJG( SN ) + C(IC-INCC)*CS C(IC) = C(IC)*CS - C(IC-INCC)*SN IC = IC - INCC C(IC) = TEMP END IF IF ( WITHZ ) $ CALL ZROT( N, Z(1,K-1), 1, Z(1,K), 1, CS, $ DCONJG( SN ) ) END IF END IF END IF 10 CONTINUE C RETURN C *** Last line of TG01KZ *** END control-4.1.2/src/slicot/src/PaxHeaders/TC05AD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TC05AD.f0000644000175000017500000003135615012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE TC05AD( LERI, M, P, SVAL, INDEX, PCOEFF, LDPCO1, $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, RCOND, CFREQR, $ LDCFRE, IWORK, DWORK, ZWORK, INFO ) C C PURPOSE C C To evaluate the transfer matrix T(s) of a left polynomial matrix C representation [T(s) = inv(P(s))*Q(s)] or a right polynomial C matrix representation [T(s) = Q(s)*inv(P(s))] at any specified C complex frequency s = SVAL. C C This routine will calculate the standard frequency response C matrix at frequency omega if SVAL is supplied as (0.0,omega). C C ARGUMENTS C C Mode Parameters C C LERI CHARACTER*1 C Indicates whether a left polynomial matrix representation C or a right polynomial matrix representation is to be used C to evaluate the transfer matrix as follows: C = 'L': A left matrix fraction is input; C = 'R': A right matrix fraction is input. C C Input/Output Parameters 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 SVAL (input) COMPLEX*16 C The frequency at which the transfer matrix or the C frequency respose matrix is to be evaluated. C For a standard frequency response set the real part C of SVAL to zero. C C INDEX (input) INTEGER array, dimension (MAX(M,P)) C If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the C maximum degree of the polynomials in the I-th row of the C denominator matrix P(s) of the given left polynomial C matrix representation. C If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the C maximum degree of the polynomials in the I-th column of C the denominator matrix P(s) of the given right polynomial C matrix representation. C C PCOEFF (input) DOUBLE PRECISION array, dimension C (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1. C If LERI = 'L' then porm = P, otherwise porm = M. C The leading porm-by-porm-by-kpcoef part of this array must C contain the coefficients of the denominator matrix P(s). C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if C LERI = 'L' then iorj = I, otherwise iorj = J. C Thus for LERI = 'L', P(s) = C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). C If LERI = 'R', PCOEFF is modified by the routine but C restored on exit. C C LDPCO1 INTEGER C The leading dimension of array PCOEFF. C LDPCO1 >= MAX(1,P) if LERI = 'L', C LDPCO1 >= MAX(1,M) if LERI = 'R'. C C LDPCO2 INTEGER C The second dimension of array PCOEFF. C LDPCO2 >= MAX(1,P) if LERI = 'L', C LDPCO2 >= MAX(1,M) if LERI = 'R'. C C QCOEFF (input) DOUBLE PRECISION array, dimension C (LDQCO1,LDQCO2,kpcoef) C If LERI = 'L' then porp = M, otherwise porp = P. C The leading porm-by-porp-by-kpcoef part of this array must C contain the coefficients of the numerator matrix Q(s). C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). C If LERI = 'R', QCOEFF is modified by the routine but C restored on exit. C C LDQCO1 INTEGER C The leading dimension of array QCOEFF. C LDQCO1 >= MAX(1,P) if LERI = 'L', C LDQCO1 >= MAX(1,M,P) if LERI = 'R'. C C LDQCO2 INTEGER C The second dimension of array QCOEFF. C LDQCO2 >= MAX(1,M) if LERI = 'L', C LDQCO2 >= MAX(1,M,P) if LERI = 'R'. C C RCOND (output) DOUBLE PRECISION C The estimated reciprocal of the condition number of the C denominator matrix P(SVAL). C If RCOND is nearly zero, SVAL is approximately a system C pole. C C CFREQR (output) COMPLEX*16 array, dimension (LDCFRE,MAX(M,P)) C The leading porm-by-porp part of this array contains the C frequency response matrix T(SVAL). C C LDCFRE INTEGER C The leading dimension of array CFREQR. C LDCFRE >= MAX(1,P) if LERI = 'L', C LDCFRE >= MAX(1,M,P) if LERI = 'R'. C C Workspace C C IWORK INTEGER array, dimension (liwork) C where liwork = P, if LERI = 'L', C liwork = M, if LERI = 'R'. C C DWORK DOUBLE PRECISION array, dimension (ldwork) C where ldwork = 2*P, if LERI = 'L', C ldwork = 2*M, if LERI = 'R'. C C ZWORK COMPLEX*16 array, dimension (lzwork), C where lzwork = P*(P+2), if LERI = 'L', C lzwork = M*(M+2), if LERI = '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 = 1: if P(SVAL) is exactly or nearly singular; C no frequency response is calculated. C C METHOD C C The method for a left matrix fraction will be described here; C right matrix fractions are dealt with by obtaining the dual left C fraction and calculating its frequency response (see SLICOT C Library routine TC01OD). The first step is to calculate the C complex value P(SVAL) of the denominator matrix P(s) at the C desired frequency SVAL. If P(SVAL) is approximately singular, C SVAL is approximately a pole of this system and so the frequency C response matrix T(SVAL) is not calculated; in this case, the C routine returns with the Error Indicator (INFO) set to 1. C Otherwise, the complex value Q(SVAL) of the numerator matrix Q(s) C at frequency SVAL is calculated in a similar way to P(SVAL), and C the desired response matrix T(SVAL) = inv(P(SVAL))*Q(SVAL) is C found by solving the corresponding system of complex linear C equations. C C REFERENCES C C None C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TC01AD by T.W.C.Williams, Kingston C Polytechnic, United Kingdom, March 1982. C C REVISIONS C C February 22, 1998 (changed the name of TC01MD). C C KEYWORDS C C Coprime matrix fraction, elementary polynomial operations, C polynomial matrix, state-space representation, transfer matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER LERI INTEGER INFO, LDCFRE, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M, $ P DOUBLE PRECISION RCOND COMPLEX*16 SVAL C .. Array Arguments .. INTEGER INDEX(*), IWORK(*) DOUBLE PRECISION DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), $ QCOEFF(LDQCO1,LDQCO2,*) COMPLEX*16 CFREQR(LDCFRE,*), ZWORK(*) C .. Local Scalars .. LOGICAL LLERI INTEGER I, IZWORK, IJ, INFO1, J, K, KPCOEF, LDZWOR, $ MAXIND, MINMP, MPLIM, MWORK, PWORK DOUBLE PRECISION CNORM C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANGE EXTERNAL DLAMCH, LSAME, ZLANGE C .. External Subroutines .. EXTERNAL TC01OD, XERBLA, ZCOPY, ZGECON, ZGETRF, ZGETRS, $ ZSWAP C .. Intrinsic Functions .. INTRINSIC DCMPLX, MAX, MIN C .. Executable Statements .. C INFO = 0 LLERI = LSAME( LERI, 'L' ) MPLIM = MAX( M, P ) C C Test the input scalar arguments. C IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( P.LT.0 ) THEN INFO = -3 ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN INFO = -7 ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN INFO = -8 ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR. $ ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, M, P ) ) ) THEN INFO = -10 ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR. $ ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MPLIM ) ) ) THEN INFO = -11 ELSE IF( ( LLERI .AND. LDCFRE.LT.MAX( 1, P ) ) .OR. $ ( .NOT.LLERI .AND. LDCFRE.LT.MAX( 1, MPLIM ) ) ) THEN INFO = -14 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TC05AD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( M.EQ.0 .OR. P.EQ.0 ) THEN RCOND = ONE RETURN END IF C IF ( LLERI ) THEN C C Initialization for left matrix fraction. C PWORK = P MWORK = M ELSE C C Initialization for right matrix fraction: obtain dual system. C PWORK = M MWORK = P IF ( MPLIM.GT.1 ) $ CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2, $ QCOEFF, LDQCO1, LDQCO2, INFO ) END IF C LDZWOR = PWORK IZWORK = LDZWOR*LDZWOR + 1 MAXIND = 0 C DO 10 I = 1, PWORK IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I) 10 CONTINUE C KPCOEF = MAXIND + 1 C C Calculate the complex denominator matrix P(SVAL), row by row. C DO 50 I = 1, PWORK IJ = I C DO 20 J = 1, PWORK ZWORK(IJ) = DCMPLX( PCOEFF(I,J,1), ZERO ) IJ = IJ + PWORK 20 CONTINUE C C Possibly non-constant row: finish evaluating it. C DO 40 K = 2, INDEX(I) + 1 C IJ = I C DO 30 J = 1, PWORK ZWORK(IJ) = ( SVAL*ZWORK(IJ) ) + $ DCMPLX( PCOEFF(I,J,K), ZERO ) IJ = IJ + PWORK 30 CONTINUE C 40 CONTINUE C 50 CONTINUE C C Check if this P(SVAL) is singular: if so, don't compute T(SVAL). C Note that DWORK is not actually referenced in ZLANGE routine. C CNORM = ZLANGE( '1-norm', PWORK, PWORK, ZWORK, LDZWOR, DWORK ) C CALL ZGETRF( PWORK, PWORK, ZWORK, LDZWOR, IWORK, INFO ) C IF ( INFO.GT.0 ) THEN C C Singular matrix. Set INFO and RCOND for error return. C INFO = 1 RCOND = ZERO ELSE C C Estimate the reciprocal condition of P(SVAL). C Workspace: ZWORK: PWORK*PWORK + 2*PWORK, DWORK: 2*PWORK. C CALL ZGECON( '1-norm', PWORK, ZWORK, LDZWOR, CNORM, RCOND, $ ZWORK(IZWORK), DWORK, INFO ) C IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN C C Nearly singular matrix. Set INFO for error return. C INFO = 1 ELSE C C Calculate the complex numerator matrix Q(SVAL), row by row. C DO 90 I = 1, PWORK C DO 60 J = 1, MWORK CFREQR(I,J) = DCMPLX( QCOEFF(I,J,1), ZERO ) 60 CONTINUE C C Possibly non-constant row: finish evaluating it. C DO 80 K = 2, INDEX(I) + 1 C DO 70 J = 1, MWORK CFREQR(I,J) = ( SVAL*CFREQR(I,J) ) + $ DCMPLX( QCOEFF(I,J,K), ZERO ) 70 CONTINUE C 80 CONTINUE C 90 CONTINUE C C Now calculate frequency response T(SVAL). C CALL ZGETRS( 'No transpose', PWORK, MWORK, ZWORK, LDZWOR, $ IWORK, CFREQR, LDCFRE, INFO ) END IF END IF C C For right matrix fraction, return to original (dual of the dual) C system. C IF ( ( .NOT.LLERI ) .AND. ( MPLIM.NE.1 ) ) THEN CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO1 ) C IF ( INFO.EQ.0 ) THEN C C Also, transpose T(SVAL) here if this was successfully C calculated. C MINMP = MIN( M, P ) C DO 100 J = 1, MPLIM IF ( J.LT.MINMP ) THEN CALL ZSWAP( MINMP-J, CFREQR(J+1,J), 1, CFREQR(J,J+1), $ LDCFRE ) ELSE IF ( J.GT.P ) THEN CALL ZCOPY( P, CFREQR(1,J), 1, CFREQR(J,1), LDCFRE ) ELSE IF ( J.GT.M ) THEN CALL ZCOPY( M, CFREQR(J,1), LDCFRE, CFREQR(1,J), 1 ) END IF 100 CONTINUE C END IF END IF C RETURN C *** Last line of TC05AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03TS.f0000644000000000000000000000013215012430707016205 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03TS.f0000644000175000017500000006373615012430707017420 0ustar00lilgelilge00000000000000 SUBROUTINE MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, LDU1, U2, $ LDU2, J1, N1, N2, DWORK, INFO ) C C PURPOSE C C To swap diagonal blocks A11 and A22 of order 1 or 2 in the upper C quasi-triangular matrix A contained in a skew-Hamiltonian matrix C C [ A G ] T C X = [ T ], G = -G, C [ 0 A ] C C or in a Hamiltonian matrix C C [ A G ] T C X = [ T ], G = G. C [ 0 -A ] C C This routine is a modified version of the LAPACK subroutine C DLAEX2. C C The matrix A must be in Schur canonical form (as returned by the C LAPACK routine DHSEQR), that is, block upper triangular with C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has C its diagonal elements equal and its off-diagonal elements of C opposite sign. C C ARGUMENTS C C Mode Parameters C C ISHAM LOGIGAL C Specifies the type of X: C = .TRUE.: X is a Hamiltonian matrix; C = .FALSE.: X is a skew-Hamiltonian matrix. C C WANTU LOGIGAL C = .TRUE.: update the matrices U1 and U2 containing the C Schur vectors; C = .FALSE.: do not update U1 and U2. 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 part of this array must C contain the upper quasi-triangular matrix A, in Schur C canonical form. C On exit, the leading N-by-N part of this array contains C the reordered matrix A, again in Schur canonical form. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) C On entry, the leading N-by-N part of this array must C contain the upper triangular part of the symmetric C matrix G, if ISHAM = .TRUE., or the strictly upper C triangular part of the skew-symmetric matrix G, otherwise. C The rest of this array is not referenced. C On exit, the leading N-by-N part of this array contains C the upper or strictly upper triangular part of the C symmetric or skew-symmetric matrix G, respectively, C updated by the orthogonal transformation which reorders A. C C LDG INTEGER C The leading dimension of the array G. LDG >= MAX(1,N). C C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) C On entry, if WANTU = .TRUE., the leading N-by-N part of C this array must contain the matrix U1. C On exit, if WANTU = .TRUE., the leading N-by-N part of C this array contains U1, postmultiplied by the orthogonal C transformation which reorders A. See the description in C the SLICOT subroutine MB03TD for further details. C If WANTU = .FALSE., this array is not referenced. C C LDU1 INTEGER C The leading dimension of the array U1. C LDU1 >= MAX(1,N), if WANTU = .TRUE.; C LDU1 >= 1, otherwise. C C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) C On entry, if WANTU = .TRUE., the leading N-by-N part of C this array must contain the matrix U2. C On exit, if WANTU = .TRUE., the leading N-by-N part of C this array contains U2, postmultiplied by the orthogonal C transformation which reorders A. C If WANTU = .FALSE., this array is not referenced. C C LDU2 INTEGER C The leading dimension of the array U2. C LDU2 >= MAX(1,N), if WANTU = .TRUE.; C LDU2 >= 1, otherwise. C C J1 (input) INTEGER C The index of the first row of the first block A11. C If J1+N1 < N, then A11 is swapped with the block starting C at (J1+N1+1)-th diagonal element. C If J1+N1 > N, then A11 is the last block in A and swapped C with -A11', if ISHAM = .TRUE., C or A11', if ISHAM = .FALSE.. C C N1 (input) INTEGER C The order of the first block A11. N1 = 0, 1 or 2. C C N2 (input) INTEGER C The order of the second block A22. N2 = 0, 1 or 2. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (N) C C Error Indicator C C INFO INTEGER C = 0: successful exit; C = 1: the transformed matrix A would be too far from Schur C form; the blocks are not swapped and A, G, U1 and C U2 are unchanged. C C REFERENCES C C [1] Bai, Z., and Demmel, J.W. C On swapping diagonal blocks in real Schur form. C Linear Algebra Appl., 186, pp. 73-95, 1993. C C [2] Benner, P., Kressner, D., and Mehrmann, V. C Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory, C Algorithms and Applications. Techn. Report, TU Berlin, 2003. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAEX2). C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO, THIRTY, FORTY PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, $ TWO = 2.0D+0, THIRTY = 3.0D+1, $ FORTY = 4.0D+1 ) INTEGER LDD, LDX PARAMETER ( LDD = 4, LDX = 2 ) C .. Scalar Arguments .. LOGICAL ISHAM, WANTU INTEGER INFO, J1, LDA, LDG, LDU1, LDU2, N, N1, N2 C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*), $ U2(LDU2,*) C .. Local Scalars .. LOGICAL LBLK INTEGER IERR, J2, J3, J4, K, ND DOUBLE PRECISION A11, A22, A33, CS, DNORM, EPS, SCALE, SMLNUM, $ SN, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, $ WR1, WR2, XNORM C .. Local Arrays .. DOUBLE PRECISION D(LDD,4), V(3), V1(3), V2(3), X(LDX,2) C .. External Functions .. DOUBLE PRECISION DDOT, DLAMCH, DLANGE EXTERNAL DDOT, DLAMCH, DLANGE C .. External Subroutines .. EXTERNAL DAXPY, DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, $ DLASET, DLASY2, DROT, DSCAL, DSWAP, DSYMV, $ DSYR2, MB01MD, MB01ND C .. Intrinsic Functions .. INTRINSIC ABS, MAX C C .. Executable Statements .. C INFO = 0 C C Quick return if possible. C IF ( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) $ RETURN LBLK = ( J1+N1.GT.N ) C J2 = J1 + 1 J3 = J1 + 2 J4 = J1 + 3 C IF ( LBLK .AND. N1.EQ.1 ) THEN C IF ( ISHAM ) THEN A11 = A(N,N) CALL DLARTG( G(N,N), -TWO*A11, CS, SN, TEMP ) CALL DROT( N-1, A(1,N), 1, G(1,N), 1, CS, SN ) A(N,N) = -A11 IF ( WANTU ) $ CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN ) ELSE CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 ) CALL DSCAL( N-1, -ONE, A(1,N), 1 ) IF ( WANTU ) THEN CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 ) CALL DSCAL( N, -ONE, U1(1,N), 1 ) END IF END IF C ELSE IF ( LBLK .AND. N1.EQ.2 ) THEN C IF ( ISHAM ) THEN C C Reorder Hamiltonian matrix: C C [ A11 G11 ] C [ T ]. C [ 0 -A11 ] C ND = 4 CALL DLACPY( 'Full', 2, 2, A(N-1,N-1), LDA, D, LDD ) CALL DLASET( 'All', 2, 2, ZERO, ZERO, D(3,1), LDD ) CALL DLACPY( 'Upper', 2, 2, G(N-1,N-1), LDG, D(1,3), LDD ) D(2,3) = D(1,4) D(3,3) = -D(1,1) D(4,3) = -D(1,2) D(3,4) = -D(2,1) D(4,4) = -D(2,2) DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK ) C C Compute machine-dependent threshold for test for accepting C swap. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS THRESH = MAX( FORTY*EPS*DNORM, SMLNUM ) C C Solve A11*X + X*A11' = scale*G11 for X. C CALL DLASY2( .FALSE., .FALSE., -1, 2, 2, D, LDD, D(3,3), $ LDD, D(1,3), LDD, SCALE, X, LDX, XNORM, IERR ) C C Compute symplectic QR decomposition of C C ( -X11 -X12 ) C ( -X21 -X22 ). C ( scale 0 ) C ( 0 scale ) C TEMP = -X(1,1) CALL DLARTG( TEMP, SCALE, V1(1), V2(1), X(1,1) ) CALL DLARTG( X(1,1), -X(2,1), V1(2), V2(2), TEMP ) X(1,2) = -X(1,2) X(2,2) = -X(2,2) X(1,1) = ZERO X(2,1) = SCALE CALL DROT( 1, X(1,2), 1, X(1,1), 1, V1(1), V2(1) ) CALL DROT( 1, X(1,2), 1, X(2,2), 1, V1(2), V2(2) ) CALL DROT( 1, X(1,1), 1, X(2,1), 1, V1(2), V2(2) ) CALL DLARTG( X(2,2), X(2,1), V1(3), V2(3), TEMP ) C C Perform swap provisionally on D. C CALL DROT( 4, D(1,1), LDD, D(3,1), LDD, V1(1), V2(1) ) CALL DROT( 4, D(1,1), LDD, D(2,1), LDD, V1(2), V2(2) ) CALL DROT( 4, D(3,1), LDD, D(4,1), LDD, V1(2), V2(2) ) CALL DROT( 4, D(2,1), LDD, D(4,1), LDD, V1(3), V2(3) ) CALL DROT( 4, D(1,1), 1, D(1,3), 1, V1(1), V2(1) ) CALL DROT( 4, D(1,1), 1, D(1,2), 1, V1(2), V2(2) ) CALL DROT( 4, D(1,3), 1, D(1,4), 1, V1(2), V2(2) ) CALL DROT( 4, D(1,2), 1, D(1,4), 1, V1(3), V2(3) ) C C Test whether to reject swap. C IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ), $ ABS( D(4,2) ) ).GT.THRESH ) GO TO 50 C CALL DLACPY( 'All', 2, 2, D(1,1), LDD, A(N-1,N-1), LDA ) CALL DLACPY( 'Upper', 2, 2, D(1,3), LDD, G(N-1,N-1), LDG ) C IF ( N.GT.2 ) THEN CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, V1(1), V2(1) ) CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, V1(2), V2(2) ) CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, V1(2), V2(2) ) CALL DROT( N-2, A(1,N), 1, G(1,N), 1, V1(3), V2(3) ) END IF C IF ( WANTU ) THEN CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, V1(1), V2(1) ) CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, V1(2), V2(2) ) CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, V1(2), V2(2) ) CALL DROT( N, U1(1,N), 1, U2(1,N), 1, V1(3), V2(3) ) END IF C ELSE C IF ( ABS( A(N-1,N) ).GT.ABS( A(N,N-1) ) ) THEN TEMP = G(N-1,N) CALL DLARTG( TEMP, A(N-1,N), CS, SN, G(N-1,N) ) SN = -SN CALL DROT(N-2, A(1,N), 1, G(1,N), 1, CS, SN ) C A(N-1,N) = -SN*A(N,N-1) TEMP = -CS*A(N,N-1) A(N,N-1) = G(N-1,N) G(N-1,N) = TEMP IF ( WANTU ) $ CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN ) CALL DSWAP( N-2, A(1,N-1), 1, G(1,N-1), 1 ) CALL DSCAL( N-2, -ONE, A(1,N-1), 1 ) IF ( WANTU ) THEN CALL DSWAP( N, U1(1,N-1), 1, U2(1,N-1), 1 ) CALL DSCAL( N, -ONE, U1(1,N-1), 1 ) END IF ELSE TEMP = G(N-1,N) CALL DLARTG( TEMP, A(N,N-1), CS, SN, G(N-1,N) ) CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, CS, SN ) A(N,N-1) = -SN*A(N-1,N) A(N-1,N) = CS*A(N-1,N) IF ( WANTU ) $ CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, CS, SN ) CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 ) CALL DSCAL( N-1, -ONE, A(1,N), 1 ) IF ( WANTU ) THEN CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 ) CALL DSCAL( N, -ONE, U1(1,N), 1 ) END IF END IF END IF C C Standardize new 2-by-2 block. C CALL DLANV2( A(N-1,N-1), A(N-1,N), A(N,N-1), $ A(N,N), WR1, WI1, WR2, WI2, CS, SN ) CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, CS, SN ) IF ( ISHAM ) THEN TEMP = G(N-1,N) CALL DROT( N-1, G(1,N-1), 1, G(1,N), 1, CS, SN ) TAU = CS*TEMP + SN*G(N,N) G(N,N) = CS*G(N,N) - SN*TEMP G(N-1,N-1) = CS*G(N-1,N-1) + SN*TAU CALL DROT( 1, G(N-1,N), LDG, G(N,N), LDG, CS, SN ) ELSE CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, CS, SN ) END IF IF ( WANTU ) THEN CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, CS, SN ) CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, CS, SN ) END IF C ELSE IF ( N1.EQ.1 .AND. N2.EQ.1 ) THEN C C Swap two 1-by-1 blocks. C A11 = A(J1,J1) A22 = A(J2,J2) C C Determine the transformation to perform the interchange. C CALL DLARTG( A(J1,J2), A22-A11, CS, SN, TEMP ) C C Apply transformation to the matrix A. C IF ( J3.LE.N ) $ CALL DROT( N-J1-1, A(J1,J3), LDA, A(J2,J3), LDA, CS, SN ) CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN ) C A(J1,J1) = A22 A(J2,J2) = A11 C C Apply transformation to the matrix G. C IF ( ISHAM ) THEN TEMP = G(J1,J2) CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN ) TAU = CS*TEMP + SN*G(J2,J2) G(J2,J2) = CS*G(J2,J2) - SN*TEMP G(J1,J1) = CS*G(J1,J1) + SN*TAU CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN ) ELSE IF ( N.GT.J1+1 ) $ CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG, CS, $ SN ) CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN ) END IF IF ( WANTU ) THEN C C Accumulate transformation in the matrices U1 and U2. C CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN ) CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN ) END IF C ELSE C C Swapping involves at least one 2-by-2 block. C C Copy the diagonal block of order N1+N2 to the local array D C and compute its norm. C ND = N1 + N2 CALL DLACPY( 'Full', ND, ND, A(J1,J1), LDA, D, LDD ) DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK ) C C Compute machine-dependent threshold for test for accepting C swap. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS THRESH = MAX( THIRTY*EPS*DNORM, SMLNUM ) C C Solve A11*X - X*A22 = scale*A12 for X. C CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, $ D(N1+1,N1+1), LDD, D(1,N1+1), LDD, SCALE, X, LDX, $ XNORM, IERR ) C C Swap the adjacent diagonal blocks. C K = N1 + N1 + N2 - 3 GO TO ( 10, 20, 30 )K C 10 CONTINUE C C N1 = 1, N2 = 2: generate elementary reflector H so that: C C ( scale, X11, X12 ) H = ( 0, 0, * ). C V(1) = SCALE V(2) = X(1,1) V(3) = X(1,2) CALL DLARFG( 3, V(3), V, 1, TAU ) V(3) = ONE A11 = A(J1,J1) C C Perform swap provisionally on diagonal block in D. C CALL DLARFX( 'Left', 3, 3, V, TAU, D, LDD, DWORK ) CALL DLARFX( 'Right', 3, 3, V, TAU, D, LDD, DWORK ) C C Test whether to reject swap. C IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(3,3)-A11 ) ) $ .GT.THRESH ) GO TO 50 C C Accept swap: apply transformation to the entire matrix A. C CALL DLARFX( 'Left', 3, N-J1+1, V, TAU, A(J1,J1), LDA, DWORK ) CALL DLARFX( 'Right', J2, 3, V, TAU, A(1,J1), LDA, DWORK ) C A(J3,J1) = ZERO A(J3,J2) = ZERO A(J3,J3) = A11 C C Apply transformation to G. C IF ( ISHAM ) THEN CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, $ DWORK, 1 ) TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 ) CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 ) CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1, $ G(J1,J1), LDG ) IF ( N.GT.J1+2 ) $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, $ DWORK ) ELSE CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, $ DWORK, 1 ) CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1), $ LDG ) IF ( N.GT.J1+2 ) $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, $ DWORK ) END IF C IF ( WANTU ) THEN C C Accumulate transformation in the matrices U1 and U2. C CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK ) CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK ) END IF GO TO 40 C 20 CONTINUE C C N1 = 2, N2 = 1: generate elementary reflector H so that: C C H ( -X11 ) = ( * ) C ( -X21 ) = ( 0 ). C ( scale ) = ( 0 ) C V(1) = -X(1,1) V(2) = -X(2,1) V(3) = SCALE CALL DLARFG( 3, V(1), V(2), 1, TAU ) V(1) = ONE A33 = A(J3,J3) C C Perform swap provisionally on diagonal block in D. C CALL DLARFX( 'L', 3, 3, V, TAU, D, LDD, DWORK ) CALL DLARFX( 'R', 3, 3, V, TAU, D, LDD, DWORK ) C C Test whether to reject swap. C IF ( MAX( ABS( D(2,1) ), ABS( D(3,1) ), ABS( D(1,1)-A33 ) ) $ .GT. THRESH ) GO TO 50 C C Accept swap: apply transformation to the entire matrix A. C CALL DLARFX( 'Right', J3, 3, V, TAU, A(1,J1), LDA, DWORK ) CALL DLARFX( 'Left', 3, N-J1, V, TAU, A(J1,J2), LDA, DWORK ) C A(J1,J1) = A33 A(J2,J1) = ZERO A(J3,J1) = ZERO C C Apply transformation to G. C IF ( ISHAM ) THEN CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, $ DWORK, 1 ) TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 ) CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 ) CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1, G(J1,J1), $ LDG ) IF ( N.GT.J1+2 ) $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, $ DWORK ) ELSE CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, $ DWORK, 1 ) CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1), $ LDG ) IF ( N.GT.J1+2 ) $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, $ DWORK ) END IF C IF ( WANTU ) THEN C C Accumulate transformation in the matrices U1 and U2. C CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK ) CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK ) END IF GO TO 40 C 30 CONTINUE C C N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so C that: C C H(2) H(1) ( -X11 -X12 ) = ( * * ) C ( -X21 -X22 ) ( 0 * ). C ( scale 0 ) ( 0 0 ) C ( 0 scale ) ( 0 0 ) C V1(1) = -X(1,1) V1(2) = -X(2,1) V1(3) = SCALE CALL DLARFG( 3, V1(1), V1(2), 1, TAU1 ) V1(1) = ONE C TEMP = -TAU1*( X(1,2)+V1(2)*X(2,2) ) V2(1) = -TEMP*V1(2) - X(2,2) V2(2) = -TEMP*V1(3) V2(3) = SCALE CALL DLARFG( 3, V2(1), V2(2), 1, TAU2 ) V2(1) = ONE C C Perform swap provisionally on diagonal block in D. C CALL DLARFX( 'L', 3, 4, V1, TAU1, D, LDD, DWORK ) CALL DLARFX( 'R', 4, 3, V1, TAU1, D, LDD, DWORK ) CALL DLARFX( 'L', 3, 4, V2, TAU2, D(2,1), LDD, DWORK ) CALL DLARFX( 'R', 4, 3, V2, TAU2, D(1,2), LDD, DWORK ) C C Test whether to reject swap. C IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ), $ ABS( D(4,2) ) ).GT.THRESH ) GO TO 50 C C Accept swap: apply transformation to the entire matrix A. C CALL DLARFX( 'L', 3, N-J1+1, V1, TAU1, A(J1,J1), LDA, DWORK ) CALL DLARFX( 'R', J4, 3, V1, TAU1, A(1,J1), LDA, DWORK ) CALL DLARFX( 'L', 3, N-J1+1, V2, TAU2, A(J2,J1), LDA, DWORK ) CALL DLARFX( 'R', J4, 3, V2, TAU2, A(1,J2), LDA, DWORK ) C A(J3,J1) = ZERO A(J3,J2) = ZERO A(J4,J1) = ZERO A(J4,J2) = ZERO C C Apply transformation to G. C IF ( ISHAM ) THEN CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG, $ DWORK ) CALL DSYMV( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO, $ DWORK, 1 ) TEMP = -HALF*TAU1*DDOT( 3, DWORK, 1, V1, 1 ) CALL DAXPY( 3, TEMP, V1, 1, DWORK, 1 ) CALL DSYR2( 'Upper', 3, -ONE, V1, 1, DWORK, 1, $ G(J1,J1), LDG ) IF ( N.GT.J1+2 ) $ CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3), $ LDG, DWORK ) C CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG, $ DWORK ) CALL DSYMV( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO, $ DWORK, 1 ) TEMP = -HALF*TAU2*DDOT( 3, DWORK, 1, V2, 1 ) CALL DAXPY( 3, TEMP, V2, 1, DWORK, 1 ) CALL DSYR2( 'Upper', 3, -ONE, V2, 1, DWORK, 1, G(J2,J2), $ LDG ) IF ( N.GT.J2+2 ) $ CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3), $ LDG, DWORK ) ELSE CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG, $ DWORK ) CALL MB01MD( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO, $ DWORK, 1 ) CALL MB01ND( 'Upper', 3, ONE, V1, 1, DWORK, 1, G(J1,J1), $ LDG ) IF ( N.GT.J1+2 ) $ CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3), $ LDG, DWORK ) CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG, $ DWORK ) CALL MB01MD( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO, $ DWORK, 1 ) CALL MB01ND( 'Upper', 3, ONE, V2, 1, DWORK, 1, G(J2,J2), $ LDG ) IF ( N.GT.J2+2 ) $ CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3), $ LDG, DWORK ) END IF C IF ( WANTU ) THEN C C Accumulate transformation in the matrices U1 and U2. C CALL DLARFX( 'R', N, 3, V1, TAU1, U1(1,J1), LDU1, DWORK ) CALL DLARFX( 'R', N, 3, V2, TAU2, U1(1,J2), LDU1, DWORK ) CALL DLARFX( 'R', N, 3, V1, TAU1, U2(1,J1), LDU2, DWORK ) CALL DLARFX( 'R', N, 3, V2, TAU2, U2(1,J2), LDU2, DWORK ) END IF C 40 CONTINUE C IF ( N2.EQ.2 ) THEN C C Standardize new 2-by-2 block A11. C CALL DLANV2( A(J1,J1), A(J1,J2), A(J2,J1), A(J2,J2), WR1, $ WI1, WR2, WI2, CS, SN ) CALL DROT( N-J1-1, A(J1,J1+2), LDA, A(J2,J1+2), LDA, CS, $ SN ) CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN ) IF ( ISHAM ) THEN TEMP = G(J1,J2) CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN ) TAU = CS*TEMP + SN*G(J2,J2) G(J2,J2) = CS*G(J2,J2) - SN*TEMP G(J1,J1) = CS*G(J1,J1) + SN*TAU CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN ) ELSE IF ( N.GT.J1+1 ) $ CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG, $ CS, SN ) CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN ) END IF IF ( WANTU ) THEN CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN ) CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN ) END IF END IF C IF ( N1.EQ.2 ) THEN C C Standardize new 2-by-2 block A22. C J3 = J1 + N2 J4 = J3 + 1 CALL DLANV2( A(J3,J3), A(J3,J4), A(J4,J3), A(J4,J4), WR1, $ WI1, WR2, WI2, CS, SN ) IF ( J3+2.LE.N ) $ CALL DROT( N-J3-1, A(J3,J3+2), LDA, A(J4,J3+2), LDA, CS, $ SN ) CALL DROT( J3-1, A(1,J3), 1, A(1,J4), 1, CS, SN ) IF ( ISHAM ) THEN TEMP = G(J3,J4) CALL DROT( J3, G(1,J3), 1, G(1,J4), 1, CS, SN ) TAU = CS*TEMP + SN*G(J4,J4) G(J4,J4) = CS*G(J4,J4) - SN*TEMP G(J3,J3) = CS*G(J3,J3) + SN*TAU CALL DROT( N-J3, G(J3,J4), LDG, G(J4,J4), LDG, CS, SN ) ELSE IF ( N.GT.J3+1 ) $ CALL DROT( N-J3-1, G(J3,J3+2), LDG, G(J4,J3+2), LDG, $ CS, SN ) CALL DROT( J3-1, G(1,J3), 1, G(1,J4), 1, CS, SN ) END IF IF ( WANTU ) THEN CALL DROT( N, U1(1,J3), 1, U1(1,J4), 1, CS, SN ) CALL DROT( N, U2(1,J3), 1, U2(1,J4), 1, CS, SN ) END IF END IF C END IF RETURN C C Exit with INFO = 1 if swap was rejected. C 50 CONTINUE INFO = 1 RETURN C *** Last line of MB03TS *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01ED.f0000644000000000000000000000013215012430707016161 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01ED.f0000644000175000017500000006733115012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE TG01ED( JOBA, L, N, M, P, A, LDA, E, LDE, B, LDB, $ C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, TOL, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute for the descriptor system (A-lambda E,B,C) C the orthogonal transformation matrices Q and Z such that the C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is in an C SVD (singular value decomposition) coordinate form with C the system matrices Q'*A*Z and Q'*E*Z in the form C C ( A11 A12 ) ( Er 0 ) C Q'*A*Z = ( ) , Q'*E*Z = ( ) , C ( A21 A22 ) ( 0 0 ) C C where Er is an invertible diagonal matrix having on the diagonal C the decreasingly ordered nonzero singular values of E. C Optionally, the A22 matrix can be further reduced to the C SVD form C C ( Ar 0 ) C A22 = ( ) , C ( 0 0 ) C C where Ar is an invertible diagonal matrix having on the diagonal C the decreasingly ordered nonzero singular values of A22. C The left and/or right orthogonal transformations performed C to reduce E and A22 are accumulated. C C ARGUMENTS C C Mode Parameters C C JOBA CHARACTER*1 C = 'N': do not reduce A22; C = 'R': reduce A22 to an SVD form. C C Input/Output Parameters C C L (input) INTEGER C The number of rows of matrices A, B, and E. L >= 0. C C N (input) INTEGER C The number of columns of matrices A, E, and C. N >= 0. C C M (input) INTEGER C The number of columns of matrix B. M >= 0. C C P (input) INTEGER C The number of rows of matrix C. P >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the state dynamics matrix A. C On exit, the leading L-by-N part of this array contains C the transformed matrix Q'*A*Z. If JOBA = 'R', this matrix C is in the form C C ( A11 * * ) C Q'*A*Z = ( * Ar 0 ) , C ( * 0 0 ) C C where A11 is a RANKE-by-RANKE matrix and Ar is a C RNKA22-by-RNKA22 invertible diagonal matrix, with C decresingly ordered positive diagonal elements. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,L). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the descriptor matrix E. C On exit, the leading L-by-N part of this array contains C the transformed matrix Q'*E*Z. C C ( Er 0 ) C Q'*E*Z = ( ) , C ( 0 0 ) C C where Er is a RANKE-by-RANKE invertible diagonal matrix C having on the diagonal the decreasingly ordered positive C singular values of E. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,L). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, the leading L-by-M part of this array must C contain the input/state matrix B. C On exit, the leading L-by-M part of this array contains C the transformed matrix Q'*B. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Z. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C Q (output) DOUBLE PRECISION array, dimension (LDQ,L) C The leading L-by-L part of this array contains the C orthogonal matrix Q, which is the accumulated product of C transformations applied to A, E, and B on the left. C C LDQ INTEGER C The leading dimension of array Q. LDQ >= MAX(1,L). 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 is the accumulated product of C transformations applied to A, E, and C on the right. C C LDZ INTEGER C The leading dimension of array Z. LDZ >= MAX(1,N). C C RANKE (output) INTEGER C The effective rank of matrix E, and thus also the order C of the invertible diagonal submatrix Er. C RANKE is computed as the number of singular values of E C greater than TOL*SVEMAX, where SVEMAX is the maximum C singular value of E. C C RNKA22 (output) INTEGER C If JOBA = 'R', then RNKA22 is the effective rank of C matrix A22, and thus also the order of the invertible C diagonal submatrix Ar. RNKA22 is computed as the number C of singular values of A22 greater than TOL*SVAMAX, C where SVAMAX is an estimate of the maximum singular value C of A. C If JOBA = 'N', then RNKA22 is not referenced. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in determining the rank of E C and of A22. If TOL > 0, then singular values less than C TOL*SVMAX are treated as zero, where SVMAX is the maximum C singular value of E or an estimate of it for A and E. C If TOL <= 0, the default tolerance TOLDEF = EPS*L*N is C used instead, where EPS is the machine precision C (see LAPACK Library routine DLAMCH). TOL < 1. 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 length of the array DWORK. C LDWORK >= MAX(1,MIN(L,N) + C MAX(3*MIN(L,N)+MAX(L,N), 5*MIN(L,N), M, P)). 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: the QR algorithm has failed to converge when computing C singular value decomposition. In this case INFO C specifies how many superdiagonals did not converge. C This failure is not likely to occur. C C METHOD C C The routine computes the singular value decomposition (SVD) of E, C in the form C C ( Er 0 ) C E = Q * ( ) * Z' C ( 0 0 ) C C and finds the largest RANKE-by-RANKE leading diagonal submatrix C Er whose condition number is less than 1/TOL. RANKE defines thus C the effective rank of matrix E. C If JOBA = 'R' the same reduction is performed on A22 in the C partitioned matrix C C ( A11 A12 ) C Q'*A*Z = ( ) , C ( A21 A22 ) C C to obtain it in the form C C ( Ar 0 ) C A22 = ( ) , C ( 0 0 ) C C with Ar an invertible diagonal matrix. C C The accumulated transformations are also applied to the rest of C matrices C C B <- Q' * B, C <- C * Z. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( L*L*N ) floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C March 1999. Based on the RASP routine RPDSSV. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 1999, C Feb. 2000, Oct. 2001, May 2003, Feb. 2017, June 2017. C C KEYWORDS C C Descriptor system, matrix algebra, matrix operations, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER JOBA INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK, $ LDZ, M, N, P, RNKA22, RANKE DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), $ Z( LDZ, * ) C .. Local Scalars .. LOGICAL REDA INTEGER I, IR1, J, KW, LA22, LN, LN2, LWR, NA22, WRKOPT DOUBLE PRECISION EPSM, SVEMAX, SVLMAX, TOLDEF C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DGELQF, DGESVD, $ DLACPY, DLASET, DORMQR, DORMLQ, DSWAP, MA02AD, $ MB03UD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C C .. Executable Statements .. C REDA = LSAME( JOBA, 'R' ) C C Test the input parameters. C INFO = 0 WRKOPT = MIN( L, N ) + $ MAX( M, P, 3*MIN( L, N ) + MAX( L, N ), 5*MIN( L, N ) ) IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA ) THEN INFO = -1 ELSE IF( L.LT.0 ) 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, L ) ) THEN INFO = -7 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -9 ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN INFO = -15 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( TOL.GE.ONE ) THEN INFO = -20 ELSE IF( LDWORK.LT.MAX( 1, WRKOPT ) ) THEN INFO = -22 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01ED', -INFO ) RETURN END IF C C Quick return if possible. C IF( L.EQ.0 .OR. N.EQ.0 ) THEN IF( L.GT.0 ) $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) IF( N.GT.0 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) DWORK(1) = ONE RANKE = 0 IF( REDA ) RNKA22 = 0 RETURN END IF C LN = MIN( L, N ) EPSM = DLAMCH( 'EPSILON' ) C TOLDEF = TOL IF( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance for rank determination. C TOLDEF = EPSM * DBLE( L*N ) END IF C C Set the estimate of the maximum singular value of E to ||E||_F. C SVLMAX = DLANGE( 'Frobenius', L, N, E, LDE, DWORK ) C C Compute the SVD of E C C ( Er 0 ) C E = Qr * ( ) * Zr' C ( 0 0 ) C C Workspace: needed MIN(L,N) + MAX(3*MIN(L,N)+MAX(L,N),5*MIN(L,N)); C prefer larger. C LWR = LDWORK - LN KW = LN + 1 C CALL DGESVD( 'A', 'A', L, N, E, LDE, DWORK, Q, LDQ, Z, LDZ, $ DWORK(KW), LWR, INFO ) IF( INFO.GT.0 ) $ RETURN WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) C C Determine the rank of E. C RANKE = 0 IF( DWORK(1).GT.TOLDEF ) THEN RANKE = 1 SVEMAX = DWORK(1) DO 10 I = 2, LN IF( DWORK(I).LT.SVEMAX*TOLDEF ) GO TO 20 RANKE = RANKE + 1 10 CONTINUE C 20 CONTINUE END IF C C Apply transformation on the rest of matrices. C IF( RANKE.GT.0 ) THEN C C A <-- Qr' * A * Zr. C CALL DGEMM( 'Transpose', 'No transpose', L, N, L, ONE, $ Q, LDQ, A, LDA, ZERO, E, LDE ) CALL DGEMM( 'No transpose', 'Transpose', L, N, N, ONE, $ E, LDE, Z, LDZ, ZERO, A, LDA ) C C B <-- Qr' * B. C Workspace: need L; C prefer L*M. C IF( LWR.GT.L*M .AND. M.GT.0 ) THEN C CALL DGEMM( 'Transpose', 'No transpose', L, M, L, ONE, $ Q, LDQ, B, LDB, ZERO, DWORK(KW), L ) CALL DLACPY( 'Full', L, M, DWORK(KW), L, B, LDB ) ELSE DO 30 J = 1, M CALL DGEMV( 'Transpose', L, L, ONE, Q, LDQ, B(1,J), 1, $ ZERO, DWORK(KW), 1 ) CALL DCOPY( L, DWORK(KW), 1, B(1,J), 1 ) 30 CONTINUE END IF C C C <-- C * Zr. C Workspace: need N; C prefer P*N. C IF( LWR.GT.P*N ) THEN C CALL DGEMM( 'No transpose', 'Transpose', P, N, N, ONE, $ C, LDC, Z, LDZ, ZERO, DWORK(KW), MAX( 1, P ) ) CALL DLACPY( 'Full', P, N, DWORK(KW), MAX( 1, P ), C, LDC ) ELSE DO 40 I = 1, P CALL DGEMV( 'No transpose', N, N, ONE, Z, LDZ, $ C(I,1), LDC, ZERO, DWORK(KW), 1 ) CALL DCOPY( N, DWORK(KW), 1, C(I,1), LDC ) 40 CONTINUE END IF WRKOPT = MAX( WRKOPT, L*M, P*N ) END IF C C Reduce A22 if necessary. C IF( REDA ) THEN LA22 = L - RANKE NA22 = N - RANKE LN2 = MIN( LA22, NA22 ) IF( LN2.EQ.0 ) THEN IR1 = 1 RNKA22 = 0 ELSE C C Set the estimate of maximum singular value of A to detect C a negligible A22 submatrix. C SVLMAX = DLANGE( 'Frobenius', L, N, A, LDA, DWORK ) C C Compute the SVD of A22 using a storage saving approach. C IR1 = RANKE + 1 IF( LA22.GE.NA22 ) THEN C C Compute the QR decomposition of A22 in the form C C A22 = Q2 * ( R2 ) , C ( 0 ) C C where R2 is upper triangular. C Workspace: need MIN(L,N) + N; C prefer MIN(L,N) + N*NB. C CALL DGEQRF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1), $ DWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) C C Apply transformation Q2 to A, B, and Q. C C A <--diag(I, Q2') * A C Workspace: need MIN(L,N) + N; C prefer MIN(L,N) + N*NB. C CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, LN2, $ A(IR1,IR1), LDA, DWORK(IR1), A(IR1,1), LDA, $ DWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) C C B <-- diag(I, Q2') * B C Workspace: need MIN(L,N) + M; C prefer MIN(L,N) + M*NB. C IF ( M.GT.0 ) THEN CALL DORMQR( 'Left', 'Transpose', LA22, M, LN2, $ A(IR1,IR1), LDA, DWORK(IR1), B(IR1,1), $ LDB, DWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) END IF C C Q <-- Q * diag(I, Q2) C Workspace: need MIN(L,N) + L; C prefer MIN(L,N) + L*NB. C CALL DORMQR( 'Right', 'No transpose', L, LA22, LN2, $ A(IR1,IR1), LDA, DWORK(IR1), Q(1,IR1), LDQ, $ DWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) C C Compute the SVD of the upper triangular submatrix R2 as C C ( Ar 0 ) C R2 = Q2r * ( ) * Z2r' , C ( 0 0 ) C C where Q2r is stored in E and Z2r' is stored in A22. C Workspace: need MAX(1,5*MIN(L,N)); C prefer larger. C CALL MB03UD( 'Vectors', 'Vectors', LN2, A(IR1,IR1), LDA, $ E(IR1,IR1), LDE, DWORK(IR1), DWORK(KW), LWR, $ INFO ) IF( INFO.GT.0 ) $ RETURN WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) C C Determine the rank of A22. C RNKA22 = 0 IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN RNKA22 = 1 DO 50 I = IR1+1, LN IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 60 RNKA22 = RNKA22 + 1 50 CONTINUE C 60 CONTINUE END IF C C Apply transformation on the rest of matrices. C IF( RNKA22.GT.0 ) THEN C C A <-- diag(I,Q2r') * A * diag(I,Zr2) C CALL DGEMM( 'Transpose', 'No transpose', LN2, RANKE, $ LN2, ONE, E(IR1,IR1), LDE, A(IR1,1), LDA, $ ZERO, E(IR1,1), LDE ) CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE, $ A(IR1,1), LDA ) CALL DGEMM( 'No transpose', 'Transpose', RANKE, LN2, $ LN2, ONE, A(1,IR1), LDA, A(IR1,IR1), LDA, $ ZERO, E(1,IR1), LDE ) CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE, $ A(1,IR1), LDA ) C C B <-- diag(I,Q2r') * B C IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN C CALL DGEMM( 'Transpose', 'No transpose', LN2, M, $ LN2, ONE, E(IR1,IR1), LDE, B(IR1,1), $ LDB, ZERO, DWORK(KW), LN2 ) CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2, $ B(IR1,1), LDB ) ELSE DO 70 J = 1, M CALL DGEMV( 'Transpose', LN2, LN2, ONE, $ E(IR1,IR1), LDE, B( IR1,J), 1, $ ZERO, DWORK(KW), 1 ) CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 ) 70 CONTINUE END IF C C C <-- C * diag(I,Zr2) C IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN C CALL DGEMM( 'No transpose', 'Transpose', P, LN2, $ LN2, ONE, C(1,IR1), LDC, A(IR1,IR1), $ LDA, ZERO, DWORK(KW), P ) CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P, $ C(1,IR1), LDC ) ELSE DO 80 I = 1, P CALL DGEMV( 'No transpose', LN2, LN2, ONE, $ A(IR1,IR1), LDA, C(I,IR1), LDC, $ ZERO, DWORK(KW), 1 ) CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC ) 80 CONTINUE END IF C C Q <-- Q * diag(I, Qr2) C IF( LWR.GT.L*LN2 ) THEN C CALL DGEMM( 'No transpose', 'No transpose', L, LN2, $ LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1), $ LDE, ZERO, DWORK(KW), L ) CALL DLACPY( 'Full', L, LN2, DWORK(KW), L, $ Q(1,IR1), LDQ ) ELSE DO 90 I = 1, L CALL DGEMV( 'Transpose', LN2, LN2, ONE, $ E(IR1,IR1), LDE, Q(I,IR1), LDQ, $ ZERO, DWORK(KW), 1 ) CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ ) 90 CONTINUE END IF C C Z' <-- diag(I, Zr2') * Z' C IF( LWR.GT.N*LN2 ) THEN C CALL DGEMM( 'No transpose', 'No transpose', LN2, N, $ LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1), $ LDZ, ZERO, DWORK(KW), LN2 ) CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2, $ Z(IR1,1), LDZ ) ELSE DO 100 J = 1, N CALL DGEMV( 'No transpose', LN2, LN2, ONE, $ A(IR1,IR1), LDA, Z(IR1,J), 1, $ ZERO, DWORK(KW), 1 ) CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 ) 100 CONTINUE END IF END IF ELSE C C Compute the LQ decomposition of A22 in the form C C A22 = ( L2 0 )* Z2 C C where L2 is lower triangular. C Workspace: need MIN(L,N) + L; C prefer MIN(L,N) + L*NB. C CALL DGELQF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1), $ DWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) C C Apply transformation Z2 to A, C, and Z. C C A <-- A * diag(I, Z2') C Workspace: need 2*MIN(L,N); C prefer MIN(L,N) + MIN(L,N)*NB. C CALL DORMLQ( 'Right', 'Transpose', RANKE, NA22, LN2, $ A(IR1,IR1), LDA, DWORK(IR1), A(1,IR1), LDA, $ DWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) C C C <-- C * diag(I, Z2') C Workspace: need MIN(L,N) + P; C prefer MIN(L,N) + P*NB. C IF ( P.GT.0 ) THEN CALL DORMLQ( 'Right', 'Transpose', P, NA22, LN2, $ A(IR1,IR1), LDA, DWORK(IR1), C(1,IR1), $ LDC, DWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) END IF C C Z' <- diag(I, Z2) * Z' C Workspace: need MIN(L,N) + N; C prefer MIN(L,N) + N*NB. C CALL DORMLQ( 'Left', 'No transpose', NA22, N, LN2, $ A(IR1,IR1), LDA, DWORK(IR1), Z(IR1,1), LDZ, $ DWORK(KW), LWR, INFO ) WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) C C Compute the SVD of the lower triangular submatrix L2 as C C ( Ar 0 ) C L2' = Z2r * ( ) * Q2r' C ( 0 0 ) C C where Q2r' is stored in E and Z2r is stored in A22. C Workspace: need MAX(1,5*MIN(L,N)); C prefer larger. C CALL MA02AD( 'Lower', LN2, LN2, A(IR1,IR1), LDA, $ E(IR1,IR1), LDE ) CALL MB03UD( 'Vectors', 'Vectors', LN2, E(IR1,IR1), LDE, $ A(IR1,IR1), LDA, DWORK(IR1), DWORK(KW), $ LWR, INFO ) IF( INFO.GT.0 ) $ RETURN WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) C C Determine the rank of A22. C RNKA22 = 0 IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN RNKA22 = 1 DO 110 I = IR1+1, LN IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 120 RNKA22 = RNKA22 + 1 110 CONTINUE C 120 CONTINUE END IF C C Apply transformation on the rest of matrices. C IF( RNKA22.GT.0 ) THEN C C A <-- diag(I,Q2r') * A * diag(I,Zr2) C CALL DGEMM( 'No transpose', 'No transpose', LN2, $ RANKE, LN2, ONE, E(IR1,IR1), LDE, $ A(IR1,1), LDA, ZERO, E(IR1,1), LDE ) CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE, $ A(IR1,1), LDA ) CALL DGEMM( 'No transpose', 'No transpose', RANKE, $ LN2, LN2, ONE, A(1,IR1), LDA, $ A(IR1,IR1), LDA, ZERO, E(1,IR1), LDE ) CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE, $ A(1,IR1), LDA ) C C B <-- diag(I,Q2r') * B C IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN C CALL DGEMM( 'No transpose', 'No transpose', LN2, M, $ LN2, ONE, E(IR1,IR1), LDE, B(IR1,1), $ LDB, ZERO, DWORK(KW), LN2 ) CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2, $ B(IR1,1), LDB ) ELSE DO 130 J = 1, M CALL DGEMV( 'No transpose', LN2, LN2, ONE, $ E(IR1,IR1), LDE, B( IR1,J), 1, $ ZERO, DWORK(KW), 1 ) CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 ) 130 CONTINUE END IF C C C <-- C * diag(I,Zr2) C IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN C CALL DGEMM( 'No transpose', 'No transpose', P, LN2, $ LN2, ONE, C(1,IR1), LDC, A(IR1,IR1), $ LDA, ZERO, DWORK(KW), P ) CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P, $ C(1,IR1), LDC ) ELSE DO 140 I = 1, P CALL DGEMV( 'Transpose', LN2, LN2, ONE, $ A(IR1,IR1), LDA, C(I,IR1), LDC, $ ZERO, DWORK(KW), 1 ) CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC ) 140 CONTINUE END IF C C Q <-- Q * diag(I, Qr2) C IF( LWR.GT.L*LN2 ) THEN C CALL DGEMM( 'No transpose', 'Transpose', L, LN2, $ LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1), $ LDE, ZERO, DWORK(KW), L ) CALL DLACPY( 'Full', L, LN2, DWORK(KW), L, $ Q(1,IR1), LDQ ) ELSE DO 150 I = 1, L CALL DGEMV( 'No transpose', LN2, LN2, ONE, $ E(IR1,IR1), LDE, Q(I,IR1), LDQ, $ ZERO, DWORK(KW), 1 ) CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ ) 150 CONTINUE END IF C C Z' <-- diag(I, Zr2') * Z' C IF( LWR.GT.N*LN2 ) THEN C CALL DGEMM( 'Transpose', 'No transpose', LN2, N, $ LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1), $ LDZ, ZERO, DWORK(KW), LN2 ) CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2, $ Z(IR1,1), LDZ ) ELSE DO 160 J = 1, N CALL DGEMV( 'Transpose', LN2, LN2, ONE, $ A(IR1,IR1), LDA, Z(IR1,J), 1, $ ZERO, DWORK(KW), 1 ) CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 ) 160 CONTINUE END IF END IF END IF END IF END IF C C Set E. C CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) CALL DCOPY( RANKE, DWORK, 1, E, LDE+1 ) C IF( REDA ) THEN C C Set A22. C CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, A(IR1,IR1), LDA ) CALL DCOPY( RNKA22, DWORK(IR1), 1, A(IR1,IR1), LDA+1 ) END IF C C Transpose Z. C DO 170 I = 2, N CALL DSWAP( I-1, Z(1,I), 1, Z(I,1), LDZ ) 170 CONTINUE C DWORK(1) = WRKOPT C RETURN C *** Last line of TG01ED *** END control-4.1.2/src/slicot/src/PaxHeaders/BB04AD.f0000644000000000000000000000013215012430707016131 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/BB04AD.f0000644000175000017500000003762415012430707017341 0ustar00lilgelilge00000000000000 SUBROUTINE BB04AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, 1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, 2 LDWORK, INFO) C C PURPOSE C C To generate benchmark examples of (generalized) discrete-time C Lyapunov equations C C T T C A X A - E X E = Y . C C In some examples, the right hand side has the form C C T C Y = - B B C C and the solution can be represented as a product of Cholesky C factors C C T C X = U U . C C E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note C that E can be the identity matrix. For some examples, B, X, or U C are not provided. C C This routine is an implementation of the benchmark library C DTLEX (Version 1.0) described in [1]. C C ARGUMENTS C C Mode Parameters C C DEF CHARACTER*1 C Specifies the kind of values used as parameters when C generating parameter-dependent and scalable examples C (i.e., examples with NR(1) = 2, 3, or 4): C DEF = 'D' or 'd': Default values are used. C DEF = 'N' or 'n': Values set in DPAR and IPAR are used. C This parameter is not referenced if NR(1) = 1. C Note that the scaling parameter of examples with C NR(1) = 3 or 4 is considered as a regular parameter in C this context. C C Input/Output Parameters C C NR (input) INTEGER array, dimension 2 C Specifies the index of the desired example according C to [1]. C NR(1) defines the group: C 1 : parameter-free problems of fixed size C 2 : parameter-dependent problems of fixed size C 3 : parameter-free problems of scalable size C 4 : parameter-dependent problems of scalable size C NR(2) defines the number of the benchmark example C within a certain group according to [1]. C C DPAR (input/output) DOUBLE PRECISION array, dimension 2 C On entry, if DEF = 'N' or 'n' and the desired example C depends on real parameters, then the array DPAR must C contain the values for these parameters. C For an explanation of the parameters see [1]. C For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's', C respectively. C For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and C 's', respectively. C For Examples 4.3 and 4.4, DPAR(1) defines the parameter C 't'. C On exit, if DEF = 'D' or 'd' and the desired example C depends on real parameters, then the array DPAR is C overwritten by the default values given in [1]. C C IPAR (input/output) INTEGER array of DIMENSION at least 1 C On entry, if DEF = 'N' or 'n' and the desired example C depends on integer parameters, then the array IPAR must C contain the values for these parameters. C For an explanation of the parameters see [1]. C For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'. C For Example 4.4, IPAR(1) defines 'q'. C On exit, if DEF = 'D' or 'd' and the desired example C depends on integer parameters, then the array IPAR is C overwritten by the default values given in [1]. C C VEC (output) LOGICAL array, dimension 8 C Flag vector which displays the availability of the output C data: C VEC(1) and VEC(2) refer to N and M, respectively, and are C always .TRUE. C VEC(3) is .TRUE. iff E is NOT the identity matrix. C VEC(4) and VEC(5) refer to A and Y, respectively, and are C always .TRUE. C VEC(6) is .TRUE. iff B is provided. C VEC(7) is .TRUE. iff the solution matrix X is provided. C VEC(8) is .TRUE. iff the Cholesky factor U is provided. C C N (output) INTEGER C The actual state dimension, i.e., the order of the C matrices E and A. C C M (output) INTEGER C The number of rows in the matrix B. If B is not provided C for the desired example, M = 0 is returned. C C E (output) DOUBLE PRECISION array, dimension (LDE,N) C The leading N-by-N part of this array contains the C matrix E. C NOTE that this array is overwritten (by the identity C matrix), if VEC(3) = .FALSE. C C LDE INTEGER C The leading dimension of array E. LDE >= N. C C A (output) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array contains the C matrix A. C C LDA INTEGER C The leading dimension of array A. LDA >= N. C C Y (output) DOUBLE PRECISION array, dimension (LDY,N) C The leading N-by-N part of this array contains the C matrix Y. C C LDY INTEGER C The leading dimension of array Y. LDY >= N. C C B (output) DOUBLE PRECISION array, dimension (LDB,N) C The leading M-by-N part of this array contains the C matrix B. C C LDB INTEGER C The leading dimension of array B. LDB >= M. C C X (output) DOUBLE PRECISION array, dimension (LDX,N) C The leading N-by-N part of this array contains the C matrix X. C C LDX INTEGER C The leading dimension of array X. LDX >= N. C C U (output) DOUBLE PRECISION array, dimension (LDU,N) C The leading N-by-N part of this array contains the C matrix U. C C LDU INTEGER C The leading dimension of array U. LDU >= N. C C NOTE (output) CHARACTER*70 C String containing short information about the chosen C example. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is C required. C For the other examples, no workspace is needed, i.e., C LDWORK >= 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; in particular, INFO = -3 or -4 indicates C that at least one of the parameters in DPAR or C IPAR, respectively, has an illegal value. C C REFERENCES C C [1] D. Kressner, V. Mehrmann, and T. Penzl. C DTLEX - a Collection of Benchmark Examples for Discrete- C Time Lyapunov Equations. C SLICOT Working Note 1999-7, 1999. C C NUMERICAL ASPECTS C C None C C CONTRIBUTOR C C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) C C For questions concerning the collection or for the submission of C test examples, please contact Volker Mehrmann C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). C C REVISIONS C C June 1999, V. Sima. C C KEYWORDS C C discrete-time Lyapunov equations C C ******************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, FOUR PARAMETER (ZERO = .0D0, ONE = .1D1, TWO = .2D1, 1 FOUR = .4D1) C .. Scalar Arguments .. CHARACTER DEF CHARACTER*70 NOTE INTEGER INFO, LDA, LDB, LDE, LDU, LDWORK, LDX, LDY, M, N C .. Array Arguments .. LOGICAL VEC(8) INTEGER IPAR(*), NR(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), DPAR(*), DWORK(LDWORK), 1 E(LDE,*), U(LDU,*), X(LDX,*), Y(LDY,*) C .. Local Scalars .. INTEGER I, J, K DOUBLE PRECISION TEMP, TTEMP, TWOBYN C .. Local Arrays .. LOGICAL VECDEF(8) C .. External Functions .. C . BLAS . DOUBLE PRECISION DDOT EXTERNAL DDOT C . LAPACK . LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. C . BLAS . EXTERNAL DGEMV, DGER, DAXPY C . LAPACK . EXTERNAL DLASET C .. Intrinsic Functions .. INTRINSIC DBLE, MIN, MOD, SQRT C .. Data Statements .. C . default values for availabilities . DATA VECDEF /.TRUE., .TRUE., .FALSE., .TRUE., 1 .TRUE., .FALSE., .FALSE., .FALSE./ C C .. Executable Statements .. C INFO = 0 DO 10 I = 1, 8 VEC(I) = VECDEF(I) 10 CONTINUE C IF (NR(1) .EQ. 4) THEN IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN INFO = -1 RETURN END IF C IF (NR(2) .EQ. 1) THEN NOTE = 'DTLEX: Example 4.1' IF (LSAME(DEF,'D')) THEN IPAR(1) = 10 DPAR(1) = .15D1 DPAR(2) = .15D1 END IF IF ((DPAR(1) .LE. ONE) .OR. (DPAR(2) .LE. ONE)) INFO = -3 IF (IPAR(1) .LT. 2) INFO = -4 N = IPAR(1) M = 1 IF (LDE .LT. N) INFO = -9 IF (LDA .LT. N) INFO = -11 IF (LDY .LT. N) INFO = -13 IF (LDB .LT. M) INFO = -15 IF (LDX .LT. N) INFO = -17 IF (LDWORK .LT. N*2) INFO = -22 IF (INFO .NE. 0) RETURN C VEC(6) = .TRUE. VEC(7) = .TRUE. TWOBYN = TWO / DBLE( N ) CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) CALL DLASET('A', N, N, ZERO, ZERO, X, LDX) DO 20 I = 1, N TEMP = DPAR(1) ** (I-1) A(I,I) = (TEMP-ONE) / (TEMP+ONE) DWORK(I) = ONE 20 CONTINUE C H1 * A CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) C A * H1 CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) C S A INV(S), B INV(S) DO 40 J = 1, N B(1,J) = B(1,J) / (DPAR(2)**(J-1)) DO 30 I = 1, N A(I,J) = A(I,J) * (DPAR(2)**(I-J)) 30 CONTINUE DWORK(J) = ONE - TWO * MOD(J,2) 40 CONTINUE C H2 * A CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) C A * H2 CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) C B * H2 CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, 1 B, LDB) C Y = -B' * B CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) C X = -Y DO 50 J = 1, N CALL DAXPY(N, -ONE, Y(1,J), 1, X(1,J), 1) 50 CONTINUE C ELSE IF (NR(2) .EQ. 2) THEN NOTE = 'DTLEX: Example 4.2' IF (LSAME(DEF,'D')) THEN IPAR(1) = 10 DPAR(1) = -.5D0 DPAR(2) = .15D1 END IF IF ((DPAR(1) .LE. -ONE) .OR. (DPAR(1) .GE. ONE) .OR. 1 (DPAR(2) .LE. ONE)) INFO = -3 IF (IPAR(1) .LT. 2) INFO = -4 N = IPAR(1) M = 1 IF (LDE .LT. N) INFO = -9 IF (LDA .LT. N) INFO = -11 IF (LDY .LT. N) INFO = -13 IF (LDB .LT. M) INFO = -15 IF (LDWORK .LT. N*2) INFO = -22 IF (INFO .NE. 0) RETURN C VEC(6) = .TRUE. TWOBYN = TWO / DBLE( N ) CALL DLASET('A', N, N, ZERO, ONE, E, LDE) CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) DO 60 I = 1, N-1 DWORK(I) = ONE A(I,I+1) = ONE 60 CONTINUE DWORK(N) = ONE C H1 * A CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) C A * H1 CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) C S A INV(S), B INV(S) DO 80 J = 1, N B(1,J) = B(1,J) / (DPAR(2)**(J-1)) DO 70 I = 1, N A(I,J) = A(I,J) * (DPAR(2)**(I-J)) 70 CONTINUE DWORK(J) = ONE - TWO * MOD(J,2) 80 CONTINUE C H2 * A CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) C A * H2 CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) C B * H2 CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, 1 B, LDB) C Y = -B' * B CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) C ELSE IF (NR(2) .EQ. 3) THEN NOTE = 'DTLEX: Example 4.3' IF (LSAME(DEF,'D')) THEN IPAR(1) = 10 DPAR(1) = .1D2 END IF IF (DPAR(1) .LT. ZERO) INFO = -3 IF (IPAR(1) .LT. 2) INFO = -4 N = IPAR(1) M = 0 IF (LDE .LT. N) INFO = -9 IF (LDA .LT. N) INFO = -11 IF (LDY .LT. N) INFO = -13 IF (LDX .LT. N) INFO = -17 IF (INFO .NE. 0) RETURN C VEC(3) = .TRUE. VEC(7) = .TRUE. TEMP = TWO ** (-DPAR(1)) CALL DLASET('U', N, N, ZERO, ZERO, E, LDE) CALL DLASET('L', N, N, TEMP, ONE, E, LDE) CALL DLASET('L', N, N, ZERO, ZERO, A, LDA) CALL DLASET('U', N, N, ONE, ZERO, A, LDA) CALL DLASET('A', N, N, ONE, ONE, X, LDX) DO 90 I = 1, N A(I,I) = DBLE( I ) + TEMP 90 CONTINUE DO 110 J = 1, N DO 100 I = 1, N Y(I,J) = TEMP * TEMP * DBLE( 1 - (N-I) * (N-J) ) + 1 TEMP * DBLE( 3 * (I+J) - 2 * (N+1) ) + 2 FOUR*DBLE( I*J ) - TWO * DBLE( I+J ) 100 CONTINUE 110 CONTINUE C ELSE IF (NR(2) .EQ. 4) THEN NOTE = 'DTLEX: Example 4.4' IF (LSAME(DEF,'D')) THEN IPAR(1) = 10 DPAR(1) = .15D1 END IF IF (DPAR(1) .LT. ONE) INFO = -3 IF (IPAR(1) .LT. 1) INFO = -4 N = IPAR(1) * 3 M = 1 IF (LDE .LT. N) INFO = -9 IF (LDA .LT. N) INFO = -11 IF (LDY .LT. N) INFO = -13 IF (LDB .LT. M) INFO = -15 IF (INFO .NE. 0) RETURN C VEC(3) = .TRUE. VEC(6) = .TRUE. CALL DLASET('A', N, N, ZERO, ZERO, E, LDE) CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) DO 140 I = 1, IPAR(1) TTEMP = ONE - ONE / (DPAR(1)**I) TEMP = - TTEMP / SQRT( TWO ) DO 130 J = 1, I - 1 DO 120 K = 0, 2 A(N - I*3+3, J*3-K) = TTEMP A(N - I*3+2, J*3-K) = TWO * TEMP 120 CONTINUE 130 CONTINUE A(N - I*3+3, I*3-2) = TTEMP A(N - I*3+2, I*3-2) = TWO * TEMP A(N - I*3+2, I*3-1) = TWO * TEMP A(N - I*3+2, I*3 ) = TEMP A(N - I*3+1, I*3 ) = TEMP 140 CONTINUE DO 160 J = 1, N IF (J .GT. 1) CALL DAXPY(N, ONE, A(J-1,1), LDA, A(J,1), LDA) B(1, J) = DBLE( J ) DO 150 I = 1, N E(I,N-J+1) = DBLE( MIN(I,J) ) Y(I,J) = -DBLE( I*J ) 150 CONTINUE 160 CONTINUE C ELSE INFO = -2 END IF ELSE INFO = -2 END IF C RETURN C *** Last Line of BB04AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03AI.f0000644000000000000000000000013215012430707016150 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03AI.f0000644000175000017500000002005615012430707017347 0ustar00lilgelilge00000000000000 SUBROUTINE MB03AI( SHFT, K, N, AMAP, S, SINV, A, LDA1, LDA2, C1, $ S1, C2, S2, DWORK ) C C PURPOSE C C To compute two Givens rotations (C1,S1) and (C2,S2) C such that the orthogonal matrix C C [ Q 0 ] [ C1 S1 0 ] [ 1 0 0 ] C Z = [ ], Q := [ -S1 C1 0 ] * [ 0 C2 S2 ], C [ 0 I ] [ 0 0 1 ] [ 0 -S2 C2 ] C C makes the first column of the real Wilkinson double shift C polynomial of the product of matrices in periodic upper Hessenberg C form, stored in the array A, parallel to the first unit vector. C Only the rotation defined by C1 and S1 is used for the real C Wilkinson single shift polynomial (see SLICOT Library routines C MB03BE or MB03BF). All factors whose exponents differ from that of C the Hessenberg factor are assumed nonsingular. The matrix product C is evaluated. C C ARGUMENTS C C Mode Parameters C C SHFT CHARACTER*1 C Specifies the number of shifts employed by the shift C polynomial, as follows: C = 'D': two shifts (assumes N > 2); C = 'S': one real shift. C C Input/Output Parameters C C K (input) INTEGER C The number of factors. K >= 1. C C N (input) INTEGER C The order of the factors. N >= 2. C C AMAP (input) INTEGER array, dimension (K) C The map for accessing the factors, i.e., if AMAP(I) = J, C then the factor A_I is stored at the J-th position in A. C AMAP(K) is the pointer to the Hessenberg matrix. C Before calling this routine, AMAP returned by SLICOT C Library routine MB03BA should be modified as follows: C J = AMAP(1), AMAP(I) = AMAP(I+1), I = 1:K-1, AMAP(K) = J. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C SINV (input) INTEGER C Signature multiplier. Entries of S are virtually C multiplied by SINV. C C A (input) DOUBLE PRECISION array, dimension (LDA1,LDA2,K) C The leading N-by-N-by-K part of this array must contain C the product (implicitly represented by its K factors) C in periodic upper Hessenberg form. C C LDA1 INTEGER C The first leading dimension of the array A. LDA1 >= N. C C LDA2 INTEGER C The second leading dimension of the array A. LDA2 >= N. C C C1 (output) DOUBLE PRECISION C S1 (output) DOUBLE PRECISION C On exit, C1 and S1 contain the parameters for the first C Givens rotation. C C C2 (output) DOUBLE PRECISION C S2 (output) DOUBLE PRECISION C On exit, if SHFT = 'D', C2 and S2 contain the parameters C for the second Givens rotation. Otherwise, C2 = 1, S2 = 0. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (N*(N+2)) C C METHOD C C The necessary elements of the real Wilkinson double shift C polynomial are computed, and suitable Givens rotations are C found. For numerical reasons, this routine should be called C when convergence difficulties are encountered for small order C matrices and small K, e.g., N, K <= 6. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Jan. 2019. C C REVISIONS C C V. Sima, Dec. 2019, Dec. 2020. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO, ZERO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER SHFT INTEGER K, LDA1, LDA2, N, SINV DOUBLE PRECISION C1, C2, S1, S2 C .. Array Arguments .. INTEGER AMAP(*), S(*) DOUBLE PRECISION A(LDA1,LDA2,*), DWORK(*) C .. Local Scalars .. LOGICAL ISC, SGLE INTEGER I, II, IN1, IN2, IND, IR, J, L, NN DOUBLE PRECISION E1, E2, MD, MXC, MXR, P1, P2, P3, PR, SM C .. Local Arrays .. DOUBLE PRECISION Z(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAPY2 EXTERNAL LSAME, DLAPY2 C .. External Subroutines .. EXTERNAL DCOPY, DLAHQR, DLARTG, DLASET, DTRMM, DTRMV, $ DTRSM C .. Intrinsic Functions .. INTRINSIC ABS C C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked for errors. C C Evaluate the matrix product. C SGLE = LSAME( SHFT, 'S' ) C NN = N*N IR = NN + 1 II = IR + N CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK, N ) C DO 10 J = 1, K - 1 I = AMAP(J) IF ( S(I).EQ.SINV ) THEN CALL DTRMM( 'Right', 'Upper', 'NoTran', 'NonUnit', N, N, $ ONE, A(1,1,I), LDA1, DWORK, N ) ELSE CALL DTRSM( 'Right', 'Upper', 'NoTran', 'NonUnit', N, N, $ ONE, A(1,1,I), LDA1, DWORK, N ) END IF 10 CONTINUE C C Compute in DWORK(IR:IR+N-1) the last column of the product. C I = AMAP(K) CALL DCOPY( N, A(1,N,I), 1, DWORK(IR), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NonUnit', N, DWORK, N, $ DWORK(IR), 1 ) J = IR - N C DO 20 L = N - 1, 1, -1 CALL DCOPY( L+1, A(1,L,I), 1, DWORK(II), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NonUnit', L+1, DWORK, N, $ DWORK(II), 1 ) CALL DCOPY( L+1, DWORK(II), 1, DWORK(J), 1 ) J = J - N 20 CONTINUE C DO 30 L = 1, N CALL DCOPY( L+1, DWORK(J+N), 1, DWORK(J), 1 ) J = J + N 30 CONTINUE C IF ( SGLE ) THEN CALL DLARTG( DWORK(1) - DWORK(NN), DWORK(2), C1, S1, E1 ) C2 = ONE S2 = ZERO ELSE C C Save the needed elements of the product. C E1 = DWORK(1) E2 = DWORK(2) P1 = DWORK(N+1) P2 = DWORK(N+2) P3 = DWORK(N+3) C C Compute eigenvalues of the product. C CALL DLAHQR( .FALSE., .FALSE., N, 1, N, DWORK, N, DWORK(IR), $ DWORK(II), 1, 1, Z, 1, IND ) C C Find two eigenvalues with the largest moduli. C If there are complex eigenvalues, selection is based on them. C IND = 0 IN2 = 0 ISC = .FALSE. MXC = ZERO MXR = ZERO C DO 40 I = II, II + N - 1 IF ( DWORK(I).NE.ZERO ) THEN ISC = .TRUE. MD = DLAPY2( DWORK( I-N ), DWORK( I ) ) IF ( MD.GT.MXC ) THEN MXC = MD IND = I END IF ELSE MD = ABS( DWORK( I-N ) ) IN1 = IN2 IF ( MD.GT.MXR ) THEN MXR = MD IN2 = I - N END IF END IF 40 CONTINUE C IF ( ISC ) THEN SM = TWO*DWORK(IND-N) PR = MXC**2 ELSE IF ( IN1.EQ.IN2 ) THEN MXR = ZERO SM = DWORK(IN2) DWORK(IN2) = ZERO C DO 50 I = IR, IR + N - 1 MD = ABS( DWORK( I ) ) IF ( MD.GT.MXR ) THEN MXR = MD IN1 = I END IF 50 CONTINUE C DWORK(IN2) = SM END IF SM = DWORK(IN1) + DWORK(IN2) PR = DWORK(IN1) * DWORK(IN2) END IF C C Compute a multiple of the first column of the real Wilkinson C double shift polynomial, having only three nonzero elements. C P1 = P1 + ( ( E1 - SM )*E1 + PR )/E2 P2 = P2 + E1 - SM C C Compute the rotations to annihilate P2 and P3. C CALL DLARTG( P2, P3, C2, S2, E1 ) CALL DLARTG( P1, E1, C1, S1, E2 ) END IF C RETURN C *** Last line of MB03AI *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01DD.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01DD.f0000644000175000017500000002141015012430707017352 0ustar00lilgelilge00000000000000 SUBROUTINE TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC, Z, LDZ, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To reduce the descriptor system pair (C,A-lambda E) to the C RQ-coordinate form by computing an orthogonal transformation C matrix Z such that the transformed descriptor system pair C (C*Z,A*Z-lambda E*Z) has the descriptor matrix E*Z in an upper C trapezoidal form. C The right orthogonal transformations performed to reduce E can C be optionally accumulated. C C ARGUMENTS C C Mode Parameters C C COMPZ CHARACTER*1 C = 'N': do not compute Z; C = 'I': Z is initialized to the unit matrix, and the C orthogonal matrix Z is returned; C = 'U': Z must contain an orthogonal matrix Z1 on entry, C and the product Z1*Z is returned. C C Input/Output Parameters C C L (input) INTEGER C The number of rows of matrices A and E. L >= 0. C C N (input) INTEGER C The number of columns of matrices A, E, and C. N >= 0. C C P (input) INTEGER C The number of rows of matrix C. P >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the state dynamics matrix A. C On exit, the leading L-by-N part of this array contains C the transformed matrix A*Z. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,L). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the descriptor matrix E. C On exit, the leading L-by-N part of this array contains C the transformed matrix E*Z in upper trapezoidal form, C i.e. C C ( E11 ) C E*Z = ( ) , if L >= N , C ( R ) C or C C E*Z = ( 0 R ), if L < N , C C where R is an MIN(L,N)-by-MIN(L,N) upper triangular C matrix. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,L). 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Z. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C If COMPZ = 'N': Z is not referenced. C If COMPZ = 'I': on entry, Z need not be set; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix Z, C which is the product of Householder C transformations applied to A, E, and C C on the right. C If COMPZ = 'U': on entry, the leading N-by-N part of this C array must contain an orthogonal matrix C Z1; C on exit, the leading N-by-N part of this C array contains the orthogonal matrix C Z1*Z. C C LDZ INTEGER C The leading dimension of array Z. C LDZ >= 1, if COMPZ = 'N'; C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. 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 length of the array DWORK. C LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)). C For optimum performance C LWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)*NB), C where NB is the optimal blocksize. 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 the RQ factorization of E to reduce it C the upper trapezoidal form. C C The transformations are also applied to the rest of system C matrices C C A <- A * Z, C <- C * Z. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( L*N*N ) floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C March 1999. Based on the RASP routine RPDSRQ. C C REVISIONS C C July 1999, V. Sima, Research Institute for Informatics, Bucharest. C C KEYWORDS C C Descriptor system, matrix algebra, matrix operations, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, L, LDA, LDC, LDE, LDWORK, LDZ, N, P C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), $ E( LDE, * ), Z( LDZ, * ) C .. Local Scalars .. LOGICAL ILZ INTEGER ICOMPZ, LN, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGERQF, DLASET, DORMRQ, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C C .. Executable Statements .. C C Decode COMPZ. C IF( LSAME( COMPZ, 'N' ) ) THEN ILZ = .FALSE. ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'U' ) ) THEN ILZ = .TRUE. ICOMPZ = 2 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ILZ = .TRUE. ICOMPZ = 3 ELSE ICOMPZ = 0 END IF C C Test the input parameters. C INFO = 0 WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, P ) ) IF( ICOMPZ.EQ.0 ) THEN INFO = -1 ELSE IF( L.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( P.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, L ) ) THEN INFO = -6 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -8 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -10 ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN INFO = -12 ELSE IF( LDWORK.LT.WRKOPT ) THEN INFO = -14 END IF IF( INFO .NE. 0 ) THEN CALL XERBLA( 'TG01DD', -INFO ) RETURN END IF C C Initialize Q if necessary. C IF( ICOMPZ.EQ.3 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) C C Quick return if possible. C IF( L.EQ.0 .OR. N.EQ.0 ) THEN DWORK( 1 ) = ONE RETURN END IF C LN = MIN( L, N ) C C Compute the RQ decomposition of E, E = R*Z. C C Workspace: need MIN(L,N) + L; C prefer MIN(L,N) + L*NB. C CALL DGERQF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) C C Apply transformation on the rest of matrices. C C A <-- A * Z'. C Workspace: need MIN(L,N) + L; C prefer MIN(L,N) + L*NB. C CALL DORMRQ( 'Right', 'Transpose', L, N, LN, E( L-LN+1,1 ), LDE, $ DWORK, A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) C C C <-- C * Z'. C Workspace: need MIN(L,N) + P; C prefer MIN(L,N) + P*NB. C CALL DORMRQ( 'Right', 'Transpose', P, N, LN, E( L-LN+1,1 ), LDE, $ DWORK, C, LDC, DWORK( LN+1 ), LDWORK-LN, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) C C Z <-- Z1 * Z'. C Workspace: need MIN(L,N) + N; C prefer MIN(L,N) + N*NB. C IF( ILZ ) THEN CALL DORMRQ( 'Right', 'Transpose', N, N, LN, E( L-LN+1,1 ), $ LDE, DWORK, Z, LDZ, DWORK( LN+1 ), LDWORK-LN, $ INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) END IF C C Set lower triangle of E to zero. C IF( L.LT.N ) THEN CALL DLASET( 'Full', L, N-L, ZERO, ZERO, E, LDE ) IF( L.GE.2 ) CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, $ E( 2, N-L+1 ), LDE ) ELSE IF( N.GE.2 ) CALL DLASET( 'Lower', N-1, N, ZERO, ZERO, $ E( L-N+2, 1 ), LDE ) END IF C DWORK(1) = WRKOPT C RETURN C *** Last line of TG01DD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01ID.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB01ID.f0000644000175000017500000002637615012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE TB01ID( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ SCALE, INFO ) C C PURPOSE C C To reduce the 1-norm of a system matrix C C S = ( A B ) C ( C 0 ) C C corresponding to the triple (A,B,C), by balancing. This involves C a diagonal similarity transformation inv(D)*A*D applied C iteratively to A to make the rows and columns of C -1 C diag(D,I) * S * diag(D,I) C C as close in norm as possible. C C The balancing can be performed optionally on the following C particular system matrices C C S = A, S = ( A B ) or S = ( A ) C ( C ) C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Indicates which matrices are involved in balancing, as C follows: C = 'A': All matrices are involved in balancing; C = 'B': B and A matrices are involved in balancing; C = 'C': C and A matrices are involved in balancing; C = 'N': B and C matrices are not involved in balancing. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A, the number of rows of matrix B C and the number of columns of matrix C. C N represents the dimension of the state vector. N >= 0. C C M (input) INTEGER. C The number of columns of matrix B. C M represents the dimension of input vector. M >= 0. C C P (input) INTEGER. C The number of rows of matrix C. C P represents the dimension of output vector. P >= 0. C C MAXRED (input/output) DOUBLE PRECISION C On entry, the maximum allowed reduction in the 1-norm of C S (in an iteration) if zero rows or columns are C encountered. C If MAXRED > 0.0, MAXRED must be larger than one (to enable C the norm reduction). C If MAXRED <= 0.0, then the value 10.0 for MAXRED is C used. C On exit, if the 1-norm of the given matrix S is non-zero, C the ratio between the 1-norm of the given matrix and the C 1-norm of the balanced matrix. 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 system state matrix A. C On exit, the leading N-by-N part of this array contains C the balanced matrix inv(D)*A*D. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, if M > 0, the leading N-by-M part of this array C must contain the system input matrix B. C On exit, if M > 0, the leading N-by-M part of this array C contains the balanced matrix inv(D)*B. C The array B is not referenced if M = 0. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N) if M > 0. C LDB >= 1 if M = 0. C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) C On entry, if P > 0, the leading P-by-N part of this array C must contain the system output matrix C. C On exit, if P > 0, the leading P-by-N part of this array C contains the balanced matrix C*D. C The array C is not referenced if P = 0. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C SCALE (output) DOUBLE PRECISION array, dimension (N) C The scaling factors applied to S. If D(j) is the scaling C factor applied to row and column j, then SCALE(j) = D(j), C for j = 1,...,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 METHOD C C Balancing consists of applying a diagonal similarity C transformation C -1 C diag(D,I) * S * diag(D,I) C C to make the 1-norms of each row of the first N rows of S and its C corresponding column nearly equal. C C Information about the diagonal matrix D is returned in the vector C SCALE. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. C This subroutine is based on LAPACK routine DGEBAL, and routine C BALABC (A. Varga, German Aerospace Research Establishment, DLR). C C REVISIONS C C - C C KEYWORDS C C Balancing, eigenvalue, matrix algebra, matrix operations, C similarity transformation. C C ********************************************************************* C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION SCLFAC PARAMETER ( SCLFAC = 1.0D+1 ) DOUBLE PRECISION FACTOR, MAXR PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER JOB INTEGER INFO, LDA, LDB, LDC, M, N, P DOUBLE PRECISION MAXRED C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ SCALE( * ) C .. C .. Local Scalars .. LOGICAL NOCONV, WITHB, WITHC INTEGER I, ICA, IRA, J DOUBLE PRECISION CA, CO, F, G, MAXNRM, RA, RO, S, SFMAX1, $ SFMAX2, SFMIN1, SFMIN2, SNORM, SRED C .. C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DASUM, DLAMCH EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME C .. C .. External Subroutines .. EXTERNAL DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. C .. Executable Statements .. C C Test the scalar input arguments. C INFO = 0 WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) C IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, '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( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( ( M.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. $ ( M.EQ.0 .AND. LDB.LT.1 ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TB01ID', -INFO ) RETURN END IF C IF( N.EQ.0 ) $ RETURN C C Compute the 1-norm of the required part of matrix S and exit if C it is zero. C SNORM = ZERO C DO 10 J = 1, N SCALE( J ) = ONE CO = DASUM( N, A( 1, J ), 1 ) IF( WITHC .AND. P.GT.0 ) $ CO = CO + DASUM( P, C( 1, J ), 1 ) SNORM = MAX( SNORM, CO ) 10 CONTINUE C IF( WITHB ) THEN C DO 20 J = 1, M SNORM = MAX( SNORM, DASUM( N, B( 1, J ), 1 ) ) 20 CONTINUE C END IF C IF( SNORM.EQ.ZERO ) $ RETURN C C Set some machine parameters and the maximum reduction in the C 1-norm of S if zero rows or columns are encountered. C SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) SFMAX1 = ONE / SFMIN1 SFMIN2 = SFMIN1*SCLFAC SFMAX2 = ONE / SFMIN2 C SRED = MAXRED IF( SRED.LE.ZERO ) SRED = MAXR C MAXNRM = MAX( SNORM/SRED, SFMIN1 ) C C Balance the matrix. C C Iterative loop for norm reduction. C 30 CONTINUE NOCONV = .FALSE. C DO 90 I = 1, N CO = ZERO RO = ZERO C DO 40 J = 1, N IF( J.EQ.I ) $ GO TO 40 CO = CO + ABS( A( J, I ) ) RO = RO + ABS( A( I, J ) ) 40 CONTINUE C ICA = IDAMAX( N, A( 1, I ), 1 ) CA = ABS( A( ICA, I ) ) IRA = IDAMAX( N, A( I, 1 ), LDA ) RA = ABS( A( I, IRA ) ) C IF( WITHC .AND. P.GT.0 ) THEN CO = CO + DASUM( P, C( 1, I ), 1 ) ICA = IDAMAX( P, C( 1, I ), 1 ) CA = MAX( CA, ABS( C( ICA, I ) ) ) END IF C IF( WITHB .AND. M.GT.0 ) THEN RO = RO + DASUM( M, B( I, 1 ), LDB ) IRA = IDAMAX( M, B( I, 1 ), LDB ) RA = MAX( RA, ABS( B( I, IRA ) ) ) END IF C C Special case of zero CO and/or RO. C IF( CO.EQ.ZERO .AND. RO.EQ.ZERO ) $ GO TO 90 IF( CO.EQ.ZERO ) THEN IF( RO.LE.MAXNRM ) $ GO TO 90 CO = MAXNRM END IF IF( RO.EQ.ZERO ) THEN IF( CO.LE.MAXNRM ) $ GO TO 90 RO = MAXNRM END IF C C Guard against zero CO or RO due to underflow. C G = RO / SCLFAC F = ONE S = CO + RO 50 CONTINUE IF( CO.GE.G .OR. MAX( F, CO, CA ).GE.SFMAX2 .OR. $ MIN( RO, G, RA ).LE.SFMIN2 )GO TO 60 F = F*SCLFAC CO = CO*SCLFAC CA = CA*SCLFAC G = G / SCLFAC RO = RO / SCLFAC RA = RA / SCLFAC GO TO 50 C 60 CONTINUE G = CO / SCLFAC 70 CONTINUE IF( G.LT.RO .OR. MAX( RO, RA ).GE.SFMAX2 .OR. $ MIN( F, CO, G, CA ).LE.SFMIN2 )GO TO 80 F = F / SCLFAC CO = CO / SCLFAC CA = CA / SCLFAC G = G / SCLFAC RO = RO*SCLFAC RA = RA*SCLFAC GO TO 70 C C Now balance. C 80 CONTINUE IF( ( CO+RO ).GE.FACTOR*S ) $ GO TO 90 IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN IF( F*SCALE( I ).LE.SFMIN1 ) $ GO TO 90 END IF IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN IF( SCALE( I ).GE.SFMAX1 / F ) $ GO TO 90 END IF G = ONE / F SCALE( I ) = SCALE( I )*F NOCONV = .TRUE. C CALL DSCAL( N, G, A( I, 1 ), LDA ) CALL DSCAL( N, F, A( 1, I ), 1 ) IF( M.GT.0 ) CALL DSCAL( M, G, B( I, 1 ), LDB ) IF( P.GT.0 ) CALL DSCAL( P, F, C( 1, I ), 1 ) C 90 CONTINUE C IF( NOCONV ) $ GO TO 30 C C Set the norm reduction parameter. C MAXRED = SNORM SNORM = ZERO C DO 100 J = 1, N CO = DASUM( N, A( 1, J ), 1 ) IF( WITHC .AND. P.GT.0 ) $ CO = CO + DASUM( P, C( 1, J ), 1 ) SNORM = MAX( SNORM, CO ) 100 CONTINUE C IF( WITHB ) THEN C DO 110 J = 1, M SNORM = MAX( SNORM, DASUM( N, B( 1, J ), 1 ) ) 110 CONTINUE C END IF MAXRED = MAXRED/SNORM RETURN C *** Last line of TB01ID *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03BZ.f0000644000000000000000000000013215012430707016205 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SG03BZ.f0000644000175000017500000007767015012430707017422 0ustar00lilgelilge00000000000000 SUBROUTINE SG03BZ( DICO, FACT, TRANS, N, M, A, LDA, E, LDE, Q, $ LDQ, Z, LDZ, B, LDB, SCALE, ALPHA, BETA, DWORK, $ ZWORK, LZWORK, INFO ) C C PURPOSE C C To compute the Cholesky factor U of the matrix X, C C H C X = op(U) * op(U), C C which is the solution of either the generalized c-stable C continuous-time Lyapunov equation C C H H C op(A) * X * op(E) + op(E) * X * op(A) C C 2 H C = - SCALE * op(B) * op(B), (1) C C or the generalized d-stable discrete-time Lyapunov equation C C H H C op(A) * X * op(A) - op(E) * X * op(E) C C 2 H C = - SCALE * op(B) * op(B), (2) C C without first finding X and without the need to form the matrix C op(B)**H * op(B). C C op(K) is either K or K**H for K = A, B, E, U. A and E are N-by-N C matrices, op(B) is an M-by-N matrix. The resulting matrix U is an C N-by-N upper triangular matrix with non-negative entries on its C main diagonal. SCALE is an output scale factor set to avoid C overflow in U. C C In the continuous-time case (1) the pencil A - lambda * E must be C c-stable (that is, all eigenvalues must have negative real parts). C In the discrete-time case (2) the pencil A - lambda * E must be C d-stable (that is, the moduli of all eigenvalues must be smaller C than one). 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 FACT CHARACTER*1 C Specifies whether the generalized (complex) Schur C factorization of the pencil A - lambda * E is supplied on C entry or not: C = 'N': Factorization is not supplied; C = 'F': Factorization is supplied. C C TRANS CHARACTER*1 C Specifies whether the conjugate transposed equation is to C be solved or not: C = 'N': op(A) = A, op(E) = E; C = 'C': op(A) = A**H, op(E) = E**H. 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 number of rows in the matrix op(B). M >= 0. C If M = 0, A and E are unchanged on exit, and Q, Z, ALPHA C and BETA are not set. C C A (input/output) COMPLEX*16 array, dimension (LDA,N) C On entry, if FACT = 'F', then the leading N-by-N upper C triangular part of this array must contain the generalized C Schur factor A_s of the matrix A (see definition (3) in C section METHOD). A_s must be an upper triangular matrix. C The elements below the upper triangular part of the array C A are used as workspace. C If FACT = 'N', then the leading N-by-N part of this array C must contain the matrix A. C On exit, if FACT = 'N', the leading N-by-N upper C triangular part of this array contains the generalized C Schur factor A_s of the matrix A. (A_s is an upper C triangular matrix.) If FACT = 'F', the leading N-by-N C upper triangular part of this array is unchanged. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C E (input/output) COMPLEX*16 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 generalized C Schur factor E_s of the matrix E (see definition (4) in C section METHOD). E_s must be an upper triangular matrix. C The elements below the upper triangular part of the array C E are used as workspace. C If FACT = 'N', then the leading N-by-N part of this array C must contain the coefficient matrix E of the equation. C On exit, if FACT = 'N', the leading N-by-N upper C triangular part of this array contains the generalized C Schur factor E_s of the matrix E. (E_s is an upper C triangular matrix.) If FACT = 'F', the leading N-by-N C upper triangular part of this array is unchanged. C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,N). C C Q (input/output) COMPLEX*16 array, dimension (LDQ,N) C On entry, if FACT = 'F', then the leading N-by-N part of C this array must contain the unitary matrix Q from the C generalized Schur factorization (see definitions (3) and C (4) in section METHOD), or an identity matrix (if the C original equation has upper triangular matrices A and E). C If FACT = 'N', Q need not be set on entry. C On exit, if FACT = 'N', the leading N-by-N part of this C array contains the unitary matrix Q from the generalized C Schur factorization. If FACT = 'F', this array is C unchanged. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= MAX(1,N). C C Z (input/output) COMPLEX*16 array, dimension (LDZ,N) C On entry, if FACT = 'F', then the leading N-by-N part of C this array must contain the unitary matrix Z from the C generalized Schur factorization (see definitions (3) and C (4) in section METHOD), or an identity matrix (if the C original equation has upper triangular matrices A and E). C If FACT = 'N', Z need not be set on entry. C On exit, if FACT = 'N', the leading N-by-N part of this C array contains the unitary matrix Z from the generalized C Schur factorization. If FACT = 'F', this array is C unchanged. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1,N). C C B (input/output) COMPLEX*16 array, dimension (LDB,N1) C On entry, if TRANS = 'C', the leading N-by-M part of this C array must contain the matrix B and N1 >= MAX(M,N). C If TRANS = 'N', the leading M-by-N part of this array C must contain the matrix B and N1 >= N. C On exit, if INFO = 0, the leading N-by-N part of this C array contains the Cholesky factor U of the solution C matrix X of the problem, X = op(U)**H * op(U). C If M = 0 and N > 0, then U is set to zero. C C LDB INTEGER C The leading dimension of the array B. C If TRANS = 'C', LDB >= MAX(1,N). C If TRANS = 'N', LDB >= MAX(1,M,N). C C SCALE (output) DOUBLE PRECISION C The scale factor set to avoid overflow in U. C 0 < SCALE <= 1. C C ALPHA (output) COMPLEX*16 arrays, dimension (N) C BETA If INFO = 0, 5, 6, or 7, then ALPHA(j)/BETA(j), C j = 1, ... , N, are the eigenvalues of the matrix pencil C A - lambda * E (the diagonals of the complex Schur form). C All BETA(j) are non-negative real numbers. C ALPHA will be always less than and usually comparable with C norm(A) in magnitude, and BETA always less than and C usually comparable with norm(B). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK), where C LDWORK = 0, if MIN(M,N) = 0 or C FACT = 'F' and N <= 1; else, C LDWORK = N-1, if FACT = 'F' and DICO = 'C'; C LDWORK = MAX(N-1,10), if FACT = 'F' and DICO = 'D'; C LDWORK = 8*N, if FACT = 'N'. C C ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal value C of LZWORK. C On exit, if INFO = -21, ZWORK(1) returns the minimum value C of LZWORK. C C LZWORK INTEGER C The dimension of the array ZWORK. C LZWORK >= MAX(1,3*N-3,2*N). C For good performance, LZWORK should be larger. C C If LZWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the ZWORK C array, returns this value as the first entry of the ZWORK C array, and no error message related to LZWORK is issued by C 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 = 4: FACT = 'N' and the pencil A - lambda * E cannot be C reduced to generalized Schur form: LAPACK routine C ZGGES has failed to converge; C = 5: DICO = 'C' and the pencil A - lambda * E is not C c-stable; C = 6: DICO = 'D' and the pencil A - lambda * E is not C d-stable; C = 7: the LAPACK routine ZSTEIN utilized to factorize M3 C failed to converge in the discrete-time case (see C section METHOD for SLICOT Library routine SG03BS). C This error is unlikely to occur. C C METHOD C C An extension [2] of Hammarling's method [1] to generalized C Lyapunov equations is utilized to solve (1) or (2). C C First the pencil A - lambda * E is reduced to complex generalized C Schur form A_s - lambda * E_s by means of unitary transformations C (QZ-algorithm): C C A_s = Q**H * A * Z (upper triangular), (3) C C E_s = Q**H * E * Z (upper triangular). (4) C C If the pencil A - lambda * E has already been factorized prior to C calling the routine, however, then the factors A_s, E_s, Q and Z C may be supplied and the initial factorization omitted. C C Depending on the parameters TRANS and M, the N-by-N upper C triangular matrix B_s is defined as follows. In any case Q_B is C an M-by-M unitary matrix, which need not be accumulated. C C 1. If TRANS = 'N' and M < N, B_s is the upper triangular matrix C from the QR-factorization C C ( Q_B O ) ( B * Z ) C ( ) * B_s = ( ), C ( O I ) ( O ) C C where the O's are zero matrices of proper size and I is the C identity matrix of order N-M. C C 2. If TRANS = 'N' and M >= N, B_s is the upper triangular matrix C from the (rectangular) QR-factorization C C ( B_s ) C Q_B * ( ) = B * Z, C ( O ) C C where O is the (M-N)-by-N zero matrix. C C 3. If TRANS = 'C' and M < N, B_s is the upper triangular matrix C from the RQ-factorization C C ( Q_B O ) C (B_s O ) * ( ) = ( Q**H * B O ). C ( O I ) C C 4. If TRANS = 'C' and M >= N, B_s is the upper triangular matrix C from the (rectangular) RQ-factorization C C ( B_s O ) * Q_B = Q**H * B, C C where O is the N-by-(M-N) zero matrix. C C Assuming SCALE = 1, the transformation of A, E and B described C above leads to the reduced continuous-time equation C C H H C op(A_s) op(U_s) op(U_s) op(E_s) C C H H C + op(E_s) op(U_s) op(U_s) op(A_s) C C H C = - op(B_s) op(B_s) (5) C C or to the reduced discrete-time equation C C H H C op(A_s) op(U_s) op(U_s) op(A_s) C C H H C - op(E_s) op(U_s) op(U_s) op(E_s) C C H C = - op(B_s) op(B_s). (6) C C For brevity we restrict ourself to equation (5) and the case C TRANS = 'N'. The other three cases can be treated in a similar C fashion. C C We use the following partitioning for the matrices A_s, E_s, B_s, C and U_s C C ( A11 A12 ) ( E11 E12 ) C A_s = ( ), E_s = ( ), C ( 0 A22 ) ( 0 E22 ) C C ( B11 B12 ) ( U11 U12 ) C B_s = ( ), U_s = ( ). (7) C ( 0 B22 ) ( 0 U22 ) C C The size of the (1,1)-blocks is 1-by-1. C C We compute U11, U12**H, and U22 in three steps. C C Step I: C C From (5) and (7) we get the 1-by-1 equation C C H H H H C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 C C H C = - B11 * B11. C C For brevity, details are omitted here. See [2]. The technique C for computing U11 is similar to those applied to standard C Lyapunov equations in Hammarling's algorithm ([1], section 5). C C Furthermore, the auxiliary scalars M1 and M2 defined as follows C C M1 = A11 / E11 , C C M2 = B11 / E11 / U11 , C C are computed in a numerically reliable way. C C Step II: C C The generalized Sylvester equation C C H H H H C A22 * U12 + E22 * U12 * M1 = C C H H H H H C - B12 * M2 - A12 * U11 - E12 * U11 * M1 C C is solved for U12**H, as a linear system of order N-1. C C Step III: C C It can be shown that C C H H H H C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = C C H H C - B22 * B22 - y * y (8) C C holds, where y is defined as C C H H H H H C y = B12 - ( E12 * U11 + E22 * U12 ) * M2 . C C If B22_tilde is the square triangular matrix arising from the C (rectangular) QR-factorization C C ( B22_tilde ) ( B22 ) C Q_B_tilde * ( ) = ( ), C ( O ) ( y**H ) C C where Q_B_tilde is a unitary matrix of order N, then C C H H H C - B22 * B22 - y * y = - B22_tilde * B22_tilde. C C Replacing the right hand side in (8) by the term C - B22_tilde**H * B22_tilde leads to a reduced generalized C Lyapunov equation like (5), but of dimension N-1. C C The recursive application of the steps I to III yields the C solution U_s of the equation (5). C C It remains to compute the solution matrix U of the original C problem (1) or (2) from the matrix U_s. To this end we transform C the solution back (with respect to the transformation that led C from (1) to (5) (from (2) to (6)) and apply the QR-factorization C (RQ-factorization). The upper triangular solution matrix U is C obtained by C C Q_U * U = U_s * Q**H (if TRANS = 'N'), C C or C C U * Q_U = Z * U_s (if TRANS = 'C'), C C where Q_U is an N-by-N unitary matrix. Again, the unitary matrix C Q_U need not be accumulated. C C REFERENCES C C [1] Hammarling, S.J. C Numerical solution of the stable, non-negative definite C Lyapunov equation. C IMA J. Num. Anal., 2, pp. 303-323, 1982. 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 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 C | FACT = 'F' FACT = 'N' C ---------+-------------------------------------------------- C M <= N | (13*N**3+6*M*N**2 (211*N**3+6*M*N**2 C | +6*M**2*N-2*M**3)/3 +6*M**2*N-2*M**3)/3 C | C M > N | (11*N**3+12*M*N**2)/3 (209*N**3+12*M*N**2)/3 C C FURTHER COMMENTS 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 A condition estimate can be obtained from the routine SG03AD. C C CONTRIBUTOR C C V. Sima, June 2021. C C REVISIONS C C V. Sima, July 2021, Oct. 2021 - Feb. 2022. 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 ) COMPLEX*16 CONE, CZERO PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), $ CZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. DOUBLE PRECISION SCALE INTEGER INFO, LDA, LDB, LDE, LDQ, LDZ, LZWORK, M, N CHARACTER DICO, FACT, TRANS C .. Array Arguments .. COMPLEX*16 A(LDA,*), ALPHA(*), B(LDB,*), BETA(*), E(LDE,*), $ Q(LDQ,*), Z(LDZ,*), ZWORK(*) DOUBLE PRECISION DWORK(*) C .. Local Scalars .. DOUBLE PRECISION BIGNMS, BIGNUM, EPS, MA, MATO, MB, MBTO, ME, $ METO, MN, MX, SMLNUM, T, TMP INTEGER BL, I, INFO1, J, K, L, MAXMN, MINMN, MINWRK, NC, $ NR, OPTWRK LOGICAL ISDISC, ISFACT, ISTRAN, LASCL, LBSCL, LESCL, $ LQUERY, LSCL, NUNITQ, NUNITZ, SCALB C .. Local Arrays .. LOGICAL BWORK(1) C .. External Functions .. DOUBLE PRECISION DLAMCH, ZLANGE, ZLANTR LOGICAL DELCTG, LSAME, MA02HZ EXTERNAL DELCTG, DLAMCH, LSAME, MA02HZ, ZLANGE, ZLANTR C .. External Subroutines .. EXTERNAL DLABAD, MB01UZ, SG03BS, SG03BT, XERBLA, ZCOPY, $ ZDSCAL, ZGEMM, ZGEQRF, ZGERQF, ZGGES, ZLACGV, $ ZLACPY, ZLASCL, ZLASET, ZSWAP C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SIGN, SQRT C .. Executable Statements .. C C Decode input parameters. C ISDISC = LSAME( DICO, 'D' ) ISFACT = LSAME( FACT, 'F' ) ISTRAN = LSAME( TRANS, 'C' ) LQUERY = LZWORK.EQ.-1 C C Check the scalar input parameters. C INFO = 0 IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN INFO = -1 ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT, 'N' ) ) ) THEN INFO = -2 ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN INFO = -3 ELSEIF ( N.LT.0 ) THEN INFO = -4 ELSEIF ( M.LT.0 ) THEN INFO = -5 ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSEIF ( LDE.LT.MAX( 1, N ) ) THEN INFO = -9 ELSEIF ( LDQ.LT.MAX( 1, N ) ) THEN INFO = -11 ELSEIF ( LDZ.LT.MAX( 1, N ) ) THEN INFO = -13 ELSEIF ( ( ISTRAN .AND. ( LDB.LT.MAX( 1, N ) ) ) .OR. $ ( .NOT.ISTRAN .AND. ( LDB.LT.MAX( 1, M, N ) ) ) ) THEN INFO = -15 ELSE C C Compute minimal and optimal workspace. C MINWRK = MAX( 1, 2*N, 3*N-3 ) MAXMN = MAX( M, N ) IF ( LQUERY ) THEN OPTWRK = MINWRK IF ( .NOT.ISFACT ) THEN CALL ZGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, $ N, A, LDA, E, LDE, I, ALPHA, BETA, Q, LDQ, Z, $ LDZ, ZWORK, -1, DWORK, BWORK, INFO1 ) OPTWRK = MAX( OPTWRK, INT( ZWORK(1) ) ) END IF IF ( ISTRAN ) THEN CALL ZGERQF( N, MAXMN, B, LDB, ZWORK, ZWORK, -1, INFO1 ) ELSE CALL ZGEQRF( MAXMN, N, B, LDB, ZWORK, ZWORK, -1, INFO1 ) END IF OPTWRK = MAX( OPTWRK, INT( ZWORK(1) ) + N ) ELSEIF ( LZWORK.LT.MINWRK ) THEN ZWORK(1) = MINWRK INFO = -21 END IF END IF C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'SG03BZ', -INFO ) RETURN ELSE IF ( LQUERY ) THEN ZWORK(1) = OPTWRK RETURN END IF C SCALE = ONE C C Quick return if possible. C IF ( ISTRAN ) THEN K = N L = M ELSE K = M L = N END IF MB = ZLANGE( 'Max', K, L, B, LDB, DWORK ) IF ( MB.EQ.ZERO ) THEN IF ( N.GT.0 ) $ CALL ZLASET( 'Full', N, N, CZERO, CZERO, B, LDB ) ZWORK(1) = CONE RETURN END IF C C Set constants to control overflow. C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNMS = ONE/SMLNUM CALL DLABAD( SMLNUM, BIGNMS ) SMLNUM = SQRT( SMLNUM )/EPS BIGNUM = ONE/SMLNUM C IF ( .NOT.ISFACT ) THEN C C Reduce the pencil A - lambda * E to generalized Schur form. C C A := Q**H * A * Z (upper triangular), C E := Q**H * E * Z (upper triangular). C C The diagonal elements of E are non-negative real numbers. C C Workspace: complex >= MAX(1,2*N); prefer larger; C real = 8*N. C CALL ZGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N, A, $ LDA, E, LDE, I, ALPHA, BETA, Q, LDQ, Z, LDZ, ZWORK, $ LZWORK, DWORK, BWORK, INFO1 ) IF ( INFO1.NE.0 ) THEN INFO = 4 RETURN END IF C OPTWRK = INT( ZWORK(1) ) C ELSE C C Set the eigenvalues of the matrix pencil A - lambda * E. C CALL ZCOPY( N, A, LDA+1, ALPHA, 1 ) CALL ZCOPY( N, E, LDE+1, BETA, 1 ) OPTWRK = MINWRK END IF C C Check for identity matrices Q and/or Z. C NUNITQ = .NOT.MA02HZ( 'All', N, N, CONE, Q, LDQ ) NUNITZ = .NOT.MA02HZ( 'All', N, N, CONE, Z, LDZ ) C C Check on the stability of the matrix pencil A - lambda * E. C IF ( ISDISC ) THEN C DO 10 I = 1, N IF ( ABS( ALPHA(I) ).GE.DBLE( BETA(I) ) ) THEN INFO = 6 RETURN END IF 10 CONTINUE C ELSE C DO 20 I = 1, N IF ( ( ALPHA(I).EQ.CZERO ) .OR. ( BETA(I).EQ.CZERO ) .OR. $ ( SIGN( ONE, DBLE( ALPHA(I) ) )* $ SIGN( ONE, DBLE( BETA(I) ) ).GE.ZERO ) ) THEN INFO = 5 RETURN END IF 20 CONTINUE C END IF C C Scale A if the maximum absolute value of its elements is outside C the range [SMLNUM,BIGNUM]. Scale similarly E and B. The scaling C factors of E may be set equal to those for A, to preserve C stability in the discrete-time case. Scaling of B is done before C further processing if the maximum absolute value of its elements C is greater than BIGNMS; otherwise, it is postponed. Scaling is C also performed if the maximum absolute values of A, E, B differ C too much, or their minimum (maximum) is too large (small). C MA = MIN( ZLANTR( 'Max', 'Upper', 'NoDiag', N, N, A, LDA, DWORK ), $ BIGNMS ) ME = MIN( ZLANTR( 'Max', 'Upper', 'NoDiag', N, N, E, LDE, DWORK ), $ BIGNMS ) C MN = MIN( MA, ME, MB ) MX = MAX( MA, ME, MB ) C LSCL = MN.LT.MX*SMLNUM .OR. MX.LT.SMLNUM .OR. MN.GT.BIGNUM IF ( LSCL ) THEN MATO = ONE METO = ONE MBTO = ONE LASCL = .TRUE. LESCL = .TRUE. LBSCL = .TRUE. ELSE IF ( MA.GT.ZERO .AND. MA.LT.SMLNUM ) THEN MATO = SMLNUM LASCL = .TRUE. ELSE IF ( MA.GT.BIGNUM ) THEN MATO = BIGNUM LASCL = .TRUE. ELSE LASCL = .FALSE. END IF C IF ( ME.GT.ZERO .AND. ME.LT.SMLNUM ) THEN METO = SMLNUM LESCL = .TRUE. ELSE IF ( ME.GT.BIGNUM ) THEN METO = BIGNUM LESCL = .TRUE. ELSE LESCL = .FALSE. END IF C IF ( MB.GT.ZERO .AND. MB.LT.SMLNUM ) THEN MBTO = SMLNUM LBSCL = .TRUE. ELSE IF ( MB.GT.BIGNUM ) THEN MBTO = BIGNUM LBSCL = .TRUE. ELSE MBTO = ONE LBSCL = .FALSE. END IF END IF C IF ( ISDISC .AND. LASCL .AND. LESCL ) THEN IF ( MATO/MA.GT.METO/ME ) THEN ME = MA METO = MATO END IF END IF C IF ( LASCL ) $ CALL ZLASCL( 'Upper', 0, 0, MA, MATO, N, N, A, LDA, INFO ) IF ( LESCL ) $ CALL ZLASCL( 'Upper', 0, 0, ME, METO, N, N, E, LDE, INFO ) SCALB = MB.GT.BIGNMS MB = MIN( MB, BIGNMS ) IF ( LBSCL .AND. SCALB ) $ CALL ZLASCL( 'Gen', 0, 0, MB, MBTO, K, L, B, LDB, INFO ) C C Transformation of the right hand side: C C B := Q**H * B or B := B * Z. C C Workspace: need max(1,2*N); prefer larger. C IF ( ISTRAN ) THEN C IF ( NUNITQ ) THEN NC = INT( LZWORK / N ) C DO 30 J = 1, M, NC BL = MIN( M-J+1, NC ) CALL ZGEMM( 'ConjTrans', 'NoTrans', N, BL, N, CONE, Q, $ LDQ, B(1,J), LDB, CZERO, ZWORK, N ) CALL ZLACPY( 'All', N, BL, ZWORK, N, B(1,J), LDB ) 30 CONTINUE C END IF C ELSE C IF ( NUNITQ ) THEN NR = INT( LZWORK / N ) C DO 40 I = 1, M, NR BL = MIN( M-I+1, NR ) CALL ZGEMM( TRANS, 'NoTrans', BL, N, N, CONE, B(I,1), $ LDB, Z, LDZ, CZERO, ZWORK, BL ) CALL ZLACPY( 'All', BL, N, ZWORK, BL, B(I,1), LDB ) 40 CONTINUE C END IF C END IF C C Overwrite B with the triangular matrix of its RQ-factorization C or its QR-factorization. Then, do scaling, if it was postponed. C Make sure that the entries on the main diagonal are non-negative. C C Workspace: need max(1,MIN(M,N)+N); prefer larger. C MINMN = MIN( M, N ) IF ( ISTRAN ) THEN C CALL ZGERQF( N, M, B, LDB, ZWORK, ZWORK(N+1), LZWORK-N, INFO1 ) IF ( N.GE.M ) THEN IF ( LBSCL .AND. .NOT.SCALB ) THEN CALL ZLASCL( 'Gen', 0, 0, MB, MBTO, N-M, M, B, LDB, $ INFO ) CALL ZLASCL( 'Upper', 0, 0, MB, MBTO, M, M, B(N-M+1,1), $ LDB, INFO ) END IF IF ( N.GT.M ) THEN C DO 50 I = M, 1, -1 CALL ZCOPY( I+N-M, B(1,I), 1, B(1,I+N-M), 1 ) 50 CONTINUE C CALL ZLASET( 'All', N, N-M, CZERO, CZERO, B, LDB ) END IF IF ( M.GT.1 ) $ CALL ZLASET( 'Lower', M-1, M-1, CZERO, CZERO, $ B(N-M+2,N-M+1), LDB ) ELSE C DO 60 I = 1, N CALL ZCOPY( I, B(1,M-N+I), 1, B(1,I), 1 ) 60 CONTINUE C IF ( LBSCL .AND. .NOT.SCALB ) $ CALL ZLASCL( 'Upper', 0, 0, MB, MBTO, N, N, B, LDB, $ INFO ) IF ( N.GT.1 ) $ CALL ZLASET( 'Lower', N-1, N-1, CZERO, CZERO, B(2,1), $ LDB ) END IF C DO 70 I = N - MINMN + 1, N IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( I, MONE, B(1,I), 1 ) 70 CONTINUE C ELSE C CALL ZGEQRF( M, N, B, LDB, ZWORK, ZWORK(N+1), LZWORK-N, INFO1 ) IF ( LBSCL .AND. .NOT.SCALB ) $ CALL ZLASCL( 'Upper', 0, 0, MB, MBTO, M, N, B, LDB, INFO ) IF ( MAXMN.GT.1 ) $ CALL ZLASET( 'Lower', MAXMN-1, MINMN, CZERO, CZERO, B(2,1), $ LDB ) IF ( N.GT.M ) $ CALL ZLASET( 'All', N-M, N, CZERO, CZERO, B(M+1,1), LDB ) C DO 80 I = 1, MINMN IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( N+1-I, MONE, B(I,I), LDB ) 80 CONTINUE C END IF C C Solve the reduced generalized Lyapunov equation. C C Workspace: complex MAX(3*N-3,0); C real MAX(N-1,0), if DICO = 'C'; C 0, if DICO = 'D' and N <= 1; C MAX(N-1,10), if DICO = 'D' and N > 1. C IF ( ISDISC ) THEN CALL SG03BS( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, $ ZWORK, INFO1 ) IF ( INFO1.NE.0 ) THEN IF ( INFO1.EQ.3 ) $ INFO = 6 IF ( INFO1.EQ.4 ) $ INFO = 7 RETURN END IF ELSE CALL SG03BT( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, $ ZWORK, INFO1 ) IF ( INFO1.NE.0 ) THEN IF ( INFO1.EQ.3 ) $ INFO = 5 RETURN END IF END IF C C Transform the solution matrix back, if Z and/or Q are not unit: C C U := Z * U or U := U * Q**H ( U**H := Q * U**H). C IF ( ISTRAN ) THEN C IF ( NUNITZ ) THEN C C Workspace: max(1,N); prefer larger. C CALL MB01UZ( 'Right', 'Upper', 'NoTrans', N, N, CONE, B, $ LDB, Z, LDZ, ZWORK, LZWORK, INFO ) C C Overwrite U with the triangular matrix of its C RQ-factorization and make the entries on the main diagonal C non-negative. C C Workspace: >= max(1,2*N); prefer larger. C CALL ZGERQF( N, N, B, LDB, ZWORK, ZWORK(N+1), LZWORK-N, $ INFO1 ) IF ( N.GT.1 ) $ CALL ZLASET( 'Lower', N-1, N-1, CZERO, CZERO, B(2,1), $ LDB ) C DO 90 I = 1, N IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( I, MONE, B(1,I), 1 ) 90 CONTINUE C END IF C ELSE C IF ( NUNITQ ) THEN C C Workspace: max(1,N); prefer larger. C CALL MB01UZ( 'Right', 'Upper', 'CTrans', N, N, CONE, B, LDB, $ Q, LDQ, ZWORK, LZWORK, INFO ) C DO 100 I = 1, N CALL ZSWAP( I, B(I,1), LDB, B(1,I), 1 ) 100 CONTINUE C DO 110 I = 1, N CALL ZLACGV( N, B(1,I), 1 ) 110 CONTINUE C C Overwrite U with the triangular matrix of its C QR-factorization and make the entries on the main diagonal C non-negative. C C Workspace: >= max(1,2*N); prefer larger. C CALL ZGEQRF( N, N, B, LDB, ZWORK, ZWORK(N+1), LZWORK-N, $ INFO1 ) IF ( N.GT.1 ) $ CALL ZLASET( 'Lower', N-1, N-1, CZERO, CZERO, B(2,1), $ LDB ) C DO 120 I = 1, N IF ( DBLE( B(I,I) ).LT.ZERO ) $ CALL ZDSCAL( N+1-I, MONE, B(I,I), LDB ) 120 CONTINUE C END IF C END IF C C Undo the scaling of A, E, and B and update SCALE. C TMP = ONE IF ( LASCL ) THEN CALL ZLASCL( 'Upper', 0, 0, MATO, MA, N, N, A, LDA, INFO ) TMP = SQRT( MATO/MA ) END IF IF ( LESCL ) THEN CALL ZLASCL( 'Upper', 0, 0, METO, ME, N, N, E, LDE, INFO ) TMP = TMP*SQRT( METO/ME ) END IF IF ( LBSCL ) THEN MX = ZLANTR( 'Max', 'Upper', 'NoDiag', N, N, B, LDB, DWORK ) MN = MIN( TMP, MB ) T = MAX( TMP, MB ) IF ( T.GT.ONE ) THEN IF ( MN.GT.BIGNMS/T ) THEN SCALE = SCALE/T TMP = TMP/T END IF END IF TMP = TMP*MB IF ( TMP.GT.ONE ) THEN IF ( MX.GT.BIGNMS/TMP ) THEN SCALE = SCALE/MX TMP = TMP/MX END IF END IF END IF CALL ZLASCL( 'Upper', 0, 0, MBTO, TMP, N, N, B, LDB, INFO ) C OPTWRK = MAX( OPTWRK, INT( ZWORK(N+1) ) + N ) C ZWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) ) RETURN C *** Last line of SG03BZ *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04RV.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB04RV.f0000644000175000017500000001464515012430707017423 0ustar00lilgelilge00000000000000 SUBROUTINE SB04RV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, $ LDBA, D, DWORK ) C C PURPOSE C C To construct the right-hand sides D for a system of equations in C quasi-Hessenberg form solved via SB04RX (case with 2 right-hand C sides). C C ARGUMENTS C C Mode Parameters C C ABSCHR CHARACTER*1 C Indicates whether AB contains A or B, as follows: C = 'A': AB contains A; C = 'B': AB contains B. C C UL CHARACTER*1 C Indicates whether AB is upper or lower Hessenberg matrix, C as follows: C = 'U': AB is upper Hessenberg; C = 'L': AB is lower Hessenberg. 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 C (input) DOUBLE PRECISION array, dimension (LDC,M) C The leading N-by-M part of this array must contain both C the not yet modified part of the coefficient matrix C of C the Sylvester equation X + AXB = C, and both the currently C computed part of the solution of the Sylvester equation. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,N). C C INDX (input) INTEGER C The position of the first column/row of C to be used in C the construction of the right-hand side D. C C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) C The leading N-by-N or M-by-M part of this array must C contain either A or B of the Sylvester equation C X + AXB = C. C C LDAB INTEGER C The leading dimension of array AB. C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on C ABSCHR = 'A' or ABSCHR = 'B', respectively). C C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) C The leading N-by-N or M-by-M part of this array must C contain either A or B of the Sylvester equation C X + AXB = C, the matrix not contained in AB. C C LDBA INTEGER C The leading dimension of array BA. C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on C ABSCHR = 'B' or ABSCHR = 'A', respectively). C C D (output) DOUBLE PRECISION array, dimension (*) C The leading 2*N or 2*M part of this array (depending on C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the C right-hand side stored as a matrix with two rows. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C where LDWORK is equal to 2*N or 2*M (depending on C ABSCHR = 'B' or ABSCHR = 'A', respectively). C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C D. Sima, University of Bucharest, May 2000. C C REVISIONS C C - 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 .. CHARACTER ABSCHR, UL INTEGER INDX, LDAB, LDBA, LDC, M, N C .. Array Arguments .. DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMV C .. Executable Statements .. C C For speed, no tests on the input scalar arguments are made. C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 ) $ RETURN C IF ( LSAME( ABSCHR, 'B' ) ) THEN C C Construct the 2 columns of the right-hand side. C CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) IF ( LSAME( UL, 'U' ) ) THEN IF ( INDX.GT.1 ) THEN CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, $ ZERO, DWORK, 1 ) CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX+1), $ 1, ZERO, DWORK(N+1), 1 ) CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, $ D(1), 2 ) CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, $ ONE, D(2), 2 ) END IF ELSE IF ( INDX.LT.M-1 ) THEN CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, $ AB(INDX+2,INDX), 1, ZERO, DWORK, 1 ) CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, $ AB(INDX+2,INDX+1), 1, ZERO, DWORK(N+1), 1 ) CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, $ D(1), 2 ) CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, $ ONE, D(2), 2 ) END IF END IF ELSE C C Construct the 2 rows of the right-hand side. C CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) IF ( LSAME( UL, 'U' ) ) THEN IF ( INDX.LT.N-1 ) THEN CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, $ AB(INDX,INDX+2), LDAB, ZERO, DWORK, 1 ) CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, $ AB(INDX+1,INDX+2), LDAB, ZERO, DWORK(M+1), $ 1 ) CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, $ D(1), 2 ) CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, $ ONE, D(2), 2 ) END IF ELSE IF ( INDX.GT.1 ) THEN CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), $ LDAB, ZERO, DWORK, 1 ) CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX+1,1), $ LDAB, ZERO, DWORK(M+1), 1 ) CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, $ D(1), 2 ) CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, $ ONE, D(2), 2 ) END IF END IF END IF C RETURN C *** Last line of SB04RV *** END control-4.1.2/src/slicot/src/PaxHeaders/MA02ED.f0000644000000000000000000000013215012430707016145 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02ED.f0000644000175000017500000000433615012430707017347 0ustar00lilgelilge00000000000000 SUBROUTINE MA02ED( UPLO, N, A, LDA ) 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 control-4.1.2/src/slicot/src/PaxHeaders/AB09JW.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09JW.f0000644000175000017500000010651115012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE AB09JW( JOB, DICO, JOBEW, STBCHK, N, M, P, NW, MW, $ A, LDA, B, LDB, C, LDC, D, LDD, AW, LDAW, $ EW, LDEW, BW, LDBW, CW, LDCW, DW, LDDW, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To construct a state-space representation (A,BS,CS,DS) of the C projection of G*W or G*conj(W) containing the poles of G, from the C state-space representations (A,B,C,D) and (AW-lambda*EW,BW,CW,DW), C of the transfer-function matrices G and W, respectively. C G is assumed to be a stable transfer-function matrix and C the state matrix A must be in a real Schur form. C When computing the stable projection of G*W, it is assumed C that G and W have completely distinct poles. C When computing the stable projection of G*conj(W), it is assumed C that G and conj(W) have completely distinct poles. C C Note: For a transfer-function matrix G, conj(G) denotes the C conjugate of G given by G'(-s) for a continuous-time system or C G'(1/z) for a discrete-time system. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the projection to be computed as follows: C = 'W': compute the projection of G*W containing C the poles of G; C = 'C': compute the projection of G*conj(W) containing C the poles of G. C C DICO CHARACTER*1 C Specifies the type of the systems as follows: C = 'C': G and W are continuous-time systems; C = 'D': G and W are discrete-time systems. C C JOBEW CHARACTER*1 C Specifies whether EW is a general square or an identity C matrix as follows: C = 'G': EW is a general square matrix; C = 'I': EW is the identity matrix. C C STBCHK CHARACTER*1 C Specifies whether stability/antistability of W is to be C checked as follows: C = 'C': check stability if JOB = 'C' or antistability if C JOB = 'W'; C = 'N': do not check stability or antistability. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the state vector of the system with C the transfer-function matrix G. N >= 0. C C M (input) INTEGER C The dimension of the input vector of the system with C the transfer-function matrix G, and also the dimension C of the output vector if JOB = 'W', or of the input vector C if JOB = 'C', of the system with the transfer-function C matrix W. M >= 0. C C P (input) INTEGER C The dimension of the output vector of the system with the C transfer-function matrix G. P >= 0. C C NW (input) INTEGER C The dimension of the state vector of the system with the C transfer-function matrix W. NW >= 0. C C MW (input) INTEGER C The dimension of the input vector, if JOB = 'W', or of C the output vector, if JOB = 'C', of the system with the C transfer-function matrix W. MW >= 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 matrix A of the system with the transfer-function C matrix G in a real Schur form. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, C dimension (LDB,MAX(M,MW)) C On entry, the leading N-by-M part of this array must C contain the input matrix B of the system with the C transfer-function matrix G. C On exit, if INFO = 0, the leading N-by-MW part of this C array contains the input matrix BS of the projection of C G*W, if JOB = 'W', or of G*conj(W), if JOB = 'C'. 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 C the output/state matrix C of the system with the C transfer-function matrix G. The matrix CS is equal to C. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C D (input/output) DOUBLE PRECISION array, C dimension (LDB,MAX(M,MW)) C On entry, the leading P-by-M part of this array must C contain the feedthrough matrix D of the system with C the transfer-function matrix G. C On exit, if INFO = 0, the leading P-by-MW part of C this array contains the feedthrough matrix DS of the C projection of G*W, if JOB = 'W', or of G*conj(W), C if JOB = 'C'. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1,P). C C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) C On entry, the leading NW-by-NW part of this array must C contain the state matrix AW of the system with the C transfer-function matrix W. C On exit, if INFO = 0, the leading NW-by-NW part of this C array contains a condensed matrix as follows: C if JOBEW = 'I', it contains the real Schur form of AW; C if JOBEW = 'G' and JOB = 'W', it contains a quasi-upper C triangular matrix representing the real Schur matrix C in the real generalized Schur form of the pair (AW,EW); C if JOBEW = 'G', JOB = 'C' and DICO = 'C', it contains a C quasi-upper triangular matrix corresponding to the C generalized real Schur form of the pair (AW',EW'); C if JOBEW = 'G', JOB = 'C' and DICO = 'D', it contains an C upper triangular matrix corresponding to the generalized C real Schur form of the pair (EW',AW'). C C LDAW INTEGER C The leading dimension of the array AW. LDAW >= MAX(1,NW). C C EW (input/output) DOUBLE PRECISION array, dimension (LDEW,NW) C On entry, if JOBEW = 'G', the leading NW-by-NW part of C this array must contain the descriptor matrix EW of the C system with the transfer-function matrix W. C If JOBEW = 'I', EW is assumed to be an identity matrix C and is not referenced. C On exit, if INFO = 0 and JOBEW = 'G', the leading NW-by-NW C part of this array contains a condensed matrix as follows: C if JOB = 'W', it contains an upper triangular matrix C corresponding to the real generalized Schur form of the C pair (AW,EW); C if JOB = 'C' and DICO = 'C', it contains an upper C triangular matrix corresponding to the generalized real C Schur form of the pair (AW',EW'); C if JOB = 'C' and DICO = 'D', it contains a quasi-upper C triangular matrix corresponding to the generalized C real Schur form of the pair (EW',AW'). C C LDEW INTEGER C The leading dimension of the array EW. C LDEW >= MAX(1,NW), if JOBEW = 'G'; C LDEW >= 1, if JOBEW = 'I'. C C BW (input/output) DOUBLE PRECISION array, C dimension (LDBW,MBW), where MBW = MW, if JOB = 'W', and C MBW = M, if JOB = 'C'. C On entry, the leading NW-by-MBW part of this array must C contain the input matrix BW of the system with the C transfer-function matrix W. C On exit, if INFO = 0, the leading NW-by-MBW part of this C array contains Q'*BW, where Q is the orthogonal matrix C that reduces AW to the real Schur form or the left C orthogonal matrix used to reduce the pair (AW,EW), C (AW',EW') or (EW',AW') to the generalized real Schur form. C C LDBW INTEGER C The leading dimension of the array BW. LDBW >= MAX(1,NW). C C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) C On entry, the leading PCW-by-NW part of this array must C contain the output matrix CW of the system with the C transfer-function matrix W, where PCW = M if JOB = 'W' or C PCW = MW if JOB = 'C'. C On exit, if INFO = 0, the leading PCW-by-NW part of this C array contains CW*Q, where Q is the orthogonal matrix that C reduces AW to the real Schur form, or CW*Z, where Z is the C right orthogonal matrix used to reduce the pair (AW,EW), C (AW',EW') or (EW',AW') to the generalized real Schur form. C C LDCW INTEGER C The leading dimension of the array CW. C LDCW >= MAX(1,PCW), where PCW = M if JOB = 'W', or C PCW = MW if JOB = 'C'. C C DW (input) DOUBLE PRECISION array, C dimension (LDDW,MBW), where MBW = MW if JOB = 'W', and C MBW = M if JOB = 'C'. C The leading PCW-by-MBW part of this array must contain C the feedthrough matrix DW of the system with the C transfer-function matrix W, where PCW = M if JOB = 'W', C or PCW = MW if JOB = 'C'. C C LDDW INTEGER C LDDW >= MAX(1,PCW), where PCW = M if JOB = 'W', or C PCW = MW if JOB = 'C'. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = 0, if JOBEW = 'I'; C LIWORK = NW+N+6, if JOBEW = 'G'. 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 >= LW1, if JOBEW = 'I', C LDWORK >= LW2, if JOBEW = 'G', where C LW1 = MAX( 1, NW*(NW+5), NW*N + MAX( a, N*MW, P*MW ) ) C a = 0, if DICO = 'C' or JOB = 'W', C a = 2*NW, if DICO = 'D' and JOB = 'C'; C LW2 = MAX( 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ), C NW*N + MAX( NW*N+N*N, MW*N, P*MW ) ). C For good 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: the reduction of the pair (AW,EW) to the real C generalized Schur form failed (JOBEW = 'G'), C or the reduction of the matrix AW to the real C Schur form failed (JOBEW = 'I); C = 2: the solution of the Sylvester equation failed C because the matrix A and the pencil AW-lambda*EW C have common eigenvalues (if JOB = 'W'), or the C pencil -AW-lambda*EW and A have common eigenvalues C (if JOB = 'C' and DICO = 'C'), or the pencil C AW-lambda*EW has an eigenvalue which is the C reciprocal of one of eigenvalues of A C (if JOB = 'C' and DICO = 'D'); C = 3: the solution of the Sylvester equation failed C because the matrices A and AW have common C eigenvalues (if JOB = 'W'), or the matrices A C and -AW have common eigenvalues (if JOB = 'C' and C DICO = 'C'), or the matrix A has an eigenvalue C which is the reciprocal of one of eigenvalues of AW C (if JOB = 'C' and DICO = 'D'); C = 4: JOB = 'W' and the pair (AW,EW) has not completely C unstable generalized eigenvalues, or JOB = 'C' and C the pair (AW,EW) has not completely stable C generalized eigenvalues. C C METHOD C C If JOB = 'W', the matrices of the stable projection of G*W are C computed as C C BS = B*DW + Y*BW, CS = C, DS = D*DW, C C where Y satisfies the generalized Sylvester equation C C -A*Y*EW + Y*AW + B*CW = 0. C C If JOB = 'C', the matrices of the stable projection of G*conj(W) C are computed using the following formulas: C C - for a continuous-time system, the matrices BS, CS and DS of C the stable projection are computed as C C BS = B*DW' + Y*CW', CS = C, DS = D*DW', C C where Y satisfies the generalized Sylvester equation C C A*Y*EW' + Y*AW' + B*BW' = 0. C C - for a discrete-time system, the matrices BS, CS and DS of C the stable projection are computed as C C BS = B*DW' + A*Y*CW', CS = C, DS = D*DW' + C*Y*CW', C C where Y satisfies the generalized Sylvester equation C C Y*EW' - A*Y*AW' = B*BW'. C C REFERENCES C C [1] Varga, A. C Efficient and numerically reliable implementation of the C frequency-weighted Hankel-norm approximation model reduction C approach. C Proc. 2001 ECC, Porto, Portugal, 2001. C C [2] Zhou, K. C Frequency-weighted H-infinity norm and optimal Hankel norm C model reduction. C IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995. C C NUMERICAL ASPECTS C C The implemented methods rely on numerically stable algorithms. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. C D. Sima, University of Bucharest, March 2001. C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. C C REVISIONS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. C V. Sima, Research Institute for Informatics, Bucharest, June 2001. C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. C V. Sima, Research Institute for Informatics, Bucharest, May 2010. C C KEYWORDS C C Frequency weighting, model reduction, multivariable system, C state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOB, JOBEW, STBCHK INTEGER INFO, LDA, LDAW, LDB, LDBW, LDC, LDCW, $ LDD, LDDW, LDEW, LDWORK, M, MW, N, NW, P C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), AW(LDAW,*), B(LDB,*), BW(LDBW,*), $ C(LDC,*), CW(LDCW,*), D(LDD,*), DW(LDDW,*), $ DWORK(*), EW(LDEW,*) C .. Local Scalars .. CHARACTER*1 EVTYPE, STDOM LOGICAL CONJS, DISCR, STABCK, UNITEW DOUBLE PRECISION ALPHA, DIF, SCALE, TOLINF, WORK INTEGER I, IA, IERR, KAI, KAR, KB, KC, KE, KF, KQ, KW, $ KZ, LDW, LDWM, LDWN, LDWP, LW, SDIM C .. Local Arrays .. LOGICAL BWORK(1) C .. External Functions .. LOGICAL DELCTG, LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DELCTG, DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL AB09JX, DGEMM, DGGES, DLACPY, DLASET, DSWAP, $ DTGSYL, DTRSYL, SB04PY, TB01WD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, SQRT C C .. Executable Statements .. C CONJS = LSAME( JOB, 'C' ) DISCR = LSAME( DICO, 'D' ) UNITEW = LSAME( JOBEW, 'I' ) STABCK = LSAME( STBCHK, 'C' ) C INFO = 0 IF( UNITEW ) THEN IF ( DISCR .AND. CONJS ) THEN IA = 2*NW ELSE IA = 0 END IF LW = MAX( 1, NW*( NW + 5 ), NW*N + MAX( IA, N*MW, P*MW ) ) ELSE LW = MAX( 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ), $ NW*N + MAX( NW*N + N*N, MW*N, P*MW ) ) END IF C C Test the input scalar arguments. C LDW = MAX( 1, NW ) LDWM = MAX( 1, MW ) LDWN = MAX( 1, N ) LDWP = MAX( 1, P ) IF( .NOT. ( LSAME( JOB, 'W' ) .OR. CONJS ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -2 ELSE IF( .NOT. ( LSAME( JOBEW, 'G' ) .OR. UNITEW ) ) THEN INFO = -3 ELSE IF( .NOT. ( LSAME( STBCHK, 'N' ) .OR. STABCK ) ) 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( NW.LT.0 ) THEN INFO = -8 ELSE IF( MW.LT.0 ) THEN INFO = -9 ELSE IF( LDA.LT.LDWN ) THEN INFO = -11 ELSE IF( LDB.LT.LDWN ) THEN INFO = -13 ELSE IF( LDC.LT.LDWP ) THEN INFO = -15 ELSE IF( LDD.LT.LDWP ) THEN INFO = -17 ELSE IF( LDAW.LT.LDW ) THEN INFO = -19 ELSE IF( LDEW.LT.1 .OR. ( .NOT.UNITEW .AND. LDEW.LT.NW ) ) THEN INFO = -21 ELSE IF( LDBW.LT.LDW ) THEN INFO = -23 ELSE IF( ( .NOT.CONJS .AND. LDCW.LT.MAX( 1, M ) ) .OR. $ ( CONJS .AND. LDCW.LT.LDWM ) ) THEN INFO = -25 ELSE IF( ( .NOT.CONJS .AND. LDDW.LT.MAX( 1, M ) ) .OR. $ ( CONJS .AND. LDDW.LT.LDWM ) ) THEN INFO = -27 ELSE IF( LDWORK.LT.LW ) THEN INFO = -30 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09JW', -INFO ) RETURN END IF C C Quick return if possible. C IF( M.EQ.0 ) THEN CALL DLASET( 'Full', N, MW, ZERO, ZERO, B, LDB ) CALL DLASET( 'Full', P, MW, ZERO, ZERO, D, LDD ) DWORK(1) = ONE RETURN END IF C C Set options for stability/antistability checking. C IF( DISCR ) THEN ALPHA = ONE ELSE ALPHA = ZERO END IF C WORK = ONE TOLINF = DLAMCH( 'Precision' ) C IF( UNITEW ) THEN C C EW is the identity matrix. C IF( NW.GT.0 ) THEN C C Reduce AW to the real Schur form using an orthogonal C similarity transformation AW <- Q'*AW*Q and apply the C transformation to BW and CW: BW <- Q'*BW and CW <- CW*Q. C C Workspace needed: NW*(NW+5); C prefer larger. C KW = NW*( NW + 2 ) + 1 IF( CONJS ) THEN STDOM = 'S' ALPHA = ALPHA + SQRT( TOLINF ) CALL TB01WD( NW, M, MW, AW, LDAW, BW, LDBW, CW, LDCW, $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), $ DWORK(KW), LDWORK-KW+1, IERR ) ELSE STDOM = 'U' ALPHA = ALPHA - SQRT( TOLINF ) CALL TB01WD( NW, MW, M, AW, LDAW, BW, LDBW, CW, LDCW, $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), $ DWORK(KW), LDWORK-KW+1, IERR ) END IF IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF IF( STABCK ) THEN C C Check stability/antistability of eigenvalues of AV. C CALL AB09JX( DICO, STDOM, 'S', NW, ALPHA, DWORK, $ DWORK(NW+1), DWORK, TOLINF, IERR ) IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF END IF C WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) C END IF C KW = NW*N + 1 IF( CONJS ) THEN C C Compute the projection of G*conj(W). C C Total workspace needed: NW*N + MAX( a, N*MW, P*MW ), where C a = 0, if DICO = 'C', C a = 2*NW, if DICO = 'D'. C C Compute -BW*B'. C Workspace needed: NW*N. C CALL DGEMM( 'N', 'T', NW, N, M, -ONE, BW, LDBW, B, LDB, $ ZERO, DWORK, LDW ) C IF( DISCR ) THEN C C Compute Y' and SCALE satisfying C C AW*Y'*A' - Y' = -SCALE*BW*B'. C C Additional workspace needed: 2*NW. C CALL SB04PY( 'N', 'T', -1, NW, N, AW, LDAW, A, LDA, $ DWORK, LDW, SCALE, DWORK(KW), IERR ) IF( IERR.NE.0 ) THEN INFO = 3 RETURN END IF C C Construct BS = B*DW' + A*Y*CW'/SCALE, C DS = D*DW' + C*Y*CW'/SCALE. C C Additional workspace needed: MAX( N*MW, P*MW ). C C B <- B*DW'. C CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, $ ZERO, DWORK(KW), LDWN ) CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) C C D <- D*DW'. C CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, $ ZERO, DWORK(KW), LDWP ) CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) C C B <- B + A*Y*CW'/SCALE. C CALL DGEMM( 'T', 'T', N, MW, NW, ONE / SCALE, DWORK, LDW, $ CW, LDCW, ZERO, DWORK(KW), LDWN ) CALL DGEMM( 'N', 'N', N, MW, N, ONE, A, LDA, $ DWORK(KW), LDWN, ONE, B, LDB ) C C D <- D + C*Y*CW'/SCALE. C CALL DGEMM( 'N', 'N', P, MW, N, ONE, C, LDC, $ DWORK(KW), LDWN, ONE, D, LDD ) ELSE C C Compute Y' and SCALE satisfying C C AW*Y' + Y'*A' + SCALE*BW*B' = 0. C IF( N.GT.0 ) THEN CALL DTRSYL( 'N', 'T', 1, NW, N, AW, LDAW, A, LDA, $ DWORK, LDW, SCALE, IERR ) IF( IERR.NE.0 ) THEN INFO = 3 RETURN END IF END IF C C Construct BS = B*DW' + Y*CW'/SCALE, C DS = D*DW'. C C Additional workspace needed: MAX( N*MW, P*MW ). C C Construct B <- B*DW' + Y*CW'/SCALE. C CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, $ ZERO, DWORK(KW), LDWN ) CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) CALL DGEMM( 'T', 'T', N, MW, NW, ONE / SCALE, DWORK, LDW, $ CW, LDCW, ONE, B, LDB) C C D <- D*DW'. C CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, $ ZERO, DWORK(KW), LDWP ) CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) END IF ELSE C C Compute the projection of G*W. C C Total workspace needed: NW*N + MAX( N*MW, P*MW ). C C Compute B*CW. C Workspace needed: N*NW. C CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, $ ZERO, DWORK, LDWN ) C C Compute Y and SCALE satisfying C C A*Y - Y*AW - SCALE*B*CW = 0. C IF( N.GT.0 ) THEN CALL DTRSYL( 'N', 'N', -1, N, NW, A, LDA, AW, LDAW, $ DWORK, LDWN, SCALE, IERR ) IF( IERR.NE.0 ) THEN INFO = 3 RETURN END IF END IF C C Construct BS = B*DW + Y*BW/SCALE, C DS = D*DW. C C Additional workspace needed: MAX( N*MW, P*MW ). C Construct B <- B*DW + Y*BW/SCALE. C CALL DGEMM( 'N', 'N', N, MW, M, ONE, B, LDB, DW, LDDW, $ ZERO, DWORK(KW), LDWN ) CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) CALL DGEMM( 'N', 'N', N, MW, NW, ONE / SCALE, DWORK, LDWN, $ BW, LDBW, ONE, B, LDB) C C D <- D*DW. C CALL DGEMM( 'N', 'N', P, MW, M, ONE, D, LDD, DW, LDDW, $ ZERO, DWORK(KW), LDWP ) CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) END IF ELSE C C EW is a general matrix. C IF( NW.GT.0 ) THEN TOLINF = TOLINF * DLANGE( '1', NW, NW, EW, LDEW, DWORK ) C C Reduce (AW,EW), or (AW',EW') or (EW',AW') to a generalized C real Schur form using an orthogonal equivalence C transformation and apply the orthogonal transformation C appropriately to BW and CW, or CW' and BW'. C C Workspace needed: 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ); C prefer larger. C KQ = 1 KZ = KQ + NW*NW KAR = KZ + NW*NW KAI = KAR + NW KB = KAI + NW KW = KB + NW C IF( CONJS ) THEN STDOM = 'S' ALPHA = ALPHA + SQRT( TOLINF ) C C Transpose AW and EW, if non-scalar. C DO 10 I = 1, NW - 1 CALL DSWAP( NW-I, AW(I+1,I), 1, AW(I,I+1), LDAW ) CALL DSWAP( NW-I, EW(I+1,I), 1, EW(I,I+1), LDEW ) 10 CONTINUE C IF( DISCR ) THEN C C Reduce (EW',AW') to a generalized real Schur form C using orthogonal transformation matrices Q and Z C such that Q'*EW'*Z results in a quasi-triangular form C and Q'*AW'*Z results upper triangular. C Total workspace needed: 2*NW*NW + 11*NW + 16. C EVTYPE = 'R' CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', $ DELCTG, NW, EW, LDEW, AW, LDAW, SDIM, $ DWORK(KAR), DWORK(KAI), DWORK(KB), $ DWORK(KQ), LDW, DWORK(KZ), LDW, $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) ELSE C C Reduce (AW',EW') to a generalized real Schur form C using orthogonal transformation matrices Q and Z C such that Q'*AW'*Z results in a quasi-triangular form C and Q'*EW'*Z results upper triangular. C Total workspace needed: 2*NW*NW + 11*NW + 16. C EVTYPE = 'G' CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', $ DELCTG, NW, AW, LDAW, EW, LDEW, SDIM, $ DWORK(KAR), DWORK(KAI), DWORK(KB), $ DWORK(KQ), LDW, DWORK(KZ), LDW, $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) END IF IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF IF( STABCK ) THEN C C Check stability/antistability of generalized C eigenvalues of the pair (AV,EV). C CALL AB09JX( DICO, STDOM, EVTYPE, NW, ALPHA, $ DWORK(KAR), DWORK(KAI), DWORK(KB), $ TOLINF, IERR ) IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF END IF WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) C C Compute Z'*BW and CW*Q. C Total workspace needed: 2*NW*NW + NW*MAX(M,MW). C KW = KAR CALL DLACPY( 'Full', NW, M, BW, LDBW, DWORK(KW), LDW ) CALL DGEMM( 'T', 'N', NW, M, NW, ONE, DWORK(KZ), LDW, $ DWORK(KW), LDW, ZERO, BW, LDBW ) CALL DLACPY( 'Full', MW, NW, CW, LDCW, DWORK(KW), LDWM ) CALL DGEMM( 'N', 'N', MW, NW, NW, ONE, DWORK(KW), LDWM, $ DWORK(KQ), LDW, ZERO, CW, LDCW ) ELSE C C Reduce (AW,EW) to a generalized real Schur form C using orthogonal transformation matrices Q and Z C such that Q'*AW*Z results in a quasi-triangular form C and Q'*EW*Z results upper triangular. C Total workspace needed: 2*NW*NW + 11*NW + 16. C STDOM = 'U' EVTYPE = 'G' ALPHA = ALPHA - SQRT( TOLINF ) CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', $ DELCTG, NW, AW, LDAW, EW, LDEW, SDIM, $ DWORK(KAR), DWORK(KAI), DWORK(KB), $ DWORK(KQ), LDW, DWORK(KZ), LDW, $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF IF( STABCK ) THEN C C Check stability/antistability of generalized C eigenvalues of the pair (AV,EV). C CALL AB09JX( DICO, STDOM, EVTYPE, NW, ALPHA, $ DWORK(KAR), DWORK(KAI), DWORK(KB), $ TOLINF, IERR ) IF( IERR.NE.0 ) THEN INFO = 4 RETURN END IF END IF WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) C C Compute Q'*BW and CW*Z. C Total workspace needed: 2*NW*NW + NW*MAX(M,MW). C KW = KAR CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KW), LDW ) CALL DGEMM( 'T', 'N', NW, MW, NW, ONE, DWORK(KQ), LDW, $ DWORK(KW), LDW, ZERO, BW, LDBW ) CALL DLACPY( 'Full', M, NW, CW, LDCW, DWORK(KW), M ) CALL DGEMM( 'N', 'N', M, NW, NW, ONE, DWORK(KW), M, $ DWORK(KZ), LDW, ZERO, CW, LDCW ) END IF WORK = MAX( WORK, DBLE( 2*NW*NW + NW*MAX( M, MW ) ) ) C END IF C KC = 1 KF = KC + NW*N KE = KF + NW*N KW = KE + N*N CALL DLASET( 'Full', N, NW, ZERO, ZERO, DWORK(KF), LDWN ) C IF( CONJS ) THEN C C Compute the projection of G*conj(W). C C Total workspace needed: NW*N + MAX( NW*N+N*N, MW*N, P*MW ) C C Compute B*BW'. C Workspace needed: N*NW. C CALL DGEMM( 'N', 'T', N, NW, M, ONE, B, LDB, BW, LDBW, $ ZERO, DWORK(KC), LDWN ) C IF( DISCR ) THEN C C Compute Y and SCALE satisfying C C Y*EW' - A*Y*AW' = SCALE*B*BW' by solving equivalently C C A*X - Y*EW' = -SCALE*B*BW', C X - Y*AW' = 0. C C Additional workspace needed: C real N*NW + N*N; C integer NW+N+6. C C IF( N.GT.0 ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN $ ) CALL DTGSYL( 'N', 0, N, NW, A, LDA, EW, LDEW, $ DWORK(KC), LDWN, DWORK(KE), LDWN, AW, $ LDAW, DWORK(KF), LDWN, SCALE, DIF, $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) C C Note that the computed solution in DWORK(KC) is -Y. C IF( IERR.NE.0 ) THEN INFO = 2 RETURN END IF END IF C C Construct BS = B*DW' + A*Y*CW'/SCALE, C DS = D*DW' + C*Y*CW'/SCALE. C C Additional workspace needed: MAX( N*MW, P*MW ). C C B <- B*DW'. C CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, $ ZERO, DWORK(KW), LDWN ) CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) C C D <- D*DW'. C CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, $ ZERO, DWORK(KW), LDWP ) CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) C C B <- B + A*Y*CW'/SCALE. C CALL DGEMM( 'N', 'T', N, MW, NW, -ONE / SCALE, $ DWORK(KF), LDWN, CW, LDCW, ZERO, $ DWORK(KW), LDWN ) CALL DGEMM( 'N', 'N', N, MW, N, ONE, A, LDA, $ DWORK(KW), LDWN, ONE, B, LDB ) C C D <- D + C*Y*CW'/SCALE. C CALL DGEMM( 'N', 'N', P, MW, N, ONE, C, LDC, $ DWORK(KW), LDWN, ONE, D, LDD ) ELSE C C Compute Y and SCALE satisfying C C A*Y*EW' + Y*AW' + SCALE*B*BW' = 0 by solving equivalently C C A*X - Y*AW' = SCALE*B*BW', C (-I)*X - Y*EW' = 0. C C Additional workspace needed: C real N*NW+N*N; C integer NW+N+6. C IF( N.GT.0 ) THEN CALL DLASET( 'Full', N, N, ZERO, -ONE, DWORK(KE), LDWN $ ) CALL DTGSYL( 'N', 0, N, NW, A, LDA, AW, LDAW, $ DWORK(KC), LDWN, DWORK(KE), LDWN, EW, $ LDEW, DWORK(KF), LDWN, SCALE, DIF, $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) IF( IERR.NE.0 ) THEN INFO = 2 RETURN END IF END IF C C Construct BS = B*DW' + Y*CW'/SCALE, C DS = D*DW'. C C Additional workspace needed: MAX( N*MW, P*MW ). C C Construct B <- B*DW' + Y*CW'/SCALE. C CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, $ ZERO, DWORK(KW), LDWN ) CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) CALL DGEMM( 'N', 'T', N, MW, NW, ONE / SCALE, $ DWORK(KF), LDWN, CW, LDCW, ONE, B, LDB ) C C D <- D*DW'. C CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, $ ZERO, DWORK(KW), LDWP ) CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) END IF ELSE C C Compute the projection of G*W. C C Total workspace needed: NW*N + MAX( NW*N+N*N, MW*N, P*MW ) C C Compute B*CW. C Workspace needed: N*NW. C CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, $ ZERO, DWORK(KC), LDWN ) C C Compute Y and SCALE satisfying C C -A*Y*EW + Y*AW + B*CW = 0 by solving equivalently C C A*X - Y*AW = SCALE*B*CW, C X - Y*EW = 0. C C Additional workspace needed: C real N*NW + N*N; C integer NW+N+6. C IF( N.GT.0 ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN ) CALL DTGSYL( 'N', 0, N, NW, A, LDA, AW, LDAW, $ DWORK(KC), LDWN, DWORK(KE), LDWN, EW, LDEW, $ DWORK(KF), LDWN, SCALE, DIF, DWORK(KW), $ LDWORK-KW+1, IWORK, IERR ) IF( IERR.NE.0 ) THEN INFO = 2 RETURN END IF END IF C C Construct BS = B*DW + Y*BW/SCALE, C DS = D*DW. C C Additional workspace needed: MAX( N*MW, P*MW ). C Construct B <- B*DW + Y*BW/SCALE. C CALL DGEMM( 'N', 'N', N, MW, M, ONE, B, LDB, DW, LDDW, $ ZERO, DWORK(KW), LDWN ) CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) CALL DGEMM( 'N', 'N', N, MW, NW, ONE / SCALE, $ DWORK(KF), LDWN, BW, LDBW, ONE, B, LDB) C C D <- D*DW. C CALL DGEMM( 'N', 'N', P, MW, M, ONE, D, LDD, DW, LDDW, $ ZERO, DWORK(KW), LDWP ) CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) END IF END IF C DWORK(1) = MAX( WORK, DBLE( LW ) ) C RETURN C *** Last line of AB09JW *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04QC.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04QC.f0000644000175000017500000011632715012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE MB04QC( STRAB, TRANA, TRANB, TRANQ, DIRECT, STOREV, $ STOREW, M, N, K, V, LDV, W, LDW, RS, LDRS, T, $ LDT, A, LDA, B, LDB, DWORK ) C C PURPOSE C C To apply the orthogonal symplectic block reflector C C [ I+V*T*V' V*R*S*V' ] C Q = [ ] C [ -V*R*S*V' I+V*T*V' ] C C or its transpose to a real 2m-by-n matrix [ op(A); op(B) ] from C the left. C The k-by-k upper triangular blocks of the matrices C C [ S1 ] [ T11 T12 T13 ] C R = [ R1 R2 R3 ], S = [ S2 ], T = [ T21 T22 T23 ], C [ S3 ] [ T31 T32 T33 ] C C with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular, C are stored rowwise in the arrays RS and T, respectively. C C ARGUMENTS C C Mode Parameters C C STRAB CHARACTER*1 C Specifies the structure of the first blocks of A and B: C = 'Z': the leading K-by-N submatrices of op(A) and op(B) C are (implicitly) assumed to be zero; C = 'N'; no structure to mention. C C TRANA CHARACTER*1 C Specifies the form of op( A ) as follows: C = 'N': op( A ) = A; C = 'T': op( A ) = A'; C = 'C': op( A ) = A'. C C TRANB CHARACTER*1 C Specifies the form of op( B ) as follows: C = 'N': op( B ) = B; C = 'T': op( B ) = B'; C = 'C': op( B ) = B'. C C DIRECT CHARACTER*1 C This is a dummy argument, which is reserved for future C extensions of this subroutine. Not referenced. C C TRANQ CHARACTER*1 C = 'N': apply Q; C = 'T': apply Q'. C C STOREV CHARACTER*1 C Specifies how the vectors which define the concatenated C Householder reflectors contained in V are stored: C = 'C': columnwise; C = 'R': rowwise. C C STOREW CHARACTER*1 C Specifies how the vectors which define the concatenated C Householder reflectors contained in W are stored: C = 'C': columnwise; C = 'R': rowwise. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrices op(A) and op(B). C M >= 0. C C N (input) INTEGER C The number of columns of the matrices op(A) and op(B). C N >= 0. C C K (input) INTEGER C The order of the triangular matrices defining R, S and T. C M >= K >= 0. C C V (input) DOUBLE PRECISION array, dimension C (LDV,K) if STOREV = 'C', C (LDV,M) if STOREV = 'R' C On entry with STOREV = 'C', the leading M-by-K part of C this array must contain in its columns the vectors which C define the elementary reflector used to form parts of Q. C On entry with STOREV = 'R', the leading K-by-M part of C this array must contain in its rows the vectors which C define the elementary reflector used to form parts of Q. C C LDV INTEGER C The leading dimension of the array V. C LDV >= MAX(1,M), if STOREV = 'C'; C LDV >= MAX(1,K), if STOREV = 'R'. C C W (input) DOUBLE PRECISION array, dimension C (LDW,K) if STOREW = 'C', C (LDW,M) if STOREW = 'R' C On entry with STOREW = 'C', the leading M-by-K part of C this array must contain in its columns the vectors which C define the elementary reflector used to form parts of Q. C On entry with STOREW = 'R', the leading K-by-M part of C this array must contain in its rows the vectors which C define the elementary reflector used to form parts of Q. C C LDW INTEGER C The leading dimension of the array W. C LDW >= MAX(1,M), if STOREW = 'C'; C LDW >= MAX(1,K), if STOREW = 'R'. C C RS (input) DOUBLE PRECISION array, dimension (K,6*K) C On entry, the leading K-by-6*K part of this array must C contain the upper triangular matrices defining the factors C R and S of the symplectic block reflector Q. The C (strictly) lower portions of this array are not C referenced. C C LDRS INTEGER C The leading dimension of the array RS. LDRS >= MAX(1,K). C C T (input) DOUBLE PRECISION array, dimension (K,9*K) C On entry, the leading K-by-9*K part of this array must C contain the upper triangular matrices defining the factor C T of the symplectic block reflector Q. The (strictly) C lower portions of this array are not referenced. C C LDT INTEGER C The leading dimension of the array T. LDT >= MAX(1,K). C C A (input/output) DOUBLE PRECISION array, dimension C (LDA,N) if TRANA = 'N', C (LDA,M) if TRANA = 'C' or TRANA = 'T' C On entry with TRANA = 'N', the leading M-by-N part of this C array must contain the matrix A. C On entry with TRANA = 'T' or TRANA = '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 the array A. C LDA >= MAX(1,M), if TRANA = 'N'; C LDA >= MAX(1,N), if TRANA = 'C' or TRANA = 'T'. C C B (input/output) DOUBLE PRECISION array, dimension C (LDB,N) if TRANB = 'N', C (LDB,M) if TRANB = 'C' or TRANB = 'T' C On entry with TRANB = 'N', the leading M-by-N part of this C array must contain the matrix B. C On entry with TRANB = 'T' or TRANB = 'C', the leading C N-by-M part of this array must contain the matrix B. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,M), if TRANB = 'N'; C LDB >= MAX(1,N), if TRANB = 'C' or TRANB = 'T'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK), where C LDWORK >= 8*N*K, if STRAB = 'Z', C LDWORK >= 9*N*K, if STRAB = 'N'. C C REFERENCES C C [1] Kressner, D. C Block algorithms for orthogonal symplectic factorizations. C BIT, 43 (4), pp. 775-790, 2003. C C NUMERICAL ASPECTS C C The algorithm requires 16*( M - K )*N + ( 26*K - 4 )*K*N floating C point operations if STRAB = 'Z' and additional ( 12*K + 2 )*K*N C floating point operations if STRAB = 'N'. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAESB). C P. Gahinet, The MathWorks, Natick, U.S.A., Mar. 2011. C C KEYWORDS C C Elementary matrix operations, orthogonal symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DIRECT, STOREV, STOREW, STRAB, TRANA, TRANB, $ TRANQ INTEGER K, LDA, LDB, LDRS, LDT, LDV, LDW, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), RS(LDRS,*), $ T(LDT,*), V(LDV,*), W(LDW,*) C .. Local Scalars .. LOGICAL LA1B1, LCOLV, LCOLW, LTRA, LTRB, LTRQ INTEGER I, ITEMP, PDW1, PDW2, PDW3, PDW4, PDW5, PDW6, $ PDW7, PDW8, PDW9, PR1, PR2, PR3, PS1, PS2, PS3, $ PT11, PT12, PT13, PT21, PT22, PT23, PT31, PT32, $ PT33 DOUBLE PRECISION FACT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DLASET, DTRMM C C .. Executable Statements .. C C Quick return if possible. C IF ( M.LE.0 .OR. N.LE.0 ) $ RETURN LA1B1 = LSAME( STRAB, 'N' ) LCOLV = LSAME( STOREV, 'C' ) LCOLW = LSAME( STOREW, 'C' ) LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) LTRQ = LSAME( TRANQ, 'T' ) .OR. LSAME( TRANQ, 'C' ) C PR1 = 1 PR2 = PR1 + K PR3 = PR2 + K PS1 = PR3 + K PS2 = PS1 + K PS3 = PS2 + K PT11 = 1 PT12 = PT11 + K PT13 = PT12 + K PT21 = PT13 + K PT22 = PT21 + K PT23 = PT22 + K PT31 = PT23 + K PT32 = PT31 + K PT33 = PT32 + K PDW1 = 1 PDW2 = PDW1 + N*K PDW3 = PDW2 + N*K PDW4 = PDW3 + N*K PDW5 = PDW4 + N*K PDW6 = PDW5 + N*K PDW7 = PDW6 + N*K PDW8 = PDW7 + N*K PDW9 = PDW8 + N*K C C Update the matrix A. C IF ( LA1B1 ) THEN C C NZ1) DW7 := A1' C IF ( LTRA ) THEN DO 10 I = 1, K CALL DCOPY( N, A(1,I), 1, DWORK(PDW7+(I-1)*N), 1 ) 10 CONTINUE ELSE DO 20 I = 1, N CALL DCOPY( K, A(1,I), 1, DWORK(PDW7+I-1), N ) 20 CONTINUE END IF C C NZ2) DW1 := DW7*W1 C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW1), 1 ) IF ( LCOLW ) THEN CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, W, LDW, DWORK(PDW1), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, $ K, ONE, W, LDW, DWORK(PDW1), N ) END IF C C NZ3) DW2 := DW7*V1 C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW2), 1 ) IF ( LCOLV ) THEN CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, DWORK(PDW2), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, $ K, ONE, V, LDV, DWORK(PDW2), N ) END IF FACT = ONE ELSE FACT = ZERO END IF C C 1) DW1 := A2'*W2 C IF ( M.GT.K ) THEN IF ( LTRA.AND.LCOLW ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, $ A(1,K+1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), $ N ) ELSE IF ( LTRA ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, $ A(1,K+1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), $ N ) ELSE IF ( LCOLW ) THEN CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, $ A(K+1,1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), $ N ) ELSE CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ A(K+1,1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), $ N ) END IF ELSE IF ( .NOT.LA1B1 ) THEN CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) END IF C C 2) DW2 := A2'*V2 C IF ( M.GT.K ) THEN IF ( LTRA.AND.LCOLV ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, $ A(1,K+1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), $ N ) ELSE IF ( LTRA ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, $ A(1,K+1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), $ N ) ELSE IF ( LCOLV ) THEN CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, $ A(K+1,1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), $ N ) ELSE CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ A(K+1,1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), $ N ) END IF ELSE IF ( .NOT.LA1B1 ) THEN CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW2), N ) END IF C IF ( LTRQ ) THEN C C 3) DW3 := DW1*T11 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) C C 4) DW4 := DW2*T31 C CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) C C 5) DW3 := DW3 + DW4 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) C IF ( LA1B1 ) THEN C C NZ4) DW8 := DW7*T21 C CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) C C NZ5) DW3 := DW3 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) END IF C C 6) DW4 := DW1*T12 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT12), LDT, DWORK(PDW4), N ) C C 7) DW5 := DW2*T32 C CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) C C 8) DW4 := DW4 + DW5 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) C IF ( LA1B1 ) THEN C C NZ6) DW8 := DW7*T22 C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) C C NZ7) DW4 := DW4 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) END IF C C 9) DW5 := DW2*T33 C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) C C 10) DW6 := DW1*T13 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW6), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT13), LDT, DWORK(PDW6), N ) C C 11) DW5 := DW5 + DW6 C CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) C IF ( LA1B1 ) THEN C C NZ8) DW8 := DW7*T23 C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT23), LDT, DWORK(PDW8), N ) C C NZ9) DW5 := DW5 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) END IF C C 12) DW1 := DW1*R1 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PR1), LDRS, DWORK(PDW1), N ) C C 13) DW2 := DW2*R3 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW2), N ) C C 14) DW1 := DW1 + DW2 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW2), 1, DWORK(PDW1+N), 1 ) C IF ( LA1B1 ) THEN C C NZ10) DW7 := DW7*R2 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) C C NZ11) DW1 := DW1 + DW7 C CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW1), 1 ) END IF C C Swap Pointers PDW1 <-> PDW2 C ITEMP = PDW2 PDW2 = PDW1 PDW1 = ITEMP ELSE C C 3) DW3 := DW1*T11' C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) C C 4) DW4 := DW2*T13' C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) C C 5) DW3 := DW3 + DW4 C CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) C IF ( LA1B1 ) THEN C C NZ4) DW8 := DW7*T12' C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) C C NZ5) DW3 := DW3 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) END IF C C 6) DW4 := DW2*T23' C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) C C 7) DW5 := DW1*T21' C CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) C C 8) DW4 := DW4 + DW5 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) C IF ( LA1B1 ) THEN C C NZ6) DW8 := DW7*T22' C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) C C NZ7) DW4 := DW4 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) END IF C C 9) DW5 := DW2*T33' C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) C C 10) DW6 := DW1*T31' C CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, T(1,PT31+1), LDT, DWORK(PDW6), N ) C C 11) DW5 := DW5 + DW6 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) C IF ( LA1B1 ) THEN C C NZ8) DW8 := DW7*T32' C CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW8), N ) C C NZ9) DW5 := DW5 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) END IF C C 12) DW1 := DW1*S1' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW1+N), N ) C C 13) DW2 := DW2*S3' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) C C 14) DW2 := DW1 + DW2 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW2), 1 ) C IF ( LA1B1 ) THEN C C NZ10) DW7 := DW7*S2' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) C C NZ11) DW2 := DW2 + DW7 C CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW2), 1 ) END IF END IF C IF ( LA1B1 ) THEN C C NZ12) DW9 := B1' C IF ( LTRB ) THEN DO 30 I = 1, K CALL DCOPY( N, B(1,I), 1, DWORK(PDW9+(I-1)*N), 1 ) 30 CONTINUE ELSE DO 40 I = 1, N CALL DCOPY( K, B(1,I), 1, DWORK(PDW9+I-1), N ) 40 CONTINUE END IF C C NZ13) DW1 := DW9*W1 C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW1), 1 ) IF ( LCOLW ) THEN CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, W, LDW, DWORK(PDW1), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, $ K, ONE, W, LDW, DWORK(PDW1), N ) END IF C C NZ14) DW6 := DW9*V1 C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW6), 1 ) IF ( LCOLV ) THEN CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, $ K, ONE, V, LDV, DWORK(PDW6), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, $ K, ONE, V, LDV, DWORK(PDW6), N ) END IF END IF C C 15) DW1 := B2'*W2 C IF ( M.GT.K ) THEN IF ( LTRB.AND.LCOLW ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, $ B(1,K+1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), $ N ) ELSE IF ( LTRB ) THEN C C Critical Position C CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, $ B(1,K+1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), $ N ) ELSE IF ( LCOLW ) THEN CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, $ B(K+1,1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), $ N ) ELSE CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ B(K+1,1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), $ N ) END IF ELSE IF ( .NOT.LA1B1 ) THEN CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) END IF C C 16) DW6 := B2'*V2 C IF ( M.GT.K ) THEN IF ( LTRB.AND.LCOLV ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, $ B(1,K+1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), $ N ) ELSE IF ( LTRB ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, $ B(1,K+1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), $ N ) ELSE IF ( LCOLV ) THEN CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, $ B(K+1,1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), $ N ) ELSE CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, $ B(K+1,1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), $ N ) END IF ELSE IF ( .NOT.LA1B1 ) THEN CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW6), N ) END IF C IF ( LTRQ ) THEN C C 17) DW7 := DW1*R1 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW7), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PR1), LDRS, DWORK(PDW7), N ) C C 18) DW8 := DW6*R3 C CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) C C 19) DW7 := DW7 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7+N), 1 ) C IF ( LA1B1 ) THEN C C NZ15) DW8 := DW9*R2 C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, RS(1,PR2), LDRS, DWORK(PDW8), N ) C C NZ16) DW7 := DW7 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) END IF C C 20) DW8 := DW7*S1 C CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) C C 21) DW3 := DW3 - DW8 C CALL DAXPY( N*(K-1), -ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) C C 22) DW8 := DW7*S3 C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, RS(1,PS3), LDRS, DWORK(PDW8), N ) C C 23) DW5 := DW5 - DW8 C CALL DAXPY( N*K, -ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) C C 24) DW7 := DW7*S2 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ -ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) ELSE C C 17) DW7 := DW6*S3' C CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW7), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS3), LDRS, DWORK(PDW7), N ) C C 18) DW8 := DW1*S1' C CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) C C 19) DW7 := DW7 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) C IF ( LA1B1 ) THEN C C NZ15) DW8 := DW9*S2' C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS2), LDRS, DWORK(PDW8), N ) C C NZ16) DW7 := DW7 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) END IF C C 20) DW8 := DW7*R1' C CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PR1), LDRS, DWORK(PDW8), N ) C C 21) DW3 := DW3 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) C C 22) DW8 := DW7*R3' C CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) C C 23) DW5 := DW5 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) C C 24) DW7 := DW7*R2' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) END IF C C 25) A2 := A2 + W2*DW3' C IF ( M.GT.K ) THEN IF ( LTRA.AND.LCOLW ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, A(1,K+1), $ LDA ) ELSE IF ( LTRA ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, A(1,K+1), $ LDA ) ELSE IF ( LCOLW ) THEN CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), $ LDA ) ELSE CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), $ LDA ) END IF END IF C C 26) A2 := A2 + V2*DW5' C IF ( M.GT.K ) THEN IF ( LTRA.AND.LCOLV ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, $ DWORK(PDW5), N, V(K+1,1), LDV, ONE, A(1,K+1), $ LDA ) ELSE IF ( LTRA ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, $ DWORK(PDW5), N, V(1,K+1), LDV, ONE, A(1,K+1), $ LDA ) ELSE IF ( LCOLV ) THEN CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, $ V(K+1,1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), $ LDA ) ELSE CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, $ V(1,K+1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), $ LDA ) END IF END IF C C 27) DW4 := DW4 + DW7 C CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW4), 1 ) C C 28) DW3 := DW3*W1' C IF ( LCOLW ) THEN CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, $ W, LDW, DWORK(PDW3), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, W, LDW, DWORK(PDW3), N ) END IF C C 29) DW4 := DW4 + DW3 C CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) C C 30) DW5 := DW5*V1' C IF ( LCOLV ) THEN CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, $ V, LDV, DWORK(PDW5), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, V, LDV, DWORK(PDW5), N ) END IF C C 31) DW4 := DW4 + DW5 C CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) C C 32) A1 := A1 + DW4' C IF ( LA1B1 ) THEN IF ( LTRA ) THEN DO 50 I = 1, K CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) 50 CONTINUE ELSE DO 60 I = 1, N CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, A(1,I), 1 ) 60 CONTINUE END IF ELSE IF ( LTRA ) THEN DO 70 I = 1, K CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) 70 CONTINUE ELSE DO 80 I = 1, N CALL DCOPY( K, DWORK(PDW4+I-1), N, A(1,I), 1 ) 80 CONTINUE END IF END IF C C Update the matrix B. C IF ( LTRQ ) THEN C C 33) DW3 := DW1*T11 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) C C 34) DW4 := DW6*T31 C CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) C C 35) DW3 := DW3 + DW4 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) C IF ( LA1B1 ) THEN C C NZ17) DW8 := DW9*T21 C CALL DCOPY( N*(K-1), DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) C C NZ18) DW3 := DW3 + DW8 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) END IF C C 36) DW4 := DW2*S1 C CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW4), N ) C C 37) DW3 := DW3 + DW4 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) C C 38) DW4 := DW1*T12 C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT12), LDT, DWORK(PDW4), N ) C C 38) DW5 := DW6*T32 C CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) C C 40) DW4 := DW4 + DW5 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) C IF ( LA1B1 ) THEN C C NZ19) DW8 := DW9*T22 C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) C C NZ20) DW4 := DW4 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) END IF C C 41) DW5 := DW2*S2 C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS2), LDRS, DWORK(PDW5), N ) C C 42) DW4 := DW4 + DW5 C CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) C C 43) DW6 := DW6*T33 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) C C 44) DW1 := DW1*T13 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT13), LDT, DWORK(PDW1), N ) C C 45) DW6 := DW6 + DW1 C CALL DAXPY( N*K, ONE, DWORK(PDW1), 1, DWORK(PDW6), 1 ) C IF ( LA1B1 ) THEN C C NZ19) DW9 := DW9*T23 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, $ K, ONE, T(1,PT23), LDT, DWORK(PDW9), N ) C C NZ20) DW6 := DW6 + DW9 C CALL DAXPY( N*K, ONE, DWORK(PDW9), 1, DWORK(PDW6), 1 ) END IF C C 46) DW2 := DW2*S3 C CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) C C 45) DW6 := DW6 + DW2 C CALL DAXPY( N*K, ONE, DWORK(PDW2), 1, DWORK(PDW6), 1 ) ELSE C C 33) DW3 := DW1*T11' C CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) C C 34) DW4 := DW6*T13' C CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) C C 35) DW3 := DW3 + DW4 C CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) C IF ( LA1B1 ) THEN C C NZ17) DW8 := DW9*T12' C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) C C NZ18) DW3 := DW3 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) END IF C C 36) DW4 := DW2*R1' C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, RS(1,PR1), LDRS, DWORK(PDW4), N ) C C 37) DW3 := DW3 - DW4 C CALL DAXPY( N*K, -ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) C C 38) DW4 := DW6*T23' C CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) C C 39) DW5 := DW1*T21' C CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) C C 40) DW4 := DW4 + DW5 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) C IF ( LA1B1 ) THEN C C NZ19) DW8 := DW9*T22' C CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) C C NZ20) DW4 := DW4 + DW8 C CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) END IF C C 41) DW5 := DW2*R2' C CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, $ ONE, RS(1,PR2), LDRS, DWORK(PDW5), N ) C C 42) DW4 := DW4 - DW5 C CALL DAXPY( N*K, -ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) C C 43) DW6 := DW6*T33' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) C C 44) DW1 := DW1*T31' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, T(1,PT31+1), LDT, DWORK(PDW1+N), N ) C C 45) DW6 := DW6 + DW1 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) C IF ( LA1B1 ) THEN C C NZ19) DW9 := DW9*T32' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW9+N), N ) C C NZ20) DW6 := DW6 + DW9 C CALL DAXPY( N*(K-1), ONE, DWORK(PDW9+N), 1, DWORK(PDW6), 1 ) END IF C C 46) DW2 := DW2*R3' C CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW2+N), N ) C C 45) DW6 := DW6 - DW2 C CALL DAXPY( N*(K-1), -ONE, DWORK(PDW2+N), 1, DWORK(PDW6), 1 ) END IF C C 46) B2 := B2 + W2*DW3' C IF ( M.GT.K ) THEN IF ( LTRB.AND.LCOLW ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, B(1,K+1), $ LDB ) ELSE IF ( LTRB ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, B(1,K+1), $ LDB ) ELSE IF ( LCOLW ) THEN CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), $ LDB ) ELSE CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), $ LDB ) END IF END IF C C 47) B2 := B2 + V2*DW6' C IF ( M.GT.K ) THEN IF ( LTRB.AND.LCOLV ) THEN CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, $ DWORK(PDW6), N, V(K+1,1), LDV, ONE, B(1,K+1), $ LDB ) ELSE IF ( LTRB ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, $ DWORK(PDW6), N, V(1,K+1), LDV, ONE, B(1,K+1), $ LDB ) ELSE IF ( LCOLV ) THEN CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, $ V(K+1,1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), $ LDB ) ELSE CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, $ V(1,K+1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), $ LDB ) END IF END IF C C 48) DW3 := DW3*W1' C IF ( LCOLW ) THEN CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, $ W, LDW, DWORK(PDW3), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, W, LDW, DWORK(PDW3), N ) END IF C C 49) DW4 := DW4 + DW3 C CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) C C 50) DW6 := DW6*V1' C IF ( LCOLV ) THEN CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, $ V, LDV, DWORK(PDW6), N ) ELSE CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, $ ONE, V, LDV, DWORK(PDW6), N ) END IF C C 51) DW4 := DW4 + DW6 C CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW4), 1 ) C C 52) B1 := B1 + DW4' C IF ( LA1B1 ) THEN IF ( LTRB ) THEN DO 90 I = 1, K CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) 90 CONTINUE ELSE DO 100 I = 1, N CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, B(1,I), 1 ) 100 CONTINUE END IF ELSE IF ( LTRB ) THEN DO 110 I = 1, K CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) 110 CONTINUE ELSE DO 120 I = 1, N CALL DCOPY( K, DWORK(PDW4+I-1), N, B(1,I), 1 ) 120 CONTINUE END IF END IF C RETURN C *** Last line of MB04QC *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03YA.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03YA.f0000644000175000017500000002337015012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE MB03YA( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILOQ, IHIQ, $ POS, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) C C PURPOSE C C To annihilate one or two entries on the subdiagonal of the C Hessenberg matrix A for dealing with zero elements on the diagonal C of the triangular matrix B. C C MB03YA is an auxiliary routine called by SLICOT Library routines C MB03XP and MB03YD. C C ARGUMENTS C C Mode Parameters C C WANTT LOGICAL C Indicates whether the user wishes to compute the full C Schur form or the eigenvalues only, as follows: C = .TRUE. : Compute the full Schur form; C = .FALSE.: compute the eigenvalues only. C C WANTQ LOGICAL C Indicates whether or not the user wishes to accumulate C the matrix Q as follows: C = .TRUE. : The matrix Q is updated; C = .FALSE.: the matrix Q is not required. C C WANTZ LOGICAL C Indicates whether or not the user wishes to accumulate C the matrix Z as follows: C = .TRUE. : The matrix Z is updated; C = .FALSE.: the matrix Z is not required. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and B. N >= 0. C C ILO (input) INTEGER C IHI (input) INTEGER C It is assumed that the matrices A and B are already C (quasi) upper triangular in rows and columns 1:ILO-1 and C IHI+1:N. The routine works primarily with the submatrices C in rows and columns ILO to IHI, but applies the C transformations to all the rows and columns of the C matrices A and B, if WANTT = .TRUE.. C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. C C ILOQ (input) INTEGER C IHIQ (input) INTEGER C Specify the rows of Q and Z to which transformations C must be applied if WANTQ = .TRUE. and WANTZ = .TRUE., C respectively. C 1 <= ILOQ <= ILO; IHI <= IHIQ <= N. C C POS (input) INTEGER C The position of the zero element on the diagonal of B. C ILO <= POS <= IHI. 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 Hessenberg matrix A. C On exit, the leading N-by-N part of this array contains C the updated matrix A where A(POS,POS-1) = 0, if POS > ILO, C and A(POS+1,POS) = 0, if POS < IHI. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) C On entry, the leading N-by-N part of this array must C contain an upper triangular matrix B with B(POS,POS) = 0. C On exit, the leading N-by-N part of this array contains C the updated upper triangular matrix B. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, if WANTQ = .TRUE., then the leading N-by-N part C of this array must contain the current matrix Q of C transformations accumulated by MB03XP. C On exit, if WANTQ = .TRUE., then the leading N-by-N part C of this array contains the matrix Q updated in the C submatrix Q(ILOQ:IHIQ,ILO:IHI). C If WANTQ = .FALSE., Q is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. LDQ >= 1. C If WANTQ = .TRUE., LDQ >= MAX(1,N). C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) C On entry, if WANTZ = .TRUE., then the leading N-by-N part C of this array must contain the current matrix Z of C transformations accumulated by MB03XP. C On exit, if WANTZ = .TRUE., then the leading N-by-N part C of this array contains the matrix Z updated in the C submatrix Z(ILOQ:IHIQ,ILO:IHI). C If WANTZ = .FALSE., Z is not referenced. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= 1. C If WANTZ = .TRUE., LDZ >= MAX(1,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 METHOD C C The method is illustrated by Wilkinson diagrams for N = 5, C POS = 3: C C [ x x x x x ] [ x x x x x ] C [ x x x x x ] [ o x x x x ] C A = [ o x x x x ], B = [ o o o x x ]. C [ o o x x x ] [ o o o x x ] C [ o o o x x ] [ o o o o x ] C C First, a QR factorization is applied to A(1:3,1:3) and the C resulting nonzero in the updated matrix B is immediately C annihilated by a Givens rotation acting on columns 1 and 2: C C [ x x x x x ] [ x x x x x ] C [ x x x x x ] [ o x x x x ] C A = [ o o x x x ], B = [ o o o x x ]. C [ o o x x x ] [ o o o x x ] C [ o o o x x ] [ o o o o x ] C C Secondly, an RQ factorization is applied to A(4:5,4:5) and the C resulting nonzero in the updated matrix B is immediately C annihilated by a Givens rotation acting on rows 4 and 5: C C [ x x x x x ] [ x x x x x ] C [ x x x x x ] [ o x x x x ] C A = [ o o x x x ], B = [ o o o x x ]. C [ o o o x x ] [ o o o x x ] C [ o o o x x ] [ o o o o x ] C C REFERENCES C C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. C The periodic Schur decomposition: Algorithms and applications. C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, C 1992. C C NUMERICAL ASPECTS C C The algorithm requires O(N**2) floating point operations and is C backward stable. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLADFB). C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. Scalar Arguments .. LOGICAL WANTQ, WANTT, WANTZ INTEGER IHI, IHIQ, ILO, ILOQ, INFO, LDA, LDB, LDQ, LDZ, $ N, POS C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. INTEGER I1, I2, J, NQ DOUBLE PRECISION CS, SN, TEMP C .. External Subroutines .. EXTERNAL DLARTG, DROT, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 NQ = IHIQ - ILOQ + 1 IF ( N.LT.0 ) THEN INFO = -4 ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF ( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN INFO = -6 ELSE IF ( ILOQ.LT.1 .OR. ILOQ.GT.ILO ) THEN INFO = -7 ELSE IF ( IHIQ.LT.IHI .OR. IHIQ.GT.N ) THEN INFO = -8 ELSE IF ( POS.LT.ILO .OR. POS.GT.IHI ) THEN INFO = -9 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN INFO = -15 ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN INFO = -17 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03YA', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C IF ( WANTT ) THEN I1 = 1 I2 = N ELSE I1 = ILO I2 = IHI END IF C C Apply a zero-shifted QR step. C DO 10 J = ILO, POS-1 TEMP = A(J,J) CALL DLARTG( TEMP, A(J+1,J), CS, SN, A(J,J) ) A(J+1,J) = ZERO CALL DROT( I2-J, A(J,J+1), LDA, A(J+1,J+1), LDA, CS, SN ) CALL DROT( MIN(J,POS-2)-I1+2, B(I1,J), 1, B(I1,J+1), 1, CS, $ SN ) IF ( WANTQ ) $ CALL DROT( NQ, Q(ILOQ,J), 1, Q(ILOQ,J+1), 1, CS, SN ) 10 CONTINUE DO 20 J = ILO, POS-2 TEMP = B(J,J) CALL DLARTG( TEMP, B(J+1,J), CS, SN, B(J,J) ) B(J+1,J) = ZERO CALL DROT( I2-J, B(J,J+1), LDB, B(J+1,J+1), LDB, CS, SN ) CALL DROT( J-I1+2, A(I1,J), 1, A(I1,J+1), 1, CS, SN ) IF ( WANTZ ) $ CALL DROT( NQ, Z(ILOQ,J), 1, Z(ILOQ,J+1), 1, CS, SN ) 20 CONTINUE C C Apply a zero-shifted RQ step. C DO 30 J = IHI, POS+1, -1 TEMP = A(J,J) CALL DLARTG( TEMP, A(J,J-1), CS, SN, A(J,J) ) A(J,J-1) = ZERO SN = -SN CALL DROT( J-I1, A(I1,J-1), 1, A(I1,J), 1, CS, SN ) CALL DROT( I2 - MAX( J-1,POS+1 ) + 1, B(J-1,MAX( J-1,POS+1 )), $ LDB, B(J,MAX(J-1,POS+1)), LDB, CS, SN ) IF ( WANTZ ) $ CALL DROT( NQ, Z(ILOQ,J-1), 1, Z(ILOQ,J), 1, CS, SN ) 30 CONTINUE DO 40 J = IHI, POS+2, -1 TEMP = B(J,J) CALL DLARTG( TEMP, B(J,J-1), CS, SN, B(J,J) ) B(J,J-1) = ZERO SN = -SN CALL DROT( J-I1, B(I1,J-1), 1, B(I1,J), 1, CS, SN ) CALL DROT( I2-J+2, A(J-1,J-1), LDA, A(J,J-1), LDA, CS, SN ) IF ( WANTQ ) $ CALL DROT( NQ, Q(ILOQ,J-1), 1, Q(ILOQ,J), 1, CS, SN ) 40 CONTINUE RETURN C *** Last line of MB03YA *** END control-4.1.2/src/slicot/src/PaxHeaders/FB01SD.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/FB01SD.f0000644000175000017500000005421315012430707017355 0ustar00lilgelilge00000000000000 SUBROUTINE FB01SD( JOBX, MULTAB, MULTRC, N, M, P, SINV, LDSINV, $ AINV, LDAINV, B, LDB, RINV, LDRINV, C, LDC, $ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To calculate a combined measurement and time update of one C iteration of the time-varying Kalman filter. This update is given C for the square root information filter, using dense matrices. C C ARGUMENTS C C Mode Parameters C C JOBX CHARACTER*1 C Indicates whether X is to be computed as follows: C i+1 C = 'X': X is computed and stored in array X; C i+1 C = 'N': X is not required. C i+1 C C MULTAB CHARACTER*1 -1 C Indicates how matrices A and B are to be passed to C i i C the routine as follows: -1 C = 'P': Array AINV must contain the matrix A and the C -1 i C array B must contain the product A B ; C i i C = 'N': Arrays AINV and B must contain the matrices C as described below. C C MULTRC CHARACTER*1 -1/2 C Indicates how matrices R and C are to be passed to C i+1 i+1 C the routine as follows: C = 'P': Array RINV is not used and the array C must C -1/2 C contain the product R C ; C i+1 i+1 C = 'N': Arrays RINV and C must contain the matrices C as described below. C C Input/Output Parameters C C N (input) INTEGER C The actual state dimension, i.e., the order of the C -1 -1 C matrices S and A . N >= 0. C i i C C M (input) INTEGER C The actual input dimension, i.e., the order of the matrix C -1/2 C Q . M >= 0. C i C C P (input) INTEGER C The actual output dimension, i.e., the order of the matrix C -1/2 C R . P >= 0. C i+1 C C SINV (input/output) DOUBLE PRECISION array, dimension C (LDSINV,N) C On entry, the leading N-by-N upper triangular part of this C -1 C array must contain S , the inverse of the square root C i C (right Cholesky factor) of the state covariance matrix C P (hence the information square root) at instant i. C i|i C On exit, the leading N-by-N upper triangular part of this C -1 C array contains S , the inverse of the square root (right C i+1 C Cholesky factor) of the state covariance matrix P C i+1|i+1 C (hence the information square root) at instant i+1. C The strict lower triangular part of this array is not C referenced. C C LDSINV INTEGER C The leading dimension of array SINV. LDSINV >= MAX(1,N). C C AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N) C -1 C The leading N-by-N part of this array must contain A , C i C the inverse of the state transition matrix of the discrete C system at instant i. C C LDAINV INTEGER C The leading dimension of array AINV. LDAINV >= 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 B , C -1 i C the input weight matrix (or the product A B if C i i C MULTAB = 'P') of the discrete system at instant i. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C RINV (input) DOUBLE PRECISION array, dimension (LDRINV,*) C If MULTRC = 'N', then the leading P-by-P upper triangular C -1/2 C part of this array must contain R , the inverse of the C i+1 C covariance square root (right Cholesky factor) of the C output (measurement) noise (hence the information square C root) at instant i+1. C The strict lower triangular part of this array is not C referenced. C Otherwise, RINV is not referenced and can be supplied as a C dummy array (i.e., set parameter LDRINV = 1 and declare C this array to be RINV(1,1) in the calling program). C C LDRINV INTEGER C The leading dimension of array RINV. C LDRINV >= MAX(1,P) if MULTRC = 'N'; C LDRINV >= 1 if MULTRC = 'P'. C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C The leading P-by-N part of this array must contain C , C -1/2 i+1 C the output weight matrix (or the product R C if C i+1 i+1 C MULTRC = 'P') of the discrete system at instant i+1. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C QINV (input/output) DOUBLE PRECISION array, dimension C (LDQINV,M) C On entry, the leading M-by-M upper triangular part of this C -1/2 C array must contain Q , the inverse of the covariance C i C square root (right Cholesky factor) of the input (process) C noise (hence the information square root) at instant i. C On exit, the leading M-by-M upper triangular part of this C -1/2 C array contains (QINOV ) , the inverse of the covariance C i C square root (right Cholesky factor) of the process noise C innovation (hence the information square root) at C instant i. C The strict lower triangular part of this array is not C referenced. C C LDQINV INTEGER C The leading dimension of array QINV. LDQINV >= MAX(1,M). C C X (input/output) DOUBLE PRECISION array, dimension (N) C On entry, this array must contain X , the estimated C i C filtered state at instant i. C On exit, if JOBX = 'X', and INFO = 0, then this array C contains X , the estimated filtered state at C i+1 C instant i+1. C On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then C -1 C this array contains S X . C i+1 i+1 C C RINVY (input) DOUBLE PRECISION array, dimension (P) C -1/2 C This array must contain R Y , the product of the C i+1 i+1 C -1/2 C upper triangular matrix R and the measured output C i+1 C vector Y at instant i+1. C i+1 C C Z (input) DOUBLE PRECISION array, dimension (M) C This array must contain Z , the mean value of the state C i C process noise at instant i. C C E (output) DOUBLE PRECISION array, dimension (P) C This array contains E , the estimated error at instant C i+1 C i+1. C C Tolerances C C TOL DOUBLE PRECISION C If JOBX = 'X', then TOL is used to test for near C -1 C singularity of the matrix S . If the user sets C i+1 C TOL > 0, then the given value of TOL is used as a C lower bound for the reciprocal condition number of that C matrix; a matrix whose estimated condition number is less C than 1/TOL is considered to be nonsingular. If the user C sets TOL <= 0, then an implicitly computed, default C tolerance, defined by TOLDEF = N*N*EPS, is used instead, C where EPS is the machine precision (see LAPACK Library C routine DLAMCH). C Otherwise, TOL is not referenced. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C where LIWORK = N if JOBX = 'X', C and LIWORK = 1 otherwise. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK. If INFO = 0 and JOBX = 'X', DWORK(2) returns C an estimate of the reciprocal of the condition number C -1 C (in the 1-norm) of S . C i+1 C C LDWORK The length of the array DWORK. C LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N), C if JOBX = 'N'; C LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N,3*N), C if JOBX = 'X'. 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; -1 C = 1: if JOBX = 'X' and the matrix S is singular, C i+1 -1 C i.e., the condition number estimate of S (in the C i+1 C -1 -1/2 C 1-norm) exceeds 1/TOL. The matrices S , Q C i+1 i C and E have been computed. C C METHOD C C The routine performs one recursion of the square root information C filter algorithm, summarized as follows: C C | -1/2 -1/2 | | -1/2 | C | Q 0 Q Z | | (QINOV ) * * | C | i i i | | i | C | | | | C | -1 -1 -1 -1 -1 | | -1 -1 | C T | S A B S A S X | = | 0 S S X | C | i i i i i i i | | i+1 i+1 i+1| C | | | | C | -1/2 -1/2 | | | C | 0 R C R Y | | 0 0 E | C | i+1 i+1 i+1 i+1| | i+1 | C C (Pre-array) (Post-array) C C where T is an orthogonal transformation triangularizing the C -1/2 C pre-array, (QINOV ) is the inverse of the covariance square C i C root (right Cholesky factor) of the process noise innovation C (hence the information square root) at instant i, and E is the C i+1 C estimated error at instant i+1. C C The inverse of the corresponding state covariance matrix P C i+1|i+1 C (hence the information matrix I) is then factorized as C C -1 -1 -1 C I = P = (S )' S C i+1|i+1 i+1|i+1 i+1 i+1 C C and one combined time and measurement update for the state is C given by X . C i+1 C C The triangularization is done entirely via Householder C transformations exploiting the zero pattern of the pre-array. C C REFERENCES C C [1] Anderson, B.D.O. and Moore, J.B. C Optimal Filtering. C Prentice Hall, Englewood Cliffs, New Jersey, 1979. C C [2] Verhaegen, M.H.G. and Van Dooren, P. C Numerical Aspects of Different Kalman Filter Implementations. C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. C C [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. C Algorithm 675: FORTRAN Subroutines for Computing the Square C Root Covariance Filter and Square Root Information Filter in C Dense or Hessenberg Forms. C ACM Trans. Math. Software, 15, pp. 243-256, 1989. C C NUMERICAL ASPECTS C C The algorithm requires approximately C C 3 2 2 2 C (7/6)N + N x (7/2 x M + P) + N x (1/2 x P + M ) C C operations and is backward stable (see [2]). C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C Supersedes Release 2.0 routine FB01GD by M. Vanbegin, C P. Van Dooren, and M.H.G. Verhaegen. C C REVISIONS C C February 20, 1998, November 20, 2003, February 14, 2004. C C KEYWORDS C C Kalman filtering, optimal filtering, orthogonal transformation, C recursive estimation, square-root filtering, square-root C information filtering. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER JOBX, MULTAB, MULTRC INTEGER INFO, LDAINV, LDB, LDC, LDQINV, LDRINV, LDSINV, $ LDWORK, M, N, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION AINV(LDAINV,*), B(LDB,*), C(LDC,*), DWORK(*), $ E(*), QINV(LDQINV,*), RINV(LDRINV,*), RINVY(*), $ SINV(LDSINV,*), X(*), Z(*) C .. Local Scalars .. LOGICAL LJOBX, LMULTA, LMULTR INTEGER I, I12, I13, I21, I23, IJ, ITAU, JWORK, LDW, M1, $ N1, NP, WRKOPT DOUBLE PRECISION RCOND C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL DDOT, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DLACPY, DORMQR, $ DTRMM, DTRMV, MB02OD, MB04KD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C NP = N + P N1 = MAX( 1, N ) M1 = MAX( 1, M ) INFO = 0 LJOBX = LSAME( JOBX, 'X' ) LMULTA = LSAME( MULTAB, 'P' ) LMULTR = LSAME( MULTRC, 'P' ) C C Test the input scalar arguments. C IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LMULTA .AND. .NOT.LSAME( MULTAB, 'N' ) ) THEN INFO = -2 ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( P.LT.0 ) THEN INFO = -6 ELSE IF( LDSINV.LT.N1 ) THEN INFO = -8 ELSE IF( LDAINV.LT.N1 ) THEN INFO = -10 ELSE IF( LDB.LT.N1 ) THEN INFO = -12 ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN INFO = -14 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -16 ELSE IF( LDQINV.LT.M1 ) THEN INFO = -18 ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(N + 2*M) + 3*M, $ NP*(N + 1) + 2*N, 3*N ) ) $ .OR. $ ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(N + 2*M) + 3*M, $ NP*(N + 1) + 2*N ) ) ) THEN INFO = -26 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'FB01SD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, P ).EQ.0 ) THEN IF ( LJOBX ) THEN DWORK(1) = TWO DWORK(2) = ONE ELSE DWORK(1) = ONE END IF RETURN END IF C C Construction of the needed part of the pre-array in DWORK. C To save workspace, only the blocks (1,3), (2,1)-(2,3), (3,2), and C (3,3) will be constructed when needed as shown below. C C Storing SINV x AINV and SINV x AINV x B in the (1,1) and (1,2) C blocks of DWORK, respectively. C The variables called Ixy define the starting positions where the C (x,y) blocks of the pre-array are initially stored in DWORK. C Workspace: need N*(N+M). 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 LDW = N1 I21 = N*N + 1 C CALL DLACPY( 'Full', N, N, AINV, LDAINV, DWORK, LDW ) IF ( LMULTA ) THEN CALL DLACPY( 'Full', N, M, B, LDB, DWORK(I21), LDW ) ELSE CALL DGEMM( 'No transpose', 'No transpose', N, M, N, ONE, $ DWORK, LDW, B, LDB, ZERO, DWORK(I21), LDW ) END IF CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, N+M, $ ONE, SINV, LDSINV, DWORK, LDW ) C C Storing the process noise mean value in (1,3) block of DWORK. C Workspace: need N*(N+M) + M. C I13 = N*( N + M ) + 1 C CALL DCOPY( M, Z, 1, DWORK(I13), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV, $ DWORK(I13), 1 ) C C Computing SINV x X in X. C CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV, $ X, 1 ) C C Triangularization (2 steps). C C Step 1: annihilate the matrix SINV x AINV x B. C Workspace: need N*(N+2*M) + 3*M. C I12 = I13 + M ITAU = I12 + M*N JWORK = ITAU + M C CALL MB04KD( 'Full', M, N, N, QINV, LDQINV, DWORK(I21), LDW, $ DWORK, LDW, DWORK(I12), M1, DWORK(ITAU), $ DWORK(JWORK) ) WRKOPT = MAX( 1, N*( N + 2*M ) + 3*M ) C IF ( N.EQ.0 ) THEN CALL DCOPY( P, RINVY, 1, E, 1 ) IF ( LJOBX ) $ DWORK(2) = ONE DWORK(1) = WRKOPT RETURN END IF C C Apply the transformations to the last column of the pre-array. C (Only the updated (2,3) block is now needed.) C IJ = I21 C DO 10 I = 1, M CALL DAXPY( N, -DWORK(ITAU+I-1)*( DWORK(I13+I-1) + $ DDOT( N, DWORK(IJ), 1, X, 1 ) ), $ DWORK(IJ), 1, X, 1 ) IJ = IJ + N 10 CONTINUE C C Now, the workspace for SINV x AINV x B, as well as for the updated C (1,2) block of the pre-array, are no longer needed. C Move the computed (2,3) block of the pre-array in the (1,2) block C position of DWORK, to save space for the following computations. C Then, adjust the implicitly defined leading dimension of DWORK, C to make space for storing the (3,2) and (3,3) blocks of the C pre-array. C Workspace: need (N+P)*(N+1). C CALL DCOPY( N, X, 1, DWORK(I21), 1 ) LDW = MAX( 1, NP ) C DO 30 I = N + 1, 1, -1 DO 20 IJ = N, 1, -1 DWORK(NP*(I-1)+IJ) = DWORK(N*(I-1)+IJ) 20 CONTINUE 30 CONTINUE C C Copy of RINV x C in the (2,1) block of DWORK. C CALL DLACPY( 'Full', P, N, C, LDC, DWORK(N+1), LDW ) IF ( .NOT.LMULTR ) $ CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N, $ ONE, RINV, LDRINV, DWORK(N+1), LDW ) C C Copy the inclusion measurement in the (2,2) block of DWORK. C I21 = NP*N + 1 I23 = I21 + N CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 ) WRKOPT = MAX( WRKOPT, NP*( N + 1 ) ) C C Step 2: QR factorization of the first block column of the matrix C C [ SINV x AINV SINV x X ] C [ RINV x C RINV x Y ], C C where the first block row was modified at Step 1. C Workspace: need (N+P)*(N+1) + 2*N; C prefer (N+P)*(N+1) + N + N*NB. C ITAU = I21 + NP JWORK = ITAU + N C CALL DGEQRF( NP, N, DWORK, LDW, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Apply the Householder transformations to the last column. C Workspace: need (N+P)*(N+1) + 1; prefer (N+P)*(N+1) + NB. C CALL DORMQR( 'Left', 'Transpose', NP, 1, N, DWORK, LDW, $ DWORK(ITAU), DWORK(I21), LDW, DWORK(JWORK), $ LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Output SINV, X, and E and set the optimal workspace dimension C (and the reciprocal of the condition number estimate). C CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV ) CALL DCOPY( N, DWORK(I21), 1, X, 1 ) CALL DCOPY( P, DWORK(I23), 1, E, 1 ) C IF ( LJOBX ) THEN C C Compute X. C Workspace: need 3*N. C CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit', $ '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND, $ TOL, IWORK, DWORK, INFO ) IF ( INFO.EQ.0 ) THEN WRKOPT = MAX( WRKOPT, 3*N ) DWORK(2) = RCOND END IF END IF C DWORK(1) = WRKOPT C RETURN C *** Last line of FB01SD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01NX.f0000644000000000000000000000013215012430707016216 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01NX.f0000644000175000017500000002644715012430707017427 0ustar00lilgelilge00000000000000 SUBROUTINE TG01NX( JOBT, N, M, P, NDIM, A, LDA, E, LDE, B, LDB, $ C, LDC, Q, LDQ, Z, LDZ, IWORK, INFO ) C C PURPOSE C C To compute equivalence transformation matrices Q and Z which C reduce the regular pole pencil A-lambda*E of the descriptor system C (A-lambda*E,B,C), with (A,E) in a generalized real Schur form, to C the block-diagonal form C C ( A1 0 ) ( E1 0 ) C Q*A*Z = ( ) , Q*E*Z = ( ) , (1) C ( 0 A2 ) ( 0 E2 ) C C where the pair (Q*A*Z,Q*E*Z) is in a generalized real Schur form, C with (A1,E1) and (A2,E2) having no common generalized eigenvalues. C This decomposition corresponds to an additive spectral C decomposition of the transfer-function matrix of the descriptor C system as the sum of two terms containing the generalized C eigenvalues of (A1,E1) and (A2,E2), respectively. C C ARGUMENTS C C Mode Parameters C C JOBT CHARACTER*1 C = 'D': compute the direct transformation matrices; C = 'I': compute the inverse transformation matrices C inv(Q) and inv(Z). C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrix B, the number of columns C of the matrix C and the order of the square matrices A C and E. N >= 0. C C M (input) INTEGER C The number of columns of the matrix B. M >= 0. C C P (input) INTEGER C The number of rows of the matrix C. P >= 0. C C NDIM (input) INTEGER C The dimension of the leading diagonal blocks of (A,E) C having generalized eigenvalues distinct from those of the C trailing diagonal block. 0 <= NDIM <= 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 N-by-N state matrix A in a real Schur form. C On exit, the leading N-by-N part of this array contains C the transformed state matrix Q*A*Z (if JOBT = 'D') or C inv(Q)*A*inv(Z) (if JOBT = 'I'), in the form (1), where C A1 is a NDIM-by-NDIM 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, the leading N-by-N part of this array must C contain the N-by-N descriptor matrix E in upper triangular C form. C On exit, the leading N-by-N part of this array contains C the transformed descriptor matrix Q*E*Z (if JOBT = 'D') or C inv(Q)*E*inv(Z) (if JOBT = 'I'), in the form (1), where C E1 is an NDIM-by-NDIM matrix. C C LDE INTEGER C The leading dimension of the array E. LDE >= 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 N-by-M input matrix B. C On exit, the leading N-by-M part of this array contains C the transformed input matrix Q*B (if JOBT = 'D') or C inv(Q)*B (if JOBT = 'I'). C C LDB INTEGER C The leading dimension of the 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 C. C On exit, the leading P-by-N part of this array contains C the transformed matrix C*Z (if JOBT = 'D') or C*inv(Z) C (if JOBT = 'I'). C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1,P). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, the leading N-by-N part of this array contains C Q1, the orthogonal left transformation matrix Q used to C reduce the pair (A,E) to the generalized real Schur form. C On exit, the leading N-by-N part of this array contains C the left transformation matrix Q = Q2*Q1, if JOBT = 'D', C or its inverse inv(Q), if JOBT = 'I'. 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, the leading N-by-N part of this array contains C the orthogonal right transformation matrix Z1 used to C reduce the pair (A,E) to the generalized real Schur form. C On exit, the leading N-by-N part of this array contains C the right transformation matrix Z = Z1*Z2, if JOBT = 'D', C or its inverse inv(Z), if JOBT = 'I'. C C LDZ INTEGER C The leading dimension of the array Z. LDZ >= MAX(1,N). C C Workspace C C IWORK INTEGER array, dimension (N+6) 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 separation of the two diagonal blocks failed C because of very close eigenvalues. C C METHOD C C For the separation, transformation matrices Q2 and Z2 of the form C C ( I -X ) ( I Y ) C Q2 = ( ) , Z2 = ( ) C ( 0 I ) ( 0 I ) C C are determined, such that Q2*A*Z2 and Q2*E*Z2 are block diagonal C as in (1). X and Y are computed by solving generalized Sylvester C equations. C C If we partition Q2*B and C*Z2 according to (1) in the form ( B1 ) C ( B2 ) C and ( C1 C2 ), then (A1-lambda*E1,B1,C1) and (A2-lambda*E2,B2,C2) C represent an additive spectral decomposition of the system C transfer-function matrix. C C REFERENCES C C [1] Kagstrom, B. and Van Dooren, P. C Additive decomposition of a transfer function with respect C to a specified region. C Proc. MTNS Symp., Brussels, 1989. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N**3 ) floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C November 2002. C C REVISIONS C C V. Sima, Dec. 2016. C C KEYWORDS C C Generalized eigenvalue problem, system poles, multivariable C system, additive decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER JOBT INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, M, N, NDIM, $ P C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), E(LDE,*), $ Q(LDQ,*), Z(LDZ,*) C .. Local Scalars .. LOGICAL TRINV DOUBLE PRECISION DIF, SCALE INTEGER I, N1, N11, N2 C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DGEMM, DLASET, DSWAP, DTGSYL, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. Executable Statements .. C C Test the input parameters. C INFO = 0 TRINV = LSAME( JOBT, 'I' ) IF( .NOT.LSAME( JOBT, 'D' ) .AND. .NOT.TRINV ) 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( NDIM.LT.0 .OR. NDIM.GT.N ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN INFO = -17 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'TG01NX', -INFO ) RETURN END IF C C Quick return if possible C IF( N.EQ.0 ) $ RETURN C IF( TRINV ) THEN C C Transpose Z in-situ. C DO 10 I = 2, N CALL DSWAP( I-1, Z(1,I), 1, Z(I,1), LDZ ) 10 CONTINUE C C Transpose Q in-situ. C DO 20 I = 2, N CALL DSWAP( I-1, Q(1,I), 1, Q(I,1), LDQ ) 20 CONTINUE END IF C C Let be A and E partitioned as ( A11 A12 ) and ( E11 E12 ). C ( 0 A22 ) ( 0 E22 ) C Split the pairs (A11,E11) and (A22,E22) by using the following C left and right transformation matrices C ( I -X ) ( I Y ) C Q2 = ( ) , Z2 = ( ) , C ( 0 I ) ( 0 I ) C where X and Y are computed by solving the generalized C Sylvester equations C C A11 * Y - X * A22 = scale * A12 C E11 * Y - X * E22 = scale * E12. C C -Y is computed in A12 and -X is computed in E12. C C Integer workspace: need N+6. C N1 = NDIM N2 = N - NDIM N11 = MIN( N1 + 1, N ) C IF( N1.GT.0 .AND. N2.GT.0 ) THEN CALL DTGSYL( 'No transpose', 0, N1, N2, A, LDA, A(N11,N11), $ LDA, A(1,N11), LDA, E, LDE, E(N11,N11), LDE, $ E(1,N11), LDE, SCALE, DIF, DUM, 1, IWORK, INFO ) IF( INFO.NE.0 ) THEN INFO = 1 RETURN END IF C C Transform B = ( B1 ) and C = ( C1 C2 ). C ( B2 ) C IF( SCALE.GT.0 ) $ SCALE = ONE/SCALE C C B1 <- B1 - X*B2. C CALL DGEMM( 'N', 'N', N1, M, N2, SCALE, E(1,N11), LDE, $ B(N11,1), LDB, ONE, B, LDB ) C C C2 <- C2 + C1*Y. C CALL DGEMM( 'N', 'N', P, N2, N1, -SCALE, C, LDC, A(1,N11), $ LDA, ONE, C(1,N11), LDC ) C IF( TRINV ) THEN C C Transform Q1 = ( Q11 Q12 ) and Z1 = ( Z11 ). C ( Z21 ) C C Q12 <- Q12 + Q11*X. C CALL DGEMM( 'N', 'N', N, N2, N1, -SCALE, Q, LDQ, E(1,N11), $ LDE, ONE, Q(1,N11), LDQ ) C C Z11 <- Z11 - Y*Z21. C CALL DGEMM( 'N', 'N', N1, N, N2, SCALE, A(1,N11), LDA, $ Z(N11,1), LDZ, ONE, Z, LDZ ) ELSE C C Transform Q1 = ( Q11 ) and Z1 = ( Z11 Z12 ). C ( Q21 ) C C Q11 <- Q11 - X*Q21. C CALL DGEMM( 'N', 'N', N1, N, N2, SCALE, E(1,N11), LDE, $ Q(N11,1), LDQ, ONE, Q, LDQ ) C C Z12 <- Z12 + Z11*Y. C CALL DGEMM( 'N', 'N', N, N2, N1, -SCALE, Z, LDZ, A(1,N11), $ LDA, ONE, Z(1,N11), LDZ ) END IF C C Set A12 and E12 to zero. C CALL DLASET( 'Full', N1, N2, ZERO, ZERO, A(1,N11), LDA ) CALL DLASET( 'Full', N1, N2, ZERO, ZERO, E(1,N11), LDE ) END IF C RETURN C *** Last line of TG01NX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01OS.f0000644000000000000000000000013215012430707016176 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01OS.f0000644000175000017500000002232415012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE MB01OS( UPLO, TRANS, N, H, LDH, X, LDX, P, LDP, INFO ) C C PURPOSE C C To compute P = H*X or P = X*H, where H is an upper Hessenberg C matrix and X is a symmetric matrix. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies which triangle of the symmetric matrix X is C 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 operation to be performed as follows: C = 'N': compute P = H*X; C = 'T' or 'C': compute P = X*H. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices H, X, and P. N >= 0. C C H (input) DOUBLE PRECISION array, dimension (LDH,N) C On entry, the leading N-by-N upper Hessenberg part of this C array must contain the upper Hessenberg matrix H. C The remaining part of this array is not referenced. C C LDH INTEGER C The leading dimension of the array H. LDH >= MAX(1,N). 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 C LDX INTEGER C The leading dimension of the array X. LDX >= MAX(1,N). C C P (output) DOUBLE PRECISION array, dimension (LDP,N) C On exit, the leading N-by-N part of this array contains C the computed matrix P. C C LDP INTEGER C The leading dimension of the array P. LDP >= MAX(1,N). 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 C structure into account, and using inline code and BLAS routines. C Let X = U + sL, where U is upper triangular and sL is strictly C lower triangular. Then, P = H*X = H*U + H*sL = H*U + H*sU', where C sU is the strictly upper triangular part of X. C Similarly, P = X*H = L'*H + sL*H, where L is lower triangular, and C X = L + sL'. Note that H*U and L'*H are both upper Hessenberg. C However, when UPLO = 'L' and TRANS = 'N', or when UPLO = 'U' and C TRANS = 'T', then the matrix P is full. The computations are done C similarly. C C NUMERICAL ASPECTS C C The algorithm requires approximately N**3/2 operations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2019. 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 TRANS, UPLO INTEGER INFO, LDH, LDP, LDX, N C .. Array Arguments .. DOUBLE PRECISION H(LDH,*), P(LDP,*), X(LDX,*) C .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, J, J3 LOGICAL LTRANS, LUPLO C .. Local Arrays .. DOUBLE PRECISION TMP(1) C .. External Functions .. DOUBLE PRECISION DDOT LOGICAL LSAME EXTERNAL DDOT, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DTRMM, DTRMV, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN 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 ( N.LT.0 ) THEN INFO = -3 ELSE IF ( LDH.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF ( LDX.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF ( LDP.LT.MAX( 1, N ) ) THEN INFO = -9 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01OS', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C IF ( .NOT.LTRANS ) THEN C IF ( LUPLO ) THEN TMP(1) = ZERO C C Compute P := H*U + H*sU'. C DO 30 J = 1, N - 1 CALL DCOPY( J, X(1,J), 1, P(1,J), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, H, LDH, P(1,J), $ 1 ) CALL DCOPY( N-J, TMP, 0, P(J+1,J), 1 ) C DO 10 I = 2, J + 1 P(I,J) = P(I,J) + H(I,I-1)*X(I-1,J) 10 CONTINUE C DO 20 I = J + 2, N CALL DAXPY( I, X(J,I-1), H(1,I-1), 1, P(1,J), 1 ) 20 CONTINUE C CALL DAXPY( N, X(J,N), H(1,N), 1, P(1,J), 1 ) 30 CONTINUE C CALL DCOPY( N, X(1,N), 1, P(1,N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', N, H, LDH, P(1,N), 1 ) C DO 40 I = 2, N P(I,N) = P(I,N) + H(I,I-1)*X(I-1,N) 40 CONTINUE C ELSE C C Compute P := H*L + H*sL'. C There is no contribution from sL' for the first column. C CALL DCOPY( N, X, 1, P, 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', N, H, LDH, P, 1 ) C DO 50 I = 2, N P(I,1) = P(I,1 ) + H(I,I-1)*X(I-1,1) 50 CONTINUE C DO 80 J = 2, N C C Compute the contribution from H*sL'. C CALL DCOPY( J-1, X(J,1), LDX, P(1,J), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', J-1, H, LDH, $ P(1,J), 1 ) P(J,J) = ZERO C DO 60 I = 2, J P(I,J) = P(I,J ) + H(I,I-1)*X(J,I-1) 60 CONTINUE C C Compute the contribution from H*L. C TEMP = P(J,J) CALL DGEMV( 'NoTran', J-1, N-J+1, ONE, H(1,J), LDH, $ X(J,J), 1, ONE, P(1,J), 1 ) CALL DCOPY( N-J+1, X(J,J), 1, P(J,J), 1 ) CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', N-J+1, H(J,J), $ LDH, P(J,J), 1 ) P(J,J) = P(J,J) + TEMP C DO 70 I = J+1, N P(I,J) = P(I,J ) + H(I,I-1)*X(I-1,J) 70 CONTINUE C 80 CONTINUE C END IF C ELSE C IF ( LUPLO ) THEN C C Compute P := U*H + sU'*H. C DO 90 J = 1, N - 2 J3 = MIN( J+3, N ) CALL DCOPY( J+1, H(1,J), 1, P(1,J), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J+1, X, LDX, $ P(1,J), 1 ) CALL DCOPY( J+1, H(1,J), 1, P(2,J+1), 1 ) CALL DTRMV( UPLO, 'Tran', 'NoDiag', J+1, X(1,2), LDX, $ P(2,J+1), 1 ) CALL DAXPY( J, ONE, P(2,J+1), 1, P(2,J), 1 ) P(J+2,J) = DDOT( J+1, X(1,J+2), 1, H(1,J), 1 ) CALL DGEMV( 'Tran', J+1, N-J3, ONE, X(1,J3), LDX, $ H(1,J), 1, ONE, P(J3,J), 1 ) P(N,J) = DDOT( J+1, X(1,N), 1, H(1,J), 1 ) 90 CONTINUE C IF ( N.EQ.1 ) THEN P(1,1) = X(1,1)*H(1,1) ELSE CALL DCOPY( N, H(1,N-1), 1, P(1,N-1), 1 ) CALL DCOPY( N, H(1,N), 1, P(1,N), 1 ) CALL DTRMM( 'Left', UPLO, 'NoTran', 'NoDiag', N, 2, ONE, $ X, LDX, P(1,N-1), LDP ) C DO 100 I = 2, N CALL DGEMV( 'Tran', I-1, 2, ONE, H(1,N-1), LDH, $ X(1,I), 1, ONE, P(I,N-1), LDP ) 100 CONTINUE C END IF C ELSE C C Compute P := L*H + sL'*H. C DO 110 J = 1, N - 1 CALL DCOPY( J, H(1,J), 1, P(1,J), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, X, LDX, P(1,J), $ 1 ) CALL DCOPY( J, H(2,J), 1, P(1,J+1), 1 ) CALL DTRMV( UPLO, 'Tran', 'NoDiag', J, X(2,1), LDX, $ P(1,J+1), 1 ) CALL DAXPY( J, ONE, P(1,J+1), 1, P(1,J), 1 ) CALL DGEMV( 'NoTran', N-J, J+1, ONE, X(J+1,1), LDX, $ H(1,J), 1, ZERO, P(J+1,J), 1 ) 110 CONTINUE C CALL DCOPY( N, H(1,N), 1, P(1,N), 1 ) CALL DTRMV( UPLO, 'NoTran', 'NoDiag', N, X, LDX, P(1,N), 1 ) C DO 120 I = 1, N - 1 P(I,N) = P(I,N) + DDOT( N-I, X(I+1,I), 1, H(I+1,N), 1 ) 120 CONTINUE C END IF C END IF C RETURN C *** Last line of MB01OS *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09JD.f0000644000000000000000000000013215012430707016146 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09JD.f0000644000175000017500000016171015012430707017350 0ustar00lilgelilge00000000000000 SUBROUTINE AB09JD( JOBV, JOBW, JOBINV, DICO, EQUIL, ORDSEL, $ N, NV, NW, M, P, NR, ALPHA, A, LDA, B, LDB, $ C, LDC, D, LDD, AV, LDAV, BV, LDBV, $ CV, LDCV, DV, LDDV, AW, LDAW, BW, LDBW, $ CW, LDCW, DW, LDDW, NS, HSV, TOL1, TOL2, $ IWORK, DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for an original C state-space representation (A,B,C,D) by using the frequency C weighted optimal Hankel-norm approximation method. C The Hankel norm of the weighted error C C op(V)*(G-Gr)*op(W) C C is minimized, where G and Gr are the transfer-function matrices C of the original and reduced systems, respectively, V and W are C invertible transfer-function matrices representing the left and C right frequency weights, and op(X) denotes X, inv(X), conj(X) or C conj(inv(X)). V and W are specified by their state space C realizations (AV,BV,CV,DV) and (AW,BW,CW,DW), respectively. C When minimizing ||V*(G-Gr)*W||, V and W must be antistable. C When minimizing inv(V)*(G-Gr)*inv(W), V and W must have only C antistable zeros. C When minimizing conj(V)*(G-Gr)*conj(W), V and W must be stable. C When minimizing conj(inv(V))*(G-Gr)*conj(inv(W)), V and W must C be minimum-phase. C If the original system is unstable, then the frequency weighted C Hankel-norm approximation is computed only for the C ALPHA-stable part of the system. C C For a transfer-function matrix G, conj(G) denotes the conjugate C of G given by G'(-s) for a continuous-time system or G'(1/z) C for a discrete-time system. C C ARGUMENTS C C Mode Parameters C C JOBV CHARACTER*1 C Specifies the left frequency-weighting as follows: C = 'N': V = I; C = 'V': op(V) = V; C = 'I': op(V) = inv(V); C = 'C': op(V) = conj(V); C = 'R': op(V) = conj(inv(V)). C C JOBW CHARACTER*1 C Specifies the right frequency-weighting as follows: C = 'N': W = I; C = 'W': op(W) = W; C = 'I': op(W) = inv(W); C = 'C': op(W) = conj(W); C = 'R': op(W) = conj(inv(W)). C C JOBINV CHARACTER*1 C Specifies the computational approach to be used as C follows: C = 'N': use the inverse free descriptor system approach; C = 'I': use the inversion based standard approach; C = 'A': switch automatically to the inverse free C descriptor approach in case of badly conditioned C feedthrough matrices in V or W (see METHOD). 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 EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e., the order of the matrix A. N >= 0. C C NV (input) INTEGER C The order of the realization of the left frequency C weighting V, i.e., the order of the matrix AV. NV >= 0. C C NW (input) INTEGER C The order of the realization of the right frequency C weighting W, i.e., the order of the matrix AW. NW >= 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of C the resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. For a system with NU ALPHA-unstable C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), C NR is set as follows: if ORDSEL = 'F', NR is equal to C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the C multiplicity of the Hankel singular value HSV(NR-NU+1), C NR is the desired order on entry, and NMIN is the order C of a minimal realization of the ALPHA-stable part of the C given system; NMIN is determined as the number of Hankel C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where C EPS is the machine precision (see LAPACK Library Routine C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the C ALPHA-stable part of the weighted system (computed in C HSV(1)); C if ORDSEL = 'A', NR is the sum of NU and the number of C Hankel singular values greater than C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). C C ALPHA (input) DOUBLE PRECISION C Specifies the ALPHA-stability boundary for the eigenvalues C of the state dynamics matrix A. For a continuous-time C system (DICO = 'C'), ALPHA <= 0 is the boundary value for C the real parts of eigenvalues, while for a discrete-time C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the C boundary value for the moduli of eigenvalues. C The ALPHA-stability domain does not include the boundary. 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, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the C reduced order system in a real Schur form. C The resulting A has a block-diagonal form with two blocks. C For a system with NU ALPHA-unstable eigenvalues and C NS ALPHA-stable eigenvalues (NU+NS = N), the leading C NU-by-NU block contains the unreduced part of A C corresponding to ALPHA-unstable eigenvalues. C The trailing (NR+NS-N)-by-(NR+NS-N) block contains C the reduced part of A corresponding to ALPHA-stable C eigenvalues. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) C On entry, if JOBV <> 'N', the leading NV-by-NV part of C this array must contain the state matrix AV of a state C space realization of the left frequency weighting V. C On exit, if JOBV <> 'N', and INFO = 0, the leading C NV-by-NV part of this array contains the real Schur form C of AV. C AV is not referenced if JOBV = 'N'. C C LDAV INTEGER C The leading dimension of the array AV. C LDAV >= MAX(1,NV), if JOBV <> 'N'; C LDAV >= 1, if JOBV = 'N'. C C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) C On entry, if JOBV <> 'N', the leading NV-by-P part of C this array must contain the input matrix BV of a state C space realization of the left frequency weighting V. C On exit, if JOBV <> 'N', and INFO = 0, the leading C NV-by-P part of this array contains the transformed C input matrix BV corresponding to the transformed AV. C BV is not referenced if JOBV = 'N'. C C LDBV INTEGER C The leading dimension of the array BV. C LDBV >= MAX(1,NV), if JOBV <> 'N'; C LDBV >= 1, if JOBV = 'N'. C C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) C On entry, if JOBV <> 'N', the leading P-by-NV part of C this array must contain the output matrix CV of a state C space realization of the left frequency weighting V. C On exit, if JOBV <> 'N', and INFO = 0, the leading C P-by-NV part of this array contains the transformed output C matrix CV corresponding to the transformed AV. C CV is not referenced if JOBV = 'N'. C C LDCV INTEGER C The leading dimension of the array CV. C LDCV >= MAX(1,P), if JOBV <> 'N'; C LDCV >= 1, if JOBV = 'N'. C C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) C If JOBV <> 'N', the leading P-by-P part of this array C must contain the feedthrough matrix DV of a state space C realization of the left frequency weighting V. C DV is not referenced if JOBV = 'N'. C C LDDV INTEGER C The leading dimension of the array DV. C LDDV >= MAX(1,P), if JOBV <> 'N'; C LDDV >= 1, if JOBV = 'N'. C C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) C On entry, if JOBW <> 'N', the leading NW-by-NW part of C this array must contain the state matrix AW of a state C space realization of the right frequency weighting W. C On exit, if JOBW <> 'N', and INFO = 0, the leading C NW-by-NW part of this array contains the real Schur form C of AW. C AW is not referenced if JOBW = 'N'. C C LDAW INTEGER C The leading dimension of the array AW. C LDAW >= MAX(1,NW), if JOBW <> 'N'; C LDAW >= 1, if JOBW = 'N'. C C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) C On entry, if JOBW <> 'N', the leading NW-by-M part of C this array must contain the input matrix BW of a state C space realization of the right frequency weighting W. C On exit, if JOBW <> 'N', and INFO = 0, the leading C NW-by-M part of this array contains the transformed C input matrix BW corresponding to the transformed AW. C BW is not referenced if JOBW = 'N'. C C LDBW INTEGER C The leading dimension of the array BW. C LDBW >= MAX(1,NW), if JOBW <> 'N'; C LDBW >= 1, if JOBW = 'N'. C C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) C On entry, if JOBW <> 'N', the leading M-by-NW part of C this array must contain the output matrix CW of a state C space realization of the right frequency weighting W. C On exit, if JOBW <> 'N', and INFO = 0, the leading C M-by-NW part of this array contains the transformed output C matrix CW corresponding to the transformed AW. C CW is not referenced if JOBW = 'N'. C C LDCW INTEGER C The leading dimension of the array CW. C LDCW >= MAX(1,M), if JOBW <> 'N'; C LDCW >= 1, if JOBW = 'N'. C C DW (input) DOUBLE PRECISION array, dimension (LDDW,M) C If JOBW <> 'N', the leading M-by-M part of this array C must contain the feedthrough matrix DW of a state space C realization of the right frequency weighting W. C DW is not referenced if JOBW = 'N'. C C LDDW INTEGER C The leading dimension of the array DW. C LDDW >= MAX(1,M), if JOBW <> 'N'; C LDDW >= 1, if JOBW = 'N'. C C NS (output) INTEGER C The dimension of the ALPHA-stable subsystem. C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, the leading NS elements of this array contain C the Hankel singular values, ordered decreasingly, of the C projection G1s of op(V)*G1*op(W) (see METHOD), where G1 C is the ALPHA-stable part of the original system. C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL1 = c*HNORM(G1s), where c is a constant in the C interval [0.00001,0.001], and HNORM(G1s) is the C Hankel-norm of the projection G1s of op(V)*G1*op(W) C (see METHOD), computed in HSV(1). C If TOL1 <= 0 on entry, the used default value is C TOL1 = NS*EPS*HNORM(G1s), where NS is the number of C ALPHA-stable eigenvalues of A and EPS is the machine C precision (see LAPACK Library Routine DLAMCH). C If ORDSEL = 'F', the value of TOL1 is ignored. C TOL1 < 1. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the ALPHA-stable part of the given system. C The recommended value is TOL2 = NS*EPS*HNORM(G1s). C This value is used by default if TOL2 <= 0 on entry. C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. C TOL2 < 1. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = MAX(1,M,c,d), if DICO = 'C', C LIWORK = MAX(1,N,M,c,d), if DICO = 'D', where C c = 0, if JOBV = 'N', C c = MAX(2*P,NV+P+N+6,2*NV+P+2), if JOBV <> 'N', C d = 0, if JOBW = 'N', C d = MAX(2*M,NW+M+N+6,2*NW+M+2), if JOBW <> 'N'. 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( LDW1, LDW2, LDW3, LDW4 ), where C for NVP = NV+P and NWM = NW+M we have C LDW1 = 0 if JOBV = 'N' and C LDW1 = 2*NVP*(NVP+P) + P*P + C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ) C if JOBV <> 'N', C LDW2 = 0 if JOBW = 'N' and C LDW2 = 2*NWM*(NWM+M) + M*M + C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ) C if JOBW <> 'N', C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + C MAX( 3*M+1, MIN(N,M)+P ). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than NSMIN, the sum of the order of the C ALPHA-unstable part and the order of a minimal C realization of the ALPHA-stable part of the given C system. In this case, the resulting NR is set equal C to NSMIN. C = 2: with ORDSEL = 'F', the selected order NR is less C than the order of the ALPHA-unstable part of the C given system. In this case NR is set equal to the C order of the ALPHA-unstable part. 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 computation of the ordered real Schur form of A C failed; C = 2: the separation of the ALPHA-stable/unstable C diagonal blocks failed because of very close C eigenvalues; C = 3: the reduction of AV to a real Schur form failed; C = 4: the reduction of AW to a real Schur form failed; C = 5: the reduction to generalized Schur form of the C descriptor pair corresponding to the inverse of V C failed; C = 6: the reduction to generalized Schur form of the C descriptor pair corresponding to the inverse of W C failed; C = 7: the computation of Hankel singular values failed; C = 8: the computation of stable projection in the C Hankel-norm approximation algorithm failed; C = 9: the order of computed stable projection in the C Hankel-norm approximation algorithm differs C from the order of Hankel-norm approximation; C = 10: the reduction of AV-BV*inv(DV)*CV to a C real Schur form failed; C = 11: the reduction of AW-BW*inv(DW)*CW to a C real Schur form failed; C = 12: the solution of the Sylvester equation failed C because the poles of V (if JOBV = 'V') or of C conj(V) (if JOBV = 'C') are not distinct from C the poles of G1 (see METHOD); C = 13: the solution of the Sylvester equation failed C because the poles of W (if JOBW = 'W') or of C conj(W) (if JOBW = 'C') are not distinct from C the poles of G1 (see METHOD); C = 14: the solution of the Sylvester equation failed C because the zeros of V (if JOBV = 'I') or of C conj(V) (if JOBV = 'R') are not distinct from C the poles of G1sr (see METHOD); C = 15: the solution of the Sylvester equation failed C because the zeros of W (if JOBW = 'I') or of C conj(W) (if JOBW = 'R') are not distinct from C the poles of G1sr (see METHOD); C = 16: the solution of the generalized Sylvester system C failed because the zeros of V (if JOBV = 'I') or C of conj(V) (if JOBV = 'R') are not distinct from C the poles of G1sr (see METHOD); C = 17: the solution of the generalized Sylvester system C failed because the zeros of W (if JOBW = 'I') or C of conj(W) (if JOBW = 'R') are not distinct from C the poles of G1sr (see METHOD); C = 18: op(V) is not antistable; C = 19: op(W) is not antistable; C = 20: V is not invertible; C = 21: W is not invertible. C C METHOD C C Let G be the transfer-function matrix of the original C linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t), (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09JD determines C the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t), (2) C C such that the corresponding transfer-function matrix Gr minimizes C the Hankel-norm of the frequency-weighted error C C op(V)*(G-Gr)*op(W). (3) C C For minimizing (3) with op(V) = V and op(W) = W, V and W are C assumed to have poles distinct from those of G, while with C op(V) = conj(V) and op(W) = conj(W), conj(V) and conj(W) are C assumed to have poles distinct from those of G. For minimizing (3) C with op(V) = inv(V) and op(W) = inv(W), V and W are assumed to C have zeros distinct from the poles of G, while with C op(V) = conj(inv(V)) and op(W) = conj(inv(W)), conj(V) and conj(W) C are assumed to have zeros distinct from the poles of G. C C Note: conj(G) = G'(-s) for a continuous-time system and C conj(G) = G'(1/z) for a discrete-time system. C C The following procedure is used to reduce G (see [1]): C C 1) Decompose additively G as C C G = G1 + G2, C C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and C G2 = (A2,B2,C2,0) has only ALPHA-unstable poles. C C 2) Compute G1s, the projection of op(V)*G1*op(W) containing the C poles of G1, using explicit formulas [4] or the inverse-free C descriptor system formulas of [5]. C C 3) Determine G1sr, the optimal Hankel-norm approximation of G1s, C of order r. C C 4) Compute G1r, the projection of inv(op(V))*G1sr*inv(op(W)) C containing the poles of G1sr, using explicit formulas [4] C or the inverse-free descriptor system formulas of [5]. C C 5) Assemble the reduced model Gr as C C Gr = G1r + G2. C C To reduce the weighted ALPHA-stable part G1s at step 3, the C optimal Hankel-norm approximation method of [2], based on the C square-root balancing projection formulas of [3], is employed. C C The optimal weighted approximation error satisfies C C HNORM[op(V)*(G-Gr)*op(W)] >= S(r+1), C C where S(r+1) is the (r+1)-th Hankel singular value of G1s, the C transfer-function matrix computed at step 2 of the above C procedure, and HNORM(.) denotes the Hankel-norm. C C REFERENCES C C [1] Latham, G.A. and Anderson, B.D.O. C Frequency-weighted optimal Hankel-norm approximation of stable C transfer functions. C Systems & Control Letters, Vol. 5, pp. 229-236, 1985. C C [2] Glover, K. C All optimal Hankel norm approximation of linear C multivariable systems and their L-infinity error bounds. C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. C C [3] Tombs, M.S. and Postlethwaite, I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C [4] Varga, A. C Explicit formulas for an efficient implementation C of the frequency-weighting model reduction approach. C Proc. 1993 European Control Conference, Groningen, NL, C pp. 693-696, 1993. C C [5] Varga, A. C Efficient and numerically reliable implementation of the C frequency-weighted Hankel-norm approximation model reduction C approach. C Proc. 2001 ECC, Porto, Portugal, 2001. C C NUMERICAL ASPECTS C C The implemented methods rely on an accuracy enhancing square-root C technique. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2001. C D. Sima, University of Bucharest, April 2001. C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. C C REVISIONS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. C V. Sima, Research Institute for Informatics, Bucharest, June 2001, C March 2005. C C KEYWORDS C C Frequency weighting, model reduction, multivariable system, C state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION C100, ONE, P0001, ZERO PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, P0001 = 0.0001D0, $ ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, JOBINV, JOBV, JOBW, ORDSEL INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, $ NR, NS, NV, NW, P DOUBLE PRECISION ALPHA, TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), $ HSV(*) C .. Local Scalars .. CHARACTER JOBVL, JOBWL LOGICAL AUTOM, CONJV, CONJW, DISCR, FIXORD, INVFR, $ LEFTI, LEFTW, RIGHTI, RIGHTW INTEGER IERR, IWARNL, KAV, KAW, KBV, KBW, KCV, KCW, KDV, $ KDW, KEV, KEW, KI, KL, KU, KW, LDABV, LDABW, $ LDCDV, LDCDW, LW, NRA, NU, NU1, NVP, NWM, RANK DOUBLE PRECISION ALPWRK, MAXRED, RCOND, SQREPS, TOL, WRKOPT C .. Local Arrays .. DOUBLE PRECISION TEMP(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB07ND, AB08MD, AB09CX, AB09JV, AB09JW, AG07BD, $ DLACPY, TB01ID, TB01KD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) FIXORD = LSAME( ORDSEL, 'F' ) LEFTI = LSAME( JOBV, 'I' ) .OR. LSAME( JOBV, 'R' ) LEFTW = LSAME( JOBV, 'V' ) .OR. LSAME( JOBV, 'C' ) .OR. LEFTI CONJV = LSAME( JOBV, 'C' ) .OR. LSAME( JOBV, 'R' ) RIGHTI = LSAME( JOBW, 'I' ) .OR. LSAME( JOBW, 'R' ) RIGHTW = LSAME( JOBW, 'W' ) .OR. LSAME( JOBW, 'C' ) .OR. RIGHTI CONJW = LSAME( JOBW, 'C' ) .OR. LSAME( JOBW, 'R' ) INVFR = LSAME( JOBINV, 'N' ) AUTOM = LSAME( JOBINV, 'A' ) C LW = 1 IF( LEFTW ) THEN NVP = NV + P LW = MAX( LW, 2*NVP*( NVP + P ) + P*P + $ MAX( 2*NVP*NVP + MAX( 11*NVP + 16, P*NVP ), $ NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ) ) END IF IF( RIGHTW ) THEN NWM = NW + M LW = MAX( LW, 2*NWM*( NWM + M ) + M*M + $ MAX( 2*NWM*NWM + MAX( 11*NWM + 16, M*NWM ), $ NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ) ) END IF LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 ) LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) C C Check the input scalar arguments. C IF( .NOT. ( LSAME( JOBV, 'N' ) .OR. LEFTW ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( JOBW, 'N' ) .OR. RIGHTW ) ) THEN INFO = -2 ELSE IF( .NOT. ( INVFR .OR. AUTOM .OR. LSAME( JOBINV, 'I' ) ) ) $ THEN INFO = -3 ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -4 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -5 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -6 ELSE IF( N.LT.0 ) THEN INFO = -7 ELSE IF( NV.LT.0 ) THEN INFO = -8 ELSE IF( NW.LT.0 ) THEN INFO = -9 ELSE IF( M.LT.0 ) THEN INFO = -10 ELSE IF( P.LT.0 ) THEN INFO = -11 ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -12 ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN INFO = -13 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -19 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -21 ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN INFO = -23 ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN INFO = -25 ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN INFO = -27 ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN INFO = -29 ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN INFO = -31 ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN INFO = -33 ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN INFO = -35 ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN INFO = -37 ELSE IF( TOL1.GE.ONE ) THEN INFO = -40 ELSE IF( ( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) $ .OR. TOL2.GE.ONE ) THEN INFO = -41 ELSE IF( LDWORK.LT.LW ) THEN INFO = -44 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09JD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 NS = 0 DWORK(1) = ONE RETURN END IF C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C Workspace: N. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Correct the value of ALPHA to ensure stability. C ALPWRK = ALPHA SQREPS = SQRT( DLAMCH( 'E' ) ) IF( DISCR ) THEN IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQREPS ELSE IF( ALPHA.EQ.ZERO ) ALPWRK = -SQREPS END IF C C Allocate working storage. C KU = 1 KL = KU + N*N KI = KL + N KW = KI + N C C Compute an additive decomposition G = G1 + G2, where G1 C is the ALPHA-stable projection of G. C C Reduce A to a block-diagonal real Schur form, with the NU-th order C ALPHA-unstable part in the leading diagonal position, using a C non-orthogonal similarity transformation A <- inv(T)*A*T and C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. C C Workspace needed: N*(N+2); C Additional workspace: need 3*N; C prefer larger. C CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) C IF( IERR.NE.0 ) THEN IF( IERR.NE.3 ) THEN INFO = 1 ELSE INFO = 2 END IF RETURN END IF C WRKOPT = DWORK(KW) + DBLE( KW-1 ) IWARNL = 0 C NS = N - NU IF( FIXORD ) THEN NRA = MAX( 0, NR-NU ) IF( NR.LT.NU ) $ IWARNL = 2 ELSE NRA = 0 END IF C C Finish if only unstable part is present. C IF( NS.EQ.0 ) THEN NR = NU DWORK(1) = WRKOPT RETURN END IF C NU1 = NU + 1 IF( CONJV ) THEN JOBVL = 'C' ELSE JOBVL = 'V' END IF IF( CONJW ) THEN JOBWL = 'C' ELSE JOBWL = 'W' END IF IF( LEFTW ) THEN C C Check if V is invertible. C Real workspace: need (NV+P)**2 + MAX( P + MAX(3*P,NV), C MIN(P+1,NV) + MAX(3*(P+1),NV+P) ); C prefer larger. C Integer workspace: need 2*NV+P+2. C TOL = ZERO CALL AB08MD( 'S', NV, P, P, AV, LDAV, BV, LDBV, CV, LDCV, $ DV, LDDV, RANK, TOL, IWORK, DWORK, LDWORK, $ IERR ) IF( RANK.NE.P ) THEN INFO = 20 RETURN END IF WRKOPT = MAX( WRKOPT, DWORK(1) ) C IF( LEFTI ) THEN IF( INVFR ) THEN IERR = 1 ELSE C C Allocate storage for a standard inverse of V. C Workspace: need NV*(NV+2*P) + P*P. C KAV = 1 KBV = KAV + NV*NV KCV = KBV + NV*P KDV = KCV + P*NV KW = KDV + P*P C LDABV = MAX( NV, 1 ) LDCDV = P CALL DLACPY( 'Full', NV, NV, AV, LDAV, $ DWORK(KAV), LDABV ) CALL DLACPY( 'Full', NV, P, BV, LDBV, $ DWORK(KBV), LDABV ) CALL DLACPY( 'Full', P, NV, CV, LDCV, $ DWORK(KCV), LDCDV ) CALL DLACPY( 'Full', P, P, DV, LDDV, $ DWORK(KDV), LDCDV ) C C Compute the standard inverse of V. C Additional real workspace: need MAX(1,4*P); C prefer larger. C Integer workspace: need 2*P. C CALL AB07ND( NV, P, DWORK(KAV), LDABV, DWORK(KBV), LDABV, $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) C C Check if inversion is accurate. C IF( AUTOM ) THEN IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 ELSE IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 END IF IF( IERR.NE.0 .AND. NV.EQ.0 ) THEN INFO = 20 RETURN END IF END IF C IF( IERR.NE.0 ) THEN C C Allocate storage for a descriptor inverse of V. C KAV = 1 KEV = KAV + NVP*NVP KBV = KEV + NVP*NVP KCV = KBV + NVP*P KDV = KCV + P*NVP KW = KDV + P*P C LDABV = MAX( NVP, 1 ) LDCDV = P C C DV is singular or ill-conditioned. C Form a descriptor inverse of V. C Workspace: need 2*(NV+P)*(NV+2*P) + P*P. C CALL AG07BD( 'I', NV, P, AV, LDAV, TEMP, 1, BV, LDBV, $ CV, LDCV, DV, LDDV, DWORK(KAV), LDABV, $ DWORK(KEV), LDABV, DWORK(KBV), LDABV, $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IERR ) C C Compute the projection containing the poles of weighted C reduced ALPHA-stable part using descriptor inverse of V C of order NVP = NV + P. C Additional real workspace: need C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ); C prefer larger. C Integer workspace: need NVP+N+6. C CALL AB09JV( JOBVL, DICO, 'G', 'C', NS, M, P, NVP, P, $ A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, D, LDD, $ DWORK(KAV), LDABV, DWORK(KEV), LDABV, $ DWORK(KBV), LDABV, DWORK(KCV), LDCDV, $ DWORK(KDV), LDCDV, IWORK, DWORK(KW), $ LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 5 ELSE IF( IERR.EQ.2 ) THEN INFO = 16 ELSE IF( IERR.EQ.4 ) THEN INFO = 18 END IF RETURN END IF ELSE C C Compute the projection containing the poles of weighted C reduced ALPHA-stable part using explicit inverse of V. C Additional real workspace: need C MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) C a = 0, if DICO = 'C' or JOBVL = 'V', C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; C prefer larger. C CALL AB09JV( JOBVL, DICO, 'I', 'C', NS, M, P, NV, P, $ A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, D, LDD, DWORK(KAV), LDABV, $ TEMP, 1, DWORK(KBV), LDABV, $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IWORK, $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 10 ELSE IF( IERR.EQ.3 ) THEN INFO = 14 ELSE IF( IERR.EQ.4 ) THEN INFO = 18 END IF RETURN END IF END IF C WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) ELSE C C Compute the projection of V*G1 or conj(V)*G1 containing the C poles of G. C C Workspace need: C real MAX( 1, NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) C a = 0, if DICO = 'C' or JOBVL = 'V', C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; C prefer larger. C CALL AB09JV( JOBVL, DICO, 'I', 'C', NS, M, P, NV, P, $ A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, D, LDD, AV, LDAV, $ TEMP, 1, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, $ DWORK, LDWORK, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 3 ELSE IF( IERR.EQ.3 ) THEN INFO = 12 ELSE IF( IERR.EQ.4 ) THEN INFO = 18 END IF RETURN END IF C WRKOPT = MAX( WRKOPT, DWORK(1) ) END IF END IF C IF( RIGHTW ) THEN C C Check if W is invertible. C Real workspace: need (NW+M)**2 + MAX( M + MAX(3*M,NW), C MIN(M+1,NW) + MAX(3*(M+1),NW+M) ); C prefer larger. C Integer workspace: need 2*NW+M+2. C TOL = ZERO CALL AB08MD( 'S', NW, M, M, AW, LDAW, BW, LDBW, CW, LDCW, $ DW, LDDW, RANK, TOL, IWORK, DWORK, LDWORK, $ IERR ) IF( RANK.NE.M ) THEN INFO = 21 RETURN END IF WRKOPT = MAX( WRKOPT, DWORK(1) ) C IF( RIGHTI ) THEN IF( INVFR ) THEN IERR = 1 ELSE C C Allocate storage for a standard inverse of W. C Workspace: need NW*(NW+2*M) + M*M. C KAW = 1 KBW = KAW + NW*NW KCW = KBW + NW*M KDW = KCW + M*NW KW = KDW + M*M C LDABW = MAX( NW, 1 ) LDCDW = M CALL DLACPY( 'Full', NW, NW, AW, LDAW, $ DWORK(KAW), LDABW ) CALL DLACPY( 'Full', NW, M, BW, LDBW, $ DWORK(KBW), LDABW ) CALL DLACPY( 'Full', M, NW, CW, LDCW, $ DWORK(KCW), LDCDW ) CALL DLACPY( 'Full', M, M, DW, LDDW, $ DWORK(KDW), LDCDW ) C C Compute the standard inverse of W. C Additional real workspace: need MAX(1,4*M); C prefer larger. C Integer workspace: need 2*M. C CALL AB07ND( NW, M, DWORK(KAW), LDABW, DWORK(KBW), LDABW, $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) C C Check if inversion is accurate. C IF( AUTOM ) THEN IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 ELSE IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 END IF IF( IERR.NE.0 .AND. NW.EQ.0 ) THEN INFO = 21 RETURN END IF END IF C IF( IERR.NE.0 ) THEN C C Allocate storage for a descriptor inverse of W. C KAW = 1 KEW = KAW + NWM*NWM KBW = KEW + NWM*NWM KCW = KBW + NWM*M KDW = KCW + M*NWM KW = KDW + M*M C LDABW = MAX( NWM, 1 ) LDCDW = M C C DW is singular or ill-conditioned. C Form the descriptor inverse of W. C Workspace: need 2*(NW+M)*(NW+2*M) + M*M. C CALL AG07BD( 'I', NW, M, AW, LDAW, TEMP, 1, BW, LDBW, $ CW, LDCW, DW, LDDW, DWORK(KAW), LDABW, $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, IERR ) C C Compute the projection containing the poles of weighted C reduced ALPHA-stable part using descriptor inverse of W C of order NWM = NW + M. C Additional real workspace: need C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ); C prefer larger. C Integer workspace: need NWM+N+6. C CALL AB09JW( JOBWL, DICO, 'G', 'C', NS, M, P, NWM, M, $ A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 6 ELSE IF( IERR.EQ.2 ) THEN INFO = 17 ELSE IF( IERR.EQ.4 ) THEN INFO = 19 END IF RETURN END IF ELSE C C Compute the projection containing the poles of weighted C reduced ALPHA-stable part using explicit inverse of W. C Additional real workspace: need C MAX( NW*(NW+5), NW*N + MAX( a, M*N, P*M ) ) C a = 0, if DICO = 'C' or JOBWL = 'W', C a = 2*NW, if DICO = 'D' and JOBWL = 'C'; C prefer larger. C CALL AB09JW( JOBWL, DICO, 'I', 'C', NS, M, P, NW, M, $ A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, $ TEMP, 1, DWORK(KBW), LDABW, $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 11 ELSE IF( IERR.EQ.3 ) THEN INFO = 15 ELSE IF( IERR.EQ.4 ) THEN INFO = 19 END IF RETURN END IF END IF C WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) ELSE C C Compute the projection G1s of V*G1*W or conj(V)*G1*conj(W) C containing the poles of G. C C Workspace need: C real MAX( 1, NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) C b = 0, if DICO = 'C' or JOBWL = 'W', C b = 2*NW, if DICO = 'D' and JOBWL = 'C'; C prefer larger. C CALL AB09JW( JOBWL, DICO, 'I', 'C', NS, M, P, NW, M, $ A(NU1,NU1), LDA, B(NU1,1), LDB, C(1,NU1), LDC, $ D, LDD, AW, LDAW, TEMP, 1, BW, LDBW, CW, LDCW, $ DW, LDDW, IWORK, DWORK, LDWORK, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 4 ELSE IF( IERR.EQ.3 ) THEN INFO = 13 ELSE IF( IERR.EQ.4 ) THEN INFO = 19 END IF RETURN END IF C WRKOPT = MAX( WRKOPT, DWORK(1) ) END IF END IF C C Determine a reduced order approximation G1sr of G1s using the C Hankel-norm approximation method. The resulting A(NU1:N,NU1:N) C is further in a real Schur form. C C Workspace: need MAX( LDW3, LDW4 ), C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + C MAX( 3*M+1, MIN(N,M)+P ); C prefer larger. C CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) C IF( IERR.NE.0 ) THEN C C Set INFO = 7, 8 or 9. C INFO = IERR + 5 RETURN END IF C IWARN = MAX( IWARNL, IWARN ) WRKOPT = MAX( WRKOPT, DWORK(1) ) C IF( LEFTW ) THEN IF( .NOT.LEFTI ) THEN IF( INVFR ) THEN IERR = 1 ELSE C C Allocate storage for a standard inverse of V. C Workspace: need NV*(NV+2*P) + P*P. C KAV = 1 KBV = KAV + NV*NV KCV = KBV + NV*P KDV = KCV + P*NV KW = KDV + P*P C LDABV = MAX( NV, 1 ) LDCDV = P CALL DLACPY( 'Full', NV, NV, AV, LDAV, $ DWORK(KAV), LDABV ) CALL DLACPY( 'Full', NV, P, BV, LDBV, $ DWORK(KBV), LDABV ) CALL DLACPY( 'Full', P, NV, CV, LDCV, $ DWORK(KCV), LDCDV ) CALL DLACPY( 'Full', P, P, DV, LDDV, $ DWORK(KDV), LDCDV ) C C Compute the standard inverse of V. C Additional real workspace: need MAX(1,4*P); C prefer larger. C Integer workspace: need 2*P. C CALL AB07ND( NV, P, DWORK(KAV), LDABV, DWORK(KBV), LDABV, $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) C C Check if inversion is accurate. C IF( AUTOM ) THEN IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 ELSE IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 END IF IF( IERR.NE.0 .AND. NV.EQ.0 ) THEN INFO = 20 RETURN END IF END IF C IF( IERR.NE.0 ) THEN C C Allocate storage for a descriptor inverse of V. C KAV = 1 KEV = KAV + NVP*NVP KBV = KEV + NVP*NVP KCV = KBV + NVP*P KDV = KCV + P*NVP KW = KDV + P*P C LDABV = MAX( NVP, 1 ) LDCDV = P C C DV is singular or ill-conditioned. C Form a descriptor inverse of V. C Workspace: need 2*(NV+P)*(NV+2*P) + P*P. C CALL AG07BD( 'I', NV, P, AV, LDAV, TEMP, 1, BV, LDBV, $ CV, LDCV, DV, LDDV, DWORK(KAV), LDABV, $ DWORK(KEV), LDABV, DWORK(KBV), LDABV, $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IERR ) C C Compute the projection containing the poles of weighted C reduced ALPHA-stable part using descriptor inverse of V C of order NVP = NV + P. C Additional real workspace: need C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ); C prefer larger. C Integer workspace: need NVP+N+6. C CALL AB09JV( JOBVL, DICO, 'G', 'N', NRA, M, P, NVP, P, $ A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, D, LDD, $ DWORK(KAV), LDABV, DWORK(KEV), LDABV, $ DWORK(KBV), LDABV, DWORK(KCV), LDCDV, $ DWORK(KDV), LDCDV, IWORK, DWORK(KW), $ LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 5 ELSE IF( IERR.EQ.2 ) THEN INFO = 16 END IF RETURN END IF ELSE C C Compute the projection containing the poles of weighted C reduced ALPHA-stable part using explicit inverse of V. C Additional real workspace: need C MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) C a = 0, if DICO = 'C' or JOBVL = 'V', C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; C prefer larger. C CALL AB09JV( JOBVL, DICO, 'I', 'N', NRA, M, P, NV, P, $ A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, D, LDD, DWORK(KAV), LDABV, $ TEMP, 1, DWORK(KBV), LDABV, $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IWORK, $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 10 ELSE IF( IERR.EQ.3 ) THEN INFO = 14 END IF RETURN END IF END IF C WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) ELSE C C Compute the projection of V*G1sr or conj(V)*G1sr containing C the poles of G. C C Workspace need: C real MAX( 1, NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) C a = 0, if DICO = 'C' or JOBVL = 'V', C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; C prefer larger. C CALL AB09JV( JOBVL, DICO, 'I', 'N', NRA, M, P, NV, P, $ A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, D, LDD, AV, LDAV, $ TEMP, 1, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, $ DWORK, LDWORK, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 3 ELSE IF( IERR.EQ.3 ) THEN INFO = 12 END IF RETURN END IF C WRKOPT = MAX( WRKOPT, DWORK(1) ) END IF END IF C IF( RIGHTW ) THEN IF( .NOT.RIGHTI ) THEN IF( INVFR ) THEN IERR = 1 ELSE C C Allocate storage for a standard inverse of W. C Workspace: need NW*(NW+2*M) + M*M. C KAW = 1 KBW = KAW + NW*NW KCW = KBW + NW*M KDW = KCW + M*NW KW = KDW + M*M C LDABW = MAX( NW, 1 ) LDCDW = M CALL DLACPY( 'Full', NW, NW, AW, LDAW, $ DWORK(KAW), LDABW ) CALL DLACPY( 'Full', NW, M, BW, LDBW, $ DWORK(KBW), LDABW ) CALL DLACPY( 'Full', M, NW, CW, LDCW, $ DWORK(KCW), LDCDW ) CALL DLACPY( 'Full', M, M, DW, LDDW, $ DWORK(KDW), LDCDW ) C C Compute the standard inverse of W. C Additional real workspace: need MAX(1,4*M); C prefer larger. C Integer workspace: need 2*M. C CALL AB07ND( NW, M, DWORK(KAW), LDABW, DWORK(KBW), LDABW, $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) C C Check if inversion is accurate. C IF( AUTOM ) THEN IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 ELSE IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 END IF IF( IERR.NE.0 .AND. NW.EQ.0 ) THEN INFO = 21 RETURN END IF END IF C IF( IERR.NE.0 ) THEN C C Allocate storage for a descriptor inverse of W. C KAW = 1 KEW = KAW + NWM*NWM KBW = KEW + NWM*NWM KCW = KBW + NWM*M KDW = KCW + M*NWM KW = KDW + M*M C LDABW = MAX( NWM, 1 ) LDCDW = M C C DW is singular or ill-conditioned. C Form the descriptor inverse of W. C Workspace: need 2*(NW+M)*(NW+2*M) + M*M. C CALL AG07BD( 'I', NW, M, AW, LDAW, TEMP, 1, BW, LDBW, $ CW, LDCW, DW, LDDW, DWORK(KAW), LDABW, $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, IERR ) C C Compute the projection containing the poles of weighted C reduced ALPHA-stable part using descriptor inverse of W C of order NWM = NW + M. C Additional real workspace: need C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ); C prefer larger. C Integer workspace: need NWM+N+6. C CALL AB09JW( JOBWL, DICO, 'G', 'N', NRA, M, P, NWM, M, $ A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 6 ELSE IF( IERR.EQ.2 ) THEN INFO = 17 END IF RETURN END IF ELSE C C Compute the projection containing the poles of weighted C reduced ALPHA-stable part using explicit inverse of W. C Additional real workspace: need C MAX( NW*(NW+5), NW*N + MAX( a, M*N, P*M ) ) C a = 0, if DICO = 'C' or JOBWL = 'W', C a = 2*NW, if DICO = 'D' and JOBWL = 'C'; C prefer larger. C CALL AB09JW( JOBWL, DICO, 'I', 'N', NRA, M, P, NW, M, $ A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, $ TEMP, 1, DWORK(KBW), LDABW, $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 11 ELSE IF( IERR.EQ.3 ) THEN INFO = 15 END IF RETURN END IF END IF C WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) ELSE C C Compute the projection G1r of V*G1sr*W or C conj(V)*G1sr*conj(W) containing the poles of G. C C Workspace need: C real MAX( 1, NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) C b = 0, if DICO = 'C' or JOBWL = 'W', C b = 2*NW, if DICO = 'D' and JOBWL = 'C'; C prefer larger. C CALL AB09JW( JOBWL, DICO, 'I', 'N', NRA, M, P, NW, M, $ A(NU1,NU1), LDA, B(NU1,1), LDB, C(1,NU1), LDC, $ D, LDD, AW, LDAW, TEMP, 1, BW, LDBW, CW, LDCW, $ DW, LDDW, IWORK, DWORK, LDWORK, IERR ) C IF( IERR.NE.0 ) THEN IF( IERR.EQ.1 ) THEN INFO = 4 ELSE IF( IERR.EQ.3 ) THEN INFO = 13 END IF RETURN END IF C WRKOPT = MAX( WRKOPT, DWORK(1) ) END IF END IF C NR = NRA + NU DWORK(1) = WRKOPT C RETURN C *** Last line of AB09JD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04BP.f0000644000000000000000000000013215012430707016161 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04BP.f0000644000175000017500000016220315012430707017361 0ustar00lilgelilge00000000000000 SUBROUTINE MB04BP( JOB, COMPQ1, COMPQ2, N, A, LDA, DE, LDDE, C1, $ LDC1, VW, LDVW, Q1, LDQ1, Q2, LDQ2, B, LDB, F, $ LDF, C2, LDC2, ALPHAR, ALPHAI, BETA, IWORK, $ LIWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the eigenvalues of a real N-by-N skew-Hamiltonian/ C Hamiltonian pencil aS - bH with C C ( A D ) ( C V ) C S = ( ) and H = ( ). (1) C ( E A' ) ( W -C' ) C C Optionally, if JOB = 'T', decompositions of S and H will be C computed via orthogonal transformations Q1 and Q2 as follows: C C ( Aout Dout ) C Q1' S J Q1 J' = ( ), C ( 0 Aout' ) C C ( Bout Fout ) C J' Q2' J S Q2 = ( ) =: T, (2) C ( 0 Bout' ) C C ( C1out Vout ) ( 0 I ) C Q1' H Q2 = ( ), where J = ( ) C ( 0 C2out' ) ( -I 0 ) C C and Aout, Bout, C1out are upper triangular, C2out is upper quasi- C triangular and Dout and Fout are skew-symmetric. The notation M' C denotes the transpose of the matrix M. C Optionally, if COMPQ1 = 'I' or COMPQ1 = 'U', then the orthogonal C transformation matrix Q1 will be computed. C Optionally, if COMPQ2 = 'I' or COMPQ2 = 'U', then the orthogonal C transformation matrix Q2 will be computed. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'E': compute the eigenvalues only; S and H will not C necessarily be transformed as in (2). C = 'T': put S and H into the forms in (2) and return the C eigenvalues in ALPHAR, ALPHAI and BETA. C C COMPQ1 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q1, as follows: C = 'N': Q1 is not computed; C = 'I': the array Q1 is initialized internally to the unit C matrix, and the orthogonal matrix Q1 is returned; C = 'U': the array Q1 contains an orthogonal matrix Q on C entry, and the product Q*Q1 is returned, where Q1 C is the product of the orthogonal transformations C that are applied to the pencil aS - bH to reduce C S and H to the forms in (2), for COMPQ1 = 'I'. C C COMPQ2 CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrix Q2, as follows: C = 'N': Q2 is not computed; C = 'I': on exit, the array Q2 contains the orthogonal C matrix Q2; C = 'U': on exit, the array Q2 contains the matrix product C J*Q*J'*Q2, where Q2 is the product of the C orthogonal transformations that are applied to C the pencil aS - bH to reduce S and H to the forms C in (2), for COMPQ2 = 'I'. C Setting COMPQ2 <> 'N' assumes COMPQ2 = COMPQ1. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix A. C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix Aout; otherwise, it contains the C upper triangular matrix A obtained just before the C application of the periodic QZ algorithm. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C DE (input/output) DOUBLE PRECISION array, dimension C (LDDE, N/2+1) C On entry, the leading N/2-by-N/2 strictly lower triangular C part of this array must contain the strictly lower C triangular part of the skew-symmetric matrix E, and the C N/2-by-N/2 strictly upper triangular part of the submatrix C in the columns 2 to N/2+1 of this array must contain the C strictly upper triangular part of the skew-symmetric C matrix D. C The entries on the diagonal and the first superdiagonal of C this array need not be set, but are assumed to be zero. C On exit, if JOB = 'T', the leading N/2-by-N/2 strictly C upper triangular part of the submatrix in the columns 2 to C N/2+1 of this array contains the strictly upper triangular C part of the skew-symmetric matrix Dout. C If JOB = 'E', the leading N/2-by-N/2 strictly upper C triangular part of the submatrix in the columns 2 to N/2+1 C of this array contains the strictly upper triangular part C of the skew-symmetric matrix D just before the application C of the periodic QZ algorithm. The remaining entries are C meaningless. C C LDDE INTEGER C The leading dimension of the array DE. C LDDE >= MAX(1, N/2). C C C1 (input/output) DOUBLE PRECISION array, dimension C (LDC1, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix C1 = C. C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix C1out; otherwise, it contains C the upper triangular matrix C1 obtained just before the C application of the periodic QZ algorithm. C C LDC1 INTEGER C The leading dimension of the array C1. C LDC1 >= MAX(1, N/2). C C VW (input/output) DOUBLE PRECISION array, dimension C (LDVW, N/2+1) C On entry, the leading N/2-by-N/2 lower triangular part of C this array must contain the lower triangular part of the C symmetric matrix W, and the N/2-by-N/2 upper triangular C part of the submatrix in the columns 2 to N/2+1 of this C array must contain the upper triangular part of the C symmetric matrix V. C On exit, if JOB = 'T', the N/2-by-N/2 part in the columns C 2 to N/2+1 of this array contains the matrix Vout. C If JOB = 'E', the N/2-by-N/2 part in the columns 2 to C N/2+1 of this array contains the matrix V just before the C application of the periodic QZ algorithm. C C LDVW INTEGER C The leading dimension of the array VW. C LDVW >= MAX(1, N/2). C C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1, N) C On entry, if COMPQ1 = 'U', then the leading N-by-N part of C this array must contain a given matrix Q, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q and the transformation matrix Q1 C used to transform the matrices S and H. C On exit, if COMPQ1 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q1. C If COMPQ1 = 'N', this array is not referenced. C C LDQ1 INTEGER C The leading dimension of the array Q1. C LDQ1 >= 1, if COMPQ1 = 'N'; C LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N) C On exit, if COMPQ2 = 'U', then the leading N-by-N part of C this array contains the product of the matrix J*Q*J' and C the transformation matrix Q2 used to transform the C matrices S and H. C On exit, if COMPQ2 = 'I', then the leading N-by-N part of C this array contains the orthogonal transformation matrix C Q2. C If COMPQ2 = 'N', this array is not referenced. C C LDQ2 INTEGER C The leading dimension of the array Q2. C LDQ2 >= 1, if COMPQ2 = 'N'; C LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'. C C B (output) DOUBLE PRECISION array, dimension (LDB, N/2) C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix Bout; otherwise, it contains the C upper triangular matrix B obtained just before the C application of the periodic QZ algorithm. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C F (output) DOUBLE PRECISION array, dimension (LDF, N/2) C On exit, if JOB = 'T', the leading N/2-by-N/2 strictly C upper triangular part of this array contains the strictly C upper triangular part of the skew-symmetric matrix Fout. C If JOB = 'E', the leading N/2-by-N/2 strictly upper C triangular part of this array contains the strictly upper C triangular part of the skew-symmetric matrix F just before C the application of the periodic QZ algorithm. C The entries on the leading N/2-by-N/2 lower triangular C part of this array are not referenced. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1, N/2). C C C2 (output) DOUBLE PRECISION array, dimension (LDC2, N/2) C On exit, if JOB = 'T', the leading N/2-by-N/2 part of this C array contains the matrix C2out; otherwise, it contains C the upper Hessenberg matrix C2 obtained just before the C application of the periodic QZ algorithm. C C LDC2 INTEGER C The leading dimension of the array C2. C LDC2 >= MAX(1, N/2). C C ALPHAR (output) DOUBLE PRECISION array, dimension (N/2) C The real parts of each scalar alpha defining an eigenvalue C of the pencil aS - bH. C C ALPHAI (output) DOUBLE PRECISION array, dimension (N/2) C The imaginary parts of each scalar alpha defining an C eigenvalue of the pencil aS - bH. C If ALPHAI(j) is zero, then the j-th eigenvalue is real. C C BETA (output) DOUBLE PRECISION array, dimension (N/2) C The scalars beta that define the eigenvalues of the pencil C aS - bH. C Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and C beta = BETA(j) represent the j-th eigenvalue of the pencil C aS - bH, in the form lambda = alpha/beta. Since lambda may C overflow, the ratios should not, in general, be computed. C Due to the skew-Hamiltonian/Hamiltonian structure of the C pencil, for every eigenvalue lambda, -lambda is also an C eigenvalue, and thus it has only to be saved once in C ALPHAR, ALPHAI and BETA. C Specifically, only eigenvalues with imaginary parts C greater than or equal to zero are stored; their conjugate C eigenvalues are not stored. If imaginary parts are zero C (i.e., for real eigenvalues), only positive eigenvalues C are stored. The remaining eigenvalues have opposite signs. C As a consequence, pairs of complex eigenvalues, stored in C consecutive locations, are not complex conjugate. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C On exit, if INFO = 3, IWORK(1) contains the number of C (pairs of) possibly inaccurate eigenvalues, q <= N/2, and C IWORK(2), ..., IWORK(q+1) indicate their indices. C Specifically, a positive value is an index of a real or C purely imaginary eigenvalue, corresponding to a 1-by-1 C block, while the absolute value of a negative entry in C IWORK is an index to the first eigenvalue in a pair of C consecutively stored eigenvalues, corresponding to a C 2-by-2 block. A 2-by-2 block may have two complex, two C real, two purely imaginary, or one real and one purely C imaginary eigenvalue. C For i = q+2, ..., 2*q+1, IWORK(i) contains a pointer to C the starting location in DWORK of the i-th quadruple of C 1-by-1 blocks, if IWORK(i-q) > 0, or 2-by-2 blocks, C if IWORK(i-q) < 0, defining unreliable eigenvalues. C IWORK(2*q+2) contains the number of the 1-by-1 blocks, and C IWORK(2*q+3) contains the number of the 2-by-2 blocks, C corresponding to unreliable eigenvalues. IWORK(2*q+4) C contains the total number t of the 2-by-2 blocks. C If INFO = 0, then q = 0, therefore IWORK(1) = 0. C C LIWORK INTEGER C The dimension of the array IWORK. LIWORK >= N+12. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or INFO = 3, DWORK(1) returns the C optimal LDWORK, and DWORK(2), ..., DWORK(5) contain the C Frobenius norms of the factors of the formal matrix C product used by the algorithm. In addition, DWORK(6), ..., C DWORK(5+4*s) contain the s quadruple values corresponding C to the 1-by-1 blocks. Their eigenvalues are real or purely C imaginary. Such an eigenvalue is obtained from C -i*sqrt(a1*a3/a2/a4), but always taking a positive sign, C where a1, ..., a4 are the corresponding quadruple values. C Moreover, DWORK(6+4*s), ..., DWORK(5+4*s+16*t) contain the C t groups of quadruple 2-by-2 matrices corresponding to the C 2-by-2 blocks. Their eigenvalue pairs are either complex, C or placed on the real and imaginary axes. Such an C eigenvalue pair is obtained as -1i*sqrt(ev), but taking C positive imaginary parts, where ev are the eigenvalues of C the product A1*inv(A2)*A3*inv(A4), where A1, ..., A4 C define the corresponding 2-by-2 matrix quadruple. C On exit, if INFO = -27, DWORK(1) returns the minimum value C of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C If JOB = 'E' and COMPQ1 = 'N' and COMPQ2 = 'N', C LDWORK >= N**2 + MAX(L,36); C if JOB = 'T' or COMPQ1 <> 'N' or COMPQ2 <> 'N', C LDWORK >= 2*N**2 + MAX(L,36); C where C L = 4*N + 4, if N/2 is even, and C L = 4*N, if N/2 is odd. C For good performance LDWORK should generally be larger. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value; C = 1: problem during computation of the eigenvalues; C = 2: periodic QZ algorithm did not converge in the SLICOT C Library subroutine MB03BD; C = 3: some eigenvalues might be inaccurate, and details can C be found in IWORK and DWORK. This is a warning. C C METHOD C C The algorithm uses Givens rotations and Householder reflections to C annihilate elements in S, T, and H such that A, B, and C1 are C upper triangular and C2 is upper Hessenberg. Finally, the periodic C QZ algorithm is applied to transform C2 to upper quasi-triangular C form while A, B, and C1 stay in upper triangular form. C See also page 27 in [1] for more details. C C REFERENCES C C [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) real C floating point operations. C C FURTHER COMMENTS C C For large values of N, the routine applies the transformations C for reducing T on panels of columns. The user may specify in INFO C the desired number of columns. If on entry INFO < 0, then the C routine estimates a suitable value of this number. If INFO = 0, C the routine MB04BD is directly called. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, July 2011. C C REVISIONS C C M. Voigt, Jan. 2012, July 2013, June 2014, July 2014. C V. Sima, Oct. 2012, Jan. 2013, Feb. 2013, July 2013, July 2014, C Aug. 2014, June 2015, Jan. 2017, Mar. 2020, Apr. 2020, Sep. 2022. C C KEYWORDS C C periodic QZ algorithm, upper (quasi-)triangular matrix, C skew-Hamiltonian/Hamiltonian pencil. C C ****************************************************************** C C .. Parameters .. C NX is the maximum value of N for which MB04BD can be called. DOUBLE PRECISION ZERO, HALF, ONE, TWO, FIVE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, $ TWO = 2.0D+0, FIVE = 5.0D+0 ) INTEGER NX PARAMETER ( NX = 250 ) C C .. Scalar Arguments .. CHARACTER COMPQ1, COMPQ2, JOB INTEGER INFO, LDA, LDB, LDC1, LDC2, LDDE, LDF, LDQ1, $ LDQ2, LDVW, LDWORK, LIWORK, N C C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), C1( LDC1, * ), $ C2( LDC2, * ), DE( LDDE, * ), DWORK( * ), $ F( LDF, * ), Q1( LDQ1, * ), Q2( LDQ2, * ), $ VW( LDVW, * ) C C .. Local Scalars .. LOGICAL LCMPQ1, LCMPQ2, LINIQ1, LINIQ2, LTRI, LUPDQ1, $ LUPDQ2, UNREL CHARACTER*16 CMPQ, CMPSC INTEGER EMAX, EMIN, I, I11, I22, I2X2, IC, ICS, IMAT, $ IW, IWARN, IWRK, J, JA, JB, JC, JE, JS, K, L, $ M, M1, MJ2, MJ3, MK1, MK2, MK3, MM, N1, N2, N3, $ NB, NBETA0, NC, NINF, OPTDW, P DOUBLE PRECISION BASE, CO, MU, NU, SI, TEMP, TMP1, TMP2 COMPLEX*16 EIG C C .. Local Arrays .. INTEGER IDUM( 1 ) DOUBLE PRECISION DUM( 4 ) C C .. External Functions .. LOGICAL LSAME INTEGER MA02OD DOUBLE PRECISION DDOT, DLAMCH, DLANTR, DLAPY2 EXTERNAL DDOT, DLAMCH, DLANTR, DLAPY2, LSAME, MA02OD C C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DLACPY, DLARF, $ DLARFG, DLARTG, DLASET, DROT, DSYMV, DSYR2, $ MA02AD, MA02PD, MB01LD, MB01MD, MB01ND, MB03BD, $ MB04BD, XERBLA C C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD, $ SQRT C C .. Executable Statements .. C C Decode the input arguments. C NB = INFO M = N/2 MM = M*M M1 = MAX( 1, M ) LTRI = LSAME( JOB, 'T' ) LINIQ1 = LSAME( COMPQ1, 'I' ) LINIQ2 = LSAME( COMPQ2, 'I' ) LUPDQ1 = LSAME( COMPQ1, 'U' ) LUPDQ2 = LSAME( COMPQ2, 'U' ) LCMPQ1 = LUPDQ1 .OR. LINIQ1 LCMPQ2 = LUPDQ2 .OR. LINIQ2 C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPQ1, 'N' ) .OR. LCMPQ1 ) ) THEN INFO = -2 ELSE IF( .NOT.( LSAME( COMPQ2, 'N' ) .OR. LCMPQ2 ) ) THEN INFO = -3 ELSE IF( ( LINIQ2 .AND. .NOT.LINIQ1 ) .OR. $ ( LUPDQ2 .AND. .NOT.LUPDQ1 ) ) THEN INFO = -3 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -4 ELSE IF( LDA.LT.M1 ) THEN INFO = -6 ELSE IF( LDDE.LT.M1 ) THEN INFO = -8 ELSE IF( LDC1.LT.M1 ) THEN INFO = -10 ELSE IF( LDVW.LT.M1 ) THEN INFO = -12 ELSE IF( LDQ1.LT.1 .OR. ( LCMPQ1 .AND. LDQ1.LT.N ) ) THEN INFO = -14 ELSE IF( LDQ2.LT.1 .OR. ( LCMPQ2 .AND. LDQ2.LT.N ) ) THEN INFO = -16 ELSE IF( LDB.LT.M1 ) THEN INFO = -18 ELSE IF( LDF.LT.M1 ) THEN INFO = -20 ELSE IF( LDC2.LT.M1 ) THEN INFO = -22 ELSE IF( LIWORK.LT.N+12 ) THEN INFO = -27 ELSE IF( MOD( M, 2 ).EQ.0 ) THEN I = MAX( 4*N, 32 ) + 4 ELSE I = MAX( 4*N, 36 ) END IF IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 ) THEN OPTDW = 8*MM + I ELSE OPTDW = 4*MM + I END IF IF( LDWORK.LT.OPTDW ) $ INFO = -29 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04BP', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IWORK( 1 ) = 0 DWORK( 1 ) = FIVE DWORK( 2 ) = ZERO DWORK( 3 ) = ZERO DWORK( 4 ) = ZERO DWORK( 5 ) = ZERO RETURN END IF C C A block algorithm is used for large M. C IF( NB.EQ.0 .OR. ( NB.LT.0 .AND. N.LE.NX ) ) THEN CALL MB04BD( JOB, COMPQ1, COMPQ2, N, A, LDA, DE, LDDE, C1, $ LDC1, VW, LDVW, Q1, LDQ1, Q2, LDQ2, B, LDB, F, $ LDF, C2, LDC2, ALPHAR, ALPHAI, BETA, IWORK, $ LIWORK, DWORK, LDWORK, INFO ) RETURN ELSE IF( NB.LT.0 ) THEN CALL DGEQRF( M, M, A, LDA, DWORK, DWORK, -1, INFO ) NB = MIN( MAX( INT( DWORK( 1 ) )/M1, 2 ), M ) END IF C C Determine machine constants. C BASE = DLAMCH( 'Base' ) EMIN = INT( DLAMCH( 'Minimum Exponent' ) ) EMAX = INT( DLAMCH( 'Largest Exponent' ) ) C C Find half of the number of infinite eigenvalues if S is diagonal. C Otherwise, find a lower bound of this number. C NINF = 0 IF( M.EQ.1 ) THEN TEMP = ZERO ELSE TEMP = DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, DE( 2, 1 ), $ LDDE, DWORK ) + $ DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, DE( 1, 3 ), $ LDDE, DWORK ) END IF IF( TEMP.EQ.ZERO ) THEN IF( M.EQ.1 ) THEN IF( A( 1, 1 ).EQ.ZERO ) $ NINF = 1 ELSE IF( DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, A( 2, 1 ), $ LDA, DWORK ).EQ.ZERO .AND. $ DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, A( 1, 2 ), $ LDA, DWORK ).EQ.ZERO ) THEN DO 10 J = 1, M IF( A( J, J ).EQ.ZERO ) $ NINF = NINF + 1 10 CONTINUE ELSE CALL MA02PD( M, M, A, LDA, I, J ) NINF = MAX( I, J )/2 END IF END IF ELSE C C Incrementing NINF below is due to even multiplicity of C eigenvalues for real skew-Hamiltonian matrices. C NINF = MA02OD( 'Skew', M, A, LDA, DE, LDDE ) IF( MOD( NINF, 2 ).GT.0 ) $ NINF = NINF + 1 NINF = NINF/2 END IF C C STEP 1: Reduce S to skew-Hamiltonian triangular form. C IF( LINIQ1 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 ) C DUM( 1 ) = ZERO C DO 20 K = 1, M - 1 C C Generate elementary reflector H(k) = I - nu * v * v' to C annihilate E(k+2:m,k). C MK2 = MIN( K+2, M ) MK3 = MK2 + 1 TMP1 = DE( K+1, K ) CALL DLARFG( M-K, TMP1, DE( MK2, K ), 1, NU ) IF( NU.NE.ZERO ) THEN DE( K+1, K ) = ONE C C Apply H(k) from both sides to E(k+1:m,k+1:m). C Compute x := nu * E(k+1:m,k+1:m) * v. C CALL MB01MD( 'Lower', M-K, NU, DE( K+1, K+1 ), LDDE, $ DE( K+1, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v in x. C MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 ) CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C E := E + v * w' - w * v'. C CALL MB01ND( 'Lower', M-K, ONE, DE( K+1, K ), 1, DWORK, 1, $ DE( K+1, K+1 ), LDDE ) C C Apply H(k) to W(k+1:m,1:k) from the left (and implicitly to C W(1:k,k+1:m) from the right). C CALL DLARF( 'Left', M-K, K, DE( K+1, K ), 1, NU, $ VW( K+1, 1 ), LDVW, DWORK ) C C Apply H(k) from both sides to W(k+1:m,k+1:m). C Compute x := nu * W(k+1:m,k+1:m) * v. C CALL DSYMV( 'Lower', M-K, NU, VW( K+1, K+1 ), LDVW, $ DE( K+1, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 ) CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C W := W - v * w' - w * v'. C CALL DSYR2( 'Lower', M-K, -ONE, DE( K+1, K ), 1, DWORK, 1, $ VW( K+1, K+1 ), LDVW ) C C Apply H(k) from the right hand side to A(1:m,k+1:m) and C C1(1:m,k+1:m). C CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU, $ A( 1, K+1 ), LDA, DWORK ) CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU, $ C1( 1, K+1 ), LDC1, DWORK ) C IF( LCMPQ1 ) THEN C C Apply H(k) from the right hand side to Q1(1:n,m+k+1:n). C CALL DLARF( 'Right', N, M-K, DE( K+1, K ), 1, NU, $ Q1( 1, M+K+1 ), LDQ1, DWORK ) END IF DE( K+1, K ) = TMP1 END IF C C Determine a Givens rotation to annihilate E(k+1,k) from the C left. C TMP2 = A( K+1, K ) CALL DLARTG( TMP2, DE( K+1, K ), CO, SI, A( K+1, K ) ) C C Update A, E and D. C CALL DROT( M-K-1, DE( MK2, K+1 ), 1, A( K+1, MK2 ), LDA, CO, $ SI ) CALL DROT( K, A( 1, K+1 ), 1, DE( 1, K+2 ), 1, CO, SI ) CALL DROT( M-K-1, DE( K+1, MK3 ), LDDE, A( MK2, K+1 ), 1, CO, $ SI ) C C Update C1, W and V. C CALL DROT( K, VW( K+1, 1 ), LDVW, C1( K+1, 1 ), LDC1, CO, -SI ) CALL DROT( M-K-1, VW( MK2, K+1 ), 1, C1( K+1, MK2 ), LDC1, CO, $ -SI ) CALL DROT( K, C1( 1, K+1 ), 1, VW( 1, K+2 ), 1, CO, SI ) CALL DROT( M-K-1, VW( K+1, MK3 ), LDVW, C1( MK2, K+1 ), 1, CO, $ -SI ) C C Fix the diagonal part. C TMP1 = C1( K+1, K+1 ) TMP2 = VW( K+1, K+2 ) C1( K+1, K+1 ) = ( CO - SI )*( CO + SI )*TMP1 + $ CO*SI*( VW( K+1, K+1 ) + TMP2 ) TMP1 = TWO*CO*SI*TMP1 VW( K+1, K+2 ) = CO**2*TMP2 - SI**2*VW( K+1, K+1 ) - TMP1 VW( K+1, K+1 ) = CO**2*VW( K+1, K+1 ) - SI**2*TMP2 - TMP1 C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, K+1 ), 1, Q1( 1, M+K+1 ), 1, CO, SI ) END IF C C Generate elementary reflector P(k) to annihilate A(k+1:m,k). C TMP1 = A( K, K ) CALL DLARFG( M-K+1, TMP1, A( K+1, K ), 1, NU ) IF( NU.NE.ZERO ) THEN A( K, K ) = ONE C C Apply P(k) from the left hand side to A(k:m,k+1:m). C CALL DLARF( 'Left', M-K+1, M-K, A( K, K ), 1, NU, $ A( K, K+1 ), LDA, DWORK ) C C Apply P(k) to D(1:k-1,k:m) from the right (and implicitly C to D(k:m,1:k-1) from the left). C CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU, $ DE( 1, K+1 ), LDDE, DWORK ) C C Apply P(k) from both sides to D(k:m,k:m). C Compute x := nu * D(k:m,k:m) * v. C CALL MB01MD( 'Upper', M-K+1, NU, DE( K, K+1 ), LDDE, $ A( K, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v in x. C MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 ) CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 ) C C Apply the transformation as a skew-symmetric rank-2 update: C D := D + v * w' - w * v'. C CALL MB01ND( 'Upper', M-K+1, ONE, A( K, K ), 1, DWORK, 1, $ DE( K, K+1 ), LDDE ) C C Apply P(k) from the left hand side to C1(k:m,1:m). C CALL DLARF( 'Left', M-K+1, M, A( K, K ), 1, NU, C1( K, 1 ), $ LDC1, DWORK ) C C Apply P(k) to V(1:k-1,k:m) from the right (and implicitly C to V(k:m,1:k-1) from the left). C CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU, $ VW( 1, K+1 ), LDVW, DWORK ) C C Apply P(k) from both sides to V(k:m,k:m). C Compute x := nu * V(k:m,k:m) * v. C CALL DSYMV( 'Upper', M-K+1, NU, VW( K, K+1 ), LDVW, $ A( K, K ), 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 ) CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C V := V - v * w' - w * v'. C CALL DSYR2( 'Upper', M-K+1, -ONE, A( K, K ), 1, DWORK, 1, $ VW( K, K+1 ), LDVW ) C IF( LCMPQ1 ) THEN C C Apply P(k) from the right hand side to Q1(1:n,k:m). C CALL DLARF( 'Right', N, M-K+1, A( K, K ), 1, NU, $ Q1( 1, K ), LDQ1, DWORK ) END IF A( K, K ) = TMP1 END IF C C Set A(k+1:m,k) to zero in order to be able to apply MB03BD. C CALL DCOPY( M-K, DUM, 0, A( K+1, K ), 1 ) 20 CONTINUE C C The following operations do not preserve the Hamiltonian structure C of H. -C1 is copied to C2. The lower triangular part of W(1:m,1:m) C and its transpose are stored in DWORK. Then, the transpose of the C upper triangular part of V(1:m,1:m) is saved in the lower C triangular part of VW(1:m,2:m+1). C IMAT = 4*MM + 1 CALL DLACPY( 'Full', M, M, A, LDA, B, LDB ) CALL DLACPY( 'Upper', M, M, DE( 1, 2 ), LDDE, F, LDF ) C DO 40 J = 1, M DO 30 I = 1, M C2( I, J ) = -C1( I, J ) 30 CONTINUE 40 CONTINUE C CALL DLACPY( 'Lower', M, M, VW, LDVW, DWORK, M ) CALL MA02AD( 'Lower', M, M, VW, LDVW, DWORK, M ) C CALL MA02AD( 'Upper', M, M, VW( 1, 2 ), LDVW, VW( 1, 2 ), LDVW ) C IF ( LCMPQ2 ) THEN CALL DLACPY( 'Full', M, M, Q1( M+1, M+1 ), LDQ1, Q2, LDQ2 ) C DO 60 J = 1, M DO 50 I = M + 1, N Q2( I, J ) = -Q1( I-M, J+M ) 50 CONTINUE 60 CONTINUE C DO 80 J = M + 1, N DO 70 I = 1, M Q2( I, J ) = -Q1( I+M, J-M ) 70 CONTINUE 80 CONTINUE C CALL DLACPY( 'Full', M, M, Q1, LDQ1, Q2( M+1, M+1 ), LDQ2 ) END IF C C STEP 2: Eliminations in H. C DO 400 K = 1, M MK1 = MIN( K+1, M ) C C I. Annihilate W(k:m-1,k). C JS = K JE = MIN( M, JS+NB-1 ) JB = JE IC = IMAT JC = 2*( M - K ) + IMAT N1 = MIN( M-K, JE-JS+1 ) N2 = MIN( M-K+1, JE-JS+1 ) N3 = MIN( M, NB ) C DO 110 J = K, M - 1 MJ3 = MIN( J+3, M+1 ) C C Determine a Givens rotation to annihilate W(j,k) from the C left. C CALL DLARTG( DWORK( ( K-1 )*M+J+1 ), DWORK( ( K-1 )*M+J ), $ CO, SI, TMP1 ) DWORK( IC ) = CO DWORK( IC+1 ) = SI IC = IC + 2 C C Update C2 and W. C CALL DROT( M, C2( 1, J+1 ), 1, C2( 1, J ), 1, CO, SI ) DWORK( ( K-1 )*M+J+1 ) = TMP1 DWORK( ( K-1 )*M+J ) = ZERO CALL DROT( N1, DWORK( K*M+J+1 ), M, DWORK( K*M+J ), M, CO, $ SI ) C C Update A. C IF( J.EQ.JE ) THEN C C Update the next panel (the columns JE+1 to JE+NB) of A C and D for previous row transformations. C JS = JE + 1 JE = MIN( M, JE+NB ) NC = JE - JS + 1 JA = 2*( M - K ) + IMAT DO 90 I = K, J - 1 CALL DROT( NC, A( I, JS ), LDA, A( I+1, JS ), LDA, $ DWORK( JA ), DWORK( JA+1 ) ) JA = JA + 2 90 CONTINUE JA = 2*( M - K ) + IMAT DO 100 I = K, J - 1 CALL DROT( NC, DE( I, JS+1 ), LDDE, DE( I+1, JS+1 ), $ LDDE, DWORK( JA ), DWORK( JA+1 ) ) JA = JA + 2 100 CONTINUE END IF C CALL DROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO, SI ) TMP1 = -SI*A( J+1, J+1 ) A( J+1, J+1 ) = CO*A( J+1, J+1 ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M+J+1 ), 1, Q1( 1, M+J ), 1, CO, SI $ ) END IF C C Determine a Givens rotation to annihilate A(j+1,j) from the C left. C CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 ) DWORK( JC ) = CO DWORK( JC+1 ) = SI JC = JC + 2 C C Update A and D. C NC = MIN( JE-J, JE-JS+1 ) A( J, J ) = TMP2 CALL DROT( NC, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO, SI $ ) CALL DROT( J-1, DE( 1, J+1 ), 1, DE( 1, J+2 ), 1, CO, SI ) CALL DROT( NC-1, DE( J, MJ3 ), LDDE, DE( J+1, MJ3 ), LDDE, $ CO, SI ) C C Update C1 and V. C CALL DROT( N2, C1( J, K ), LDC1, C1( J+1, K ), LDC1, CO, $ SI ) CALL DROT( N3, VW( J, 2 ), LDVW, VW( J+1, 2 ), LDVW, CO, $ SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, J ), 1, Q1( 1, J+1 ), 1, CO, SI ) END IF 110 CONTINUE C C Update the remaining panels of columns of W, C1, and V for C previous row transformations. C DO 140 JS = JB + 1, M, NB JE = MIN( M, JS+NB-1 ) NC = JE - JS + 1 IC = IMAT DO 120 J = K, M - 1 CALL DROT( NC, DWORK( JS*M+J+1 ), M, DWORK( JS*M+J ), M, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 120 CONTINUE JC = 2*( M - K ) + IMAT DO 130 J = K, M - 1 CALL DROT( NC, C1( J, JS ), LDC1, C1( J+1, JS ), LDC1, $ DWORK( JC ), DWORK( JC+1 ) ) JC = JC + 2 130 CONTINUE 140 CONTINUE C DO 160 JS = 2 + NB, M + 1, NB JE = MIN( M+1, JS+NB-1 ) NC = JE - JS + 1 JC = 2*( M - K ) + IMAT DO 150 J = K, M - 1 CALL DROT( NC, VW( J, JS ), LDVW, VW( J+1, JS ), LDVW, $ DWORK( JC ), DWORK( JC+1 ) ) JC = JC + 2 150 CONTINUE 160 CONTINUE C C II. Annihilate W(m,k). C C Determine a Givens rotation to annihilate W(m,k) from the left. C CALL DLARTG( C1( M, K ), DWORK( M*K ), CO, SI, TMP1 ) C C Update C1 and W. C C1( M, K ) = TMP1 DWORK( M*K ) = ZERO CALL DROT( M-K, C1( M, MK1 ), LDC1, DWORK( M*MK1 ), M, CO, SI ) CALL DROT( M, VW( M, 2 ), LDVW, C2( 1, M ), 1, CO, SI ) C C Update A and D. C CALL DROT( M-1, A( 1, M ), 1, DE( 1, M+1 ), 1, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI ) END IF C C III. Annihilate C1(k+1:m,k). C JS = K JE = MIN( M, JS+NB-1 ) IC = IMAT JC = 2*( M - K ) + IMAT N1 = MIN( M-K, JE-JS+1 ) N2 = MIN( M-K+1, JE-JS+1 ) N3 = MIN( M, NB ) C DO 170 J = M, K + 1, -1 C C Determine a Givens rotation to annihilate C1(j,k) from the C left. C CALL DLARTG( C1( J-1, K ), C1( J, K ), CO, SI, TMP1 ) DWORK( IC ) = CO DWORK( IC+1 ) = SI IC = IC + 2 C C Update C1 and V. C C1( J-1, K ) = TMP1 C1( J, K ) = ZERO CALL DROT( N1, C1( J-1, MK1 ), LDC1, C1( J, MK1 ), LDC1, $ CO, SI ) CALL DROT( N3, VW( J-1, 2 ), LDVW, VW( J, 2 ), LDVW , CO, SI $ ) C C Update A and D. C TMP1 = -SI*A( J-1, J-1 ) A( J-1, J-1 ) = CO*A( J-1, J-1 ) CALL DROT( 1, A( J-1, J ), LDA, A( J, J ), LDA, CO, SI ) CALL DROT( J-2, DE( 1, J ), 1, DE( 1, J+1 ), 1, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, J-1 ), 1, Q1( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate A(j,j-1) from the C right. C CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 ) DWORK( JC ) = CO DWORK( JC+1 ) = SI JC = JC + 2 C C Update A. C A( J, J ) = TMP2 CALL DROT( J-1, A( 1, J ), 1, A( 1, J-1 ), 1, CO, SI ) C C Update C2 and W. C CALL DROT( M, C2( 1, J ), 1, C2( 1, J-1 ), 1, CO, SI ) CALL DROT( N2, DWORK( ( K-1 )*M+J ), M, $ DWORK( ( K-1)*M+J-1 ), M, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M+J ), 1, Q1( 1, M+J-1 ), 1, CO, SI $ ) END IF 170 CONTINUE C C Update the remaining panels of columns of C1, W, V, A, and D C for previous row transformations. C DO 190 JS = MK1 + N1, M, NB JE = MIN( M, JS+NB-1 ) NC = JE - JS + 1 IC = IMAT DO 180 J = M, K + 1, -1 CALL DROT( NC, C1( J-1, JS ), LDC1, C1( J, JS ), LDC1, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 180 CONTINUE 190 CONTINUE C DO 210 JS = K - 1 + N2, M, NB JE = MIN( M, JS+NB-1 ) NC = JE - JS + 1 JC = 2*( M - K ) + IMAT DO 200 J = M, K + 1, -1 CALL DROT( NC, DWORK( JS*M+J ), M, DWORK(JS*M+J-1 ), M, $ DWORK( JC ), DWORK( JC+1 ) ) JC = JC + 2 200 CONTINUE 210 CONTINUE C DO 230 JS = 2 + NB, M + 1, NB JE = MIN( M+1, JS+NB-1 ) NC = JE - JS + 1 IC = IMAT DO 220 J = M, K + 1, -1 CALL DROT( NC, VW( J-1, JS ), LDVW, VW( J, JS ), LDVW, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 220 CONTINUE 230 CONTINUE C ICS = IMAT + 2 JE = M C C WHILE( JE.GT.2 ) DO 240 CONTINUE IF( JE.GT.2 ) THEN NC = 0 IC = ICS ICS = ICS + 2*NB DO 250 J = JE - 1, K + 1, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL DROT( NC, A( J-1, JS ), LDA, A( J, JS ), LDA, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 250 CONTINUE JE = JE - NB GO TO 240 END IF C END WHILE 240 C ICS = IMAT + 2 JE = M + 1 C C WHILE( JE.GT.3 ) DO 260 CONTINUE IF( JE.GT.3 ) THEN NC = 0 IC = ICS ICS = ICS + 2*NB DO 270 J = JE - 2, K + 1, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL DROT( NC, DE( J-1, JS ), LDDE, DE( J, JS ), LDDE, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 270 CONTINUE JE = JE - NB GO TO 260 END IF C END WHILE 260 C C IV. Annihilate W(k,k+1:m-1). C JS = K + 1 JE = MIN( M, JS+NB-1 ) JC = IMAT N2 = MIN( M-K+1, JE-JS+1 ) C DO 300 J = K + 1, M - 1 MJ2 = MIN( J+2, M ) C C Determine a Givens rotation to annihilate W(k,j) from the C right. C CALL DLARTG( DWORK( J*M+K ), DWORK( ( J-1 )*M+K ), CO, $ SI, TMP1 ) C C Update C1 and W. C CALL DROT( M, C1( 1, J+1 ), 1, C1( 1, J ), 1, CO, SI ) DWORK( ( J-1 )*M+K ) = ZERO DWORK( J*M+K ) = TMP1 CALL DROT( M-K, DWORK( J*M+MK1 ), 1, DWORK( ( J-1 )*M+K+1 ), $ 1, CO, SI ) C C Update B. C IF( J.EQ.JE ) THEN C C Update the columns JE+1 to JE+NB of B and F for previous C row transformations. C JS = JE + 1 JE = MIN( M, JE+NB ) NC = JE - JS + 1 JA = IMAT DO 280 I = K + 1, J - 1 CALL DROT( NC, B( I, JS ), LDB, B( I+1, JS ), LDB, $ DWORK( JA ), DWORK( JA+1 ) ) JA = JA + 2 280 CONTINUE JA = IMAT DO 290 I = K + 1, J - 1 CALL DROT( NC, F( I, JS ), LDF, F( I+1, JS ), LDF, $ DWORK( JA ), DWORK( JA+1 ) ) JA = JA + 2 290 CONTINUE END IF C CALL DROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO, SI ) TMP1 = -SI*B( J+1, J+1 ) B( J+1, J+1 ) = CO*B( J+1, J+1 ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, J+1 ), 1, Q2( 1, J ), 1, CO, SI ) END IF C C Determine a Givens rotation to annihilate B(j+1,j) from the C left. C CALL DLARTG( B( J, J ), TMP1, CO, SI, TMP2 ) DWORK( JC ) = CO DWORK( JC+1 ) = SI JC = JC + 2 C C Update B and F. C NC = MIN( JE-J, JE-JS+1 ) B( J, J ) = TMP2 CALL DROT( NC, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, CO, SI $ ) CALL DROT( J-1, F( 1, J ), 1, F( 1, J+1 ), 1, CO, SI ) CALL DROT( NC-1, F( J, MJ2 ), LDF, F( J+1, MJ2 ), LDF, CO, $ SI ) C C Update C2 and V. C CALL DROT( N2, C2( J, K ), LDC2, C2( J+1, K ), LDC2, CO, $ SI ) CALL DROT( M, VW( 1, J+1 ), 1, VW( 1, J+2 ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, M+J ), 1, Q2( 1, M+J+1 ), 1, CO, SI $ ) END IF 300 CONTINUE C C Update the remaining panels of columns of C2 for previous row C transformations. C DO 320 JS = K + N2, M, NB JE = MIN( M, JS+NB-1 ) NC = JE - JS + 1 JC = IMAT DO 310 J = K + 1, M - 1 CALL DROT( NC, C2( J, JS ), LDC2, C2( J+1, JS ), LDC2, $ DWORK( JC ), DWORK( JC+1 ) ) JC = JC + 2 310 CONTINUE 320 CONTINUE C C V. Annihilate W(k,m). C IF( K.LT.M ) THEN C C Determine a Givens rotation to annihilate W(k,m) from the C right. C CALL DLARTG( C2( M, K ), DWORK( ( M-1 )*M+K ), CO, SI, TMP1 $ ) C C Update C1, C2, W and V. C CALL DROT( M, VW( 1, M+1 ), 1, C1( 1, M ), 1, CO, SI ) C2( M, K ) = TMP1 DWORK( ( M-1 )*M+K ) = ZERO CALL DROT( M-K, C2( M, K+1 ), LDC2, DWORK( ( M-1 )*M+K+1 ), $ 1, CO, SI ) C C Update B and F. C CALL DROT( M-1, F( 1, M ), 1, B( 1, M ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, N ), 1, Q2( 1, M ), 1, CO, SI ) END IF ELSE C C Determine a Givens rotation to annihilate W(m,m) from the C left. C CALL DLARTG( C1( M, M ), DWORK( MM ), CO, SI, TMP1 ) C C Update C1, C2, W and V. C C1( M, M ) = TMP1 DWORK( MM ) = ZERO CALL DROT( M, VW( M, 2 ), LDVW, C2( 1, M ), 1, CO, SI ) C C Update A and D. C CALL DROT( M-1, A( 1, M ), 1, DE( 1, M+1 ), 1, CO, SI ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI ) END IF END IF C C VI. Annihilate C2(k+2:m,k). C JS = K JE = MIN( M, JS+NB-1 ) IC = IMAT N1 = MIN( M-K, JE-JS+1 ) C DO 330 J = M, K + 2, -1 C C Determine a Givens rotation to annihilate C2(j,k) from the C left. C CALL DLARTG( C2( J-1, K ), C2( J, K ), CO, SI, TMP1 ) DWORK( IC ) = CO DWORK( IC+1 ) = SI IC = IC + 2 C C Update C2 and V. C C2( J-1, K ) = TMP1 C2( J, K ) = ZERO CALL DROT( N1, C2( J-1, MK1 ), LDC2, C2( J, MK1 ), LDC2, $ CO, SI ) CALL DROT( M, VW( 1, J ), 1, VW( 1, J+1 ), 1, CO, SI ) C C Update B and F. C CALL DROT( 1, B( J-1, J ), LDB, B( J, J ), LDB, CO, SI ) TMP1 = -SI*B( J-1, J-1 ) B( J-1, J-1 ) = CO*B( J-1, J-1 ) CALL DROT( J-2, F( 1, J-1 ), 1, F( 1, J ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, M+J-1 ), 1, Q2( 1, M+J ), 1, CO, SI $ ) END IF C C Determine a Givens rotation to annihilate B(j,j-1) from the C right. C CALL DLARTG( B( J, J ), TMP1, CO, SI, TMP2 ) B( J, J ) = TMP2 C C Update B. C CALL DROT( J-1, B( 1, J ), 1, B( 1, J-1 ), 1, CO, SI ) C C Update C1 and W. C CALL DROT( M, C1( 1, J ), 1, C1( 1, J-1 ), 1, CO, SI ) CALL DROT( M-K+1, DWORK( ( J-1 )*M+K ), 1, $ DWORK( ( J-2 )*M+K ), 1, CO, SI ) C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DROT( N, Q2( 1, J ), 1, Q2( 1, J-1 ), 1, CO, SI ) END IF 330 CONTINUE C C Update the remaining panels of columns of C2, B, and F for C previous row transformations. C DO 350 JS = MK1 + N1, M, NB JE = MIN( M, JS+NB-1 ) NC = JE - JS + 1 IC = IMAT DO 340 J = M, K + 2, -1 CALL DROT( NC, C2( J-1, JS ), LDC2, C2( J, JS ), LDC2, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 340 CONTINUE 350 CONTINUE C ICS = IMAT + 2 JE = M C C WHILE( JE.GT.2 ) DO 360 CONTINUE IF( JE.GT.2 ) THEN NC = 0 IC = ICS ICS = ICS + 2*NB DO 370 J = JE - 1, K + 2, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL DROT( NC, B( J-1, JS ), LDB, B( J, JS ), LDB, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 370 CONTINUE JE = JE - NB GO TO 360 END IF C END WHILE 360 C ICS = IMAT + 2 JE = M C C WHILE( JE.GT.3 ) DO 380 CONTINUE IF( JE.GT.3 ) THEN NC = 0 IC = ICS ICS = ICS + 2*NB DO 390 J = JE - 1, K + 2, -1 NC = MIN( NC+1, NB ) JS = JE - NC + 1 CALL DROT( NC, F( J-1, JS ), LDF, F( J, JS ), LDF, $ DWORK( IC ), DWORK( IC+1 ) ) IC = IC + 2 390 CONTINUE JE = JE - NB GO TO 380 END IF C END WHILE 380 C 400 CONTINUE C C ( A1 D1 ) ( B1 F1 ) ( C11 V1 ) C Now we have S = ( ), T = ( ), H = ( ), C ( 0 A1' ) ( 0 B1' ) ( 0 C21' ) C C where A1, B1, and C11 are upper triangular, C21 is upper C Hessenberg, and D1 and F1 are skew-symmetric. C C STEP 3: Apply the periodic QZ algorithm to the generalized matrix C C -1 -1 C product C21 A1 C11 B1 in order to make C21 upper C quasi-triangular. C C Determine the mode of computations. C IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 ) THEN CMPQ = 'Initialize' IWRK = 8*MM + 1 ELSE CMPQ = 'No Computation' IMAT = 1 IWRK = 4*MM + 1 END IF C IF( LTRI ) THEN CMPSC = 'Schur Form' ELSE CMPSC = 'Eigenvalues Only' END IF C C Save matrices in the form that is required by MB03BD. C CALL DLACPY( 'Full', M, M, C2, LDC2, DWORK( IMAT ), M ) CALL DLACPY( 'Full', M, M, A, LDA, DWORK( IMAT+MM ), M ) CALL DLACPY( 'Full', M, M, C1, LDC1, DWORK( IMAT+2*MM ), M ) CALL DLACPY( 'Full', M, M, B, LDB, DWORK( IMAT+3*MM ), M ) IWORK( 1 ) = 1 IWORK( 2 ) = -1 IWORK( 3 ) = 1 IWORK( 4 ) = -1 C C Apply periodic QZ algorithm. C Workspace: need IWRK + MAX( N, 32 ) + 3. C CALL MB03BD( CMPSC, 'Careful', CMPQ, IDUM, 4, M, 1, 1, M, IWORK, $ DWORK( IMAT ), M, M, DWORK, M, M, ALPHAR, ALPHAI, $ BETA, IWORK( 5 ), IWORK( M+5 ), LIWORK-( M+4 ), $ DWORK( IWRK ), LDWORK-IWRK+1, IWARN, INFO ) IF( IWARN.GT.0 .AND. IWARN.LT.M ) THEN INFO = 1 RETURN ELSE IF( IWARN.EQ.M+1 ) THEN INFO = 3 ELSE IF( INFO.GT.0 ) THEN INFO = 2 RETURN END IF OPTDW = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 ) NBETA0 = 0 I11 = 0 I22 = 0 I2X2 = 0 C C Compute the eigenvalues with nonnegative imaginary parts of the C pencil aS - bH. Also, count the number of 2-by-2 diagonal blocks, C I2X2, and the number of 1-by-1 and 2-by-2 blocks with unreliable C eigenvalues, I11 and I22, respectively. C I = 1 C WHILE( I.LE.M ) DO 410 CONTINUE IF( I.LE.M ) THEN IF( NINF.GT.0 ) THEN IF( BETA( I ).EQ.ZERO ) $ NBETA0 = NBETA0 + 1 END IF IF( IWORK( I+4 ).GE.2*EMIN .AND. IWORK( I+4 ).LE.2*EMAX ) THEN C C B = SQRT(BASE**IWORK(i+4)) is between underflow and overflow C threshold, BETA(i) is divided by B. C BETA( I ) = BETA( I )/BASE**( HALF*IWORK( I+4 ) ) IF( BETA( I ).NE.ZERO ) THEN IF( IWORK( M+I+5 ).LT.0 ) THEN I22 = I22 + 1 ELSE IF( IWORK( M+I+5 ).GT.0 ) THEN I11 = I11 + 1 END IF EIG = SQRT( DCMPLX( ALPHAR( I ), ALPHAI( I ) ) ) ALPHAR( I ) = DIMAG( EIG ) ALPHAI( I ) = DBLE( EIG ) IF( ALPHAR( I ).LT.ZERO ) $ ALPHAR( I ) = -ALPHAR( I ) IF( ALPHAI( I ).LT.ZERO ) $ ALPHAI( I ) = -ALPHAI( I ) IF( ALPHAR( I ).NE.ZERO .AND. ALPHAI( I ).NE.ZERO ) THEN ALPHAR( I+1 ) = -ALPHAR( I ) ALPHAI( I+1 ) = ALPHAI( I ) BETA( I+1 ) = BETA( I ) I2X2 = I2X2 + 1 I = I + 1 END IF END IF ELSE IF( IWORK( I+4 ).LT.2*EMIN ) THEN C C Set to zero the numerator part of the eigenvalue. C ALPHAR( I ) = ZERO ALPHAI( I ) = ZERO I11 = I11 + 1 ELSE C C Set an infinite eigenvalue. C IF( NINF.GT.0 ) $ NBETA0 = NBETA0 + 1 BETA( I ) = ZERO I11 = I11 + 1 END IF I = I + 1 GO TO 410 END IF C END WHILE 410 C IWORK( 1 ) = I11 + I22 C C Set to infinity the largest eigenvalues, if necessary. C L = 0 IF( NINF.GT.0 ) THEN DO 430 J = 1, NINF - NBETA0 TMP1 = ZERO TMP2 = ONE P = 1 DO 420 I = 1, M IF( BETA( I ).GT.ZERO ) THEN TEMP = DLAPY2( ALPHAR( I ), ALPHAI( I ) ) IF( TEMP.GT.TMP1 .AND. TMP2.GE.BETA( I ) ) THEN TMP1 = TEMP TMP2 = BETA( I ) P = I END IF END IF 420 CONTINUE L = L + 1 BETA( P ) = ZERO 430 CONTINUE C IF( L.EQ.IWORK( 1 ) ) THEN C C All unreliable eigenvalues found have been set to infinity. C INFO = 0 I11 = 0 I22 = 0 IWORK( 1 ) = 0 END IF END IF C C Save the norms of the factors. C CALL DCOPY( 4, DWORK( IWRK+1 ), 1, DUM, 1 ) C C Save the quadruples of the 1-by-1 and 2-by-2 diagonal blocks. C All 1-by-1 diagonal blocks come first. C Save also information about blocks with possible loss of accuracy. C C Workspace: IWRK+w-1, where w = 4 if M = 1, or w = 4*N, otherwise. C K = IWRK IW = IWORK( 1 ) I = 1 J = 1 L = 4*( M - 2*I2X2 ) + K C C WHILE( I.LE.N ) DO UNREL = .FALSE. 440 CONTINUE IF( I.LE.M ) THEN IF( J.LE.IW ) $ UNREL = I.EQ.ABS( IWORK( M+I+5 ) ) IF( ALPHAR( I ).NE.ZERO .AND. BETA( I ).NE.ZERO .AND. $ ALPHAI( I ).NE.ZERO ) THEN IF( UNREL ) THEN J = J + 1 IWORK( J ) = IWORK( M+I+5 ) IWORK( IW+J ) = L - IWRK + 1 UNREL = .FALSE. END IF CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1) ), M, $ DWORK( L ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+MM ), $ M, DWORK( L+4 ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+2*MM ), $ M, DWORK( L+8 ), 2 ) CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+3*MM ), $ M, DWORK( L+12 ), 2 ) L = L + 16 I = I + 2 ELSE IF ( UNREL ) THEN J = J + 1 IWORK( J ) = I IWORK( IW+J ) = K - IWRK + 1 UNREL = .FALSE. END IF CALL DCOPY( 4, DWORK( IMAT+(M+1)*(I-1) ), MM, DWORK( K ), $ 1 ) K = K + 4 I = I + 1 END IF GO TO 440 END IF C END WHILE 440 C IWORK( 2*IW+2 ) = I11 IWORK( 2*IW+3 ) = I22 IWORK( 2*IW+4 ) = I2X2 C IF( LTRI ) THEN C C Update C1 and C2. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+2*MM ), M, C1, LDC1 ) CALL DLACPY( 'Full', M, M, DWORK( IMAT ), M, C2, LDC2 ) C C Update V. C CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( 2*MM+1 ), M, VW( 1, 2 ), LDVW, ZERO, $ DWORK( IMAT ), M ) CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, $ DWORK( IMAT ), M, DWORK, M, ZERO, VW( 1, 2 ), $ LDVW ) C C Update A. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+MM ), M, A, LDA ) C C Skew-symmetric update of D. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, DE( 1, 2 ), $ LDDE, DWORK( 2*MM+1 ), M, DE( 1, 2 ), LDDE, $ DWORK( IMAT ), LDWORK-IMAT+1, IW ) C C Update B. C CALL DLACPY( 'Upper', M, M, DWORK( IMAT+3*MM ), M, B, LDB ) C C Skew-symmetric update of F. C CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, F, LDF, $ DWORK, M, F, LDF, DWORK( IMAT ), LDWORK-IMAT+1, $ IW ) C IF( LCMPQ1 ) THEN C C Update Q1. C CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q1, LDQ1, DWORK( 2*MM+1 ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1, LDQ1 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q1( 1, M+1 ), LDQ1, DWORK( MM+1 ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1( 1, M+1 ), $ LDQ1 ) END IF C IF( LCMPQ2 ) THEN C C Update Q2. C CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q2, LDQ2, DWORK( 3*MM+1 ), M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2, LDQ2 ) CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE, $ Q2( 1, M+1 ), LDQ2, DWORK, M, ZERO, $ DWORK( IMAT ), N ) CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2( 1, M+1 ), $ LDQ2 ) END IF END IF C C Move the norms, and the quadruples of 1-by-1 and 2-by-2 blocks C in front. C K = 4*( M - 2*I2X2 ) + 16*I2X2 CALL DCOPY( K, DWORK( IWRK ), 1, DWORK( 6 ), 1 ) CALL DCOPY( 4, DUM, 1, DWORK( 2 ), 1 ) C DWORK( 1 ) = OPTDW RETURN C *** Last line of MB04BP *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04LD.f0000644000000000000000000000013215012430707016157 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04LD.f0000644000175000017500000001546415012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE MB04LD( UPLO, N, M, P, L, LDL, A, LDA, B, LDB, C, LDC, $ TAU, DWORK ) C C PURPOSE C C To calculate an LQ factorization of the first block row and apply C the orthogonal transformations (from the right) also to the second C block row of a structured matrix, as follows C _ C [ L A ] [ L 0 ] C [ ]*Q = [ ] C [ 0 B ] [ C D ] C _ C where L and L are lower triangular. The matrix A can be full or C lower trapezoidal/triangular. The problem structure is exploited. C This computation is useful, for instance, in combined measurement C and time update of one iteration of the Kalman filter (square C root covariance filter). 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 = 'L': Matrix A is lower trapezoidal/triangular; C = 'F': Matrix A is full. C C Input/Output Parameters C C N (input) INTEGER _ C The order of the matrices L and L. N >= 0. C C M (input) INTEGER C The number of columns of the matrices A, B and D. M >= 0. C C P (input) INTEGER C The number of rows of the matrices B, C and D. P >= 0. C C L (input/output) DOUBLE PRECISION array, dimension (LDL,N) C On entry, the leading N-by-N lower triangular part of this C array must contain the lower triangular matrix L. C On exit, the leading N-by-N lower triangular part of this C _ C array contains the lower triangular matrix L. C The strict upper triangular part of this array is not C referenced. C C LDL INTEGER C The leading dimension of array L. LDL >= MAX(1,N). C C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) C On entry, if UPLO = 'F', the leading N-by-M part of this C array must contain the matrix A. If UPLO = 'L', the C leading N-by-MIN(N,M) part of this array must contain the C lower trapezoidal (lower triangular if N <= M) matrix A, C and the elements above the diagonal are not referenced. C On exit, the leading N-by-M part (lower trapezoidal or C triangular, if UPLO = 'L') of this array contains the C trailing components (the vectors v, see Method) of the C elementary reflectors used in the factorization. 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 P-by-M part of this array must C contain the matrix B. C On exit, the leading P-by-M part of this array contains C the computed matrix D. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,P). C C C (output) DOUBLE PRECISION array, dimension (LDC,N) C The leading P-by-N part of this array contains the C computed matrix C. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). 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 (N) 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 an M-vector, if UPLO = 'F', or an min(i,M)-vector, if C i C UPLO = 'L'. The components of v are stored in the i-th row of A, C i C and tau is stored in TAU(i). C i C C NUMERICAL ASPECTS C C The algorithm is backward stable. C C CONTRIBUTORS C C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C C REVISIONS C C - C C KEYWORDS C C Elementary reflector, LQ 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, LDL, M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), $ L(LDL,*), TAU(*) C .. Local Scalars .. LOGICAL LUPLO INTEGER I, IM C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL C .. Intrinsic Functions .. INTRINSIC MIN C .. Executable Statements .. C IF( MIN( M, N ).EQ.0 ) $ RETURN C LUPLO = LSAME( UPLO, 'L' ) IM = M C DO 10 I = 1, N C C Annihilate the I-th row of A and apply the transformations to C the entire block matrix, exploiting its structure. C IF( LUPLO ) IM = MIN( I, M ) CALL DLARFG( IM+1, L(I,I), A(I,1), LDA, TAU(I) ) IF( TAU(I).NE.ZERO ) THEN C C [ w ] [ L(I+1:N,I) A(I+1:N,1:IM) ] [ 1 ] C [ ] := [ ] * [ ] C [ C(:,I) ] [ 0 B(:,1:IM) ] [ v ] C IF( I.LT.N ) THEN CALL DCOPY( N-I, L(I+1,I), 1, DWORK, 1 ) CALL DGEMV( 'No transpose', N-I, IM, ONE, A(I+1,1), LDA, $ A(I,1), LDA, ONE, DWORK, 1 ) END IF CALL DGEMV( 'No transpose', P, IM, ONE, B, LDB, A(I,1), $ LDA, ZERO, C(1,I), 1 ) C C [ L(I+1:N,I) A(I+1:N,1:IM) ] [ L(I+1:N,I) A(I+1:N,1:IM) ] C [ ] := [ ] C [ C(:,I) D(:,1:IM) ] [ 0 B(:,1:IM) ] C C [ w ] C - tau * [ ] * [ 1 , v'] C [ C(:,I) ] C IF( I.LT.N ) THEN CALL DAXPY( N-I, -TAU(I), DWORK, 1, L(I+1,I), 1 ) CALL DGER( N-I, IM, -TAU(I), DWORK, 1, A(I,1), LDA, $ A(I+1,1), LDA ) END IF CALL DSCAL( P, -TAU(I), C(1,I), 1 ) CALL DGER( P, IM, ONE, C(1,I), 1, A(I,1), LDA, B, LDB ) END IF 10 CONTINUE C RETURN C *** Last line of MB04LD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04QF.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04QF.f0000644000175000017500000004661115012430707017372 0ustar00lilgelilge00000000000000 SUBROUTINE MB04QF( DIRECT, STOREV, STOREW, N, K, V, LDV, W, LDW, $ CS, TAU, RS, LDRS, T, LDT, DWORK ) C C PURPOSE C C To form the triangular block factors R, S and T of a symplectic C block reflector SH, which is defined as a product of 2k C concatenated Householder reflectors and k Givens rotations, C C SH = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). C C The upper triangular blocks of the matrices C C [ S1 ] [ T11 T12 T13 ] C R = [ R1 R2 R3 ], S = [ S2 ], T = [ T21 T22 T23 ], C [ S3 ] [ T31 T32 T33 ] C C with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular, C are stored rowwise in the arrays RS and T, respectively. C C ARGUMENTS C C Mode Parameters C C DIRECT CHARACTER*1 C This is a dummy argument, which is reserved for future C extensions of this subroutine. Not referenced. C C STOREV CHARACTER*1 C Specifies how the vectors which define the concatenated C Householder F(i) reflectors are stored: C = 'C': columnwise; C = 'R': rowwise. C C STOREW CHARACTER*1 C Specifies how the vectors which define the concatenated C Householder H(i) reflectors are stored: C = 'C': columnwise; C = 'R': rowwise. C C Input/Output Parameters C C N (input) INTEGER C The order of the Householder reflectors F(i) and H(i). C N >= 0. C C K (input) INTEGER C The number of Givens rotations. K >= 1. C C V (input) DOUBLE PRECISION array, dimension C (LDV,K) if STOREV = 'C', C (LDV,N) if STOREV = 'R' C On entry with STOREV = 'C', the leading N-by-K part of C this array must contain in its i-th column the vector C which defines the elementary reflector F(i). C On entry with STOREV = 'R', the leading K-by-N part of C this array must contain in its i-th row the vector C which defines the elementary reflector F(i). C C LDV INTEGER C The leading dimension of the array V. C LDV >= MAX(1,N), if STOREV = 'C'; C LDV >= K, if STOREV = 'R'. C C W (input) DOUBLE PRECISION array, dimension C (LDW,K) if STOREW = 'C', C (LDW,N) if STOREW = 'R' C On entry with STOREW = 'C', the leading N-by-K part of C this array must contain in its i-th column the vector C which defines the elementary reflector H(i). C On entry with STOREV = 'R', the leading K-by-N part of C this array must contain in its i-th row the vector C which defines the elementary reflector H(i). C C LDW INTEGER C The leading dimension of the array W. C LDW >= MAX(1,N), if STOREW = 'C'; C LDW >= K, if STOREW = 'R'. C C CS (input) DOUBLE PRECISION array, dimension (2*K) C On entry, the first 2*K elements of this array must C contain the cosines and sines of the symplectic Givens C rotations G(i). C C TAU (input) DOUBLE PRECISION array, dimension (K) C On entry, the first K elements of this array must C contain the scalar factors of the elementary reflectors C F(i). C C RS (output) DOUBLE PRECISION array, dimension (K,6*K) C On exit, the leading K-by-6*K part of this array contains C the upper triangular matrices defining the factors R and C S of the symplectic block reflector SH. The (strictly) C lower portions of this array are not used. C C LDRS INTEGER C The leading dimension of the array RS. LDRS >= K. C C T (output) DOUBLE PRECISION array, dimension (K,9*K) C On exit, the leading K-by-9*K part of this array contains C the upper triangular matrices defining the factor T of the C symplectic block reflector SH. The (strictly) lower C portions of this array are not used. C C LDT INTEGER C The leading dimension of the array T. LDT >= K. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (3*K) C C REFERENCES C C [1] Kressner, D. C Block algorithms for orthogonal symplectic factorizations. C BIT, 43 (4), pp. 775-790, 2003. C C NUMERICAL ASPECTS C C The algorithm requires ( 4*K - 2 )*K*N + 19/3*K*K*K + 1/2*K*K C + 43/6*K - 4 floating point operations. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAEST). C C KEYWORDS C C Elementary matrix operations, orthogonal symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DIRECT, STOREV, STOREW INTEGER K, LDRS, LDT, LDV, LDW, N C .. Array Arguments .. DOUBLE PRECISION CS(*), DWORK(*), RS(LDRS,*), T(LDT,*), $ TAU(*), V(LDV,*), W(LDW,*) C .. Local Scalars .. LOGICAL LCOLV, LCOLW INTEGER I, J, K2, PR1, PR2, PR3, PS1, PS2, PS3, PT11, $ PT12, PT13, PT21, PT22, PT23, PT31, PT32, PT33 DOUBLE PRECISION CM1, TAUI, VII, WII C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DSCAL, DTRMV C C .. Executable Statements .. C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C LCOLV = LSAME( STOREV, 'C' ) LCOLW = LSAME( STOREW, 'C' ) C K2 = K + K PR1 = 0 PR2 = PR1 + K PR3 = PR2 + K PS1 = PR3 + K PS2 = PS1 + K PS3 = PS2 + K C PT11 = 0 PT12 = PT11 + K PT13 = PT12 + K PT21 = PT13 + K PT22 = PT21 + K PT23 = PT22 + K PT31 = PT23 + K PT32 = PT31 + K PT33 = PT32 + K C DO 90 I = 1, K TAUI = TAU(I) VII = V(I,I) V(I,I) = ONE WII = W(I,I) W(I,I) = ONE IF ( WII.EQ.ZERO ) THEN DO 10 J = 1, I T(J,PT11+I) = ZERO 10 CONTINUE DO 20 J = 1, I-1 T(J,PT21+I) = ZERO 20 CONTINUE DO 30 J = 1, I-1 T(J,PT31+I) = ZERO 30 CONTINUE DO 40 J = 1, I-1 RS(J,PS1+I) = ZERO 40 CONTINUE ELSE C C Treat first Householder reflection. C IF ( LCOLV.AND.LCOLW ) THEN C C Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i). C CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW, $ W(I,I), 1, ZERO, DWORK, 1 ) C C Compute t2 = -wii * V(i:n,1:i-1)' * W(i:n,i). C CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV, $ W(I,I), 1, ZERO, DWORK(K+1), 1 ) ELSE IF ( LCOLV ) THEN C C Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'. C CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I), $ LDW, W(I,I), LDW, ZERO, DWORK, 1 ) C C Compute t2 = -wii * V(i:n,1:i-1)' * W(i,i:n)'. C CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV, $ W(I,I), LDW, ZERO, DWORK(K+1), 1 ) ELSE IF ( LCOLW ) THEN C C Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i). C CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW, $ W(I,I), 1, ZERO, DWORK, 1 ) C C Compute t2 = -wii * V(1:i-1,i:n) * W(i:n,i). C CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I), $ LDV, W(I,I), 1, ZERO, DWORK(K+1), 1 ) ELSE C C Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'. C CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I), $ LDW, W(I,I), LDW, ZERO, DWORK, 1 ) C C Compute t2 = -wii * V(1:i-1,i:n) * W(i,i:n)'. C CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I), $ LDV, W(I,I), LDW, ZERO, DWORK(K+1), 1 ) END IF C C T11(1:i-1,i) := T11(1:i-1,1:i-1)*t1 + T13(1:i-1,1:i-1)*t2 C CALL DCOPY( I-1, DWORK, 1, T(1,PT11+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT11+1), LDT, T(1,PT11+I), 1 ) CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, T(1,PT11+I), 1 ) T(I,PT11+I) = -WII C IF ( I.GT.1 ) THEN C C T21(1:i-1,i) := T21(1:i-1,1:i-1)*t1 + T23(1:i-1,1:i-1)*t2 C CALL DCOPY( I-2, DWORK(2), 1, T(1,PT21+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, $ T(1,PT21+2), LDT, T(1,PT21+I), 1 ) T(I-1, PT21+I) = ZERO CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, T(1,PT21+I), 1 ) C C T31(1:i-1,i) := T31(1:i-1,1:i-1)*t1 + T33(1:i-1,1:i-1)*t2 C CALL DCOPY( I-2, DWORK(2), 1, T(1,PT31+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, $ T(1,PT31+2), LDT, T(1,PT31+I), 1 ) T(I-1, PT31+I) = ZERO CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, T(1,PT31+I), 1 ) C C S1(1:i-1,i) := S1(1:i-1,1:i-1)*t1 + S3(1:i-1,1:i-1)*t2 C CALL DCOPY( I-2, DWORK(2), 1, RS(1,PS1+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, $ RS(1,PS1+2), LDRS, RS(1,PS1+I), 1 ) RS(I-1, PS1+I) = ZERO CALL DCOPY( I-1, DWORK(K+1), 1, RS(1,PS3+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 ) CALL DAXPY( I-1, ONE, RS(1,PS3+I), 1, RS(1,PS1+I), 1 ) END IF END IF C C Treat Givens rotation. C CM1 = CS(2*I-1) - ONE IF ( LCOLW ) THEN CALL DCOPY( I, W(I,1), LDW, DWORK, 1 ) ELSE CALL DCOPY( I, W(1,I), 1, DWORK, 1 ) END IF IF ( LCOLV ) THEN CALL DCOPY( I-1, V(I,1), LDV, DWORK(K+1), 1 ) ELSE CALL DCOPY( I-1, V(1,I), 1, DWORK(K+1), 1 ) END IF C C R1(1:i,i) = T11(1:i,1:i) * dwork(1:i) C + [ T13(1:i-1,1:i-1) * dwork(k+1:k+i-1); 0 ] C CALL DCOPY( I, DWORK, 1, RS(1,PR1+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, $ T(1,PT11+1), LDT, RS(1,PR1+I), 1 ) CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, RS(1,PR1+I), 1 ) C C R2(1:i-1,i) = T21(1:i-1,2:i) * W(i,2:i) C + T23(1:i-1,1:i-1) * V(i,1:i-1) C CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR2+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT21+2), LDT, RS(1,PR2+I), 1 ) CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, RS(1,PR2+I), 1 ) C C R3(1:i-1,i) = T31(1:i-1,2:i) * dwork(2:i) C + T33(1:i-1,1:i-1) * dwork(k+1:k+i-1) C CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR3+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT31+2), LDT, RS(1,PR3+I), 1 ) CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, RS(1,PR3+I), 1 ) C C S2(1:i-1,i) = S1(1:i-1,2:i) * dwork(2:i) C + S3(1:i-1,1:i-1) * dwork(k+1:k+i-1) C CALL DCOPY( I-1, DWORK(2), 1, RS(1,PS2+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ RS(1,PS1+2), LDRS, RS(1,PS2+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ RS(1,PS3+1), LDRS, DWORK(K+1), 1 ) CALL DAXPY( I-1, ONE, DWORK(K+1), 1, RS(1,PS2+I), 1 ) RS(I,PS2+I) = -CS(2*I) C C T12(1:i,i) = [ R1(1:i-1,1:i-1)*S2(1:i-1,i); 0 ] C + (c-1) * R1(1:i,i) C CALL DCOPY( I-1, RS(1,PS2+I), 1, T(1,PT12+I), 1 ) CALL DSCAL( I-1, CM1, RS(1,PS2+I), 1) CALL DSCAL( I-1, CS(2*I), T(1,PT12+I), 1 ) CALL DCOPY( I-1, T(1,PT12+I), 1, T(1,PT22+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ RS(1,PR1+1), LDRS, T(1,PT12+I), 1 ) T(I,PT12+I) = ZERO CALL DAXPY( I, CM1, RS(1,PR1+I), 1, T(1,PT12+I), 1 ) C C T22(1:i-1,i) = R2(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R2(1:i-1,i) C IF (I.GT.1) $ CALL DCOPY( I-2, T(2,PT22+I), 1, T(1,PT32+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Unit diagonal', I-1, $ RS(1,PR2+1), LDRS, T(1,PT22+I), 1 ) CALL DAXPY( I-1, CM1, RS(1,PR2+I), 1, T(1,PT22+I), 1 ) T(I,PT22+I) = CM1 C C T32(1:i-1,i) = R3(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R3(1:i-1,i) C IF ( I.GT.1 ) THEN CALL DTRMV( 'Upper', 'No transpose', 'Non-Unit', I-2, $ RS(1,PR3+2), LDRS, T(1,PT32+I), 1 ) T(I-1,PT32+I) = ZERO CALL DAXPY( I-1, CM1, RS(1,PR3+I), 1, T(1,PT32+I), 1 ) END IF C IF ( TAUI.EQ.ZERO ) THEN DO 50 J = 1, I T(J,PT13+I) = ZERO 50 CONTINUE DO 60 J = 1, I T(J,PT23+I) = ZERO 60 CONTINUE DO 70 J = 1, I T(J,PT33+I) = ZERO 70 CONTINUE DO 80 J = 1, I RS(J,PS3+I) = ZERO 80 CONTINUE ELSE C C Treat second Householder reflection. C IF ( LCOLV.AND.LCOLW ) THEN C C Compute t1 = -tau(i) * W(i:n,1:i)' * V(i:n,i). C CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1), $ LDW, V(I,I), 1, ZERO, DWORK, 1 ) C C Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i). C CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1), $ LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 ) ELSE IF ( LCOLV ) THEN C C Compute t1 = -tau(i) * W(1:i,i:n) * V(i:n,i). C CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I), $ LDW, V(I,I), 1, ZERO, DWORK, 1 ) C C Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i). C CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1), $ LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 ) ELSE IF ( LCOLW ) THEN C C Compute t1 = -tau(i) * W(i:n,1:i)' * V(i,i:n)'. C CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1), $ LDW, V(I,I), LDV, ZERO, DWORK, 1 ) C C Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'. C CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I), $ LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 ) ELSE C C Compute t1 = -tau(i) * W(1:i,i:n) * V(i,i:n)'. C CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I), $ LDW, V(I,I), LDV, ZERO, DWORK, 1 ) C C Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'. C CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I), $ LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 ) END IF C C T13(1:i,i) := T11(1:i,1:i)*t1 - tau(i)*T12(1:i,i) C + [T13(1:i-1,1:i-1)*t2;0] C CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT13+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) T(I,PT13+I) = ZERO CALL DCOPY( I, DWORK, 1, DWORK(K+1), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, $ T(1,PT11+1), LDT, DWORK(K+1), 1 ) CALL DAXPY( I, ONE, DWORK(K+1), 1, T(1,PT13+I), 1 ) CALL DAXPY( I, -TAUI, T(1,PT12+I), 1, T(1,PT13+I), 1 ) C C T23(1:i,i) := T21(1:i,1:i)*t1 - tau(i)*T22(1:i,i) C + [T23(1:i-1,1:i-1)*t2;0] C CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT23+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) T(I,PT23+I) = ZERO CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT21+2), LDT, DWORK(K+1), 1 ) CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT23+I), 1 ) CALL DAXPY( I, -TAUI, T(1,PT22+I), 1, T(1,PT23+I), 1 ) C C T33(1:i,i) := T31(1:i,1:i)*t1 - tau(i)*T32(1:i,i) C + [T33(1:i-1,1:i-1)*t2;0] C CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT33+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ T(1,PT31+2), LDT, DWORK(K+1), 1 ) CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT33+I), 1 ) CALL DAXPY( I-1, -TAUI, T(1,PT32+I), 1, T(1,PT33+I), 1 ) T(I,PT33+I) = -TAUI C C S3(1:i,i) := S1(1:i,1:i)*t1 - tau(i)*S2(1:i,i) C + [S3(1:i-1,1:i-1)*t2;0] C CALL DCOPY( I-1, DWORK(K2+1), 1, RS(1,PS3+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 ) CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, $ RS(1,PS1+2), LDRS, DWORK(2), 1 ) CALL DAXPY( I-1, ONE, DWORK(2), 1, RS(1,PS3+I), 1 ) RS(I,PS3+I) = ZERO CALL DAXPY( I, -TAUI, RS(1,PS2+I), 1, RS(1,PS3+I), 1 ) END IF W(I,I) = WII V(I,I) = VII 90 CONTINUE C RETURN C *** Last line of MB04QF *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04OX.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04OX.f0000644000175000017500000000517015012430707017405 0ustar00lilgelilge00000000000000 SUBROUTINE MB04OX( N, A, LDA, X, INCX ) C C PURPOSE C C To perform the QR factorization C C (U ) = Q*(R), C (x') (0) C C where U and R are n-by-n upper triangular matrices, x is an C n element vector and Q is an (n+1)-by-(n+1) orthogonal matrix. C C U must be supplied in the n-by-n upper triangular part of the C array A and this is overwritten by R. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The number of elements of X and the order of the square C 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 of this C array must contain the upper triangular matrix U. C On exit, the leading N-by-N upper triangular part of this C array contains the upper triangular matrix R. C The strict lower triangle of A is not referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C X (input/output) DOUBLE PRECISION array, dimension C (1+(N-1)*INCX) C On entry, the incremented array X must contain the C vector x. On exit, the content of X is changed. C C INCX (input) INTEGER. C Specifies the increment for the elements of X. INCX > 0. C C METHOD C C The matrix Q is formed as a sequence of plane rotations in planes C (1, n+1), (2, n+1), ..., (n, n+1), the rotation in the (j, n+1)th C plane, Q(j), being chosen to annihilate the jth element of x. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, July 1998. C Based on the RASP routine DUTUPD. C C REVISIONS C C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INCX, LDA, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), X(*) C .. Local Scalars .. DOUBLE PRECISION CI, SI, TEMP INTEGER I, IX C .. External Subroutines .. EXTERNAL DLARTG, DROT C C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked. C IX = 1 C DO 20 I = 1, N - 1 CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP ) A(I,I) = TEMP IX = IX + INCX CALL DROT( N-I, A(I,I+1), LDA, X(IX), INCX, CI, SI ) 20 CONTINUE C CALL DLARTG( A(N,N), X(IX), CI, SI, TEMP ) A(N,N) = TEMP C RETURN C *** Last line of MB04OX *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01TD.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB01TD.f0000644000175000017500000002312215012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE TB01TD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, LOW, $ IGH, SCSTAT, SCIN, SCOUT, DWORK, INFO ) C C PURPOSE C C To reduce a given state-space representation (A,B,C,D) to C balanced form by means of state permutations and state, input and C output scalings. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the state-space representation, i.e. the C order of the original state dynamics 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/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the original state dynamics matrix A. C On exit, the leading N-by-N part of this array contains C the balanced state dynamics matrix A. 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 original input/state matrix B. C On exit, the leading N-by-M part of this array contains C the balanced input/state matrix B. 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 original state/output matrix C. C On exit, the leading P-by-N part of this array contains C the balanced state/output matrix C. 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 original direct transmission matrix D. C On exit, the leading P-by-M part of this array contains C the scaled direct transmission matrix D. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C LOW (output) INTEGER C The index of the lower end of the balanced submatrix of A. C C IGH (output) INTEGER C The index of the upper end of the balanced submatrix of A. C C SCSTAT (output) DOUBLE PRECISION array, dimension (N) C This array contains the information defining the C similarity transformations used to permute and balance C the state dynamics matrix A, as returned from the LAPACK C library routine DGEBAL. C C SCIN (output) DOUBLE PRECISION array, dimension (M) C Contains the scalars used to scale the system inputs so C that the columns of the final matrix B have norms roughly C equal to the column sums of the balanced matrix A C (see FURTHER COMMENTS). C The j-th input of the balanced state-space representation C is SCIN(j)*(j-th column of the permuted and balanced C input/state matrix B). C C SCOUT (output) DOUBLE PRECISION array, dimension (P) C Contains the scalars used to scale the system outputs so C that the rows of the final matrix C have norms roughly C equal to the row sum of the balanced matrix A. C The i-th output of the balanced state-space representation C is SCOUT(i)*(i-th row of the permuted and balanced C state/ouput matrix C). 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 METHOD C C Similarity transformations are used to permute the system states C and balance the corresponding row and column sum norms of a C submatrix of the state dynamics matrix A. These operations are C also applied to the input/state matrix B and the system inputs C are then scaled (see parameter SCIN) so that the columns of the C final matrix B have norms roughly equal to the column sum norm of C the balanced matrix A (see FURTHER COMMENTS). C The above operations are also applied to the matrix C, and the C system outputs are then scaled (see parameter SCOUT) so that the C rows of the final matrix C have norms roughly equal to the row sum C norm of the balanced matrix A (see FURTHER COMMENTS). C Finally, the (I,J)-th element of the direct transmission matrix D C is scaled as C D(I,J) = D(I,J)*(1.0/SCIN(J))*SCOUT(I), where I = 1,2,...,P C and J = 1,2,...,M. C C Scaling performed to balance the row/column sum norms is by C integer powers of the machine base so as to avoid introducing C rounding errors. C C REFERENCES C C [1] Wilkinson, J.H. and Reinsch, C. C Handbook for Automatic Computation, (Vol II, Linear Algebra). C Springer-Verlag, 1971, (contribution II/11). C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations and is backward stable. C C FURTHER COMMENTS C C The columns (rows) of the final matrix B (matrix C) have norms C 'roughly' equal to the column (row) sum norm of the balanced C matrix A, i.e. C size/BASE < abssum <= size C where C BASE = the base of the arithmetic used on the computer, which C can be obtained from the LAPACK Library routine C DLAMCH; C C size = column or row sum norm of the balanced matrix A; C abssum = column sum norm of the balanced matrix B or row sum C norm of the balanced matrix C. C C The routine is BASE dependent. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. C Supersedes Release 2.0 routine TB01HD by T.W.C.Williams, Kingston C Polytechnic, United Kingdom, October 1982. C C REVISIONS C C - C C KEYWORDS C C Balanced form, orthogonal transformation, similarity C transformation, state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER IGH, INFO, LDA, LDB, LDC, LDD, LOW, M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), SCIN(*), SCOUT(*), SCSTAT(*) C .. Local Scalars .. INTEGER I, J, K, KNEW, KOLD DOUBLE PRECISION ACNORM, ARNORM, SCALE C .. External Functions .. DOUBLE PRECISION DLANGE EXTERNAL DLANGE C .. External Subroutines .. EXTERNAL DGEBAL, DSCAL, DSWAP, TB01TY, 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( P.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -9 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -11 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TB01TD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAX( N, M, P ).EQ.0 ) THEN LOW = 1 IGH = N RETURN END IF C C Permute states, and balance a submatrix of A. C CALL DGEBAL( 'Both', N, A, LDA, LOW, IGH, SCSTAT, INFO ) C C Use the information in SCSTAT on state scalings and reorderings C to transform B and C. C DO 10 K = 1, N KOLD = K IF ( ( LOW.GT.KOLD ) .OR. ( KOLD.GT.IGH ) ) THEN IF ( KOLD.LT.LOW ) KOLD = LOW - KOLD KNEW = INT( SCSTAT(KOLD) ) IF ( KNEW.NE.KOLD ) THEN C C Exchange rows KOLD and KNEW of B. C CALL DSWAP( M, B(KOLD,1), LDB, B(KNEW,1), LDB ) C C Exchange columns KOLD and KNEW of C. C CALL DSWAP( P, C(1,KOLD), 1, C(1,KNEW), 1 ) END IF END IF 10 CONTINUE C IF ( IGH.NE.LOW ) THEN C DO 20 K = LOW, IGH SCALE = SCSTAT(K) C C Scale the K-th row of permuted B. C CALL DSCAL( M, ONE/SCALE, B(K,1), LDB ) C C Scale the K-th column of permuted C. C CALL DSCAL( P, SCALE, C(1,K), 1 ) 20 CONTINUE C END IF C C Calculate the column and row sum norms of A. C ACNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) ARNORM = DLANGE( 'I-norm', N, N, A, LDA, DWORK ) C C Scale the columns of B (i.e. inputs) to have norms roughly ACNORM. C CALL TB01TY( 1, 0, 0, N, M, ACNORM, B, LDB, SCIN ) C C Scale the rows of C (i.e. outputs) to have norms roughly ARNORM. C CALL TB01TY( 0, 0, 0, P, N, ARNORM, C, LDC, SCOUT ) C C Finally, apply these input and output scalings to D and set SCIN. C DO 40 J = 1, M SCALE = SCIN(J) C DO 30 I = 1, P D(I,J) = D(I,J)*( SCALE*SCOUT(I) ) 30 CONTINUE C SCIN(J) = ONE/SCALE 40 CONTINUE C RETURN C *** Last line of TB01TD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03KD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03KD.f0000644000175000017500000004336015012430707017357 0ustar00lilgelilge00000000000000 SUBROUTINE MB03KD( COMPQ, WHICHQ, STRONG, K, NC, KSCHUR, N, NI, S, $ SELECT, T, LDT, IXT, Q, LDQ, IXQ, M, TOL, $ IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To reorder the diagonal blocks of the formal matrix product C C T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1), (1) C C of length K, in the generalized periodic Schur form, C C [ T11_k T12_k T13_k ] C T_k = [ 0 T22_k T23_k ], k = 1, ..., K, (2) C [ 0 0 T33_k ] C C where C C - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or C NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced C infinite eigenvalues, C - the submatrices T22_k are NC-by-NC and contain core eigenvalues, C which are generically neither zero nor infinite, C - the submatrices T33_k contain dimension-induced zero C eigenvalues, C C such that the M selected eigenvalues pointed to by the logical C vector SELECT end up in the leading part of the matrix sequence C T22_k. C C Given that N(k) = N(k+1) for all k where S(k) = -1, the T11_k are C void and the first M columns of the updated orthogonal C transformation matrix sequence Q_1, ..., Q_K span a periodic C deflating subspace corresponding to the same eigenvalues. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether to compute the orthogonal transformation C matrices Q_k, as follows: C = 'N': do not compute any of the matrices Q_k; C = 'I': each coefficient of Q is initialized internally to C the identity matrix, and the orthogonal matrices C Q_k are returned, where Q_k, k = 1, ..., K, C performed the reordering; C = 'U': each coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the products Q1_k*Q_k are C returned; C = 'W': the computation of each Q_k is specified C individually in the array WHICHQ. C C WHICHQ INTEGER array, dimension (K) C If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k C as follows: C = 0: do not compute Q_k; C = 1: the kth coefficient of Q is initialized to the C identity matrix, and the orthogonal matrix Q_k is C returned; C = 2: the kth coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the product Q1_k*Q_k is C returned. C This array is not referenced if COMPQ <> 'W'. C C STRONG CHARACTER*1 C Specifies whether to perform the strong stability tests, C as follows: C = 'N': do not perform the strong stability tests; C = 'S': perform the strong stability tests; often, this is C not needed, and omitting them can save some C computations. C C Input/Output Parameters C C K (input) INTEGER C The period of the periodic matrix sequences T and Q (the C number of factors in the matrix product). K >= 2. C (For K = 1, a standard eigenvalue reordering problem is C obtained.) C C NC (input) INTEGER C The number of core eigenvalues. 0 <= NC <= min(N). C C KSCHUR (input) INTEGER C The index for which the matrix T22_kschur is upper quasi- C triangular. All other T22 matrices are upper triangular. C C N (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the formal matrix product T, C such that the k-th coefficient T_k is an N(k+1)-by-N(k) C matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix, C if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1). C C NI (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the matrix sequence T11_k. C N(k) >= NI(k) + NC >= 0. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures (exponents) of the factors in the K-periodic C matrix sequence. Each entry in S must be either 1 or -1; C the value S(k) = -1 corresponds to using the inverse of C the factor T_k. C C SELECT (input) LOGICAL array, dimension (NC) C SELECT specifies the eigenvalues in the selected cluster. C To select a real eigenvalue w(j), SELECT(j) must be set to C .TRUE.. To select a complex conjugate pair of eigenvalues C w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, C either SELECT(j) or SELECT(j+1) or both must be set to C .TRUE.; a complex conjugate pair of eigenvalues must be C either both included in the cluster or both excluded. C C T (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXT(k) the C matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1, C or at least N(k)-by-N(k+1), if S(k) = -1, in periodic C Schur form. C On exit, the matrices T_k are overwritten by the reordered C periodic Schur form. C C LDT INTEGER array, dimension (K) C The leading dimensions of the matrices T_k in the one- C dimensional array T. C LDT(k) >= max(1,N(k+1)), if S(k) = 1, C LDT(k) >= max(1,N(k)), if S(k) = -1. C C IXT INTEGER array, dimension (K) C Start indices of the matrices T_k in the one-dimensional C array T. C C Q (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXQ(k) a C matrix Q_k of size at least N(k)-by-N(k), provided that C COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) = 2. C On exit, if COMPQ = 'I' or COMPQ = 'W' and WHICHQ(k) = 1, C Q_k contains the orthogonal matrix that performed the C reordering. If COMPQ = 'U', or COMPQ = 'W' and C WHICHQ(k) = 2, Q_k is post-multiplied with the orthogonal C matrix that performed the reordering. C This array is not referenced if COMPQ = 'N'. C C LDQ INTEGER array, dimension (K) C The leading dimensions of the matrices Q_k in the one- C dimensional array Q. C LDQ(k) >= max(1,N(k)), if COMPQ = 'I', or COMPQ = 'U', or C COMPQ = 'W' and WHICHQ(k) > 0; C This array is not referenced if COMPQ = 'N'. C C IXQ INTEGER array, dimension (K) C Start indices of the matrices Q_k in the one-dimensional C array Q. C This array is not referenced if COMPQ = 'N'. C C M (output) INTEGER C The number of selected core eigenvalues which were C reordered to the top of T22_k. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance parameter c. The weak and strong stability C tests performed for checking the reordering use a C threshold computed by the formula MAX(c*EPS*NRM, SMLNUM), C where NRM is the varying Frobenius norm of the matrices C formed by concatenating K pairs of adjacent diagonal C blocks of sizes 1 and/or 2 in the T22_k submatrices from C (2), which are swapped, and EPS and SMLNUM are the machine C precision and safe minimum divided by EPS, respectively C (see LAPACK Library routine DLAMCH). The value c should C normally be at least 10. C C Workspace C C IWORK INTEGER array, dimension (4*K) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= 10*K + MN, if all blocks involved in reordering C have order 1; C LDWORK >= 25*K + MN, if there is at least a block of C order 2, but no adjacent blocks of C order 2 are involved in reordering; C LDWORK >= MAX(42*K + MN, 80*K - 48), if there is at least C a pair of adjacent blocks of order 2 C involved in reordering; C where MN = MXN, if MXN > 10, and MN = 0, otherwise, with C MXN = MAX(N(k),k=1,...,K). C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message 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 = 1: the reordering of T failed because some eigenvalues C are too close to separate (the problem is very ill- C conditioned); T may have been partially reordered. C C METHOD C C An adaptation of the LAPACK Library routine DTGSEN is used. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C C CONTRIBUTOR C C R. Granat, Umea University, Sweden, Apr. 2008. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Mar. 2010, SLICOT Library version of the PEP routine PEP_DTGSEN. C V. Sima, July, 2010, Aug. 2011. C C KEYWORDS C C Orthogonal transformation, periodic QZ algorithm, periodic C Sylvester-like equations, QZ algorithm. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER COMPQ, STRONG INTEGER INFO, K, KSCHUR, LDWORK, M, NC DOUBLE PRECISION TOL C .. C .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ), $ LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * ) DOUBLE PRECISION DWORK( * ), Q( * ), T( * ) C .. C .. Local Scalars .. CHARACTER COMPQC LOGICAL INITQ, PAIR, SPECQ, SWAP, WANTQ, WANTQL, WS INTEGER I, IP1, IT, L, LL, LS, MAXN, MINN, MINSUM, $ MNWORK, NKP1, SUMD C .. C .. Local Arrays .. DOUBLE PRECISION TOLA( 3 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. C .. External Subroutines .. EXTERNAL DLASET, MB03KA, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MOD C .. C .. Local Functions .. INTEGER INDP1 INDP1( I, K ) = MOD( I, K ) + 1 C .. C .. Executable Statements .. C C Decode and test the input parameters. C INFO = 0 INITQ = LSAME( COMPQ, 'I' ) WANTQ = LSAME( COMPQ, 'U' ) .OR. INITQ SPECQ = LSAME( COMPQ, 'W' ) WS = LSAME( STRONG, 'S' ) C C Test all input arguments. C IF( K.LT.2 ) THEN INFO = -4 C C Check options for generating orthogonal factors. C ELSE IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. WANTQ .OR. SPECQ ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( STRONG, 'N' ) .OR. WS ) ) THEN INFO = -3 ELSE IF( TOL.LE.ZERO ) THEN INFO = -18 END IF IF( INFO.EQ.0 .AND. SPECQ ) THEN DO 10 L = 1, K IF( WHICHQ(L).LT.0 .OR. WHICHQ(L).GT.2 ) $ INFO = -2 10 CONTINUE END IF C C Check whether any of the dimensions is negative. C At the same time the sequence of consecutive sums of dimension C differences is formed and its minimum is determined. C Also, the maximum of all dimensions is computed. C SUMD = 0 IF( INFO.EQ.0 ) THEN MINSUM = 0 MAXN = 0 MINN = N(K) C DO 20 L = 1, K IF( L.LT.K .AND. N(L).LT.MINN ) $ MINN = N(L) NKP1 = N(INDP1(L,K)) IF ( N(L).LT.0 ) $ INFO = -7 IF ( S(L).EQ.-1 ) $ SUMD = SUMD + ( NKP1 - N(L) ) IF ( SUMD.LT.MINSUM ) $ MINSUM = SUMD MAXN = MAX( MAXN, N(L) ) C C Check the condition N(l) >= NI(l) + NC >= 0. C IF( INFO.EQ.0 .AND. ( N(L).LT.NI(L)+NC .OR. NI(L).LT.0 ) ) $ INFO = -8 20 CONTINUE END IF C C Check the condition 0 <= NC <= min(N). C IF( INFO.EQ.0 .AND. ( NC.LT.0 .OR. NC.GT.MINN ) ) $ INFO = -5 C C Check KSCHUR. C IF( INFO.EQ.0 .AND. ( KSCHUR.LT.1 .OR. KSCHUR.GT.K ) ) $ INFO = -6 C C Check that the complete sum is zero; otherwise T is singular. C IF( INFO.EQ.0 .AND. SUMD.NE.0 ) $ INFO = -7 C C Check signatures. C IF( INFO.EQ.0 ) THEN DO 30 L = 1, K IF( ABS( S(L) ).NE.1 ) $ INFO = -9 30 CONTINUE END IF C C Check the leading dimensions of T_k. C IF( INFO.EQ.0 ) THEN DO 40 L = 1, K NKP1 = N(INDP1(L,K)) IF ( S(L).EQ.1 ) THEN IF ( LDT(L).LT.MAX( 1, NKP1 ) ) $ INFO = -12 ELSE IF ( LDT(L).LT.MAX( 1, N(L) ) ) $ INFO = -12 END IF 40 CONTINUE END IF C C Check the leading dimensions of Q_k. C IF( INFO.EQ.0 .AND. ( WANTQ .OR. SPECQ ) ) THEN DO 50 L = 1, K WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ(L).NE.0 IF ( WANTQL ) THEN IF ( LDQ( L ).LT.MAX( 1, N(L) ) ) $ INFO = -15 END IF 50 CONTINUE END IF C C Set M to the dimension of the specified periodic invariant C subspace. C M = 0 I = KSCHUR PAIR = .FALSE. IP1 = INDP1( I, K ) DO 70 L = 1, NC IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( L.LT.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + L - 1 )*LDT(I) + NI(IP1) + L ELSE IT = IXT(I) + ( NI(IP1) + L - 1 )*LDT(I) + NI(I) + L END IF IF( T(IT).EQ.ZERO ) THEN IF( SELECT( L ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( L ) .OR. SELECT( L+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( NC ) ) $ M = M + 1 END IF END IF 70 CONTINUE C C Set COMPQ for MB03KA, if needed. C IF( INITQ ) THEN COMPQC = 'U' ELSE COMPQC = COMPQ END IF C C Check workspace. C IF( INFO.EQ.0 ) THEN CALL MB03KA( COMPQC, WHICHQ, WS, K, NC, KSCHUR, 1, 1, N, NI, S, $ T, LDT, IXT, Q, LDQ, IXQ, DWORK, IWORK, DWORK, -1, $ INFO ) MNWORK = MAX( 1, INT( DWORK(1) ) ) IF( LDWORK.NE.-1 .AND. LDWORK.LT.MNWORK ) $ INFO = -21 END IF C C Quick return if possible. C IF( INFO.LT.0 ) THEN CALL XERBLA( 'MB03KD', -INFO ) RETURN ELSE IF( LDWORK.EQ.-1 ) THEN DWORK(1) = DBLE( MNWORK ) RETURN END IF C C Compute some machine-dependent parameters. C TOLA( 1 ) = TOL TOLA( 2 ) = DLAMCH( 'Precision' ) TOLA( 3 ) = DLAMCH( 'Safe minimum' ) / TOLA( 2 ) C C Initialization of orthogonal factors. C DO 80 L = 1, K IF ( SPECQ ) $ INITQ = WHICHQ(L).EQ.1 IF ( INITQ ) $ CALL DLASET( 'All', N(L), N(L), ZERO, ONE, Q( IXQ( L ) ), $ LDQ( L ) ) 80 CONTINUE C C Collect the selected blocks at the top-left corner of T22_k. C LS = 0 PAIR = .FALSE. I = KSCHUR IP1 = INDP1( I, K ) DO 90 L = 1, NC IF( PAIR ) THEN PAIR = .FALSE. ELSE SWAP = SELECT( L ) IF( L.LT.NC ) THEN IF( S(I).EQ.1 ) THEN IT = IXT(I) + ( NI(I) + L - 1 )*LDT(I) + NI(IP1) + L ELSE IT = IXT(I) + ( NI(IP1) + L - 1 )*LDT(I) + NI(I) + L END IF IF( T(IT).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP .OR. SELECT( L+1 ) END IF END IF IF( SWAP ) THEN LS = LS + 1 C C Swap the L-th block to position LS in T22_k. C LL = L IF( L.NE.LS ) THEN CALL MB03KA( COMPQC, WHICHQ, WS, K, NC, KSCHUR, LL, $ LS, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, $ TOLA, IWORK, DWORK, LDWORK, INFO ) IF( INFO.NE.0 ) THEN C C Blocks too close to swap; exit. C GO TO 100 END IF END IF IF( PAIR ) $ LS = LS + 1 END IF END IF 90 CONTINUE C 100 CONTINUE C C Store optimal workspace length and return. C DWORK(1) = DBLE( MNWORK ) RETURN C C *** Last line of MB03KD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03WX.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03WX.f0000644000175000017500000001047715012430707017422 0ustar00lilgelilge00000000000000 SUBROUTINE MB03WX( N, P, T, LDT1, LDT2, WR, WI, INFO ) C C PURPOSE C C To compute the eigenvalues of a product of matrices, C T = T_1*T_2*...*T_p, where T_1 is an upper quasi-triangular C matrix and T_2, ..., T_p are upper triangular matrices. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix T. N >= 0. C C P (input) INTEGER C The number of matrices in the product T_1*T_2*...*T_p. C P >= 1. C C T (input) DOUBLE PRECISION array, dimension (LDT1,LDT2,P) C The leading N-by-N part of T(*,*,1) must contain the upper C quasi-triangular matrix T_1 and the leading N-by-N part of C T(*,*,j) for j > 1 must contain the upper-triangular C matrix T_j, j = 2, ..., p. C The elements below the subdiagonal of T(*,*,1) and below C the diagonal of T(*,*,j), j = 2, ..., p, are not C referenced. C C LDT1 INTEGER C The first leading dimension of the array T. C LDT1 >= max(1,N). C C LDT2 INTEGER C The second leading dimension of the array T. C LDT2 >= 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_1. If T(i:i+1,i:i+1,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 V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. C C REVISIONS C C - C C KEYWORDS C C Eigenvalue, eigenvalue decomposition, periodic systems, C real Schur form, triangular form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D+0 ) C .. Scalar Arguments .. INTEGER INFO, LDT1, LDT2, N, P C .. Array Arguments .. DOUBLE PRECISION T( LDT1, LDT2, * ), WI( * ), WR( * ) C .. Local Scalars .. INTEGER I, I1, INEXT, J DOUBLE PRECISION A11, A12, A21, A22, CS, SN, T11, T12, T22 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( P.LT.1 ) THEN INFO = -2 ELSE IF( LDT1.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDT2.LT.MAX( 1, N ) ) THEN INFO = -5 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB03WX', -INFO ) RETURN END IF C INEXT = 1 DO 30 I = 1, N IF( I.LT.INEXT ) $ GO TO 30 IF( I.NE.N ) THEN IF( T( I+1, I, 1 ).NE.ZERO ) THEN C C A pair of eigenvalues. First compute the corresponding C elements of T(I:I+1,I:I+1). C INEXT = I + 2 I1 = I + 1 T11 = ONE T12 = ZERO T22 = ONE C DO 10 J = 2, P T22 = T22*T( I1, I1, J ) T12 = T11*T( I, I1, J ) + T12*T( I1, I1, J ) T11 = T11*T( I, I, J ) 10 CONTINUE C A11 = T( I, I, 1 )*T11 A12 = T( I, I, 1 )*T12 + T( I, I1, 1 )*T22 A21 = T( I1, I, 1 )*T11 A22 = T( I1, I, 1 )*T12 + T( I1, I1, 1 )*T22 C CALL DLANV2( A11, A12, A21, A22, WR( I ), WI( I ), $ WR( I1 ), WI( I1 ), CS, SN ) GO TO 30 END IF END IF C C Simple eigenvalue. Compute the corresponding element of T(I,I). C INEXT = I + 1 T11 = ONE C DO 20 J = 1, P T11 = T11*T( I, I, J ) 20 CONTINUE C WR( I ) = T11 WI( I ) = ZERO 30 CONTINUE C RETURN C *** Last line of MB03WX *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01RB.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01RB.f0000644000175000017500000004132615012430707017362 0ustar00lilgelilge00000000000000 SUBROUTINE MB01RB( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, $ A, LDA, B, LDB, INFO ) 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. A block algorithm is used. 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 The required triangle only is computed and overwritten, contrary C to a general matrix multiplication operation. C C This is a BLAS 3 version of the SLICOT Library routine MB01RX. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2013. C C REVISIONS C C V. Sima, Jul. 2013. 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 NBS is a value used to switch from small to C large block sizes. C N1P is a block size to be used for large C matrices when SIDE = 'L' and TRANS = 'T', and C N1L is a minimum block size N1 in this case. C N2P and N2L are similar block sizes for N2, C used when SIDE and TRANS have other values. INTEGER N1L, N1P, N2L, N2P, NBS PARAMETER ( N1L = 128, N1P = 512, N2L = 40, N2P = 128, $ NBS = 48 ) 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 I, IB, J, JB, MN, MX, N1, N2, NB, NBMIN, NX C .. Local Arrays .. DOUBLE PRECISION D(1) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL ILAENV, LSAME C .. External Subroutines .. EXTERNAL DGEMM, DGEQRF, DLASCL, DLASET, MB01RX, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, 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( 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( 'MB01RB', -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 essentially C BLAS 3 operations. C C Find the block size using DGEQRF. C MX = MAX( M, N ) MN = MIN( M, N ) CALL DGEQRF( MX, MN, A, MX, D, D, -1, INFO ) NB = INT( D(1) )/MN/8*8 C IF( NB.GT.1 .AND. NB.LT.M ) THEN C C Determine when to cross over from blocked to unblocked code. C NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', MX, MN, -1, -1 ) ) IF( NX.LT.M ) THEN C C Determine the minimum value of NB. C NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', MX, MN, -1, -1 ) ) END IF ELSE NX = 0 NBMIN = 2 END IF C IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN C C Use blocked code initially. C IF( LTRANS .AND. LSIDE ) THEN IF( NB.LE.NBS ) THEN N1 = MIN( MAX( N1L, NB ), N ) ELSE N1 = MIN( N1P, N ) END IF ELSE IF( NB.LE.NBS ) THEN N2 = MIN( MAX( N2L, NB ), N ) ELSE N2 = MIN( N2P, N ) END IF END IF C DO 50 I = 1, M - NX, NB IB = I + NB JB = MIN( M-I+1, NB ) C C Compute the current diagonal block and the needed off- C diagonal part of the current block row, if UPLO = 'U', C or block column, if UPLO = 'L'. C IF( LTRANS ) THEN IF( LSIDE ) THEN CALL MB01RX( SIDE, UPLO, TRANS, JB, N1, ALPHA, BETA, $ R(I,I), LDR, A(1,I), LDA, B(1,I), LDB, $ INFO ) DO 10 J = N1+1, N, N1 CALL MB01RX( SIDE, UPLO, TRANS, JB, MIN(N1, N-J+1), $ ONE, BETA, R(I,I), LDR, A(J,I), LDA, $ B(J,I), LDB, INFO ) 10 CONTINUE IF( IB.LE.M ) THEN IF( LUPLO ) THEN CALL DGEMM( TRANS, 'No transpose', JB, M-IB+1, $ N, BETA, A(1,I), LDA, B(1,IB), LDB, $ ALPHA, R(I,IB), LDR ) ELSE CALL DGEMM( TRANS, 'No transpose', M-IB+1, JB, $ N, BETA, A(1,IB), LDA, B(1,I), LDB, $ ALPHA, R(IB,I), LDR ) END IF END IF ELSE CALL MB01RX( SIDE, UPLO, TRANS, JB, N2, ALPHA, BETA, $ R(I,I), LDR, A(I,1), LDA, B(I,1), LDB, $ INFO ) DO 20 J = N2+1, N, N2 CALL MB01RX( SIDE, UPLO, TRANS, JB, MIN(N2, N-J+1), $ ONE, BETA, R(I,I), LDR, A(I,J), LDA, $ B(I,J), LDB, INFO ) 20 CONTINUE IF( IB.LE.M ) THEN IF( LUPLO ) THEN CALL DGEMM( 'No transpose', TRANS, JB, M-IB+1, $ N, BETA, B(I,1), LDB, A(IB,1), LDA, $ ALPHA, R(I,IB), LDR ) ELSE CALL DGEMM( 'No transpose', TRANS, M-IB+1, JB, $ N, BETA, B(IB,1), LDB, A(I,1), LDA, $ ALPHA, R(IB,I), LDR ) END IF END IF END IF ELSE IF( LSIDE ) THEN CALL MB01RX( SIDE, UPLO, TRANS, JB, N2, ALPHA, BETA, $ R(I,I), LDR, A(I,1), LDA, B(1,I), LDB, $ INFO ) DO 30 J = N2+1, N, N2 CALL MB01RX( SIDE, UPLO, TRANS, JB, MIN(N2, N-J+1), $ ONE, BETA, R(I,I), LDR, A(I,J), LDA, $ B(J,I), LDB, INFO ) 30 CONTINUE IF( IB.LE.M ) THEN IF( LUPLO ) THEN CALL DGEMM( TRANS, 'No transpose', JB, M-IB+1, $ N, BETA, A(I,1), LDA, B(1,IB), LDB, $ ALPHA, R(I,IB), LDR ) ELSE CALL DGEMM( TRANS, 'No transpose', M-IB+1, JB, $ N, BETA, A(IB,1), LDA, B(1,I), LDB, $ ALPHA, R(IB,I), LDR ) END IF END IF ELSE CALL MB01RX( SIDE, UPLO, TRANS, JB, N2, ALPHA, BETA, $ R(I,I), LDR, A(1,I), LDA, B(I,1), LDB, $ INFO ) DO 40 J = N2+1, N, N2 CALL MB01RX( SIDE, UPLO, TRANS, JB, MIN(N2, N-J+1), $ ONE, BETA, R(I,I), LDR, A(J,I), LDA, $ B(I,J), LDB, INFO ) 40 CONTINUE IF( IB.LE.M ) THEN IF( LUPLO ) THEN CALL DGEMM( 'No transpose', TRANS, JB, M-IB+1, $ N, BETA, B(I,1), LDB, A(1,IB), LDA, $ ALPHA, R(I,IB), LDR ) ELSE CALL DGEMM( 'No transpose', TRANS, M-IB+1, JB, $ N, BETA, B(IB,1), LDB, A(1,I), LDA, $ ALPHA, R(IB,I), LDR ) END IF END IF END IF END IF C 50 CONTINUE ELSE I = 1 N1 = N N2 = N END IF C C Use unblocked code to compute the last or only block. C IF( I.LE.M ) THEN IF( LTRANS ) THEN IF( LSIDE ) THEN CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, N1, ALPHA, BETA, $ R(I,I), LDR, A(1,I), LDA, B(1,I), LDB, $ INFO ) DO 60 J = N1+1, N, N1 CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, MIN(N1, N-J+1), $ ONE, BETA, R(I,I), LDR, A(J,I), LDA, $ B(J,I), LDB, INFO ) 60 CONTINUE ELSE CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, N2, ALPHA, BETA, $ R(I,I), LDR, A(I,1), LDA, B(I,1), LDB, $ INFO ) DO 70 J = N2+1, N, N2 CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, MIN(N2, N-J+1), $ ONE, BETA, R(I,I), LDR, A(I,J), LDA, $ B(I,J), LDB, INFO ) 70 CONTINUE END IF ELSE IF( LSIDE ) THEN CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, N2, ALPHA, BETA, $ R(I,I), LDR, A(I,1), LDA, B(1,I), LDB, $ INFO ) DO 80 J = N2+1, N, N2 CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, MIN(N2, N-J+1), $ ONE, BETA, R(I,I), LDR, A(I,J), LDA, $ B(J,I), LDB, INFO ) 80 CONTINUE ELSE CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, N2, ALPHA, BETA, $ R(I,I), LDR, A(1,I), LDA, B(I,1), LDB, $ INFO ) DO 90 J = N2+1, N, N2 CALL MB01RX( SIDE, UPLO, TRANS, M-I+1, MIN(N2, N-J+1), $ ONE, BETA, R(I,I), LDR, A(J,I), LDA, $ B(I,J), LDB, INFO ) 90 CONTINUE END IF END IF END IF C RETURN C *** Last line of MB01RB *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04WU.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04WU.f0000644000175000017500000003214615012430707017415 0ustar00lilgelilge00000000000000 SUBROUTINE MB04WU( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2, $ CS, TAU, DWORK, LDWORK, INFO ) C C PURPOSE C C To generate a matrix Q with orthogonal columns (spanning an C isotropic subspace), which is defined as the first n columns C of a product of symplectic reflectors and Givens rotations, C C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). C C The matrix Q is returned in terms of its first 2*M rows C C [ op( Q1 ) op( Q2 ) ] C Q = [ ]. C [ -op( Q2 ) op( Q1 ) ] C C ARGUMENTS C C Mode Parameters C C TRANQ1 CHARACTER*1 C Specifies the form of op( Q1 ) as follows: C = 'N': op( Q1 ) = Q1; C = 'T': op( Q1 ) = Q1'; C = 'C': op( Q1 ) = Q1'. C C TRANQ2 CHARACTER*1 C Specifies the form of op( Q2 ) as follows: C = 'N': op( Q2 ) = Q2; C = 'T': op( Q2 ) = Q2'; C = 'C': op( Q2 ) = Q2'. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrices Q1 and Q2. M >= 0. C C N (input) INTEGER C The number of columns of the matrices Q1 and Q2. C M >= N >= 0. C C K (input) INTEGER C The number of symplectic Givens rotations whose product C partly defines the matrix Q. N >= K >= 0. C C Q1 (input/output) DOUBLE PRECISION array, dimension C (LDQ1,N) if TRANQ1 = 'N', C (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C' C On entry with TRANQ1 = 'N', the leading M-by-K part of C this array must contain in its i-th column the vector C which defines the elementary reflector F(i). C On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading C K-by-M part of this array must contain in its i-th row C the vector which defines the elementary reflector F(i). C On exit with TRANQ1 = 'N', the leading M-by-N part of this C array contains the matrix Q1. C On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading C N-by-M part of this array contains the matrix Q1'. C C LDQ1 INTEGER C The leading dimension of the array Q1. C LDQ1 >= MAX(1,M), if TRANQ1 = 'N'; C LDQ1 >= MAX(1,N), if TRANQ1 = 'T' or TRANQ1 = 'C'. C C Q2 (input/output) DOUBLE PRECISION array, dimension C (LDQ2,N) if TRANQ2 = 'N', C (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C' C On entry with TRANQ2 = 'N', the leading M-by-K part of C this array must contain in its i-th column the vector C which defines the elementary reflector H(i) and, on the C diagonal, the scalar factor of H(i). C On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading C K-by-M part of this array must contain in its i-th row the C vector which defines the elementary reflector H(i) and, on C the diagonal, the scalar factor of H(i). C On exit with TRANQ2 = 'N', the leading M-by-N part of this C array contains the matrix Q2. C On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading C N-by-M part of this array contains the matrix Q2'. C C LDQ2 INTEGER C The leading dimension of the array Q2. C LDQ2 >= MAX(1,M), if TRANQ2 = 'N'; C LDQ2 >= MAX(1,N), if TRANQ2 = 'T' or TRANQ2 = 'C'. C C CS (input) DOUBLE PRECISION array, dimension (2*K) C On entry, the first 2*K elements of this array must C contain the cosines and sines of the symplectic Givens C rotations G(i). C C TAU (input) DOUBLE PRECISION array, dimension (K) C On entry, the first K elements of this array must C contain the scalar factors of the elementary reflectors C F(i). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -13, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,M+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 REFERENCES C C [1] Bunse-Gerstner, A. C Matrix factorizations for symplectic QR-like methods. C Linear Algebra Appl., 83, pp. 49-77, 1986. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSQ). C C KEYWORDS C C Elementary matrix operations, orthogonal symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. Scalar Arguments .. CHARACTER TRANQ1, TRANQ2 INTEGER INFO, K, LDQ1, LDQ2, LDWORK, M, N C .. Array Arguments .. DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) C .. Local Scalars .. LOGICAL LTRQ1, LTRQ2 INTEGER I, J DOUBLE PRECISION NU C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLARF, DLASET, DROT, DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 LTRQ1 = LSAME( TRANQ1,'T' ) .OR. LSAME( TRANQ1,'C' ) LTRQ2 = LSAME( TRANQ2,'T' ) .OR. LSAME( TRANQ2,'C' ) C C Check the scalar input parameters. C IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN INFO = -2 ELSE IF ( M.LT.0 ) THEN INFO = -3 ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN INFO = -4 ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN INFO = -5 ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR. $ ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN INFO = -7 ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR. $ ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN INFO = -9 ELSE IF ( LDWORK.LT.MAX( 1,M + N ) ) THEN DWORK(1) = DBLE( MAX( 1,M + N ) ) INFO = -13 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04WU', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Initialize columns K+1:N to columns of the unit matrix. C DO 20 J = K + 1, N DO 10 I = 1, M Q1(I,J) = ZERO 10 CONTINUE Q1(J,J) = ONE 20 CONTINUE CALL DLASET( 'All', M, N-K, ZERO, ZERO, Q2(1,K+1), LDQ2 ) C IF ( LTRQ1.AND.LTRQ2 ) THEN DO 50 I = K, 1, -1 C C Apply F(I) to Q1(I+1:N,I:M) and Q2(I+1:N,I:M) from the C right. C CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 ) IF ( I.LT.N ) THEN Q1(I,I) = ONE CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), $ Q1(I+1,I), LDQ1, DWORK(M+1) ) CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), $ Q2(I+1,I), LDQ2, DWORK(M+1) ) END IF IF ( I.LT.M ) $ CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 ) Q1(I,I) = ONE - TAU(I) C C Set Q1(I,1:I-1) and Q2(I,1:M) to zero. C DO 30 J = 1, I - 1 Q1(I,J) = ZERO 30 CONTINUE DO 40 J = 1, M Q2(I,J) = ZERO 40 CONTINUE C C Apply G(I) to Q1(I:N,I) and Q2(I:N,I) from the right. C CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), 1, CS(2*I-1), $ CS(2*I) ) C C Apply H(I) to Q1(I:N,I:M) and Q2(I:N,I:M) from the right. C NU = DWORK(1) DWORK(1) = ONE CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I), $ LDQ1, DWORK(M+1) ) CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I), $ LDQ2, DWORK(M+1) ) 50 CONTINUE ELSE IF ( LTRQ1 ) THEN DO 80 I = K, 1, -1 C C Apply F(I) to Q1(I+1:N,I:M) from the right and to C Q2(I:M,I+1:N) from the left. C CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 ) IF ( I.LT.N ) THEN Q1(I,I) = ONE CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), $ Q1(I+1,I), LDQ1, DWORK(M+1) ) CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), LDQ1, TAU(I), $ Q2(I,I+1), LDQ2, DWORK(M+1) ) END IF IF ( I.LT.M ) $ CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 ) Q1(I,I) = ONE - TAU(I) C C Set Q1(I,1:I-1) and Q2(1:M,I) to zero. C DO 60 J = 1, I - 1 Q1(I,J) = ZERO 60 CONTINUE DO 70 J = 1, M Q2(J,I) = ZERO 70 CONTINUE C C Apply G(I) to Q1(I:N,I) from the right and to Q2(I,I:N) C from the left. C CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), LDQ2, CS(2*I-1), $ CS(2*I) ) C C Apply H(I) to Q1(I:N,I:M) from the right and to Q2(I:M,I:N) C from the left. C NU = DWORK(1) DWORK(1) = ONE CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I), $ LDQ1, DWORK(M+1) ) CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I), $ LDQ2, DWORK(M+1) ) 80 CONTINUE ELSE IF ( LTRQ2 ) THEN DO 110 I = K, 1, -1 C C Apply F(I) to Q1(I:M,I+1:N) from the left and to C Q2(I+1:N,I:M) from the right. C CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 ) IF ( I.LT.N ) THEN Q1(I,I) = ONE CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), $ Q1(I,I+1), LDQ1, DWORK(M+1) ) CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), 1, TAU(I), $ Q2(I+1,I), LDQ2, DWORK(M+1) ) END IF IF ( I.LT.M ) $ CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 ) Q1(I,I) = ONE - TAU(I) C C Set Q1(1:I-1,I) and Q2(I,1:M) to zero. C DO 90 J = 1, I - 1 Q1(J,I) = ZERO 90 CONTINUE DO 100 J = 1, M Q2(I,J) = ZERO 100 CONTINUE C C Apply G(I) to Q1(I,I:N) from the left and to Q2(I:N,I) C from the right. C CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), 1, CS(2*I-1), $ CS(2*I) ) C C Apply H(I) to Q1(I:M,I:N) from the left and to Q2(I:N,I:M) C from the left. C NU = DWORK(1) DWORK(1) = ONE CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I), $ LDQ1, DWORK(M+1) ) CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I), $ LDQ2, DWORK(M+1) ) 110 CONTINUE ELSE DO 140 I = K, 1, -1 C C Apply F(I) to Q1(I:M,I+1:N) and Q2(I:M,I+1:N) from the left. C CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 ) IF ( I.LT.N ) THEN Q1(I,I) = ONE CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), $ Q1(I,I+1), LDQ1, DWORK(M+1) ) CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), $ Q2(I,I+1), LDQ2, DWORK(M+1) ) END IF IF ( I.LT.M ) $ CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 ) Q1(I,I) = ONE - TAU(I) C C Set Q1(1:I-1,I) and Q2(1:M,I) to zero. C DO 120 J = 1, I - 1 Q1(J,I) = ZERO 120 CONTINUE DO 130 J = 1, M Q2(J,I) = ZERO 130 CONTINUE C C Apply G(I) to Q1(I,I:N) and Q2(I,I:N) from the left. C CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), $ CS(2*I) ) C C Apply H(I) to Q1(I:M,I:N) and Q2(I:M,I:N) from the left. C NU = DWORK(1) DWORK(1) = ONE CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I), $ LDQ1, DWORK(M+1) ) CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I), $ LDQ2, DWORK(M+1) ) 140 CONTINUE END IF DWORK(1) = DBLE( MAX( 1, M+N ) ) C *** Last line of MB04WU *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01TD.f0000644000000000000000000000013015012430707016163 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MC01TD.f0000644000175000017500000002176615012430707017375 0ustar00lilgelilge00000000000000 SUBROUTINE MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO ) C C PURPOSE C C To determine whether or not a given polynomial P(x) with real C coefficients is stable, either in the continuous-time or discrete- C time case. C C A polynomial is said to be stable in the continuous-time case C if all its zeros lie in the left half-plane, and stable in the C discrete-time case if all its zeros lie inside the unit circle. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Indicates whether the stability test to be applied to C P(x) is in the continuous-time or discrete-time case as C follows: C = 'C': Continuous-time case; C = 'D': Discrete-time case. C C Input/Output Parameters C C DP (input/output) INTEGER C On entry, the degree of the polynomial P(x). DP >= 0. C On exit, if P(DP+1) = 0.0 on entry, then DP contains the C index of the highest power of x for which P(DP+1) <> 0.0. C C P (input) DOUBLE PRECISION array, dimension (DP+1) C This array must contain the coefficients of P(x) in C increasing powers of x. C C STABLE (output) LOGICAL C Contains the value .TRUE. if P(x) is stable and the value C .FALSE. otherwise (see also NUMERICAL ASPECTS). C C NZ (output) INTEGER C If INFO = 0, contains the number of unstable zeros - that C is, the number of zeros of P(x) in the right half-plane if C DICO = 'C' or the number of zeros of P(x) outside the unit C circle if DICO = 'D' (see also NUMERICAL ASPECTS). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (2*DP+2) C The leading (DP+1) elements of DWORK contain the Routh C coefficients, if DICO = 'C', or the constant terms of C the Schur-Cohn transforms, if DICO = 'D'. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = k: if the degree of the polynomial P(x) has been C reduced to (DB - k) because P(DB+1-j) = 0.0 on entry C for j = 0, 1,..., k-1 and P(DB+1-k) <> 0.0. 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 on entry, P(x) is the zero polynomial; C = 2: if the polynomial P(x) is most probably unstable, C although it may be stable with one or more zeros C very close to either the imaginary axis if C DICO = 'C' or the unit circle if DICO = 'D'. C The number of unstable zeros (NZ) is not determined. C C METHOD C C The stability of the real polynomial C 2 DP C P(x) = p(0) + p(1) * x + p(2) * x + ... + p(DP) x C C is determined as follows. C C In the continuous-time case (DICO = 'C') the Routh algorithm C (see [1]) is used. The routine computes the Routh coefficients and C if they are non-zero then the number of sign changes in the C sequence of the coefficients is equal to the number of zeros with C positive imaginary part. C C In the discrete-time case (DICO = 'D') the Schur-Cohn C algorithm (see [2] and [3]) is applied to the reciprocal C polynomial C 2 DP C Q(x) = p(DP) + p(DP-1) * x + p(DP-2) * x + ... + p(0) x . C C The routine computes the constant terms of the Schur transforms C and if all of them are non-zero then the number of zeros of P(x) C with modulus greater than unity is obtained from the sequence of C constant terms. C C REFERENCES C C [1] Gantmacher, F.R. C Applications of the Theory of Matrices. C Interscience Publishers, New York, 1959. C C [2] Kucera, V. C Discrete Linear Control. The Algorithmic Approach. C John Wiley & Sons, Chichester, 1979. C C [3] Henrici, P. C Applied and Computational Complex Analysis (Vol. 1). C John Wiley & Sons, New York, 1974. C C NUMERICAL ASPECTS C C The algorithm used by the routine is numerically stable. C C Note that if some of the Routh coefficients (DICO = 'C') or C some of the constant terms of the Schur-Cohn transforms (DICO = C 'D') are small relative to EPS (the machine precision), then C the number of unstable zeros (and hence the value of STABLE) may C be incorrect. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01HD by F. Delebecque and C A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Elementary polynomial operations, polynomial operations, C stability, stability criteria, zeros. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO LOGICAL STABLE INTEGER DP, INFO, IWARN, NZ C .. Array Arguments .. DOUBLE PRECISION DWORK(*), P(*) C .. Local Scalars .. LOGICAL DICOC INTEGER I, K, K1, K2, SIGNUM DOUBLE PRECISION ALPHA, P1, PK1 C .. External Functions .. INTEGER IDAMAX LOGICAL LSAME EXTERNAL IDAMAX, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DRSCL, XERBLA C .. Intrinsic Functions .. INTRINSIC SIGN C .. Executable Statements .. C IWARN = 0 INFO = 0 DICOC = LSAME( DICO, 'C' ) C C Test the input scalar arguments. C IF( .NOT.DICOC .AND. .NOT.LSAME( DICO, 'D' ) ) THEN INFO = -1 ELSE IF( DP.LT.0 ) THEN INFO = -2 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MC01TD', -INFO ) RETURN END IF C C WHILE (DP >= 0 and P(DP+1) = 0 ) DO 20 IF ( DP.GE.0 ) THEN IF ( P(DP+1).EQ.ZERO ) THEN DP = DP - 1 IWARN = IWARN + 1 GO TO 20 END IF END IF C END WHILE 20 C IF ( DP.EQ.-1 ) THEN INFO = 1 RETURN END IF C C P(x) is not the zero polynomial and its degree is exactly DP. C IF ( DICOC ) THEN C C Continuous-time case. C C Compute the Routh coefficients and the number of sign changes. C CALL DCOPY( DP+1, P, 1, DWORK, 1 ) NZ = 0 K = DP C WHILE ( K > 0 and DWORK(K) non-zero) DO 40 IF ( K.GT.0 ) THEN IF ( DWORK(K).EQ.ZERO ) THEN INFO = 2 ELSE ALPHA = DWORK(K+1)/DWORK(K) IF ( ALPHA.LT.ZERO ) NZ = NZ + 1 K = K - 1 C DO 60 I = K, 2, -2 DWORK(I) = DWORK(I) - ALPHA*DWORK(I-1) 60 CONTINUE C GO TO 40 END IF END IF C END WHILE 40 ELSE C C Discrete-time case. C C To apply [3], section 6.8, on the reciprocal of polynomial C P(x) the elements of the array P are copied in DWORK in C reverse order. C CALL DCOPY( DP+1, P, 1, DWORK, -1 ) C K-1 C DWORK(K),...,DWORK(DP+1), are the coefficients of T P(x) C scaled with a factor alpha(K) in order to avoid over- or C underflow, C i-1 C DWORK(i), i = 1,...,K, contains alpha(i) * T P(0). C SIGNUM = ONE NZ = 0 K = 1 C WHILE ( K <= DP and DWORK(K) non-zero ) DO 80 IF ( ( K.LE.DP ) .AND. ( INFO.EQ.0 ) ) THEN C K C Compute the coefficients of T P(x). C K1 = DP - K + 2 K2 = DP + 2 ALPHA = DWORK(K-1+IDAMAX( K1, DWORK(K), 1 )) IF ( ALPHA.EQ.ZERO ) THEN INFO = 2 ELSE CALL DCOPY( K1, DWORK(K), 1, DWORK(K2), 1 ) CALL DRSCL( K1, ALPHA, DWORK(K2), 1 ) P1 = DWORK(K2) PK1 = DWORK(K2+K1-1) C DO 100 I = 1, K1 - 1 DWORK(K+I) = P1*DWORK(DP+1+I) - PK1*DWORK(K2+K1-I) 100 CONTINUE C C Compute the number of unstable zeros. C K = K + 1 IF ( DWORK(K).EQ.ZERO ) THEN INFO = 2 ELSE SIGNUM = SIGNUM*SIGN( ONE, DWORK(K) ) IF ( SIGNUM.LT.ZERO ) NZ = NZ + 1 END IF GO TO 80 END IF C END WHILE 80 END IF END IF C IF ( ( INFO.EQ.0 ) .AND. ( NZ.EQ.0 ) ) THEN STABLE = .TRUE. ELSE STABLE = .FALSE. END IF C RETURN C *** Last line of MC01TD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02MT.f0000644000000000000000000000013015012430707016202 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB02MT.f0000644000175000017500000005175715012430707017417 0ustar00lilgelilge00000000000000 SUBROUTINE SB02MT( JOBG, JOBL, FACT, UPLO, N, M, A, LDA, B, LDB, $ Q, LDQ, R, LDR, L, LDL, IPIV, OUFACT, G, LDG, $ IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the following matrices C C -1 C G = B*R *B', C C - -1 C A = A - B*R *L', C C - -1 C Q = Q - L*R *L', C C where A, B, Q, R, L, and G are N-by-N, N-by-M, N-by-N, M-by-M, C N-by-M, and N-by-N matrices, respectively, with Q, R and G C symmetric matrices. C C When R is well-conditioned with respect to inversion, standard C algorithms for solving linear-quadratic optimization problems will C then also solve optimization problems with coupling weighting C matrix L. Moreover, a gain in efficiency is possible using matrix C G in the deflating subspace algorithms (see SLICOT Library routine C SB02OD) or in the Newton's algorithms (see SLICOT Library routine C SG02CD). C C ARGUMENTS C C Mode Parameters C C JOBG CHARACTER*1 C Specifies whether or not the matrix G is to be computed, C as follows: C = 'G': Compute G; C = 'N': Do not compute G. C C JOBL CHARACTER*1 C Specifies whether or not the matrix L is zero, as follows: C = 'Z': L is zero; C = 'N': L is nonzero. C C FACT CHARACTER*1 C Specifies how the matrix R is given (factored or not), as C follows: C = 'N': Array R contains the matrix R; C = 'C': Array R contains the Cholesky factor of R; C = 'U': Array R contains the factors of the symmetric C indefinite UdU' or LdL' factorization of R. C C UPLO CHARACTER*1 C Specifies which triangle of the matrices R, Q (if C JOBL = 'N'), and G (if JOBG = 'G') is stored, as follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, Q, and G, and the number of C rows of the matrices B and L. N >= 0. C C M (input) INTEGER C The order of the matrix R, and the number of columns of C the matrices B and L. M >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, if JOBL = 'N', the leading N-by-N part of this C array must contain the matrix A. C On exit, if JOBL = 'N', and INFO = 0, the leading N-by-N C - -1 C part of this array contains the matrix A = A - B*R L'. C If JOBL = 'Z', this array is not referenced. C C LDA INTEGER C The leading dimension of array A. C LDA >= MAX(1,N) if JOBL = 'N'; C LDA >= 1 if JOBL = 'Z'. 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 matrix B. C On exit, if OUFACT = 1, and INFO = 0, the leading N-by-M C -1 C part of this array contains the matrix B*chol(R) . C On exit, B is unchanged if OUFACT <> 1 (hence also when C FACT = 'U'). C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, if JOBL = 'N', the leading N-by-N upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the upper C triangular part or lower triangular part, respectively, of C the symmetric matrix Q. The strictly lower triangular part C (if UPLO = 'U') or strictly upper triangular part (if C UPLO = 'L') is not referenced. C On exit, if JOBL = 'N' and INFO = 0, the leading N-by-N C upper triangular part (if UPLO = 'U') or lower triangular C part (if UPLO = 'L') of this array contains the upper C triangular part or lower triangular part, respectively, of C - -1 C the symmetric matrix Q = Q - L*R *L'. C If JOBL = 'Z', this array is not referenced. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= MAX(1,N) if JOBL = 'N'; C LDQ >= 1 if JOBL = 'Z'. C C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) C On entry, if FACT = 'N', the leading M-by-M upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the upper C triangular part or lower triangular part, respectively, C of the symmetric input weighting matrix R. C On entry, if FACT = 'C', the leading M-by-M upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the Cholesky C factor of the positive definite input weighting matrix R C (as produced by LAPACK routine DPOTRF). C On entry, if FACT = 'U', the leading M-by-M upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array must contain the factors of C the UdU' or LdL' factorization, respectively, of the C symmetric indefinite input weighting matrix R (as produced C by LAPACK routine DSYTRF). C If FACT = 'N', the strictly lower triangular part (if UPLO C = 'U') or strictly upper triangular part (if UPLO = 'L') C of this array is used as workspace (filled in by C symmetry). C On exit, if OUFACT = 1, and INFO = 0 (or INFO = M+1), C the leading M-by-M upper triangular part (if UPLO = 'U') C or lower triangular part (if UPLO = 'L') of this array C contains the Cholesky factor of the given input weighting C matrix. C On exit, if OUFACT = 2, and INFO = 0 (or INFO = M+1), C the leading M-by-M upper triangular part (if UPLO = 'U') C or lower triangular part (if UPLO = 'L') of this array C contains the factors of the UdU' or LdL' factorization, C respectively, of the given input weighting matrix. C On exit R is unchanged if FACT = 'C' or 'U'. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,M). C C L (input/output) DOUBLE PRECISION array, dimension (LDL,M) C On entry, if JOBL = 'N', the leading N-by-M part of this C array must contain the matrix L. C On exit, if JOBL = 'N', OUFACT = 1, and INFO = 0, the C leading N-by-M part of this array contains the matrix C -1 C L*chol(R) . C On exit, L is unchanged if OUFACT <> 1 (hence also when C FACT = 'U'). C L is not referenced if JOBL = 'Z'. C C LDL INTEGER C The leading dimension of array L. C LDL >= MAX(1,N) if JOBL = 'N'; C LDL >= 1 if JOBL = 'Z'. C C IPIV (input/output) INTEGER array, dimension (M) C On entry, if FACT = 'U', this array must contain details C of the interchanges performed and the block structure of C the d factor in the UdU' or LdL' factorization of matrix R C (as produced by LAPACK routine DSYTRF). C On exit, if OUFACT = 2, this array contains details of C the interchanges performed and the block structure of the C d factor in the UdU' or LdL' factorization of matrix R, C as produced by LAPACK routine DSYTRF. C This array is not referenced if FACT = 'C'. C C OUFACT (output) INTEGER C Information about the factorization finally used. C OUFACT = 0: no factorization of R has been used (M = 0); C OUFACT = 1: Cholesky factorization of R has been used; C OUFACT = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = 'L') C factorization of R has been used. C C G (output) DOUBLE PRECISION array, dimension (LDG,N) C If JOBG = 'G', and INFO = 0, the leading N-by-N upper C triangular part (if UPLO = 'U') or lower triangular part C (if UPLO = 'L') of this array contains the upper C triangular part (if UPLO = 'U') or lower triangular part C -1 C (if UPLO = 'L'), respectively, of the matrix G = B*R B'. C If JOBG = 'N', this array is not referenced. C C LDG INTEGER C The leading dimension of array G. C LDG >= MAX(1,N) if JOBG = 'G'; C LDG >= 1 if JOBG = 'N'. C C Workspace C C IWORK INTEGER array, dimension (M) C If FACT = 'C' or FACT = 'U', this array is not referenced. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0 or LDWORK = -1, DWORK(1) returns the C optimal value of LDWORK; if FACT = 'N' and LDWORK is set C as specified below, DWORK(2) contains the reciprocal C condition number of the given matrix R. C On exit, if LDWORK = -2 on input or INFO = -23, then C DWORK(1) returns the minimal value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 1 if FACT = 'C' or (FACT = 'U' and C JOBG = 'N' and JOBL = 'Z'); C LDWORK >= MAX(2,3*M) if FACT = 'N' and JOBG = 'N' and C JOBL = 'Z'; C LDWORK >= MAX(2,3*M,N*M) if FACT = 'N' and (JOBG = 'G' or C JOBL = 'N'); C LDWORK >= MAX(1,N*M) if FACT = 'U' and (JOBG = 'G' or C JOBL = 'N'). C For optimum performance LDWORK should be larger than 3*M, C if FACT = 'N'. C C If LDWORK = -1, an optimal workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C If LDWORK = -2, a minimal workspace query is assumed; the C routine only calculates the minimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message 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 = i: if the i-th element (1 <= i <= M) of the d factor is C exactly zero; the UdU' (or LdL') factorization has C been completed, but the block diagonal matrix d is C exactly singular; C = M+1: if the matrix R is numerically singular. C C METHOD C - - C The matrices G, and/or A and Q are evaluated using the given or C computed symmetric factorization of R. C C NUMERICAL ASPECTS C C The routine should not be used when R is ill-conditioned. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2013, C Feb. 2014, Mar. 2014, May 2014. C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, discrete-time system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER FACT, JOBG, JOBL, UPLO INTEGER INFO, LDA, LDB, LDG, LDL, LDQ, LDR, LDWORK, M, $ N, OUFACT C .. Array Arguments .. INTEGER IPIV(*), IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), G(LDG,*), $ L(LDL,*), Q(LDQ,*), R(LDR,*) C .. Local Scalars .. LOGICAL LFACTC, LFACTU, LJOBG, LJOBL, LNFACT, LUPLOU CHARACTER NT, TR, TRANS INTEGER J, WRKMIN, WRKOPT DOUBLE PRECISION EPS, RCOND, RNORM C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL DLAMCH, DLANSY, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DLASET, DPOCON, DPOTRF, DSYCON, $ DSYRK, DSYTRF, DSYTRS, DTRSM, MA02ED, MB01RB, $ XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C INFO = 0 LJOBG = LSAME( JOBG, 'G' ) LJOBL = LSAME( JOBL, 'N' ) LFACTC = LSAME( FACT, 'C' ) LFACTU = LSAME( FACT, 'U' ) LUPLOU = LSAME( UPLO, 'U' ) LNFACT = .NOT.( LFACTC .OR. LFACTU ) C C Test the input scalar arguments. C IF( .NOT.LJOBG .AND. .NOT.LSAME( JOBG, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN INFO = -2 ELSE IF( LNFACT .AND. .NOT.LSAME( FACT, 'N' ) ) THEN INFO = -3 ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.1 .OR. ( LJOBL .AND. LDA.LT.N ) ) THEN INFO = -8 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDQ.LT.1 .OR. ( LJOBL .AND. LDQ.LT.N ) ) THEN INFO = -12 ELSE IF( LDR.LT.MAX( 1, M ) ) THEN INFO = -14 ELSE IF( LDL.LT.1 .OR. ( LJOBL .AND. LDL.LT.N ) ) THEN INFO = -16 ELSE IF( LDG.LT.1 .OR. ( LJOBG .AND. LDG.LT.N ) ) THEN INFO = -20 ELSE IF( LFACTC ) THEN WRKMIN = 1 ELSE IF( LFACTU ) THEN IF( LJOBG .OR. LJOBL ) THEN WRKMIN = MAX( 1, N*M ) ELSE WRKMIN = 1 END IF ELSE IF( LJOBG .OR. LJOBL ) THEN WRKMIN = MAX( 2, 3*M, N*M ) ELSE WRKMIN = MAX( 2, 3*M ) END IF END IF IF( LDWORK.EQ.-1 ) THEN IF( LNFACT ) THEN CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, -1, INFO ) WRKOPT = MAX( WRKMIN, INT( DWORK(1) ) ) ELSE WRKOPT = WRKMIN END IF DWORK(1) = WRKOPT RETURN ELSE IF( LDWORK.EQ.-2 ) THEN DWORK(1) = WRKMIN RETURN ELSE IF( LDWORK.LT.WRKMIN ) THEN INFO = -23 DWORK(1) = WRKMIN END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB02MT', -INFO ) RETURN END IF C C Quick return if possible. C IF( M.EQ.0 ) THEN IF( LJOBG ) $ CALL DLASET( UPLO, N, N, ZERO, ZERO, G, LDG ) OUFACT = 0 DWORK(1) = WRKMIN IF( LNFACT ) $ DWORK(2) = ZERO RETURN END IF C C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 WRKOPT = 1 C IF( LNFACT ) THEN C C Set relative machine precision. C EPS = DLAMCH( 'Precision' ) C C Compute the norm of the matrix R, which is not factored. C Then save the given triangle of R in the other strict triangle C and the diagonal in the workspace, and try Cholesky C factorization. C Workspace: need M. C RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) CALL DCOPY( M, R, LDR+1, DWORK, 1 ) CALL MA02ED( UPLO, M, R, LDR ) CALL DPOTRF( UPLO, M, R, LDR, INFO ) IF( INFO.EQ.0 ) THEN C C Compute the reciprocal of the condition number of R. C Workspace: need 3*M. C CALL DPOCON( UPLO, M, R, LDR, RNORM, RCOND, DWORK, IWORK, $ INFO ) C C Return if the matrix is singular to working precision. C OUFACT = 1 IF( RCOND.LT.EPS ) THEN INFO = M + 1 DWORK(2) = RCOND RETURN END IF WRKOPT = MAX( WRKOPT, 3*M ) ELSE C C Use UdU' or LdL' factorization, first restoring the saved C triangle. C CALL DCOPY( M, DWORK, 1, R, LDR+1 ) IF( LUPLOU ) THEN CALL MA02ED( 'Lower', M, R, LDR ) ELSE CALL MA02ED( 'Upper', M, R, LDR ) END IF C C Compute the UdU' or LdL' factorization. C Workspace: need 1, C prefer M*NB. C CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) OUFACT = 2 IF( INFO.GT.0 ) THEN DWORK(2) = ZERO RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Compute the reciprocal of the condition number of R. C Workspace: need 2*M. C CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, $ IWORK, INFO ) C C Return if the matrix is singular to working precision. C IF( RCOND.LT.EPS ) THEN INFO = M + 1 DWORK(2) = RCOND RETURN END IF END IF ELSE IF( LFACTC ) THEN OUFACT = 1 ELSE OUFACT = 2 END IF C IF( N.GT.0 .AND. ( LJOBG .OR. LJOBL ) ) THEN NT = 'No transpose' TR = 'Transpose' C IF( OUFACT.EQ.1 ) THEN C C Solve positive definite linear system(s). C IF( LUPLOU ) THEN TRANS = NT ELSE TRANS = TR END IF C C Solve the system X*U = B, overwriting B with X. C CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, ONE, R, $ LDR, B, LDB ) C IF( LJOBG ) THEN C -1 C Compute the matrix G = B*R *B', multiplying X*X' in G. C CALL DSYRK( UPLO, NT, N, M, ONE, B, LDB, ZERO, G, LDG ) END IF C IF( LJOBL ) THEN C C Update matrices A and Q. C C Solve the system Y*U = L, overwriting L with Y. C CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, ONE, $ R, LDR, L, LDL ) C C Compute A <- A - X*Y'. C CALL DGEMM( NT, TR, N, N, M, -ONE, B, LDB, L, LDL, ONE, $ A, LDA ) C C Compute Q <- Q - Y*Y'. C CALL DSYRK( UPLO, NT, N, M, -ONE, L, LDL, ONE, Q, LDQ ) END IF ELSE C C Solve indefinite linear system(s). C IF( LJOBG ) THEN C C Solve the system UdU'*X = B' (or LdL'*X = B'). C Workspace: need N*M. C DO 10 J = 1, M CALL DCOPY( N, B(1,J), 1, DWORK(J), M ) 10 CONTINUE C CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) C -1 C Compute a triangle of the matrix G = B*R *B' = B*X. C CALL MB01RB( 'Left', UPLO, NT, N, M, ZERO, ONE, G, LDG, $ B, LDB, DWORK, M, INFO ) END IF C IF( LJOBL ) THEN C C Update matrices A and Q. C C Solve the system UdU'*Y = L' (or LdL'*Y = L'). C DO 20 J = 1, M CALL DCOPY( N, L(1,J), 1, DWORK(J), M ) 20 CONTINUE C CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) C C A <- A - B*Y. C CALL DGEMM( NT, NT, N, N, M, -ONE, B, LDB, DWORK, M, ONE, $ A, LDA ) C - -1 C Compute a triangle of the matrix Q = Q - L*R *L' C = Q - L*Y. C CALL MB01RB( 'Left', UPLO, NT, N, M, ONE, -ONE, Q, LDQ, $ L, LDL, DWORK, M, INFO ) END IF END IF END IF C DWORK(1) = WRKOPT IF( LNFACT ) $ DWORK(2) = RCOND C C *** Last line of SB02MT *** RETURN END control-4.1.2/src/slicot/src/PaxHeaders/AG8BYZ.f0000644000000000000000000000013215012430707016241 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AG8BYZ.f0000644000175000017500000005472715012430707017454 0ustar00lilgelilge00000000000000 SUBROUTINE AG8BYZ( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE, $ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL, $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) C C PURPOSE C C To extract from the (N+P)-by-(M+N) descriptor system pencil C C S(lambda) = ( B A - lambda*E ) C ( D C ) C C with E nonsingular and upper triangular a C (NR+PR)-by-(M+NR) "reduced" descriptor system pencil C C ( Br Ar-lambda*Er ) C Sr(lambda) = ( ) C ( Dr Cr ) C C having the same finite Smith zeros as the pencil C S(lambda) but with Dr, a PR-by-M full row rank C left upper trapezoidal matrix, and Er, an NR-by-NR C upper triangular nonsingular matrix. C C ARGUMENTS C C Mode Parameters C C FIRST LOGICAL C Specifies if AG8BYZ is called first time or it is called C for an already reduced system, with D full column rank C with the last M rows in upper triangular form: C FIRST = .TRUE., first time called; C FIRST = .FALSE., not first time called. C C Input/Output Parameters C C N (input) INTEGER C The number of rows of matrix B, the number of columns of C matrix C and the order of square matrices A and E. C N >= 0. C C M (input) INTEGER C The number of columns of matrices B and D. M >= 0. C M <= P if FIRST = .FALSE. . C C P (input) INTEGER C The number of rows of matrices C and D. P >= 0. 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) COMPLEX*16 array, dimension (LDABCD,M+N) C On entry, the leading (N+P)-by-(M+N) part of this array C must contain the compound matrix C ( B A ) , C ( D C ) C where A is an N-by-N matrix, B is an N-by-M matrix, C C is a P-by-N matrix and D is a P-by-M matrix. C If FIRST = .FALSE., then D must be a full column C rank matrix with the last M rows in upper triangular form. C On exit, the leading (NR+PR)-by-(M+NR) part of ABCD C contains the reduced compound matrix C ( Br Ar ) , C ( Dr Cr ) C where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix, C Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank C left upper trapezoidal matrix with the first PR columns C in upper triangular form. C C LDABCD INTEGER C The leading dimension of array ABCD. C LDABCD >= MAX(1,N+P). C C E (input/output) COMPLEX*16 array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the upper triangular nonsingular matrix E. C On exit, the leading NR-by-NR part contains the reduced C upper triangular nonsingular matrix Er. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). C C NR (output) INTEGER C The order of the reduced matrices Ar and Er; also the C number of rows of the reduced matrix Br and the number C of columns of the reduced matrix Cr. C If Dr is invertible, NR is also the number of finite C Smith zeros. C C PR (output) INTEGER C The rank of the resulting matrix Dr; also the number of C rows of reduced matrices Cr and Dr. C C NINFZ (output) INTEGER C Number of infinite zeros. NINFZ = 0 if FIRST = .FALSE. . C C DINFZ (output) INTEGER C The maximal multiplicity of infinite zeros. C DINFZ = 0 if FIRST = .FALSE. . C C NKRONL (output) INTEGER C The maximal dimension of left elementary Kronecker blocks. C C INFZ (output) INTEGER array, dimension (N) C INFZ(i) contains the number of infinite zeros of C degree i, where i = 1,2,...,DINFZ. C INFZ is not referenced if FIRST = .FALSE. . C C KRONL (output) INTEGER array, dimension (N+1) C KRONL(i) contains the number of left elementary Kronecker C blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL. 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 <= 0, then an implicitly computed, C default tolerance TOLDEF = (N+P)*(N+M)*EPS, is used C instead, where EPS is the machine precision C (see LAPACK Library routine DLAMCH). C NOTE that when SVLMAX > 0, the estimated ranks could be C less than those defined above (see SVLMAX). TOL <= 1. C C Workspace C C IWORK INTEGER array, dimension (M) C If FIRST = .FALSE., IWORK is not referenced. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C LDWORK >= 2*MAX(M,P), if FIRST = .TRUE.; C LDWORK >= 2*P, if FIRST = .FALSE. . C C ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal value C of LZWORK. C C LZWORK INTEGER C The length of the array ZWORK. C LZWORK >= 1, if P = 0; otherwise C LZWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 3*P ), C if FIRST = .TRUE.; C LZWORK >= MAX( 1, N+M-1, 3*P ), if FIRST = .FALSE. . C The second term is not needed if M = 0. C For optimum performance LZWORK should be larger. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK 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 subroutine is based on the reduction algorithm of [1]. C C REFERENCES C C [1] P. Misra, P. Van Dooren and A. Varga. C Computation of structural invariants of generalized C state-space systems. C Automatica, 30, pp. 1921-1936, 1994. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( (P+N)*(M+N)*N ) floating point operations. C C FURTHER COMMENTS C C The number of infinite zeros is computed as C C DINFZ C NINFZ = Sum (INFZ(i)*i) . C i=1 C Note that each infinite zero of multiplicity k corresponds to C an infinite eigenvalue of multiplicity k+1. C The multiplicities of the infinite eigenvalues can be determined C from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows: C C DINFZ C - there are PR - Sum (INFZ(i)) simple infinite eigenvalues; C i=1 C C - there are INFZ(i) infinite eigenvalues with multiplicity i+1, C for i = 1, ..., DINFZ. C C The left Kronecker indices are: C C [ 0 0 ... 0 | 1 1 ... 1 | .... | NKRONL ... NKRONL ] C |<- KRONL(1) ->|<- KRONL(2) ->| |<- KRONL(NKRONL) ->| C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. C May 1999. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Nov. 2008. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. C V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion. C V. Sima, Apr. 2011. C C KEYWORDS C C Generalized eigenvalue problem, Kronecker indices, multivariable C system, unitary transformation, structural invariant. C C ****************************************************************** C C .. Parameters .. INTEGER IMAX, IMIN PARAMETER ( IMAX = 1, IMIN = 2 ) DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) COMPLEX*16 CONE, CZERO PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), $ CZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. INTEGER DINFZ, INFO, LDABCD, LDE, LZWORK, M, N, NINFZ, $ NKRONL, NR, P, PR DOUBLE PRECISION SVLMAX, TOL LOGICAL FIRST C .. Array Arguments .. INTEGER INFZ( * ), IWORK(*), KRONL( * ) DOUBLE PRECISION DWORK( * ) COMPLEX*16 ABCD( LDABCD, * ), E( LDE, * ), ZWORK( * ) C .. Local Scalars .. LOGICAL LQUERY INTEGER I, ICOL, ILAST, IRC, IROW, ISMAX, ISMIN, ITAU, $ J, JLAST, JWORK1, JWORK2, K, MN, MN1, MNR, $ MNTAU, MP1, MPM, MUI, MUIM1, N1, NBLCKS, PN, $ RANK, RO, RO1, SIGMA, TAUI, WRKOPT DOUBLE PRECISION C, RCOND, SMAX, SMAXPR, SMIN, SMINPR, T, TOLZ, $ TT COMPLEX*16 C1, C2, S, S1, S2, TC C .. Local Arrays .. DOUBLE PRECISION SVAL(3) COMPLEX*16 DUM(1) C .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DZNRM2 EXTERNAL DLAMCH, DZNRM2, IDAMAX C .. External Subroutines .. EXTERNAL MB3OYZ, XERBLA, ZCOPY, ZLAIC1, ZLAPMT, ZLARFG, $ ZLARTG, ZLASET, ZLATZM, ZROT, ZSWAP, ZUNMQR C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, INT, MAX, MIN, SQRT C .. Executable Statements .. C C Test the input parameters. C LQUERY = ( LZWORK.EQ.-1 ) INFO = 0 PN = P + N MN = M + N MPM = MIN( P, M ) IF( N.LT.0 ) THEN INFO = -2 ELSE IF( M.LT.0 .OR. ( .NOT.FIRST .AND. M.GT.P ) ) THEN INFO = -3 ELSE IF( P.LT.0 ) THEN INFO = -4 ELSE IF( SVLMAX.LT.ZERO ) THEN INFO = -5 ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN INFO = -7 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( TOL.GT.ONE ) THEN INFO = -17 ELSE WRKOPT = MAX( 1, 3*P ) IF( P.GT.0 ) THEN IF( M.GT.0 ) THEN WRKOPT = MAX( WRKOPT, MN-1 ) IF( FIRST ) THEN WRKOPT = MAX( WRKOPT, MPM + MAX( 3*M-1, N ) ) IF( LQUERY ) THEN CALL ZUNMQR( 'Left', 'ConjTranspose', P, N, MPM, $ ABCD, LDABCD, ZWORK, ABCD, LDABCD, $ ZWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, MPM + INT( ZWORK(1) ) ) END IF END IF END IF END IF IF( LZWORK.LT.WRKOPT .AND. .NOT.LQUERY ) THEN INFO = -21 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'AG8BYZ', -INFO ) RETURN ELSE IF( LQUERY ) THEN ZWORK(1) = WRKOPT RETURN END IF C C Initialize output variables. C PR = P NR = N DINFZ = 0 NINFZ = 0 NKRONL = 0 C C Quick return if possible. C IF( P.EQ.0 ) THEN ZWORK(1) = CONE RETURN END IF IF( N.EQ.0 .AND. M.EQ.0 ) THEN PR = 0 NKRONL = 1 KRONL(1) = P ZWORK(1) = CONE RETURN END IF C TOLZ = SQRT( DLAMCH( 'Epsilon' ) ) RCOND = TOL IF( RCOND.LE.ZERO ) THEN C C Use the default tolerance in rank determination. C RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' ) END IF C C The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and C SIGMA = 0 for FIRST = .TRUE. and SIGMA = M for FIRST = .FALSE.. C The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column C rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular. C IF( FIRST ) THEN SIGMA = 0 ELSE SIGMA = M END IF RO = P - SIGMA MP1 = M + 1 MUI = 0 DUM(1) = CZERO C ITAU = 1 JWORK1 = ITAU + MPM ISMIN = 1 ISMAX = ISMIN + P JWORK2 = ISMAX + P NBLCKS = 0 WRKOPT = 1 C 10 IF( PR.EQ.0 ) GO TO 90 C C (NR+1,ICOL+1) points to the current position of matrix D. C RO1 = RO MNR = M + NR IF( M.GT.0 ) THEN C C Compress rows of D; first exploit the trapezoidal shape of the C (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D; C compress the first SIGMA columns without column pivoting: C C ( x x x x x ) ( x x x x x ) C ( x x x x x ) ( 0 x x x x ) C ( x x x x x ) - > ( 0 0 x x x ) C ( 0 x x x x ) ( 0 0 0 x x ) C ( 0 0 x x x ) ( 0 0 0 x x ) C C where SIGMA = 3 and RO = 2. C Complex workspace: need maximum M+N-1. C IROW = NR DO 20 ICOL = 1, SIGMA IROW = IROW + 1 CALL ZLARFG( RO+1, ABCD(IROW,ICOL), ABCD(IROW+1,ICOL), 1, $ TC ) CALL ZLATZM( 'L', RO+1, MNR-ICOL, ABCD(IROW+1,ICOL), 1, $ DCONJG( TC ), ABCD(IROW,ICOL+1), $ ABCD(IROW+1,ICOL+1), LDABCD, ZWORK ) CALL ZCOPY( PR-ICOL, DUM, 0, ABCD(IROW+1,ICOL), 1 ) 20 CONTINUE WRKOPT = MAX( WRKOPT, MN - 1 ) C IF( FIRST ) THEN C C Continue with Householder with column pivoting. C C ( x x x x x ) ( x x x x x ) C ( 0 x x x x ) ( 0 x x x x ) C ( 0 0 x x x ) - > ( 0 0 x x x ) C ( 0 0 0 x x ) ( 0 0 0 x x ) C ( 0 0 0 x x ) ( 0 0 0 0 0 ) C C Real workspace: need maximum 2*M; C Complex workspace: need maximum min(P,M)+3*M-1; C Integer workspace: need maximum M. C IROW = MIN( NR+SIGMA+1, PN ) ICOL = MIN( SIGMA+1, M ) CALL MB3OYZ( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, $ RCOND, SVLMAX, RANK, SVAL, IWORK, ZWORK(ITAU), $ DWORK, ZWORK(JWORK1), INFO ) WRKOPT = MAX( WRKOPT, JWORK1 + 3*M - 2 ) C C Apply the column permutations to B and part of D. C CALL ZLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL), $ LDABCD, IWORK ) C IF( RANK.GT.0 ) THEN C C Apply the Householder transformations to the submatrix C. C Complex workspace: need maximum min(P,M) + N; C prefer maximum min(P,M) + N*NB. C CALL ZUNMQR( 'Left', 'ConjTranspose', RO1, NR, RANK, $ ABCD(IROW,ICOL), LDABCD, ZWORK(ITAU), $ ABCD(IROW,MP1), LDABCD, ZWORK(JWORK1), $ LZWORK-JWORK1+1, INFO ) WRKOPT = MAX( WRKOPT, JWORK1 + INT( ZWORK(JWORK1) ) - 1 ) CALL ZLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), CZERO, $ CZERO, ABCD(MIN( IROW+1, PN ),ICOL), $ LDABCD ) RO1 = RO1 - RANK END IF END IF C C Terminate if Dr has maximal row rank. C IF( RO1.EQ.0 ) GO TO 90 C END IF C C Update SIGMA. C SIGMA = PR - RO1 C NBLCKS = NBLCKS + 1 TAUI = RO1 C C Compress the columns of current C to separate a TAUI-by-MUI C full column rank block. C IF( NR.EQ.0 ) THEN C C Finish for zero state dimension. C PR = SIGMA RANK = 0 ELSE C C Perform RQ-decomposition with row pivoting on the current C C while keeping E upper triangular. C The current C is the TAUI-by-NR matrix delimited by rows C IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD. C The rank of current C is computed in MUI. C Real workspace: need maximum 2*P; C Complex workspace: need maximum 3*P. C IRC = NR + SIGMA N1 = NR IF( TAUI.GT.1 ) THEN C C Compute norms. C DO 30 I = 1, TAUI DWORK(I) = DZNRM2( NR, ABCD(IRC+I,MP1), LDABCD ) DWORK(P+I) = DWORK(I) 30 CONTINUE END IF C RANK = 0 MNTAU = MIN( TAUI, NR ) C C ICOL and IROW will point to the current pivot position in C. C ILAST = NR + PR JLAST = M + NR IROW = ILAST ICOL = JLAST I = TAUI 40 IF( RANK.LT.MNTAU ) THEN MN1 = M + N1 C C Pivot if necessary. C IF( I.NE.1 ) THEN J = IDAMAX( I, DWORK, 1 ) IF( J.NE.I ) THEN DWORK(J) = DWORK(I) DWORK(P+J) = DWORK(P+I) CALL ZSWAP( N1, ABCD(IROW,MP1), LDABCD, $ ABCD(IRC+J,MP1), LDABCD ) END IF END IF C C Zero elements left to ABCD(IROW,ICOL). C DO 50 K = 1, N1-1 J = M + K C C Rotate columns J, J+1 to zero ABCD(IROW,J). C TC = ABCD(IROW,J+1) CALL ZLARTG( TC, ABCD(IROW,J), C, S, ABCD(IROW,J+1) ) ABCD(IROW,J) = CZERO CALL ZROT( IROW-1, ABCD(1,J+1), 1, ABCD(1,J), 1, C, S ) CALL ZROT( K+1, E(1,K+1), 1, E(1,K), 1, C, S ) C C Rotate rows K, K+1 to zero E(K+1,K). C TC = E(K,K) CALL ZLARTG( TC, E(K+1,K), C, S, E(K,K) ) E(K+1,K) = CZERO CALL ZROT( N1-K, E(K,K+1), LDE, E(K+1,K+1), LDE, C, S ) CALL ZROT( MN1, ABCD(K,1), LDABCD, ABCD(K+1,1), LDABCD, $ C, S ) 50 CONTINUE C IF( RANK.EQ.0 ) THEN C C Initialize; exit if matrix is zero (RANK = 0). C SMAX = ABS( ABCD(ILAST,JLAST) ) IF ( SMAX.EQ.ZERO ) GO TO 80 SMIN = SMAX SMAXPR = SMAX SMINPR = SMIN C1 = CONE C2 = CONE ELSE C C One step of incremental condition estimation. C Complex workspace: need maximum 3*P. C CALL ZCOPY( RANK, ABCD(IROW,ICOL+1), LDABCD, $ ZWORK(JWORK2), 1 ) CALL ZLAIC1( IMIN, RANK, ZWORK(ISMIN), SMIN, $ ZWORK(JWORK2), ABCD(IROW,ICOL), SMINPR, S1, $ C1 ) CALL ZLAIC1( IMAX, RANK, ZWORK(ISMAX), SMAX, $ ZWORK(JWORK2), ABCD(IROW,ICOL), SMAXPR, S2, $ C2 ) WRKOPT = MAX( WRKOPT, 3*P ) END IF C C Check the rank; finish the loop if rank loss occurs. C IF( SVLMAX*RCOND.LE.SMAXPR ) THEN IF( SVLMAX*RCOND.LE.SMINPR ) THEN IF( SMAXPR*RCOND.LE.SMINPR ) THEN C C Finish the loop if last row. C IF( N1.EQ.0 ) THEN RANK = RANK + 1 GO TO 80 END IF C IF( N1.GT.1 ) THEN C C Update norms. C IF( I-1.GT.1 ) THEN DO 60 J = 1, I - 1 IF( DWORK(J).NE.ZERO ) THEN T = ABS( ABCD(IRC+J,ICOL) ) / DWORK(J) T = MAX( ( ONE + T )*( ONE - T ), ZERO) TT = T*( DWORK(J)/DWORK(P+J) )**2 IF( TT.GT.TOLZ ) THEN DWORK(J) = DWORK(J)*SQRT( T ) ELSE DWORK(J) = DZNRM2( N1-1, $ ABCD(IRC+J,MP1), LDABCD ) DWORK(P+J) = DWORK(J) END IF END IF 60 CONTINUE END IF END IF C DO 70 J = 1, RANK ZWORK(ISMIN+J-1) = S1*ZWORK(ISMIN+J-1) ZWORK(ISMAX+J-1) = S2*ZWORK(ISMAX+J-1) 70 CONTINUE C ZWORK(ISMIN+RANK) = C1 ZWORK(ISMAX+RANK) = C2 SMIN = SMINPR SMAX = SMAXPR RANK = RANK + 1 ICOL = ICOL - 1 IROW = IROW - 1 N1 = N1 - 1 I = I - 1 GO TO 40 END IF END IF END IF END IF END IF C 80 CONTINUE MUI = RANK NR = NR - MUI PR = SIGMA + MUI C C Set number of left Kronecker blocks of order (i-1)-by-i. C KRONL(NBLCKS) = TAUI - MUI C C Set number of infinite divisors of order i-1. C IF( FIRST .AND. NBLCKS.GT.1 ) $ INFZ(NBLCKS-1) = MUIM1 - TAUI MUIM1 = MUI RO = MUI C C Continue reduction if rank of current C is positive. C IF( MUI.GT.0 ) $ GO TO 10 C C Determine the maximal degree of infinite zeros and C the number of infinite zeros. C 90 CONTINUE IF( FIRST ) THEN IF( MUI.EQ.0 ) THEN DINFZ = MAX( 0, NBLCKS - 1 ) ELSE DINFZ = NBLCKS INFZ(NBLCKS) = MUI END IF K = DINFZ DO 100 I = K, 1, -1 IF( INFZ(I).NE.0 ) GO TO 110 DINFZ = DINFZ - 1 100 CONTINUE 110 CONTINUE DO 120 I = 1, DINFZ NINFZ = NINFZ + INFZ(I)*I 120 CONTINUE END IF C C Determine the maximal order of left elementary Kronecker blocks. C NKRONL = NBLCKS DO 130 I = NBLCKS, 1, -1 IF( KRONL(I).NE.0 ) GO TO 140 NKRONL = NKRONL - 1 130 CONTINUE 140 CONTINUE C ZWORK(1) = WRKOPT RETURN C *** Last line of AG8BYZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02KD.f0000644000000000000000000000013215012430707016154 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02KD.f0000644000175000017500000006455215012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE MB02KD( LDBLK, TRANS, K, L, M, N, R, ALPHA, BETA, $ TC, LDTC, TR, LDTR, B, LDB, C, LDC, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To compute the matrix product C C C = alpha*op( T )*B + beta*C, C C where alpha and beta are scalars and T is a block Toeplitz matrix C specified by its first block column TC and first block row TR; C B and C are general matrices of appropriate dimensions. C C ARGUMENTS C C Mode Parameters C C LDBLK CHARACTER*1 C Specifies where the (1,1)-block of T is stored, as C follows: C = 'C': in the first block of TC; C = 'R': in the first block of TR. C C TRANS CHARACTER*1 C Specifies the form of op( T ) to be used in the matrix C multiplication as follows: C = 'N': op( T ) = T; C = 'T': op( T ) = T'; C = 'C': op( T ) = T'. C C Input/Output Parameters C C K (input) INTEGER C The number of rows in the blocks of T. K >= 0. C C L (input) INTEGER C The number of columns in the blocks of T. L >= 0. C C M (input) INTEGER C The number of blocks in the first block column of T. C M >= 0. C C N (input) INTEGER C The number of blocks in the first block row of T. N >= 0. C C R (input) INTEGER C The number of columns in B and C. R >= 0. C C ALPHA (input) DOUBLE PRECISION C The scalar alpha. When alpha is zero then TC, TR and B C are not referenced. C C BETA (input) DOUBLE PRECISION C The scalar beta. When beta is zero then C need not be set C before entry. C C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) C On entry with LDBLK = 'C', the leading M*K-by-L part of C this array must contain the first block column of T. C On entry with LDBLK = 'R', the leading (M-1)*K-by-L part C of this array must contain the 2nd to the M-th blocks of C the first block column of T. C C LDTC INTEGER C The leading dimension of the array TC. C LDTC >= MAX(1,M*K), if LDBLK = 'C'; C LDTC >= MAX(1,(M-1)*K), if LDBLK = 'R'. C C TR (input) DOUBLE PRECISION array, dimension (LDTR,k) C where k is (N-1)*L when LDBLK = 'C' and is N*L when C LDBLK = 'R'. C On entry with LDBLK = 'C', the leading K-by-(N-1)*L part C of this array must contain the 2nd to the N-th blocks of C the first block row of T. C On entry with LDBLK = 'R', the leading K-by-N*L part of C this array must contain the first block row of T. C C LDTR INTEGER C The leading dimension of the array TR. LDTR >= MAX(1,K). C C B (input) DOUBLE PRECISION array, dimension (LDB,R) C On entry with TRANS = 'N', the leading N*L-by-R part of C this array must contain the matrix B. C On entry with TRANS = 'T' or TRANS = 'C', the leading C M*K-by-R part of this array must contain the matrix B. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,N*L), if TRANS = 'N'; C LDB >= MAX(1,M*K), if TRANS = 'T' or TRANS = 'C'. C C C (input/output) DOUBLE PRECISION array, dimension (LDC,R) C On entry with TRANS = 'N', the leading M*K-by-R part of C this array must contain the matrix C. C On entry with TRANS = 'T' or TRANS = 'C', the leading C N*L-by-R part of this array must contain the matrix C. C On exit with TRANS = 'N', the leading M*K-by-R part of C this array contains the updated matrix C. C On exit with TRANS = 'T' or TRANS = 'C', the leading C N*L-by-R part of this array contains the updated matrix C. C C LDC INTEGER C The leading dimension of the array C. C LDC >= MAX(1,M*K), if TRANS = 'N'; C LDC >= MAX(1,N*L), if TRANS = 'T' or TRANS = 'C'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -19, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 1. 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 For point Toeplitz matrices or sufficiently large block Toeplitz C matrices, this algorithm uses convolution algorithms based on C the fast Hartley transforms [1]. Otherwise, TC is copied in C reversed order into the workspace such that C can be computed from C barely M matrix-by-matrix multiplications. C C REFERENCES C C [1] Van Loan, Charles. C Computational frameworks for the fast Fourier transform. C SIAM, 1992. C C NUMERICAL ASPECTS C C The algorithm requires O( (K*L+R*L+K*R)*(N+M)*log(N+M) + K*L*R ) C floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, June 2001, C March 2004, May 2011. C C KEYWORDS C C Convolution, elementary matrix operations, C fast Hartley transform, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, THOM50 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0, FOUR = 4.0D0, THOM50 = .95D3 ) C .. Scalar Arguments .. CHARACTER LDBLK, TRANS INTEGER INFO, K, L, LDB, LDC, LDTC, LDTR, LDWORK, M, N, $ R DOUBLE PRECISION ALPHA, BETA C .. Array Arguments .. DOUBLE PRECISION B(LDB,*), C(LDC,*), DWORK(*), TC(LDTC,*), $ TR(LDTR,*) C .. Local Scalars .. LOGICAL FULLC, LMULT, LQUERY, LTRAN CHARACTER*1 WGHT INTEGER DIMB, DIMC, I, ICP, ICQ, IERR, IR, J, JJ, KK, $ LEN, LL, LN, METH, MK, NL, P, P1, P2, PB, PC, $ PDW, PP, PT, Q1, Q2, R1, R2, S1, S2, SHFT, WPOS, $ WRKOPT DOUBLE PRECISION CF, COEF, PARAM, SCAL, SF, T1, T2, TH C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DG01OD, DGEMM, DLACPY, DLASET, $ DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC ATAN, COS, DBLE, MAX, MIN, SIN C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 FULLC = LSAME( LDBLK, 'C' ) LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) LMULT = ALPHA.NE.ZERO MK = M*K NL = N*L LQUERY = LDWORK.EQ.-1 C C Check the scalar input parameters. C IF ( .NOT.( FULLC .OR. LSAME( LDBLK, 'R' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( LTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN INFO = -2 ELSE IF ( K.LT.0 ) THEN INFO = -3 ELSE IF ( L.LT.0 ) THEN INFO = -4 ELSE IF ( M.LT.0 ) THEN INFO = -5 ELSE IF ( N.LT.0 ) THEN INFO = -6 ELSE IF ( R.LT.0 ) THEN INFO = -7 ELSE IF ( LMULT .AND. FULLC .AND. LDTC.LT.MAX( 1, MK ) ) THEN INFO = -11 ELSE IF ( LMULT .AND. .NOT.FULLC .AND. $ LDTC.LT.MAX( 1,( M - 1 )*K ) ) THEN INFO = -11 ELSE IF ( LMULT .AND. LDTR.LT.MAX( 1, K ) ) THEN INFO = -13 ELSE IF ( LMULT .AND. .NOT.LTRAN .AND. LDB.LT.MAX( 1, NL ) ) THEN INFO = -15 ELSE IF ( LMULT .AND. LTRAN .AND. LDB.LT.MAX( 1, MK ) ) THEN INFO = -15 ELSE IF ( .NOT.LTRAN .AND. LDC.LT.MAX( 1, MK ) ) THEN INFO = -17 ELSE IF ( LTRAN .AND. LDC.LT.MAX( 1, NL ) ) THEN INFO = -17 ELSE IF ( LDWORK.LT.1 .AND. .NOT.LQUERY ) THEN DWORK(1) = ONE INFO = -19 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02KD', -INFO ) RETURN END IF C C The parameter PARAM is the watershed between conventional C multiplication and convolution. This is of course depending C on the used computer architecture. The lower this value is set C the more likely the routine will use convolution to compute C op( T )*B. Note that if there is enough workspace available, C convolution is always used for point Toeplitz matrices. C PARAM = THOM50 C C Decide which method to choose, based on the block sizes and C the available workspace. C LEN = 1 P = 0 C 10 CONTINUE IF ( LEN.LT.M+N-1 ) THEN LEN = LEN*2 P = P + 1 GO TO 10 END IF C COEF = THREE*DBLE( M*N )*DBLE( K*L )*DBLE( R ) / $ DBLE( LEN*( K*L + L*R + K*R ) ) C IF ( FULLC ) THEN P1 = MK*L SHFT = 0 ELSE P1 = ( M - 1 )*K*L SHFT = 1 END IF IF ( K*L.EQ.1 .AND. MIN( M, N ).GT.1 ) THEN WRKOPT = LEN*( 2 + R ) - P METH = 3 ELSE IF ( ( LEN.LT.M*N ) .AND. ( COEF.GE.PARAM ) ) THEN WRKOPT = LEN*( K*L + K*R + L*R + 1 ) - P METH = 3 ELSE METH = 2 WRKOPT = P1 END IF WRKOPT = MAX( 1, WRKOPT ) C IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Scale C beforehand. C IF ( BETA.EQ.ZERO ) THEN IF ( LTRAN ) THEN CALL DLASET( 'All', NL, R, ZERO, ZERO, C, LDC ) ELSE CALL DLASET( 'All', MK, R, ZERO, ZERO, C, LDC ) END IF ELSE IF ( BETA.NE.ONE ) THEN IF ( LTRAN ) THEN C DO 20 I = 1, R CALL DSCAL( NL, BETA, C(1,I), 1 ) 20 CONTINUE C ELSE C DO 30 I = 1, R CALL DSCAL( MK, BETA, C(1,I), 1 ) 30 CONTINUE C END IF END IF C C Quick return if possible. C IF ( .NOT.LMULT .OR. MIN( MK, NL, R ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C IF ( LDWORK.LT.WRKOPT ) METH = METH - 1 IF ( LDWORK.LT.P1 ) METH = 1 C C Start computations. C IF ( METH.EQ.1 .AND. .NOT.LTRAN ) THEN C C Method 1 is the most unlucky way to multiply Toeplitz matrices C with vectors. Due to the memory restrictions it is not C possible to flip TC. C PC = 1 C DO 50 I = 1, M PT = ( I - 1 - SHFT )*K + 1 PB = 1 C DO 40 J = SHFT + 1, I CALL DGEMM( 'No Transpose', 'No Transpose', K, R, L, $ ALPHA, TC(PT,1), LDTC, B(PB,1), LDB, ONE, $ C(PC,1), LDC ) PT = PT - K PB = PB + L 40 CONTINUE C IF ( N.GT.I-SHFT ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', K, R, $ (N-I+SHFT)*L, ALPHA, TR, LDTR, B(PB,1), LDB, $ ONE, C(PC,1), LDC ) END IF PC = PC + K 50 CONTINUE C ELSE IF ( METH.EQ.1 .AND. LTRAN ) THEN C PB = 1 C DO 70 I = 1, M PT = ( I - 1 - SHFT )*K + 1 PC = 1 C DO 60 J = SHFT + 1, I CALL DGEMM( 'Transpose', 'No Transpose', L, R, K, ALPHA, $ TC(PT,1), LDTC, B(PB,1), LDB, ONE, C(PC,1), $ LDC ) PT = PT - K PC = PC + L 60 CONTINUE C IF ( N.GT.I-SHFT ) THEN CALL DGEMM( 'Transpose', 'No Transpose', (N-I+SHFT)*L, $ R, K, ALPHA, TR, LDTR, B(PB,1), LDB, ONE, $ C(PC,1), LDC ) END IF PB = PB + K 70 CONTINUE C ELSE IF ( METH.EQ.2 .AND. .NOT.LTRAN ) THEN C C In method 2 TC is flipped resulting in less calls to the BLAS C routine DGEMM. Actually this seems often to be the best way to C multiply with Toeplitz matrices except the point Toeplitz C case. C PT = ( M - 1 - SHFT )*K + 1 C DO 80 I = 1, ( M - SHFT )*K*L, K*L CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) PT = PT - K 80 CONTINUE C PT = ( M - 1 )*K*L + 1 PC = 1 C DO 90 I = 1, M CALL DGEMM( 'No Transpose', 'No Transpose', K, R, $ MIN( I-SHFT, N )*L, ALPHA, DWORK(PT), K, B, LDB, $ ONE, C(PC,1), LDC ) IF ( N.GT.I-SHFT ) THEN CALL DGEMM( 'No Transpose', 'No Transpose', K, R, $ (N-I+SHFT)*L, ALPHA, TR, LDTR, $ B((I-SHFT)*L+1,1), LDB, ONE, C(PC,1), LDC ) END IF PC = PC + K PT = PT - K*L 90 CONTINUE C ELSE IF ( METH.EQ.2 .AND. LTRAN ) THEN C PT = ( M - 1 - SHFT )*K + 1 C DO 100 I = 1, ( M - SHFT )*K*L, K*L CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) PT = PT - K 100 CONTINUE C PT = ( M - 1 )*K*L + 1 PB = 1 C DO 110 I = 1, M CALL DGEMM( 'Tranpose', 'No Transpose', MIN( I-SHFT, N )*L, $ R, K, ALPHA, DWORK(PT), K, B(PB,1), LDB, ONE, $ C, LDC ) IF ( N.GT.I-SHFT ) THEN CALL DGEMM( 'Transpose', 'No Transpose', (N-I+SHFT)*L, R, $ K, ALPHA, TR, LDTR, B(PB,1), LDB, ONE, $ C((I-SHFT)*L+1,1), LDC ) END IF PB = PB + K PT = PT - K*L 110 CONTINUE C ELSE IF ( METH.EQ.3 ) THEN C C In method 3 the matrix-vector product is computed by a suitable C block convolution via fast Hartley transforms similar to the C SLICOT routine DE01PD. C C Step 1: Copy input data into the workspace arrays. C PDW = 1 IF ( LTRAN ) THEN DIMB = K DIMC = L ELSE DIMB = L DIMC = K END IF PB = LEN*K*L PC = LEN*( K*L + DIMB*R ) IF ( LTRAN ) THEN IF ( FULLC ) THEN CALL DLACPY( 'All', K, L, TC, LDTC, DWORK, LEN*K ) END IF C DO 120 I = 1, N - 1 + SHFT CALL DLACPY( 'All', K, L, TR(1,(I-1)*L+1), LDTR, $ DWORK((I-SHFT)*K+1), LEN*K ) 120 CONTINUE C PDW = N*K + 1 R1 = ( LEN - M - N + 1 )*K CALL DLASET( 'All', R1, L, ZERO, ZERO, DWORK(PDW), LEN*K ) PDW = PDW + R1 C DO 130 I = ( M - 1 - SHFT )*K + 1, K - SHFT*K + 1, -K CALL DLACPY( 'All', K, L, TC(I,1), LDTC, $ DWORK(PDW), LEN*K ) PDW = PDW + K 130 CONTINUE C PDW = PB + 1 CALL DLACPY( 'All', MK, R, B, LDB, DWORK(PDW), LEN*K ) PDW = PDW + MK CALL DLASET( 'All', (LEN-M)*K, R, ZERO, ZERO, DWORK(PDW), $ LEN*K ) ELSE IF ( .NOT.FULLC ) THEN CALL DLACPY( 'All', K, L, TR, LDTR, DWORK, LEN*K ) END IF CALL DLACPY( 'All', (M-SHFT)*K, L, TC, LDTC, $ DWORK(SHFT*K+1), LEN*K ) PDW = MK + 1 R1 = ( LEN - M - N + 1 )*K CALL DLASET( 'All', R1, L, ZERO, ZERO, DWORK(PDW), LEN*K ) PDW = PDW + R1 C DO 140 I = ( N - 2 + SHFT )*L + 1, SHFT*L + 1, -L CALL DLACPY( 'All', K, L, TR(1,I), LDTR, DWORK(PDW), $ LEN*K ) PDW = PDW + K 140 CONTINUE C PDW = PB + 1 CALL DLACPY( 'All', NL, R, B, LDB, DWORK(PDW), LEN*L ) PDW = PDW + NL CALL DLASET( 'All', (LEN-N)*L, R, ZERO, ZERO, DWORK(PDW), $ LEN*L ) END IF C C Take point Toeplitz matrices into extra consideration. C IF ( K*L.EQ.1 ) THEN WGHT = 'N' CALL DG01OD( 'OutputScrambled', WGHT, LEN, DWORK, $ DWORK(PC+1), IERR ) C DO 170 I = PB, PB + LEN*R - 1, LEN CALL DG01OD( 'OutputScrambled', WGHT, LEN, DWORK(I+1), $ DWORK(PC+1), IERR ) SCAL = ALPHA / DBLE( LEN ) DWORK(I+1) = SCAL*DWORK(I+1)*DWORK(1) DWORK(I+2) = SCAL*DWORK(I+2)*DWORK(2) SCAL = SCAL / TWO C LN = 1 C DO 160 LL = 1, P - 1 LN = 2*LN R1 = 2*LN C DO 150 P1 = LN + 1, LN + LN/2 T1 = DWORK(P1) + DWORK(R1) T2 = DWORK(P1) - DWORK(R1) TH = T2*DWORK(I+P1) DWORK(I+P1) = SCAL*( T1*DWORK(I+P1) $ + T2*DWORK(I+R1) ) DWORK(I+R1) = SCAL*( T1*DWORK(I+R1) - TH ) R1 = R1 - 1 150 CONTINUE C 160 CONTINUE C CALL DG01OD( 'InputScrambled', WGHT, LEN, DWORK(I+1), $ DWORK(PC+1), IERR ) 170 CONTINUE C PC = PB GOTO 420 END IF C C Step 2: Compute the weights for the Hartley transforms. C PDW = PC R1 = 1 LN = 1 TH = FOUR*ATAN( ONE ) / DBLE( LEN ) C DO 190 LL = 1, P - 2 LN = 2*LN TH = TWO*TH CF = COS( TH ) SF = SIN( TH ) DWORK(PDW+R1) = CF DWORK(PDW+R1+1) = SF R1 = R1 + 2 C DO 180 I = 1, LN-2, 2 DWORK(PDW+R1) = CF*DWORK(PDW+I) - SF*DWORK(PDW+I+1) DWORK(PDW+R1+1) = SF*DWORK(PDW+I) + CF*DWORK(PDW+I+1) R1 = R1 + 2 180 CONTINUE C 190 CONTINUE C P1 = 3 Q1 = R1 - 2 C DO 210 LL = P - 2, 1, -1 C DO 200 I = P1, Q1, 4 DWORK(PDW+R1) = DWORK(PDW+I) DWORK(PDW+R1+1) = DWORK(PDW+I+1) R1 = R1 + 2 200 CONTINUE C P1 = Q1 + 4 Q1 = R1 - 2 210 CONTINUE C C Step 3: Compute the Hartley transforms with scrambled output. C J = 0 KK = K C C WHILE J < (L*LEN*K + R*LEN*DIMB), C 220 CONTINUE C LN = LEN WPOS = PDW+1 C DO 270 PP = P - 1, 1, -1 LN = LN / 2 P2 = 1 Q2 = LN*KK + 1 R2 = ( LN/2 )*KK + 1 S2 = R2 + Q2 - 1 C DO 260 I = 0, LEN/( 2*LN ) - 1 C DO 230 IR = 0, KK - 1 T1 = DWORK(Q2+IR+J) DWORK(Q2+IR+J) = DWORK(P2+IR+J) - T1 DWORK(P2+IR+J) = DWORK(P2+IR+J) + T1 T1 = DWORK(S2+IR+J) DWORK(S2+IR+J) = DWORK(R2+IR+J) - T1 DWORK(R2+IR+J) = DWORK(R2+IR+J) + T1 230 CONTINUE C P1 = P2 + KK Q1 = P1 + LN*KK R1 = Q1 - 2*KK S1 = R1 + LN*KK C DO 250 JJ = WPOS, WPOS + LN - 3, 2 CF = DWORK(JJ) SF = DWORK(JJ+1) C DO 240 IR = 0, KK-1 T1 = DWORK(P1+IR+J) - DWORK(Q1+IR+J) T2 = DWORK(R1+IR+J) - DWORK(S1+IR+J) DWORK(P1+IR+J) = DWORK(P1+IR+J) + $ DWORK(Q1+IR+J) DWORK(R1+IR+J) = DWORK(R1+IR+J) + $ DWORK(S1+IR+J) DWORK(Q1+IR+J) = CF*T1 + SF*T2 DWORK(S1+IR+J) = -CF*T2 + SF*T1 240 CONTINUE C P1 = P1 + KK Q1 = Q1 + KK R1 = R1 - KK S1 = S1 - KK 250 CONTINUE C P2 = P2 + 2*KK*LN Q2 = Q2 + 2*KK*LN R2 = R2 + 2*KK*LN S2 = S2 + 2*KK*LN 260 CONTINUE C WPOS = WPOS + LN - 2 270 CONTINUE C DO 290 ICP = KK + 1, LEN*KK, 2*KK ICQ = ICP - KK C DO 280 IR = 0, KK - 1 T1 = DWORK(ICP+IR+J) DWORK(ICP+IR+J) = DWORK(ICQ+IR+J) - T1 DWORK(ICQ+IR+J) = DWORK(ICQ+IR+J) + T1 280 CONTINUE C 290 CONTINUE C J = J + LEN*KK IF ( J.EQ.L*LEN*K ) THEN KK = DIMB END IF IF ( J.LT.PC ) GOTO 220 C END WHILE 220 C C Step 4: Compute a Hadamard like product. C CALL DCOPY( LEN-P, DWORK(PDW+1), 1,DWORK(PDW+1+R*LEN*DIMC), 1 ) PDW = PDW + R*LEN*DIMC SCAL = ALPHA / DBLE( LEN ) P1 = 1 R1 = LEN*K*L + 1 S1 = R1 + LEN*DIMB*R IF ( LTRAN ) THEN KK = L LL = K ELSE KK = K LL = L END IF CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, DWORK(P1), $ LEN*K, DWORK(R1), LEN*DIMB, ZERO, DWORK(S1), $ LEN*DIMC ) P1 = P1 + K R1 = R1 + DIMB S1 = S1 + DIMC CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, DWORK(P1), $ LEN*K, DWORK(R1), LEN*DIMB, ZERO, DWORK(S1), $ LEN*DIMC ) SCAL = SCAL / TWO LN = 1 C DO 330 PP = 1, P - 1 LN = 2*LN P2 = ( 2*LN - 1 )*K + 1 R1 = PB + LN*DIMB + 1 R2 = PB + ( 2*LN - 1 )*DIMB + 1 S1 = PC + LN*DIMC + 1 S2 = PC + ( 2*LN - 1 )*DIMC + 1 C DO 320 P1 = LN*K + 1, ( LN + LN/2 )*K, K C DO 310 J = 0, LEN*K*( L - 1 ), LEN*K C DO 300 I = P1, P1 + K - 1 T1 = DWORK(P2) DWORK(P2) = DWORK(J+I) - T1 DWORK(J+I) = DWORK(J+I) + T1 P2 = P2 + 1 300 CONTINUE C P2 = P2 + ( LEN - 1 )*K 310 CONTINUE C P2 = P2 - LEN*K*L CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, $ DWORK(P1), LEN*K, DWORK(R1), LEN*DIMB, $ ZERO, DWORK(S1), LEN*DIMC ) CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, $ DWORK(P2), LEN*K, DWORK(R2), LEN*DIMB, ONE, $ DWORK(S1), LEN*DIMC ) CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, $ DWORK(P1), LEN*K, DWORK(R2), LEN*DIMB, ZERO, $ DWORK(S2), LEN*DIMC ) CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, -SCAL, $ DWORK(P2), LEN*K, DWORK(R1), LEN*DIMB, ONE, $ DWORK(S2), LEN*DIMC ) P2 = P2 - K R1 = R1 + DIMB R2 = R2 - DIMB S1 = S1 + DIMC S2 = S2 - DIMC 320 CONTINUE C 330 CONTINUE C C Step 5: Hartley transform with scrambled input. C DO 410 J = PC, PC + LEN*DIMC*R, LEN*DIMC C DO 350 ICP = DIMC + 1, LEN*DIMC, 2*DIMC ICQ = ICP - DIMC C DO 340 IR = 0, DIMC - 1 T1 = DWORK(ICP+IR+J) DWORK(ICP+IR+J) = DWORK(ICQ+IR+J) - T1 DWORK(ICQ+IR+J) = DWORK(ICQ+IR+J) + T1 340 CONTINUE C 350 CONTINUE C LN = 1 WPOS = PDW + LEN - 2*P + 1 C DO 400 PP = 1, P - 1 LN = 2*LN P2 = 1 Q2 = LN*DIMC + 1 R2 = ( LN/2 )*DIMC + 1 S2 = R2 + Q2 - 1 C DO 390 I = 0, LEN/( 2*LN ) - 1 C DO 360 IR = 0, DIMC - 1 T1 = DWORK(Q2+IR +J) DWORK(Q2+IR+J) = DWORK(P2+IR+J) - T1 DWORK(P2+IR+J) = DWORK(P2+IR+J) + T1 T1 = DWORK(S2+IR+J) DWORK(S2+IR+J) = DWORK(R2+IR+J) - T1 DWORK(R2+IR+J) = DWORK(R2+IR+J) + T1 360 CONTINUE C P1 = P2 + DIMC Q1 = P1 + LN*DIMC R1 = Q1 - 2*DIMC S1 = R1 + LN*DIMC C DO 380 JJ = WPOS, WPOS + LN - 3, 2 CF = DWORK(JJ) SF = DWORK(JJ+1) C DO 370 IR = 0, DIMC - 1 T1 = CF*DWORK(Q1+IR+J) + SF*DWORK(S1+IR+J) T2 = -CF*DWORK(S1+IR+J) + SF*DWORK(Q1+IR+J) DWORK(Q1+IR+J) = DWORK(P1+IR+J) - T1 DWORK(P1+IR+J) = DWORK(P1+IR+J) + T1 DWORK(S1+IR+J) = DWORK(R1+IR+J) - T2 DWORK(R1+IR+J) = DWORK(R1+IR+J) + T2 370 CONTINUE C P1 = P1 + DIMC Q1 = Q1 + DIMC R1 = R1 - DIMC S1 = S1 - DIMC 380 CONTINUE C P2 = P2 + 2*DIMC*LN Q2 = Q2 + 2*DIMC*LN R2 = R2 + 2*DIMC*LN S2 = S2 + 2*DIMC*LN 390 CONTINUE C WPOS = WPOS - 2*LN + 2 400 CONTINUE C 410 CONTINUE C C Step 6: Copy data from workspace to output. C 420 CONTINUE C IF ( LTRAN ) THEN I = NL ELSE I = MK END IF C DO 430 J = 0, R - 1 CALL DAXPY( I, ONE, DWORK(PC+(J*LEN*DIMC) + 1), 1, $ C(1,J+1), 1 ) 430 CONTINUE C END IF DWORK(1) = DBLE( WRKOPT ) RETURN C C *** Last line of MB02KD *** END control-4.1.2/src/slicot/src/PaxHeaders/MA01BZ.f0000644000000000000000000000013215012430707016167 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA01BZ.f0000644000175000017500000000650015012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE MA01BZ( BASE, K, S, A, INCA, ALPHA, BETA, SCAL ) C C PURPOSE C C To compute the general product of K complex scalars trying to C avoid over- and underflow. C C ARGUMENTS C C Input/Output Parameters C C BASE (input) DOUBLE PRECISION C Machine base. C C K (input) INTEGER C The number of scalars. K >= 1. C C S (input) INTEGER array, dimension (K) C The signature array. Each entry of S must be 1 or -1. C C A (input) COMPLEX*16 array, dimension (K) C Vector of complex scalars. C C INCA (input) INTEGER C Increment for the array A. INCA <> 0. C C ALPHA (output) COMPLEX*16 C ALPHA is a complex scalar with ABS(ALPHA) = 0, or C 1.0 <= ABS(ALPHA) < BASE, such that C C ALPHA / BETA * BASE**(SCAL) C C is the general product of the scalars in the array A. C C BETA (output) COMPLEX*16 C BETA is either 0.0 or 1.0. C See also the description of ALPHA. C C SCAL (output) INTEGER C Scaling factor exponent, see ALPHA. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, Dec. 2002. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Aug. 2009, SLICOT Library version of the routine ZLAPR1. C C KEYWORDS C C Computer arithmetic, overflow, underflow. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) COMPLEX*16 CONE, CZERO PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), $ CZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. INTEGER INCA, K, SCAL DOUBLE PRECISION BASE COMPLEX*16 ALPHA, BETA C .. Array Arguments .. INTEGER S(*) COMPLEX*16 A(*) C .. Local Scalars .. INTEGER I, INDA COMPLEX*16 CBASE C .. Intrinsic Functions .. INTRINSIC ABS, DCMPLX C C .. Executable Statements .. C CBASE = DCMPLX( BASE, ZERO ) ALPHA = CONE BETA = CONE SCAL = 0 INDA = 1 C DO 40 I = 1, K IF ( S(I).EQ.1 ) THEN ALPHA = ALPHA * A(INDA) ELSE IF ( A(INDA).EQ.CZERO ) THEN BETA = CZERO ELSE ALPHA = ALPHA / A(INDA) END IF END IF IF ( ABS( ALPHA ).EQ.ZERO ) THEN ALPHA = CZERO SCAL = 0 IF ( ABS( BETA ).EQ.ZERO ) $ RETURN ELSE C WHILE ( ABS( ALPHA ).LT.ONE ) DO 10 CONTINUE IF ( ABS( ALPHA ).GE.ONE ) $ GO TO 20 ALPHA = ALPHA*CBASE SCAL = SCAL - 1 GO TO 10 C END WHILE 10 C C WHILE ( ABS( ALPHA ).GE.BASE ) DO 20 CONTINUE IF ( ABS( ALPHA ).LT.BASE ) $ GO TO 30 ALPHA = ALPHA / CBASE SCAL = SCAL + 1 GO TO 20 C END WHILE 20 30 CONTINUE END IF INDA = INDA + INCA 40 CONTINUE C RETURN C *** Last line of MA01BZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03KB.f0000644000000000000000000000013215012430707016153 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03KB.f0000644000175000017500000016543615012430707017366 0ustar00lilgelilge00000000000000 SUBROUTINE MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, J1, N1, N2, $ N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To reorder the diagonal blocks of the formal matrix product C C T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1) (1) C C of length K in the generalized periodic Schur form C C [ T11_k T12_k T13_k ] C T_k = [ 0 T22_k T23_k ], k = 1, ..., K, (2) C [ 0 0 T33_k ] C C where C C - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or C NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced C infinite eigenvalues, C - the submatrices T22_k are NC-by-NC and contain core eigenvalues, C which are generically neither zero nor infinite, C - the submatrices T33_k contain dimension-induced zero C eigenvalues, C C such that pairs of adjacent diagonal blocks of sizes 1 and/or 2 in C the product (1) are swapped. C C Optionally, the transformation matrices Q_1,...,Q_K from the C reduction into generalized periodic Schur form are updated with C respect to the performed reordering. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C = 'N': do not compute any of the matrices Q_k; C = 'U': each coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the products Q1_k*Q_k are C returned, where Q_k, k = 1, ..., K, performed the C reordering; C = 'W': the computation of each Q_k is specified C individually in the array WHICHQ. C C WHICHQ INTEGER array, dimension (K) C If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k C as follows: C = 0: do not compute Q_k; C > 0: the kth coefficient of Q must contain an orthogonal C matrix Q1_k on entry, and the product Q1_k*Q_k is C returned. C This array is not referenced if COMPQ <> 'W'. C C WS LOGICAL C = .FALSE. : do not perform the strong stability tests; C = .TRUE. : perform the strong stability tests; often, C this is not needed, and omitting them can save C some computations. C C Input/Output Parameters C C K (input) INTEGER C The period of the periodic matrix sequences T and Q (the C number of factors in the matrix product). K >= 2. C (For K = 1, a standard eigenvalue reordering problem is C obtained.) C C NC (input) INTEGER C The number of core eigenvalues. 0 <= NC <= min(N). C C KSCHUR (input) INTEGER C The index for which the matrix T22_kschur is upper quasi- C triangular. C C J1 (input) INTEGER C The index of the first row and column of the first block C to swap in T22_k. C 1 <= J1 <= NC-N1-N2+1. C C N1 (input) INTEGER C The order of the first block to swap. N1 = 0, 1 or 2. C C N2 (input) INTEGER C The order of the second block to swap. N2 = 0, 1 or 2. C C N (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the formal matrix product T, C such that the k-th coefficient T_k is an N(k+1)-by-N(k) C matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix, C if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1). C C NI (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C dimensions of the factors of the matrix sequence T11_k. C N(k) >= NI(k) + NC >= 0. C C S (input) INTEGER array, dimension (K) C The leading K elements of this array must contain the C signatures (exponents) of the factors in the K-periodic C matrix sequence. Each entry in S must be either 1 or -1; C the value S(k) = -1 corresponds to using the inverse of C the factor T_k. C C T (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXT(k) the C matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1, C or at least N(k)-by-N(k+1), if S(k) = -1, in periodic C Schur form. C On exit, the matrices T_k are overwritten by the reordered C periodic Schur form. C C LDT INTEGER array, dimension (K) C The leading dimensions of the matrices T_k in the one- C dimensional array T. C LDT(k) >= max(1,N(k+1)), if S(k) = 1, C LDT(k) >= max(1,N(k)), if S(k) = -1. C C IXT INTEGER array, dimension (K) C Start indices of the matrices T_k in the one-dimensional C array T. C C Q (input/output) DOUBLE PRECISION array, dimension (*) C On entry, this array must contain at position IXQ(k) a C matrix Q_k of size at least N(k)-by-N(k), provided that C COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0. C On exit, if COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0, C Q_k is post-multiplied with the orthogonal matrix that C performed the reordering. C This array is not referenced if COMPQ = 'N'. C C LDQ INTEGER array, dimension (K) C The leading dimensions of the matrices Q_k in the one- C dimensional array Q. LDQ(k) >= 1, and C LDQ(k) >= max(1,N(k)), if COMPQ = 'U', or COMPQ = 'W' and C WHICHQ(k) > 0; C This array is not referenced if COMPQ = 'N'. C C IXQ INTEGER array, dimension (K) C Start indices of the matrices Q_k in the one-dimensional C array Q. C This array is not referenced if COMPQ = 'N'. C C Tolerances C C TOL DOUBLE PRECISION array, dimension (3) C This array contains tolerance parameters. The weak and C strong stability tests use a threshold computed by the C formula MAX( c*EPS*NRM, SMLNUM ), where c is a constant, C NRM is the Frobenius norm of the matrix formed by C concatenating K pairs of adjacent diagonal blocks of sizes C 1 and/or 2 in the T22_k submatrices from (2), which are C swapped, and EPS and SMLNUM are the machine precision and C safe minimum divided by EPS, respectively (see LAPACK C Library routine DLAMCH). The norm NRM is computed by this C routine; the other values are stored in the array TOL. C TOL(1), TOL(2), and TOL(3) contain c, EPS, and SMLNUM, C respectively. TOL(1) should normally be at least 10. C C Workspace C C IWORK INTEGER array, dimension (4*K) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= 10*K + MN, if N1 = 1, N2 = 1; C LDWORK >= 25*K + MN, if N1 = 1, N2 = 2; C LDWORK >= MAX(23*K + MN, 25*K - 12), if N1 = 2, N2 = 1; C LDWORK >= MAX(42*K + MN, 80*K - 48), if N1 = 2, N2 = 2; C where MN = MXN, if MXN > 10, and MN = 0, otherwise, with C MXN = MAX(N(k),k=1,...,K). C C If LDWORK = -1 a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C Error Indicator C C INFO INTEGER C = 0: successful exit; C < 0: if INFO = -22, then LDWORK is too small; appropriate C value for LDWORK is returned in DWORK(1); the other C arguments are not tested, for efficiency; C = 1: the swap was rejected from stability reasons; the C blocks are not swapped and T and Q are unchanged. C C METHOD C C The algorithm described in [1] is used. Both weak and strong C stability tests are performed. C C REFERENCES C C [1] Granat, R., Kagstrom, B. and Kressner, D. C Computing periodic deflating subspaces associated with a C specified set of eigenvalues. C BIT Numerical Mathematics, vol. 47, 763-791, 2007. C C NUMERICAL ASPECTS C C The implemented method is numerically backward stable. C 3 C The algorithm requires 0(K NC ) floating point operations. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Mar. 2010, an essentially new version of the PEP routine C PEP_DLAEXC, by R. Granat, Umea University, Sweden, Apr. 2008. C C REVISIONS C C V. Sima, Apr. 2010, May 2010, July 2010, Aug. 2011, June 2014. C C KEYWORDS C C Eigenvalues, QZ algorithm, periodic QZ algorithm, orthogonal C transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER COMPQ LOGICAL WS INTEGER INFO, J1, K, KSCHUR, LDWORK, N1, N2, NC C .. C .. Array Arguments .. INTEGER IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ), $ LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * ) DOUBLE PRECISION DWORK( * ), Q( * ), T( * ), TOL( * ) C .. C .. Local Scalars .. LOGICAL FILL21, FILL43, FILLIN, SPECQ, WANTQ, WANTQL INTEGER A, B, C, I, I11, I12, I21, I22, IA, IB, IC, $ II, INDF1, INDF2, INDTAU, INDTT, INDV1, INDV2, $ INDVF, INDVP1, INDXC, INDXV, IP1, IPP, IQ, IS, $ IT, IT2, ITAU1, ITAU2, ITAUF, ITAUF1, ITAUF2, $ ITAUP1, IV1P1, IV2P1, J2, J3, J4, L, LDWKE, $ LTAU, LTAU1, LTAU2, LTT, MINWRK, MN, ND, ND2, $ TAU, TAU1, TAU1P1, TAU2, TAU2P1, TT, V, V1, V2, $ VLOC, VLOC1, VLOC2, W, WE DOUBLE PRECISION DNRM, DTAU1, DTAU2, EPS, SCALOC, SMLNUM, $ STRONG, TAULOC, THRESH, TMP, TMP1, TMP2, V_1, $ V_2, V_3, W_2, W_3, X_11, X_12, X_21, X_22 C .. C .. Local Arrays .. DOUBLE PRECISION TAUS( 2 ), TEMP( 16 ), TEMPM1( 16 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLANTR, DLAPY2 EXTERNAL DLANGE, DLANTR, DLAPY2, LSAME C .. C .. External Subroutines .. EXTERNAL DAXPY, DLACPY, DLARFG, DLARFX, DLASCL, MB03KC, $ MB03KE, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MOD C .. C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked. C C Set the machine-dependent parameters. C IF( LDWORK.EQ.-1 ) THEN C C Compute the workspace size. C MN = 0 C DO 5 I = 1, K MN = MAX( MN, N( I ) ) 5 CONTINUE C IF( MN.LE.10 ) $ MN = 0 C IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN WE = K * 3 MN = K * 10 + MN ELSE IF( N1.EQ.1 .AND. N2.EQ.2 ) THEN WE = K * 7 MN = K * 25 + MN ELSE IF( N1.EQ.2 .AND. N2.EQ.1 ) THEN WE = K * 7 MN = K * 23 + MN ELSE IF( N1.EQ.2 .AND. N2.EQ.2 ) THEN WE = K * 12 MN = K * 42 + MN END IF C CALL MB03KE( .FALSE., .FALSE., -1, K, N1, N2, EPS, SMLNUM, S, $ T, T, T, SCALOC, DWORK, -1, INFO ) DWORK( 1 ) = MAX( INT( DWORK( 1 ) ) + WE, MN ) RETURN END IF C EPS = TOL( 2 ) SMLNUM = TOL( 3 ) C C Set integer pointers to correct subsequences in T22_k and check C workspace. For simplicity, below these subsequences are denoted C by T11, T22 and T12 and are not to be confused with the T11_k, C T22_k and T12_k in (2). Also set integer pointers to be used in C Sylvester solver. C J2 = J1 + N1 I11 = 0 I21 = I11 + K I12 = I21 + K I22 = I12 + K MN = 0 C DO 10 I = 1, K MN = MAX( MN, N( I ) ) IP1 = MOD( I, K ) + 1 IF( S( I ).EQ.1 ) THEN II = IXT( I ) + NI( I )*LDT( I ) + NI( IP1 ) - 1 ELSE II = IXT( I ) + NI( IP1 )*LDT( I ) + NI( I ) - 1 END IF IWORK( I11+I ) = II + ( J1 - 1 )*LDT( I ) + J1 IWORK( I21+I ) = IWORK( I11+I ) + N1 IWORK( I12+I ) = IWORK( I11+I ) + N1*LDT( I ) IWORK( I22+I ) = IWORK( I12+I ) + N1 10 CONTINUE C IF( MN.LE.10 ) $ MN = 0 C C Divide workspace into different arrays and submatrices. C A = 1 IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN B = A + K C = B + K TAU = C + K V = TAU + K TT = V + K * 2 W = TT + K * 4 WE = TAU MN = MN + K * 10 LDWKE = K * 5 - 4 ELSE IF( N1.EQ.1 .AND. N2.EQ.2 ) THEN B = A + K C = B + K * 4 TAU1 = C + K * 2 V1 = TAU1 + K TAU2 = V1 + K * 2 V2 = TAU2 + K TT = V2 + K * 2 LTAU = TT + K * 9 VLOC = LTAU + K W = VLOC + K * 2 WE = TAU1 MN = MN + K * 25 LDWKE = K * 18 - 13 ELSE IF( N1.EQ.2 .AND. N2.EQ.1 ) THEN B = A + K * 4 C = B + K TAU = C + K * 2 V = TAU + K TT = V + K * 3 LTAU = TT + K * 9 VLOC = LTAU + K W = VLOC + K * 2 WE = TAU MN = MN + K * 23 LDWKE = K * 18 - 13 ELSE IF( N1.EQ.2 .AND. N2.EQ.2 ) THEN B = A + K * 4 C = B + K * 4 TAU1 = C + K * 4 V1 = TAU1 + K TAU2 = V1 + K * 3 V2 = TAU2 + K TT = V2 + K * 3 LTAU1 = TT + K * 16 VLOC1 = LTAU1 + K LTAU2 = VLOC1 + K * 2 VLOC2 = LTAU2 + K W = VLOC2 + K * 2 WE = TAU1 MN = MN + K * 42 LDWKE = K * 68 - 49 END IF C MINWRK = MAX( LDWKE + WE, MN ) C C Quick return if possible. C IF( LDWORK.LT.MINWRK ) THEN DWORK( 1 ) = DBLE( MINWRK ) INFO = -22 CALL XERBLA( 'MB03KB', -INFO ) RETURN ELSE IF( NC.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 .OR. N1.GT.NC .OR. $ J2.GT.NC .OR. J2 + N2 - 1.GT.NC ) THEN RETURN END IF C C Decode the input parameters C INFO = 0 WANTQ = LSAME( COMPQ, 'U' ) SPECQ = LSAME( COMPQ, 'W' ) C C Compute some local indices. C J2 = J1 + 1 J3 = J1 + 2 J4 = J1 + 3 C C Solve the periodic Sylvester-like equation associated with C the swap. C C Copy T11, T22 and T12 to workspace. Apply scaling to all of T22_k C for numerical stability. C IA = A IB = B IC = C ND = N1 + N2 ND2 = ND**2 C DNRM = ZERO C DO 20 I = 1, K IT = IWORK( I11+I ) IS = IWORK( I12+I ) IQ = IWORK( I22+I ) TMP = DLANTR( 'Frobenius', 'Upper', 'NonUnit', ND, ND, T( IT ), $ LDT( I ), DWORK ) IF( I.EQ.KSCHUR ) THEN IF( N1.EQ.2 ) $ TMP = DLAPY2( T( IT+1 ), TMP ) IF( N2.EQ.2 ) $ TMP = DLAPY2( T( IQ+1 ), TMP ) END IF DNRM = DLAPY2( DNRM, TMP ) TMP = MAX( TMP, SMLNUM ) IF( N1.EQ.1 ) THEN DWORK( IA ) = T( IT ) / TMP DWORK( IC ) = T( IS ) / TMP IF( N2.EQ.1 ) THEN DWORK( IB ) = T( IQ ) / TMP ELSE CALL DLACPY( 'All', N2, N2, T( IQ ), LDT( I ), $ DWORK( IB ), N2 ) CALL DLASCL( 'General', 0, 0, TMP, ONE, N2, N2, $ DWORK( IB ), N2, INFO ) DWORK( IC+1 ) = T( IS+LDT(I) ) / TMP END IF ELSE CALL DLACPY( 'All', N1, N1, T( IT ), LDT( I ), DWORK( IA ), $ N1 ) CALL DLASCL( 'General', 0, 0, TMP, ONE, N1, N1, DWORK( IA ), $ N1, INFO ) IF( N2.EQ.1 ) THEN DWORK( IB ) = T( IQ ) / TMP DWORK( IC ) = T( IS ) / TMP DWORK( IC+1 ) = T( IS+1 ) / TMP ELSE CALL DLACPY( 'All', N2, N2, T( IQ ), LDT( I ), $ DWORK( IB ), N2 ) CALL DLASCL( 'General', 0, 0, TMP, ONE, N2, N2, $ DWORK( IB ), N2, INFO ) CALL DLACPY( 'All', N1, N2, T( IS ), LDT( I ), $ DWORK( IC ), N1 ) CALL DLASCL( 'General', 0, 0, TMP, ONE, N1, N2, $ DWORK( IC ), N1, INFO ) END IF END IF IA = IA + N1**2 IB = IB + N2**2 IC = IC + N1*N2 20 CONTINUE C C Compute a machine-dependent threshold of the test for accepting C a swap. C THRESH = MAX( TOL( 1 )*EPS*DNRM, SMLNUM ) C C Call the periodic Sylvester-like equation solver. C Workspace: need WE - 1 + (4*K-3)*(N1*N2)**2 + K*N1*N2. C CALL MB03KE( .FALSE., .FALSE., -1, K, N1, N2, EPS, SMLNUM, S, $ DWORK( A ), DWORK( B ), DWORK( C ), SCALOC, $ DWORK( WE ), LDWORK-WE+1, INFO ) C C Swap the adjacent diagonal blocks. C L = N1 + N1 + N2 - 2 GO TO ( 30, 70, 140, 210 ) L C 30 CONTINUE C C Direct swap with N1 = 1 and N2 = 1. C C Generate elementary reflectors H_i such that: C C H_i( X_11_i ) = ( * ). C ( scale ) ( 0 ) C INDXC = C INDXV = V C DO 40 INDTAU = TAU, TAU + K - 1 X_11 = DWORK( INDXC ) DWORK( INDXV ) = X_11 DWORK( INDXV+1 ) = SCALOC CALL DLARFG( 2, DWORK( INDXV ), DWORK( INDXV+1 ), 1, $ DWORK( INDTAU ) ) DWORK( INDXV ) = ONE C C Next, do weak stability test. C TAULOC = DWORK( INDTAU ) TMP = SCALOC * ( ONE - TAULOC ) + $ TAULOC * DWORK( INDXV+1 ) * X_11 IF( ABS( TMP ).GT.THRESH ) $ GO TO 300 INDXC = INDXC + 1 INDXV = INDXV + 2 40 CONTINUE C IF( WS ) THEN C C The swap passed weak stability test - move on and perform the C swapping temporarily into TT (workspace) and perform strong C stability test. C INDTAU = TAU INDXV = V INDTT = TT C DO 50 I = 1, K IP1 = MOD( I, K ) INDVP1 = V + IP1 * 2 ITAUP1 = TAU + IP1 CALL DLACPY( 'All', 2, 2, T( IWORK( I11+I ) ), LDT( I ), $ TEMP, 2 ) CALL DLACPY( 'All', 2, 2, TEMP, 2, DWORK( INDTT ), 2 ) IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), DWORK( INDTT ), 2, $ DWORK( W ) ) CALL DLARFX( 'Right', 2, 2, DWORK( INDXV ), $ DWORK( INDTAU ), DWORK( INDTT ), 2, $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', 2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), DWORK( INDTT ), 2, $ DWORK( W ) ) CALL DLARFX( 'Left', 2, 2, DWORK( INDXV ), $ DWORK( INDTAU ), DWORK( INDTT ), 2, $ DWORK( W ) ) END IF C CALL DLACPY( 'All', 2, 2, DWORK( INDTT ), 2, TEMPM1, 2 ) IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 2, DWORK( W ) ) CALL DLARFX( 'Right', 2, 2, DWORK( INDXV ), $ DWORK( INDTAU ), TEMPM1, 2, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 2, DWORK( W ) ) CALL DLARFX( 'Left', 2, 2, DWORK( INDXV ), $ DWORK( INDTAU ), TEMPM1, 2, DWORK( W ) ) END IF CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 ) STRONG = DLANGE( 'Frobenius', 2, 2, TEMPM1, 2, DWORK ) IF( STRONG.GT.THRESH ) $ GO TO 300 C INDTAU = INDTAU + 1 INDXV = INDXV + 2 INDTT = INDTT + 4 50 CONTINUE C END IF C C The swap was accepted - now update T and Q with respect to the C swapping. C INDTAU = TAU INDXV = V C DO 60 I = 1, K IP1 = MOD( I, K ) C C Apply Householder transformations from left or right depending C on S and accumulate transformations in matrices Q_i, i = 1:K. C INDVP1 = V + IP1 * 2 ITAUP1 = TAU + IP1 C IP1 = IP1 + 1 IT = IWORK( I11+I ) - J1 + 1 IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J2, 2, DWORK( INDXV ), $ DWORK( INDTAU ), T( IT-NI( IP1 ) ), LDT( I ), $ DWORK( W ) ) ELSE CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDXV ), $ DWORK( INDTAU ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( I )+J2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IT-NI( I ) ), LDT( I ), $ DWORK( W ) ) END IF C C Set to zero the fill-in element T(J2,J1,I). C T( IWORK( I21+I ) ) = ZERO C WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDXV ), $ DWORK( INDTAU ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF INDTAU = INDTAU + 1 INDXV = INDXV + 2 60 CONTINUE C C Exit direct swap N1 = 1 and N2 = 1. C GOTO 290 C C Direct swap with N1 = 1 and N2 = 2. C 70 CONTINUE C C Generate elementary reflectors H(1)_i and H(2)_i such that C C H(2)_i H(1)_i ( X_11_i X_12_i ) = ( * * ). C ( scale 0 ) ( 0 * ) C ( 0 scale ) ( 0 0 ) C ITAU2 = TAU2 INDXC = C INDV1 = V1 INDV2 = V2 C DO 80 ITAU1 = TAU1, TAU1 + K - 1 C C Compute elementary reflector H(1)_i. C X_11 = DWORK( INDXC ) X_12 = DWORK( INDXC+1 ) DWORK( INDV1 ) = X_11 DWORK( INDV1+1 ) = SCALOC CALL DLARFG( 2, DWORK( INDV1 ), DWORK( INDV1+1 ), 1, $ DWORK( ITAU1 ) ) DWORK( INDV1 ) = ONE C C Compute elementary reflector H(2)_i. C DWORK( INDV2 ) = X_12 DWORK( INDV2+1 ) = ZERO CALL DLARFX( 'Left', 2, 1, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDV2 ), 2, DWORK( W ) ) DWORK( INDV2 ) = DWORK( INDV2+1 ) DWORK( INDV2+1 ) = SCALOC CALL DLARFG( 2, DWORK( INDV2 ), DWORK( INDV2+1 ), 1, $ DWORK( ITAU2 ) ) DWORK( INDV2 ) = ONE C C Next, do weak stability test. C TAUS( 1 ) = DWORK( ITAU1 ) TAUS( 2 ) = DWORK( ITAU2 ) V_1 = DWORK( INDV1+1 ) TMP1 = SCALOC * ( ONE - TAUS( 1 ) ) + TAUS( 1 ) * V_1 * X_11 TMP2 = -( SCALOC * TAUS( 1 ) * V_1 + X_11 * $ ( ONE - TAUS( 1 ) * V_1**2 ) ) * ( ONE - TAUS( 2 ) ) $ + TAUS( 2 ) * DWORK( INDV2+1 ) * X_12 IF( DLAPY2( TMP1, TMP2 ).GT.THRESH ) $ GO TO 300 ITAU2 = ITAU2 + 1 INDXC = INDXC + 2 INDV1 = INDV1 + 2 INDV2 = INDV2 + 2 80 CONTINUE C C The swap passed weak stability test - move on and perform the C swapping temporarily into TT (workspace). C ITAU1 = TAU1 ITAU2 = TAU2 INDV1 = V1 INDV2 = V2 INDTT = TT LTT = 3 C DO 90 I = 1, K IP1 = MOD( I, K ) IV1P1 = V1 + IP1 * 2 IV2P1 = V2 + IP1 * 2 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ), $ DWORK( INDTT ), 3 ) C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 3, DWORK( IV1P1 ), DWORK( TAU1P1 ), $ DWORK( INDTT ), 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( IV2P1 ), DWORK( TAU2P1 ), $ DWORK( INDTT+1 ), 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDTT ), 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDV2 ), DWORK( ITAU2 ), $ DWORK( INDTT+3 ), 3, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 2, DWORK( IV1P1 ), DWORK( TAU1P1 ), $ DWORK( INDTT ), 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( IV2P1 ), DWORK( TAU2P1 ), $ DWORK( INDTT+3 ), 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDTT ), 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( INDV2 ), DWORK( ITAU2 ), $ DWORK( INDTT+1 ), 3, DWORK( W ) ) END IF ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 INDV1 = INDV1 + 2 INDV2 = INDV2 + 2 INDTT = INDTT + 9 90 CONTINUE C C Check for fill-in elements in the new 2-by-2 block. C FILLIN = .FALSE. INDTT = TT + 1 DO 100 I = 1, K IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.THRESH ) $ FILLIN = .TRUE. INDTT = INDTT + 9 100 CONTINUE C C Found fill-in elements? C IF( FILLIN ) THEN C C Restore periodic Schur form. C CALL MB03KC( K, KSCHUR, LTT, 1, S, DWORK( TT ), LTT, $ DWORK( VLOC ), DWORK( LTAU ) ) END IF C IF( WS ) THEN C C Perform strong stability test. C ITAU1 = TAU1 ITAU2 = TAU2 ITAUF = LTAU INDV1 = V1 INDV2 = V2 INDVF = VLOC INDTT = TT C DO 110 I = 1, K IP1 = MOD( I, K ) CALL DLACPY( 'All', 3, 3, DWORK( INDTT ), 3, TEMPM1, 3 ) C C Apply possible transformations from fill-in removal. C IF( FILLIN ) THEN INDVP1 = VLOC + IP1 * 2 ITAUP1 = LTAU + IP1 C C Apply on top-left 2-by-2 block. C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 3, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDVF ), $ DWORK( ITAUF ), TEMPM1, 3, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( INDVF ), $ DWORK( ITAUF ), TEMPM1, 3, DWORK( W ) ) END IF END IF C C Take the "large" transformations. C IV1P1 = V1 + IP1 * 2 IV2P1 = V2 + IP1 * 2 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 C C Apply H(1)_i+1 * H(2)_i+1 from left or right depending on S. C Apply H(2)_i * H(1)_i from right or left depending on S. C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 3, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 2 ), 3, DWORK( W ) $ ) CALL DLARFX( 'Left', 2, 3, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDV2 ), $ DWORK( ITAU2 ), TEMPM1( 4 ), 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDV1 ), $ DWORK( ITAU1 ), TEMPM1, 3, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 4 ), 3, DWORK( W ) $ ) CALL DLARFX( 'Right', 3, 2, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( INDV2 ), $ DWORK( ITAU2 ), TEMPM1( 2 ), 3, DWORK( W ) ) CALL DLARFX( 'Left', 2, 3, DWORK( INDV1 ), $ DWORK( ITAU1 ), TEMPM1, 3, DWORK( W ) ) END IF C C Compute residual norm. C CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ), $ TEMP, 3 ) CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 ) STRONG = DLANGE( 'Frobenius', 3, 3, TEMPM1, 3, DWORK ) IF( STRONG.GT.THRESH ) $ GO TO 300 C ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 ITAUF = ITAUF + 1 INDV1 = INDV1 + 2 INDV2 = INDV2 + 2 INDVF = INDVF + 2 INDTT = INDTT + 9 110 CONTINUE C END IF C C The swap was accepted - now update T and Q with respect to the C swapping. ITAU1 = TAU1 ITAU2 = TAU2 ITAUF = LTAU INDV1 = V1 INDV2 = V2 INDVF = VLOC C DO 120 I = 1, K IP1 = MOD( I, K ) IT = IWORK( I11+I ) - J1 + 1 C C Apply Householder transformations from left or right depending C on S and accumulate transformations in matrices Q_i, i = 1:K. C IV1P1 = V1 + IP1 * 2 IV2P1 = V2 + IP1 * 2 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 IP1 = IP1 + 1 C IF( S( I ).EQ.1 ) THEN IT = IT - NI( IP1 ) IT2 = IT + LDT( I ) CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IWORK( I21+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J3, 2, DWORK( INDV1 ), $ DWORK( ITAU1 ), T( IT ), LDT( I ), DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J3, 2, DWORK( INDV2 ), $ DWORK( ITAU2 ), T( IT2 ), LDT( I ), DWORK( W ) $ ) ELSE IT = IT - NI( I ) IT2 = IT + LDT( I ) CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDV1 ), $ DWORK( ITAU1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDV2 ), $ DWORK( ITAU2 ), T( IWORK( I21+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( I )+J3, 2, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IT ), LDT( I ), DWORK( W ) $ ) CALL DLARFX( 'Right', NI( I )+J3, 2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IT2 ), LDT( I ), DWORK( W ) $ ) END IF C WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDV1 ), $ DWORK( ITAU1 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) IQ = IQ + LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDV2 ), $ DWORK( ITAU2 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF C C Apply Householder transformations from fill-in removal and C accumulate transformations in matrices Q_i, i=1,...,K. C IF ( FILLIN ) THEN IV1P1 = VLOC + ( IP1 - 1 ) * 2 TAU1P1 = LTAU + ( IP1 - 1 ) C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IWORK( I11+I ) ), $ LDT( I ), DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J2, 2, DWORK( INDVF ), $ DWORK( ITAUF ), T( IT ), LDT( I ), $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', NI( I )+J2, 2, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IT ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 2, N( IP1 )-J1+1, DWORK( INDVF ), $ DWORK( ITAUF ), T( IWORK( I11+I ) ), $ LDT( I ), DWORK( W ) ) END IF C WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDVF ), $ DWORK( ITAUF ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF END IF C ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 ITAUF = ITAUF + 1 INDV1 = INDV1 + 2 INDV2 = INDV2 + 2 INDVF = INDVF + 2 120 CONTINUE C C Set to zero the fill-in elements. C DO 130 I = 1, K T( IWORK( I21+I )+1 ) = ZERO T( IWORK( I22+I )+1 ) = ZERO IF( I.NE.KSCHUR ) $ T( IWORK( I21+I ) ) = ZERO 130 CONTINUE C C Exit direct swap N1 = 1 and N2 = 2. C GOTO 290 C C Direct swap with N1 = 2 and N2 = 1. C 140 CONTINUE C C Generate elementary reflectors H_i such that: C C H_i( X_11_i ) = ( * ). C ( X_21_i ) ( 0 ) C ( scale ) ( 0 ) C INDXC = C INDXV = V C DO 150 INDTAU = TAU, TAU + K - 1 X_11 = DWORK( INDXC ) X_21 = DWORK( INDXC+1 ) DWORK( INDXV ) = X_11 DWORK( INDXV+1 ) = X_21 DWORK( INDXV+2 ) = SCALOC C CALL DLARFG( 3, DWORK( INDXV ), DWORK( INDXV+1 ), 1, $ DWORK( INDTAU ) ) DWORK( INDXV ) = ONE C C Next, do weak stability test: check that C ||H_11_i - X_i * H_21_i||_F <= tol, i = 1, ..., K. C V_2 = DWORK( INDXV+2 ) TAULOC = DWORK( INDTAU ) TMP1 = SCALOC * ( ONE - TAULOC ) + TAULOC * V_2 * X_11 TMP2 = TAULOC * ( V_2 * X_21 - SCALOC * DWORK( INDXV+1 ) ) IF( DLAPY2( TMP1, TMP2 ).GT.THRESH ) $ GO TO 300 INDXC = INDXC + 2 INDXV = INDXV + 3 150 CONTINUE C C The swap passed weak stability test - move on and perform the C swapping temporarily into TT (workspace). C INDTAU = TAU INDXV = V INDTT = TT LTT = 3 C DO 160 I = 1, K IP1 = MOD( I, K ) INDVP1 = V + IP1 * 3 ITAUP1 = TAU + IP1 CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ), $ DWORK( INDTT ), 3 ) C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 3, 3, DWORK( INDVP1 ), DWORK( ITAUP1 ), $ DWORK( INDTT ), 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 3, DWORK( INDXV ), DWORK( INDTAU ), $ DWORK( INDTT ), 3, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 3, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), DWORK( INDTT ), 3, $ DWORK( W ) ) CALL DLARFX( 'Left', 3, 3, DWORK( INDXV ), $ DWORK( INDTAU ), DWORK( INDTT ), 3, $ DWORK( W ) ) END IF INDTAU = INDTAU + 1 INDXV = INDXV + 3 INDTT = INDTT + 9 160 CONTINUE C C Check for fill-in elements. C FILLIN = .FALSE. INDTT = TT + 5 DO 170 I = 1, K IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.THRESH ) $ FILLIN = .TRUE. INDTT = INDTT + 9 170 CONTINUE C C Found fill-in elements? C IF( FILLIN ) THEN C C Restore periodic Schur form. C CALL MB03KC( K, KSCHUR, LTT, 2, S, DWORK( TT ), LTT, $ DWORK( VLOC ), DWORK( LTAU ) ) END IF C IF( WS ) THEN C C Perform strong stability test. C INDTAU = TAU INDXV = V ITAUF = LTAU INDVF = VLOC INDTT = TT C DO 180 I = 1, K IP1 = MOD( I, K ) CALL DLACPY( 'All', 3, 3, DWORK( INDTT ), 3, TEMPM1, 3 ) IF( FILLIN ) THEN INDVP1 = VLOC + IP1 * 2 ITAUP1 = LTAU + IP1 IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1( 5 ), 3, $ DWORK( W ) ) CALL DLARFX( 'Right', 3, 2, DWORK( INDVF ), $ DWORK( ITAUF ), TEMPM1( 4 ), 3, $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1( 4 ), 3, $ DWORK( W ) ) CALL DLARFX( 'Left', 2, 2, DWORK( INDVF ), $ DWORK( ITAUF ), TEMPM1( 5 ), 3, $ DWORK( W ) ) END IF END IF C INDVP1 = V + IP1 * 3 ITAUP1 = TAU + IP1 IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 3, 3, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Right', 3, 3, DWORK( INDXV ), $ DWORK( INDTAU ), TEMPM1, 3, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 3, 3, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), TEMPM1, 3, DWORK( W ) ) CALL DLARFX( 'Left', 3, 3, DWORK( INDXV ), $ DWORK( INDTAU ), TEMPM1, 3, DWORK( W ) ) END IF CALL DLACPY( 'All', 3, 3, T( IWORK( I11+I ) ), LDT( I ), $ TEMP, 3 ) CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 ) STRONG = DLANGE( 'Frobenius', 3, 3, TEMPM1, 3, DWORK ) IF( STRONG.GT.THRESH ) $ GO TO 300 C INDTAU = INDTAU + 1 INDXV = INDXV + 3 ITAUF = ITAUF + 1 INDVF = INDVF + 2 INDTT = INDTT + 9 180 CONTINUE C END IF C C The swap was accepted - now update T and Q with respect to the C swapping. C INDTAU = TAU INDXV = V ITAUF = LTAU INDVF = VLOC C DO 190 I = 1, K IP1 = MOD( I, K ) IT = IWORK( I11+I ) - J1 + 1 C C Apply Householder transformations from left or right depending C on S and accumulate transformations in matrices Q_i, i = 1:K. C INDVP1 = V + IP1 * 3 ITAUP1 = TAU + IP1 IP1 = IP1 + 1 IF( S( I ).EQ.1 ) THEN IT = IT - NI( IP1 ) CALL DLARFX( 'Left', 3, N( I )-J1+1, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J3, 3, DWORK( INDXV ), $ DWORK( INDTAU ), T( IT ), LDT( I ), DWORK( W ) $ ) ELSE IT = IT - NI( I ) CALL DLARFX( 'Left', 3, N( IP1 )-J1+1, DWORK( INDXV ), $ DWORK( INDTAU ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( I )+J3, 3, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IT ), LDT( I ), DWORK( W ) $ ) END IF WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N(I), 3, DWORK( INDXV ), $ DWORK( INDTAU ), Q( IQ ), LDQ( I ), DWORK( W ) $ ) END IF C C Apply Householder transformations from fill-in removal and C accumulate transformations in matrices Q_i, i=1,...,K. C IF ( FILLIN ) THEN INDVP1 = VLOC + ( IP1 - 1 ) * 2 ITAUP1 = LTAU + IP1 - 1 IT2 = IT + LDT( I ) IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, N( I )-J1, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IT2+J1 ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( IP1 )+J3, 2, DWORK( INDVF ), $ DWORK( ITAUF ), T( IT2 ), LDT( I ), $ DWORK( W ) ) ELSE CALL DLARFX( 'Left', 2, N( IP1 )-J1, DWORK( INDVF ), $ DWORK( ITAUF ), T( IT2+J1 ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( I )+J3, 2, DWORK( INDVP1 ), $ DWORK( ITAUP1 ), T( IT2 ), LDT( I ), $ DWORK( W ) ) END IF WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + J1*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDVF ), $ DWORK( ITAUF ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF END IF INDTAU = INDTAU + 1 INDXV = INDXV + 3 ITAUF = ITAUF + 1 INDVF = INDVF + 2 190 CONTINUE C C Set to zero the fill-in elements below the main diagonal. C DO 200 I = 1, K IT = IWORK( I11+I ) + 1 T( IT ) = ZERO T( IT+1 ) = ZERO IF( I.NE.KSCHUR ) $ T( IT+LDT( I )+1 ) = ZERO 200 CONTINUE C C Exit direct swap N1 = 2 and N2 = 1. C GOTO 290 C C Direct swap with N1 = 2 and N2 = 2. C 210 CONTINUE C C Generate elementary reflectors H(1)_i and H(2)_i such that C C H(2)_i H(1)_i ( X_11_i X_12_i ) = ( * * ). C ( X_21_i X_22_i ) ( 0 * ) C ( scale 0 ) ( 0 0 ) C ( 0 scale ) ( 0 0 ) C INDXC = C ITAU2 = TAU2 INDV1 = V1 INDV2 = V2 C DO 220 ITAU1 = TAU1, TAU1 + K - 1 X_11 = DWORK( INDXC ) X_21 = DWORK( INDXC+1 ) X_12 = DWORK( INDXC+2 ) X_22 = DWORK( INDXC+3 ) C C Compute elementary reflector H(1)_i. C DWORK( INDV1 ) = X_11 DWORK( INDV1+1 ) = X_21 DWORK( INDV1+2 ) = SCALOC CALL DLARFG( 3, DWORK( INDV1 ), DWORK( INDV1+1 ), 1, $ DWORK( ITAU1 ) ) DWORK( INDV1 ) = ONE C C Compute elementary reflector H(2)_i. C DWORK( INDV2 ) = X_12 DWORK( INDV2+1 ) = X_22 DWORK( INDV2+2 ) = ZERO CALL DLARFX( 'Left', 3, 1, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDV2 ), 3, DWORK( W ) ) DWORK( INDV2 ) = DWORK( INDV2+1 ) DWORK( INDV2+1 ) = DWORK( INDV2+2 ) DWORK( INDV2+2 ) = SCALOC CALL DLARFG( 3, DWORK( INDV2 ), DWORK( INDV2+1 ), 1, $ DWORK( ITAU2 ) ) DWORK( INDV2 ) = ONE C C Next, do weak stability test: check that C ||QQ_11_i - X_i * QQ_21_i||_F <= tol, i = 1, ...,K, C where QQ_i = H(1)_i * H(2)_i. C V_2 = DWORK( INDV1+1 ) V_3 = DWORK( INDV1+2 ) W_2 = DWORK( INDV2+1 ) W_3 = DWORK( INDV2+2 ) DTAU1 = DWORK( ITAU1 ) DTAU2 = DWORK( ITAU2 ) TEMP( 1 ) = SCALOC*( ONE - DTAU1 ) + X_11*DTAU1*V_3 TEMP( 3 ) = SCALOC*( DTAU2*W_2*DTAU1*V_3 - $ DTAU1*V_2*( ONE - DTAU2 ) ) - $ X_11*( -DTAU1*V_2*V_3*( ONE - DTAU2 ) - $ ( ONE - DTAU1*V_3**2 )*DTAU2*W_2 ) + X_12*DTAU2*W_3 TEMP( 2 ) = -SCALOC*DTAU1*V_2 + X_21*DTAU1*V_3 TEMP( 4 ) = SCALOC*( ( ONE - DTAU1*V_2**2 )*( ONE - DTAU2 ) + $ DTAU1*V_2*V_3*DTAU2*W_2 ) - $ X_21*( -DTAU1*V_2*V_3*( ONE - DTAU2 ) - $ ( ONE - DTAU1*V_3**2 )*DTAU2*W_2 ) + X_22*DTAU2*W_3 IF( DLANGE( 'Frobenius', 2, 2, TEMP, 2, DWORK ).GT.THRESH ) $ GO TO 300 INDXC = INDXC + 4 ITAU2 = ITAU2 + 1 INDV1 = INDV1 + 3 INDV2 = INDV2 + 3 220 CONTINUE C C The swap passed weak stability test - move on and perform the C swapping temporarily into TT (workspace). C ITAU1 = TAU1 ITAU2 = TAU2 INDV1 = V1 INDV2 = V2 INDTT = TT LTT = 4 C DO 230 I = 1, K IP1 = MOD( I, K ) IV1P1 = V1 + IP1 * 3 IV2P1 = V2 + IP1 * 3 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 CALL DLACPY( 'All', 4, 4, T( IWORK( I11+I ) ), LDT( I ), $ DWORK( INDTT ), 4 ) C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 3, 4, DWORK( IV1P1 ), DWORK( TAU1P1 ), $ DWORK( INDTT ), 4, DWORK( W ) ) CALL DLARFX( 'Left', 3, 4, DWORK( IV2P1 ), DWORK( TAU2P1 ), $ DWORK( INDTT+1 ), 4, DWORK( W ) ) CALL DLARFX( 'Right', 4, 3, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDTT ), 4, DWORK( W ) ) CALL DLARFX( 'Right', 4, 3, DWORK( INDV2 ), DWORK( ITAU2 ), $ DWORK( INDTT+4 ), 4, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 4, 3, DWORK( IV1P1 ), DWORK( TAU1P1 ), $ DWORK( INDTT ), 4, DWORK( W ) ) CALL DLARFX( 'Right', 4, 3, DWORK( IV2P1 ), DWORK( TAU2P1 ), $ DWORK( INDTT+4 ), 4, DWORK( W ) ) CALL DLARFX( 'Left', 3, 4, DWORK( INDV1 ), DWORK( ITAU1 ), $ DWORK( INDTT ), 4, DWORK( W ) ) CALL DLARFX( 'Left', 3, 4, DWORK( INDV2 ), DWORK( ITAU2 ), $ DWORK( INDTT+1), 4, DWORK( W ) ) END IF ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 INDV1 = INDV1 + 3 INDV2 = INDV2 + 3 INDTT = INDTT + 16 230 CONTINUE C C Check for fill-in elements. C FILLIN = .FALSE. FILL21 = .FALSE. INDTT = TT + 1 DO 240 I = 1, K IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.THRESH ) THEN FILLIN = .TRUE. FILL21 = .TRUE. END IF INDTT = INDTT + 16 240 CONTINUE C C Found fill-in elements? C IF( FILLIN ) THEN C C Restore periodic Schur form. C CALL MB03KC( K, KSCHUR, LTT, 1, S, DWORK( TT ), LTT, $ DWORK( VLOC1 ), DWORK( LTAU1 ) ) END IF C C Check for fill-in elements again. C FILLIN = .FALSE. FILL43 = .FALSE. INDTT = TT + 11 DO 250 I = 1, K IF( I.NE.KSCHUR .AND. ABS( DWORK( INDTT ) ).GT.EPS ) THEN FILLIN = .TRUE. FILL43 = .TRUE. END IF INDTT = INDTT + 16 250 CONTINUE C C Found fill-in elements? C IF( FILLIN ) THEN C C Restore periodic Schur form. C CALL MB03KC( K, KSCHUR, LTT, 3, S, DWORK( TT ), LTT, $ DWORK( VLOC2 ), DWORK( LTAU2 ) ) END IF C IF( WS ) THEN C C Perform strong stability test. C ITAU1 = TAU1 ITAU2 = TAU2 INDV1 = V1 INDV2 = V2 INDTT = TT IF( FILLIN ) THEN ITAUF1 = LTAU1 ITAUF2 = LTAU2 INDF1 = VLOC1 INDF2 = VLOC2 END IF C DO 260 I = 1, K IP1 = MOD( I, K ) CALL DLACPY( 'All', 4, 4, DWORK( INDTT ), 4, TEMPM1, 4 ) C C Apply possible transformations from fill-in removal. C IF( FILLIN ) THEN IV1P1 = VLOC1 + IP1 * 2 IV2P1 = VLOC2 + IP1 * 2 TAU1P1 = LTAU1 + IP1 TAU2P1 = LTAU2 + IP1 C C Apply on top-left 2-by-2 block. C IF( FILL21 ) THEN IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 4, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W ) $ ) CALL DLARFX( 'Right', 2, 2, DWORK( INDF1 ), $ DWORK( ITAUF1 ), TEMPM1, 4, DWORK( W ) $ ) ELSE CALL DLARFX( 'Right', 2, 2, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W ) $ ) CALL DLARFX( 'Left', 2, 4, DWORK( INDF1 ), $ DWORK( ITAUF1 ), TEMPM1, 4, DWORK( W ) $ ) END IF END IF C C Apply on down-right 2-by-2 block. C IF( FILL43 ) THEN IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, 2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 11 ), 4, $ DWORK( W ) ) CALL DLARFX( 'Right', 4, 2, DWORK( INDF2 ), $ DWORK( ITAUF2 ), TEMPM1( 9 ), 4, $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', 4, 2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 9 ), 4, $ DWORK( W ) ) CALL DLARFX( 'Left', 2, 2, DWORK( INDF2 ), $ DWORK( ITAUF2 ), TEMPM1( 11 ), 4, $ DWORK( W ) ) END IF END IF END IF C C Take the "large" transformations. C IV1P1 = V1 + IP1 * 3 IV2P1 = V2 + IP1 * 3 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 C C Apply H(2)_i+1, H(1)_i+1, H(2)_i, H(1)_i from left or right C depending on S. C IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 3, 4, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 2 ), 4, DWORK( W ) $ ) CALL DLARFX( 'Left', 3, 4, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W ) ) CALL DLARFX( 'Right', 4, 3, DWORK( INDV2 ), $ DWORK( ITAU2 ), TEMPM1( 5 ), 4, DWORK( W ) ) CALL DLARFX( 'Right', 4, 3, DWORK( INDV1 ), $ DWORK( ITAU1 ), TEMPM1, 4, DWORK( W ) ) ELSE CALL DLARFX( 'Right', 4, 3, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), TEMPM1( 5 ), 4, DWORK( W ) $ ) CALL DLARFX( 'Right', 4, 3, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), TEMPM1, 4, DWORK( W ) ) CALL DLARFX( 'Left', 3, 4, DWORK( INDV2 ), $ DWORK( ITAU2 ), TEMPM1( 2 ), 4, DWORK( W ) ) CALL DLARFX( 'Left', 3, 4, DWORK( INDV1 ), $ DWORK( ITAU1 ), TEMPM1, 4, DWORK( W ) ) END IF C C Compute residual norm. C CALL DLACPY( 'All', 4, 4, T( IWORK( I11+I ) ), LDT( I ), $ TEMP, 4 ) CALL DAXPY( ND2, -ONE, TEMP, 1, TEMPM1, 1 ) STRONG = DLANGE( 'Frobenius', 4, 4, TEMPM1, 4, DWORK ) IF( STRONG.GT.THRESH ) $ GO TO 300 C ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 INDV1 = INDV1 + 3 INDV2 = INDV2 + 3 INDTT = INDTT + 16 IF( FILLIN ) THEN ITAUF1 = ITAUF1 + 1 ITAUF2 = ITAUF2 + 1 INDF1 = INDF1 + 2 INDF2 = INDF2 + 2 END IF 260 CONTINUE C END IF C C The swap was accepted - now update T and Q with respect to the C swapping. C ITAU1 = TAU1 ITAU2 = TAU2 INDV1 = V1 INDV2 = V2 IF( FILLIN ) THEN ITAUF1 = LTAU1 ITAUF2 = LTAU2 INDF1 = VLOC1 INDF2 = VLOC2 END IF C DO 270 I = 1, K IP1 = MOD( I, K ) IPP = IP1 + 1 IT = IWORK( I11+I ) - J1 + 1 C C Apply Householder transformations from left or right depending C on S and accumulate transformations in matrices Q_i, i = 1:K. C IV1P1 = V1 + IP1 * 3 IV2P1 = V2 + IP1 * 3 TAU1P1 = TAU1 + IP1 TAU2P1 = TAU2 + IP1 C IF( S( I ).EQ.1 ) THEN IT = IT - NI( IPP ) IT2 = IT + LDT( I ) CALL DLARFX( 'Left', 3, N( I )-J1+1, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 3, N( I )-J1+1, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IWORK( I11+I )+1 ), $ LDT( I ), DWORK( W ) ) CALL DLARFX( 'Right', NI( IPP )+J4, 3, DWORK( INDV1 ), $ DWORK( ITAU1 ), T( IT ), LDT( I ), DWORK( W ) ) CALL DLARFX( 'Right', NI( IPP )+J4, 3, DWORK( INDV2 ), $ DWORK( ITAU2 ), T( IT2 ), LDT( I ), DWORK( W ) $ ) ELSE IT = IT - NI( I ) IT2 = IT + LDT( I ) CALL DLARFX( 'Right', NI( I )+J4, 3, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IT ), LDT( I ), DWORK( W ) $ ) CALL DLARFX( 'Right', NI( I )+J4, 3, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IT2 ), LDT( I ), DWORK( W ) $ ) CALL DLARFX( 'Left', 3, N( IPP )-J1+1, DWORK( INDV1 ), $ DWORK( ITAU1 ), T( IWORK( I11+I ) ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 3, N( IPP )-J1+1, DWORK( INDV2 ), $ DWORK( ITAU2 ), T( IWORK( I11+I )+1 ), $ LDT( I ), DWORK( W ) ) END IF C WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N( I ), 3, DWORK( INDV1 ), $ DWORK( ITAU1 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) IQ = IQ + LDQ( I ) CALL DLARFX( 'Right', N( I ), 3, DWORK( INDV2 ), $ DWORK( ITAU2 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF C C Apply Householder transformations from fill-in removal and C accumulate transformations. C IF ( FILLIN ) THEN IV1P1 = VLOC1 + IP1 * 2 IV2P1 = VLOC2 + IP1 * 2 TAU1P1 = LTAU1 + IP1 TAU2P1 = LTAU2 + IP1 C IF( FILL21 ) THEN IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, N( I )-J1+1, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IWORK( I11+I ) ), $ LDT( I ), DWORK( W ) ) CALL DLARFX( 'Right', NI( IPP )+J2, 2, DWORK( INDF1 ), $ DWORK( ITAUF1 ), T( IT ), LDT( I ), $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', NI( I )+J2, 2, DWORK( IV1P1 ), $ DWORK( TAU1P1 ), T( IT ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 2, N( IPP )-J1+1, DWORK( INDF1 ), $ DWORK( ITAUF1 ), T( IWORK( I11+I ) ), $ LDT( I ), DWORK( W ) ) END IF END IF C IF( FILL43 ) THEN IT = IWORK( I22+I ) IT2 = IT2 + LDT( I ) IF( S( I ).EQ.1 ) THEN CALL DLARFX( 'Left', 2, N( I )-J2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IT ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Right', NI( IPP )+J4, 2, DWORK( INDF2 ), $ DWORK( ITAUF2 ), T( IT2 ), LDT( I ), $ DWORK( W ) ) ELSE CALL DLARFX( 'Right', NI( I )+J4, 2, DWORK( IV2P1 ), $ DWORK( TAU2P1 ), T( IT2 ), LDT( I ), $ DWORK( W ) ) CALL DLARFX( 'Left', 2, N( IPP )-J2, DWORK( INDF2 ), $ DWORK( ITAUF2 ), T( IT ), LDT( I ), $ DWORK( W ) ) END IF END IF C WANTQL = WANTQ IF ( SPECQ ) $ WANTQL = WHICHQ( I ).NE.0 IF ( WANTQL ) THEN IF( FILL21 ) THEN IQ = IXQ( I ) + ( J1 - 1 )*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDF1 ), $ DWORK( ITAUF1 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF IF( FILL43 ) THEN IQ = IXQ( I ) + J2*LDQ( I ) CALL DLARFX( 'Right', N( I ), 2, DWORK( INDF2 ), $ DWORK( ITAUF2 ), Q( IQ ), LDQ( I ), $ DWORK( W ) ) END IF END IF END IF ITAU1 = ITAU1 + 1 ITAU2 = ITAU2 + 1 INDV1 = INDV1 + 3 INDV2 = INDV2 + 3 IF( FILLIN ) THEN ITAUF1 = ITAUF1 + 1 ITAUF2 = ITAUF2 + 1 INDF1 = INDF1 + 2 INDF2 = INDF2 + 2 END IF 270 CONTINUE C C Set to zero the fill-in elements below the main diagonal. C DO 280 I = 1, K IT = IWORK( I21+I ) T( IT ) = ZERO T( IT+1 ) = ZERO IT = IT + LDT( I ) T( IT ) = ZERO T( IT+1 ) = ZERO IF( I.NE.KSCHUR ) THEN T( IWORK( I11+I )+1 ) = ZERO T( IWORK( I22+I )+1 ) = ZERO END IF 280 CONTINUE C C Exit direct swap N1 = 2 and N2 = 2. C C Normal exit. C 290 CONTINUE C C Store optimal workspace values and return. C DWORK( 1 ) = DBLE( MINWRK ) RETURN C C Exit with INFO = 1 if swap was rejected. C 300 CONTINUE INFO = 1 RETURN C C *** Last line of MB03KB *** END control-4.1.2/src/slicot/src/PaxHeaders/SG02CV.f0000644000000000000000000000013215012430707016201 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SG02CV.f0000644000175000017500000004131715012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE SG02CV( DICO, JOB, JOBE, UPLO, TRANS, N, A, LDA, E, $ LDE, X, LDX, R, LDR, NORMS, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute the residual matrix R for a continuous-time or C discrete-time "reduced" Lyapunov equation, using the formulas C C R = op(A)'*X + X*op(A) + Q, C or C R = op(A)'*X*op(E) + op(E)'*X*op(A) + Q, C C in the continuous-time case, or the formulas C C R = op(A)'*X*op(A) - X + Q, C or C R = op(A)'*X*op(A) - op(E)'*X*op(E) + Q, C C in the discrete-time case, where X and Q are symmetric matrices, C A is in upper real Schur form, E is upper triangular, and op(W) is C C op(W) = W or op(W) = W'. C C Optionally, the Frobenius norms of the product terms defining the C denominator of the relative residual are also computed. The norms C of Q and X are not computed. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of the Lyapunov equation, as follows: C = 'C': continuous-time Lyapunov equation; C = 'D': discrete-time Lyapunov equation. C C JOB CHARACTER*1 C Specifies which results must be computed, as follows: C = 'R': The matrix R only must be computed; C = 'N': The matrix R and the norms must be computed; C = 'B': The matrix R and the norms must be computed. C C JOBE CHARACTER*1 C Specifies whether E is a general or an identity matrix, C as follows: C = 'G': The matrix E is general and is given; C = 'I': The matrix E is assumed identity and is not given. C C UPLO CHARACTER*1 C Specifies which triangles of the symmetric matrices X and C Q 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(W) to be used in the formulas C above, as follows: C = 'N': op(W) = W; C = 'T': op(W) = W'; C = 'C': op(W) = W'. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, E, Q, X, and R. N >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N upper part of this array must contain C the upper real Schur matrix A. C If TRANS = 'N' and (DICO = 'D' or (JOB = 'R' and C JOBE = 'G')), the entries 3, 4,..., N of the first column C are modified internally, but are restored on exit. C Otherwise, the part of this array below the first C subdiagonal is not referenced. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C E (input) DOUBLE PRECISION array, dimension (LDE,*) C If JOBE = 'G', the leading N-by-N upper triangular part of C this array must contain the upper triangular matrix E. C The strictly lower triangular part of this array is not C referenced. C If JOBE = 'I', this array is not referenced. C C LDE INTEGER C The leading dimension of array E. C LDE >= MAX(1,N), if JOBE = 'G'; C LDE >= 1, if JOBE = 'I'. C C X (input/works.) 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 If DICO = 'D' or (JOB = 'R' and JOBE = 'G'), the diagonal C elements of this array are modified internally, but they C are restored on exit. C C LDX INTEGER C The leading dimension of array X. LDX >= MAX(1,N). C C R (input/output) DOUBLE PRECISION array, dimension (LDR,*) C On entry, the leading N-by-N upper or lower triangular C part (depending on UPLO) of this array must contain the C upper or lower triangular part, respectively, of the C matrix Q. The other strictly triangular part is not C referenced. C On exit, the leading N-by-N upper or lower triangular C part (depending on UPLO) of this array contains the upper C or lower triangular part, respectively, of the matrix R. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C NORMS (output) DOUBLE PRECISION array, dimension (LN) C If JOB = 'N' or JOB = 'B', LN = 1 or 2, if (DICO = 'C' or C JOBE = 'I'), or (DICO = 'D' and JOBE = 'G'), respectively. C If DICO = 'C', C NORMS(1) contains the Frobenius norm of the matrix C op(A)'*X (or of X*op(A)), if JOBE = 'I', or of the matrix C op(A)'*X*op(E) (or of op(E)'*X*op(A)), if JOBE = 'G'. C If DICO = 'D', C NORMS(1) contains the Frobenius norm of the matrix C op(A)'*X*op(A); C if JOBE = 'G', NORMS(2) contains the Frobenius norm of the C matrix op(E)'*X*op(E). C If JOB <> 'N', this array is not referenced. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = -17 or if LDWORK = -2 on input, then C DWORK(1) returns the minimum value of LDWORK. C On exit, if INFO = 0, or if LDWORK = -1 on input, then C DWORK(1) returns the optimal value of LDWORK. C C LDWORK The length of the array DWORK. LDWORK >= MAX(v,1), with v C specified in the following table, where C a = 1, if JOBE = 'G'; C a = 0, if JOBE = 'I'. C C DICO JOB v C ---------------------------- C 'C' 'R' a*N*N C 'C' 'N','B' N*N C ---------------------------- C 'D' 'R' N*N C 'D' 'N','B' 2*N*N C ---------------------------- C C If LDWORK = -1, an optimal workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message is issued by XERBLA. C C If LDWORK = -2, a minimal workspace query is assumed; the C routine only calculates the minimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message 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 matrix expressions are efficiently evaluated, using symmetry. C If JOB = 'N' or JOB = 'B', then: C If DICO = 'C', the matrices op(op(A)'*X*op(E)) or op(X*op(A)), are C efficiently computed. C If DICO = 'D', the matrices op(A)'*X*op(A) and op(E)'*X*op(E), if C JOBE = 'G', are efficiently computed. The results are used to C evaluate R and the norms. C If JOB = 'R', then the needed parts of the intermediate results C are obtained and used to evaluate R. C C NUMERICAL ASPECTS C C The calculations are backward stable. C C The algorithm requires approximately a*N^3 operations, where ^ C denotes the power operator, and C C a = 1, if DICO = 'C' and JOB <> 'R' and JOBE = 'G'; C a = 1/2, otherwise. C C An "operation" includes a multiplication, an addition, and some C address calculations. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2019. C C REVISIONS C C V. Sima, Apr. 2019. C C KEYWORDS C C Algebraic Lyapunov equation, elementary matrix operations, matrix C algebra, matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOB, JOBE, TRANS, UPLO INTEGER INFO, LDA, LDE, LDR, LDWORK, LDX, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), DWORK(*), E(LDE,*), NORMS(*), $ R(LDR,*), X(LDX,*) C .. Local Scalars .. CHARACTER NTRANS LOGICAL DISCR, LJOBE, LJOBN, LJOBR, LTRANS, LUPLO, $ UNITE INTEGER J, MINWRK, NN, OPTWRK C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE, DLANSY EXTERNAL DLANGE, DLANSY, LSAME C .. External Subroutines .. EXTERNAL DAXPY, MB01OC, MB01OD, MB01OO, MB01OS, MB01RH, $ MB01RT, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 C DISCR = LSAME( DICO, 'D' ) LJOBN = LSAME( JOB, 'N' ) .OR. LSAME( JOB, 'B' ) LJOBR = LSAME( JOB, 'R' ) LJOBE = LSAME( JOBE, 'G' ) LUPLO = LSAME( UPLO, 'U' ) LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) UNITE = .NOT.LJOBE C IF ( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.LJOBN .AND. .NOT.LJOBR ) THEN INFO = -2 ELSE IF( UNITE .AND. .NOT.LSAME( JOBE, 'I' ) ) THEN INFO = -3 ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -4 ELSE IF( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDE.LT.1 .OR. ( LJOBE .AND. LDE.LT.N ) ) THEN INFO = -10 ELSE IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -14 ELSE NN = N*N C IF ( LJOBN ) THEN IF ( DISCR ) THEN MINWRK = 2*NN ELSE MINWRK = NN END IF ELSE IF ( .NOT.DISCR .AND. UNITE ) THEN MINWRK = 0 ELSE MINWRK = NN END IF C OPTWRK = MINWRK C IF ( LDWORK.EQ.-2 ) THEN DWORK(1) = MAX( 1, MINWRK ) RETURN ELSE IF ( LDWORK.EQ.-1 ) THEN DWORK(1) = MAX( 1, OPTWRK ) RETURN END IF C IF ( LDWORK.LT.MINWRK ) THEN INFO = -17 DWORK(1) = MAX( 1, MINWRK ) END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SG02CV', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN IF ( .NOT.LJOBR ) THEN NORMS(1) = ZERO IF ( DISCR .AND. LJOBE ) $ NORMS(2) = ZERO END IF RETURN END IF C IF ( LTRANS ) THEN NTRANS = 'NoTran' ELSE NTRANS = 'Tran' END IF C IF ( LJOBR ) THEN C C JOB = 'R'. C IF ( DISCR ) THEN C C Discrete-time case. C C Compute in R a triangle of the symmetric matrix C R = Q + A'*X*A, if TRANS = 'N'; C R = Q + A*X*A', if TRANS = 'T'. C C Workspace: N*N. C CALL MB01RH( UPLO, NTRANS, N, ONE, ONE, R, LDR, A, LDA, X, $ LDX, DWORK, LDWORK, INFO ) C IF ( UNITE ) THEN C C Subtract the triangle of X from R. C IF ( LUPLO ) THEN C DO 10 J = 1, N CALL DAXPY( J, -ONE, X(1,J), 1, R(1,J), 1 ) 10 CONTINUE C ELSE C DO 20 J = 1, N CALL DAXPY( N-J+1, -ONE, X(J,J), 1, R(J,J), 1 ) 20 CONTINUE C END IF C ELSE C C Subtract the triangle of op(E)'*X*op(E) from R. C C Workspace: N*N. C CALL MB01RT( UPLO, NTRANS, N, ONE, -ONE, R, LDR, E, LDE, $ X, LDX, DWORK, LDWORK, INFO ) END IF C ELSE C C Continuous-time case. C IF ( LJOBE ) THEN C C Compute in R a triangle of C R = op(A)'*X*op(E) + op(E)'*X*op(A) + Q. C C Workspace N*N. C CALL MB01OD( UPLO, NTRANS, N, ONE, ONE, R, LDR, A, LDA, $ X, LDX, E, LDE, DWORK, NN, INFO ) C ELSE C C Compute in R a triangle of C R = op(A)'*X + X*op(A) + Q. C CALL MB01OC( UPLO, NTRANS, N, ONE, ONE, R, LDR, A, LDA, $ X, LDX, INFO ) END IF C END IF C ELSE C C JOB = 'B' or 'N'. C IF ( DISCR ) THEN C C Discrete-time case. C IF ( LJOBE ) THEN C C Compute in DWORK a triangle of op(E)'*X*op(E) and its C norm. C C Workspace: 2*N*N. C CALL MB01RT( UPLO, NTRANS, N, ZERO, ONE, DWORK, N, E, $ LDE, X, LDX, DWORK(NN+1), LDWORK, INFO ) C NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK, N, DWORK ) C C Compute in R the triangle of Q - op(E)'*X*op(E). C IF ( LUPLO ) THEN C DO 30 J = 1, N CALL DAXPY( J, -ONE, DWORK(1+(J-1)*N), 1, R(1,J), $ 1 ) 30 CONTINUE C ELSE C DO 40 J = 1, N CALL DAXPY( N-J+1, -ONE, DWORK(J+(J-1)*N), 1, $ R(J,J), 1 ) 40 CONTINUE C END IF C ELSE C C Compute in R the triangle of Q - X. C IF ( LUPLO ) THEN C DO 50 J = 1, N CALL DAXPY( J, -ONE, X(1,J), 1, R(1,J), 1 ) 50 CONTINUE C ELSE C DO 60 J = 1, N CALL DAXPY( N-J+1, -ONE, X(J,J), 1, R(J,J), 1 ) 60 CONTINUE C END IF C END IF C C Compute in DWORK a triangle of op(A)'*X*op(A) and its norm. C C Workspace: 2*N*N. C CALL MB01RH( UPLO, NTRANS, N, ZERO, ONE, DWORK, N, A, LDA, $ X, LDX, DWORK(NN+1), NN, INFO ) C NORMS(1) = DLANSY( 'F-norm', UPLO, N, DWORK, N, DWORK ) C C Update the triangle of R := R + op(A)'*X*op(A). C IF ( LUPLO ) THEN C DO 70 J = 1, N CALL DAXPY( J, ONE, DWORK(1+(J-1)*N), 1, R(1,J), 1 ) 70 CONTINUE C ELSE C DO 80 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK(J+(J-1)*N), 1, R(J,J), $ 1 ) 80 CONTINUE C END IF C ELSE C C Continuous-time case. C IF ( LJOBE ) THEN C C Compute in DWORK C E'*X*A, if TRANS = 'N'; C A*X*E', if TRANS = 'T'. C C Workspace: N*N. C CALL MB01OO( UPLO, NTRANS, N, A, LDA, X, LDX, E, LDE, $ DWORK, N, INFO ) C ELSE C C Compute in DWORK C A*X, if TRANS = 'N'; C X*A, if TRANS = 'T'. C C Workspace: N*N. C CALL MB01OS( UPLO, NTRANS, N, A, LDA, X, LDX, DWORK, N, $ INFO ) C END IF C C Compute the norm of the product P. C NORMS(1) = DLANGE( 'F-norm', N, N, DWORK, N, DWORK ) C C Compute in R a triangle of Q + P + P'. C IF ( LUPLO ) THEN C DO 90 J = 1, N CALL DAXPY( J, ONE, DWORK(1+(J-1)*N), 1, R(1,J), 1 ) CALL DAXPY( J, ONE, DWORK(J), N, R(1,J), 1 ) 90 CONTINUE C ELSE C DO 100 J = 1, N CALL DAXPY( N-J+1, ONE, DWORK(J+(J-1)*N), 1, R(J,J), $ 1 ) CALL DAXPY( N-J+1, ONE, DWORK(J+(J-1)*N), N, R(J,J), $ 1 ) 100 CONTINUE C END IF C END IF C END IF C DWORK(1) = MAX( 1, OPTWRK ) C RETURN C *** Last line of SG02CV *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01JY.f0000644000000000000000000000013215012430707016213 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01JY.f0000644000175000017500000011540115012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE TG01JY( JOB, SYSTYP, EQUIL, CKSING, RESTOR, N, M, P, A, $ LDA, E, LDE, B, LDB, C, LDC, NR, INFRED, TOL, $ IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To find a reduced (controllable, observable, or irreducible) C descriptor representation (Ar-lambda*Er,Br,Cr) for an original C descriptor representation (A-lambda*E,B,C). C The pencil Ar-lambda*Er is in an upper block Hessenberg form, with C either Ar or Er upper triangular. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Indicates whether the user wishes to remove the C uncontrollable and/or unobservable parts as follows: C = 'I': Remove both the uncontrollable and unobservable C parts to get an irreducible descriptor C representation; C = 'C': Remove the uncontrollable part only to get a C controllable descriptor representation; C = 'O': Remove the unobservable part only to get an C observable descriptor representation. C C SYSTYP CHARACTER*1 C Indicates the type of descriptor system algorithm C to be applied according to the assumed C transfer-function matrix as follows: C = 'R': Rational transfer-function matrix; C = 'S': Proper (standard) transfer-function matrix; C = 'P': Polynomial transfer-function matrix. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily scale C the system (A-lambda*E,B,C) as follows: C = 'S': Perform scaling; C = 'N': Do not perform scaling. C C CKSING CHARACTER*1 C Specifies whether the user wishes to check if the pencil C (A-lambda*E) is singular as follows: C = 'C': Check singularity; C = 'N': Do not check singularity. C If the pencil is singular, the reduced system computed for C CKSING = 'N' can be wrong. C C RESTOR CHARACTER*1 C Specifies whether the user wishes to save the system C matrices before each phase and restore them if no order C reduction took place as follows: C = 'R': Save and restore; C = 'N': Do not save the matrices. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the descriptor state vector; also the C order of square matrices A and E, the number of rows of C matrix B, and the number of columns of matrix C. N >= 0. C C M (input) INTEGER C The dimension of descriptor system input vector; also the C number of columns of matrix B. M >= 0. C C P (input) INTEGER C The dimension of descriptor system output vector; also the C number of rows of matrix C. 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 original state matrix A. C On exit, the leading NR-by-NR part of this array contains C the reduced order state matrix Ar of an irreducible, C controllable, or observable realization for the original C system, depending on the value of JOB, JOB = 'I', C JOB = 'C', or JOB = 'O', respectively. C The matrix Ar is upper triangular if SYSTYP = 'P'. C If SYSTYP = 'S' and JOB = 'C', the matrix [Br Ar] C is in a controllable staircase form (see SLICOT Library C routine TG01HD). C If SYSTYP = 'S' and JOB = 'I' or 'O', the matrix ( Ar ) C ( Cr ) C is in an observable staircase form (see TG01HD). C The resulting Ar has INFRED(5) nonzero sub-diagonals. C The block structure of staircase forms is contained C in the leading INFRED(7) elements of IWORK. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the original descriptor matrix E. C On exit, the leading NR-by-NR part of this array contains C the reduced order descriptor matrix Er of an irreducible, C controllable, or observable realization for the original C system, depending on the value of JOB, JOB = 'I', C JOB = 'C', or JOB = 'O', respectively. C The resulting Er has INFRED(6) nonzero sub-diagonals. C If at least for one k = 1,...,4, INFRED(k) >= 0, then the C resulting Er is structured being either upper triangular C or block Hessenberg, in accordance to the last C performed order reduction phase (see METHOD). C The block structure of staircase forms is contained C in the leading INFRED(7) elements of IWORK. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), C if JOB = 'C', or (LDB,MAX(M,P)), otherwise. C On entry, the leading N-by-M part of this array must C contain the original input matrix B; if JOB = 'I', C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) C part is used as internal workspace. C On exit, the leading NR-by-M part of this array contains C the reduced input matrix Br of an irreducible, C controllable, or observable realization for the original C system, depending on the value of JOB, JOB = 'I', C JOB = 'C', or JOB = 'O', respectively. C If JOB = 'C', only the first IWORK(1) rows of B are C nonzero. 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 original output matrix C; if JOB = 'I', C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N C part is used as internal workspace. C On exit, the leading P-by-NR part of this array contains C the transformed state/output matrix Cr of an irreducible, C controllable, or observable realization for the original C system, depending on the value of JOB, JOB = 'I', C JOB = 'C', or JOB = 'O', respectively. C If JOB = 'I', or JOB = 'O', only the last IWORK(1) columns C (in the first NR columns) of C are nonzero. C C LDC INTEGER C The leading dimension of array C. C LDC >= MAX(1,M,P) if N > 0. C LDC >= 1 if N = 0. C C NR (output) INTEGER C The order of the reduced descriptor representation C (Ar-lambda*Er,Br,Cr) of an irreducible, controllable, C or observable realization for the original system, C depending on JOB = 'I', JOB = 'C', or JOB = 'O', C respectively. C C INFRED (output) INTEGER array, dimension 7 C This array contains information on performed reduction C and on structure of resulting system matrices as follows: C INFRED(k) >= 0 (k = 1, 2, 3, or 4) if Phase k of reduction C (see METHOD) has been performed. In this C case, INFRED(k) is the achieved order C reduction in Phase k. C INFRED(k) < 0 (k = 1, 2, 3, or 4) if Phase k was not C performed. C INFRED(5) - the number of nonzero sub-diagonals of A. C INFRED(6) - the number of nonzero sub-diagonals of E. C INFRED(7) - the number of blocks in the resulting C staircase form at last performed reduction C phase. The block dimensions are contained C in the first INFRED(7) elements of IWORK. C C Tolerances C C TOL DOUBLE PRECISION array, dimension 3 C TOL(1) is the tolerance to be used in rank determinations C when transforming (A-lambda*E,B,C). If the user sets C TOL(1) > 0, then the given value of TOL(1) is used as a C lower bound for reciprocal condition numbers in rank C determinations; a (sub)matrix whose estimated condition C number is less than 1/TOL(1) is considered to be of full C rank. If the user sets TOL(1) <= 0, then an implicitly C computed, default tolerance, defined by TOLDEF1 = N*N*EPS, C is used instead, where EPS is the machine precision (see C LAPACK Library routine DLAMCH). TOL(1) < 1. C TOL(2) is the tolerance to be used for checking pencil C singularity when CKSING = 'C', or singularity of the C matrices A and E when CKSING = 'N'. If the user sets C TOL(2) > 0, then the given value of TOL(2) is used. C If the user sets TOL(2) <= 0, then an implicitly C computed, default tolerance, defined by TOLDEF2 = 10*EPS, C is used instead. TOL(2) < 1. C TOL(3) is the threshold value for magnitude of the matrix C elements, if EQUIL = 'S': elements with magnitude less C than or equal to TOL(3) are ignored for scaling. If the C user sets TOL(3) >= 0, then the given value of TOL(3) is C used. If the user sets TOL(3) < 0, then an implicitly C computed, default threshold, defined by THRESH = c*EPS, C where c = MAX(norm_1(A,E,B,C)) is used instead. C TOL(3) = 0 is not always a good choice. TOL(3) < 1. C TOL(3) is not used if EQUIL = 'N'. C C Workspace C C IWORK INTEGER array, dimension (2*N+MAX(M,P)) C On exit, if INFO = 0, the leading INFRED(7) elements of C IWORK contain the orders of the diagonal blocks of C Ar-lambda*Er. 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,x,y,8*N), if EQUIL = 'S', C LDWORK >= MAX(1,x,y), if EQUIL = 'N', C where x = MAX(2*(z+MAX(M,P)+N-1),N*N+4*N), if RESTOR = 'R' C x = MAX( 2*(MAX(M,P)+N-1),N*N+4*N), if RESTOR = 'N' C y = 2*N*N+10*N+MAX(N,23), if CKSING = 'C', C y = 0, if CKSING = 'N', C z = 2*N*N+N*M+N*P, if JOB = 'I', C z = 0, if JOB <> 'I'. C For good performance, LDWORK should be generally larger. C If RESTOR = 'R', or C LDWORK >= MAX(1,2*N*N+N*M+N*P+2*(MAX(M,P)+N-1), C more accurate results are to be expected by considering C only those reductions phases (see METHOD), where effective C order reduction occurs. This is achieved by saving the C system matrices before each phase and restoring them if no C order reduction took place. Actually, if JOB = 'I' and C RESTOR = 'N', then the saved matrices are those obtained C after orthogonally triangularizing the matrix A (if C SYSTYP = 'R' or 'P'), or the matrix E (if SYSTYP = 'R' C or 'S'). 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. The optimal workspace includes the C extra space for improving the accuracy. 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 given pencil A - lambda*E is numerically C singular and the reduced system is not computed. C This error can be returned only if CKSING = 'C'. C C METHOD C C The subroutine is based on the reduction algorithms of [1], but C with a different ordering of the phases. C The order reduction is performed in 4 phases: C Phase 1: Eliminate all infinite and finite nonzero uncontrollable C eigenvalues. The resulting matrix ( Br Er ) is in a C controllable staircase form (see TG01HD), and Ar is C upper triangular. C This phase is performed if JOB = 'I' or 'C' and C SYSTYP = 'R' or 'P'. C Phase 2: Eliminate all infinite and finite nonzero unobservable C eigenvalues. The resulting matrix ( Er ) is in an C ( Cr ) C observable staircase form (see SLICOT Library routine C TG01ID), and Ar is upper triangular. C This phase is performed if JOB = 'I' or 'O' and C SYSTYP = 'R' or 'P'. C Phase 3: Eliminate all finite uncontrollable eigenvalues. C The resulting matrix ( Br Ar ) is in a controllable C staircase form (see TG01HD), and Er is upper triangular. C This phase is performed if JOB = 'I' or 'C' and C SYSTYP = 'R' or 'S'. C Phase 4: Eliminate all finite unobservable eigenvalues. C The resulting matrix ( Ar ) is in an observable C ( Cr ) C staircase form (see TG01ID), and Er is upper triangular. C This phase is performed if JOB = 'I' or 'O' and C SYSTYP = 'R' or 'S'. C The routine checks the singularity of the matrices A and/or E C (depending on JOB and SYSTYP) and skips the unnecessary phases. C See FURTHER COMMENTS. C C REFERENCES C C [1] A. Varga C Computation of Irreducible Generalized State-Space C Realizations. C Kybernetika, vol. 26, pp. 89-106, 1990. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable and requires C 0( N**3 ) floating point operations. C C FURTHER COMMENTS C C If the pencil A-lambda*E has no zero eigenvalues, then an C irreducible realization is computed skipping Phases 3 and 4 C (equivalent to setting: JOB = 'I' and SYSTYP = 'P'). C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2012. C Based on the SLICOT Library routine TG01JD by A. Varga. C C REVISIONS C C V. Sima, March 2012, April 2012, June 2012. C C KEYWORDS C C Controllability, irreducible realization, observability, C orthogonal canonical form, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO, TEN, TOLRC PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, TEN = 10.0D0, $ TOLRC = 1.0D-10 ) C .. Scalar Arguments .. CHARACTER CKSING, EQUIL, JOB, RESTOR, SYSTYP INTEGER INFO, LDA, LDB, LDC, LDE, LDWORK, M, N, NR, P C .. Array Arguments .. INTEGER INFRED(*), IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), $ E(LDE,*), TOL(*) C .. Local Scalars .. CHARACTER JOBQ, JOBZ LOGICAL FINCON, FINOBS, INFCON, INFOBS, LEQUIL, LJOBC, $ LJOBIR, LJOBO, LQUERY, LSING, LSPACE, LSYSP, $ LSYSR, LSYSS, MAXACC, SINGA, SINGE INTEGER I, J, K, KWA, KWB, KWC, KWE, KWR, LBA, LBAS, $ LBE, LBES, LDQ, LDZ, LWA, LWB, LWC, LWE, M1, $ MAXMP, MAXWRK, MINWRK, N1, NB, NBLCK, NC, NN, $ NX, P1 DOUBLE PRECISION ANORM, ENORM, RCOND, T, TL, TT, TZER C .. Local Arrays .. LOGICAL BWORK(1) DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL DELCTG, LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 EXTERNAL DELCTG, DLAMCH, DLANGE, DLAPY2, ILAENV, LSAME C .. External Subroutines .. EXTERNAL DGECON, DGEQRF, DGETRF, DGGES, DLACPY, DLARF, $ DLARFG, DLASET, DORMQR, MA02CD, TB01XD, TG01AD, $ TG01HY, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN C .. Executable Statements .. C INFO = 0 MAXMP = MAX( M, P ) N1 = MAX( 1, N ) C C Decode JOB. C LJOBIR = LSAME( JOB, 'I' ) LJOBC = LJOBIR .OR. LSAME( JOB, 'C' ) LJOBO = LJOBIR .OR. LSAME( JOB, 'O' ) C C Decode SYSTYP. C LSYSR = LSAME( SYSTYP, 'R' ) LSYSS = LSYSR .OR. LSAME( SYSTYP, 'S' ) LSYSP = LSYSR .OR. LSAME( SYSTYP, 'P' ) C LEQUIL = LSAME( EQUIL, 'S' ) C LSING = LSAME( CKSING, 'C' ) C MAXACC = LSAME( RESTOR, 'R' ) C C Test the input scalar arguments. C IF( .NOT.LJOBC .AND. .NOT.LJOBO ) THEN INFO = -1 ELSE IF( .NOT.LSYSS .AND. .NOT.LSYSP ) THEN INFO = -2 ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN INFO = -3 ELSE IF( .NOT.LSING .AND. .NOT.LSAME( CKSING, 'N' ) ) THEN INFO = -4 ELSE IF( .NOT.MAXACC .AND. .NOT.LSAME( RESTOR, 'N' ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( M.LT.0 ) THEN INFO = -7 ELSE IF( P.LT.0 ) THEN INFO = -8 ELSE IF( LDA.LT.N1 ) THEN INFO = -10 ELSE IF( LDE.LT.N1 ) THEN INFO = -12 ELSE IF( LDB.LT.N1 ) THEN INFO = -14 ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN INFO = -16 ELSE IF( TOL(1).GE.ONE ) THEN INFO = -19 ELSE IF( TOL(2).GE.ONE ) THEN INFO = -19 ELSE IF( TOL(3).GE.ONE ) THEN INFO = -19 ELSE NN = N*N K = N*( 2*N + M + P ) IF( MAXACC ) THEN MINWRK = MAX( 1, 2*( K + MAXMP + N - 1 ), NN + 4*N ) ELSE MINWRK = MAX( 1, 2*( MAXMP + N - 1 ), NN + 4*N ) END IF IF( LEQUIL ) $ MINWRK = MAX( MINWRK, 8*N ) IF( LSING ) $ MINWRK = MAX( MINWRK, 2*NN + 10*N + MAX( N, 23 ) ) C C Set controllability/observability determination options. C FINCON = LJOBC .AND. LSYSS INFCON = LJOBC .AND. LSYSP FINOBS = LJOBO .AND. LSYSS INFOBS = LJOBO .AND. LSYSP C C Set large workspace option and determine offsets. C MAXWRK = K + 2*( MAXMP + N - 1 ) LSPACE = LDWORK.GE.MAXWRK IF( LJOBIR ) $ MAXWRK = MAXWRK + K LQUERY = LDWORK.EQ.-1 MAXWRK = MAX( MAXWRK, MINWRK ) JOBQ = 'N' JOBZ = 'N' TL = TOL(1) IF( LQUERY ) THEN C C Compute optimal workspace. C IF( LSING ) THEN CALL DGGES( 'No Q', 'No Z', 'No sort', DELCTG, N, DWORK, $ N1, DWORK, N1, KWA, DWORK, DWORK, DWORK, $ DWORK, 1, DWORK, 1, DWORK, -1, BWORK, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) + 2*NN + 3*N ) END IF IF( N.GT.1 ) THEN IF( FINCON .OR. INFCON ) THEN CALL TG01HY( JOBQ, JOBZ, N, N, M, P, N, N-1, A, LDA, $ E, LDE, B, LDB, C, LDC, DUM, 1, DUM, 1, $ NR, NBLCK, IWORK, TL, IWORK, DWORK, -1, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) + K ) END IF IF( FINOBS .OR. INFOBS ) THEN CALL TG01HY( JOBQ, JOBZ, N, N, P, M, N, N-1, A, LDA, $ E, LDE, B, LDB, C, LDC, DUM, 1, DUM, 1, $ NR, NBLCK, IWORK, TL, IWORK, DWORK, -1, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) + K ) END IF END IF ELSE IF( LDWORK.LT.MINWRK ) THEN INFO = -22 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01JY', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = MAXWRK RETURN END IF C C Quick return if possible. C INFRED(1) = -1 INFRED(2) = -1 INFRED(3) = -1 INFRED(4) = -1 INFRED(5) = 0 INFRED(6) = 0 INFRED(7) = 0 C IF( MAX( N, MAXMP ).EQ.0 ) THEN NR = 0 DWORK(1) = ONE RETURN END IF C LBA = MAX( 0, N-1 ) LBE = LBA TZER = TOL(2) IF ( TL.LE.ZERO .OR. TZER.LE.ZERO .OR. LEQUIL ) THEN T = DLAMCH( 'Precision' ) IF( TL.LE.ZERO ) $ TL = NN*T IF( TZER.LE.ZERO ) $ TZER = TEN*T IF( LEQUIL ) THEN THRESH = TOL(3) IF( THRESH.LT.ZERO ) THEN ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) ENORM = DLANGE( '1-norm', N, N, E, LDE, DWORK ) THRESH = MAX( ANORM, ENORM, $ DLANGE( '1-norm', N, M, B, LDB, DWORK ), $ DLANGE( '1-norm', P, N, C, LDC, DWORK ) )*T END IF END IF END IF C C Check if A and/or E are singular. C Workspace: need N*N + 4*N. C SINGA = .FALSE. SINGE = .FALSE. C J = NN + 1 C IF( LSING .OR. FINCON .OR. FINOBS ) THEN CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N1 ) CALL DGETRF( N, N, DWORK, N1, IWORK, I ) IF( I.GT.0 ) THEN SINGA = .TRUE. ELSE IF( .NOT.LEQUIL .OR. TOL(3).GE.ZERO ) $ ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) CALL DGECON( '1-norm', N, DWORK, N1, ANORM, RCOND, $ DWORK(J), IWORK, I ) IF( RCOND.GT.TOLRC ) THEN FINCON = .FALSE. FINOBS = .FALSE. END IF IF( RCOND.LE.TZER ) $ SINGA = .TRUE. END IF C END IF C IF( LSING .OR. INFCON .OR. INFOBS ) THEN CALL DLACPY( 'Full', N, N, E, LDE, DWORK, N1 ) CALL DGETRF( N, N, DWORK, N1, IWORK, I ) IF( I.GT.0 ) THEN SINGE = .TRUE. ELSE IF( .NOT.LEQUIL .OR. TOL(3).GE.ZERO ) $ ENORM = DLANGE( '1-norm', N, N, E, LDE, DWORK ) CALL DGECON( '1-norm', N, DWORK, N1, ENORM, RCOND, $ DWORK(J), IWORK, I ) IF( RCOND.LE.TZER ) $ SINGE = .TRUE. END IF C IF( .NOT.SINGE ) THEN INFCON = .FALSE. INFOBS = .FALSE. END IF END IF C IF( LSING .AND. SINGA .AND. SINGE ) THEN C C Check pencil regularity. C Workspace: need 2*N*N + 10*N + MAX(N,23); C prefer larger. C A variation of this routine can apply the QZ algorithm directly C to A and E, and update B and C. Then, the reduction can be done C on the transformed system. C K = J + NN CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N1 ) CALL DLACPY( 'Full', N, N, E, LDE, DWORK(J), N1 ) CALL DGGES( 'No Q', 'No Z', 'No sort', DELCTG, N, DWORK, N1, $ DWORK(J), N1, KWA, DWORK(K), DWORK(K+N), $ DWORK(K+2*N), DWORK, 1, DWORK, 1, DWORK(K+3*N), $ LDWORK-(K+3*N)+1, BWORK, I ) MAXWRK = MAX( MAXWRK, INT( DWORK(K+3*N) ) + K + 3*N - 1 ) C DO 10 I = K, K+N-1 IF( ABS( DWORK(I+2*N) ).LE.TZER ) THEN IF( DLAPY2( DWORK(I), DWORK(I+N) ).LE.TZER ) THEN INFO = 1 RETURN END IF END IF 10 CONTINUE END IF C M1 = MAX( 1, M ) P1 = MAX( 1, P ) C IF( LSPACE ) THEN C C Determine offsets for large workspace option. C KWA = 1 KWE = J KWB = KWE + NN KWC = KWB + N*M KWR = KWC + N*P ELSE KWR = 1 END IF C IF( MAXACC ) THEN C C Determine offsets for large workspace option. C LWA = KWR LWE = LWA + NN LWB = LWE + NN LWC = LWB + N*M KWR = LWC + N*P END IF C C If required, scale the system (A-lambda*E,B,C). C Workspace: need 8*N. C IF( LEQUIL ) THEN CALL TG01AD( 'All', N, N, M, P, THRESH, A, LDA, E, LDE, B, LDB, $ C, LDC, DWORK, DWORK(N+1), DWORK(2*N+1), INFO ) END IF C LDQ = 1 LDZ = 1 NC = N NR = N C IF( INFCON ) THEN C C Phase 1: Eliminate all infinite and all finite nonzero C uncontrollable eigenvalues. C IF( MAXACC ) THEN C C Save system matrices. C CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(LWA), N1 ) CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(LWE), N1 ) CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(LWB), N1 ) CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(LWC), P1 ) END IF C IF( LSPACE ) THEN C C Reduce A to upper triangular form if necessary. C Check if block algorithms should be used. C IF( LBA.GT.0 .AND. INFOBS ) THEN CALL DGEQRF( NC, NC, A, LDA, DWORK, DWORK, -1, INFO ) NB = INT( DWORK(1)/NC ) IF( LDWORK.LT.NC*NB ) $ NB = INT( LDWORK/NC ) C NX = ILAENV( 3, 'DGEQRF', ' ', NC, NC, -1, -1 ) IF( LBA.LT.NX/2 .OR. NB.LT.NX .OR. NC.LT.NX ) THEN C DO 20 I = 1, NC-1 C C Generate elementary reflector H(i) to annihilate C A(i+1:i+lba,i). C K = MIN( LBA, NC-I ) + 1 CALL DLARFG( K, A(I,I), A(I+1,I), 1, TT ) T = A(I,I) A(I,I) = ONE C C Apply H(i) to A(i:nc,i+1:n) from the left. C CALL DLARF( 'Left', K, N-I, A(I,I), 1, TT, $ A(I,I+1), LDA, DWORK ) C C Apply H(i) to E(i:nc,1:n) from the left. C CALL DLARF( 'Left', K, N, A(I,I), 1, TT, E(I,1), $ LDE, DWORK ) C C Apply H(i) to B(i:nc,1:m) from the left. C CALL DLARF( 'Left', K, M, A(I,I), 1, TT, B(I,1), $ LDB, DWORK ) A(I,I) = T 20 CONTINUE C ELSE C CALL DGEQRF( NC, NC, A, LDA, DWORK, DWORK(NC+1), $ LDWORK-NC, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(NC+1) )+NC ) CALL DORMQR( 'Left', 'Transpose', NC, N, NC, A, LDA, $ DWORK, E, LDE, DWORK(NC+1), LDWORK-NC, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(NC+1) )+NC ) CALL DORMQR( 'Left', 'Transpose', NC, M, NC, A, LDA, $ DWORK, B, LDB, DWORK(NC+1), LDWORK-NC, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(NC+1) )+NC ) END IF IF( NC.GT.1 ) $ CALL DLASET( 'Lower', NC-1, NC-1, ZERO, ZERO, A(2,1), $ LDA ) LBA = 0 C END IF C C Save system matrices. C CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) END IF C C Perform infinite controllability form reduction. C Workspace: need 2*(M+N-1); C prefer larger. C CALL TG01HY( JOBQ, JOBZ, NC, NC, M, P, NC, LBA, E, LDE, A, LDA, $ B, LDB, C, LDC, DUM, LDQ, DUM, LDZ, NR, NBLCK, $ IWORK, TL, IWORK(N+1), DWORK(KWR), LDWORK-KWR+1, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(KWR) )+KWR-1 ) INFRED(1) = NC - NR INFRED(7) = NBLCK IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN IF( NBLCK.GT.1 ) THEN LBE = IWORK(1) + IWORK(2) - 1 ELSE IF( NBLCK.EQ.1 ) THEN LBE = IWORK(1) - 1 ELSE LBE = 0 END IF LBA = 0 NC = NR ELSE IF ( .NOT.MAXACC ) THEN C C Restore orthogonally transformed system matrices. C CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) ELSE C C Restore system matrices. C CALL DLACPY( 'Full', NC, NC, DWORK(LWA), N1, A, LDA ) CALL DLACPY( 'Full', NC, NC, DWORK(LWE), N1, E, LDE ) CALL DLACPY( 'Full', NC, M, DWORK(LWB), N1, B, LDB ) CALL DLACPY( 'Full', P, NC, DWORK(LWC), P1, C, LDC ) LBA = MAX( 0, N-1 ) END IF END IF C IF( INFOBS ) THEN C C Phase 2: Eliminate all infinite and all finite nonzero C unobservable eigenvalues. C C Compute the pertransposed dual system exploiting matrix shapes. C CALL TB01XD( 'Z', NC, M, P, LBA, MAX( 0, NC-1 ), A, LDA, $ B, LDB, C, LDC, DUM, 1, INFO ) CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) C IF( LSPACE) THEN C C Save system matrices. C CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) END IF C C Perform infinite observability form reduction. C Workspace: need 2*(P+N-1); C prefer larger. C CALL TG01HY( JOBZ, JOBQ, NC, NC, P, M, NC, LBA, E, LDE, A, LDA, $ B, LDB, C, LDC, DUM, LDZ, DUM, LDQ, NR, NBLCK, $ IWORK(N+1), TL, IWORK(2*N+1), DWORK(KWR), $ LDWORK-KWR+1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(KWR) )+KWR-1 ) INFRED(2) = NC - NR IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN INFRED(7) = NBLCK DO 30 I = 1, NBLCK IWORK(I) = IWORK(N+I) 30 CONTINUE IF( NBLCK.GT.1 ) THEN LBE = IWORK(1) + IWORK(2) - 1 ELSE IF( NBLCK.EQ.1 ) THEN LBE = IWORK(1) - 1 ELSE LBE = 0 END IF LBA = 0 NC = NR ELSE C C Restore orthogonally transformed system matrices. C CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) END IF C IF( FINCON .OR. .NOT. FINOBS ) THEN C C Compute the pertransposed dual system exploiting matrix C shapes. C CALL TB01XD( 'Z', NC, P, M, LBA, MAX( 0, NC-1 ), A, LDA, $ B, LDB, C, LDC, DUM, 1, INFO ) CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) END IF END IF C IF( FINCON ) THEN C C Phase 3: Eliminate all finite uncontrollable eigenvalues. C IF( MAXACC ) THEN C C Save system matrices. C CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(LWA), N1 ) CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(LWE), N1 ) CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(LWB), N1 ) CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(LWC), P1 ) LBAS = LBA LBES = LBE END IF C IF( LSPACE ) THEN C C Reduce E to upper triangular form if necessary. C Check if block algorithms should be used. C IF( LBE.GT.0 .AND. FINOBS ) THEN CALL DGEQRF( NC, NC, E, LDE, DWORK, DWORK, -1, INFO ) NB = INT( DWORK(1)/NC ) IF( LDWORK.LT.NC*NB ) $ NB = INT( LDWORK/NC ) C NX = ILAENV( 3, 'DGEQRF', ' ', NC, NC, -1, -1 ) IF( LBE.LT.NX/2 .OR. NB.LT.NX .OR. NC.LT.NX ) THEN C DO 40 I = 1, NC-1 C C Generate elementary reflector H(i) to annihilate C E(i+1:i+lbe,i). C K = MIN( LBE, NC-I ) + 1 CALL DLARFG( K, E(I,I), E(I+1,I), 1, TT ) T = E(I,I) E(I,I) = ONE C C Apply H(i) to E(i:nc,i+1:n) from the left. C CALL DLARF( 'Left', K, N-I, E(I,I), 1, TT, $ E(I,I+1), LDE, DWORK ) C C Apply H(i) to A(i:nc,1:n) from the left. C CALL DLARF( 'Left', K, N, E(I,I), 1, TT, A(I,1), $ LDA, DWORK ) C C Apply H(i) to B(i:nc,1:m) from the left. C CALL DLARF( 'Left', K, M, E(I,I), 1, TT, B(I,1), $ LDB, DWORK ) E(I,I) = T 40 CONTINUE C ELSE C CALL DGEQRF( NC, NC, E, LDE, DWORK, DWORK(NC+1), $ LDWORK-NC, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(NC+1) )+NC ) CALL DORMQR( 'Left', 'Transpose', NC, N, NC, E, LDE, $ DWORK, A, LDA, DWORK(NC+1), LDWORK-NC, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(NC+1) )+NC ) CALL DORMQR( 'Left', 'Transpose', NC, M, NC, E, LDE, $ DWORK, B, LDB, DWORK(NC+1), LDWORK-NC, $ INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(NC+1) )+NC ) END IF IF( NC.GT.1 ) $ CALL DLASET( 'Lower', NC-1, NC-1, ZERO, ZERO, E(2,1), $ LDE ) LBE = 0 LBA = MAX( 0, NC-1 ) C END IF C C Save system matrices. C CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) END IF C C Perform finite controllability form reduction. C Workspace: need 2*(M+N-1); C prefer larger. C CALL TG01HY( JOBQ, JOBZ, NC, NC, M, P, NC, LBE, A, LDA, E, LDE, $ B, LDB, C, LDC, DUM, LDQ, DUM, LDZ, NR, NBLCK, $ IWORK(N+1), TL, IWORK(2*N+1), DWORK(KWR), $ LDWORK-KWR+1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(KWR) )+KWR-1 ) INFRED(3) = NC - NR IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN INFRED(7) = NBLCK DO 50 I = 1, NBLCK IWORK(I) = IWORK(N+I) 50 CONTINUE IF( NBLCK.GT.1 ) THEN LBA = IWORK(1) + IWORK(2) - 1 ELSE IF( NBLCK.EQ.1 ) THEN LBA = IWORK(1) - 1 ELSE LBA = 0 END IF LBE = 0 NC = NR ELSE IF ( .NOT.MAXACC ) THEN C C Restore orthogonally transformed system matrices. C CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) ELSE C C Restore system matrices. C CALL DLACPY( 'Full', NC, NC, DWORK(LWA), N1, A, LDA ) CALL DLACPY( 'Full', NC, NC, DWORK(LWE), N1, E, LDE ) CALL DLACPY( 'Full', NC, M, DWORK(LWB), N1, B, LDB ) CALL DLACPY( 'Full', P, NC, DWORK(LWC), P1, C, LDC ) LBA = LBAS LBE = LBES END IF C IF( FINOBS ) THEN C C Compute the pertransposed dual system exploiting matrix C shapes. C CALL TB01XD( 'Z', NC, M, P, LBA, MAX( 0, NC-1 ), A, LDA, $ B, LDB, C, LDC, DUM, 1, INFO ) CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) END IF END IF C IF( FINOBS ) THEN C C Phase 4: Eliminate all finite unobservable eigenvalues. C IF( LSPACE ) THEN C C Save system matrices. C CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) END IF C C Perform finite observability form reduction. C Workspace: need 2*(P+N-1); C prefer larger. C CALL TG01HY( JOBZ, JOBQ, NC, NC, P, M, NC, LBE, A, LDA, E, LDE, $ B, LDB, C, LDC, DUM, LDZ, DUM, LDQ, NR, NBLCK, $ IWORK(N+1), TL, IWORK(2*N+1), DWORK(KWR), $ LDWORK-KWR+1, INFO ) MAXWRK = MAX( MAXWRK, INT( DWORK(KWR) )+KWR-1 ) INFRED(4) = NC - NR IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN INFRED(7) = NBLCK DO 60 I = 1, NBLCK IWORK(I) = IWORK(N+I) 60 CONTINUE IF( NBLCK.GT.1 ) THEN LBA = IWORK(1) + IWORK(2) - 1 ELSE IF( NBLCK.EQ.1 ) THEN LBA = IWORK(1) - 1 ELSE LBA = 0 END IF LBE = 0 NC = NR ELSE C C Restore orthogonally transformed system matrices. C CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) END IF C C Compute the pertransposed dual system exploiting matrix shapes. C CALL TB01XD( 'Z', NC, P, M, LBA, MAX( 0, NC-1 ), A, LDA, $ B, LDB, C, LDC, DUM, 1, INFO ) CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) END IF C C Set structural information on A and E. C INFRED(5) = LBA INFRED(6) = LBE DWORK(1) = MAXWRK C RETURN C *** Last line of TG01JY *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09HD.f0000644000000000000000000000013215012430707016144 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09HD.f0000644000175000017500000006204415012430707017346 0ustar00lilgelilge00000000000000 SUBROUTINE AB09HD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, $ BETA, A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, $ TOL1, TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN, $ INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for an original C state-space representation (A,B,C,D) by using the stochastic C balancing approach in conjunction with the square-root or C the balancing-free square-root Balance & Truncate (B&T) C or Singular Perturbation Approximation (SPA) model reduction C methods for the ALPHA-stable part of the system. 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 JOB CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root Balance & Truncate method; C = 'F': use the balancing-free square-root C Balance & Truncate method; C = 'S': use the square-root Singular Perturbation C Approximation method; C = 'P': use the balancing-free square-root C Singular Perturbation Approximation method. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e., the order of the 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 P <= M if BETA = 0. C C NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of the C resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. For a system with NU ALPHA-unstable C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), C NR is set as follows: if ORDSEL = 'F', NR is equal to C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order C on entry, and NMIN is the order of a minimal realization C of the ALPHA-stable part of the given system; NMIN is C determined as the number of Hankel singular values greater C than NS*EPS, where EPS is the machine precision C (see LAPACK Library Routine DLAMCH); C if ORDSEL = 'A', NR is the sum of NU and the number of C Hankel singular values greater than MAX(TOL1,NS*EPS); C NR can be further reduced to ensure that C HSV(NR-NU) > HSV(NR+1-NU). C C ALPHA (input) DOUBLE PRECISION C Specifies the ALPHA-stability boundary for the eigenvalues C of the state dynamics matrix A. For a continuous-time C system (DICO = 'C'), ALPHA <= 0 is the boundary value for C the real parts of eigenvalues, while for a discrete-time C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the C boundary value for the moduli of eigenvalues. C The ALPHA-stability domain does not include the boundary. C C BETA (input) DOUBLE PRECISION C BETA > 0 specifies the absolute/relative error weighting C parameter. A large positive value of BETA favours the C minimization of the absolute approximation error, while a C small value of BETA is appropriate for the minimization C of the relative error. C BETA = 0 means a pure relative error method and can be C used only if rank(D) = P. 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, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the reduced C order system. C The resulting A has a block-diagonal form with two blocks. C For a system with NU ALPHA-unstable eigenvalues and C NS ALPHA-stable eigenvalues (NU+NS = N), the leading C NU-by-NU block contains the unreduced part of A C corresponding to ALPHA-unstable eigenvalues in an C upper real Schur form. C The trailing (NR+NS-N)-by-(NR+NS-N) block contains C the reduced part of A corresponding to ALPHA-stable C eigenvalues. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C NS (output) INTEGER C The dimension of the ALPHA-stable subsystem. C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, the leading NS elements of HSV contain the C Hankel singular values of the phase system corresponding C to the ALPHA-stable part of the original system. C The Hankel singular values are ordered decreasingly. C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value of TOL1 lies C in the interval [0.00001,0.001]. C If TOL1 <= 0 on entry, the used default value is C TOL1 = NS*EPS, where NS is the number of C ALPHA-stable eigenvalues of A and EPS is the machine C precision (see LAPACK Library Routine DLAMCH). C If ORDSEL = 'F', the value of TOL1 is ignored. C TOL1 < 1. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the phase system (see METHOD) corresponding C to the ALPHA-stable part of the given system. C The recommended value is TOL2 = NS*EPS. C This value is used by default if TOL2 <= 0 on entry. C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. C TOL2 < 1. C C Workspace C C IWORK INTEGER array, dimension (MAX(1,2*N)) C On exit with INFO = 0, IWORK(1) contains the order of the C minimal realization of the system. 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) contains RCOND, the reciprocal C condition number of the U11 matrix from the expression C used to compute the solution X = U21*inv(U11) of the C Riccati equation for spectral factorization. C A small value RCOND indicates possible ill-conditioning C of the respective Riccati equation. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 2*N*N + MB*(N+P) + MAX( 2, N*(MAX(N,MB,P)+5), C 2*N*P+MAX(P*(MB+2),10*N*(N+1) ) ), C where MB = M if BETA = 0 and MB = M+P if BETA > 0. C For optimum performance LDWORK should be larger. C C BWORK LOGICAL array, dimension 2*N C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than NSMIN, the sum of the order of the C ALPHA-unstable part and the order of a minimal C realization of the ALPHA-stable part of the given C system; in this case, the resulting NR is set equal C to NSMIN; C = 2: with ORDSEL = 'F', the selected order NR corresponds C to repeated singular values for the ALPHA-stable C part, which are neither all included nor all C excluded from the reduced model; in this case, the C resulting NR is automatically decreased to exclude C all repeated singular values; C = 3: with ORDSEL = 'F', the selected order NR is less C than the order of the ALPHA-unstable part of the C given system; in this case NR is set equal to the C order of the ALPHA-unstable part. 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 computation of the ordered real Schur form of A C failed; C = 2: the reduction of the Hamiltonian matrix to real C Schur form failed; C = 3: the reordering of the real Schur form of the C Hamiltonian matrix failed; C = 4: the Hamiltonian matrix has less than N stable C eigenvalues; C = 5: the coefficient matrix U11 in the linear system C X*U11 = U21 to determine X is singular to working C precision; C = 6: BETA = 0 and D has not a maximal row rank; C = 7: the computation of Hankel singular values failed; C = 8: the separation of the ALPHA-stable/unstable diagonal C blocks failed because of very close eigenvalues; C = 9: the resulting order of reduced stable part is less C than the number of unstable zeros of the stable C part. C METHOD C C Let be the following linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t), (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09HD determines for C the given system (1), the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t), (2) C C such that C C INFNORM[inv(conj(W))*(G-Gr)] <= C (1+HSV(NR+NS-N+1)) / (1-HSV(NR+NS-N+1)) + ... C + (1+HSV(NS)) / (1-HSV(NS)) - 1, C C where G and Gr are transfer-function matrices of the systems C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, W is the right, minimum C phase spectral factor satisfying C C G1*conj(G1) = conj(W)* W, (3) C C G1 is the NS-order ALPHA-stable part of G, and INFNORM(G) is the C infinity-norm of G. HSV(1), ... , HSV(NS) are the Hankel-singular C values of the stable part of the phase system (Ap,Bp,Cp) C with the transfer-function matrix C C P = inv(conj(W))*G1. C C If BETA > 0, then the model reduction is performed on [G BETA*I] C instead of G. This is the recommended approach to be used when D C has not a maximal row rank or when a certain balance between C relative and absolute approximation errors is desired. For C increasingly large values of BETA, the obtained reduced system C assymptotically approaches that computed by using the C Balance & Truncate or Singular Perturbation Approximation methods. C C Note: conj(G) denotes either G'(-s) for a continuous-time system C or G'(1/z) for a discrete-time system. C inv(G) is the inverse of G. C C The following procedure is used to reduce a given G: C C 1) Decompose additively G as C C G = G1 + G2, C C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. C C 2) Determine G1r, a reduced order approximation of the C ALPHA-stable part G1 using the balancing stochastic method C in conjunction with either the B&T [1,2] or SPA methods [3]. C C 3) Assemble the reduced model Gr as C C Gr = G1r + G2. C C Note: The employed stochastic truncation algorithm [2,3] has the C property that right half plane zeros of G1 remain as right half C plane zeros of G1r. Thus, the order can not be chosen smaller than C the sum of the number of unstable poles of G and the number of C unstable zeros of G1. C C The reduction of the ALPHA-stable part G1 is done as follows. C C If JOB = 'B', the square-root stochastic Balance & Truncate C method of [1] is used. C For an ALPHA-stable continuous-time system (DICO = 'C'), C the resulting reduced model is stochastically balanced. C C If JOB = 'F', the balancing-free square-root version of the C stochastic Balance & Truncate method [1] is used to reduce C the ALPHA-stable part G1. C C If JOB = 'S', the stochastic balancing method is used to reduce C the ALPHA-stable part G1, in conjunction with the square-root C version of the Singular Perturbation Approximation method [3,4]. C C If JOB = 'P', the stochastic balancing method is used to reduce C the ALPHA-stable part G1, in conjunction with the balancing-free C square-root version of the Singular Perturbation Approximation C method [3,4]. C C REFERENCES C C [1] Varga A. and Fasol K.H. C A new square-root balancing-free stochastic truncation model C reduction algorithm. C Proc. 12th IFAC World Congress, Sydney, 1993. C C [2] Safonov M. G. and Chiang R. Y. C Model reduction for robust control: a Schur relative error C method. C Int. J. Adapt. Contr. Sign. Proc., vol. 2, pp. 259-272, 1988. C C [3] Green M. and Anderson B. D. O. C Generalized balanced stochastic truncation. C Proc. 29-th CDC, Honolulu, Hawaii, pp. 476-481, 1990. C C [4] Varga A. C Balancing-free square-root algorithm for computing C singular perturbation approximations. C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, C Vol. 2, pp. 1062-1065. C C NUMERICAL ASPECTS C C The implemented methods rely on accuracy enhancing square-root or C balancing-free square-root techniques. The effectiveness of the C accuracy enhancing technique depends on the accuracy of the C solution of a Riccati equation. An ill-conditioned Riccati C solution typically results when [D BETA*I] is nearly C rank deficient. C 3 C The algorithm requires about 100N floating point operations. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. C D. Sima, University of Bucharest, May 2000. C V. Sima, Research Institute for Informatics, Bucharest, May 2000. C Partly based on the RASP routine SRBFS, by A. Varga, 1992. C C REVISIONS C C A. Varga, Australian National University, Canberra, November 2000. C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. C Oct. 2001. C C KEYWORDS C C Minimal realization, model reduction, multivariable system, C state-space model, state-space representation, C stochastic balancing. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, TWOBY3, C100 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ TWOBY3 = TWO/3.0D0, C100 = 100.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, JOB, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, $ M, N, NR, NS, P DOUBLE PRECISION ALPHA, BETA, TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), HSV(*) LOGICAL BWORK(*) C .. Local Scalars .. LOGICAL BTA, DISCR, FIXORD, LEQUIL, SPA INTEGER IERR, IWARNL, KB, KD, KT, KTI, KU, KW, KWI, KWR, $ LW, LWR, MB, NMR, NN, NRA, NU, NU1, WRKOPT DOUBLE PRECISION EPSM, MAXRED, RICOND, SCALEC, SCALEO C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB04MD, AB09HY, AB09IX, DLACPY, DLASET, TB01ID, $ TB01KD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) FIXORD = LSAME( ORDSEL, 'F' ) LEQUIL = LSAME( EQUIL, 'S' ) BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) MB = M IF( BETA.GT.ZERO ) MB = M + P LW = 2*N*N + MB*(N+P) + MAX( 2, N*(MAX( N, MB, P )+5), $ 2*N*P+MAX( P*(MB+2), 10*N*(N+1) ) ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN INFO = -2 ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN INFO = -3 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( P.LT.0 .OR. ( BETA.EQ.ZERO .AND. P.GT.M ) ) THEN INFO = -7 ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -8 ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN INFO = -9 ELSE IF( BETA.LT.ZERO ) THEN INFO = -10 ELSE IF( LDA.LT.MAX( 1, 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.MAX( 1, P ) ) THEN INFO = -18 ELSE IF( TOL1.GE.ONE ) THEN INFO = -21 ELSE IF( ( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) $ .OR. TOL2.GE.ONE ) THEN INFO = -22 ELSE IF( LDWORK.LT.LW ) THEN INFO = -25 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09HD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 .OR. $ ( BTA .AND. FIXORD .AND. NR.EQ.0 ) ) THEN NR = 0 NS = 0 IWORK(1) = 0 DWORK(1) = TWO DWORK(2) = ONE RETURN END IF C IF( LEQUIL ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C Workspace: N. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Allocate working storage. C NN = N*N KU = 1 KWR = KU + NN KWI = KWR + N KW = KWI + N LWR = LDWORK - KW + 1 C C Reduce A to a block-diagonal real Schur form, with the C ALPHA-unstable part in the leading diagonal position, using a C non-orthogonal similarity transformation A <- inv(T)*A*T and C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. C C Workspace needed: N*(N+2); C Additional workspace: need 3*N; C prefer larger. C CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPHA, A, LDA, $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), $ DWORK(KWI), DWORK(KW), LWR, IERR ) C IF( IERR.NE.0 ) THEN IF( IERR.NE.3 ) THEN INFO = 1 ELSE INFO = 8 END IF RETURN END IF C WRKOPT = INT( DWORK(KW) ) + KW - 1 C IWARNL = 0 NS = N - NU IF( FIXORD ) THEN NRA = MAX( 0, NR-NU ) IF( NR.LT.NU ) $ IWARNL = 3 ELSE NRA = 0 END IF C C Finish if the system is completely unstable. C IF( NS.EQ.0 ) THEN NR = NU IWORK(1) = NS DWORK(1) = WRKOPT DWORK(2) = ONE RETURN END IF C NU1 = NU + 1 C C Allocate working storage. C KB = 1 KD = KB + N*MB KT = KD + P*MB KTI = KT + N*N KW = KTI + N*N C C Form [B 0] and [D BETA*I]. C CALL DLACPY( 'F', NS, M, B(NU1,1), LDB, DWORK(KB), N ) CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P ) IF( BETA.GT.ZERO ) THEN CALL DLASET( 'F', NS, P, ZERO, ZERO, DWORK(KB+N*M), N ) CALL DLASET( 'F', P, P, ZERO, BETA, DWORK(KD+P*M), P ) END IF C C For discrete-time case, apply the discrete-to-continuous bilinear C transformation to the stable part. C IF( DISCR ) THEN C C Real workspace: need N, prefer larger; C Integer workspace: need N. C CALL AB04MD( 'Discrete', NS, MB, P, ONE, ONE, A(NU1,NU1), LDA, $ DWORK(KB), N, C(1,NU1), LDC, DWORK(KD), P, $ IWORK, DWORK(KT), LDWORK-KT+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KT) ) + KT - 1 ) END IF C C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R C of the controllability and observability Grammians, respectively. C Real workspace: need 2*N*N + MB*(N+P)+ C MAX( 2, N*(MAX(N,MB,P)+5), C 2*N*P+MAX(P*(MB+2), 10*N*(N+1) ) ); C prefer larger. C Integer workspace: need 2*N. C CALL AB09HY( NS, MB, P, A(NU1,NU1), LDA, DWORK(KB), N, $ C(1,NU1), LDC, DWORK(KD), P, SCALEC, SCALEO, $ DWORK(KTI), N, DWORK(KT), N, IWORK, DWORK(KW), $ LDWORK-KW+1, BWORK, INFO ) IF( INFO.NE.0 ) $ RETURN WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) RICOND = DWORK(KW+1) C C Compute a BTA or SPA of the stable part. C Real workspace: need 2*N*N + MB*(N+P)+ C MAX( 1, 2*N*N+5*N, N*MAX(MB,P) ). C EPSM = DLAMCH( 'Epsilon' ) CALL AB09IX( 'C', JOB, 'Schur', ORDSEL, NS, MB, P, NRA, SCALEC, $ SCALEO, A(NU1,NU1), LDA, DWORK(KB), N, C(1,NU1), LDC, $ DWORK(KD), P, DWORK(KTI), N, DWORK(KT), N, NMR, HSV, $ MAX( TOL1, N*EPSM ), TOL2, IWORK, DWORK(KW), $ LDWORK-KW+1, IWARN, IERR ) IWARN = MAX( IWARN, IWARNL ) IF( IERR.NE.0 ) THEN INFO = 7 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Check if the resulting order is greater than the number of C unstable zeros (this check is implicit by looking at Hankel C singular values equal to 1). C IF( NRA.LT.NS .AND. HSV(NRA+1).GE.ONE-EPSM**TWOBY3 ) THEN INFO = 9 RETURN END IF C C For discrete-time case, apply the continuous-to-discrete C bilinear transformation. C IF( DISCR ) THEN CALL AB04MD( 'Continuous', NRA, MB, P, ONE, ONE, $ A(NU1,NU1), LDA, DWORK(KB), N, C(1,NU1), LDC, $ DWORK(KD), P, IWORK, DWORK, LDWORK, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) END IF C CALL DLACPY( 'F', NRA, M, DWORK(KB), N, B(NU1,1), LDB ) CALL DLACPY( 'F', P, M, DWORK(KD), P, D, LDD ) C NR = NRA + NU C IWORK(1) = NMR DWORK(1) = WRKOPT DWORK(2) = RICOND C RETURN C *** Last line of AB09HD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04QR.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB04QR.f0000644000175000017500000001230115012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE SB04QR( M, D, IPR, INFO ) 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 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 C None. C C CONTRIBUTORS C C D. Sima, University of Bucharest, May 2000. 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, MOD C .. Executable Statements .. C INFO = 0 I2 = M*M/2 + 3*M 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.4 .AND. MOD( I, 2 ).EQ.0 ) M1 = M1 - 2 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 = 3 IF ( MOD( I, 2 ).EQ.0 ) 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 ) IPR(J) = IPR(J) + 1 60 CONTINUE C 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 SB04QR *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01XD.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01XD.f0000644000175000017500000001341515012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE MB01XD( UPLO, N, A, LDA, INFO ) C C PURPOSE C C To compute the matrix product U' * U or L * L', where U and L are C upper and lower triangular matrices, respectively, stored in the C corresponding upper or lower triangular part of the array A. C C If UPLO = 'U' then the upper triangle of the result is stored, C overwriting the matrix U in A. C If UPLO = 'L' then the lower triangle of the result is stored, C overwriting the matrix L in A. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies which triangle (U or L) is given in the array A, C as follows: C = 'U': the upper triangular part U is given; C = 'L': the lower triangular part L is given. C C Input/Output Parameters C C N (input) INTEGER C The order of the triangular matrices U or L. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,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 matrix U. C On entry, if UPLO = 'L', the leading N-by-N lower C triangular part of this array must contain the lower C triangular matrix L. C On exit, if UPLO = 'U', the leading N-by-N upper C triangular part of this array contains the upper C triangular part of the product U' * U. The strictly lower C triangular part is not referenced. C On exit, if UPLO = 'L', the leading N-by-N lower C triangular part of this array contains the lower C triangular part of the product L * L'. The strictly upper C triangular part is not referenced. C C LDA INTEGER C The leading dimension of array A. LDA >= max(1,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 METHOD C C The matrix product U' * U or L * L' is computed using BLAS 3 C operations as much as possible (a block algorithm). C C FURTHER COMMENTS C C This routine is a counterpart of LAPACK Library routine DLAUUM, C which computes the matrix product U * U' or L' * L. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. C C REVISIONS C C - C C KEYWORDS C C Elementary matrix operations, matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, N C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) C .. C .. Local Scalars .. LOGICAL UPPER INTEGER I, IB, II, NB C .. C .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV C .. C .. External Subroutines .. EXTERNAL DGEMM, DSYRK, DTRMM, MB01XY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB01XD', -INFO ) RETURN END IF C C Quick return, if possible. C IF( N.EQ.0 ) $ RETURN C C Determine the block size for this environment (as for DLAUUM). C NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 ) C IF( NB.LE.1 .OR. NB.GE.N ) THEN C C Use unblocked code. C CALL MB01XY( UPLO, N, A, LDA, INFO ) ELSE C C Use blocked code. C IF( UPPER ) THEN C C Compute the product U' * U. C DO 10 I = N, 1, -NB IB = MIN( NB, I ) II = I - IB + 1 IF( I.LT.N ) THEN CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-unit', $ IB, N-I, ONE, A( II, II ), LDA, $ A( II, II+IB ), LDA ) CALL DGEMM( 'Transpose', 'No transpose', IB, N-I, $ I-IB, ONE, A( 1, II ), LDA, A( 1, II+IB ), $ LDA, ONE, A( II, II+IB ), LDA ) END IF CALL MB01XY( 'Upper', IB, A( II, II ), LDA, INFO ) CALL DSYRK( 'Upper', 'Transpose', IB, II-1, ONE, $ A( 1, II ), LDA, ONE, A( II, II ), LDA ) 10 CONTINUE ELSE C C Compute the product L * L'. C DO 20 I = N, 1, -NB IB = MIN( NB, I ) II = I - IB + 1 IF( I.LT.N ) THEN CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Non-unit', $ N-I, IB, ONE, A( II, II ), LDA, $ A( II+IB, II ), LDA ) CALL DGEMM( 'No transpose', 'Transpose', N-I, IB, $ I-IB, ONE, A( II+IB, 1 ), LDA, A( II, 1 ), $ LDA, ONE, A( II+IB, II ), LDA ) END IF CALL MB01XY( 'Lower', IB, A( II, II ), LDA, INFO ) CALL DSYRK( 'Lower', 'No Transpose', IB, II-1, ONE, $ A( II, 1 ), LDA, ONE, A( II, II ), LDA ) 20 CONTINUE END IF END IF C RETURN C C *** Last line of MB01XD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02ID.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02ID.f0000644000175000017500000005043015012430707017350 0ustar00lilgelilge00000000000000 SUBROUTINE MB02ID( JOB, K, L, M, N, RB, RC, TC, LDTC, TR, LDTR, B, $ LDB, C, LDC, DWORK, LDWORK, INFO ) C C PURPOSE C C To solve the overdetermined or underdetermined real linear systems C involving an M*K-by-N*L block Toeplitz matrix T that is specified C by its first block column and row. It is assumed that T has full C rank. C The following options are provided: C C 1. If JOB = 'O' or JOB = 'A' : find the least squares solution of C an overdetermined system, i.e., solve the least squares problem C C minimize || B - T*X ||. (1) C C 2. If JOB = 'U' or JOB = 'A' : find the minimum norm solution of C the undetermined system C T C T * X = C. (2) C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the problem to be solved as follows C = 'O': solve the overdetermined system (1); C = 'U': solve the underdetermined system (2); C = 'A': solve (1) and (2). C C Input/Output Parameters C C K (input) INTEGER C The number of rows in the blocks of T. K >= 0. C C L (input) INTEGER C The number of columns in the blocks of T. L >= 0. C C M (input) INTEGER C The number of blocks in the first block column of T. C M >= 0. C C N (input) INTEGER C The number of blocks in the first block row of T. C 0 <= N <= M*K / L. C C RB (input) INTEGER C If JOB = 'O' or 'A', the number of columns in B. RB >= 0. C C RC (input) INTEGER C If JOB = 'U' or 'A', the number of columns in C. RC >= 0. C C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) C On entry, the leading M*K-by-L part of this array must C contain the first block column of T. C C LDTC INTEGER C The leading dimension of the array TC. LDTC >= MAX(1,M*K) C C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) C On entry, the leading K-by-(N-1)*L part of this array must C contain the 2nd to the N-th blocks of the first block row C of T. C C LDTR INTEGER C The leading dimension of the array TR. LDTR >= MAX(1,K). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,RB) C On entry, if JOB = 'O' or JOB = 'A', the leading M*K-by-RB C part of this array must contain the right hand side C matrix B of the overdetermined system (1). C On exit, if JOB = 'O' or JOB = 'A', the leading N*L-by-RB C part of this array contains the solution of the C overdetermined system (1). C This array is not referenced if JOB = 'U'. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,M*K), if JOB = 'O' or JOB = 'A'; C LDB >= 1, if JOB = 'U'. C C C (input) DOUBLE PRECISION array, dimension (LDC,RC) C On entry, if JOB = 'U' or JOB = 'A', the leading N*L-by-RC C part of this array must contain the right hand side C matrix C of the underdetermined system (2). C On exit, if JOB = 'U' or JOB = 'A', the leading M*K-by-RC C part of this array contains the solution of the C underdetermined system (2). C This array is not referenced if JOB = 'O'. C C LDC INTEGER C The leading dimension of the array C. C LDB >= 1, if JOB = 'O'; C LDB >= MAX(1,M*K), if JOB = 'U' or JOB = 'A'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -17, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C Let x = MAX( 2*N*L*(L+K) + (6+N)*L,(N*L+M*K+1)*L + M*K ) C and y = N*M*K*L + N*L, then C if MIN( M,N ) = 1 and JOB = 'O', C LDWORK >= MAX( y + MAX( M*K,RB ),1 ); C if MIN( M,N ) = 1 and JOB = 'U', C LDWORK >= MAX( y + MAX( M*K,RC ),1 ); C if MIN( M,N ) = 1 and JOB = 'A', C LDWORK >= MAX( y +MAX( M*K,MAX( RB,RC ),1 ); C if MIN( M,N ) > 1 and JOB = 'O', C LDWORK >= MAX( x,N*L*RB + 1 ); C if MIN( M,N ) > 1 and JOB = 'U', C LDWORK >= MAX( x,N*L*RC + 1 ); C if MIN( M,N ) > 1 and JOB = 'A', C LDWORK >= MAX( x,N*L*MAX( RB,RC ) + 1 ). 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 = 1: the reduction algorithm failed. The Toeplitz matrix C associated with T is (numerically) not of full rank. C C METHOD C C Householder transformations and modified hyperbolic rotations C are used in the Schur algorithm [1], [2]. C C REFERENCES C C [1] Kailath, T. and Sayed, A. C Fast Reliable Algorithms for Matrices with Structure. C SIAM Publications, Philadelphia, 1999. C C [2] Kressner, D. and Van Dooren, P. C Factorizations and linear system solvers for matrices with C Toeplitz structure. C SLICOT Working Note 2000-2, 2000. C C NUMERICAL ASPECTS C C The algorithm requires O( L*L*K*(N+M)*log(N+M) + N*N*L*L*(L+K) ) C and additionally C C if JOB = 'O' or JOB = 'A', C O( (K*L+RB*L+K*RB)*(N+M)*log(N+M) + N*N*L*L*RB ); C if JOB = 'U' or JOB = 'A', C O( (K*L+RC*L+K*RC)*(N+M)*log(N+M) + N*N*L*L*RC ); C C floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, May 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, June 2001. C D. Kressner, Technical Univ. Berlin, Germany, July 2002. C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004, C May 2011. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER INFO, K, L, LDB, LDC, LDTC, LDTR, LDWORK, M, N, $ RB, RC C .. Array Arguments .. DOUBLE PRECISION B(LDB,*), C(LDC,*), DWORK(LDWORK), TC(LDTC,*), $ TR(LDTR,*) C .. Local Scalars .. INTEGER I, IERR, LEN, NB, NBMIN, PDI, PDW, PNI, PNR, $ PPI, PPR, PT, RNK, WRKMIN, WRKOPT, X, Y LOGICAL COMPO, COMPU, COMPUS, LQUERY C .. Local Arrays .. INTEGER IPVT(1) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL ILAENV, LSAME C .. External Subroutines .. EXTERNAL DGELQF, DGELS, DGEMM, DGEQRF, DLACPY, DLASET, $ DORGQR, DTRMM, DTRSM, DTRTRI, MA02AD, MB02CU, $ MB02CV, MB02KD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 COMPO = LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) COMPU = LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) X = MAX( 2*N*L*( L + K ) + ( 6 + N )*L, $ ( N*L + M*K + 1 )*L + M*K ) Y = N*M*K*L + N*L IF ( MIN( M, N ).EQ.1 ) THEN WRKMIN = MAX( M*K, 1 ) IF ( COMPO ) WRKMIN = MAX( WRKMIN, RB ) IF ( COMPU ) WRKMIN = MAX( WRKMIN, RC ) WRKMIN = MAX( Y + WRKMIN, 1 ) ELSE WRKMIN = X IF ( COMPO ) WRKMIN = MAX( WRKMIN, N*L*RB + 1 ) IF ( COMPU ) WRKMIN = MAX( WRKMIN, N*L*RC + 1 ) END IF WRKOPT = 1 LQUERY = LDWORK.EQ.-1 C C Check the scalar input parameters. C IF ( .NOT.( COMPO .OR. COMPU ) ) THEN INFO = -1 ELSE IF ( K.LT.0 ) THEN INFO = -2 ELSE IF ( L.LT.0 ) THEN INFO = -3 ELSE IF ( M.LT.0 ) THEN INFO = -4 ELSE IF ( N.LT.0 .OR. ( N*L ).GT.( M*K ) ) THEN INFO = -5 ELSE IF ( COMPO .AND. RB.LT.0 ) THEN INFO = -6 ELSE IF ( COMPU .AND. RC.LT.0 ) THEN INFO = -7 ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN INFO = -9 ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN INFO = -11 ELSE IF ( LDB.LT.1 .OR. ( COMPO .AND. LDB.LT.M*K ) ) THEN INFO = -13 ELSE IF ( LDC.LT.1 .OR. ( COMPU .AND. LDC.LT.M*K ) ) THEN INFO = -15 ELSE COMPUS = COMPU IF( COMPO .AND. MIN( N*L, RB ).EQ.0 ) $ COMPO = .FALSE. IF( COMPU .AND. MIN( N*L, RC ).EQ.0 ) $ COMPU = .FALSE. IF ( LQUERY ) THEN IF ( MIN( M, N ).EQ.1 ) THEN PDW = K*L*M*N IF ( COMPO ) THEN CALL DGELS( 'NonTranspose', M*K, N*L, RB, DWORK, M*K, $ B, LDB, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW ) END IF IF ( COMPU ) THEN CALL DGELS( 'Transpose', M*K, N*L, RC, DWORK, M*K, C, $ LDC, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW ) END IF ELSE IF ( COMPO ) THEN CALL MB02KD( 'Column', 'Transpose', K, L, M, N, RB, $ ONE, ZERO, TC, LDTC, TR, LDTR, B, LDB, $ DWORK, N*L, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + N*L*RB ) END IF PDW = ( N*L + M*K )*L CALL DGEQRF( M*K, L, DWORK, M*K, DWORK, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW + L ) CALL DORGQR( M*K, L, L, DWORK, M*K, DWORK, DWORK, -1, $ IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW + L ) CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, $ ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, DWORK, $ N*L, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW ) PDW = 2*N*L*( L + K ) CALL DGELQF( N*L, L, DWORK, MAX( 1, N*L ), DWORK, DWORK, $ -1, IERR ) WRKOPT = MAX( WRKOPT, PDW + 6*L + INT( DWORK(1) ) ) IF ( COMPU ) THEN CALL MB02KD( 'Column', 'NonTranspose', K, L, M, N, RC, $ ONE, ZERO, TC, LDTC, TR, LDTR, C, LDC, $ DWORK, M*K, DWORK, -1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + M*K*RC ) END IF END IF ELSE IF ( LDWORK.LT.WRKMIN ) THEN DWORK(1) = DBLE( WRKMIN ) INFO = -17 END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02ID', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C C Quick return if possible. C IF( COMPUS .AND. MIN( N*L, RC ).EQ.0 ) $ CALL DLASET( 'Full', M*K, RC, ZERO, ZERO, C, LDC ) IF ( .NOT.( COMPO .OR. COMPU ) ) THEN DWORK(1) = ONE RETURN END IF C C Check cases M = 1 or N = 1. C IF ( MIN( M, N ).EQ.1 ) THEN PDW = K*L*M*N IF ( COMPO ) THEN CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1), $ M*K ) CALL DGELS( 'NonTranspose', M*K, N*L, RB, DWORK, M*K, B, $ LDB, DWORK(PDW+1), LDWORK-PDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW ) END IF IF ( COMPU ) THEN CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1), $ M*K ) CALL DGELS( 'Transpose', M*K, N*L, RC, DWORK, M*K, C, LDC, $ DWORK(PDW+1), LDWORK-PDW, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW ) END IF DWORK(1) = DBLE( WRKOPT ) RETURN END IF C C Step 1: Compute the generator. C IF ( COMPO ) THEN CALL MB02KD( 'Column', 'Transpose', K, L, M, N, RB, ONE, ZERO, $ TC, LDTC, TR, LDTR, B, LDB, DWORK, N*L, $ DWORK(N*L*RB+1), LDWORK-N*L*RB, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(N*L*RB+1) ) + N*L*RB ) CALL DLACPY( 'All', N*L, RB, DWORK, N*L, B, LDB ) END IF C PDW = N*L*L + 1 CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK(PDW), M*K ) CALL DGEQRF( M*K, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L), $ DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) + $ PDW + (M*K+1)*L - 1 ) C DO 10 I = PDW, PDW + M*K*L - 1, M*K + 1 IF ( DWORK(I).EQ.ZERO ) THEN INFO = 1 RETURN END IF 10 CONTINUE C CALL MA02AD( 'Upper', L, L, DWORK(PDW), M*K, DWORK, N*L ) CALL DORGQR( M*K, L, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L), $ DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) + $ PDW + (M*K+1)*L - 1 ) CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, ZERO, $ TC, LDTC, TR, LDTR, DWORK(PDW), M*K, DWORK(L+1), $ N*L, DWORK(PDW+M*K*L), LDWORK-PDW-M*K*L+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K*L) ) + PDW + M*K*L - 1 ) PPR = N*L*L + 1 PNR = N*L*( L + K ) + 1 CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(PPR+L), N*L ) CALL DLACPY( 'All', (N-1)*L, L, DWORK(L+1), N*L, DWORK(PNR+L), $ N*L ) PT = ( M - 1 )*K + 1 PDW = PNR + N*L*L + L C DO 30 I = 1, MIN( M, N-1 ) CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), N*L ) PT = PT - K PDW = PDW + L 30 CONTINUE C PT = 1 C DO 40 I = M + 1, N - 1 CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), N*L ) PT = PT + L PDW = PDW + L 40 CONTINUE C IF ( COMPO ) THEN C C Apply the first reduction step to T'*B. C CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', $ L, RB, ONE, DWORK, N*L, B, LDB ) CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RB, L, ONE, $ DWORK(L+1), N*L, B, LDB, -ONE, B(L+1,1), LDB ) CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L, $ RB, ONE, DWORK, N*L, B, LDB ) END IF C IF ( COMPU ) THEN C C Apply the first reduction step to C. C CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', $ L, RC, ONE, DWORK, N*L, C, LDC ) CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RC, L, ONE, $ DWORK(L+1), N*L, C, LDC, -ONE, C(L+1,1), LDC ) CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L, $ RC, ONE, DWORK, N*L, C, LDC ) END IF C PDI = ( N - 1 )*L + 1 CALL DLACPY( 'Lower', L, L, DWORK, N*L, DWORK(PDI), N*L ) CALL DTRTRI( 'Lower', 'NonUnit', L, DWORK(PDI), N*L, IERR ) CALL MA02AD( 'Lower', L-1, L, DWORK(PDI+1), N*L, $ DWORK((2*N-1)*L+1), N*L ) CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PDI+1), N*L ) CALL DLACPY( 'Upper', L, L, DWORK(PDI), N*L, DWORK(PNR), N*L ) CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PNR+1), N*L ) CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PPR), N*L ) CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PNR+N*L*L), N*L ) C PPI = PPR PPR = PPR + L PNI = PNR PNR = PNR + L PDW = 2*N*L*( L + K ) + 1 LEN = ( N - 1 )*L C C Determine block size for the involved block Householder C transformations. C NB = MIN( ( LDWORK - PDW - 6*L + 1 ) / ( N*L ), L ) NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', N*L, L, -1, -1 ) ) IF ( NB.LT.NBMIN ) NB = 0 C DO 50 I = L + 1, N*L, L CALL MB02CU( 'Column', L, L+K, L+K, NB, DWORK, N*L, DWORK(PPR), $ N*L, DWORK(PNR), N*L, RNK, IPVT, DWORK(PDW), ZERO, $ DWORK(PDW+6*L), LDWORK-PDW-6*L+1, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The rank condition is (numerically) not C satisfied. C INFO = 1 RETURN END IF CALL MB02CV( 'Column', 'NoStructure', L, LEN-L, L+K, L+K, NB, $ -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L, $ DWORK(L+1), N*L, DWORK(PPR+L), N*L, DWORK(PNR+L), $ N*L, DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, $ IERR ) PDI = PDI - L IF ( COMPO ) THEN C C Block Gaussian elimination to B. C CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', $ L, RB, -ONE, DWORK, N*L, B(I,1), LDB ) IF ( LEN.GT.L ) THEN CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RB, L, $ ONE, DWORK(L+1), N*L, B(I,1), LDB, ONE, $ B(I+L,1), LDB ) END IF END IF IF ( COMPU ) THEN C C Block Gaussian elimination to C. C CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', $ L, RC, -ONE, DWORK, N*L, C(I,1), LDC ) IF ( LEN.GT.L ) THEN CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RC, L, $ ONE, DWORK(L+1), N*L, C(I,1), LDC, ONE, $ C(I+L,1), LDC ) END IF END IF CALL DLASET( 'All', L, L, ZERO, ZERO, DWORK(PDI), N*L ) CALL MB02CV( 'Column', 'Triangular', L, I+L-1, L+K, L+K, NB, $ -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L, $ DWORK(PDI), N*L, DWORK(PPI), N*L, DWORK(PNI), N*L, $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, $ IERR ) IF ( COMPO ) THEN C C Apply block Gaussian elimination to B. C CALL DGEMM( 'NoTranspose', 'NoTranspose', I-1, RB, L, ONE, $ DWORK(PDI), N*L, B(I,1), LDB, ONE, B, LDB ) CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L, $ RB, ONE, DWORK((N-1)*L+1), N*L, B(I,1), LDB ) END IF IF ( COMPU ) THEN C C Apply block Gaussian elimination to C. C CALL DGEMM( 'NonTranspose', 'NonTranspose', I-1, RC, L, ONE, $ DWORK(PDI), N*L, C(I,1), LDC, ONE, C, LDC ) CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L, $ RC, ONE, DWORK((N-1)*L+1), N*L, C(I,1), LDC ) END IF LEN = LEN - L PNR = PNR + L PPR = PPR + L 50 CONTINUE C IF ( COMPU ) THEN CALL MB02KD( 'Column', 'NonTranspose', K, L, M, N, RC, ONE, $ ZERO, TC, LDTC, TR, LDTR, C, LDC, DWORK, M*K, $ DWORK(M*K*RC+1), LDWORK-M*K*RC, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(M*K*RC+1) ) + M*K*RC ) CALL DLACPY( 'All', M*K, RC, DWORK, M*K, C, LDC ) END IF DWORK(1) = DBLE( WRKOPT ) RETURN C C *** Last line of MB02ID *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01ND.f0000644000000000000000000000013215012430707016152 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/IB01ND.f0000644000175000017500000006572615012430707017366 0ustar00lilgelilge00000000000000 SUBROUTINE IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, TOL, IWORK, $ DWORK, LDWORK, IWARN, INFO ) C C PURPOSE C C To find the singular value decomposition (SVD) giving the system C order, using the triangular factor of the concatenated block C Hankel matrices. Related preliminary calculations needed for C computing the system matrices are also performed. C C ARGUMENTS C C Mode Parameters C C METH CHARACTER*1 C Specifies the subspace identification method to be used, C as follows: C = 'M': MOESP algorithm with past inputs and outputs; C = 'N': N4SID algorithm. C C JOBD CHARACTER*1 C Specifies whether or not the matrices B and D should later C be computed using the MOESP approach, as follows: C = 'M': the matrices B and D should later be computed C using the MOESP approach; C = 'N': the matrices B and D should not be computed using C the MOESP approach. C This parameter is not relevant for METH = 'N'. C C Input/Output Parameters C C NOBR (input) INTEGER C The number of block rows, s, in the input and output C block Hankel matrices. NOBR > 0. C C M (input) INTEGER C The number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L > 0. C C R (input/output) DOUBLE PRECISION array, dimension C ( LDR,2*(M+L)*NOBR ) C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper C triangular part of this array must contain the upper C triangular factor R from the QR factorization of the C concatenated block Hankel matrices. Denote R_ij, C i,j = 1:4, the ij submatrix of R, partitioned by C M*NOBR, M*NOBR, L*NOBR, and L*NOBR rows and columns. C On exit, if INFO = 0, the leading C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this C array contains the matrix S, the processed upper C triangular factor R, as required by other subroutines. C Specifically, let S_ij, i,j = 1:4, be the ij submatrix C of S, partitioned by M*NOBR, L*NOBR, M*NOBR, and C L*NOBR rows and columns. The submatrix S_22 contains C the matrix of left singular vectors needed subsequently. C Useful information is stored in S_11 and in the C block-column S_14 : S_44. For METH = 'M' and JOBD = 'M', C the upper triangular part of S_31 contains the upper C triangular factor in the QR factorization of the matrix C R_1c = [ R_12' R_22' R_11' ]', and S_12 contains the C corresponding leading part of the transformed matrix C R_2c = [ R_13' R_23' R_14' ]'. For METH = 'N', the C subarray S_41 : S_43 contains the transpose of the C matrix contained in S_14 : S_34. C C LDR INTEGER C The leading dimension of the array R. C LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ), C for METH = 'M' and JOBD = 'M'; C LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or C for METH = 'N'. C C SV (output) DOUBLE PRECISION array, dimension ( L*NOBR ) C The singular values of the relevant part of the triangular C factor from the QR factorization of the concatenated block C Hankel matrices. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used for estimating the rank of C matrices. If the user sets TOL > 0, then the given value C of TOL is used as a lower bound for the reciprocal C condition number; an m-by-n matrix whose estimated C condition number is less than 1/TOL is considered to C be of full rank. If the user sets TOL <= 0, then an C implicitly computed, default tolerance, defined by C TOLDEF = m*n*EPS, is used instead, where EPS is the C relative machine precision (see LAPACK Library routine C DLAMCH). C This parameter is not used for METH = 'M'. C C Workspace C C IWORK INTEGER array, dimension ((M+L)*NOBR) C This parameter is not referenced for METH = 'M'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK, and, for METH = 'N', DWORK(2) and DWORK(3) C contain the reciprocal condition numbers of the C triangular factors of the matrices U_f and r_1 [6]. C On exit, if INFO = -12, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ), C if METH = 'M' and JOBD = 'M'; C LDWORK >= 5*L*NOBR, if METH = 'M' and JOBD = 'N'; C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N'. C For good performance, LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 4: the least squares problems with coefficient matrix C U_f, used for computing the weighted oblique C projection (for METH = 'N'), have a rank-deficient C coefficient matrix; C = 5: the least squares problem with coefficient matrix C r_1 [6], used for computing the weighted oblique C projection (for METH = 'N'), has a rank-deficient C coefficient matrix. 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 = 2: the singular value decomposition (SVD) algorithm did C not converge. C C METHOD C C A singular value decomposition (SVD) of a certain matrix is C computed, which reveals the order n of the system as the number C of "non-zero" singular values. For the MOESP approach, this matrix C is [ R_24' R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s), C where R is the upper triangular factor R constructed by SLICOT C Library routine IB01MD. For the N4SID approach, a weighted C oblique projection is computed from the upper triangular factor R C and its SVD is then found. C C REFERENCES C C [1] Verhaegen M., and Dewilde, P. C Subspace Model Identification. Part 1: The output-error C state-space model identification class of algorithms. C Int. J. Control, 56, pp. 1187-1210, 1992. C C [2] Verhaegen M. C Subspace Model Identification. Part 3: Analysis of the C ordinary output-error state-space model identification C algorithm. C Int. J. Control, 58, pp. 555-586, 1993. C C [3] Verhaegen M. C Identification of the deterministic part of MIMO state space C models given in innovations form from input-output data. C Automatica, Vol.30, No.1, pp.61-74, 1994. C C [4] Van Overschee, P., and De Moor, B. C N4SID: Subspace Algorithms for the Identification of C Combined Deterministic-Stochastic Systems. C Automatica, Vol.30, No.1, pp. 75-93, 1994. C C [5] Van Overschee, P., and De Moor, B. C Subspace Identification for Linear Systems: Theory - C Implementation - Applications. C Kluwer Academic Publishers, Boston/London/Dordrecht, 1996. C C [6] Sima, V. C Subspace-based Algorithms for Multivariable System C Identification. C Studies in Informatics and Control, 5, pp. 335-344, 1996. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C 3 C The algorithm requires 0(((m+l)s) ) floating point operations. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. C C REVISIONS C C Feb. 2000, Feb. 2001, Feb. 2004, March 2005. C C KEYWORDS C C Identification methods, multivariable systems, QR decomposition, C singular value decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER INFO, IWARN, L, LDR, LDWORK, M, NOBR CHARACTER JOBD, METH C .. Array Arguments .. DOUBLE PRECISION DWORK(*), R(LDR, *), SV(*) INTEGER IWORK(*) C .. Local Scalars .. DOUBLE PRECISION EPS, RCOND1, RCOND2, SVLMAX, THRESH, TOLL INTEGER I, IERR, ITAU, ITAU2, ITAU3, J, JWORK, LLMNOB, $ LLNOBR, LMMNOB, LMNOBR, LNOBR, MAXWRK, MINWRK, $ MMNOBR, MNOBR, NR, NR2, NR3, NR4, NRSAVE, RANK, $ RANK1 LOGICAL JOBDM, MOESP, N4SID C .. Local Arrays .. DOUBLE PRECISION DUM(1), SVAL(3) C .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, ILAENV, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP, $ DTRCON, MA02AD, MB03OD, MB03UD, MB04ID, MB04IY, $ MB04OD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. C .. Executable Statements .. C C Decode the scalar input parameters. C MOESP = LSAME( METH, 'M' ) N4SID = LSAME( METH, 'N' ) JOBDM = LSAME( JOBD, 'M' ) MNOBR = M*NOBR LNOBR = L*NOBR LLNOBR = LNOBR + LNOBR LMNOBR = LNOBR + MNOBR MMNOBR = MNOBR + MNOBR LMMNOB = MMNOBR + LNOBR NR = LMNOBR + LMNOBR IWARN = 0 INFO = 0 C C Check the scalar input parameters. C IF( .NOT.( MOESP .OR. N4SID ) ) THEN INFO = -1 ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN INFO = -2 ELSE IF( NOBR.LE.0 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( L.LE.0 ) THEN INFO = -5 ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND. $ LDR.LT.3*MNOBR ) ) THEN INFO = -7 ELSE C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 MINWRK = 1 IF ( LDWORK.GE.1 ) THEN IF ( MOESP ) THEN MINWRK = 5*LNOBR IF ( JOBDM ) $ MINWRK = MAX( MMNOBR - NOBR, LMNOBR, MINWRK ) MAXWRK = LNOBR + LNOBR*ILAENV( 1, 'DGEQRF', ' ', LMNOBR, $ LNOBR, -1, -1 ) ELSE C MINWRK = MAX( MINWRK, 5*LMNOBR + 1 ) MAXWRK = MAX( MNOBR + MNOBR*ILAENV( 1, 'DGEQRF', ' ', $ MMNOBR, MNOBR, -1, -1 ), $ MNOBR + LLNOBR*ILAENV( 1, 'DORMQR', 'LT', $ MMNOBR, LLNOBR, MNOBR, -1 ) ) MAXWRK = MAX( MAXWRK, MNOBR + LNOBR*ILAENV( 1, 'DORMQR', $ 'LN', MMNOBR, LNOBR, MNOBR, $ -1 ) ) MAXWRK = MAX( MAXWRK, LNOBR + LNOBR*ILAENV( 1, 'DGEQRF', $ ' ', LMMNOB, LNOBR, -1, -1 ) ) END IF MAXWRK = MAX( MINWRK, MAXWRK ) END IF C IF( LDWORK.LT.MINWRK ) THEN INFO = -12 DWORK( 1 ) = MINWRK END IF END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB01ND', -INFO ) RETURN END IF C C Compute pointers to the needed blocks of R. C NR2 = MNOBR + 1 NR3 = MMNOBR + 1 NR4 = LMMNOB + 1 ITAU = 1 JWORK = ITAU + MNOBR C IF( MOESP ) THEN C C MOESP approach. C IF( M.GT.0 .AND. JOBDM ) THEN C C Rearrange the blocks of R: C Copy the (1,1) block into the position (3,2) and C copy the (1,4) block into (3,3). C CALL DLACPY( 'Upper', MNOBR, MNOBR, R, LDR, R(NR3,NR2), $ LDR ) CALL DLACPY( 'Full', MNOBR, LNOBR, R(1,NR4), LDR, $ R(NR3,NR3), LDR ) C C Using structure, triangularize the matrix C R_1c = [ R_12' R_22' R_11' ]' C and then apply the transformations to the matrix c R_2c = [ R_13' R_23' R_14' ]'. C Workspace: need M*NOBR + MAX(M-1,L)*NOBR. C CALL MB04OD( 'Upper', MNOBR, LNOBR, MNOBR, R(NR2,NR2), LDR, $ R(NR3,NR2), LDR, R(NR2,NR3), LDR, R(NR3,NR3), $ LDR, DWORK(ITAU), DWORK(JWORK) ) CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LNOBR, R(1,NR2), LDR, $ R(1,NR3), LDR, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Copy the leading M*NOBR x M*NOBR and M*NOBR x L*NOBR C submatrices of R_1c and R_2c, respectively, into their C final positions, required by SLICOT Library routine IB01PD. C CALL DLACPY( 'Upper', MNOBR, MNOBR, R(1,NR2), LDR, $ R(LMNOBR+1,1), LDR ) CALL DLACPY( 'Full', MNOBR, LNOBR, R(1,NR3), LDR, R(1,NR2), $ LDR ) END IF C C Copy [ R_24' R_34' ]' in [ R_22' R_32' ]'. C CALL DLACPY( 'Full', LMNOBR, LNOBR, R(NR2,NR4), LDR, $ R(NR2,NR2), LDR ) C C Triangularize the matrix in [ R_22' R_32' ]'. C Workspace: need 2*L*NOBR; prefer L*NOBR + L*NOBR*NB. C JWORK = ITAU + LNOBR CALL DGEQRF( LMNOBR, LNOBR, R(NR2,NR2), LDR, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C ELSE C C N4SID approach. C DUM(1) = ZERO LLMNOB = LLNOBR + MNOBR C C Set the precision parameters. A threshold value EPS**(2/3) is C used for deciding to use pivoting or not, where EPS is the C relative machine precision (see LAPACK Library routine DLAMCH). C TOLL = TOL EPS = DLAMCH( 'Precision' ) THRESH = EPS**( TWO/THREE ) C IF( M.GT.0 ) THEN C C For efficiency of later calculations, interchange the first C two block-columns. The corresponding submatrices are C redefined according to their new position. C DO 10 I = 1, MNOBR CALL DSWAP( I, R(1,I), 1, R(1,MNOBR+I), 1 ) CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(I+1,I), 1 ) CALL DCOPY( MMNOBR-I, DUM, 0, R(I+1,MNOBR+I), 1 ) 10 CONTINUE C C Now, C C U_f = [ R_11' R_21' 0 0 ]', C U_p = [ R_12' 0 0 0 ]', C Y_p = [ R_13' R_23' R_33' 0 ]', and C Y_f = [ R_14' R_24' R_34' R_44' ]', C C where R_21, R_12, R_33, and R_44 are upper triangular. C Define W_p := [ U_p Y_p ]. C C Prepare the computation of residuals of the two least C squares problems giving the weighted oblique projection P: C C r_1 = W_p - U_f X_1, X_1 = arg min || U_f X - W_p ||, C r_2 = Y_f - U_f X_2, X_2 = arg min || U_f X - Y_f ||, C C P = (arg min || r_1 X - r_2 ||)' r_1'. (1) C C Alternately, P' is given by the projection C P' = Q_1 (Q_1)' r_2, C where Q_1 contains the first k columns of the orthogonal C matrix in the QR factorization of r_1, k := rank(r_1). C C Triangularize the matrix U_f = q r (using structure), and C apply the transformation q' to the corresponding part of C the matrices W_p, and Y_f. C Workspace: need 2*(M+L)*NOBR. C CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LLMNOB, R, LDR, $ R(1,NR2), LDR, DWORK(ITAU), DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Save updated Y_f (transposed) in the last block-row of R. C CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), $ LDR ) C C Check the condition of the triangular factor r and decide C to use pivoting or not. C Workspace: need 4*M*NOBR. C CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBR, R, LDR, $ RCOND1, DWORK(JWORK), IWORK, IERR ) C IF( TOLL.LE.ZERO ) $ TOLL = MNOBR*MNOBR*EPS IF ( RCOND1.GT.MAX( TOLL, THRESH ) ) THEN C C U_f is considered full rank and no pivoting is used. C CALL DLASET( 'Full', MNOBR, LLMNOB, ZERO, ZERO, R(1,NR2), $ LDR ) ELSE C C Save information about q in the (2,1) block of R. C Use QR factorization with column pivoting, r P = Q R. C Information on Q is stored in the strict lower triangle C of R_11 and in DWORK(ITAU2). C DO 20 I = 1, MNOBR - 1 DO 15 J = MMNOBR, NR2, -1 R(J,I) = R(J-MNOBR+I,I) 15 CONTINUE CALL DCOPY( MNOBR-I, DUM, 0, R(I+1,I), 1 ) IWORK(I) = 0 20 CONTINUE C IWORK(MNOBR) = 0 C C Workspace: need 5*M*NOBR+1. C prefer 4*M*NOBR + (M*NOBR+1)*NB. C ITAU2 = JWORK JWORK = ITAU2 + MNOBR SVLMAX = ZERO CALL MB03OD( 'QR', MNOBR, MNOBR, R, LDR, IWORK, TOLL, $ SVLMAX, DWORK(ITAU2), RANK, SVAL, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Workspace: need 2*M*NOBR + (M+2*L)*NOBR; C prefer 2*M*NOBR + (M+2*L)*NOBR*NB. C CALL DORMQR( 'Left', 'Transpose', MNOBR, LLMNOB, MNOBR, $ R, LDR, DWORK(ITAU2), R(1,NR2), LDR, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) IF ( RANK.LT.MNOBR ) THEN C C The least squares problem is rank-deficient. C IWARN = 4 END IF C C Determine residuals r_1 and r_2: premultiply by Q and C then by q. C Workspace: need 2*M*NOBR + (M+2*L)*NOBR); C prefer 2*M*NOBR + (M+2*L)*NOBR*NB. C CALL DLASET( 'Full', RANK, LLMNOB, ZERO, ZERO, R(1,NR2), $ LDR ) CALL DORMQR( 'Left', 'NoTranspose', MNOBR, LLMNOB, MNOBR, $ R, LDR, DWORK(ITAU2), R(1,NR2), LDR, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) JWORK = ITAU2 C C Restore the transformation q. C DO 30 I = 1, MNOBR - 1 DO 25 J = NR2, MMNOBR R(J-MNOBR+I,I) = R(J,I) 25 CONTINUE 30 CONTINUE C END IF C C Premultiply by the transformation q (apply transformations C in backward order). C Workspace: need M*NOBR + (M+2*L)*NOBR; C prefer larger. C CALL MB04IY( 'Left', 'NoTranspose', MMNOBR, LLMNOB, MNOBR, $ MNOBR-1, R, LDR, DWORK(ITAU), R(1,NR2), LDR, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C ELSE C C Save Y_f (transposed) in the last block-row of R. C CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), $ LDR ) RCOND1 = ONE END IF C C Triangularize the matrix r_1 for determining the oblique C projection P in least squares problem in (1). Exploit the C fact that the third block-row of r_1 has the structure C [ 0 T ], where T is an upper triangular matrix. Then apply C the corresponding transformations Q' to the matrix r_2. C Workspace: need 2*M*NOBR; C prefer M*NOBR + M*NOBR*NB. C CALL DGEQRF( MMNOBR, MNOBR, R(1,NR2), LDR, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C C Workspace: need M*NOBR + 2*L*NOBR; C prefer M*NOBR + 2*L*NOBR*NB. C CALL DORMQR( 'Left', 'Transpose', MMNOBR, LLNOBR, MNOBR, $ R(1,NR2), LDR, DWORK(ITAU), R(1,NR3), LDR, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) NRSAVE = NR2 C ITAU2 = JWORK JWORK = ITAU2 + LNOBR CALL MB04ID( LMNOBR, LNOBR, LNOBR-1, LNOBR, R(NR2,NR3), LDR, $ R(NR2,NR4), LDR, DWORK(ITAU2), DWORK(JWORK), $ LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Check the condition of the triangular matrix of order (m+l)*s C just determined, and decide to use pivoting or not. C Workspace: need 4*(M+L)*NOBR. C CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LMNOBR, R(1,NR2), $ LDR, RCOND2, DWORK(JWORK), IWORK, IERR ) C IF( TOL.LE.ZERO ) $ TOLL = LMNOBR*LMNOBR*EPS IF ( RCOND2.LE.MAX( TOLL, THRESH ) ) THEN IF ( M.GT.0 ) THEN C C Save information about Q in R_11 (in the strict lower C triangle), R_21 and R_31 (transposed information). C CALL DLACPY( 'Lower', MMNOBR-1, MNOBR, R(2,NR2), LDR, $ R(2,1), LDR ) NRSAVE = 1 C DO 40 I = NR2, LMNOBR CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(MNOBR+I,1), $ LDR ) 40 CONTINUE C END IF C CALL DLASET( 'Lower', LMNOBR-1, LMNOBR-1, ZERO, ZERO, $ R(2,NR2), LDR ) C C Use QR factorization with column pivoting. C Workspace: need 5*(M+L)*NOBR+1. C prefer 4*(M+L)*NOBR + ((M+L)*NOBR+1)*NB. C DO 50 I = 1, LMNOBR IWORK(I) = 0 50 CONTINUE C ITAU3 = JWORK JWORK = ITAU3 + LMNOBR SVLMAX = ZERO CALL MB03OD( 'QR', LMNOBR, LMNOBR, R(1,NR2), LDR, IWORK, $ TOLL, SVLMAX, DWORK(ITAU3), RANK1, SVAL, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Workspace: need 2*(M+L)*NOBR + L*NOBR; C prefer 2*(M+L)*NOBR + L*NOBR*NB. C CALL DORMQR( 'Left', 'Transpose', LMNOBR, LNOBR, LMNOBR, $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) IF ( RANK1.LT.LMNOBR ) THEN C C The least squares problem is rank-deficient. C IWARN = 5 END IF C C Apply the orthogonal transformations, in backward order, to C [r_2(1:rank(r_1),:)' 0]', to obtain P'. C Workspace: need 2*(M+L)*NOBR + L*NOBR; C prefer 2*(M+L)*NOBR + L*NOBR*NB. C CALL DLASET( 'Full', LMNOBR-RANK1, LNOBR, ZERO, ZERO, $ R(RANK1+1,NR4), LDR ) CALL DORMQR( 'Left', 'NoTranspose', LMNOBR, LNOBR, LMNOBR, $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) JWORK = ITAU3 C IF ( M.GT.0 ) THEN C C Restore the saved transpose matrix from R_31. C DO 60 I = NR2, LMNOBR CALL DCOPY( MNOBR, R(MNOBR+I,1), LDR, R(I+1,MNOBR+I), $ 1 ) 60 CONTINUE C END IF C END IF C C Workspace: need M*NOBR + L*NOBR; C prefer larger. C CALL MB04IY( 'Left', 'NoTranspose', LMNOBR, LNOBR, LNOBR, $ LNOBR-1, R(NR2,NR3), LDR, DWORK(ITAU2), $ R(NR2,NR4), LDR, DWORK(JWORK), LDWORK-JWORK+1, $ IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Workspace: need M*NOBR + L*NOBR; C prefer M*NOBR + L*NOBR*NB. C JWORK = ITAU2 CALL DORMQR( 'Left', 'NoTranspose', MMNOBR, LNOBR, MNOBR, $ R(1,NRSAVE), LDR, DWORK(ITAU), R(1,NR4), LDR, $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C C Now, the matrix P' is available in R_14 : R_34. C Triangularize the matrix P'. C Workspace: need 2*L*NOBR; C prefer L*NOBR + L*NOBR*NB. C JWORK = ITAU + LNOBR CALL DGEQRF( LMMNOB, LNOBR, R(1,NR4), LDR, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C C Copy the triangular factor to its final position, R_22. C CALL DLACPY( 'Upper', LNOBR, LNOBR, R(1,NR4), LDR, R(NR2,NR2), $ LDR ) C C Restore Y_f. C CALL MA02AD( 'Full', LNOBR, LMMNOB, R(NR4,1), LDR, R(1,NR4), $ LDR ) END IF C C Find the singular value decomposition of R_22. C Workspace: need 5*L*NOBR. C CALL MB03UD( 'NoVectors', 'Vectors', LNOBR, R(NR2,NR2), LDR, $ DUM, 1, SV, DWORK, LDWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 2 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C C Transpose R(m*s+1:(m+L)*s,m*s+1:(m+L)*s) in-situ; its C columns will then be the singular vectors needed subsequently. C DO 70 I = NR2+1, LMNOBR CALL DSWAP( LMNOBR-I+1, R(I,I-1), 1, R(I-1,I), LDR ) 70 CONTINUE C C Return optimal workspace in DWORK(1) and reciprocal condition C numbers, if METH = 'N'. C DWORK(1) = MAXWRK IF ( N4SID ) THEN DWORK(2) = RCOND1 DWORK(3) = RCOND2 END IF RETURN C C *** Last line of IB01ND *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09IY.f0000644000000000000000000000013215012430707016172 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09IY.f0000644000175000017500000007550215012430707017377 0ustar00lilgelilge00000000000000 SUBROUTINE AB09IY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NV, PV, $ NW, MW, ALPHAC, ALPHAO, A, LDA, B, LDB, C, LDC, $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, $ SCALEC, SCALEO, S, LDS, R, LDR, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To compute for given state-space representations C (A,B,C,0), (AV,BV,CV,DV), and (AW,BW,CW,DW) of the C transfer-function matrices G, V and W, respectively, C the Cholesky factors of the frequency-weighted C controllability and observability Grammians corresponding C to a frequency-weighted model reduction problem. C G, V and W must be stable transfer-function matrices with C the state matrices A, AV, and AW in real Schur form. C It is assumed that the state space realizations (AV,BV,CV,DV) C and (AW,BW,CW,DW) are minimal. In case of possible pole-zero C cancellations in forming V*G and/or G*W, the parameters for the C choice of frequency-weighted Grammians ALPHAO and/or ALPHAC, C respectively, must be different from 1. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of the systems as follows: C = 'C': G, V and W are continuous-time systems; C = 'D': G, V and W are discrete-time systems. C C JOBC CHARACTER*1 C Specifies the choice of frequency-weighted controllability C Grammian as follows: C = 'S': choice corresponding to a combination method [4] C of the approaches of Enns [1] and Lin-Chiu [2,3]; C = 'E': choice corresponding to the stability enhanced C modified combination method of [4]. C C JOBO CHARACTER*1 C Specifies the choice of frequency-weighted observability C Grammian as follows: C = 'S': choice corresponding to a combination method [4] C of the approaches of Enns [1] and Lin-Chiu [2,3]; C = 'E': choice corresponding to the stability enhanced C modified combination method of [4]. C C WEIGHT CHARACTER*1 C Specifies the type of frequency weighting, as follows: C = 'N': no weightings are used (V = I, W = I); C = 'L': only left weighting V is used (W = I); C = 'R': only right weighting W is used (V = I); C = 'B': both left and right weightings V and W are used. C C Input/Output Parameters C C N (input) INTEGER C The order of the state-space representation of G, i.e., C the order of the matrix A. N >= 0. C C M (input) INTEGER C The number of columns of the matrix B and C the number of rows of the matrices CW and DW. M >= 0. C M represents the dimension of the input vector of the C system with the transfer-function matrix G and C also the dimension of the output vector of the system C with the transfer-function matrix W. C C P (input) INTEGER C The number of rows of the matrix C and the C number of columns of the matrices BV and DV. P >= 0. C P represents the dimension of the output vector of the C system with the transfer-function matrix G and C also the dimension of the input vector of the system C with the transfer-function matrix V. C C NV (input) INTEGER C The order of the matrix AV. Also the number of rows of C the matrix BV and the number of columns of the matrix CV. C NV represents the dimension of the state vector of the C system with the transfer-function matrix V. NV >= 0. C C PV (input) INTEGER C The number of rows of the matrices CV and DV. PV >= 0. C PV represents the dimension of the output vector of the C system with the transfer-function matrix V. C C NW (input) INTEGER C The order of the matrix AW. Also the number of rows of C the matrix BW and the number of columns of the matrix CW. C NW represents the dimension of the state vector of the C system with the transfer-function matrix W. NW >= 0. C C MW (input) INTEGER C The number of columns of the matrices BW and DW. MW >= 0. C MW represents the dimension of the input vector of the C system with the transfer-function matrix W. C C ALPHAC (input) DOUBLE PRECISION C Combination method parameter for defining the C frequency-weighted controllability Grammian (see METHOD); C ABS(ALPHAC) <= 1. C C ALPHAO (input) DOUBLE PRECISION C Combination method parameter for defining the C frequency-weighted observability Grammian (see METHOD); C ABS(ALPHAO) <= 1. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must C contain the state matrix A (of the system with the C transfer-function matrix G) in a real Schur form. 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. 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. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C AV (input) DOUBLE PRECISION array, dimension (LDAV,NV) C If WEIGHT = 'L' or 'B', the leading NV-by-NV part of this C array must contain the state matrix AV (of the system with C the transfer-function matrix V) in a real Schur form. C AV is not referenced if WEIGHT = 'R' or 'N'. C C LDAV INTEGER C The leading dimension of array AV. C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; C LDAV >= 1, if WEIGHT = 'R' or 'N'. C C BV (input) DOUBLE PRECISION array, dimension (LDBV,P) C If WEIGHT = 'L' or 'B', the leading NV-by-P part of this C array must contain the input matrix BV of the system with C the transfer-function matrix V. C BV is not referenced if WEIGHT = 'R' or 'N'. C C LDBV INTEGER C The leading dimension of array BV. C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; C LDBV >= 1, if WEIGHT = 'R' or 'N'. C C CV (input) DOUBLE PRECISION array, dimension (LDCV,NV) C If WEIGHT = 'L' or 'B', the leading PV-by-NV part of this C array must contain the output matrix CV of the system with C the transfer-function matrix V. C CV is not referenced if WEIGHT = 'R' or 'N'. C C LDCV INTEGER C The leading dimension of array CV. C LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; C LDCV >= 1, if WEIGHT = 'R' or 'N'. C C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) C If WEIGHT = 'L' or 'B', the leading PV-by-P part of this C array must contain the feedthrough matrix DV of the system C with the transfer-function matrix V. C DV is not referenced if WEIGHT = 'R' or 'N'. C C LDDV INTEGER C The leading dimension of array DV. C LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; C LDDV >= 1, if WEIGHT = 'R' or 'N'. C C AW (input) DOUBLE PRECISION array, dimension (LDAW,NW) C If WEIGHT = 'R' or 'B', the leading NW-by-NW part of this C array must contain the state matrix AW (of the system with C the transfer-function matrix W) in a real Schur form. C AW is not referenced if WEIGHT = 'L' or 'N'. C C LDAW INTEGER C The leading dimension of array AW. C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; C LDAW >= 1, if WEIGHT = 'L' or 'N'. C C BW (input) DOUBLE PRECISION array, dimension (LDBW,MW) C If WEIGHT = 'R' or 'B', the leading NW-by-MW part of this C array must contain the input matrix BW of the system with C the transfer-function matrix W. C BW is not referenced if WEIGHT = 'L' or 'N'. C C LDBW INTEGER C The leading dimension of array BW. C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; C LDBW >= 1, if WEIGHT = 'L' or 'N'. C C CW (input) DOUBLE PRECISION array, dimension (LDCW,NW) C If WEIGHT = 'R' or 'B', the leading M-by-NW part of this C array must contain the output matrix CW of the system with C the transfer-function matrix W. C CW is not referenced if WEIGHT = 'L' or 'N'. C C LDCW INTEGER C The leading dimension of array CW. C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; C LDCW >= 1, if WEIGHT = 'L' or 'N'. C C DW (input) DOUBLE PRECISION array, dimension (LDDW,MW) C If WEIGHT = 'R' or 'B', the leading M-by-MW part of this C array must contain the feedthrough matrix DW of the system C with the transfer-function matrix W. C DW is not referenced if WEIGHT = 'L' or 'N'. C C LDDW INTEGER C The leading dimension of array DW. C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; C LDDW >= 1, if WEIGHT = 'L' or 'N'. C C SCALEC (output) DOUBLE PRECISION C Scaling factor for the controllability Grammian in (1) C or (3). See METHOD. C C SCALEO (output) DOUBLE PRECISION C Scaling factor for the observability Grammian in (2) C or (4). See METHOD. C C S (output) DOUBLE PRECISION array, dimension (LDS,N) C The leading N-by-N upper triangular part of this array C contains the Cholesky factor S of the frequency-weighted C cotrollability Grammian P = S*S'. See METHOD. C C LDS INTEGER C The leading dimension of array S. LDS >= MAX(1,N). C C R (output) DOUBLE PRECISION array, dimension (LDR,N) C The leading N-by-N upper triangular part of this array C contains the Cholesky factor R of the frequency-weighted C observability Grammian Q = R'*R. See METHOD. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). 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 length of the array DWORK. C LDWORK >= MAX( 1, LLEFT, LRIGHT ), C where C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) C if WEIGHT = 'L' or 'B' and PV > 0; C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) C if WEIGHT = 'R' or 'B' and MW > 0; C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. 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: if the state matrices A and/or AV are not stable or C not in a real Schur form; C = 2: if the state matrices A and/or AW are not stable or C not in a real Schur form; C = 3: eigenvalues computation failure. C C METHOD C C Let Pi = Si*Si' and Qo = Ro'*Ro be the Cholesky factored C controllability and observability Grammians satisfying C in the continuous-time case C C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, (1) C C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, (2) C C and in the discrete-time case C C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0, (3) C C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0, (4) C C where C C Ai = ( A B*Cw ) , Bi = ( B*Dw ) , C ( 0 Aw ) ( Bw ) C C Ao = ( A 0 ) , Co = ( Dv*C Cv ) . C ( Bv*C Av ) C C Consider the partitioned Grammians C C Pi = ( P11 P12 ) and Qo = ( Q11 Q12 ) , C ( P12' P22 ) ( Q12' Q22 ) C C where P11 and Q11 are the leading N-by-N parts of Pi and Qo, C respectively, and let P0 and Q0 be non-negative definite matrices C defined in the combination method [4] C -1 C P0 = P11 - ALPHAC**2*P12*P22 *P21 , C -1 C Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21. C C The frequency-weighted controllability and observability C Grammians, P and Q, respectively, are defined as follows: C P = P0 if JOBC = 'S' (standard combination method [4]); C P = P1 >= P0 if JOBC = 'E', where P1 is the controllability C Grammian defined to enforce stability for a modified combination C method of [4]; C Q = Q0 if JOBO = 'S' (standard combination method [4]); C Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability C Grammian defined to enforce stability for a modified combination C method of [4]. C C If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of C Grammians corresponds to the method of Enns [1], while if C ALPHAC = ALPHAO = 1, the choice of Grammians corresponds to the C method of Lin and Chiu [2,3]. C C The routine computes directly the Cholesky factors S and R C such that P = S*S' and Q = R'*R according to formulas C developed in [4]. No matrix inversions are involved. C C REFERENCES C C [1] Enns, D. C Model reduction with balanced realizations: An error bound C and a frequency weighted generalization. C Proc. CDC, Las Vegas, pp. 127-132, 1984. C C [2] Lin, C.-A. and Chiu, T.-Y. C Model reduction via frequency-weighted balanced realization. C Control Theory and Advanced Technology, vol. 8, C pp. 341-351, 1992. C C [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. C New results on frequency weighted balanced reduction C technique. C Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. C C [4] Varga, A. and Anderson, B.D.O. C Square-root balancing-free methods for the frequency-weighted C balancing related model reduction. C (report in preparation) C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. C D. Sima, University of Bucharest, August 2000. C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. C C REVISIONS C C A. Varga, Australian National University, Canberra, November 2000. C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2001. C C KEYWORDS C C Frequency weighting, model reduction, multivariable system, C state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, JOBC, JOBO, WEIGHT INTEGER INFO, LDA, LDAV, LDAW, LDB, LDBV, LDBW, $ LDC, LDCV, LDCW, LDDV, LDDW, LDR, LDS, LDWORK, $ M, MW, N, NV, NW, P, PV DOUBLE PRECISION ALPHAC, ALPHAO, SCALEC, SCALEO C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), $ DV(LDDV,*), DW(LDDW,*), $ DWORK(*), R(LDR,*), S(LDS,*) C .. Local Scalars .. LOGICAL DISCR, FRWGHT, LEFTW, RIGHTW INTEGER I, IERR, J, KAW, KTAU, KU, KW, LDU, LW, MBBAR, $ NNV, NNW, PCBAR DOUBLE PRECISION T, TOL, WORK C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DLACPY, DLASET, DSCAL, DSYEV, $ MB01WD, MB04ND, MB04OD, SB03OU, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT C .. Executable Statements .. C DISCR = LSAME( DICO, 'D' ) LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) FRWGHT = LEFTW .OR. RIGHTW C INFO = 0 LW = 1 NNV = N + NV NNW = N + NW IF( LEFTW .AND. PV.GT.0 ) THEN LW = MAX( LW, NNV*( NNV + MAX( NNV, PV ) + 5 ) ) ELSE LW = MAX( LW, N*( P + 5 ) ) END IF IF( RIGHTW .AND. MW.GT.0 ) THEN LW = MAX( LW, NNW*( NNW + MAX( NNW, MW ) + 5 ) ) ELSE LW = MAX( LW, N*( M + 5 ) ) END IF C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) $ THEN INFO = -2 ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) $ THEN INFO = -3 ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) 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( NV.LT.0 ) THEN INFO = -8 ELSE IF( PV.LT.0 ) THEN INFO = -9 ELSE IF( NW.LT.0 ) THEN INFO = -10 ELSE IF( MW.LT.0 ) THEN INFO = -11 ELSE IF( ABS( ALPHAC ).GT.ONE ) THEN INFO = -12 ELSE IF( ABS( ALPHAO ).GT.ONE ) THEN INFO = -13 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -19 ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN INFO = -21 ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN INFO = -23 ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.PV ) ) THEN INFO = -25 ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.PV ) ) THEN INFO = -27 ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN INFO = -29 ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN INFO = -31 ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN INFO = -33 ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN INFO = -35 ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -39 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -41 ELSE IF( LDWORK.LT.LW ) THEN INFO = -43 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09IY', -INFO ) RETURN END IF C C Quick return if possible. C SCALEC = ONE SCALEO = ONE IF( MIN( N, M, P ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C WORK = 1 IF( LEFTW .AND. PV.GT.0 ) THEN C C Build the extended permuted matrices C C Ao = ( Av Bv*C ) , Co = ( Cv Dv*C ) . C ( 0 A ) C KAW = 1 KU = KAW + NNV*NNV LDU = MAX( NNV, PV ) CALL DLACPY( 'Full', NV, NV, AV, LDAV, DWORK(KAW), NNV ) CALL DLASET( 'Full', N, NV, ZERO, ZERO, DWORK(KAW+NV), NNV ) CALL DGEMM( 'No-transpose', 'No-transpose', NV, N, P, ONE, $ BV, LDBV, C, LDC, ZERO, DWORK(KAW+NNV*NV), NNV ) CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW+NNV*NV+NV), NNV ) C CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KU), LDU ) CALL DGEMM( 'No-transpose', 'No-transpose', PV, N, P, ONE, $ DV, LDDV, C, LDC, ZERO, DWORK(KU+LDU*NV), LDU ) C C Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro, C the continuous-time Lyapunov equation (if DICO = 'C') C C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0. C C Workspace: need (N+NV)*(N+NV+MAX(N+NV,PV)+5); C prefer larger. C KTAU = KU + LDU*NNV KW = KTAU + NNV C CALL SB03OU( DISCR, .FALSE., NNV, PV, DWORK(KAW), NNV, $ DWORK(KU), LDU, DWORK(KTAU), DWORK(KU), LDU, $ SCALEO, DWORK(KW), LDWORK-KW+1, IERR ) C IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) C C Partition Ro as Ro = ( R11 R12 ) and compute R such that C ( 0 R22 ) C C R'*R = R22'*R22 + (1-ALPHAO**2)*R12'*R12. C KW = KU + LDU*NV + NV CALL DLACPY( 'Upper', N, N, DWORK(KW), LDU, R, LDR ) IF( ALPHAO.NE.ZERO ) THEN T = SQRT( ONE - ALPHAO*ALPHAO ) DO 10 J = KU + LDU*NV, KU + LDU*(NNV-1), LDU CALL DSCAL( NV, T, DWORK(J), 1 ) 10 CONTINUE END IF IF( ALPHAO.LT.ONE .AND. NV.GT.0 ) THEN KTAU = 1 CALL MB04OD( 'Full', N, 0, NV, R, LDR, DWORK(KU+LDU*NV), $ LDU, DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) ) C DO 30 J = 1, N DWORK(J) = R(J,J) DO 20 I = 1, J IF ( DWORK(I).LT.ZERO ) R(I,J) = -R(I,J) 20 CONTINUE 30 CONTINUE C END IF C IF( LSAME( JOBO, 'E' ) .AND. ALPHAO.LT.ONE ) THEN C C Form Y = -A'*(R'*R)-(R'*R)*A if DICO = 'C', or C Y = -A'*(R'*R)*A+(R'*R) if DICO = 'D'. C CALL DLACPY( 'Upper', N, N, R, LDR, DWORK(KU), N ) CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg', N, $ -ONE, ZERO, R, LDR, DWORK(KAW+NNV*NV+NV), NNV, $ DWORK(KU), N, IERR ) C C Compute the eigendecomposition of Y as Y = Z*Sigma*Z'. C KU = N + 1 CALL DSYEV( 'Vectors', 'Upper', N, R, LDR, DWORK, DWORK(KU), $ LDWORK-N, IERR ) IF( IERR.GT.0 ) THEN INFO = 3 RETURN END IF WORK = MAX( WORK, DWORK(KU) + DBLE( N ) ) C C Partition Sigma = (Sigma1,Sigma2), such that C Sigma1 <= 0, Sigma2 > 0. C Partition correspondingly Z = [Z1 Z2]. C TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) ) $ * DLAMCH( 'Epsilon') C _ C Form C = [ sqrt(Sigma2)*Z2' ] C PCBAR = 0 DO 40 J = 1, N IF( DWORK(J).GT.TOL ) THEN CALL DSCAL( N, SQRT( DWORK(J) ), R(1,J), 1 ) CALL DCOPY( N, R(1,J), 1, DWORK(KU+PCBAR), N ) PCBAR = PCBAR + 1 END IF 40 CONTINUE C C Solve for the Cholesky factor R of Q, Q = R'*R, C the continuous-time Lyapunov equation (if DICO = 'C') C _ _ C A'*Q + Q*A + t^2*C'*C = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C _ _ C A'*Q*A - Q + t^2*C'*C = 0. C C Workspace: need N*(N + 6); C prefer larger. C KTAU = KU + N*N KW = KTAU + N C CALL SB03OU( DISCR, .FALSE., N, PCBAR, A, LDA, DWORK(KU), N, $ DWORK(KTAU), R, LDR, T, DWORK(KW), LDWORK-KW+1, $ IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF SCALEO = SCALEO*T WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) END IF C ELSE C C Solve for the Cholesky factor R of Q, Q = R'*R, C the continuous-time Lyapunov equation (if DICO = 'C') C C A'*Q + Q*A + scaleo^2*C'*C = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C C A'*Q*A - Q + scaleo^2*C'*C = 0. C C Workspace: need N*(P + 5); C prefer larger. C KU = 1 KTAU = KU + P*N KW = KTAU + N C CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, $ DWORK(KTAU), R, LDR, SCALEO, DWORK(KW), $ LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) END IF C IF( RIGHTW .AND. MW.GT.0 ) THEN C C Build the extended matrices C C Ai = ( A B*Cw ) , Bi = ( B*Dw ) . C ( 0 Aw ) ( Bw ) C KAW = 1 KU = KAW + NNW*NNW CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), NNW ) CALL DLASET( 'Full', NW, N, ZERO, ZERO, DWORK(KAW+N), NNW ) CALL DGEMM( 'No-transpose', 'No-transpose', N, NW, M, ONE, $ B, LDB, CW, LDCW, ZERO, DWORK(KAW+NNW*N), NNW ) CALL DLACPY( 'Full', NW, NW, AW, LDAW, $ DWORK(KAW+NNW*N+N), NNW ) C CALL DGEMM( 'No-transpose', 'No-transpose', N, MW, M, ONE, $ B, LDB, DW, LDDW, ZERO, DWORK(KU), NNW ) CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KU+N), NNW ) C C Solve for the Cholesky factor Si of Pi, Pi = Si*Si', C the continuous-time Lyapunov equation (if DICO = 'C') C C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0. C C Workspace: need (N+NW)*(N+NW+MAX(N+NW,MW)+5); C prefer larger. C KTAU = KU + NNW*MAX( NNW, MW ) KW = KTAU + NNW C CALL SB03OU( DISCR, .TRUE., NNW, MW, DWORK(KAW), NNW, $ DWORK(KU), NNW, DWORK(KTAU), DWORK(KU), NNW, $ SCALEC, DWORK(KW), LDWORK-KW+1, IERR ) C IF( IERR.NE.0 ) THEN INFO = 2 RETURN END IF WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) C C Partition Si as Si = ( S11 S12 ) and compute S such that C ( 0 S22 ) C C S*S' = S11*S11' + (1-ALPHAC**2)*S12*S12'. C CALL DLACPY( 'Upper', N, N, DWORK(KU), NNW, S, LDS ) IF( ALPHAC.NE.ZERO ) THEN T = SQRT( ONE - ALPHAC*ALPHAC ) DO 50 J = KU + NNW*N, KU + NNW*(NNW-1), NNW CALL DSCAL( N, T, DWORK(J), 1 ) 50 CONTINUE END IF IF( ALPHAC.LT.ONE .AND. NW.GT.0 ) THEN KTAU = N*NNW + 1 KW = KTAU + N CALL MB04ND( 'Full', N, 0, NW, S, LDS, DWORK(KU+NNW*N), NNW, $ DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) ) C DO 70 J = 1, N IF ( S(J,J).LT.ZERO ) THEN DO 60 I = 1, J S(I,J) = -S(I,J) 60 CONTINUE END IF 70 CONTINUE END IF C IF( LSAME( JOBC, 'E' ) .AND. ALPHAC.LT.ONE ) THEN C C Form X = -A*(S*S')-(S*S')*A' if DICO = 'C', or C X = -A*(S*S')*A'+(S*S') if DICO = 'D'. C CALL DLACPY( 'Upper', N, N, S, LDS, DWORK(KU), N ) CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', N, $ -ONE, ZERO, S, LDS, DWORK(KAW), NNW, DWORK(KU), $ N, IERR ) C C Compute the eigendecomposition of X as X = Z*Sigma*Z'. C KU = N + 1 CALL DSYEV( 'Vectors', 'Upper', N, S, LDS, DWORK, DWORK(KU), $ LDWORK-N, IERR ) IF( IERR.GT.0 ) THEN INFO = 3 RETURN END IF WORK = MAX( WORK, DWORK(KU) + DBLE( N ) ) C C Partition Sigma = (Sigma1,Sigma2), such that C Sigma1 =< 0, Sigma2 > 0. C Partition correspondingly Z = [Z1 Z2]. C TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) ) $ * DLAMCH( 'Epsilon') C _ C Form B = [ Z2*sqrt(Sigma2) ] C MBBAR = 0 I = KU DO 80 J = 1, N IF( DWORK(J).GT.TOL ) THEN MBBAR = MBBAR + 1 CALL DSCAL( N, SQRT( DWORK(J) ), S(1,J), 1 ) CALL DCOPY( N, S(1,J), 1, DWORK(I), 1 ) I = I + N END IF 80 CONTINUE C C Solve for the Cholesky factor S of P, P = S*S', C the continuous-time Lyapunov equation (if DICO = 'C') C _ _ C A*P + P*A' + t^2*B*B' = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C _ _ C A*P*A' - P + t^2*B*B' = 0. C C Workspace: need maximum N*(N + 6); C prefer larger. C KTAU = KU + MBBAR*N KW = KTAU + N C CALL SB03OU( DISCR, .TRUE., N, MBBAR, A, LDA, DWORK(KU), N, $ DWORK(KTAU), S, LDS, T, DWORK(KW), LDWORK-KW+1, $ IERR ) IF( IERR.NE.0 ) THEN INFO = 2 RETURN END IF SCALEC = SCALEC*T WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) END IF C ELSE C C Solve for the Cholesky factor S of P, P = S*S', C the continuous-time Lyapunov equation (if DICO = 'C') C C A*P + P*A' + scalec^2*B*B' = 0, C C or the discrete-time Lyapunov equation (if DICO = 'D') C C A*P*A' - P + scalec^2*B*B' = 0. C C Workspace: need N*(M+5); C prefer larger. C KU = 1 KTAU = KU + N*M KW = KTAU + N C CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, $ DWORK(KTAU), S, LDS, SCALEC, DWORK(KW), $ LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 2 RETURN END IF WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) END IF C C Save optimal workspace. C DWORK(1) = WORK C RETURN C *** Last line of AB09IY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02MR.f0000644000000000000000000000013015012430707016200 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB02MR.f0000644000175000017500000000232215012430707017375 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION SB02MR( REIG, IEIG ) C C PURPOSE C C To select the unstable eigenvalues for solving the continuous-time C algebraic Riccati equation. C C ARGUMENTS C C Input/Output Parameters C C REIG (input) DOUBLE PRECISION C The real part of the current eigenvalue considered. C C IEIG (input) DOUBLE PRECISION C The imaginary part of the current eigenvalue considered. C C METHOD C C The function value SB02MR is set to .TRUE. for an unstable C eigenvalue and to .FALSE., otherwise. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C C REVISIONS C C - C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION IEIG, REIG C .. Executable Statements .. C SB02MR = REIG.GE.ZERO C RETURN C *** Last line of SB02MR *** END control-4.1.2/src/slicot/src/PaxHeaders/SB08GD.f0000644000000000000000000000013215012430707016164 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB08GD.f0000644000175000017500000001745215012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE SB08GD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, BR, $ LDBR, DR, LDDR, IWORK, DWORK, INFO ) C C PURPOSE C C To construct the state-space representation for the system C G = (A,B,C,D) from the factors Q = (AQR,BQ,CQR,DQ) and C R = (AQR,BR,CQR,DR) of its left coprime factorization C -1 C G = R * Q, C C where G, Q and R are the corresponding transfer-function matrices. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. Also the number of rows of the C matrices B and BR and the number of columns of the matrix C C. N represents the order of the systems Q and R. N >= 0. C C M (input) INTEGER C The dimension of input vector, i.e. the number of columns C of the matrices B and D. M >= 0. C C P (input) INTEGER C The dimension of output vector, i.e. the number of rows of C the matrices C, D and DR and the number of columns of the C matrices BR and DR. 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 AQR of the systems C Q and R. C On exit, the leading N-by-N part of this array contains C the state dynamics matrix of the system G. 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 BQ of the system Q. C On exit, the leading N-by-M part of this array contains C the input/state matrix of the system G. 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 CQR of the systems C Q and R. C On exit, the leading P-by-N part of this array contains C the state/output matrix of the system G. 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 DQ of the system Q. C On exit, the leading P-by-M part of this array contains C the input/output matrix of the system G. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C BR (input) DOUBLE PRECISION array, dimension (LDBR,P) C The leading N-by-P part of this array must contain the C input/state matrix BR of the system R. C C LDBR INTEGER C The leading dimension of array BR. LDBR >= MAX(1,N). C C DR (input/output) DOUBLE PRECISION array, dimension (LDDR,P) C On entry, the leading P-by-P part of this array must C contain the input/output matrix DR of the system R. C On exit, the leading P-by-P part of this array contains C the LU factorization of the matrix DR, as computed by C LAPACK Library routine DGETRF. C C LDDR INTEGER C The leading dimension of array DR. LDDR >= MAX(1,P). C C Workspace C C IWORK INTEGER array, dimension (P) C C DWORK DOUBLE PRECISION array, dimension (MAX(1,4*P)) C On exit, DWORK(1) contains an estimate of the reciprocal C condition number of the matrix DR. 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 DR is singular; C = 2: the matrix DR is numerically singular (warning); C the calculations continued. C C METHOD C C The subroutine computes the matrices of the state-space C representation G = (A,B,C,D) by using the formulas: C C -1 -1 C A = AQR - BR * DR * CQR, C = DR * CQR, C -1 -1 C B = BQ - BR * DR * DQ, D = DR * DQ. C C REFERENCES C C [1] Varga A. C Coprime factors model reduction method based on C square-root balancing-free techniques. C System Analysis, Modelling and Simulation, C vol. 11, pp. 303-311, 1993. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C July 1998. C Based on the RASP routine LCFI. C C REVISIONS C C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. C C KEYWORDS C C Coprime factorization, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDBR, LDC, LDD, LDDR, M, N, P C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), BR(LDBR,*), C(LDC,*), $ D(LDD,*), DR(LDDR,*), DWORK(*) INTEGER IWORK(*) C .. Local Scalars DOUBLE PRECISION DRNORM, RCOND C .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE C .. External Subroutines .. EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C INFO = 0 C C Check the scalar input parameters. 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -9 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -11 ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN INFO = -15 END IF IF( INFO.NE.0 )THEN C C Error return. C CALL XERBLA( 'SB08GD', -INFO ) RETURN END IF C C Quick return if possible. C IF( P.EQ.0 )THEN DWORK(1) = ONE RETURN END IF C C Factor the matrix DR. First, compute the 1-norm. C DRNORM = DLANGE( '1-norm', P, P, DR, LDDR, DWORK ) CALL DGETRF( P, P, DR, LDDR, IWORK, INFO ) IF( INFO.NE.0 ) THEN INFO = 1 DWORK(1) = ZERO RETURN END IF C -1 C Compute C = DR * CQR. C CALL DGETRS( 'NoTranspose', P, N, DR, LDDR, IWORK, C, LDC, INFO ) C -1 C Compute A = AQR - BR * DR * CQR. C CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, -ONE, BR, LDBR, $ C, LDC, ONE, A, LDA ) C -1 C Compute D = DR * DQ. C CALL DGETRS( 'NoTranspose', P, M, DR, LDDR, IWORK, D, LDD, INFO ) C -1 C Compute B = BQ - BR * DR * DQ. C CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, P, -ONE, BR, LDBR, $ D, LDD, ONE, B, LDB ) C C Estimate the reciprocal condition number of DR. C Workspace 4*P. C CALL DGECON( '1-norm', P, DR, LDDR, DRNORM, RCOND, DWORK, IWORK, $ INFO ) IF( RCOND.LE.DLAMCH( 'Epsilon' ) ) $ INFO = 2 C DWORK(1) = RCOND C RETURN C *** Last line of SB08GD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02DD.f0000644000000000000000000000013215012430707016145 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02DD.f0000644000175000017500000005116115012430707017345 0ustar00lilgelilge00000000000000 SUBROUTINE MB02DD( JOB, TYPET, K, M, N, TA, LDTA, T, LDT, G, $ LDG, R, LDR, L, LDL, CS, LCS, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To update the Cholesky factor and the generator and/or the C Cholesky factor of the inverse of a symmetric positive definite C (s.p.d.) block Toeplitz matrix T, given the information from C a previous factorization and additional blocks in TA of its first C block row, or its first block column, depending on the routine C parameter TYPET. Transformation information is stored. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the output of the routine, as follows: C = 'R': updates the generator G of the inverse and C computes the new columns / rows for the Cholesky C factor R of T; C = 'A': updates the generator G, computes the new C columns / rows for the Cholesky factor R of T and C the new rows / columns for the Cholesky factor L C of the inverse; C = 'O': only computes the new columns / rows for the C Cholesky factor R of T. C C TYPET CHARACTER*1 C Specifies the type of T, as follows: C = 'R': the first block row of an s.p.d. block Toeplitz C matrix was/is defined; if demanded, the Cholesky C factors R and L are upper and lower triangular, C respectively, and G contains the transposed C generator of the inverse; C = 'C': the first block column of an s.p.d. block Toeplitz C matrix was/is defined; if demanded, the Cholesky C factors R and L are lower and upper triangular, C respectively, and G contains the generator of the C inverse. This choice results in a column oriented C algorithm which is usually faster. C Note: in this routine, the notation x / y means that C x corresponds to TYPET = 'R' and y corresponds to C TYPET = 'C'. C C Input/Output Parameters C C K (input) INTEGER C The number of rows / columns in T, which should be equal C to the blocksize. K >= 0. C C M (input) INTEGER C The number of blocks in TA. M >= 0. C C N (input) INTEGER C The number of blocks in T. N >= 0. C C TA (input/output) DOUBLE PRECISION array, dimension C (LDTA,M*K) / (LDTA,K) C On entry, the leading K-by-M*K / M*K-by-K part of this C array must contain the (N+1)-th to (N+M)-th blocks in the C first block row / column of an s.p.d. block Toeplitz C matrix. C On exit, if INFO = 0, the leading K-by-M*K / M*K-by-K part C of this array contains information on the Householder C transformations used, such that the array C C [ T TA ] / [ T ] C [ TA ] C C serves as the new transformation matrix T for further C applications of this routine. C C LDTA INTEGER C The leading dimension of the array TA. C LDTA >= MAX(1,K), if TYPET = 'R'; C LDTA >= MAX(1,M*K), if TYPET = 'C'. C C T (input) DOUBLE PRECISION array, dimension (LDT,N*K) / C (LDT,K) C The leading K-by-N*K / N*K-by-K part of this array must C contain transformation information generated by the SLICOT C Library routine MB02CD, i.e., in the first K-by-K block, C the upper / lower Cholesky factor of T(1:K,1:K), and in C the remaining part, the Householder transformations C applied during the initial factorization process. C C LDT INTEGER C The leading dimension of the array T. C LDT >= MAX(1,K), if TYPET = 'R'; C LDT >= MAX(1,N*K), if TYPET = 'C'. C C G (input/output) DOUBLE PRECISION array, dimension C (LDG,( N + M )*K) / (LDG,2*K) C On entry, if JOB = 'R', or 'A', then the leading C 2*K-by-N*K / N*K-by-2*K part of this array must contain, C in the first K-by-K block of the second block row / C column, the lower right block of the Cholesky factor of C the inverse of T, and in the remaining part, the generator C of the inverse of T. C On exit, if INFO = 0 and JOB = 'R', or 'A', then the C leading 2*K-by-( N + M )*K / ( N + M )*K-by-2*K part of C this array contains the same information as on entry, now C for the updated Toeplitz matrix. Actually, to obtain a C generator of the inverse one has to set C G(K+1:2*K, 1:K) = 0, if TYPET = 'R'; C G(1:K, K+1:2*K) = 0, if TYPET = 'C'. C C LDG INTEGER C The leading dimension of the array G. C LDG >= MAX(1,2*K), if TYPET = 'R' and JOB = 'R', or 'A'; C LDG >= MAX(1,( N + M )*K), C if TYPET = 'C' and JOB = 'R', or 'A'; C LDG >= 1, if JOB = 'O'. C C R (input/output) DOUBLE PRECISION array, dimension C (LDR,M*K) / (LDR,( N + M )*K) C On input, the leading N*K-by-K part of R(K+1,1) / C K-by-N*K part of R(1,K+1) contains the last block column / C row of the previous Cholesky factor R. C On exit, if INFO = 0, then the leading C ( N + M )*K-by-M*K / M*K-by-( N + M )*K part of this C array contains the last M*K columns / rows of the upper / C lower Cholesky factor of T. The elements in the strictly C lower / upper triangular part are not referenced. C C LDR INTEGER C The leading dimension of the array R. C LDR >= MAX(1, ( N + M )*K), if TYPET = 'R'; C LDR >= MAX(1, M*K), if TYPET = 'C'. C C L (output) DOUBLE PRECISION array, dimension C (LDL,( N + M )*K) / (LDL,M*K) C If INFO = 0 and JOB = 'A', then the leading C M*K-by-( N + M )*K / ( N + M )*K-by-M*K part of this C array contains the last M*K rows / columns of the lower / C upper Cholesky factor of the inverse of T. The elements C in the strictly upper / lower triangular part are not C referenced. C C LDL INTEGER C The leading dimension of the array L. C LDL >= MAX(1, M*K), if TYPET = 'R' and JOB = 'A'; C LDL >= MAX(1, ( N + M )*K), if TYPET = 'C' and JOB = 'A'; C LDL >= 1, if JOB = 'R', or 'O'. C C CS (input/output) DOUBLE PRECISION array, dimension (LCS) C On input, the leading 3*(N-1)*K part of this array must C contain the necessary information about the hyperbolic C rotations and Householder transformations applied C previously by SLICOT Library routine MB02CD. C On exit, if INFO = 0, then the leading 3*(N+M-1)*K part of C this array contains information about all the hyperbolic C rotations and Householder transformations applied during C the whole process. C C LCS INTEGER C The length of the array CS. LCS >= 3*(N+M-1)*K. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -19, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1,(N+M-1)*K). 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: the reduction algorithm failed. The block Toeplitz C matrix associated with [ T TA ] / [ T' TA' ]' is C not (numerically) positive definite. C C METHOD C C Householder transformations and modified hyperbolic rotations C are used in the Schur algorithm [1], [2]. C C REFERENCES C C [1] Kailath, T. and Sayed, A. C Fast Reliable Algorithms for Matrices with Structure. C SIAM Publications, Philadelphia, 1999. C C [2] Kressner, D. and Van Dooren, P. C Factorizations and linear system solvers for matrices with C Toeplitz structure. C SLICOT Working Note 2000-2, 2000. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C 3 2 C The algorithm requires 0(K ( N M + M ) ) floating point C operations. C C FURTHER COMMENTS C C For min(K,N,M) = 0, the routine sets DWORK(1) = 1 and returns. C Although the calculations could still be performed when N = 0, C but min(K,M) > 0, this case is not considered as an "update". C SLICOT Library routine MB02CD should be called with the argument C M instead of N. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Chemnitz, Germany, December 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, C Feb. 2004. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOB, TYPET INTEGER INFO, K, LCS, LDG, LDL, LDR, LDT, LDTA, LDWORK, $ M, N C .. Array Arguments .. DOUBLE PRECISION CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*), $ T(LDT,*), TA(LDTA,*) C .. Local Scalars .. INTEGER I, IERR, J, MAXWRK, STARTI, STARTR, STARTT LOGICAL COMPG, COMPL, ISROW C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DLASET, DTRSM, MB02CX, MB02CY, $ XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 COMPL = LSAME( JOB, 'A' ) COMPG = LSAME( JOB, 'R' ) .OR. COMPL ISROW = LSAME( TYPET, 'R' ) C C Check the scalar input parameters. C IF ( .NOT.( COMPG .OR. LSAME( JOB, 'O' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN INFO = -2 ELSE IF ( K.LT.0 ) THEN INFO = -3 ELSE IF ( M.LT.0 ) THEN INFO = -4 ELSE IF ( N.LT.0 ) THEN INFO = -5 ELSE IF ( LDTA.LT.1 .OR. ( ISROW .AND. LDTA.LT.K ) .OR. $ ( .NOT.ISROW .AND. LDTA.LT.M*K ) ) THEN INFO = -7 ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN INFO = -9 ELSE IF ( ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K ) $ .OR. ( .NOT.ISROW .AND. LDG.LT.( N + M )*K ) ) ) $ .OR. LDG.LT.1 ) THEN INFO = -11 ELSE IF ( ( ( ISROW .AND. LDR.LT.( N + M )*K ) .OR. $ ( .NOT.ISROW .AND. LDR.LT.M*K ) ) .OR. $ LDR.LT.1 ) THEN INFO = -13 ELSE IF ( ( COMPL .AND. ( ( ISROW .AND. LDL.LT.M*K ) $ .OR. ( .NOT.ISROW .AND. LDL.LT.( N + M )*K ) ) ) $ .OR. LDL.LT.1 ) THEN INFO = -15 ELSE IF ( LCS.LT.3*( N + M - 1 )*K ) THEN INFO = -17 ELSE IF ( LDWORK.LT.MAX( 1, ( N + M - 1 )*K ) ) THEN DWORK(1) = MAX( 1, ( N + M - 1 )*K ) INFO = -19 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02DD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( K, N, M ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C MAXWRK = 1 IF ( ISROW ) THEN C C Apply Cholesky factor of T(1:K, 1:K) on TA. C CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, M*K, $ ONE, T, LDT, TA, LDTA ) C C Initialize the output matrices. C IF ( COMPG ) THEN CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(1,N*K+1), LDG ) IF ( M.GE.N-1 .AND. N.GT.1 ) THEN CALL DLACPY( 'All', K, (N-1)*K, G(K+1,K+1), LDG, $ G(K+1,K*(M+1)+1), LDG ) ELSE DO 10 I = N*K, K + 1, -1 CALL DCOPY( K, G(K+1,I), 1, G(K+1,M*K+I), 1 ) 10 CONTINUE END IF CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(K+1,K+1), LDG ) END IF C CALL DLACPY( 'All', K, M*K, TA, LDTA, R, LDR ) C C Apply the stored transformations on the new columns. C DO 20 I = 2, N C C Copy the last M-1 blocks of the positive generator together; C the last M blocks of the negative generator are contained C in TA. C STARTR = ( I - 1 )*K + 1 STARTT = 3*( I - 2 )*K + 1 CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR, $ R(STARTR,K+1), LDR ) C C Apply the transformations stored in T on the generator. C CALL MB02CY( 'Row', 'NoStructure', K, K, M*K, K, $ R(STARTR,1), LDR, TA, LDTA, T(1,STARTR), LDT, $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) 20 CONTINUE C C Now, we have "normality" and can apply further M Schur steps. C DO 30 I = 1, M C C Copy the first M-I+1 blocks of the positive generator C together; the first M-I+1 blocks of the negative generator C are contained in TA. C STARTT = 3*( N + I - 2 )*K + 1 STARTI = ( M - I + 1 )*K + 1 STARTR = ( N + I - 1 )*K + 1 IF ( I.EQ.1 ) THEN CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR, $ R(STARTR,K+1), LDR ) ELSE CALL DLACPY( 'Upper', K, (M-I+1)*K, $ R(STARTR-K,(I-2)*K+1), LDR, $ R(STARTR,(I-1)*K+1), LDR ) END IF C C Reduce the generator to proper form. C CALL MB02CX( 'Row', K, K, K, R(STARTR,(I-1)*K+1), LDR, $ TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, DWORK, $ LDWORK, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) IF ( M.GT.I ) THEN CALL MB02CY( 'Row', 'NoStructure', K, K, (M-I)*K, K, $ R(STARTR,I*K+1), LDR, TA(1,I*K+1), LDTA, $ TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, $ DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) END IF C IF ( COMPG ) THEN C C Transformations acting on the inverse generator: C CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1), $ LDG, G(1,STARTR), LDG, TA(1,(I-1)*K+1), $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C CALL MB02CY( 'Row', 'NoStructure', K, K, (N+I-1)*K, K, $ G(K+1,STARTI), LDG, G, LDG, TA(1,(I-1)*K+1), $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C IF ( COMPL ) THEN CALL DLACPY( 'All', K, (N+I-1)*K, G(K+1,STARTI), LDG, $ L((I-1)*K+1,1), LDL ) CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, $ L((I-1)*K+1,STARTR), LDL ) END IF C END IF 30 CONTINUE C ELSE C C Apply Cholesky factor of T(1:K, 1:K) on TA. C CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M*K, K, $ ONE, T, LDT, TA, LDTA ) C C Initialize the output matrices. C IF ( COMPG ) THEN CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(N*K+1,1), LDG ) IF ( M.GE.N-1 .AND. N.GT.1 ) THEN CALL DLACPY( 'All', (N-1)*K, K, G(K+1,K+1), LDG, $ G(K*(M+1)+1,K+1), LDG ) ELSE DO 40 I = 1, K DO 35 J = N*K, K + 1, -1 G(J+M*K,K+I) = G(J,K+I) 35 CONTINUE 40 CONTINUE END IF CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(K+1,K+1), LDG ) END IF C CALL DLACPY( 'All', M*K, K, TA, LDTA, R, LDR ) C C Apply the stored transformations on the new rows. C DO 50 I = 2, N C C Copy the last M-1 blocks of the positive generator together; C the last M blocks of the negative generator are contained C in TA. C STARTR = ( I - 1 )*K + 1 STARTT = 3*( I - 2 )*K + 1 CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR, $ R(K+1,STARTR), LDR ) C C Apply the transformations stored in T on the generator. C CALL MB02CY( 'Column', 'NoStructure', K, K, M*K, K, $ R(1,STARTR), LDR, TA, LDTA, T(STARTR,1), LDT, $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) 50 CONTINUE C C Now, we have "normality" and can apply further M Schur steps. C DO 60 I = 1, M C C Copy the first M-I+1 blocks of the positive generator C together; the first M-I+1 blocks of the negative generator C are contained in TA. C STARTT = 3*( N + I - 2 )*K + 1 STARTI = ( M - I + 1 )*K + 1 STARTR = ( N + I - 1 )*K + 1 IF ( I.EQ.1 ) THEN CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR, $ R(K+1,STARTR), LDR ) ELSE CALL DLACPY( 'Lower', (M-I+1)*K, K, $ R((I-2)*K+1,STARTR-K), LDR, $ R((I-1)*K+1,STARTR), LDR ) END IF C C Reduce the generator to proper form. C CALL MB02CX( 'Column', K, K, K, R((I-1)*K+1,STARTR), LDR, $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, DWORK, $ LDWORK, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) IF ( M.GT.I ) THEN CALL MB02CY( 'Column', 'NoStructure', K, K, (M-I)*K, K, $ R(I*K+1,STARTR), LDR, TA(I*K+1,1), LDTA, $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, $ DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) END IF C IF ( COMPG ) THEN C C Transformations acting on the inverse generator: C CALL MB02CY( 'Column', 'Triangular', K, K, K, K, $ G(1,K+1), LDG, G(STARTR,1), LDG, $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, $ DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C CALL MB02CY( 'Column', 'NoStructure', K, K, (N+I-1)*K, K, $ G(STARTI,K+1), LDG, G, LDG, TA((I-1)*K+1,1), $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C IF ( COMPL ) THEN CALL DLACPY( 'All', (N+I-1)*K, K, G(STARTI,K+1), LDG, $ L(1,(I-1)*K+1), LDL ) CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, $ L(STARTR,(I-1)*K+1), LDL ) END IF C END IF 60 CONTINUE C END IF C DWORK(1) = MAXWRK C RETURN C C *** Last line of MB02DD *** END control-4.1.2/src/slicot/src/PaxHeaders/SG02AD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SG02AD.f0000644000175000017500000010363415012430707017360 0ustar00lilgelilge00000000000000 SUBROUTINE SG02AD( DICO, JOBB, FACT, UPLO, JOBL, SCAL, SORT, ACC, $ N, M, P, A, LDA, E, LDE, B, LDB, Q, LDQ, R, $ LDR, L, LDL, RCONDU, X, LDX, ALFAR, ALFAI, $ BETA, S, LDS, T, LDT, U, LDU, TOL, IWORK, $ DWORK, LDWORK, BWORK, IWARN, INFO ) C C PURPOSE C C To solve for X either the continuous-time algebraic Riccati C equation C -1 C Q + A'XE + E'XA - (L+E'XB)R (L+E'XB)' = 0 , (1) C C or the discrete-time algebraic Riccati equation C -1 C E'XE = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q , (2) C C where A, E, B, Q, R, and L are N-by-N, N-by-N, N-by-M, N-by-N, C M-by-M and N-by-M matrices, respectively, such that Q = C'C, C R = D'D and L = C'D; X is an N-by-N symmetric matrix. C The routine also returns the computed values of the closed-loop C spectrum of the system, i.e., the stable eigenvalues C lambda(1),...,lambda(N) of the pencil (A - BF,E), where F is C the optimal gain matrix, C -1 C F = R (L+E'XB)' , for (1), C C and C -1 C F = (R+B'XB) (L+A'XB)' , for (2). C -1 C Optionally, matrix G = BR B' may be given instead of B and R. C Other options include the case with Q and/or R given in a C factored form, Q = C'C, R = D'D, and with L a zero matrix. C C The routine uses the method of deflating subspaces, based on C reordering the eigenvalues in a generalized Schur matrix pair. C C It is assumed that E is nonsingular, but this condition is not C checked. Note that the definition (1) of the continuous-time C algebraic Riccati equation, and the formula for the corresponding C optimal gain matrix, require R to be nonsingular, but the C associated linear quadratic optimal problem could have a unique C solution even when matrix R is singular, under mild assumptions C (see METHOD). The routine SG02AD works accordingly in this case. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of Riccati equation to be solved as C follows: C = 'C': Equation (1), continuous-time case; C = 'D': Equation (2), discrete-time case. C C JOBB CHARACTER*1 C Specifies whether or not the matrix G is given, instead C of the matrices B and R, as follows: C = 'B': B and R are given; C = 'G': G is given. C C FACT CHARACTER*1 C Specifies whether or not the matrices Q and/or R (if C JOBB = 'B') are factored, as follows: C = 'N': Not factored, Q and R are given; C = 'C': C is given, and Q = C'C; C = 'D': D is given, and R = D'D; C = 'B': Both factors C and D are given, Q = C'C, R = D'D. C C UPLO CHARACTER*1 C If JOBB = 'G', or FACT = 'N', specifies which triangle of C the matrices G, or Q and R, is stored, as follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. C C JOBL CHARACTER*1 C Specifies whether or not the matrix L is zero, as follows: C = 'Z': L is zero; C = 'N': L is nonzero. C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. C SLICOT Library routine SB02MT should be called just before C SG02AD, for obtaining the results when JOBB = 'G' and C JOBL = 'N'. C C SCAL CHARACTER*1 C If JOBB = 'B', specifies whether or not a scaling strategy C should be used to scale Q, R, and L, as follows: C = 'G': General scaling should be used; C = 'N': No scaling should be used. C SCAL is not used if JOBB = 'G'. C C SORT CHARACTER*1 C Specifies which eigenvalues should be obtained in the top C of the generalized Schur form, as follows: C = 'S': Stable eigenvalues come first; C = 'U': Unstable eigenvalues come first. C C ACC CHARACTER*1 C Specifies whether or not iterative refinement should be C used to solve the system of algebraic equations giving C the solution matrix X, as follows: C = 'R': Use iterative refinement; C = 'N': Do not use iterative refinement. C C Input/Output Parameters C C N (input) INTEGER C The actual state dimension, i.e., the order of the C matrices A, E, Q, and X, and the number of rows of the C matrices B and L. N >= 0. C C M (input) INTEGER C The number of system inputs. If JOBB = 'B', M is the C order of the matrix R, and the number of columns of the C matrix B. M >= 0. C M is not used if JOBB = 'G'. C C P (input) INTEGER C The number of system outputs. If FACT = 'C' or 'D' or 'B', C P is the number of rows of the matrices C and/or D. C P >= 0. C Otherwise, P is not used. 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 matrix A of the descriptor system. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C E (input) DOUBLE PRECISION array, dimension (LDE,N) C The leading N-by-N part of this array must contain the C matrix E of the descriptor system. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,N). C C B (input) DOUBLE PRECISION array, dimension (LDB,*) C If JOBB = 'B', the leading N-by-M part of this array must C contain the input matrix B of the system. C If JOBB = 'G', 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 upper triangular part or C lower triangular part, respectively, of the matrix C -1 C G = BR B'. The strictly lower triangular part (if C UPLO = 'U') or strictly upper triangular part (if C UPLO = 'L') is not referenced. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) C If FACT = 'N' or 'D', the leading N-by-N upper triangular C part (if UPLO = 'U') or lower triangular part (if UPLO = C 'L') of this array must contain the upper triangular part C or lower triangular part, respectively, of the symmetric C state weighting matrix Q. The strictly lower triangular C part (if UPLO = 'U') or strictly upper triangular part (if C UPLO = 'L') is not referenced. C If FACT = 'C' or 'B', the leading P-by-N part of this C array must contain the output matrix C of the system. C If JOBB = 'B' and SCAL = 'G', then Q is modified C internally, but is restored on exit. C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= MAX(1,N) if FACT = 'N' or 'D'; C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. C C R (input) DOUBLE PRECISION array, dimension (LDR,*) C If FACT = 'N' or 'C', the leading M-by-M upper triangular C part (if UPLO = 'U') or lower triangular part (if UPLO = C 'L') of this array must contain the upper triangular part C or lower triangular part, respectively, of the symmetric C input weighting matrix R. The strictly lower triangular C part (if UPLO = 'U') or strictly upper triangular part (if C UPLO = 'L') is not referenced. C If FACT = 'D' or 'B', the leading P-by-M part of this C array must contain the direct transmission matrix D of the C system. C If JOBB = 'B' and SCAL = 'G', then R is modified C internally, but is restored on exit. C If JOBB = 'G', this array is not referenced. C C LDR INTEGER C The leading dimension of array R. C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; C LDR >= 1 if JOBB = 'G'. C C L (input) DOUBLE PRECISION array, dimension (LDL,*) C If JOBL = 'N' and JOBB = 'B', the leading N-by-M part of C this array must contain the cross weighting matrix L. C If JOBB = 'B' and SCAL = 'G', then L is modified C internally, but is restored on exit. C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. C C LDL INTEGER C The leading dimension of array L. C LDL >= MAX(1,N) if JOBL = 'N' and JOBB = 'B'; C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. C C RCONDU (output) DOUBLE PRECISION C If N > 0 and INFO = 0 or INFO = 7, an estimate of the C reciprocal of the condition number (in the 1-norm) of C the N-th order system of algebraic equations from which C the solution matrix X is obtained. C C X (output) DOUBLE PRECISION array, dimension (LDX,N) C If INFO = 0, the leading N-by-N part of this array C contains the solution matrix X of the problem. C C LDX INTEGER C The leading dimension of array X. LDX >= MAX(1,N). C C ALFAR (output) DOUBLE PRECISION array, dimension (2*N) C ALFAI (output) DOUBLE PRECISION array, dimension (2*N) C BETA (output) DOUBLE PRECISION array, dimension (2*N) C The generalized eigenvalues of the 2N-by-2N matrix pair, C ordered as specified by SORT (if INFO = 0, or INFO >= 5). C For instance, if SORT = 'S', the leading N elements of C these arrays contain the closed-loop spectrum of the C system. Specifically, C lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for C k = 1,2,...,N. C C S (output) DOUBLE PRECISION array, dimension (LDS,*) C The leading 2N-by-2N part of this array contains the C ordered real Schur form S of the first matrix in the C reduced matrix pencil associated to the optimal problem, C corresponding to the scaled Q, R, and L, if JOBB = 'B' C and SCAL = 'G'. That is, C C (S S ) C ( 11 12) C S = ( ), C (0 S ) C ( 22) C C where S , S and S are N-by-N matrices. C 11 12 22 C Array S must have 2*N+M columns if JOBB = 'B', and 2*N C columns, otherwise. C C LDS INTEGER C The leading dimension of array S. C LDS >= MAX(1,2*N+M) if JOBB = 'B'; C LDS >= MAX(1,2*N) if JOBB = 'G'. C C T (output) DOUBLE PRECISION array, dimension (LDT,2*N) C The leading 2N-by-2N part of this array contains the C ordered upper triangular form T of the second matrix in C the reduced matrix pencil associated to the optimal C problem, corresponding to the scaled Q, R, and L, if C JOBB = 'B' and SCAL = 'G'. That is, C C (T T ) C ( 11 12) C T = ( ), C (0 T ) C ( 22) C C where T , T and T are N-by-N matrices. C 11 12 22 C C LDT INTEGER C The leading dimension of array T. C LDT >= MAX(1,2*N+M) if JOBB = 'B'; C LDT >= MAX(1,2*N) if JOBB = 'G'. C C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) C The leading 2N-by-2N part of this array contains the right C transformation matrix U which reduces the 2N-by-2N matrix C pencil to the ordered generalized real Schur form (S,T). C That is, C C (U U ) C ( 11 12) C U = ( ), C (U U ) C ( 21 22) C C where U , U , U and U are N-by-N matrices. C 11 12 21 22 C If JOBB = 'B' and SCAL = 'G', then U corresponds to the C scaled pencil. If a basis for the stable deflating C subspace of the original problem is needed, then the C submatrix U must be multiplied by the scaling factor C 21 C contained in DWORK(4). C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,2*N). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used to test for near singularity of C the original matrix pencil, specifically of the triangular C M-by-M factor obtained during the reduction process. If C the user sets TOL > 0, then the given value of TOL is used C as a lower bound for the reciprocal condition number of C that matrix; a matrix whose estimated condition number is C less than 1/TOL is considered to be nonsingular. If the C user sets TOL <= 0, then a default tolerance, defined by C TOLDEF = EPS, is used instead, where EPS is the machine C precision (see LAPACK Library routine DLAMCH). C This parameter is not referenced if JOBB = 'G'. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK >= MAX(1,M,2*N) if JOBB = 'B'; C LIWORK >= MAX(1,2*N) if JOBB = 'G'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK. If JOBB = 'B' and N > 0, DWORK(2) returns the C reciprocal of the condition number of the M-by-M bottom C right lower triangular matrix obtained while compressing C the matrix pencil of order 2N+M to obtain a pencil of C order 2N. If ACC = 'R', and INFO = 0 or INFO = 7, DWORK(3) C returns the reciprocal pivot growth factor (see SLICOT C Library routine MB02PD) for the LU factorization of the C coefficient matrix of the system of algebraic equations C giving the solution matrix X; if DWORK(3) is much C less than 1, then the computed X and RCONDU could be C unreliable. If INFO = 0 or INFO = 7, DWORK(4) returns the C scaling factor used to scale Q, R, and L. DWORK(4) is set C to 1 if JOBB = 'G' or SCAL = 'N'. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G'; C LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. C For optimum performance LDWORK should be larger. C C BWORK LOGICAL array, dimension (2*N) C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: the computed solution may be inaccurate due to poor C scaling or eigenvalues too close to the boundary of C the stability domain (the imaginary axis, if C DICO = 'C', or the unit circle, if DICO = 'D'). 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 computed extended matrix pencil is singular, C possibly due to rounding errors; C = 2: if the QZ algorithm failed; C = 3: if reordering of the generalized eigenvalues failed; C = 4: if after reordering, roundoff changed values of C some complex eigenvalues so that leading eigenvalues C in the generalized Schur form no longer satisfy the C stability condition; this could also be caused due C to scaling; C = 5: if the computed dimension of the solution does not C equal N; C = 6: if the spectrum is too close to the boundary of C the stability domain; C = 7: if a singular matrix was encountered during the C computation of the solution matrix X. C C METHOD C C The routine uses a variant of the method of deflating subspaces C proposed by van Dooren [1]. See also [2], [3], [4]. C It is assumed that E is nonsingular, the triple (E,A,B) is C strongly stabilizable and detectable (see [3]); if, in addition, C C - [ Q L ] C R := [ ] >= 0 , C [ L' R ] C C then the pencils C C discrete-time continuous-time C C |A 0 B| |E 0 0| |A 0 B| |E 0 0| C |Q -E' L| - z |0 -A' 0| , |Q A' L| - s |0 -E' 0| , (3) C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| C C are dichotomic, i.e., they have no eigenvalues on the boundary of C the stability domain. The above conditions are sufficient for C regularity of these pencils. A necessary condition is that C rank([ B' L' R']') = m. C C Under these assumptions the algebraic Riccati equation is known to C have a unique non-negative definite solution. C The first step in the method of deflating subspaces is to form the C extended matrices in (3), of order 2N + M. Next, these pencils are C compressed to a form of order 2N (see [1]) C C lambda x A - B . C f f C C This generalized eigenvalue problem is then solved using the QZ C algorithm and the stable deflating subspace Ys is determined. C If [Y1'|Y2']' is a basis for Ys, then the required solution is C -1 C X = Y2 x Y1 . C C REFERENCES C C [1] Van Dooren, P. C A Generalized Eigenvalue Approach for Solving Riccati C Equations. C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. C C [2] Arnold, III, W.F. and Laub, A.J. C Generalized Eigenproblem Algorithms and Software for C Algebraic Riccati Equations. C Proc. IEEE, 72, 1746-1754, 1984. C C [3] Mehrmann, V. C The Autonomous Linear Quadratic Control Problem. Theory and C Numerical Solution. C Lect. Notes in Control and Information Sciences, vol. 163, C Springer-Verlag, Berlin, 1991. C C [4] Sima, V. C Algorithms for Linear-Quadratic Optimization. C Pure and Applied Mathematics: A Series of Monographs and C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. C C NUMERICAL ASPECTS C C This routine is particularly suited for systems where the matrix R C is ill-conditioned, or even singular. C C FURTHER COMMENTS C C To obtain a stabilizing solution of the algebraic Riccati C equations set SORT = 'S'. C C The routine can also compute the anti-stabilizing solutions of C the algebraic Riccati equations, by specifying SORT = 'U'. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, June 2002. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, September 2002, C December 2002. C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, discrete-time system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, P1, FOUR PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, $ P1 = 0.1D0, FOUR = 4.0D0 ) C .. Scalar Arguments .. CHARACTER ACC, DICO, FACT, JOBB, JOBL, SCAL, SORT, UPLO INTEGER INFO, IWARN, LDA, LDB, LDE, LDL, LDQ, LDR, LDS, $ LDT, LDU, LDWORK, LDX, M, N, P DOUBLE PRECISION RCONDU, TOL C .. Array Arguments .. LOGICAL BWORK(*) INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), ALFAI(*), ALFAR(*), B(LDB,*), BETA(*), $ DWORK(*), E(LDE,*), L(LDL,*), Q(LDQ,*), $ R(LDR,*), S(LDS,*), T(LDT,*), U(LDU,*), X(LDX,*) C .. Local Scalars .. CHARACTER EQUED, QTYPE, RTYPE LOGICAL COLEQU, DISCR, LFACB, LFACN, LFACQ, LFACR, $ LJOBB, LJOBL, LJOBLN, LSCAL, LSORT, LUPLO, $ REFINE, ROWEQU INTEGER I, INFO1, IW, IWB, IWC, IWF, IWR, J, LDW, MP, $ NDIM, NN, NNM, NP, NP1, WRKOPT DOUBLE PRECISION ASYM, EPS, PIVOTU, RCONDL, RNORM, SCALE, SEPS, $ U12M, UNORM C .. External Functions .. LOGICAL LSAME, SB02OU, SB02OV, SB02OW DOUBLE PRECISION DLAMCH, DLANGE, DLANSY EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02OU, SB02OV, $ SB02OW C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGECON, DGEMM, DGEQRF, DGGES, $ DLACPY, DLASCL, DLASET, DORGQR, DSCAL, DSWAP, $ MB01SD, MB02PD, MB02VD, SB02OY, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, SQRT C .. Executable Statements .. C IWARN = 0 INFO = 0 DISCR = LSAME( DICO, 'D' ) LJOBB = LSAME( JOBB, 'B' ) LFACN = LSAME( FACT, 'N' ) LFACQ = LSAME( FACT, 'C' ) LFACR = LSAME( FACT, 'D' ) LFACB = LSAME( FACT, 'B' ) LUPLO = LSAME( UPLO, 'U' ) LSORT = LSAME( SORT, 'S' ) REFINE = LSAME( ACC, 'R' ) NN = 2*N IF ( LJOBB ) THEN LJOBL = LSAME( JOBL, 'Z' ) LJOBLN = LSAME( JOBL, 'N' ) LSCAL = LSAME( SCAL, 'G' ) NNM = NN + M LDW = MAX( NNM, 3*M ) ELSE LSCAL = .FALSE. NNM = NN LDW = 1 END IF NP1 = N + 1 C C Test the input scalar arguments. C IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN INFO = -2 ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB $ .AND. .NOT.LFACN ) THEN INFO = -3 ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) $ INFO = -4 END IF IF( INFO.EQ.0 .AND. LJOBB ) THEN IF( .NOT.LJOBL .AND. .NOT.LJOBLN ) THEN INFO = -5 ELSE IF( .NOT.LSCAL .AND. .NOT. LSAME( SCAL, 'N' ) ) THEN INFO = -6 END IF END IF IF( INFO.EQ.0 ) THEN IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN INFO = -7 ELSE IF( .NOT.REFINE .AND. .NOT.LSAME( ACC, 'N' ) ) THEN INFO = -8 ELSE IF( N.LT.0 ) THEN INFO = -9 ELSE IF( LJOBB ) THEN IF( M.LT.0 ) $ INFO = -10 END IF END IF IF( INFO.EQ.0 .AND. .NOT.LFACN ) THEN IF( P.LT.0 ) $ INFO = -11 END IF IF( INFO.EQ.0 ) THEN IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -13 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN INFO = -19 ELSE IF( LJOBB ) THEN IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.MAX( 1, M ) .OR. $ ( LFACR.OR.LFACB ) .AND. LDR.LT.MAX( 1, P ) ) THEN INFO = -21 ELSE IF( ( LJOBLN .AND. LDL.LT.MAX( 1, N ) ) .OR. $ ( LJOBL .AND. LDL.LT.1 ) ) THEN INFO = -23 END IF ELSE IF( LDR.LT.1 ) THEN INFO = -21 ELSE IF( LDL.LT.1 ) THEN INFO = -23 END IF END IF END IF IF( INFO.EQ.0 ) THEN IF( LDX.LT.MAX( 1, N ) ) THEN INFO = -26 ELSE IF( LDS.LT.MAX( 1, NNM ) ) THEN INFO = -31 ELSE IF( LDT.LT.MAX( 1, NNM ) ) THEN INFO = -33 ELSE IF( LDU.LT.MAX( 1, NN ) ) THEN INFO = -35 ELSE IF( LDWORK.LT.MAX( 14*N + 23, 16*N, LDW ) ) THEN INFO = -39 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SG02AD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = FOUR DWORK(4) = ONE RETURN END IF C C Start computations. 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 LSCAL = LSCAL .AND. LJOBB IF ( LSCAL ) THEN C C Scale the matrices Q, R (or G), and L so that C norm(Q) + norm(R) + norm(L) = 1, C using the 1-norm. If Q and/or R are factored, the norms of C the factors are used. C Workspace: need max(N,M), if FACT = 'N'; C N, if FACT = 'D'; C M, if FACT = 'C'. C IF ( LFACN .OR. LFACR ) THEN SCALE = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) QTYPE = UPLO NP = N ELSE SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) QTYPE = 'G' NP = P END IF C IF ( LFACN .OR. LFACQ ) THEN RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) RTYPE = UPLO MP = M ELSE RNORM = DLANGE( '1-norm', P, M, R, LDR, DWORK ) RTYPE = 'G' MP = P END IF SCALE = SCALE + RNORM C IF ( LJOBLN ) $ SCALE = SCALE + DLANGE( '1-norm', N, M, L, LDL, DWORK ) IF ( SCALE.EQ.ZERO ) $ SCALE = ONE C CALL DLASCL( QTYPE, 0, 0, SCALE, ONE, NP, N, Q, LDQ, INFO1 ) CALL DLASCL( RTYPE, 0, 0, SCALE, ONE, MP, M, R, LDR, INFO1 ) IF ( LJOBLN ) $ CALL DLASCL( 'G', 0, 0, SCALE, ONE, N, M, L, LDL, INFO1 ) ELSE SCALE = ONE END IF C C Construct the extended matrix pair. C Workspace: need 1, if JOBB = 'G', C max(1,2*N+M,3*M), if JOBB = 'B'; C prefer larger. C CALL SB02OY( 'Optimal control', DICO, JOBB, FACT, UPLO, JOBL, $ 'Not identity E', N, M, P, A, LDA, B, LDB, Q, LDQ, R, $ LDR, L, LDL, E, LDE, S, LDS, T, LDT, TOL, IWORK, $ DWORK, LDWORK, INFO ) C IF ( LSCAL ) THEN C C Undo scaling of the data arrays. C CALL DLASCL( QTYPE, 0, 0, ONE, SCALE, NP, N, Q, LDQ, INFO1 ) CALL DLASCL( RTYPE, 0, 0, ONE, SCALE, MP, M, R, LDR, INFO1 ) IF ( LJOBLN ) $ CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, M, L, LDL, INFO1 ) END IF C IF ( INFO.NE.0 ) $ RETURN WRKOPT = DWORK(1) IF ( LJOBB ) $ RCONDL = DWORK(2) C C Workspace: need max(7*(2*N+1)+16,16*N); C prefer larger. C IF ( DISCR ) THEN IF ( LSORT ) THEN C C The natural tendency of the QZ algorithm to get the largest C eigenvalues in the leading part of the matrix pair is C exploited, by computing the unstable eigenvalues of the C permuted matrix pair. C CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, T, $ LDT, S, LDS, NDIM, ALFAR, ALFAI, BETA, U, LDU, $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) CALL DSWAP( N, ALFAR(NP1), 1, ALFAR, 1 ) CALL DSWAP( N, ALFAI(NP1), 1, ALFAI, 1 ) CALL DSWAP( N, BETA (NP1), 1, BETA , 1 ) ELSE CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, S, $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) END IF ELSE IF ( LSORT ) THEN CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OW, NN, S, $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) ELSE CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OU, NN, S, $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) END IF END IF IF ( INFO1.GT.0 .AND. INFO1.LE.NN+1 ) THEN INFO = 2 ELSE IF ( INFO1.EQ.NN+2 ) THEN INFO = 4 ELSE IF ( INFO1.EQ.NN+3 ) THEN INFO = 3 ELSE IF ( NDIM.NE.N ) THEN INFO = 5 END IF IF ( INFO.NE.0 ) $ RETURN WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Take the non-identity matrix E into account and orthogonalize the C basis. Use the array X as workspace. C Workspace: need N; C prefer N*NB. C CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, E, LDE, $ U, LDU, ZERO, X, LDX ) CALL DLACPY( 'Full', N, N, X, LDX, U, LDU ) CALL DGEQRF( NN, N, U, LDU, X, DWORK, LDWORK, INFO1 ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) CALL DORGQR( NN, N, N, U, LDU, X, DWORK, LDWORK, INFO1 ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Check for the symmetry of the solution. The array X is again used C as workspace. C CALL DGEMM( 'Transpose', 'No transpose', N, N, N, ONE, U, LDU, $ U(NP1,1), LDU, ZERO, X, LDX ) U12M = ZERO ASYM = ZERO C DO 20 J = 1, N C DO 10 I = 1, N U12M = MAX( U12M, ABS( X(I,J) ) ) ASYM = MAX( ASYM, ABS( X(I,J) - X(J,I) ) ) 10 CONTINUE C 20 CONTINUE C EPS = DLAMCH( 'Epsilon' ) SEPS = SQRT( EPS ) ASYM = ASYM - SEPS IF ( ASYM.GT.P1*U12M ) THEN INFO = 6 RETURN ELSE IF ( ASYM.GT.SEPS ) THEN IWARN = 1 END IF C C Compute the solution of X*U(1,1) = U(2,1). Use the (2,1) block C of S as a workspace for factoring U(1,1). C IF ( REFINE ) THEN C C Use LU factorization and iterative refinement for finding X. C Workspace: need 8*N. C C First transpose U(2,1) in-situ. C DO 30 I = 1, N - 1 CALL DSWAP( N-I, U(N+I,I+1), LDU, U(N+I+1,I), 1 ) 30 CONTINUE C IWR = 1 IWC = IWR + N IWF = IWC + N IWB = IWF + N IW = IWB + N C CALL MB02PD( 'Equilibrate', 'Transpose', N, N, U, LDU, $ S(NP1,1), LDS, IWORK, EQUED, DWORK(IWR), $ DWORK(IWC), U(NP1,1), LDU, X, LDX, RCONDU, $ DWORK(IWF), DWORK(IWB), IWORK(NP1), DWORK(IW), $ INFO1 ) C C Transpose U(2,1) back in-situ. C DO 40 I = 1, N - 1 CALL DSWAP( N-I, U(N+I,I+1), LDU, U(N+I+1,I), 1 ) 40 CONTINUE C IF( .NOT.LSAME( EQUED, 'N' ) ) THEN C C Undo the equilibration of U(1,1) and U(2,1). C ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) C IF( ROWEQU ) THEN C DO 50 I = 0, N - 1 DWORK(IWR+I) = ONE / DWORK(IWR+I) 50 CONTINUE C CALL MB01SD( 'Row scaling', N, N, U, LDU, DWORK(IWR), $ DWORK(IWC) ) END IF C IF( COLEQU ) THEN C DO 60 I = 0, N - 1 DWORK(IWC+I) = ONE / DWORK(IWC+I) 60 CONTINUE C CALL MB01SD( 'Column scaling', NN, N, U, LDU, DWORK(IWR), $ DWORK(IWC) ) END IF END IF C PIVOTU = DWORK(IW) C IF ( INFO1.GT.0 ) THEN C C Singular matrix. Set INFO and DWORK for error return. C INFO = 7 GO TO 80 END IF C ELSE C C Use LU factorization and a standard solution algorithm. C CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) CALL DLACPY( 'Full', N, N, U(NP1,1), LDU, X, LDX ) C C Solve the system X*U(1,1) = U(2,1). C CALL MB02VD( 'No Transpose', N, N, S(NP1,1), LDS, IWORK, X, $ LDX, INFO1 ) C IF ( INFO1.NE.0 ) THEN INFO = 7 RCONDU = ZERO GO TO 80 ELSE C C Compute the norm of U(1,1). C UNORM = DLANGE( '1-norm', N, N, U, LDU, DWORK ) C C Estimate the reciprocal condition of U(1,1). C Workspace: need 4*N. C CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCONDU, $ DWORK, IWORK(NP1), INFO ) C IF ( RCONDU.LT.EPS ) THEN C C Nearly singular matrix. Set IWARN for warning indication. C IWARN = 1 END IF WRKOPT = MAX( WRKOPT, 4*N ) END IF END IF C C Set S(2,1) to zero. C CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) C C Make sure the solution matrix X is symmetric. C DO 70 I = 1, N - 1 CALL DAXPY( N-I, ONE, X(I,I+1), LDX, X(I+1,I), 1 ) CALL DSCAL( N-I, HALF, X(I+1,I), 1 ) CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) 70 CONTINUE C IF ( LSCAL ) THEN C C Undo scaling for the solution X. C CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, N, X, LDX, INFO1 ) END IF C DWORK(1) = WRKOPT C 80 CONTINUE IF ( LJOBB ) $ DWORK(2) = RCONDL IF ( REFINE ) $ DWORK(3) = PIVOTU DWORK(4) = SCALE C RETURN C *** Last line of SG02AD *** END control-4.1.2/src/slicot/src/PaxHeaders/UD01MZ.f0000644000000000000000000000013215012430707016215 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/UD01MZ.f0000644000175000017500000001007315012430707017412 0ustar00lilgelilge00000000000000 SUBROUTINE UD01MZ( M, N, L, NOUT, A, LDA, TEXT, INFO ) C C PURPOSE C C To print an M-by-N real matrix A row by row. The elements of A C are output to 7 significant figures. C C ARGUMENTS C C Input/Output Parameters C C M (input) INTEGER C The number of rows of matrix A to be printed. M >= 1. C C N (input) INTEGER C The number of columns of matrix A to be printed. N >= 1. C C L (input) INTEGER C The number of elements of matrix A to be printed per line. C 1 <= L <= 3. C C NOUT (input) INTEGER C The output channel to which the results are sent. C NOUT >= 0. C C A (input) COMPLEX*16 array, dimension (LDA,N) C The leading M-by-N part of this array must contain the C matrix to be printed. C C LDA INTEGER C The leading dimension of array A. LDA >= M. C C TEXT (input) CHARACTER*72. C Title caption of the matrix to be printed (up to a C maximum of 72 characters). For example, TEXT = 'Matrix 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 The routine first prints the contents of TEXT as a title, followed C by the elements of the matrix A such that C C (i) if N <= L, the leading M-by-N part is printed; C (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of C consecutive columns of A are printed one after another C followed by one M-by-p block containing the last p columns C of A. C C Row numbers are printed on the left of each row and a column C number appears on top of each complex column. C The routine uses 2 + (k + 1)*(m + 1) lines and 7 + 32*c positions C per line where c is the actual number of columns, (i.e. c = L C or c = p). C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1997. C Complex version: V. Sima, Research Institute for Informatics, C Bucharest, Dec. 2008. C C REVISIONS C C - C C ****************************************************************** C C .. Scalar Arguments .. INTEGER INFO, L, LDA, M, N, NOUT CHARACTER*(*) TEXT C .. Array Arguments .. COMPLEX*16 A(LDA,*) C .. Local Scalars .. INTEGER I, J, J1, J2, JJ, LENTXT, LTEXT, N1 C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC LEN, MIN C .. Executable Statements .. C INFO = 0 C C Test the input scalar arguments. C IF( M.LT.1 ) THEN INFO = -1 ELSE IF( N.LT.1 ) THEN INFO = -2 ELSE IF( L.LT.1 .OR. L.GT.3 ) THEN INFO = -3 ELSE IF( NOUT.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.M ) THEN INFO = -6 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'UD01MZ', -INFO ) RETURN END IF C LENTXT = LEN( TEXT ) C DO 20 LTEXT = MIN( 72, LENTXT ), 2, -1 IF ( TEXT(LTEXT:LTEXT).NE.' ' ) GO TO 40 20 CONTINUE C 40 CONTINUE WRITE ( NOUT, FMT=99996 ) TEXT(1:LTEXT), M, N N1 = ( N-1 )/L J1 = 1 J2 = L C DO 80 J = 1, N1 WRITE ( NOUT, FMT=99999 ) ( JJ, JJ=J1, J2 ) C DO 60 I = 1, M WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, J2 ) 60 CONTINUE C WRITE ( NOUT, FMT=99998 ) J1 = J1 + L J2 = J2 + L 80 CONTINUE C WRITE ( NOUT, FMT=99999 ) ( J, J=J1, N ) C DO 100 I = 1, M WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, N ) 100 CONTINUE C WRITE ( NOUT, FMT=99998 ) C RETURN C 99999 FORMAT (7X,5(13X,I5,14X) ) 99998 FORMAT (' ' ) 99997 FORMAT (1X,I5,2X,3(D15.7,SP,D15.7,S,'i ') ) 99996 FORMAT (1X,A,' (',I5,'X',I5,')',/ ) C *** Last line of UD01MZ *** END control-4.1.2/src/slicot/src/PaxHeaders/SG03BV.f0000644000000000000000000000013215012430707016201 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SG03BV.f0000644000175000017500000005365415012430707017412 0ustar00lilgelilge00000000000000 SUBROUTINE SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, $ INFO ) C C PURPOSE C C To compute the Cholesky factor U of the matrix X, X = U**T * U or C X = U * U**T, which is the solution of the generalized c-stable C continuous-time Lyapunov equation C C T T 2 T C A * X * E + E * X * A = - SCALE * B * B, (1) C C or the transposed equation C C T T 2 T C A * X * E + E * X * A = - SCALE * B * B , (2) C C respectively, where A, E, B, and U are real N-by-N matrices. The C Cholesky factor U of the solution is computed without first C finding X. The pencil A - lambda * E must be in generalized Schur C form ( A upper quasitriangular, E upper triangular ). Moreover, it C must be c-stable, i.e., its eigenvalues must have negative real C parts. B must be an upper triangular matrix with non-negative C entries on its main diagonal. C C The resulting matrix U is upper triangular. The entries on its C main diagonal are non-negative. SCALE is an output scale factor C set to avoid overflow in U. C C ARGUMENTS C C Mode Parameters C C TRANS CHARACTER*1 C Specifies whether equation (1) or equation (2) is to be C solved: 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 matrices. 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. The elements C below the upper Hessenberg part are not referenced. 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 triangular matrix E. The elements below C the main diagonal are not referenced. C C LDE INTEGER C The leading dimension of the array E. LDE >= MAX(1,N). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) C On entry, the leading N-by-N upper triangular part of this C array must contain the matrix B. C On exit, the leading N-by-N upper triangular part of this C array contains the solution matrix U. The elements below C the main diagonal are not referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,N). C C SCALE (output) DOUBLE PRECISION C The scale factor set to avoid overflow in U. C 0 < SCALE <= 1. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (6*N-6) 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 generalized Sylvester equation to be solved in C step II (see METHOD) is (nearly) singular to working C precision; perturbed values were used to solve the C equation (but the matrices A and E are unchanged); C = 2: the generalized Schur form of the pencil C A - lambda * E contains a 2-by-2 main diagonal block C whose eigenvalues are not a pair of complex C conjugate numbers; C = 3: the pencil A - lambda * E is not stable, i.e., there C is an eigenvalue with zero or positive real part. C C METHOD C C The method [2] used by the routine is an extension of Hammarling's C algorithm [1] to generalized Lyapunov equations. C C We present the method for solving equation (1). Equation (2) can C be treated in a similar fashion. For simplicity, assume SCALE = 1. C C The matrix A is an upper quasitriangular matrix, i.e., it is a C block triangular matrix with square blocks on the main diagonal C and the block order at most 2. We use the following partitioning C for the matrices A, E, B and the solution matrix U C C ( A11 A12 ) ( E11 E12 ) C A = ( ), E = ( ), C ( 0 A22 ) ( 0 E22 ) C C ( B11 B12 ) ( U11 U12 ) C B = ( ), U = ( ). (3) C ( 0 B22 ) ( 0 U22 ) C C The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or C 2-by-2. C C We compute U11, U12**T, and U22 in three steps. C C Step I: C C From (1) and (3) we get the 1-by-1 or 2-by-2 equation C C T T T T C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 C C T C = - B11 * B11. C C For brevity, details are omitted here. The technique for C computing U11 is similar to those applied to standard Lyapunov C equations in Hammarling's algorithm ([1], section 6). C C Furthermore, the auxiliary matrices M1 and M2 defined as C follows C C -1 -1 C M1 = U11 * A11 * E11 * U11 , C C -1 -1 C M2 = B11 * E11 * U11 , C C are computed in a numerically reliable way. C C Step II: C C We solve for U12**T the generalized Sylvester equation C C T T T T C A22 * U12 + E22 * U12 * M1 C C T T T T T C = - B12 * M2 - A12 * U11 - E12 * U11 * M1. C C Step III: C C One can show that C C T T T T C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = C C T T C - B22 * B22 - y * y (4) C C holds, where y is defined as follows C C T T T T C w = E12 * U11 + E22 * U12 , C T T C y = B12 - w * M2 . C C If B22_tilde is the square triangular matrix arising from the C QR-factorization C C ( B22_tilde ) ( B22 ) C Q * ( ) = ( ), C ( 0 ) ( y**T ) C C then C C T T T C - B22 * B22 - y * y = - B22_tilde * B22_tilde. C C Replacing the right hand side in (4) by the term C - B22_tilde**T * B22_tilde leads to a generalized Lyapunov C equation of lower dimension compared to (1). C C The solution U of the equation (1) can be obtained by recursive C application of the steps I to III. C C REFERENCES C C [1] Hammarling, S.J. C Numerical solution of the stable, non-negative definite C Lyapunov equation. C IMA J. Num. Anal., 2, pp. 303-323, 1982. 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 The routine requires 2*N**3 flops. Note that we count a single C floating point arithmetic operation as one flop. C C FURTHER COMMENTS C C The Lyapunov equation may be very ill-conditioned. In particular, C if the pencil A - lambda * E has a pair of almost degenerate C eigenvalues, then the Lyapunov equation will be ill-conditioned. C Perturbed values were used to solve the equation. C A condition estimate can be obtained from the routine SG03AD. C When setting the error indicator INFO, the routine does not test C for near instability in the equation but only for exact C instability. C C CONTRIBUTOR C C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. C C REVISIONS C C Sep. 1998, Dec. 2021 (V. Sima). C C KEYWORDS C C Lyapunov equation C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION MONE, ONE, TWO, ZERO PARAMETER ( MONE = -1.0D0, ONE = 1.0D+0, TWO = 2.0D+0, $ ZERO = 0.0D+0 ) C .. Scalar Arguments .. CHARACTER TRANS DOUBLE PRECISION SCALE INTEGER INFO, LDA, LDB, LDE, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*) C .. Local Scalars .. DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, R, S, SCALE1, SMLNUM, $ SQTWO, T, X INTEGER I, INFO1, J, KB, KH, KL, KL1, L, LDWS, UIIPT, $ WPT, YPT LOGICAL NOTRNS C .. Local Arrays .. DOUBLE PRECISION M1(2,2), M2(2,2), TM(2,2), UI(2,2) C .. External Functions .. DOUBLE PRECISION DLAMCH LOGICAL LSAME EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DLABAD, DLACPY, DLARTG, DLASCL, $ DLASET, DROT, DSCAL, DTRMM, SG03BW, SG03BX, $ XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, SQRT 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 ( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE INFO = 0 END IF IF ( INFO.NE.0 ) THEN CALL XERBLA( 'SG03BV', -INFO ) RETURN END IF C SCALE = ONE C C Quick return if possible. C IF ( N.EQ.0 ) $ RETURN C C Set constants to control overflow. C SQTWO = SQRT( TWO ) EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' )/EPS BIGNUM = ONE/SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) C C Set workspace pointers and leading dimension of matrices in the C workspace. C UIIPT = 1 WPT = 2*N-1 YPT = 4*N-3 LDWS = N-1 C IF ( NOTRNS ) THEN C C Solve equation (1). C C Main Loop. Compute block row U(KL:KH,KL:N). KB denotes the C number of rows in this block row. C KH = 0 C WHILE ( KH.LT.N ) DO 20 CONTINUE IF ( KH.LT.N ) THEN KL = KH + 1 IF ( KL.EQ.N ) THEN KH = N KB = 1 ELSE IF ( A(KL+1,KL).EQ.ZERO ) THEN KH = KL KB = 1 ELSE KH = KL + 1 KB = 2 END IF END IF C C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary C matrices M1 and M2. (For the moment the result C U(KL:KH,KL:KH) is stored in UI). C IF ( KB.EQ.1 ) THEN DELTA1 = -A(KL,KL) IF ( DELTA1.LE.ZERO ) THEN INFO = 3 RETURN END IF DELTA1 = SQRT( DELTA1 )*SQRT( E(KL,KL) ) T = ( B(KL,KL)*SMLNUM )/SQTWO IF ( T.GT.DELTA1 ) THEN SCALE1 = DELTA1/T SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) END IF UI(1,1) = B(KL,KL)/DELTA1/SQTWO M1(1,1) = A(KL,KL)/E(KL,KL) M2(1,1) = ( DELTA1/E(KL,KL) )*SQTWO ELSE C C If a pair of complex conjugate eigenvalues occurs, apply C (complex) Hammarling algorithm for the 2-by-2 problem. C CALL SG03BX( 'C', 'N', A(KL,KL), LDA, E(KL,KL), LDE, $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, $ INFO ) IF ( INFO.NE.0 ) $ RETURN IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) END IF END IF C IF ( KH.LT.N ) THEN C C STEP II: Compute U(KL:KH,KH+1:N) by solving a generalized C Sylvester equation. (For the moment the result C U(KL:KH,KH+1:N) is stored in the workspace.) C C Form right hand side of the Sylvester equation. C CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, B(KL,KH+1), $ LDB, M2, 2, ZERO, DWORK(UIIPT), LDWS ) CALL DGEMM( 'T', 'T', N-KH, KB, KB, MONE, A(KL,KH+1), $ LDA, UI, 2, ONE, DWORK(UIIPT), LDWS ) CALL DGEMM( 'T', 'N', KB, KB, KB, ONE, UI, 2, M1, 2, $ ZERO, TM, 2 ) CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, E(KL,KH+1), $ LDE, TM, 2, ONE, DWORK(UIIPT), LDWS ) C C Solve generalized Sylvester equation. C CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 ) CALL SG03BW( 'N', N-KH, KB, A(KH+1,KH+1), LDA, TM, 2, $ E(KH+1,KH+1), LDE, M1, 2, DWORK(UIIPT), $ LDWS, SCALE1, INFO ) IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) CALL DSCAL( 4, SCALE1, UI, 1 ) END IF C C STEP III: Form the right hand side matrix C B(KH+1:N,KH+1:N) of the (smaller) Lyapunov C equation to be solved during the next pass of C the main loop. C C Compute auxiliary vectors (or matrices) W and Y. C CALL DLACPY( 'A', N-KH, KB, DWORK(UIIPT), LDWS, $ DWORK(WPT), LDWS ) CALL DTRMM( 'L', 'U', 'T', 'N', N-KH, KB, ONE, $ E(KH+1,KH+1), LDE, DWORK(WPT), LDWS ) CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, E(KL,KH+1), $ LDE, UI, 2, ONE, DWORK(WPT), LDWS ) CALL DCOPY( N-KH, B(KL,KH+1), LDB, DWORK(YPT), 1 ) IF ( KH.GT.KL ) $ CALL DCOPY( N-KH, B(KH,KH+1), LDB, DWORK(YPT+LDWS), 1) CALL DGEMM( 'N', 'T', N-KH, KB, KB, MONE, DWORK(WPT), $ LDWS, M2, 2, ONE, DWORK(YPT), LDWS ) C C Overwrite B(KH+1:N,KH+1:N) with the triangular matrix C from the QR-factorization of the (N-KH+KB)-by-(N-KH) C matrix C C ( B(KH+1:N,KH+1:N) ) C ( ) C ( Y**T ) . C L = YPT - 1 DO 60 J = 1, KB DO 40 I = 1, N-KH X = B(KH+I,KH+I) T = DWORK(L+I) CALL DLARTG( X, T, C, S, R ) B(KH+I,KH+I) = R IF ( I.LT.N-KH ) $ CALL DROT( N-KH-I, B(KH+I,KH+I+1), LDB, $ DWORK(L+I+1), 1, C, S ) 40 CONTINUE L = L + LDWS 60 CONTINUE C C Make main diagonal elements of B(KH+1:N,KH+1:N) positive. C DO 80 I = KH+1, N IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( N-I+1, MONE, B(I,I), LDB ) 80 CONTINUE C C Overwrite right hand side with the part of the solution C computed in step II. C CALL DCOPY( N-KH, DWORK(UIIPT), 1, B(KL,KH+1), LDB ) IF ( KH.GT.KL ) $ CALL DCOPY( N-KH, DWORK(UIIPT+LDWS), 1, B(KH,KH+1), $ LDB ) END IF C C Overwrite right hand side with the part of the solution C computed in step I. C CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) C GOTO 20 END IF C END WHILE 20 C ELSE C C Solve equation (2). C C Main Loop. Compute block column U(1:KH,KL:KH). KB denotes the C number of columns in this block column. C KL = N + 1 C WHILE ( KL.GT.1 ) DO 100 CONTINUE IF ( KL.GT.1 ) THEN KH = KL - 1 IF ( KH.EQ.1 ) THEN KL = 1 KB = 1 ELSE IF ( A(KH,KH-1).EQ.ZERO ) THEN KL = KH KB = 1 ELSE KL = KH - 1 KB = 2 END IF END IF KL1 = KL - 1 C C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary C matrices M1 and M2. (For the moment the result C U(KL:KH,KL:KH) is stored in UI). C IF ( KB.EQ.1 ) THEN DELTA1 = -A(KL,KL) IF ( DELTA1.LE.ZERO ) THEN INFO = 3 RETURN END IF DELTA1 = SQRT( DELTA1 )*SQRT( E(KL,KL) ) T = ( B(KL,KL)*SMLNUM )/SQTWO IF ( T.GT.DELTA1 ) THEN SCALE1 = DELTA1/T SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) END IF UI(1,1) = B(KL,KL)/DELTA1/SQTWO M1(1,1) = A(KL,KL)/E(KL,KL) M2(1,1) = ( DELTA1/E(KL,KL) )*SQTWO ELSE C C If a pair of complex conjugate eigenvalues occurs, apply C (complex) Hammarling algorithm for the 2-by-2 problem. C CALL SG03BX( 'C', 'T', A(KL,KL), LDA, E(KL,KL), LDE, $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, $ INFO ) IF ( INFO.NE.0 ) $ RETURN IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) END IF END IF C IF ( KL.GT.1 ) THEN C C STEP II: Compute U(1:KL-1,KL:KH) by solving a generalized C Sylvester equation. (For the moment the result C U(1:KL-1,KL:KH) is stored in the workspace.) C C Form right hand side of the Sylvester equation. C CALL DGEMM( 'N', 'T', KL1, KB, KB, MONE, B(1,KL), LDB, $ M2, 2, ZERO, DWORK(UIIPT), LDWS ) CALL DGEMM( 'N', 'N', KL1, KB, KB, MONE, A(1,KL), LDA, $ UI, 2, ONE, DWORK(UIIPT), LDWS ) CALL DGEMM( 'N', 'T', KB, KB, KB, ONE, UI, 2, M1, 2, $ ZERO, TM, 2 ) CALL DGEMM( 'N', 'N', KL1, KB, KB, MONE, E(1,KL), LDE, $ TM, 2, ONE, DWORK(UIIPT), LDWS ) C C Solve generalized Sylvester equation. C CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 ) CALL SG03BW( 'T', KL1, KB, A, LDA, TM, 2, E, LDE, M1, 2, $ DWORK(UIIPT), LDWS, SCALE1, INFO ) IF ( SCALE1.NE.ONE ) THEN SCALE = SCALE1*SCALE CALL DLASCL( 'Upper', 0, 0, ONE, SCALE1, N, N, B, LDB, $ INFO1 ) CALL DSCAL( 4, SCALE1, UI, 1 ) END IF C C STEP III: Form the right hand side matrix C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov C equation to be solved during the next pass of C the main loop. C C Compute auxiliary vectors (or matrices) W and Y. C CALL DLACPY( 'A', KL1, KB, DWORK(UIIPT), LDWS, $ DWORK(WPT), LDWS ) CALL DTRMM( 'L', 'U', 'N', 'N', KL1, KB, ONE, E, LDE, $ DWORK(WPT), LDWS ) CALL DGEMM( 'N', 'N', KL1, KB, KB, ONE, E(1,KL), LDE, $ UI, 2, ONE, DWORK(WPT), LDWS ) CALL DLACPY( 'A', KL1, KB, B(1, KL), LDB, DWORK(YPT), $ LDWS ) CALL DGEMM( 'N', 'N', KL1, KB, KB, MONE, DWORK(WPT), $ LDWS, M2, 2, ONE, DWORK(YPT), LDWS ) C C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix C from the RQ-factorization of the (KL-1)-by-KH matrix C C ( ) C ( B(1:KL-1,1:KL-1) Y ) C ( ). C L = YPT - 1 DO 140 J = 1, KB DO 120 I = KL1, 1, -1 X = B(I,I) T = DWORK(L+I) CALL DLARTG( X, T, C, S, R ) B(I,I) = R IF ( I.GT.1 ) $ CALL DROT( I-1, B(1,I), 1, DWORK(L+1), 1, C, S ) 120 CONTINUE L = L + LDWS 140 CONTINUE C C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. C DO 160 I = 1, KL1 IF ( B(I,I).LT.ZERO ) $ CALL DSCAL( I, MONE, B(1,I), 1 ) 160 CONTINUE C C Overwrite right hand side with the part of the solution C computed in step II. C CALL DLACPY( 'A', KL1, KB, DWORK(UIIPT), LDWS, B(1,KL), $ LDB ) C END IF C C Overwrite right hand side with the part of the solution C computed in step I. C CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) C GOTO 100 END IF C END WHILE 100 C END IF C RETURN C *** Last line of SG03BV *** END control-4.1.2/src/slicot/src/PaxHeaders/NF01BV.f0000644000000000000000000000013015012430707016167 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/NF01BV.f0000644000175000017500000001532115012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE NF01BV( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J, $ LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the matrix J'*J + c*I, for the Jacobian J as received C from SLICOT Library routine NF01BY, for one output variable. C C NOTE: this routine must have the same arguments as SLICOT Library C routine NF01BU. C C ARGUMENTS C C Mode Parameters C C STOR CHARACTER*1 C Specifies the storage scheme for the symmetric C matrix J'*J + c*I, as follows: C = 'F' : full storage is used; C = 'P' : packed storage is used. C C UPLO CHARACTER*1 C Specifies which part of the matrix J'*J + c*I is stored, C as follows: C = 'U' : the upper triagular part is stored; C = 'L' : the lower triagular part is stored. C C Input/Output Parameters C C N (input) INTEGER C The number of columns of the Jacobian matrix J. N >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of the C matrix J, as follows: C IPAR(1) must contain the number of rows M of the Jacobian C matrix J. M >= 0. C IPAR is provided for compatibility with SLICOT Library C routine MD03AD. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 1. C C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) C The real parameters needed for solving the problem. C The entry DPAR(1) must contain the real scalar c. C C LDPAR (input) INTEGER C The length of the array DPAR. LDPAR >= 1. C C J (input) DOUBLE PRECISION array, dimension (LDJ,N) C The leading M-by-N part of this array must contain the C Jacobian matrix J. C C LDJ INTEGER C The leading dimension of the array J. LDJ >= MAX(1,M). C C JTJ (output) DOUBLE PRECISION array, C dimension (LDJTJ,N), if STOR = 'F', C dimension (N*(N+1)/2), if STOR = 'P'. C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if C STOR = 'P') part of this array contains the upper or C lower triangle of the matrix J'*J + c*I, depending on C UPLO = 'U', or UPLO = 'L', respectively, stored either as C a two-dimensional, or one-dimensional array, depending C on STOR. C C LDJTJ INTEGER C The leading dimension of the array JTJ. C LDJTJ >= MAX(1,N), if STOR = 'F'. C LDJTJ >= 1, if STOR = 'P'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C Currently, this array is not used. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 0. 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 product is computed columnn-wise, exploiting the C symmetry. BLAS 3 routine DSYRK is used if STOR = 'F', and BLAS 2 C routine DGEMV is used if STOR = 'P'. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. C C REVISIONS C C V. Sima, March 2002. C C KEYWORDS C C Elementary matrix operations, matrix algebra, matrix operations, C Wiener system. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER STOR, UPLO INTEGER INFO, LDJ, LDJTJ, LDPAR, LDWORK, LIPAR, N C .. Array Arguments .. INTEGER IPAR(*) DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), JTJ(*) C .. Local Scalars .. LOGICAL FULL, UPPER INTEGER I, II, M DOUBLE PRECISION C C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGEMV, DLASET, DSYRK, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C INFO = 0 FULL = LSAME( STOR, 'F' ) UPPER = LSAME( UPLO, 'U' ) C IF( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN INFO = -1 ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN INFO = -2 ELSEIF ( N.LT.0 ) THEN INFO = -3 ELSEIF ( LIPAR.LT.1 ) THEN INFO = -5 ELSEIF ( LDPAR.LT.1 ) THEN INFO = -7 ELSEIF ( LDJTJ.LT.1 .OR. ( FULL .AND. LDJTJ.LT.N ) ) THEN INFO = -11 ELSEIF ( LDWORK.LT.0 ) THEN INFO = -13 ELSE M = IPAR(1) IF ( M.LT.0 ) THEN INFO = -4 ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN INFO = -9 ENDIF ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'NF01BV', -INFO ) RETURN ENDIF C C Quick return if possible. C C = DPAR(1) IF ( N.EQ.0 ) THEN RETURN ELSE IF ( M.EQ.0 ) THEN IF ( FULL ) THEN CALL DLASET( UPLO, N, N, ZERO, C, JTJ, LDJTJ ) ELSE DUM(1) = ZERO CALL DCOPY( ( N*( N + 1 ) )/2, DUM, 0, JTJ, 1 ) IF ( UPPER ) THEN II = 0 C DO 10 I = 1, N II = II + I JTJ(II) = C 10 CONTINUE C ELSE II = 1 C DO 20 I = N, 1, -1 JTJ(II) = C II = II + I 20 CONTINUE C ENDIF ENDIF RETURN ENDIF C C Build a triangle of the matrix J'*J + c*I. C IF ( FULL ) THEN CALL DLASET( UPLO, N, N, ZERO, C, JTJ, LDJTJ ) CALL DSYRK( UPLO, 'Transpose', N, M, ONE, J, LDJ, ONE, JTJ, $ LDJTJ ) ELSEIF ( UPPER ) THEN II = 0 C DO 30 I = 1, N CALL DGEMV( 'Transpose', M, I, ONE, J, LDJ, J(1,I), 1, ZERO, $ JTJ(II+1), 1 ) II = II + I JTJ(II) = JTJ(II) + C 30 CONTINUE C ELSE II = 1 C DO 40 I = N, 1, -1 CALL DGEMV( 'Transpose', M, I, ONE, J(1,N-I+1), LDJ, $ J(1,N-I+1), 1, ZERO, JTJ(II), 1 ) JTJ(II) = JTJ(II) + C II = II + I 40 CONTINUE C ENDIF C RETURN C C *** Last line of NF01BV *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03QY.f0000644000000000000000000000013215012430707016216 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB03QY.f0000644000175000017500000003255715012430707017426 0ustar00lilgelilge00000000000000 SUBROUTINE SB03QY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To estimate the separation between the matrices op(A) and -op(A)', C C sep(op(A),-op(A)') = min norm(op(A)'*X + X*op(A))/norm(X) C = 1 / norm(inv(Omega)) C C and/or the 1-norm of Theta, where op(A) = A or A' (A**T), and C Omega and Theta are linear operators associated to the real C continuous-time Lyapunov matrix equation C C op(A)'*X + X*op(A) = C, C C defined by C C Omega(W) = op(A)'*W + W*op(A), C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). C C The 1-norm condition estimators are used. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the computation to be performed, as follows: C = 'S': Compute the separation only; C = 'T': Compute the norm of Theta only; C = 'B': Compute both the separation and the norm of Theta. 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 LYAPUN CHARACTER*1 C Specifies whether or not the original Lyapunov equations C should be solved, as follows: C = 'O': Solve the original Lyapunov equations, updating C the right-hand sides and solutions with the C matrix U, e.g., X <-- U'*X*U; C = 'R': Solve reduced Lyapunov equations only, without C updating the right-hand sides and solutions. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A and X. N >= 0. C C T (input) DOUBLE PRECISION array, dimension (LDT,N) C The leading N-by-N upper Hessenberg part of this array C must contain the upper quasi-triangular matrix T in Schur C canonical form from a Schur factorization of A. C C LDT INTEGER C The leading dimension of array T. LDT >= MAX(1,N). C C U (input) DOUBLE PRECISION array, dimension (LDU,N) C The leading N-by-N part of this array must contain the C orthogonal matrix U from a real Schur factorization of A. C If LYAPUN = 'R', the array U is not referenced. C C LDU INTEGER C The leading dimension of array U. C LDU >= 1, if LYAPUN = 'R'; C LDU >= MAX(1,N), if LYAPUN = 'O'. C C X (input) DOUBLE PRECISION array, dimension (LDX,N) C The leading N-by-N part of this array must contain the C solution matrix X of the Lyapunov equation (reduced C Lyapunov equation if LYAPUN = 'R'). C If JOB = 'S', the array X is not referenced. C C LDX INTEGER C The leading dimension of array X. C LDX >= 1, if JOB = 'S'; C LDX >= MAX(1,N), if JOB = 'T' or 'B'. C C SEP (output) DOUBLE PRECISION C If JOB = 'S' or JOB = 'B', and INFO >= 0, SEP contains the C estimated separation of the matrices op(A) and -op(A)'. C If JOB = 'T' or N = 0, SEP is not referenced. C C THNORM (output) DOUBLE PRECISION C If JOB = 'T' or JOB = 'B', and INFO >= 0, THNORM contains C the estimated 1-norm of operator Theta. C If JOB = 'S' or N = 0, THNORM is not referenced. C C Workspace C C IWORK INTEGER array, dimension (N*N) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= 2*N*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 = N+1: if the matrices T and -T' have common or very C close eigenvalues; perturbed values were used to C solve Lyapunov equations (but the matrix T is C unchanged). C C METHOD C C SEP is defined as the separation of op(A) and -op(A)': C C sep( op(A), -op(A)' ) = sigma_min( K ) C C where sigma_min(K) is the smallest singular value of the C N*N-by-N*N matrix C C K = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ). C C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker C product. The routine estimates sigma_min(K) by the reciprocal of C an estimate of the 1-norm of inverse(K), computed as suggested in C [1]. This involves the solution of several continuous-time C Lyapunov equations, either direct or transposed. The true C reciprocal 1-norm of inverse(K) cannot differ from sigma_min(K) by C more than a factor of N. C The 1-norm of Theta is estimated similarly. C C REFERENCES C C [1] Higham, N.J. C FORTRAN codes for estimating the one-norm of a real or C complex matrix, with applications to condition estimation. C ACM Trans. Math. Softw., 14, pp. 381-396, 1988. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C FURTHER COMMENTS C C When SEP is zero, the routine returns immediately, with THNORM C (if requested) not set. In this case, the equation is singular. C The option LYAPUN = 'R' may occasionally produce slightly worse C or better estimates, and it is much faster than the option 'O'. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Romania, C Oct. 1998. Partly based on DGLSVX (and then SB03QD) by P. Petkov, C Tech. University of Sofia, March 1998 (and December 1998). C C REVISIONS C C February 13, 1999, V. Sima, Katholieke Univ. Leuven, Belgium. C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004, C May 2020. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) C .. C .. Scalar Arguments .. CHARACTER JOB, LYAPUN, TRANA INTEGER INFO, LDT, LDU, LDWORK, LDX, N DOUBLE PRECISION SEP, THNORM C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION DWORK( * ), T( LDT, * ), U( LDU, * ), $ X( LDX, * ) C .. C .. Local Scalars .. LOGICAL NOTRNA, UPDATE, WANTS, WANTT CHARACTER TRANAT, UPLO INTEGER INFO2, ITMP, KASE, NN DOUBLE PRECISION BIGNUM, EST, SCALE C .. C .. Local Arrays .. INTEGER ISAVE( 3 ) C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSY EXTERNAL DLAMCH, DLANSY, LSAME C .. C .. External Subroutines .. EXTERNAL DLACN2, DLACPY, DSCAL, DSYR2K, MA02ED, MB01RU, $ SB03MY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Decode and Test input parameters. C WANTS = LSAME( JOB, 'S' ) WANTT = LSAME( JOB, 'T' ) NOTRNA = LSAME( TRANA, 'N' ) UPDATE = LSAME( LYAPUN, 'O' ) C NN = N*N INFO = 0 IF( .NOT. ( WANTS .OR. WANTT .OR. LSAME( JOB, 'B' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. $ LSAME( TRANA, 'C' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN INFO = -8 ELSE IF( LDX.LT.1 .OR. ( .NOT.WANTS .AND. LDX.LT.N ) ) THEN INFO = -10 ELSE IF( LDWORK.LT.2*NN ) THEN INFO = -15 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03QY', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C ITMP = NN + 1 C IF( NOTRNA ) THEN TRANAT = 'T' ELSE TRANAT = 'N' END IF C IF( .NOT.WANTT ) THEN C C Estimate sep(op(A),-op(A)'). C Workspace: 2*N*N. C KASE = 0 C C REPEAT 10 CONTINUE CALL DLACN2( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE, ISAVE $ ) IF( KASE.NE.0 ) THEN C C Select the triangular part of symmetric matrix to be used. C IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) $ .GE. $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) $ ) THEN UPLO = 'U' ELSE UPLO = 'L' END IF C IF( UPDATE ) THEN C C Transform the right-hand side: RHS := U'*RHS*U. C CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, $ INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) END IF CALL MA02ED( UPLO, N, DWORK, N ) C IF( KASE.EQ.1 ) THEN C C Solve op(T)'*Y + Y*op(T) = scale*RHS. C CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) ELSE C C Solve op(T)*W + W*op(T)' = scale*RHS. C CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) END IF C IF( INFO2.GT.0 ) $ INFO = N + 1 C IF( UPDATE ) THEN C C Transform back to obtain the solution: Z := U*Z*U', with C Z = Y or Z = W. C CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), $ NN, INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( UPLO, N, DWORK, N ) END IF C GO TO 10 END IF C UNTIL KASE = 0 C IF( EST.GT.SCALE ) THEN SEP = SCALE / EST ELSE BIGNUM = ONE / DLAMCH( 'Safe minimum' ) IF( SCALE.LT.EST*BIGNUM ) THEN SEP = SCALE / EST ELSE SEP = BIGNUM END IF END IF C C Return if the equation is singular. C IF( SEP.EQ.ZERO ) $ RETURN END IF C IF( .NOT.WANTS ) THEN C C Estimate norm(Theta). C Workspace: 2*N*N. C KASE = 0 C C REPEAT 20 CONTINUE CALL DLACN2( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE, ISAVE $ ) IF( KASE.NE.0 ) THEN C C Select the triangular part of symmetric matrix to be used. C IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) ) $ .GE. $ DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) ) $ ) THEN UPLO = 'U' ELSE UPLO = 'L' END IF C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( UPLO, N, DWORK, N ) C C Compute RHS = op(W)'*X + X*op(W). C CALL DSYR2K( UPLO, TRANAT, N, N, ONE, DWORK, N, X, LDX, $ ZERO, DWORK( ITMP ), N ) CALL DLACPY( UPLO, N, N, DWORK( ITMP ), N, DWORK, N ) C IF( UPDATE ) THEN C C Transform the right-hand side: RHS := U'*RHS*U. C CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK, $ N, U, LDU, DWORK, N, DWORK( ITMP ), NN, $ INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) END IF CALL MA02ED( UPLO, N, DWORK, N ) C IF( KASE.EQ.1 ) THEN C C Solve op(T)'*Y + Y*op(T) = scale*RHS. C CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 ) ELSE C C Solve op(T)*W + W*op(T)' = scale*RHS. C CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 ) END IF C IF( INFO2.GT.0 ) $ INFO = N + 1 C IF( UPDATE ) THEN C C Transform back to obtain the solution: Z := U*Z*U', with C Z = Y or Z = W. C CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, $ DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ), $ NN, INFO2 ) CALL DSCAL( N, HALF, DWORK, N+1 ) C C Fill in the remaining triangle of the symmetric matrix. C CALL MA02ED( UPLO, N, DWORK, N ) END IF C GO TO 20 END IF C UNTIL KASE = 0 C IF( EST.LT.SCALE ) THEN THNORM = EST / SCALE ELSE BIGNUM = ONE / DLAMCH( 'Safe minimum' ) IF( EST.LT.SCALE*BIGNUM ) THEN THNORM = EST / SCALE ELSE THNORM = BIGNUM END IF END IF END IF C RETURN C *** Last line of SB03QY *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02MD.f0000644000000000000000000000013015012430707016162 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB02MD.f0000644000175000017500000004736215012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE SB02MD( DICO, HINV, UPLO, SCAL, SORT, N, A, LDA, G, $ LDG, Q, LDQ, RCOND, WR, WI, S, LDS, U, LDU, $ IWORK, DWORK, LDWORK, BWORK, INFO ) C C PURPOSE C C To solve for X either the continuous-time algebraic Riccati C equation C -1 C Q + A'*X + X*A - X*B*R B'*X = 0 (1) C C or the discrete-time algebraic Riccati equation C -1 C X = A'*X*A - A'*X*B*(R + B'*X*B) B'*X*A + Q (2) C C where A, B, Q and R are N-by-N, N-by-M, N-by-N and M-by-M matrices C respectively, with Q symmetric and R symmetric nonsingular; X is C an N-by-N symmetric matrix. C -1 C The matrix G = B*R B' must be provided on input, instead of B and C R, that is, for instance, the continuous-time equation C C Q + A'*X + X*A - X*G*X = 0 (3) C C is solved, where G is an N-by-N symmetric matrix. SLICOT Library C routine SB02MT should be used to compute G, given B and R. SB02MT C also enables to solve Riccati equations corresponding to optimal C problems with coupling terms. C C The routine also returns the computed values of the closed-loop C spectrum of the optimal system, i.e., the stable eigenvalues C lambda(1),...,lambda(N) of the corresponding Hamiltonian or C symplectic matrix associated to the optimal problem. C C ARGUMENTS C C Mode Parameters C C DICO CHARACTER*1 C Specifies the type of Riccati equation to be solved as C follows: C = 'C': Equation (3), continuous-time case; C = 'D': Equation (2), discrete-time case. C C HINV CHARACTER*1 C If DICO = 'D', specifies which symplectic matrix is to be C constructed, as follows: C = 'D': The matrix H in (5) (see METHOD) is constructed; C = 'I': The inverse of the matrix H in (5) is constructed. C HINV is not used if DICO = 'C'. C C UPLO CHARACTER*1 C Specifies which triangle of the matrices G and Q is C stored, as follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. C C SCAL CHARACTER*1 C Specifies whether or not a scaling strategy should be C used, as follows: C = 'G': General scaling should be used; C = 'N': No scaling should be used. C C SORT CHARACTER*1 C Specifies which eigenvalues should be obtained in the top C of the Schur form, as follows: C = 'S': Stable eigenvalues come first; C = 'U': Unstable eigenvalues come first. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, Q, G and X. 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 coefficient matrix A of the equation. C On exit, if DICO = 'D', and INFO = 0 or INFO > 1, the C -1 C leading N-by-N part of this array contains the matrix A . C Otherwise, the array A is unchanged on exit. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C G (input) DOUBLE PRECISION array, dimension (LDG,N) C The leading N-by-N upper triangular part (if UPLO = 'U') C or lower triangular part (if UPLO = 'L') of this array C must contain the upper triangular part or lower triangular C part, respectively, of the symmetric matrix G. C The strictly lower triangular part (if UPLO = 'U') or C strictly upper triangular part (if UPLO = 'L') is not C referenced. C C LDG INTEGER C The leading dimension of array G. LDG >= MAX(1,N). C C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) C On entry, the leading N-by-N upper triangular part (if C UPLO = 'U') or lower triangular part (if UPLO = 'L') of C this array must contain the upper triangular part or lower C triangular part, respectively, of the symmetric matrix Q. C The strictly lower triangular part (if UPLO = 'U') or C strictly upper triangular part (if UPLO = 'L') is not C used. C On exit, if INFO = 0, the leading N-by-N part of this C array contains the solution matrix X of the problem. C C LDQ INTEGER C The leading dimension of array N. LDQ >= MAX(1,N). C C RCOND (output) DOUBLE PRECISION C An estimate of the reciprocal of the condition number (in C the 1-norm) of the N-th order system of algebraic C equations from which the solution matrix X is obtained. C C WR (output) DOUBLE PRECISION array, dimension (2*N) C WI (output) DOUBLE PRECISION array, dimension (2*N) C If INFO = 0 or INFO = 5, these arrays contain the real and C imaginary parts, respectively, of the eigenvalues of the C 2N-by-2N matrix S, ordered as specified by SORT (except C for the case HINV = 'D', when the order is opposite to C that specified by SORT). The leading N elements of these C arrays contain the closed-loop spectrum of the system C -1 C matrix A - B*R *B'*X, if DICO = 'C', or of the matrix C -1 C A - B*(R + B'*X*B) B'*X*A, if DICO = 'D'. Specifically, C lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N. C C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) C If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this C array contains the ordered real Schur form S of the C Hamiltonian or symplectic matrix H. That is, C C (S S ) C ( 11 12) C S = ( ), C (0 S ) C ( 22) C C where S , S and S are N-by-N matrices. C 11 12 22 C C LDS INTEGER C The leading dimension of array S. LDS >= MAX(1,2*N). C C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) C If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this C array contains the transformation matrix U which reduces C the Hamiltonian or symplectic matrix H to the ordered real C Schur form S. That is, C C (U U ) C ( 11 12) C U = ( ), C (U U ) C ( 21 22) C C where U , U , U and U are N-by-N matrices. C 11 12 21 22 C C LDU INTEGER C The leading dimension of array U. LDU >= MAX(1,2*N). C C Workspace C C IWORK INTEGER array, dimension (2*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) returns the scaling factor used C (set to 1 if SCAL = 'N'), also set if INFO = 5; C if DICO = 'D', DWORK(3) returns the reciprocal condition C number of the given matrix A. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(2,6*N) if DICO = 'C'; C LDWORK >= MAX(3,6*N) if DICO = 'D'. C For optimum performance LDWORK should be larger. 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 matrix A is (numerically) singular in discrete- C time case; C = 2: if the Hamiltonian or symplectic matrix H cannot be C reduced to real Schur form; C = 3: if the real Schur form of the Hamiltonian or C symplectic matrix H cannot be appropriately ordered; C = 4: if the Hamiltonian or symplectic matrix H has less C than N stable eigenvalues; C = 5: if the N-th order system of linear algebraic C equations, from which the solution matrix X would C be obtained, is singular to working precision. C C METHOD C C The method used is the Schur vector approach proposed by Laub. C It is assumed that [A,B] is a stabilizable pair (where for (3) B C is any matrix such that B*B' = G with rank(B) = rank(G)), and C [E,A] is a detectable pair, where E is any matrix such that C E*E' = Q with rank(E) = rank(Q). Under these assumptions, any of C the algebraic Riccati equations (1)-(3) is known to have a unique C non-negative definite solution. See [2]. C Now consider the 2N-by-2N Hamiltonian or symplectic matrix C C ( A -G ) C H = ( ), (4) C (-Q -A'), C C for continuous-time equation, and C -1 -1 C ( A A *G ) C H = ( -1 -1 ), (5) C (Q*A A' + Q*A *G) C -1 C for discrete-time equation, respectively, where G = B*R *B'. C The assumptions guarantee that H in (4) has no pure imaginary C eigenvalues, and H in (5) has no eigenvalues on the unit circle. C If Y is an N-by-N matrix then there exists an orthogonal matrix U C such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U C can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks C (corresponding to the complex conjugate eigenvalues and real C eigenvalues respectively) appear in any desired order. This is the C ordered real Schur form. Thus, we can find an orthogonal C similarity transformation U which puts (4) or (5) in ordered real C Schur form C C U'*H*U = S = (S(1,1) S(1,2)) C ( 0 S(2,2)) C C where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1) C have negative real parts in case of (4), or moduli greater than C one in case of (5). If U is conformably partitioned into four C N-by-N blocks C C U = (U(1,1) U(1,2)) C (U(2,1) U(2,2)) C C with respect to the assumptions we then have C (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1), C (2), or (3) with X = X' and non-negative definite; C (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if C DICO = 'D') are equal to the eigenvalues of optimal system C (the 'closed-loop' spectrum). C C [A,B] is stabilizable if there exists a matrix F such that (A-BF) C is stable. [E,A] is detectable if [A',E'] is stabilizable. C C REFERENCES C C [1] Laub, A.J. C A Schur Method for Solving Algebraic Riccati equations. C IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979. C C [2] Wonham, W.M. C On a matrix Riccati equation of stochastic control. C SIAM J. Contr., 6, pp. 681-697, 1968. C C [3] Sima, V. C Algorithms for Linear-Quadratic Optimization. C Pure and Applied Mathematics: A Series of Monographs and C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C FURTHER COMMENTS C C To obtain a stabilizing solution of the algebraic Riccati C equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set C SORT = 'S', if HINV = 'I'. C C The routine can also compute the anti-stabilizing solutions of C the algebraic Riccati equations, by specifying C SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or C SORT = 'S' if DICO = 'D' and HINV = 'D'. C C Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I' C and SORT = 'U', will be faster then the other combinations [3]. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C Supersedes Release 2.0 routine SB02AD by Control Systems Research C Group, Kingston Polytechnic, United Kingdom, March 1982. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002. C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, discrete-time system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, HINV, SCAL, SORT, UPLO INTEGER INFO, LDA, LDG, LDQ, LDS, LDU, LDWORK, N DOUBLE PRECISION RCOND C .. Array Arguments .. LOGICAL BWORK(*) INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), $ S(LDS,*), U(LDU,*), WR(*), WI(*) C .. Local Scalars .. LOGICAL DISCR, LHINV, LSCAL, LSORT, LUPLO INTEGER I, IERR, ISCL, N2, NP1, NROT DOUBLE PRECISION GNORM, QNORM, RCONDA, UNORM, WRKOPT C .. External Functions .. LOGICAL LSAME, SB02MR, SB02MS, SB02MV, SB02MW DOUBLE PRECISION DLAMCH, DLANGE, DLANSY EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MS, $ SB02MV, SB02MW C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGECON, DGEES, DGETRF, DGETRS, $ DLACPY, DLASCL, DLASET, DSCAL, DSWAP, SB02MU, $ XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C INFO = 0 N2 = N + N NP1 = N + 1 DISCR = LSAME( DICO, 'D' ) LSCAL = LSAME( SCAL, 'G' ) LSORT = LSAME( SORT, 'S' ) LUPLO = LSAME( UPLO, 'U' ) IF ( DISCR ) LHINV = LSAME( HINV, 'D' ) C C Test the input scalar arguments. C IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN INFO = -1 ELSE IF( DISCR ) THEN IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) $ INFO = -2 END IF IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -3 ELSE IF( .NOT.LSCAL .AND. .NOT.LSAME( SCAL, 'N' ) ) THEN INFO = -4 ELSE IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDG.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN INFO = -17 ELSE IF( LDU.LT.MAX( 1, N2 ) ) THEN INFO = -19 ELSE IF( ( .NOT.DISCR .AND. LDWORK.LT.MAX( 2, 6*N ) ) .OR. $ ( DISCR .AND. LDWORK.LT.MAX( 3, 6*N ) ) ) THEN INFO = -22 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB02MD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN RCOND = ONE DWORK(1) = ONE DWORK(2) = ONE IF ( DISCR ) DWORK(3) = ONE RETURN END IF C IF ( LSCAL ) THEN C C Compute the norms of the matrices Q and G. C QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) END IF C C Initialise the Hamiltonian or symplectic matrix associated with C the problem. C Workspace: need 1 if DICO = 'C'; C max(2,4*N) if DICO = 'D'; C prefer larger if DICO = 'D'. C CALL SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S, LDS, $ IWORK, DWORK, LDWORK, INFO ) IF ( INFO.NE.0 ) THEN INFO = 1 RETURN END IF C WRKOPT = DWORK(1) IF ( DISCR ) RCONDA = DWORK(2) C ISCL = 0 IF ( LSCAL ) THEN C C Scale the Hamiltonian or symplectic matrix. C IF( QNORM.GT.GNORM .AND. GNORM.GT.ZERO ) THEN CALL DLASCL( 'G', 0, 0, QNORM, GNORM, N, N, S(NP1,1), N2, $ IERR ) CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, S(1,NP1), N2, $ IERR ) ISCL = 1 END IF END IF C C Find the ordered Schur factorization of S, S = U*H*U'. C Workspace: need 6*N; C prefer larger. C IF ( .NOT.DISCR ) THEN IF ( LSORT ) THEN CALL DGEES( 'Vectors', 'Sorted', SB02MV, N2, S, LDS, NROT, $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) ELSE CALL DGEES( 'Vectors', 'Sorted', SB02MR, N2, S, LDS, NROT, $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) END IF ELSE IF ( LSORT ) THEN CALL DGEES( 'Vectors', 'Sorted', SB02MW, N2, S, LDS, NROT, $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) ELSE CALL DGEES( 'Vectors', 'Sorted', SB02MS, N2, S, LDS, NROT, $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) END IF IF ( LHINV ) THEN CALL DSWAP( N, WR, 1, WR(NP1), 1 ) CALL DSWAP( N, WI, 1, WI(NP1), 1 ) END IF END IF IF ( INFO.GT.N2 ) THEN INFO = 3 ELSE IF ( INFO.GT.0 ) THEN INFO = 2 ELSE IF ( NROT.NE.N ) THEN INFO = 4 END IF IF ( INFO.NE.0 ) $ RETURN C WRKOPT = MAX( WRKOPT, DWORK(1) ) C C Check if U(1,1) is singular. Use the (2,1) block of S as a C workspace for factoring U(1,1). C UNORM = DLANGE( '1-norm', N, N, U, LDU, DWORK ) C CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) CALL DGETRF( N, N, S(NP1,1), LDS, IWORK, INFO ) C IF ( INFO.GT.0 ) THEN C C Singular matrix. Set INFO and RCOND for error return. C INFO = 5 RCOND = ZERO GO TO 100 END IF C C Estimate the reciprocal condition of U(1,1). C Workspace: 6*N. C CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCOND, $ DWORK, IWORK(NP1), INFO ) C IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN C C Nearly singular matrix. Set INFO for error return. C INFO = 5 RETURN END IF C C Transpose U(2,1) in Q and compute the solution. C DO 60 I = 1, N CALL DCOPY( N, U(NP1,I), 1, Q(I,1), LDQ ) 60 CONTINUE C CALL DGETRS( 'Transpose', N, N, S(NP1,1), LDS, IWORK, Q, LDQ, $ INFO ) C C Set S(2,1) to zero. C CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) C C Make sure the solution matrix X is symmetric. C DO 80 I = 1, N - 1 CALL DAXPY( N-I, ONE, Q(I,I+1), LDQ, Q(I+1,I), 1 ) CALL DSCAL( N-I, HALF, Q(I+1,I), 1 ) CALL DCOPY( N-I, Q(I+1,I), 1, Q(I,I+1), LDQ ) 80 CONTINUE C IF( LSCAL ) THEN C C Undo scaling for the solution matrix. C IF( ISCL.EQ.1 ) $ CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, Q, LDQ, IERR ) END IF C C Set the optimal workspace, the scaling factor, and reciprocal C condition number (if any). C DWORK(1) = WRKOPT 100 CONTINUE IF( ISCL.EQ.1 ) THEN DWORK(2) = QNORM / GNORM ELSE DWORK(2) = ONE END IF IF ( DISCR ) DWORK(3) = RCONDA C RETURN C *** Last line of SB02MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04DB.f0000644000000000000000000000013215012430707016145 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04DB.f0000644000175000017500000001421115012430707017340 0ustar00lilgelilge00000000000000 SUBROUTINE MB04DB( JOB, SGN, N, ILO, LSCALE, RSCALE, M, V1, LDV1, $ V2, LDV2, INFO ) C C PURPOSE C C To apply from the left the inverse of a balancing transformation, C computed by the SLICOT Library routine MB04DP, to the matrix C C [ V1 ] C [ ], C [ sgn*V2 ] C C where sgn is either +1 or -1. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the type of inverse transformation required: C = 'N': do nothing, return immediately; C = 'P': do inverse transformation for permutation only; C = 'S': do inverse transformation for scaling only; C = 'B': do inverse transformations for both permutation C and scaling. C JOB must be the same as the argument JOB supplied to C MB04DP. C C SGN CHARACTER*1 C Specifies the sign to use for V2: C = 'P': sgn = +1; C = 'N': sgn = -1. C C Input/Output Parameters C C N (input) INTEGER C The number of rows of the matrices V1 and V2. N >= 0. C C ILO (input) INTEGER C The integer ILO determined by MB04DP. C 1 <= ILO <= N+1. C C LSCALE (input) DOUBLE PRECISION array, dimension (N) C Details of the permutation and scaling factors applied C from the left, as returned by MB04DP. C C RSCALE (input) DOUBLE PRECISION array, dimension (N) C Details of the permutation and scaling factors applied C from the right, as returned by MB04DP. C C M (input) INTEGER C The number of columns of the matrices V1 and V2. M >= 0. C C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,M) C On entry, the leading N-by-M part of this array must C contain the matrix V1. C On exit, the leading N-by-M part of this array is C overwritten by the updated matrix V1 of the transformed C matrix. C C LDV1 INTEGER C The leading dimension of the array V1. LDV1 >= max(1,N). C C V2 (input/output) DOUBLE PRECISION array, dimension (LDV2,M) C On entry, the leading N-by-M part of this array must C contain the matrix V2. C On exit, the leading N-by-M part of this array is C overwritten by the updated matrix V2 of the transformed C matrix. C C LDV2 INTEGER C The leading dimension of the array V2. LDV2 >= max(1,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 REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C [2] Benner, P. C Symplectic balancing of Hamiltonian matrices. C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2001. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2015. C C REVISIONS C C - C C KEYWORDS C C Balancing, Hamiltonian matrix, skew-Hamiltonian matrix, C symplectic equivalence transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOB, SGN INTEGER ILO, INFO, LDV1, LDV2, M, N C .. Array Arguments .. DOUBLE PRECISION LSCALE(*), RSCALE(*), V1(LDV1,*), V2(LDV2,*) C .. Local Scalars .. LOGICAL LPERM, LSCAL, LSGN, SYSW INTEGER I, K C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) LSGN = LSAME( SGN, 'N' ) IF ( .NOT.LPERM .AND. .NOT.LSCAL $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN INFO = -1 ELSE IF ( .NOT.LSGN .AND. .NOT.LSAME( SGN, 'P' ) ) THEN INFO = -2 ELSE IF ( N.LT.0 ) THEN INFO = -3 ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN INFO = -4 ELSE IF ( M.LT.0 ) THEN INFO = -7 ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN INFO = -11 END IF C C Return if there were illegal values. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04DB', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 .OR. M.EQ.0 .OR. LSAME( JOB, 'N' ) ) $ RETURN C C Inverse scaling. C IF ( LSCAL ) THEN DO 10 I = ILO, N CALL DRSCL( M, LSCALE(I), V1(I,1), LDV1 ) 10 CONTINUE DO 20 I = ILO, N CALL DRSCL( M, RSCALE(I), V2(I,1), LDV2 ) 20 CONTINUE END IF C C Inverse permutation. C IF ( LPERM ) THEN DO 30 I = ILO-1, 1, -1 K = LSCALE(I) SYSW = K.GT.N IF ( SYSW ) $ K = K - N C IF ( K.NE.I ) THEN C C Exchange rows k <-> i. C CALL DSWAP( M, V1(I,1), LDV1, V1(K,1), LDV1 ) CALL DSWAP( M, V2(I,1), LDV2, V2(K,1), LDV2 ) END IF C IF ( SYSW ) THEN C C Exchange V1(k,:) <-> V2(k,:). C CALL DSWAP( M, V1(K,1), LDV1, V2(K,1), LDV2 ) C IF ( LSGN ) THEN CALL DSCAL( M, -ONE, V1(K,1), LDV1 ) ELSE CALL DSCAL( M, -ONE, V2(K,1), LDV2 ) END IF END IF 30 CONTINUE END IF C RETURN C *** Last line of MB04DB *** END control-4.1.2/src/slicot/src/PaxHeaders/MC03NY.f0000644000000000000000000000013015012430707016204 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MC03NY.f0000644000175000017500000003307615012430707017413 0ustar00lilgelilge00000000000000 SUBROUTINE MC03NY( NBLCKS, NRA, NCA, A, LDA, E, LDE, IMUK, INUK, $ VEPS, LDVEPS, INFO ) C C PURPOSE C C To determine a minimal basis of the right nullspace of the C subpencil s*E(eps)-A(eps) using the method given in [1] (see C Eqs.(4.6.8), (4.6.9)). C This pencil only contains Kronecker column indices, and it must be C in staircase form as supplied by SLICOT Library Routine MB04VD. C The basis vectors are represented by matrix V(s) having the form C C | V11(s) V12(s) V13(s) . . V1n(s) | C | V22(s) V23(s) V2n(s) | C | V33(s) . | C V(s) = | . . | C | . . | C | . . | C | Vnn(s) | C C where n is the number of full row rank blocks in matrix A(eps) and C C k j-i C Vij(s) = Vij,0 + Vij,1*s +...+ Vij,k*s +...+ Vij,j-i*s . (1) C C In other words, Vij,k is the coefficient corresponding to degree k C in the matrix polynomial Vij(s). C Vij,k has dimensions mu(i)-by-(mu(j)-nu(j)). C The coefficients Vij,k are stored in the matrix VEPS as follows C (for the case n = 3): C C sizes m1-n1 m2-n2 m2-n2 m3-n3 m3-n3 m3-n3 C C m1 { | V11,0 || V12,0 | V12,1 || V13,0 | V13,1 | V13,2 || C | || | || | | || C VEPS = m2 { | || V22,0 | || V23,0 | V23,1 | || C | || | || | | || C m3 { | || | || V33,0 | | || C C where mi = mu(i), ni = nu(i). C Matrix VEPS has dimensions nrv-by-ncv where C nrv = Sum(i=1,...,n) mu(i) C ncv = Sum(i=1,...,n) i*(mu(i)-nu(i)) C C ================================================================== C REMARK: This routine is intended to be called only from the SLICOT C routine MC03ND. C ================================================================== C C ARGUMENTS C C Input/Output Parameters C C NBLCKS (input) INTEGER C Number of full row rank blocks in subpencil C s*E(eps)-A(eps) that contains all Kronecker column indices C of s*E-A. NBLCKS >= 0. C C NRA (input) INTEGER C Number of rows of the subpencil s*E(eps)-A(eps) in s*E-A. C NRA = nu(1) + nu(2) + ... + nu(NBLCKS). NRA >= 0. C C NCA (input) INTEGER C Number of columns of the subpencil s*E(eps)-A(eps) in C s*E-A. C NCA = mu(1) + mu(2) + ... + mu(NBLCKS). NCA >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,NCA) C E (input/output) DOUBLE PRECISION array, dimension (LDE,NCA) C On entry, the leading NRA-by-NCA part of these arrays must C contain the matrices A and E, where s*E-A is the C transformed pencil s*E0-A0 which is the pencil associated C with P(s) as described in [1] Section 4.6. The pencil C s*E-A is assumed to be in generalized Schur form. C On exit, these arrays contain no useful information. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,NRA). C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,NRA). C C IMUK (input) INTEGER array, dimension (NBLCKS) C This array must contain the column dimensions mu(k) of the C full column rank blocks in the subpencil s*E(eps)-A(eps) C of s*E-A. The content of IMUK is modified by the routine C but restored on exit. C C INUK (input) INTEGER array, dimension (NBLCKS) C This array must contain the row dimensions nu(k) of the C full row rank blocks in the subpencil s*E(eps)-A(eps) of C s*E-A. C C VEPS (output) DOUBLE PRECISION array, dimension (LDVEPS,ncv) C Let nrv = Sum(i=1,...,NBLCKS) mu(i) = NCA, C ncv = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)). C The leading nrv-by-ncv part of this array contains the C column vectors of a minimal polynomial basis for the right C nullspace of the subpencil s*E(eps)-A(eps). (See [1] C Section 4.6.4.) An upper bound for ncv is (NRA+1)*NCA. C C LDVEPS INTEGER C The leading dimension of array VEPS. C LDVEPS >= MAX(1,NCA). 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 = k, the k-th diagonal block of A had not a C full row rank. C C REFERENCES C C [1] Th.G.J. Beelen, New Algorithms for Computing the Kronecker C structure of a Pencil with Applications to Systems and C Control Theory. C Ph.D.Thesis, Eindhoven University of Technology, 1987. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC03BY by Th.G.J. Beelen, C A.J. Geurts, and G.J.H.H. van den Hurk. C C REVISIONS C C Dec. 1997. C C KEYWORDS C C Elementary polynomial operations, Kronecker form, polynomial C matrix, polynomial operations, staircase form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDE, LDVEPS, NBLCKS, NCA, NRA C .. Array Arguments .. INTEGER IMUK(*), INUK(*) DOUBLE PRECISION A(LDA,*), E(LDE,*), VEPS(LDVEPS,*) C .. Local Scalars .. INTEGER AC1, AC2, AR1, ARI, ARK, DIF, EC1, ER1, I, J, K, $ MUI, NCV, NRV, NUI, SMUI, SMUI1, VC1, VC2, VR1, $ VR2, WC1, WR1 C .. Local Arrays .. DOUBLE PRECISION DUMMY(1) C .. External Subroutines .. EXTERNAL DCOPY, DGEMM, DLASET, DSCAL, DTRTRS, XERBLA C .. Executable Statements .. C INFO = 0 IF( NBLCKS.LT.0 ) THEN INFO = -1 ELSE IF( NRA.LT.0 ) THEN INFO = -2 ELSE IF( NCA.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, NRA ) ) THEN INFO = -5 ELSE IF( LDE.LT.MAX( 1, NRA ) ) THEN INFO = -7 ELSE IF( LDVEPS.LT.MAX( 1, NCA ) ) THEN INFO = -11 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MC03NY', -INFO ) RETURN END IF C C Quick return if possible. C IF ( NBLCKS.EQ.0 .OR. NRA.EQ.0 .OR. NCA.EQ.0 ) $ RETURN C C Computation of the nonzero parts of W1 and W2: C C | AH11 AH12 ... AH1n | | EH11 EH12 ... EH1n | C | AH22 AH2n | | EH22 EH2n | C W1 = | . . |, W2 = | . . | C | . . | | . . | C | AHnn | | EHnn | C C with AHij = -pinv(Aii) * Aij, EHij = pinv(Aii) * Eij and EHii = 0, C AHij and EHij have dimensions mu(i)-by-mu(j), Aii = [ Oi | Ri ], C and C Ri is a regular nu(i)-by-nu(i) upper triangular matrix; C Oi is a not necessarily square null matrix. C Note that the first mu(i)-nu(i) rows in AHij and EHij are zero. C For memory savings, the nonzero parts of W1 and W2 are constructed C over A and E, respectively. C C (AR1,AC1) denotes the position of the first element of the C submatrix Ri in matrix Aii. C EC1 is the index of the first column of Ai,i+1/Ei,i+1. C EC1 = 1 AR1 = 1 C DO 40 I = 1, NBLCKS - 1 NUI = INUK(I) IF ( NUI.EQ.0 ) GO TO 60 MUI = IMUK(I) EC1 = EC1 + MUI AC1 = EC1 - NUI CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI, $ NCA-EC1+1, A(AR1,AC1), LDA, E(AR1,EC1), LDE, $ INFO ) IF ( INFO.GT.0 ) THEN INFO = I RETURN END IF C DO 20 J = 1, NUI CALL DSCAL( J, -ONE, A(AR1,AC1+J-1), 1 ) 20 CONTINUE C CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI, $ NCA-EC1+1, A(AR1,AC1), LDA, A(AR1,EC1), LDA, $ INFO ) AR1 = AR1 + NUI 40 CONTINUE C 60 CONTINUE C C The contents of the array IMUK is changed for temporary use in C this routine as follows: C C IMUK(i) = Sum(j=1,...,i) mu(j). C C On return, the original contents of IMUK is restored. C In the same loop the actual number of columns of VEPS is computed. C The number of rows of VEPS is NCA. C C NRV = Sum(i=1,...,NBLCKS) mu(i) = NCA, C NCV = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)). C SMUI = 0 NCV = 0 C DO 80 I = 1, NBLCKS MUI = IMUK(I) SMUI = SMUI + MUI IMUK(I) = SMUI NCV = NCV + I*( MUI - INUK(I) ) 80 CONTINUE C NRV = NCA C C Computation of the matrix VEPS. C C Initialisation of VEPS to zero. C CALL DLASET( 'Full', NRV, NCV, ZERO, ZERO, VEPS, LDVEPS ) C | I | C Set Vii,0 = Kii in VEPS , i=1,...,NBLCKS, where Kii = |---| C | O | C and I is an identity matrix of size mu(i)-nu(i), C O is a null matrix, dimensions nu(i)-by-(mu(i)-nu(i)). C C WR1 := Sum(j=1,...,i-1) mu(j) + 1 C is the index of the first row in Vii,0 in VEPS. C WC1 := Sum(j=1,...,i-1) j*(mu(j)-nu(j)) + 1 C is the index of the first column in Vii,0 in VEPS. C DUMMY(1) = ONE NUI = IMUK(1) - INUK(1) CALL DCOPY( NUI, DUMMY, 0, VEPS, LDVEPS+1 ) WR1 = IMUK(1) + 1 WC1 = NUI + 1 C DO 100 I = 2, NBLCKS NUI = IMUK(I) - IMUK(I-1) - INUK(I) CALL DCOPY( NUI, DUMMY, 0, VEPS(WR1,WC1), LDVEPS+1 ) WR1 = IMUK(I) + 1 WC1 = WC1 + I*NUI 100 CONTINUE C C Determination of the remaining nontrivial matrices in Vij,k C block column by block column with decreasing block row index. C C The computation starts with the second block column since V11,0 C has already been determined. C The coefficients Vij,k satisfy the recurrence relation: C C Vij,k = Sum(r=i+1,...,j-k) AHir*Vrj,k + C + Sum(r=i+1,...,j-k+1) EHir*Vrj,k-1, i + k < j, C C = EHi,i+1 * Vi+1,j,k-1 i + k = j. C C This recurrence relation can be derived from [1], (4.6.8) C and formula (1) in Section PURPOSE. C VC1 = IMUK(1) - INUK(1) + 1 ARI = 1 C DO 180 J = 2, NBLCKS DIF = IMUK(J) - IMUK(J-1) - INUK(J) ARI = ARI + INUK(J-1) ARK = ARI C C Computation of the matrices Vij,k where i + k < j. C Each matrix Vij,k has dimension mu(i)-by-(mu(j) - nu(j)). C DO 160 K = 0, J - 2 C C VC1, VC2 are the first and last column index of Vij,k. C VC2 = VC1 + DIF - 1 AC2 = IMUK(J-K) AR1 = ARK ARK = ARK - INUK(J-K-1) C DO 120 I = J - K - 1, 1, -1 C C Compute the first part of Vij,k in decreasing order: C Vij,k := Vij,k + Sum(r=i+1,..,j-k) AHir*Vrj,k. C The non-zero parts of AHir are stored in C A(AR1:AR1+nu(i)-1,AC1:AC2) and Vrj,k are stored in C VEPS(AC1:AC2,VC1:VC2). C The non-zero part of the result is stored in C VEPS(VR1:VR2,VC1:VC2). C VR2 = IMUK(I) AC1 = VR2 + 1 VR1 = AC1 - INUK(I) AR1 = AR1 - INUK(I) CALL DGEMM( 'No transpose', 'No transpose', INUK(I), $ DIF, AC2-VR2, ONE, A(AR1,AC1), LDA, $ VEPS(AC1,VC1), LDVEPS, ONE, VEPS(VR1,VC1), $ LDVEPS ) 120 CONTINUE C ER1 = 1 C DO 140 I = 1, J - K - 1 C C Compute the second part of Vij,k+1 in normal order: C Vij,k+1 := Sum(r=i+1,..,j-k) EHir*Vrj,k. C The non-zero parts of EHir are stored in C E(ER1:ER1+nu(i)-1,EC1:AC2) and Vrj,k are stored in C VEPS(EC1:AC2,VC1:VC2). C The non-zero part of the result is stored in C VEPS(VR1:VR2,VC2+1:VC2+DIF), where C DIF = VC2 - VC1 + 1 = mu(j) - nu(j). C This code portion also computes Vij,k+1 for i + k = j. C VR2 = IMUK(I) EC1 = VR2 + 1 VR1 = EC1 - INUK(I) CALL DGEMM( 'No transpose', 'No transpose', INUK(I), $ DIF, AC2-VR2, ONE, E(ER1,EC1), LDE, $ VEPS(EC1,VC1), LDVEPS, ZERO, VEPS(VR1,VC2+1), $ LDVEPS ) ER1 = ER1 + INUK(I) 140 CONTINUE C VC1 = VC2 + 1 160 CONTINUE C VC1 = VC1 + DIF 180 CONTINUE C C Restore original contents of the array IMUK. C C Since, at the moment: C IMUK(i) = Sum(j=1,...,i) mu(j), (i=1,...,NBLCKS), C the original values are: C mu(i) = IMUK(i) - IMUK(i-1) with IMUK(0 ) = 0. C SMUI1 = 0 C DO 200 I = 1, NBLCKS SMUI = IMUK(I) IMUK(I) = SMUI - SMUI1 SMUI1 = SMUI 200 CONTINUE C RETURN C *** Last line of MC03NY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04DP.f0000644000000000000000000000013215012430707016163 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04DP.f0000644000175000017500000012544215012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE MB04DP( JOB, N, THRESH, A, LDA, DE, LDDE, C, LDC, VW, $ LDVW, ILO, LSCALE, RSCALE, DWORK, IWARN, INFO ) C C PURPOSE C C To balance the 2*N-by-2*N skew-Hamiltonian/Hamiltonian pencil C aS - bH, with C C ( A D ) ( C V ) C S = ( ) and H = ( ), A, C N-by-N, (1) C ( E A' ) ( W -C' ) C C where D and E are skew-symmetric, and V and W are symmetric C matrices. This involves, first, permuting aS - bH by a symplectic C equivalence transformation to isolate eigenvalues in the first C 1:ILO-1 elements on the diagonal of A and C; and second, applying C a diagonal equivalence transformation to make the pairs of rows C and columns ILO:N and N+ILO:2*N as close in 1-norm as possible. C Both steps are optional. Balancing may reduce the 1-norms of the C matrices S and H. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the operations to be performed on S and H: C = 'N': none: simply set ILO = 1, LSCALE(I) = 1.0 and C RSCALE(I) = 1.0 for i = 1,...,N. C = 'P': permute only; C = 'S': scale only; C = 'B': both permute and scale. C C Input/Output Parameters C C N (input) INTEGER C The order of matrices A, D, E, C, V, and W. N >= 0. C C THRESH (input) DOUBLE PRECISION C If JOB = 'S' or JOB = 'B', and THRESH >= 0, threshold C value for magnitude of the elements to be considered in C the scaling process: elements with magnitude less than or C equal to THRESH*MXNORM are ignored for scaling, where C MXNORM is the maximum of the 1-norms of the original C submatrices S(s,s) and H(s,s), with s = [ILO:N,N+ILO:2*N]. C If THRESH < 0, the subroutine finds the scaling factors C for which some conditions, detailed below, are fulfilled. C A sequence of increasing strictly positive threshold C values is used. C If THRESH = -1, the condition is that C max( norm(H(s,s),1)/norm(S(s,s),1), C norm(S(s,s),1)/norm(H(s,s),1) ) (1) C has the smallest value, for the threshold values used, C where S(s,s) and H(s,s) are the scaled submatrices. C If THRESH = -2, the norm ratio reduction (1) is tried, but C the subroutine may return IWARN = 1 and reset the scaling C factors to 1, if this seems suitable. See the description C of the argument IWARN and FURTHER COMMENTS. C If THRESH = -3, the condition is that C norm(H(s,s),1)*norm(S(s,s),1) (2) C has the smallest value for the scaled submatrices. C If THRESH = -4, the norm reduction in (2) is tried, but C the subroutine may return IWARN = 1 and reset the scaling C factors to 1, as for THRESH = -2 above. C If THRESH = -VALUE, with VALUE >= 10, the condition C numbers of the left and right scaling transformations will C be bounded by VALUE, i.e., the ratios between the largest C and smallest entries in [LSCALE(ILO:N); RSCALE(ILO:N)] C will be at most VALUE. VALUE should be a power of 10. C If JOB = 'N' or JOB = 'P', the value of THRESH is C irrelevant. 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. C On exit, the leading N-by-N part of this array contains C the matrix A of the balanced skew-Hamiltonian matrix S. C In particular, the strictly lower triangular part of the C first ILO-1 columns of A is zero. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C DE (input/output) DOUBLE PRECISION array, dimension C (LDDE, N+1) C On entry, the leading N-by-N strictly lower triangular C part of this array must contain the strictly lower C triangular part of the skew-symmetric matrix E, and the C N-by-N strictly upper triangular part of the submatrix C in the columns 2 to N+1 of this array must contain the C strictly upper triangular part of the skew-symmetric C matrix D. C The entries on the diagonal and the first superdiagonal of C this array need not be set, but are assumed to be zero. C On exit, the leading N-by-N strictly lower triangular C part of this array contains the strictly lower triangular C part of the balanced matrix E, and the N-by-N strictly C upper triangular part of the submatrix in the columns 2 to C N+1 of this array contains the strictly upper triangular C part of the balanced matrix D. In particular, the strictly C lower triangular part of the first ILO-1 columns of DE is C zero. C C LDDE INTEGER C The leading dimension of the array DE. LDDE >= MAX(1, N). C C C (input/output) DOUBLE PRECISION array, dimension (LDC, N) C On entry, the leading N-by-N part of this array must C contain the matrix C. C On exit, the leading N-by-N part of this array contains C the matrix C of the balanced Hamiltonian matrix H. C In particular, the strictly lower triangular part of the C first ILO-1 columns of C is zero. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1, N). C C VW (input/output) DOUBLE PRECISION array, dimension C (LDVW, N+1) C On entry, the leading N-by-N lower triangular part of C this array must contain the lower triangular part of the C symmetric matrix W, and the N-by-N upper triangular C part of the submatrix in the columns 2 to N+1 of this C array must contain the upper triangular part of the C symmetric matrix V. C On exit, the leading N-by-N lower triangular part of this C array contains the lower triangular part of the balanced C matrix W, and the N-by-N upper triangular part of the C submatrix in the columns 2 to N+1 of this array contains C the upper triangular part of the balanced matrix V. In C particular, the lower triangular part of the first ILO-1 C columns of VW is zero. C C LDVW INTEGER C The leading dimension of the array VW. LDVW >= MAX(1, N). C C ILO (output) INTEGER C ILO-1 is the number of deflated eigenvalues in the C balanced skew-Hamiltonian/Hamiltonian matrix pencil. C ILO is set to 1 if JOB = 'N' or JOB = 'S'. C C LSCALE (output) DOUBLE PRECISION array, dimension (N) C Details of the permutations of S and H and scaling applied C to A, D, C, and V from the left. For j = 1,...,ILO-1 let C P(j) = LSCALE(j). If P(j) <= N, then rows and columns P(j) C and P(j)+N are interchanged with rows and columns j and C j+N, respectively. If P(j) > N, then row and column P(j)-N C are interchanged with row and column j+N by a generalized C symplectic permutation. For j = ILO,...,N the j-th element C of LSCALE contains the factor of the scaling applied to C row j of the matrices A, D, C, and V. C C RSCALE (output) DOUBLE PRECISION array, dimension (N) C Details of the permutations of S and H and scaling applied C to A, E, C, and W from the right. For j = 1,...,ILO-1 let C P(j) = RSCALE(j). If P(j) <= N, then rows and columns P(j) C and P(j)+N are interchanged with rows and columns j and C j+N, respectively. If P(j) > N, then row and column P(j)-N C are interchanged with row and column j+N by a generalized C symplectic permutation. For j = ILO,...,N the j-th element C of RSCALE contains the factor of the scaling applied to C column j of the matrices A, E, C, and W. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) where C LDWORK = 0, if JOB = 'N' or JOB = 'P', or N = 0; C LDWORK = 6*N, if (JOB = 'S' or JOB = 'B') and THRESH >= 0; C LDWORK = 8*N, if (JOB = 'S' or JOB = 'B') and THRESH < 0. C On exit, if JOB = 'S' or JOB = 'B', DWORK(1) and DWORK(2) C contain the initial 1-norms of S(s,s) and H(s,s), and C DWORK(3) and DWORK(4) contain their final 1-norms, C respectively. Moreover, DWORK(5) contains the THRESH value C used (irrelevant if IWARN = 1 or ILO = N). C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: scaling has been requested, for THRESH = -2 or C THRESH = -4, but it most probably would not improve C the accuracy of the computed solution for a related C eigenproblem (since maximum norm increased C significantly compared to the original pencil C matrices and (very) high and/or small scaling C factors occurred). The returned scaling factors have C been reset to 1, but information about permutations, C if requested, has been preserved. 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 Balancing consists of applying a (symplectic) equivalence C transformation to isolate eigenvalues and/or to make the 1-norms C of each pair of rows and columns indexed by s of S and H nearly C equal. If THRESH < 0, a search is performed to find those scaling C factors giving the smallest norm ratio or product defined above C (see the description of the parameter THRESH). C C Assuming JOB = 'S', let Dl and Dr be diagonal matrices containing C the vectors LSCALE and RSCALE, respectively. The returned matrices C are obtained using the equivalence transformation C C ( Dl 0 ) ( A D ) ( Dr 0 ) ( Dl 0 ) ( C V ) ( Dr 0 ) C ( ) ( ) ( ), ( ) ( ) ( ). C ( 0 Dr ) ( E A' ) ( 0 Dl ) ( 0 Dr ) ( W -C' ) ( 0 Dl ) C C For THRESH = 0, the routine returns essentially the same results C as the LAPACK subroutine DGGBAL [1]. Setting THRESH < 0, usually C gives better results than DGGBAL for badly scaled matrix pencils. C C REFERENCES C C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., C Ostrouchov, S., and Sorensen, D. C LAPACK Users' Guide: Second Edition. C SIAM, Philadelphia, 1995. C C [2] Benner, P. C Symplectic balancing of Hamiltonian matrices. C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2001. C C NUMERICAL ASPECTS C C The transformations used preserve the skew-Hamiltonian/Hamiltonian C structure and do not introduce significant rounding errors. C No rounding errors appear if JOB = 'P'. If T is the global C transformation matrix applied to the right, then J'*T*J is the C global transformation matrix applied to the left, where C J = [ 0 I; -I 0 ], with blocks of order N. C C FURTHER COMMENTS C C If THRESH = -2, the increase of the maximum norm of the scaled C submatrices, compared to the maximum norm of the initial C submatrices, is bounded by MXGAIN = 100. C If THRESH = -2, or THRESH = -4, the maximum condition number of C the scaling transformations is bounded by MXCOND = 1/SQRT(EPS), C where EPS is the machine precision (see LAPACK Library routine C DLAMCH). C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Sep. 2015. C C REVISIONS C C V. Sima, Oct. 2015, Nov. 2015, Dec. 2015, Feb. 2016, Jan. 2017, C Feb. 2017. C C KEYWORDS C C Balancing, eigenvalue, equivalence transformation, matrix algebra, C matrix operations, symplectic equivalence transformation. C C ********************************************************************* C C .. Parameters .. DOUBLE PRECISION HALF, ONE, TEN, TWO, ZERO PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, TEN = 1.0D+1, $ TWO = 2.0D+0, ZERO = 0.0D+0 ) DOUBLE PRECISION MXGAIN, SCLFAC PARAMETER ( MXGAIN = 1.0D+2, SCLFAC = 1.0D+1 ) C .. Scalar Arguments .. CHARACTER JOB INTEGER ILO, INFO, IWARN, LDA, LDC, LDDE, LDVW, N DOUBLE PRECISION THRESH C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), C(LDC,*), DE(LDDE,*), DWORK(*), $ LSCALE(*), RSCALE(*), VW(LDVW,*) C .. Local Scalars .. LOGICAL EVNORM, LOOP, LPERM, LSCAL, STORMN INTEGER I, ICAB, ILOOLD, IR, IRAB, IT, ITER, ITH, J, $ JC, K, KOUNT, KS, KW1, KW2, KW3, KW4, KW5, KW6, $ KW7, LRAB, LSFMAX, LSFMIN, NR, NRP2 DOUBLE PRECISION AB, ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, $ COEF5, COR, DENOM, EPS, EW, GAMMA, GAP, MINPRO, $ MINRAT, MN, MX, MXCOND, MXNORM, MXS, NH, NH0, $ NHS, NS, NS0, NSS, PGAMMA, PROD, RAB, RATIO, $ SFMAX, SFMIN, SUM, T, TA, TC, TD, TE, TH, TH0, $ THS, TV, TW C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH, MA02ID EXTERNAL DDOT, DLAMCH, IDAMAX, LSAME, MA02ID C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSCAL, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN, SQRT C C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IWARN = 0 LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) C IF( .NOT.LPERM .AND. .NOT.LSCAL .AND. .NOT.LSAME( JOB, 'N' ) ) $ THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA .LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDDE.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC .LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDVW.LT.MAX( 1, N ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB04DP', -INFO ) RETURN END IF C ILO = 1 C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN IF( ( .NOT.LPERM .AND. .NOT.LSCAL ) .OR. N.EQ.1 ) THEN DUM(1) = ONE CALL DCOPY( N, DUM, 0, LSCALE, 1 ) CALL DCOPY( N, DUM, 0, RSCALE, 1 ) IF( N.EQ.1 .AND. LSCAL ) THEN NS0 = MA02ID( 'skew-Hamiltonian', '1-norm', N, A, LDA, DE, $ LDDE, DWORK ) NH0 = MA02ID( 'Hamiltonian', '1-norm', N, C, LDC, VW, LDVW, $ DWORK ) DWORK(1) = NS0 DWORK(2) = NH0 DWORK(3) = NS0 DWORK(4) = NH0 DWORK(5) = THRESH END IF RETURN END IF C IF( LPERM ) THEN C C Permute the matrices S and H to isolate the eigenvalues. C ILOOLD = 0 C WHILE ( ILO.NE.ILOOLD ) 10 CONTINUE IF( ILO.NE.ILOOLD ) THEN ILOOLD = ILO C C Scan columns ILO .. N. C I = ILO C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) 20 CONTINUE IF( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN DO 30 J = ILO, I-1 IF( A(J,I).NE.ZERO .OR. C(J,I).NE.ZERO ) THEN I = I + 1 GOTO 20 END IF 30 CONTINUE DO 40 J = I+1, N IF( A(J,I).NE.ZERO .OR. C(J,I).NE.ZERO ) THEN I = I + 1 GOTO 20 END IF 40 CONTINUE DO 50 J = ILO, I-1 IF( DE(I,J).NE.ZERO .OR. VW(I,J).NE.ZERO ) THEN I = I + 1 GOTO 20 END IF 50 CONTINUE IF( VW(I,I).NE.ZERO ) THEN I = I + 1 GOTO 20 END IF DO 60 J = I+1, N IF( DE(J,I).NE.ZERO .OR. VW(J,I).NE.ZERO ) THEN I = I + 1 GOTO 20 END IF 60 CONTINUE C C Exchange columns/rows ILO <-> I. C LSCALE(ILO) = I RSCALE(ILO) = I C IF( ILO.NE.I ) THEN C CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) C IF( I.LT.N ) $ CALL DSWAP( N-I, DE(I+1,ILO), 1, DE(I+1,I), 1 ) IF( I.GT.ILO+1 ) THEN CALL DSCAL( I-ILO-1, -ONE, DE(ILO+1,ILO), 1 ) CALL DSWAP( I-ILO-1, DE(ILO+1,ILO), 1, DE(I,ILO+1), $ LDDE ) END IF C CALL DSWAP( ILO-1, DE(1,ILO+1), 1, DE(1,I+1), 1 ) IF( N.GT.I ) $ CALL DSWAP( N-I, DE(I,I+2), LDDE, DE(ILO,I+2), $ LDDE ) IF( I.GT.ILO+1 ) THEN CALL DSCAL( I-ILO-1, -ONE, DE(ILO+1,I+1), 1 ) CALL DSWAP( I-ILO-1, DE(ILO,ILO+2), LDDE, $ DE(ILO+1,I+1), 1 ) END IF CALL DSCAL( I-ILO, -ONE, DE(ILO,I+1), 1 ) C CALL DSWAP( N, C(1,ILO), 1, C(1,I), 1 ) CALL DSWAP( N-ILO+1, C(ILO,ILO), LDC, C(I,ILO), LDC ) C T = VW(I,ILO) VW(I,ILO) = VW(ILO,ILO) VW(ILO,ILO) = T CALL DSWAP( N-I+1, VW(I,ILO), 1, VW(I,I), 1 ) CALL DSWAP( I-ILO, VW(ILO,ILO), 1, VW(I,ILO), LDVW ) C CALL DSWAP( ILO, VW(1,ILO+1), 1, VW(1,I+1), 1 ) CALL DSWAP( N-I+1, VW(I,I+1), LDVW, VW(ILO,I+1), $ LDVW ) CALL DSWAP( I-ILO, VW(ILO,ILO+1), LDVW, VW(ILO,I+1), $ 1 ) END IF ILO = ILO + 1 END IF C END WHILE 20 C C Scan columns N+ILO .. 2*N. C I = ILO C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) 70 CONTINUE IF( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN DO 80 J = ILO, I-1 IF( A(I,J).NE.ZERO .OR. C(I,J).NE.ZERO ) THEN I = I + 1 GOTO 70 END IF 80 CONTINUE DO 90 J = I+1, N IF( A(I,J).NE.ZERO .OR. C(I,J).NE.ZERO ) THEN I = I + 1 GOTO 70 END IF 90 CONTINUE DO 100 J = ILO, I-1 IF( DE(J,I+1).NE.ZERO .OR. VW(J,I+1).NE.ZERO ) THEN I = I + 1 GOTO 70 END IF 100 CONTINUE IF( VW(I,I+1).NE.ZERO ) THEN I = I + 1 GOTO 70 END IF DO 110 J = I+1, N IF( DE(I,J+1).NE.ZERO .OR. VW(I,J+1).NE.ZERO ) THEN I = I + 1 GOTO 70 END IF 110 CONTINUE C C Exchange columns/rows I <-> I+N with a symplectic C generalized permutation. C LSCALE(ILO) = N + I RSCALE(ILO) = N + I C CALL DSWAP( I-ILO, A(I,ILO), LDA, DE(I,ILO), LDDE ) CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA ) IF( N.GT.I ) THEN CALL DSWAP( N-I, A(I,I+1), LDA, DE(I+1,I), 1 ) CALL DSCAL( N-I, -ONE, DE(I+1,I), 1 ) END IF CALL DSWAP( I-1, A(1,I), 1, DE(1,I+1), 1 ) CALL DSCAL( I-1, -ONE, A(1,I), 1 ) IF( N.GT.I ) THEN CALL DSCAL( N-I, -ONE, A(I+1,I), 1 ) CALL DSWAP( N-I, A(I+1,I), 1, DE(I,I+2), LDDE ) END IF C CALL DSWAP( I-ILO, C(I,ILO), LDC, VW(I,ILO), LDVW ) CALL DSCAL( I-ILO, -ONE, C(I,ILO), LDC ) IF( N.GT.I ) THEN CALL DSWAP( N-I, C(I,I+1), LDC, VW(I+1,I), 1 ) CALL DSCAL( N-I, -ONE, C(I,I+1), LDC ) END IF CALL DSWAP( I-1, C(1,I), 1, VW(1,I+1), 1 ) CALL DSCAL( I-1, -ONE, C(1,I), 1 ) IF( N.GT.I ) THEN CALL DSWAP( N-I, C(I+1,I), 1, VW(I,I+2), LDVW ) CALL DSCAL( N-I, -ONE, C(I+1,I), 1 ) END IF C(I,I) = -C(I,I) T = VW(I,I) VW(I,I) = -VW(I,I+1) VW(I,I+1) = -T C C Exchange columns/rows ILO <-> I. C IF( ILO.NE.I ) THEN C CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) C IF( I.LT.N ) $ CALL DSWAP( N-I, DE(I+1,ILO), 1, DE(I+1,I), 1 ) IF( I.GT.ILO+1 ) THEN CALL DSCAL( I-ILO-1, -ONE, DE(ILO+1,ILO), 1 ) CALL DSWAP( I-ILO-1, DE(ILO+1,ILO), 1, DE(I,ILO+1), $ LDDE ) END IF C CALL DSWAP( ILO-1, DE(1,ILO+1), 1, DE(1,I+1), 1 ) IF( N.GT.I ) $ CALL DSWAP( N-I, DE(I,I+2), LDDE, DE(ILO,I+2), $ LDDE ) IF( I.GT.ILO+1 ) THEN CALL DSCAL( I-ILO-1, -ONE, DE(ILO+1,I+1), 1 ) CALL DSWAP( I-ILO-1, DE(ILO,ILO+2), LDDE, $ DE(ILO+1,I+1), 1 ) END IF CALL DSCAL( I-ILO, -ONE, DE(ILO,I+1), 1 ) C CALL DSWAP( N, C(1,ILO), 1, C(1,I), 1 ) CALL DSWAP( N-ILO+1, C(ILO,ILO), LDC, C(I,ILO), LDC ) C T = VW(I,ILO) VW(I,ILO) = VW(ILO,ILO) VW(ILO,ILO) = T CALL DSWAP( N-I+1, VW(I,ILO), 1, VW(I,I), 1 ) CALL DSWAP( I-ILO, VW(ILO,ILO), 1, VW(I,ILO), LDVW ) C CALL DSWAP( ILO, VW(1,ILO+1), 1, VW(1,I+1), 1 ) CALL DSWAP( N-I+1, VW(I,I+1), LDVW, VW(ILO,I+1), $ LDVW ) CALL DSWAP( I-ILO, VW(ILO,ILO+1), LDVW, VW(ILO,I+1), $ 1 ) END IF ILO = ILO + 1 END IF C END WHILE 70 GOTO 10 END IF C END WHILE 10 C DO 120 I = ILO, N LSCALE( I ) = ONE RSCALE( I ) = ONE 120 CONTINUE IF( .NOT.LSCAL ) $ RETURN END IF C NR = N - ILO + 1 C C Compute initial 1-norms and return if ILO = N. C NS0 = MA02ID( 'skew-Hamiltonian', '1-norm', NR, A(ILO,ILO), LDA, $ DE(ILO,ILO), LDDE, DWORK ) NH0 = MA02ID( 'Hamiltonian', '1-norm', NR, C(ILO,ILO), LDC, $ VW(ILO,ILO), LDVW, DWORK ) C IF( ILO.EQ.N ) THEN DWORK(1) = NS0 DWORK(2) = NH0 DWORK(3) = NS0 DWORK(4) = NH0 DWORK(5) = THRESH RETURN END IF C C Balance the submatrices in rows ILO to N. C C Initialize balancing and allocate work storage. C KW1 = N KW2 = KW1 + N KW3 = KW2 + N KW4 = KW3 + N KW5 = KW4 + N DUM(1) = ZERO C C Prepare for scaling. C SFMIN = DLAMCH( 'Safe minimum' ) SFMAX = ONE / SFMIN BASL = LOG10( SCLFAC ) LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) LSFMAX = INT( LOG10( SFMAX ) / BASL ) MXNORM = MAX( NS0, NH0 ) LOOP = THRESH.LT.ZERO C IF( LOOP ) THEN C C Compute relative threshold. C NS = NS0 NSS = NS0 NH = NH0 NHS = NH0 C ITH = THRESH MXS = MXNORM MX = ZERO MN = SFMAX IF( ITH.GE.-2 ) THEN IF( NS.LT.NH ) THEN RATIO = MIN( NH/NS, SFMAX ) ELSE RATIO = MIN( NS/NH, SFMAX ) END IF MINRAT = RATIO ELSE IF( ITH.LE.-10 ) THEN MXCOND = -THRESH ELSE DENOM = MAX( ONE, MXNORM ) PROD = ( NS/DENOM )*( NH/DENOM ) MINPRO = PROD END IF STORMN = .FALSE. EVNORM = .FALSE. C C Find maximum order of magnitude of the differences in sizes of C the nonzero entries, not considering diag(A) and diag(C). C DO 140 J = ILO, N DO 130 I = ILO, N IF( I.NE.J ) THEN AB = ABS( A(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) END IF 130 CONTINUE 140 CONTINUE C DO 160 J = ILO, N DO 150 I = ILO, N IF( I.NE.J ) THEN AB = ABS( DE(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) AB = ABS( DE(I,J+1) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) END IF 150 CONTINUE 160 CONTINUE C DO 180 J = ILO, N DO 170 I = ILO, N IF( I.NE.J ) THEN AB = ABS( C(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) END IF 170 CONTINUE 180 CONTINUE C DO 200 J = ILO, N DO 190 I = ILO, N AB = ABS( VW(I,J) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) AB = ABS( VW(I,J+1) ) IF( AB.NE.ZERO ) $ MN = MIN( MN, AB ) MX = MAX( MX, AB ) 190 CONTINUE 200 CONTINUE C IF( MX*SFMIN.LE.MN ) THEN GAP = MX/MN ELSE GAP = SFMAX END IF EPS = DLAMCH( 'Precision' ) ITER = MIN( INT( LOG10( GAP ) ), -INT( LOG10( EPS ) ) ) + 1 TH = MAX( MN, MX*EPS )/MAX( MXNORM, SFMIN ) THS = TH KW6 = KW5 + N + ILO KW7 = KW6 + N CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) C C Set the maximum condition number of the transformations. C IF( ITH.GT.-10 ) $ MXCOND = ONE/SQRT( EPS ) ELSE TH = MXNORM*THRESH ITER = 1 EVNORM = .TRUE. END IF TH0 = TH C COEF = HALF / DBLE( 2*NR ) COEF2 = COEF*COEF COEF5 = HALF*COEF2 NRP2 = NR + 2 BETA = ZERO C C If THRESH < 0, use a loop to reduce the norm ratio. C DO 450 K = 1, ITER C C Compute right side vector in resulting linear equations. C CALL DCOPY( 6*N, DUM, 0, DWORK, 1 ) CALL DCOPY( NR, DUM, 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM, 0, RSCALE(ILO), 1 ) DO 220 I = ILO, N DO 210 J = ILO, N TA = ABS( A(I,J) ) TC = ABS( C(I,J) ) IF( J.GT.I ) THEN TD = ABS( DE(I,J+1) ) ELSE IF( J.LT.I ) THEN TD = ABS( DE(J,I+1) ) ELSE TD = ZERO END IF IF( J.GT.I ) THEN TE = ABS( DE(J,I) ) ELSE IF( J.LT.I ) THEN TE = ABS( DE(I,J) ) ELSE TE = ZERO END IF IF( J.GT.I ) THEN TV = ABS( VW(I,J+1) ) ELSE TV = ABS( VW(J,I+1) ) END IF IF( J.GT.I ) THEN TW = ABS( VW(J,I) ) ELSE TW = ABS( VW(I,J) ) END IF IF( TA.GT.TH ) THEN TA = LOG10( TA ) / BASL ELSE TA = ZERO END IF IF( TC.GT.TH ) THEN TC = LOG10( TC ) / BASL ELSE TC = ZERO END IF IF( TD.GT.TH ) THEN TD = LOG10( TD ) / BASL ELSE TD = ZERO END IF IF( TE.GT.TH ) THEN TE = LOG10( TE ) / BASL ELSE TE = ZERO END IF IF( TV.GT.TH ) THEN TV = LOG10( TV ) / BASL ELSE TV = ZERO END IF IF( TW.GT.TH ) THEN TW = LOG10( TW ) / BASL ELSE TW = ZERO END IF DWORK(I+KW4) = DWORK(I+KW4) - TA - TC - TD - TV DWORK(J+KW5) = DWORK(J+KW5) - TA - TC - TE - TW 210 CONTINUE 220 CONTINUE C IT = 1 C C Start generalized conjugate gradient iteration. C 230 CONTINUE C GAMMA = ( DDOT( NR, DWORK(ILO+KW4), 1, DWORK(ILO+KW4), 1 ) + $ DDOT( NR, DWORK(ILO+KW5), 1, DWORK(ILO+KW5), 1 ) )* $ TWO C EW = ZERO DO 240 I = ILO, N EW = EW + DWORK(I+KW4) + DWORK(I+KW5) 240 CONTINUE C GAMMA = COEF*GAMMA - TWO*COEF2*EW**2 IF( GAMMA.EQ.ZERO ) $ GO TO 310 IF( IT.NE.1 ) $ BETA = GAMMA / PGAMMA T = -TWO*COEF5*EW C CALL DSCAL( NR, BETA, DWORK(ILO), 1 ) CALL DSCAL( NR, BETA, DWORK(ILO+KW1), 1 ) C CALL DAXPY( NR, COEF, DWORK(ILO+KW4), 1, DWORK(ILO+KW1), 1 ) CALL DAXPY( NR, COEF, DWORK(ILO+KW5), 1, DWORK(ILO), 1 ) C DO 250 J = ILO, N DWORK(J) = DWORK(J) + T DWORK(J+KW1) = DWORK(J+KW1) + T 250 CONTINUE C C Apply matrix to vector. C DO 270 I = ILO, N KOUNT = 0 SUM = ZERO DO 260 J = ILO, N KS = KOUNT IF( A(I,J).NE.ZERO ) $ KOUNT = KOUNT + 1 IF( C(I,J).NE.ZERO ) $ KOUNT = KOUNT + 1 SUM = SUM + DBLE( KOUNT - KS )*DWORK(J) C KS = KOUNT IF( J.GT.I ) THEN IF( DE(I,J+1).NE.ZERO ) $ KOUNT = KOUNT + 1 ELSE IF( J.LT.I ) THEN IF( DE(J,I+1).NE.ZERO ) $ KOUNT = KOUNT + 1 END IF IF( J.GE.I ) THEN IF( VW(I,J+1).NE.ZERO ) $ KOUNT = KOUNT + 1 ELSE IF( VW(J,I+1).NE.ZERO ) $ KOUNT = KOUNT + 1 END IF SUM = SUM + DBLE( KOUNT - KS )*DWORK(J+KW1) 260 CONTINUE DWORK(I+KW2) = DBLE( KOUNT )*DWORK(I+KW1) + SUM 270 CONTINUE C DO 290 J = ILO, N KOUNT = 0 SUM = ZERO DO 280 I = ILO, N KS = KOUNT IF( A(I,J).NE.ZERO ) $ KOUNT = KOUNT + 1 IF( C(I,J).NE.ZERO ) $ KOUNT = KOUNT + 1 SUM = SUM + DBLE( KOUNT - KS )*DWORK(I+KW1) C KS = KOUNT IF( J.GT.I ) THEN IF( DE(J,I).NE.ZERO ) $ KOUNT = KOUNT + 1 ELSE IF( J.LT.I ) THEN IF( DE(I,J).NE.ZERO ) $ KOUNT = KOUNT + 1 END IF IF( J.GE.I ) THEN IF( VW(J,I).NE.ZERO ) $ KOUNT = KOUNT + 1 ELSE IF( VW(I,J).NE.ZERO ) $ KOUNT = KOUNT + 1 END IF SUM = SUM + DBLE( KOUNT - KS )*DWORK(I) 280 CONTINUE DWORK(J+KW3) = DBLE( KOUNT )*DWORK(J) + SUM 290 CONTINUE C SUM = ( DDOT( NR, DWORK(ILO+KW1), 1, DWORK(ILO+KW2), 1 ) + $ DDOT( NR, DWORK(ILO), 1, DWORK(ILO+KW3), 1 ) )*TWO ALPHA = GAMMA / SUM C C Determine correction to current iteration. C CMAX = ZERO DO 300 I = ILO, N COR = ALPHA*DWORK(I+KW1) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) LSCALE(I) = LSCALE(I) + COR COR = ALPHA*DWORK(I) IF( ABS( COR ).GT.CMAX ) $ CMAX = ABS( COR ) RSCALE(I) = RSCALE(I) + COR 300 CONTINUE C IF( CMAX.GE.HALF ) THEN C CALL DAXPY( N, -ALPHA, DWORK(ILO+KW2), 1, DWORK(ILO+KW4), 1) CALL DAXPY( N, -ALPHA, DWORK(ILO+KW3), 1, DWORK(ILO+KW5), 1) C PGAMMA = GAMMA IT = IT + 1 IF( IT.LE.NRP2 ) $ GO TO 230 END IF C C End generalized conjugate gradient iteration. C 310 CONTINUE C C Compute diagonal scaling matrices. C DO 320 I = ILO, N IRAB = IDAMAX( NR, A(I,ILO), LDA ) RAB = ABS( A(I,ILO+IRAB-1) ) IRAB = IDAMAX( NR, C(I,ILO), LDC ) RAB = MAX( RAB, ABS( C(I,ILO+IRAB-1) ) ) IF( I.GT.ILO ) THEN IRAB = IDAMAX( I-1, DE(1,I+1), 1 ) RAB = MAX( RAB, ABS( DE(IRAB,I+1) ) ) END IF IF( N.GT.I ) THEN IRAB = IDAMAX( N-I, DE(I,I+2), LDDE ) RAB = MAX( RAB, ABS( DE(I,I+IRAB+1) ) ) END IF IRAB = IDAMAX( I, VW(1,I+1), 1 ) RAB = MAX( RAB, ABS( VW(IRAB,I+1) ) ) IF( N.GT.I+1 ) THEN IRAB = IDAMAX( N-I-1, VW(I,I+2), LDVW ) RAB = MAX( RAB, ABS( VW(I,I+IRAB+1) ) ) END IF C LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) IR = LSCALE(I) + SIGN( HALF, LSCALE(I) ) IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) LSCALE(I) = SCLFAC**IR C ICAB = IDAMAX( N, A(1,I), 1 ) CAB = ABS( A(ICAB,I) ) ICAB = IDAMAX( N, C(1,I), 1 ) CAB = MAX( CAB, ABS( C(ICAB,I) ) ) IF( I.GT.1 ) THEN ICAB = IDAMAX( I-1, DE(I,1), LDDE ) CAB = MAX( CAB, ABS( DE(I,ICAB) ) ) END IF IF( N.GT.I ) THEN ICAB = IDAMAX( N-I, DE(I+1,I), 1 ) CAB = MAX( CAB, ABS( DE(I+ICAB,I) ) ) END IF ICAB = IDAMAX( I, VW(I,1), LDVW ) CAB = MAX( CAB, ABS( VW(I,ICAB) ) ) IF( N.GT.I ) THEN ICAB = IDAMAX( N-I, VW(I+1,I), 1 ) CAB = MAX( CAB, ABS( VW(I+ICAB,I) ) ) END IF C LRAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) JC = RSCALE(I) + SIGN( HALF, RSCALE(I) ) JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LRAB ) RSCALE(I) = SCLFAC**JC 320 CONTINUE C DO 330 I = ILO, N IF( LSCALE(I).NE.ONE .OR. RSCALE(I).NE.ONE ) $ GO TO 340 330 CONTINUE C C Finish the procedure for all scaling factors equal to 1. C NSS = NS0 NHS = NH0 THS = TH0 GO TO 510 C 340 CONTINUE C IF( LOOP ) THEN IF( ITH.LE.-10 ) THEN C C Compute the reciprocal condition number of the left and C right transformations. Continue the loop if it is too C small. C IR = IDAMAX( NR, LSCALE(ILO), 1 ) JC = IDAMAX( NR, RSCALE(ILO), 1 ) T = MAX( LSCALE(ILO+IR-1), RSCALE(ILO+JC-1) ) MN = T DO 350 I = ILO, N IF( LSCALE(I).LT.MN ) $ MN = LSCALE(I) 350 CONTINUE DO 360 I = ILO, N IF( RSCALE(I).LT.MN ) $ MN = RSCALE(I) 360 CONTINUE T = MN/T IF( T.LT.ONE/MXCOND ) THEN TH = TH*TEN GO TO 450 ELSE THS = TH EVNORM = .TRUE. GO TO 480 END IF END IF C C Compute the 1-norms of the scaled submatrices, C without actually scaling them. C NS = ZERO DO 380 J = ILO, N T = ZERO DO 370 I = ILO, N T = T + ABS( A(I,J) )*LSCALE(I)*RSCALE(J) IF( I.LT.J ) THEN T = T + ABS( DE(J,I) )*RSCALE(I)*RSCALE(J) ELSE IF( I.GT.J ) THEN T = T + ABS( DE(I,J) )*RSCALE(I)*RSCALE(J) END IF 370 CONTINUE IF( T.GT.NS ) $ NS = T 380 CONTINUE C DO 400 J = ILO, N T = ZERO DO 390 I = ILO, N T = T + ABS( A(J,I) )*LSCALE(J)*RSCALE(I) IF( I.LT.J ) THEN T = T + ABS( DE(I,J+1) )*LSCALE(I)*LSCALE(J) ELSE IF( I.GT.J ) THEN T = T + ABS( DE(J,I+1) )*LSCALE(I)*LSCALE(J) END IF 390 CONTINUE IF( T.GT.NS ) $ NS = T 400 CONTINUE C NH = ZERO DO 420 J = ILO, N T = ZERO DO 410 I = ILO, N T = T + ABS( C(I,J) )*LSCALE(I)*RSCALE(J) IF( I.LE.J ) THEN T = T + ABS( VW(J,I) )*RSCALE(I)*RSCALE(J) ELSE IF( I.GT.J ) THEN T = T + ABS( VW(I,J) )*RSCALE(I)*RSCALE(J) END IF 410 CONTINUE IF( T.GT.NH ) $ NH = T 420 CONTINUE C DO 440 J = ILO, N T = ZERO DO 430 I = ILO, N T = T + ABS( C(J,I) )*LSCALE(J)*RSCALE(I) IF( I.LE.J ) THEN T = T + ABS( VW(I,J+1) )*LSCALE(I)*LSCALE(J) ELSE IF( I.GT.J ) THEN T = T + ABS( VW(J,I+1) )*LSCALE(I)*LSCALE(J) END IF 430 CONTINUE IF( T.GT.NH ) $ NH = T 440 CONTINUE C IF( ITH.GE.-4 .AND. ITH.LT.-2 ) THEN PROD = ( NS/DENOM )*( NH/DENOM ) IF( MINPRO.GT.PROD ) THEN MINPRO = PROD STORMN = .TRUE. CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) NSS = NS NHS = NH THS = TH END IF ELSE IF( ITH.GE.-2 ) THEN IF( NS.LT.NH ) THEN RATIO = MIN( NH/NS, SFMAX ) ELSE RATIO = MIN( NS/NH, SFMAX ) END IF IF( MINRAT.GT.RATIO ) THEN MINRAT = RATIO STORMN = .TRUE. CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 ) CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 ) MXS = MAX( NS, NH ) NSS = NS NHS = NH THS = TH END IF END IF TH = TH*TEN END IF 450 CONTINUE C C Prepare for scaling. C IF( LOOP ) THEN IF( ITH.LE.-10 ) THEN C C Could not find enough well conditioned transformations C for THRESH <= -10. Set scaling factors to 1 and return. C DUM(1) = ONE CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 ) IWARN = 1 GO TO 510 END IF C C Check if scaling might reduce the accuracy when solving related C eigenproblems, and set the scaling factors to 1 in this case, C if THRESH = -2 or THRESH = -4. C IF( ( MXNORM.LT.MXS .AND. MXNORM.LT.MXS/MXGAIN .AND. ITH.EQ.-2) $ .OR. ITH.EQ.-4 ) THEN IR = IDAMAX( NR, DWORK(KW6), 1 ) JC = IDAMAX( NR, DWORK(KW7), 1 ) T = MAX( DWORK(KW6+IR-1), DWORK(KW7+JC-1) ) MN = T DO 460 I = KW6, KW6+NR-1 IF( DWORK(I).LT.MN ) $ MN = DWORK(I) 460 CONTINUE DO 470 I = KW7, KW7+NR-1 IF( DWORK(I).LT.MN ) $ MN = DWORK(I) 470 CONTINUE T = MN/T IF( T.LT.ONE/MXCOND ) THEN DUM(1) = ONE CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 ) CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 ) IWARN = 1 NSS = NS0 NHS = NH0 THS = TH0 GO TO 510 END IF END IF IF( STORMN ) THEN CALL DCOPY( NR, DWORK(KW6), 1, LSCALE(ILO), 1 ) CALL DCOPY( NR, DWORK(KW7), 1, RSCALE(ILO), 1 ) ELSE NSS = NS NHS = NH THS = TH END IF END IF C 480 CONTINUE C C Row scaling. C DO 490 I = ILO, N CALL DSCAL( NR, LSCALE(I), A(I,ILO), LDA ) CALL DSCAL( NR, LSCALE(I), C(I,ILO), LDC ) CALL DSCAL( I-1, LSCALE(I), DE(1,I+1), 1 ) IF( N.GT.I ) $ CALL DSCAL( N-I, LSCALE(I), DE(I,I+2), LDDE ) CALL DSCAL( I, LSCALE(I), VW(1,I+1), 1 ) CALL DSCAL( N-I+1, LSCALE(I), VW(I,I+1), LDVW ) 490 CONTINUE C C Column scaling. C DO 500 J = ILO, N CALL DSCAL( N, RSCALE(J), A(1,J), 1 ) CALL DSCAL( N, RSCALE(J), C(1,J), 1 ) CALL DSCAL( J-1, RSCALE(J), DE(J,1), LDDE ) IF( N.GT.J ) $ CALL DSCAL( N-J, RSCALE(J), DE(J+1,J), 1 ) CALL DSCAL( J, RSCALE(J), VW(J,1), LDVW ) CALL DSCAL( N-J+1, RSCALE(J), VW(J,J), 1 ) 500 CONTINUE C C Set DWORK(1:5). C 510 CONTINUE IF( EVNORM ) THEN NSS = MA02ID( 'skew-Hamiltonian', '1-norm', NR, A(ILO,ILO), $ LDA, DE(ILO,ILO), LDDE, DWORK ) NHS = MA02ID( 'Hamiltonian', '1-norm', NR, C(ILO,ILO), LDC, $ VW(ILO,ILO), LDVW, DWORK ) END IF C DWORK(1) = NS0 DWORK(2) = NH0 DWORK(3) = NSS DWORK(4) = NHS IF( LOOP ) THEN DWORK(5) = THS/MAX( MXNORM, SFMIN ) ELSE DWORK(5) = THRESH END IF C RETURN C *** Last line of MB04DP *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02MU.f0000644000000000000000000000013015012430707016203 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB02MU.f0000644000175000017500000003651415012430707017412 0ustar00lilgelilge00000000000000 SUBROUTINE SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S, $ LDS, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To construct the 2n-by-2n Hamiltonian or symplectic matrix S C associated to the linear-quadratic optimization problem, used to C solve the continuous- or discrete-time algebraic Riccati equation, C respectively. C C For a continuous-time problem, S is defined by C C ( A -G ) C S = ( ), (1) C ( -Q -A') C C and for a discrete-time problem by C C -1 -1 C ( A A *G ) C S = ( -1 -1 ), (2) C ( QA A' + Q*A *G ) C C or C C -T -T C ( A + G*A *Q -G*A ) C S = ( -T -T ), (3) C ( -A *Q A ) C C where A, G, and Q are N-by-N matrices, with G and Q symmetric. C Matrix A must be nonsingular in the discrete-time case. 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 HINV CHARACTER*1 C If DICO = 'D', specifies which of the matrices (2) or (3) C is constructed, as follows: C = 'D': The matrix S in (2) is constructed; C = 'I': The (inverse) matrix S in (3) is constructed. C HINV is not referenced if DICO = 'C'. C C UPLO CHARACTER*1 C Specifies which triangle of the matrices G and Q is C stored, as follows: C = 'U': Upper triangle is stored; C = 'L': Lower triangle is stored. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, G, and Q. 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. C On exit, if DICO = 'D', and INFO = 0, the leading N-by-N C -1 C part of this array contains the matrix A . C Otherwise, the array A is unchanged on exit. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C G (input) DOUBLE PRECISION array, dimension (LDG,N) C The leading N-by-N upper triangular part (if UPLO = 'U') C or lower triangular part (if UPLO = 'L') of this array C must contain the upper triangular part or lower triangular C part, respectively, of the symmetric matrix G. C The strictly lower triangular part (if UPLO = 'U') or C strictly upper triangular part (if UPLO = 'L') is not C referenced. C C LDG INTEGER C The leading dimension of array G. LDG >= MAX(1,N). C C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) C The leading N-by-N upper triangular part (if UPLO = 'U') C or lower triangular part (if UPLO = 'L') of this array C must contain the upper triangular part or lower triangular C part, respectively, of the symmetric matrix Q. C The strictly lower triangular part (if UPLO = 'U') or C strictly upper triangular part (if UPLO = 'L') is not C referenced. C C LDQ INTEGER C The leading dimension of array Q. LDQ >= MAX(1,N). C C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) C If INFO = 0, the leading 2N-by-2N part of this array C contains the Hamiltonian or symplectic matrix of the C problem. C C LDS INTEGER C The leading dimension of array S. LDS >= MAX(1,2*N). C C Workspace C C IWORK INTEGER array, dimension (2*N) C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK; if DICO = 'D', DWORK(2) returns the reciprocal C condition number of the given matrix A. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= 1 if DICO = 'C'; C LDWORK >= MAX(2,4*N) if DICO = 'D'. C For optimum performance LDWORK should be larger, if C DICO = 'D'. 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 = i: if the leading i-by-i (1 <= i <= N) upper triangular C submatrix of A is singular in discrete-time case; C = N+1: if matrix A is numerically singular in discrete- C time case. C C METHOD C C For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1) C is constructed. C For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or C (3) - the inverse of the matrix in (2) - is constructed. C C NUMERICAL ASPECTS C C The discrete-time case needs the inverse of the matrix A, hence C the routine should not be used when A is ill-conditioned. C 3 C The algorithm requires 0(n ) floating point operations in the C discrete-time case. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004, C Aug. 2011. C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, discrete-time system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, HINV, UPLO INTEGER INFO, LDA, LDG, LDQ, LDS, LDWORK, N C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), $ S(LDS,*) C .. Local Scalars .. LOGICAL DISCR, LHINV, LQUERY, LUPLO INTEGER I, J, MAXWRK, MINWRK, N2, NJ, NP1 DOUBLE PRECISION ANORM, RCOND C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DGECON, DGEMM, DGETRF, DGETRI, DGETRS, $ DLACPY, DSWAP, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C INFO = 0 N2 = N + N DISCR = LSAME( DICO, 'D' ) LUPLO = LSAME( UPLO, 'U' ) IF( DISCR ) THEN LHINV = LSAME( HINV, 'D' ) ELSE LHINV = .FALSE. END IF C C Test the input scalar arguments. C IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN INFO = -1 ELSE IF( DISCR ) THEN IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) $ INFO = -2 END IF IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDG.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN INFO = -12 ELSE MINWRK = MAX( 2, 4*N ) LQUERY = LDWORK.EQ.-1 IF( ( LDWORK.LT.1 .OR. ( DISCR .AND. LDWORK.LT.MINWRK ) ) .AND. $ .NOT.LQUERY ) THEN INFO = -15 ELSE IF( DISCR ) THEN C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe C the minimal amount of 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 DGETRI( N, A, LDA, IWORK, DWORK, -1, INFO ) MAXWRK = MAX( MINWRK, INT( DWORK(1) ) ) ELSE MAXWRK = 1 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB02MU', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = MAXWRK RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = ONE IF ( DISCR ) DWORK(2) = ONE RETURN END IF C C The code tries to exploit data locality as much as possible. C IF ( .NOT.LHINV ) THEN CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) C C Construct Hamiltonian matrix in the continuous-time case, or C prepare symplectic matrix in (3) in the discrete-time case: C C Construct full Q in S(N+1:2*N,1:N) and change the sign, and C construct full G in S(1:N,N+1:2*N) and change the sign. C DO 200 J = 1, N NJ = N + J IF ( LUPLO ) THEN C DO 20 I = 1, J S(N+I,J) = -Q(I,J) 20 CONTINUE C DO 40 I = J + 1, N S(N+I,J) = -Q(J,I) 40 CONTINUE C DO 60 I = 1, J S(I,NJ) = -G(I,J) 60 CONTINUE C DO 80 I = J + 1, N S(I,NJ) = -G(J,I) 80 CONTINUE C ELSE C DO 100 I = 1, J - 1 S(N+I,J) = -Q(J,I) 100 CONTINUE C DO 120 I = J, N S(N+I,J) = -Q(I,J) 120 CONTINUE C DO 140 I = 1, J - 1 S(I,NJ) = -G(J,I) 140 CONTINUE C DO 180 I = J, N S(I,NJ) = -G(I,J) 180 CONTINUE C END IF 200 CONTINUE C IF ( .NOT.DISCR ) THEN C DO 240 J = 1, N NJ = N + J C DO 220 I = 1, N S(N+I,NJ) = -A(J,I) 220 CONTINUE C 240 CONTINUE C DWORK(1) = ONE END IF END IF C IF ( DISCR ) THEN C C Construct the symplectic matrix (2) or (3) in the discrete-time C case. C NP1 = N + 1 C IF ( LHINV ) THEN C C Put A' in S(N+1:2*N,N+1:2*N). C DO 260 I = 1, N CALL DCOPY( N, A(I, 1), LDA, S(NP1,N+I), 1 ) 260 CONTINUE C END IF C C Compute the norm of the matrix A. C ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) C C Compute the LU factorization of A. C CALL DGETRF( N, N, A, LDA, IWORK, INFO ) C C Return if INFO is non-zero. C IF( INFO.GT.0 ) THEN DWORK(2) = ZERO RETURN END IF C C Compute the reciprocal of the condition number of A. C Workspace: need 4*N. C CALL DGECON( '1-norm', N, A, LDA, ANORM, RCOND, DWORK, $ IWORK(NP1), INFO ) C C Return if the matrix is singular to working precision. C IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN INFO = N + 1 DWORK(2) = RCOND RETURN END IF C IF ( LHINV ) THEN C C Compute S in (2). C C Construct full Q in S(N+1:2*N,1:N). C IF ( LUPLO ) THEN DO 270 J = 1, N - 1 CALL DCOPY( J, Q(1,J), 1, S(NP1,J), 1 ) CALL DCOPY( N-J, Q(J,J+1), LDQ, S(NP1+J,J), 1 ) 270 CONTINUE CALL DCOPY( N, Q(1,N), 1, S(NP1,N), 1 ) ELSE CALL DCOPY( N, Q(1,1), 1, S(NP1,1), 1 ) DO 280 J = 2, N CALL DCOPY( J-1, Q(J,1), LDQ, S(NP1,J), 1 ) CALL DCOPY( N-J+1, Q(J,J), 1, S(N+J,J), 1 ) 280 CONTINUE END IF C C Compute the solution matrix X of the system X*A = Q by C -1 C solving A'*X' = Q and transposing the result to get Q*A . C CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1), $ LDS, INFO ) C DO 300 J = 1, N - 1 CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS ) 300 CONTINUE C C Construct full G in S(1:N,N+1:2*N). C IF ( LUPLO ) THEN DO 310 J = 1, N - 1 CALL DCOPY( J, G(1,J), 1, S(1,N+J), 1 ) CALL DCOPY( N-J, G(J,J+1), LDG, S(J+1,N+J), 1 ) 310 CONTINUE CALL DCOPY( N, G(1,N), 1, S(1,N2), 1 ) ELSE CALL DCOPY( N, G(1,1), 1, S(1,NP1), 1 ) DO 320 J = 2, N CALL DCOPY( J-1, G(J,1), LDG, S(1,N+J), 1 ) CALL DCOPY( N-J+1, G(J,J), 1, S(J,N+J), 1 ) 320 CONTINUE END IF C -1 C Compute A' + Q*A *G in S(N+1:2N,N+1:2N). C CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, $ S(NP1,1), LDS, S(1,NP1), LDS, ONE, S(NP1,NP1), $ LDS ) C C Compute the solution matrix Y of the system A*Y = G. C CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1), $ LDS, INFO ) C C Compute the inverse of A in situ. C Workspace: need N; prefer N*NB. C CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) C -1 C Copy A in S(1:N,1:N). C CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) C ELSE C C Compute S in (3) using the already prepared part. C C Compute the solution matrix X' of the system A*X' = -G C -T C and transpose the result to obtain X = -G*A . C CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1), $ LDS, INFO ) C DO 340 J = 1, N - 1 CALL DSWAP( N-J, S(J+1,N+J), 1, S(J,NP1+J), LDS ) 340 CONTINUE C -T C Compute A + G*A *Q in S(1:N,1:N). C CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, $ S(1,NP1), LDS, S(NP1, 1), LDS, ONE, S, LDS ) C C Compute the solution matrix Y of the system A'*Y = -Q. C CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1), $ LDS, INFO ) C C Compute the inverse of A in situ. C Workspace: need N; prefer N*NB. C CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) C -T C Copy A in S(N+1:2N,N+1:2N). C DO 360 J = 1, N CALL DCOPY( N, A(J,1), LDA, S(NP1,N+J), 1 ) 360 CONTINUE C END IF DWORK(1) = MAXWRK DWORK(2) = RCOND END IF C C *** Last line of SB02MU *** RETURN END control-4.1.2/src/slicot/src/PaxHeaders/AB09HY.f0000644000000000000000000000013215012430707016171 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09HY.f0000644000175000017500000003052715012430707017374 0ustar00lilgelilge00000000000000 SUBROUTINE AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, $ SCALEC, SCALEO, S, LDS, R, LDR, IWORK, $ DWORK, LDWORK, BWORK, INFO ) C C PURPOSE C C To compute the Cholesky factors Su and Ru of the controllability C Grammian P = Su*Su' and observability Grammian Q = Ru'*Ru, C respectively, satisfying C C A*P + P*A' + scalec^2*B*B' = 0, (1) C C A'*Q + Q*A + scaleo^2*Cw'*Cw = 0, (2) C C where C Cw = Hw - Bw'*X, C Hw = inv(Dw)*C, C Bw = (B*D' + P*C')*inv(Dw'), C D*D' = Dw*Dw' (Dw upper triangular), C C and, with Aw = A - Bw*Hw, X is the stabilizing solution of the C Riccati equation C C Aw'*X + X*Aw + Hw'*Hw + X*Bw*Bw'*X = 0. (3) C C The P-by-M matrix D must have full row rank. Matrix A must be C stable and in a real Schur form. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of state-space representation, i.e., C the order of the 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. M >= 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 stable state dynamics matrix A in a real Schur canonical C form. 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, corresponding to the Schur matrix A. 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, corresponding to the Schur C matrix A. 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 C contain the full row rank input/output matrix D. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C SCALEC (output) DOUBLE PRECISION C Scaling factor for the controllability Grammian in (1). C C SCALEO (output) DOUBLE PRECISION C Scaling factor for the observability Grammian in (2). C C S (output) DOUBLE PRECISION array, dimension (LDS,N) C The leading N-by-N upper triangular part of this array C contains the Cholesky factor Su of the cotrollability C Grammian P = Su*Su' satisfying (1). C C LDS INTEGER C The leading dimension of array S. LDS >= MAX(1,N). C C R (output) DOUBLE PRECISION array, dimension (LDR,N) C The leading N-by-N upper triangular part of this array C contains the Cholesky factor Ru of the observability C Grammian Q = Ru'*Ru satisfying (2). C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,N). C C Workspace C C IWORK INTEGER array, dimension (2*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) contains RCOND, the reciprocal C condition number of the U11 matrix from the expression C used to compute X = U21*inv(U11). A small value RCOND C indicates possible ill-conditioning of the Riccati C equation (3). C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( 2, N*(MAX(N,M,P)+5), C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ). C For optimum performance LDWORK should be larger. 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: the state matrix A is not stable or is not in a C real Schur form; C = 2: the reduction of Hamiltonian matrix to real Schur C form failed; C = 3: the reordering of the real Schur form of the C Hamiltonian matrix failed; C = 4: the Hamiltonian matrix has less than N stable C eigenvalues; C = 5: the coefficient matrix U11 in the linear system C X*U11 = U21, used to determine X, is singular to C working precision; C = 6: the feedthrough matrix D has not a full row rank P. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. C D. Sima, University of Bucharest, May 2000. C V. Sima, Research Institute for Informatics, Bucharest, May 2000. C Based on the RASP routines SRGRO and SRGRO1, by A. Varga, 1992. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. C C KEYWORDS C C Minimal realization, model reduction, multivariable system, C state-space model, state-space representation, C stochastic balancing. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDC, LDD, LDR, LDS, LDWORK, M, N, $ P DOUBLE PRECISION SCALEC, SCALEO C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), R(LDR,*), S(LDS,*) LOGICAL BWORK(*) C .. Local Scalars .. INTEGER I, IERR, KBW, KCW, KD, KDW, KG, KQ, KS, KTAU, KU, $ KW, KWI, KWR, LW, N2, WRKOPT DOUBLE PRECISION RCOND, RTOL C .. External Functions .. DOUBLE PRECISION DLANGE, DLAMCH EXTERNAL DLANGE, DLAMCH C .. External Subroutines .. EXTERNAL DGEMM, DGERQF, DLACPY, DORGRQ, DSYRK, DTRMM, $ DTRSM, SB02MD, SB03OU, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN C .. Executable Statements .. C INFO = 0 LW = MAX( 2, N*( MAX( N, M, P ) + 5 ), $ 2*N*P + MAX( P*(M + 2), 10*N*(N + 1) ) ) C IF( N.LT.0 ) THEN INFO = -1 ELSE IF( M.LT.0 ) THEN INFO = -2 ELSE IF( P.LT.0 .OR. P.GT.M ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -9 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -11 ELSE IF( LDS.LT.MAX( 1, N ) ) THEN INFO = -15 ELSE IF( LDR.LT.MAX( 1, N ) ) THEN INFO = -17 ELSE IF( LDWORK.LT.LW ) THEN INFO = -20 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09HY', -INFO ) RETURN END IF C C Quick return if possible. C SCALEC = ONE SCALEO = ONE IF( MIN( N, M, P ).EQ.0 ) THEN DWORK(1) = TWO DWORK(2) = ONE RETURN END IF C C Solve for Su the Lyapunov equation C 2 C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . C C Workspace: need N*(MAX(N,M) + 5); C prefer larger. C KU = 1 KTAU = KU + N*MAX( N, M ) KW = KTAU + N C CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) CALL SB03OU( .FALSE., .TRUE., N, M, A, LDA, DWORK(KU), N, $ DWORK(KTAU), S, LDS, SCALEC, DWORK(KW), $ LDWORK - KW + 1, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN ENDIF WRKOPT = INT( DWORK(KW) ) + KW - 1 C C Allocate workspace for Bw' (P*N), Cw (P*N), Q2 (P*M), C where Q2 = inv(Dw)*D. C Workspace: need 2*N*P + P*M. C KBW = 1 KCW = KBW + P*N KD = KCW + P*N KDW = KD + P*(M - P) KTAU = KD + P*M KW = KTAU + P C C Compute an upper-triangular Dw such that D*D' = Dw*Dw', using C the RQ-decomposition of D: D = [0 Dw]*( Q1 ). C ( Q2 ) C Additional workspace: need 2*P; prefer P + P*NB. C CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P ) CALL DGERQF( P, M, DWORK(KD), P, DWORK(KTAU), DWORK(KW), $ LDWORK-KW+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Check the full row rank of D. C RTOL = DBLE( M ) * DLAMCH( 'E' ) * $ DLANGE( '1', P, M, D, LDD, DWORK ) DO 10 I = KDW, KDW+P*P-1, P+1 IF( ABS( DWORK(I) ).LE.RTOL ) THEN INFO = 6 RETURN END IF 10 CONTINUE C -1 C Compute Hw = Dw *C. C CALL DLACPY( 'F', P, N, C, LDC, DWORK(KCW), P ) CALL DTRSM( 'Left', 'Upper', 'No-transpose', 'Non-unit', P, N, $ ONE, DWORK(KDW), P, DWORK(KCW), P ) C C Compute Bw' = inv(Dw)*(D*B' + C*Su*Su'). C C Compute first Hw*Su*Su' in Bw'. C CALL DLACPY( 'F', P, N, DWORK(KCW), P, DWORK(KBW), P ) CALL DTRMM( 'Right', 'Upper', 'No-transpose', 'Non-unit', P, N, $ ONE, S, LDS, DWORK(KBW), P ) CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', P, N, $ ONE, S, LDS, DWORK(KBW), P ) C C Compute Q2 = inv(Dw)*D, as the last P lines of the orthogonal C matrix ( Q1 ) from the RQ decomposition of D. C ( Q2 ) C Additional workspace: need P; prefer P*NB. C CALL DORGRQ( P, M, P, DWORK(KD), P, DWORK(KTAU), DWORK(KW), $ LDWORK-KW+1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Compute Bw' <- Bw' + Q2*B'. C CALL DGEMM( 'No-transpose', 'Transpose', P, N, M, ONE, $ DWORK(KD), P, B, LDB, ONE, DWORK(KBW), P ) C C Compute Aw = A - Bw*Hw in R. C CALL DLACPY( 'F', N, N, A, LDA, R, LDR ) CALL DGEMM( 'Transpose', 'No-transpose', N, N, P, -ONE, $ DWORK(KBW), P, DWORK(KCW), P, ONE, R, LDR ) C C Allocate storage to solve the Riccati equation (3) for C G(N*N), Q(N*N), WR(2N), WI(2N), S(2N*2N), U(2N*2N). C N2 = N + N KG = KD KQ = KG + N*N KWR = KQ + N*N KWI = KWR + N2 KS = KWI + N2 KU = KS + N2*N2 KW = KU + N2*N2 C C Compute G = -Bw*Bw'. C CALL DSYRK( 'Upper', 'Transpose', N, P, -ONE, DWORK(KBW), P, ZERO, $ DWORK(KG), N ) C C Compute Q = Hw'*Hw. C CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, DWORK(KCW), P, ZERO, $ DWORK(KQ), N ) C C Solve C C Aw'*X + X*Aw + Q - X*G*X = 0, C C with Q = Hw'*Hw and G = -Bw*Bw'. C Additional workspace: need 6*N; C prefer larger. C CALL SB02MD( 'Continuous', 'None', 'Upper', 'General', 'Stable', $ N, R, LDR, DWORK(KG), N, DWORK(KQ), N, RCOND, $ DWORK(KWR), DWORK(KWI), DWORK(KS), N2, $ DWORK(KU), N2, IWORK, DWORK(KW), LDWORK-KW+1, $ BWORK, INFO ) IF( INFO.NE.0 ) $ RETURN WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Compute Cw = Hw - Bw'*X. C CALL DGEMM ( 'No-transpose', 'No-transpose', P, N, N, -ONE, $ DWORK(KBW), P, DWORK(KQ), N, ONE, DWORK(KCW), P ) C C Solve for Ru the Lyapunov equation C 2 C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * Cw'*Cw = 0 . C C Workspace: need N*(MAX(N,P) + 5); C prefer larger. C KTAU = KCW + N*MAX( N, P ) KW = KTAU + N C CALL SB03OU( .FALSE., .FALSE., N, P, A, LDA, DWORK(KCW), P, $ DWORK(KTAU), R, LDR, SCALEO, DWORK(KW), $ LDWORK - KW + 1, IERR ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Save optimal workspace and RCOND. C DWORK(1) = WRKOPT DWORK(2) = RCOND C RETURN C *** Last line of AB09HY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02CX.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02CX.f0000644000175000017500000002345315012430707017373 0ustar00lilgelilge00000000000000 SUBROUTINE MB02CX( TYPET, P, Q, K, A, LDA, B, LDB, CS, LCS, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To bring the first blocks of a generator in proper form. C The columns / rows of the positive and negative generators C are contained in the arrays A and B, respectively. C Transformation information will be stored and can be applied C via SLICOT Library routine MB02CY. C C ARGUMENTS C C Mode Parameters C C TYPET CHARACTER*1 C Specifies the type of the generator, as follows: C = 'R': A and B are the first blocks of the rows of the C positive and negative generators; C = 'C': A and B are the first blocks of the columns of the C positive and negative generators. C Note: in the sequel, the notation x / y means that C x corresponds to TYPET = 'R' and y corresponds to C TYPET = 'C'. C C Input/Output Parameters C C P (input) INTEGER C The number of rows / columns in A containing the positive C generators. P >= 0. C C Q (input) INTEGER C The number of rows / columns in B containing the negative C generators. Q >= 0. C C K (input) INTEGER C The number of columns / rows in A and B to be processed. C Normally, the size of the first block. P >= K >= 0. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, K) / (LDA, P) C On entry, the leading P-by-K upper / K-by-P lower C triangular part of this array must contain the rows / C columns of the positive part in the first block of the C generator. C On exit, the leading P-by-K upper / K-by-P lower C triangular part of this array contains the rows / columns C of the positive part in the first block of the proper C generator. C The lower / upper trapezoidal part is not referenced. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,P), if TYPET = 'R'; C LDA >= MAX(1,K), if TYPET = 'C'. C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, K) / (LDB, Q) C On entry, the leading Q-by-K / K-by-Q part of this array C must contain the rows / columns of the negative part in C the first block of the generator. C On exit, the leading Q-by-K / K-by-Q part of this array C contains part of the necessary information for the C Householder transformations. C C LDB INTEGER C The leading dimension of the array B. C LDB >= MAX(1,Q), if TYPET = 'R'; C LDB >= MAX(1,K), if TYPET = 'C'. C C CS (output) DOUBLE PRECISION array, dimension (LCS) C On exit, the leading 2*K + MIN(K,Q) part of this array C contains necessary information for the SLICOT Library C routine MB02CY (modified hyperbolic rotation parameters C and scalar factors of the Householder transformations). C C LCS INTEGER C The length of the array CS. LCS >= 2*K + MIN(K,Q). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -12, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,K). C For optimum performance LDWORK should be larger. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal C value; C = 1: the reduction algorithm failed. The matrix C associated with the generator is not (numerically) C positive definite. C C METHOD C C If TYPET = 'R', a QR decomposition of B is first computed. C Then, the elements below the first row of each column i of B C are annihilated by a Householder transformation modifying the C first element in that column. This first element, in turn, is C then annihilated by a modified hyperbolic rotation, acting also C on the i-th row of A. C C If TYPET = 'C', an LQ decomposition of B is first computed. C Then, the elements on the right of the first column of each row i C of B are annihilated by a Householder transformation modifying the C first element in that row. This first element, in turn, is C then annihilated by a modified hyperbolic rotation, acting also C on the i-th column of A. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 2000, C February 2004. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER TYPET INTEGER INFO, K, LDA, LDB, LCS, LDWORK, P, Q C .. Array Arguments .. DOUBLE PRECISION A(LDA, *), B(LDB, *), CS(*), DWORK(*) C .. Local Scalars .. LOGICAL ISROW INTEGER I, IERR DOUBLE PRECISION ALPHA, BETA, C, MAXWRK, S, TAU C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DGELQF, DGEQRF, DLARF, DLARFG, DSCAL, $ MA02FD, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX, MIN C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 ISROW = LSAME( TYPET, 'R' ) C C Check the scalar input parameters. C IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN INFO = -1 ELSE IF ( P.LT.0 ) THEN INFO = -2 ELSE IF ( Q.LT.0 ) THEN INFO = -3 ELSE IF ( K.LT.0 .OR. K.GT.P ) THEN INFO = -4 ELSE IF ( LDA.LT.1 .OR. ( ISROW .AND. LDA.LT.P ) .OR. $ ( .NOT.ISROW .AND. LDA.LT.K ) ) THEN INFO = -6 ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.Q ) .OR. $ ( .NOT.ISROW .AND. LDB.LT.K ) ) THEN INFO = -8 ELSE IF ( LCS.LT.2*K + MIN( K, Q ) ) THEN INFO = -10 ELSE IF ( LDWORK.LT.MAX( 1, K ) ) THEN DWORK(1) = MAX( 1, K ) INFO = -12 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02CX', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( Q, K ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C IF ( ISROW ) THEN C C The generator is row wise stored. C C Step 0: Do QR decomposition of B. C CALL DGEQRF ( Q, K, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR ) MAXWRK = DWORK(1) C DO 10 I = 1, K C C Step 1: annihilate the i-th column of B. C IF ( Q.GT.1 ) THEN CALL DLARFG( MIN( I, Q ), B(1,I), B(2,I), 1, TAU ) ALPHA = B(1,I) B(1,I) = ONE IF ( K.GT.I ) $ CALL DLARF( 'Left', MIN( I, Q ), K-I, B(1,I), 1, TAU, $ B(1,I+1), LDB, DWORK ) B(1,I) = ALPHA ELSE ALPHA = B(1,I) TAU = ZERO END IF C C Step 2: annihilate the top entry of the column. C BETA = A(I,I) CALL MA02FD( BETA, ALPHA, C, S, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C CS(I*2-1) = C CS(I*2) = S CALL DSCAL( K-I+1, ONE/C, A(I,I), LDA ) CALL DAXPY( K-I+1, -S/C, B(1,I), LDB, A(I,I), LDA ) CALL DSCAL( K-I+1, C, B(1,I), LDB ) CALL DAXPY( K-I+1, -S, A(I,I), LDA, B(1,I), LDB ) B(1,I) = TAU 10 CONTINUE C ELSE C C The generator is column wise stored. C C Step 0: Do LQ decomposition of B. C CALL DGELQF ( K, Q, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR ) MAXWRK = DWORK(1) C DO 20 I = 1, K C C Step 1: annihilate the i-th row of B. C IF ( Q.GT.1 ) THEN CALL DLARFG( MIN( I, Q ), B(I,1), B(I,2), LDB, TAU ) ALPHA = B(I,1) B(I,1) = ONE IF ( K.GT.I ) $ CALL DLARF( 'Right', K-I, MIN( I, Q ), B(I,1), LDB, $ TAU, B(I+1,1), LDB, DWORK ) B(I,1) = ALPHA ELSE ALPHA = B(I,1) TAU = ZERO END IF C C Step 2: annihilate the left entry of the row. C BETA = A(I,I) CALL MA02FD( BETA, ALPHA, C, S, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C CS(I*2-1) = C CS(I*2) = S CALL DSCAL( K-I+1, ONE/C, A(I,I), 1 ) CALL DAXPY( K-I+1, -S/C, B(I,1), 1, A(I,I), 1 ) CALL DSCAL( K-I+1, C, B(I,1), 1 ) CALL DAXPY( K-I+1, -S, A(I,I), 1, B(I,1), 1 ) B(I,1) = TAU 20 CONTINUE C END IF C DWORK(1) = MAXWRK C RETURN C C *** Last line of MB02CX *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01BD.f0000644000000000000000000000013215012430707016136 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/IB01BD.f0000644000175000017500000007620515012430707017344 0ustar00lilgelilge00000000000000 SUBROUTINE IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMPL, R, $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, $ RY, LDRY, S, LDS, K, LDK, TOL, IWORK, DWORK, $ LDWORK, BWORK, IWARN, INFO ) C C PURPOSE C C To estimate the system matrices A, C, B, and D, the noise C covariance matrices Q, Ry, and S, and the Kalman gain matrix K C of a linear time-invariant state space model, using the C processed triangular factor R of the concatenated block Hankel C matrices, provided by SLICOT Library routine IB01AD. C C ARGUMENTS C C Mode Parameters C C METH CHARACTER*1 C Specifies the subspace identification method to be used, C as follows: C = 'M': MOESP algorithm with past inputs and outputs; C = 'N': N4SID algorithm; C = 'C': combined method: MOESP algorithm for finding the C matrices A and C, and N4SID algorithm for C finding the matrices B and D. C C JOB CHARACTER*1 C Specifies which matrices should be computed, as follows: C = 'A': compute all system matrices, A, B, C, and D; C = 'C': compute the matrices A and C only; C = 'B': compute the matrix B only; C = 'D': compute the matrices B and D only. C C JOBCK CHARACTER*1 C Specifies whether or not the covariance matrices and the C Kalman gain matrix are to be computed, as follows: C = 'C': the covariance matrices only should be computed; C = 'K': the covariance matrices and the Kalman gain C matrix should be computed; C = 'N': the covariance matrices and the Kalman gain matrix C should not be computed. C C Input/Output Parameters C C NOBR (input) INTEGER C The number of block rows, s, in the input and output C Hankel matrices processed by other routines. NOBR > 1. C C N (input) INTEGER C The order of the system. NOBR > N > 0. C C M (input) INTEGER C The number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L > 0. C C NSMPL (input) INTEGER C If JOBCK = 'C' or 'K', the total number of samples used C for calculating the covariance matrices. C NSMPL >= 2*(M+L)*NOBR. C This parameter is not meaningful if JOBCK = 'N'. C C R (input/workspace) DOUBLE PRECISION array, dimension C ( LDR,2*(M+L)*NOBR ) C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR part C of this array must contain the relevant data for the MOESP C or N4SID algorithms, as constructed by SLICOT Library C routine IB01AD. Let R_ij, i,j = 1:4, be the C ij submatrix of R (denoted S in IB01AD), partitioned C by M*NOBR, L*NOBR, M*NOBR, and L*NOBR rows and C columns. The submatrix R_22 contains the matrix of left C singular vectors used. Also needed, for METH = 'N' or C JOBCK <> 'N', are the submatrices R_11, R_14 : R_44, C and, for METH = 'M' or 'C' and JOB <> 'C', the C submatrices R_31 and R_12, containing the processed C matrices R_1c and R_2c, respectively, as returned by C SLICOT Library routine IB01AD. C Moreover, if METH = 'N' and JOB = 'A' or 'C', the C block-row R_41 : R_43 must contain the transpose of the C block-column R_14 : R_34 as returned by SLICOT Library C routine IB01AD. C The remaining part of R is used as workspace. C On exit, part of this array is overwritten. Specifically, C if METH = 'M', R_22 and R_31 are overwritten if C JOB = 'B' or 'D', and R_12, R_22, R_14 : R_34, C and possibly R_11 are overwritten if JOBCK <> 'N'; C if METH = 'N', all needed submatrices are overwritten. C The details of the contents of R need not be known if C this routine is called once just after calling the SLICOT C Library routine IB01AD. C C LDR INTEGER C The leading dimension of the array R. C LDR >= 2*(M+L)*NOBR. C C A (input or output) DOUBLE PRECISION array, dimension C (LDA,N) C On entry, if METH = 'N' or 'C' and JOB = 'B' or 'D', C the leading N-by-N part of this array must contain the C system state matrix. C If METH = 'M' or (METH = 'N' or 'C' and JOB = 'A' C or 'C'), this array need not be set on input. C On exit, if JOB = 'A' or 'C' and INFO = 0, the C leading N-by-N part of this array contains the system C state matrix. C C LDA INTEGER C The leading dimension of the array A. C LDA >= N, if JOB = 'A' or 'C', or METH = 'N' or 'C' C and JOB = 'B' or 'D'; C LDA >= 1, otherwise. C C C (input or output) DOUBLE PRECISION array, dimension C (LDC,N) C On entry, if METH = 'N' or 'C' and JOB = 'B' or 'D', C the leading L-by-N part of this array must contain the C system output matrix. C If METH = 'M' or (METH = 'N' or 'C' and JOB = 'A' C or 'C'), this array need not be set on input. C On exit, if JOB = 'A' or 'C' and INFO = 0, or C INFO = 3 (or INFO >= 0, for METH = 'M'), the leading C L-by-N part of this array contains the system output C matrix. C C LDC INTEGER C The leading dimension of the array C. C LDC >= L, if JOB = 'A' or 'C', or METH = 'N' or 'C' C and JOB = 'B' or 'D'; C LDC >= 1, otherwise. C C B (output) DOUBLE PRECISION array, dimension (LDB,M) C If M > 0, JOB = 'A', 'B', or 'D' and INFO = 0, the C leading N-by-M part of this array contains the system C input matrix. If M = 0 or JOB = 'C', this array is C not referenced. C C LDB INTEGER C The leading dimension of the array B. C LDB >= N, if M > 0 and JOB = 'A', 'B', or 'D'; C LDB >= 1, if M = 0 or JOB = 'C'. C C D (output) DOUBLE PRECISION array, dimension (LDD,M) C If M > 0, JOB = 'A' or 'D' and INFO = 0, the leading C L-by-M part of this array contains the system input-output C matrix. If M = 0 or JOB = 'C' or 'B', this array is C not referenced. C C LDD INTEGER C The leading dimension of the array D. C LDD >= L, if M > 0 and JOB = 'A' or 'D'; C LDD >= 1, if M = 0 or JOB = 'C' or 'B'. C C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) C If JOBCK = 'C' or 'K', the leading N-by-N part of this C array contains the positive semidefinite state covariance C matrix. If JOBCK = 'K', this matrix has been used as C state weighting matrix for computing the Kalman gain. C This parameter is not referenced if JOBCK = 'N'. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= N, if JOBCK = 'C' or 'K'; C LDQ >= 1, if JOBCK = 'N'. C C RY (output) DOUBLE PRECISION array, dimension (LDRY,L) C If JOBCK = 'C' or 'K', the leading L-by-L part of this C array contains the positive (semi)definite output C covariance matrix. If JOBCK = 'K', this matrix has been C used as output weighting matrix for computing the Kalman C gain. C This parameter is not referenced if JOBCK = 'N'. C C LDRY INTEGER C The leading dimension of the array RY. C LDRY >= L, if JOBCK = 'C' or 'K'; C LDRY >= 1, if JOBCK = 'N'. C C S (output) DOUBLE PRECISION array, dimension (LDS,L) C If JOBCK = 'C' or 'K', the leading N-by-L part of this C array contains the state-output cross-covariance matrix. C If JOBCK = 'K', this matrix has been used as state- C output weighting matrix for computing the Kalman gain. C This parameter is not referenced if JOBCK = 'N'. C C LDS INTEGER C The leading dimension of the array S. C LDS >= N, if JOBCK = 'C' or 'K'; C LDS >= 1, if JOBCK = 'N'. C C K (output) DOUBLE PRECISION array, dimension ( LDK,L ) C If JOBCK = 'K', the leading N-by-L part of this array C contains the estimated Kalman gain matrix. C If JOBCK = 'C' or 'N', this array is not referenced. C C LDK INTEGER C The leading dimension of the array K. C LDK >= N, if JOBCK = 'K'; C LDK >= 1, if JOBCK = 'C' or 'N'. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used for estimating the rank of C matrices. If the user sets TOL > 0, then the given value C of TOL is used as a lower bound for the reciprocal C condition number; an m-by-n matrix whose estimated C condition number is less than 1/TOL is considered to C be of full rank. If the user sets TOL <= 0, then an C implicitly computed, default tolerance, defined by C TOLDEF = m*n*EPS, is used instead, where EPS is the C relative machine precision (see LAPACK Library routine C DLAMCH). C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK >= max(LIW1,LIW2), where C LIW1 = N, if METH <> 'N' and M = 0 C or JOB = 'C' and JOBCK = 'N'; C LIW1 = M*NOBR+N, if METH <> 'N', JOB = 'C', C and JOBCK <> 'N'; C LIW1 = max(L*NOBR,M*NOBR), if METH = 'M', JOB <> 'C', C and JOBCK = 'N'; C LIW1 = max(L*NOBR,M*NOBR+N), if METH = 'M', JOB <> 'C', C and JOBCK = 'C' or 'K'; C LIW1 = max(M*NOBR+N,M*(N+L)), if METH = 'N', or METH = 'C' C and JOB <> 'C'; C LIW2 = 0, if JOBCK <> 'K'; C LIW2 = N*N, if JOBCK = 'K'. 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(4), and C DWORK(5) contain the reciprocal condition numbers of the C triangular factors of the following matrices (defined in C SLICOT Library routine IB01PD and in the lower level C routines): C GaL (GaL = Un(1:(s-1)*L,1:n)), C R_1c (if METH = 'M' or 'C'), C M (if JOBCK = 'C' or 'K' or METH = 'N'), and C Q or T (see SLICOT Library routine IB01PY or IB01PX), C respectively. C If METH = 'N', DWORK(3) is set to one without any C calculations. Similarly, if METH = 'M' and JOBCK = 'N', C DWORK(4) is set to one. If M = 0 or JOB = 'C', C DWORK(3) and DWORK(5) are set to one. C If JOBCK = 'K' and INFO = 0, DWORK(6) to DWORK(13) C contain information about the accuracy of the results when C computing the Kalman gain matrix, as follows: C DWORK(6) - reciprocal condition number of the matrix C U11 of the Nth order system of algebraic C equations from which the solution matrix X C of the Riccati equation is obtained; C DWORK(7) - reciprocal pivot growth factor for the LU C factorization of the matrix U11; C DWORK(8) - reciprocal condition number of the matrix C As = A - S*inv(Ry)*C, which is inverted by C the standard Riccati solver; C DWORK(9) - reciprocal pivot growth factor for the LU C factorization of the matrix As; C DWORK(10) - reciprocal condition number of the matrix C Ry; C DWORK(11) - reciprocal condition number of the matrix C Ry + C*X*C'; C DWORK(12) - reciprocal condition number for the Riccati C equation solution; C DWORK(13) - forward error bound for the Riccati C equation solution. C On exit, if INFO = -30, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= max( LDW1,LDW2,LDW3 ), where, if METH = 'M', C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ), C if JOB = 'C' or JOB = 'A' and M = 0; C LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N, C (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+ C max( L+M*NOBR, L*NOBR + C max( 3*L*NOBR+1, M ) ) ), C if M > 0 and JOB = 'A', 'B', or 'D'; C LDW2 >= 0, if JOBCK = 'N'; C LDW2 >= L*NOBR*N+ C max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L), C 4*(M*NOBR+N)+1, M*NOBR+2*N+L ), C if JOBCK = 'C' or 'K', C where Aw = N+N*N, if M = 0 or JOB = 'C'; C Aw = 0, otherwise; C if METH = 'N', C LDW1 >= L*NOBR*N+max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L, C 2*(L*NOBR-L)*N+N*N+8*N, C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ); C LDW2 >= 0, if M = 0 or JOB = 'C'; C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ C max( (N+L)**2, 4*M*(N+L)+1 ), C if M > 0 and JOB = 'A', 'B', or 'D'; C and, if METH = 'C', LDW1 as C max( LDW1 for METH = 'M', JOB = 'C', LDW1 for METH = 'N'), C and LDW2 for METH = 'N' are used; C LDW3 >= 0, if JOBCK <> 'K'; C LDW3 >= max( 4*N*N+2*N*L+L*L+max( 3*L,N*L ), C 14*N*N+12*N+5 ), if JOBCK = 'K'. C For good performance, LDWORK should be larger. C C BWORK LOGICAL array, dimension (LBWORK) C LBWORK = 2*N, if JOBCK = 'K'; C LBWORK = 0, if JOBCK <> 'K'. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 4: a least squares problem to be solved has a C rank-deficient coefficient matrix; C = 5: the computed covariance matrices are too small. C The problem seems to be a deterministic one; the C gain matrix is set to zero. 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 = 2: the singular value decomposition (SVD) algorithm did C not converge; C = 3: a singular upper triangular matrix was found; C = 3+i: if JOBCK = 'K' and the associated Riccati C equation could not be solved, where i = 1,...,6; C (see the description of the parameter INFO for the C SLICOT Library routine SB02RD for the meaning of C the i values); C = 10: the QR algorithm did not converge. C C METHOD C C In the MOESP approach, the matrices A and C are first C computed from an estimated extended observability matrix [1], C and then, the matrices B and D are obtained by solving an C extended linear system in a least squares sense. C In the N4SID approach, besides the estimated extended C observability matrix, the solutions of two least squares problems C are used to build another least squares problem, whose solution C is needed to compute the system matrices A, C, B, and D. The C solutions of the two least squares problems are also optionally C used by both approaches to find the covariance matrices. C The Kalman gain matrix is obtained by solving a discrete-time C algebraic Riccati equation. C C REFERENCES C C [1] Verhaegen M., and Dewilde, P. C Subspace Model Identification. Part 1: The output-error C state-space model identification class of algorithms. C Int. J. Control, 56, pp. 1187-1210, 1992. C C [2] Van Overschee, P., and De Moor, B. C N4SID: Two Subspace Algorithms for the Identification C of Combined Deterministic-Stochastic Systems. C Automatica, Vol.30, No.1, pp. 75-93, 1994. C C [3] Van Overschee, P. C Subspace Identification : Theory - Implementation - C Applications. C Ph. D. Thesis, Department of Electrical Engineering, C Katholieke Universiteit Leuven, Belgium, Feb. 1995. C C [4] Sima, V. C Subspace-based Algorithms for Multivariable System C Identification. C Studies in Informatics and Control, 5, pp. 335-344, 1996. C C NUMERICAL ASPECTS C C The implemented method consists in numerically stable steps. C C FURTHER COMMENTS C C The covariance matrices are computed using the N4SID approach. C Therefore, for efficiency reasons, it is advisable to set C METH = 'N', if the Kalman gain matrix or covariance matrices C are needed (JOBCK = 'K', or 'C'). When JOBCK = 'N', it could C be more efficient to use the combined method, METH = 'C'. C Often, this combination will also provide better accuracy than C MOESP algorithm. C In some applications, it is useful to compute the system matrices C using two calls to this routine, the first one with JOB = 'C', C and the second one with JOB = 'B' or 'D'. This is slightly less C efficient than using a single call with JOB = 'A', because some C calculations are repeated. If METH = 'N', all the calculations C at the first call are performed again at the second call; C moreover, it is required to save the needed submatrices of R C before the first call and restore them before the second call. C If the covariance matrices and/or the Kalman gain are desired, C JOBCK should be set to 'C' or 'K' at the second call. C If B and D are both needed, they should be computed at once. C C CONTRIBUTOR C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 1999. C C REVISIONS C C March 2000, August 2000, Sept. 2001, March 2005. C C KEYWORDS C C Identification methods; least squares solutions; multivariable C systems; QR decomposition; singular value decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDK, LDQ, $ LDR, LDRY, LDS, LDWORK, M, N, NOBR, NSMPL CHARACTER JOB, JOBCK, METH C .. Array Arguments .. DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), $ DWORK(*), K(LDK, *), Q(LDQ, *), R(LDR, *), $ RY(LDRY, *), S(LDS, *) INTEGER IWORK( * ) LOGICAL BWORK( * ) C .. Local Scalars .. DOUBLE PRECISION FERR, RCOND, RCONDR, RNORM, SEP INTEGER I, IA, IAW, IC, ID, IERR, IFACT, IG, IK, IO, $ IQ, IR, IS, IT, IV, IWARNL, IWI, IWR, IX, $ JWORK, LDUNN, LL, LMMNOL, LMNOBR, LNOBR, $ MAXWRK, MINWRK, MNOBR, MNOBRN, N2, NL, NN, NPL, $ NR CHARACTER JOBBD, JOBCOV, JOBCV LOGICAL COMBIN, MOESP, N4SID, WITHAL, WITHB, WITHC, $ WITHCO, WITHD, WITHK C .. Local Arrays .. DOUBLE PRECISION RCND(8) INTEGER OUFACT(2) C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLACPY, DLASET, IB01PD, MA02AD, SB02MT, SB02ND, $ SB02RD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX C .. Executable Statements .. C C Decode the scalar input parameters. C MOESP = LSAME( METH, 'M' ) N4SID = LSAME( METH, 'N' ) COMBIN = LSAME( METH, 'C' ) WITHAL = LSAME( JOB, 'A' ) WITHC = LSAME( JOB, 'C' ) .OR. WITHAL WITHD = LSAME( JOB, 'D' ) .OR. WITHAL WITHB = LSAME( JOB, 'B' ) .OR. WITHD WITHK = LSAME( JOBCK, 'K' ) WITHCO = LSAME( JOBCK, 'C' ) .OR. WITHK MNOBR = M*NOBR LNOBR = L*NOBR LMNOBR = LNOBR + MNOBR MNOBRN = MNOBR + N LDUNN = ( LNOBR - L )*N LMMNOL = LNOBR + 2*MNOBR + L NR = LMNOBR + LMNOBR NPL = N + L N2 = N + N NN = N*N NL = N*L LL = L*L MINWRK = 1 IWARN = 0 INFO = 0 C C Check the scalar input parameters. C IF( .NOT.( MOESP .OR. N4SID .OR. COMBIN ) ) THEN INFO = -1 ELSE IF( .NOT.( WITHB .OR. WITHC ) ) THEN INFO = -2 ELSE IF( .NOT.( WITHCO .OR. LSAME( JOBCK, 'N' ) ) ) THEN INFO = -3 ELSE IF( NOBR.LE.1 ) THEN INFO = -4 ELSE IF( N.LE.0 .OR. N.GE.NOBR ) THEN INFO = -5 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( L.LE.0 ) THEN INFO = -7 ELSE IF( WITHCO .AND. NSMPL.LT.NR ) THEN INFO = -8 ELSE IF( LDR.LT.NR ) THEN INFO = -10 ELSE IF( LDA.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) ) $ .AND. LDA.LT.N ) ) THEN INFO = -12 ELSE IF( LDC.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) ) $ .AND. LDC.LT.L ) ) THEN INFO = -14 ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.N .AND. M.GT.0 ) ) $ THEN INFO = -16 ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) $ THEN INFO = -18 ELSE IF( LDQ.LT.1 .OR. ( WITHCO .AND. LDQ.LT.N ) ) THEN INFO = -20 ELSE IF( LDRY.LT.1 .OR. ( WITHCO .AND. LDRY.LT.L ) ) THEN INFO = -22 ELSE IF( LDS.LT.1 .OR. ( WITHCO .AND. LDS.LT.N ) ) THEN INFO = -24 ELSE IF( LDK.LT.1 .OR. ( WITHK .AND. LDK.LT.N ) ) THEN INFO = -26 ELSE C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C as well as the preferred amount for good performance.) C IAW = 0 MINWRK = LDUNN + 4*N IF( .NOT.N4SID ) THEN ID = 0 IF( WITHC ) THEN MINWRK = MAX( MINWRK, 2*LDUNN + N2, LDUNN + NN + 7*N ) END IF ELSE ID = N END IF C IF( ( M.GT.0 .AND. WITHB ) .OR. .NOT.MOESP ) THEN MINWRK = MAX( MINWRK, 2*LDUNN + NN + ID + 7*N ) IF ( MOESP ) $ MINWRK = MAX( MINWRK, LDUNN + N + 6*MNOBR, LDUNN + N + $ MAX( L + MNOBR, LNOBR + $ MAX( 3*LNOBR + 1, M ) ) ) ELSE IF( .NOT.N4SID ) $ IAW = N + NN END IF C IF( .NOT.MOESP .OR. WITHCO ) THEN MINWRK = MAX( MINWRK, LDUNN + IAW + N2 + MAX( 5*N, LMMNOL ), $ ID + 4*MNOBRN + 1, ID + MNOBRN + NPL ) IF( .NOT.MOESP .AND. M.GT.0 .AND. WITHB ) $ MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) + $ MAX( NPL**2, 4*M*NPL + 1 ) ) MINWRK = LNOBR*N + MINWRK END IF C IF( WITHK ) THEN MINWRK = MAX( MINWRK, 4*NN + 2*NL + LL + MAX( 3*L, NL ), $ 14*NN + 12*N + 5 ) END IF C IF ( LDWORK.LT.MINWRK ) THEN INFO = -30 DWORK( 1 ) = MINWRK END IF END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB01BD', -INFO ) RETURN END IF C IF ( .NOT.WITHK ) THEN JOBCV = JOBCK ELSE JOBCV = 'C' END IF C IO = 1 IF ( .NOT.MOESP .OR. WITHCO ) THEN JWORK = IO + LNOBR*N ELSE JWORK = IO END IF MAXWRK = MINWRK C C Call the computational routine for estimating system matrices. C IF ( .NOT.COMBIN ) THEN CALL IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, LDR, $ A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, RY, LDRY, $ S, LDS, DWORK(IO), LNOBR, TOL, IWORK, $ DWORK(JWORK), LDWORK-JWORK+1, IWARN, INFO ) C ELSE C IF ( WITHC ) THEN IF ( WITHAL ) THEN JOBCOV = 'N' ELSE JOBCOV = JOBCV END IF CALL IB01PD( 'MOESP', 'C and A', JOBCOV, NOBR, N, M, L, $ NSMPL, R, LDR, A, LDA, C, LDC, B, LDB, D, LDD, $ Q, LDQ, RY, LDRY, S, LDS, DWORK(IO), LNOBR, $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, $ IWARNL, INFO ) IF ( INFO.NE.0 ) $ RETURN IWARN = MAX( IWARN, IWARNL ) MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) END IF C IF ( WITHB ) THEN IF ( .NOT.WITHAL ) THEN JOBBD = JOB ELSE JOBBD = 'D' END IF CALL IB01PD( 'N4SID', JOBBD, JOBCV, NOBR, N, M, L, NSMPL, R, $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, $ RY, LDRY, S, LDS, DWORK(IO), LNOBR, TOL, IWORK, $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFO ) IWARN = MAX( IWARN, IWARNL ) END IF END IF C IF ( INFO.NE.0 ) $ RETURN MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C DO 10 I = 1, 4 RCND(I) = DWORK(JWORK+I) 10 CONTINUE C IF ( WITHK ) THEN IF ( IWARN.EQ.5 ) THEN C C The problem seems to be a deterministic one. Set the Kalman C gain to zero, set accuracy parameters and return. C CALL DLASET( 'Full', N, L, ZERO, ZERO, K, LDK ) C DO 20 I = 6, 12 DWORK(I) = ONE 20 CONTINUE C DWORK(13) = ZERO ELSE C C Compute the Kalman gain matrix. C C Convert the optimal problem with coupling weighting terms C to a standard problem. C Workspace: need 4*N*N+2*N*L+L*L+max( 3*L,N*L ); C prefer larger. C IX = 1 IQ = IX + NN IA = IQ + NN IG = IA + NN IC = IG + NN IR = IC + NL IS = IR + LL JWORK = IS + NL C CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) CALL DLACPY( 'Upper', N, N, Q, LDQ, DWORK(IQ), N ) CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) CALL DLACPY( 'Full', N, L, S, LDS, DWORK(IS), N ) C CALL SB02MT( 'G needed', 'Nonzero S', 'Not factored', $ 'Upper', N, L, DWORK(IA), N, DWORK(IC), N, $ DWORK(IQ), N, DWORK(IR), L, DWORK(IS), N, $ IWORK, IFACT, DWORK(IG), N, IWORK(L+1), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) IF ( IERR.NE.0 ) THEN INFO = 3 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) RCONDR = DWORK(JWORK+1) C C Solve the Riccati equation. C Workspace: need 14*N*N+12*N+5; C prefer larger. C IT = IC IV = IT + NN IWR = IV + NN IWI = IWR + N2 IS = IWI + N2 JWORK = IS + N2*N2 C CALL SB02RD( 'All', 'Discrete', 'Direct', 'NoTranspose', $ 'Upper', 'General scaling', 'Unstable first', $ 'Not factored', 'Reduced', N, DWORK(IA), N, $ DWORK(IT), N, DWORK(IV), N, DWORK(IG), N, $ DWORK(IQ), N, DWORK(IX), N, SEP, RCOND, FERR, $ DWORK(IWR), DWORK(IWI), DWORK(IS), N2, IWORK, $ DWORK(JWORK), LDWORK-JWORK+1, BWORK, IERR ) C IF ( IERR.NE.0 .AND. IERR.LT.7 ) THEN INFO = IERR + 3 RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C DO 30 I = 1, 4 RCND(I+4) = DWORK(JWORK+I) 30 CONTINUE C C Compute the gain matrix. C Workspace: need 2*N*N+2*N*L+L*L+3*L; C prefer larger. C IA = IX + NN IC = IA + NN IR = IC + NL IK = IR + LL JWORK = IK + NL C CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) C CALL SB02ND( 'Discrete', 'NotFactored', 'Upper', $ 'Nonzero S', N, L, 0, DWORK(IA), N, DWORK(IC), $ N, DWORK(IR), L, IWORK, S, LDS, DWORK(IX), N, $ RNORM, DWORK(IK), L, OUFACT, IWORK(L+1), $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) C IF ( IERR.NE.0 ) THEN IF ( IERR.LE.L+1 ) THEN INFO = 3 ELSE IF ( IERR.EQ.L+2 ) THEN INFO = 10 END IF RETURN END IF MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) C CALL MA02AD( 'Full', L, N, DWORK(IK), L, K, LDK ) C C Set the accuracy parameters. C DWORK(11) = DWORK(JWORK+1) C DO 40 I = 6, 9 DWORK(I) = RCND(I-1) 40 CONTINUE C DWORK(10) = RCONDR DWORK(12) = RCOND DWORK(13) = FERR END IF END IF C C Return optimal workspace in DWORK(1) and the remaining C reciprocal condition numbers in the next locations. C DWORK(1) = MAXWRK C DO 50 I = 2, 5 DWORK(I) = RCND(I-1) 50 CONTINUE C RETURN C C *** Last line of IB01BD *** END control-4.1.2/src/slicot/src/PaxHeaders/TG01OZ.f0000644000000000000000000000013215012430707016221 xustar0030 mtime=1747595719.989100963 30 atime=1747595719.989100963 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TG01OZ.f0000644000175000017500000002677415012430707017435 0ustar00lilgelilge00000000000000 SUBROUTINE TG01OZ( JOBE, N, DCBA, LDDCBA, E, LDE, NZ, G, TOL, $ ZWORK, LZWORK, INFO ) C C PURPOSE C C To compute for a single-input single-output descriptor system, C given by the system matrix with complex elements C C [ D C ] C [ B A - s*E ], C C with E nonsingular, a reduced system matrix, C C [ d c ] C [ b a - s*e ], C C such that d has a "sufficiently" large magnitude. C C ARGUMENTS C C Mode Parameters C C JOBE CHARACTER*1 C Specifies whether E is a general or an identity matrix, C as follows: C = 'G': The matrix E is a general matrix; C = 'I': The matrix E is assumed identity and is not given. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the descriptor state vector; also the C order of square matrices A and E, the number of rows of C matrix B, and the number of columns of matrix C. N >= 0. C C DCBA (input/output) COMPLEX*16 array, dimension (LDDCBA,N+1) C On entry, the leading (N+1)-by-(N+1) part of this array C must contain the original system matrices A, B, C, and D, C stored as follows C C [ D C ] C [ B A ]. C C On exit, the leading (NZ+1)-by-(NZ+1) part of this array C contains the reduced system matrices a, b, c, and d. C C LDDCBA INTEGER C The leading dimension of the array DCBA. LDDCBA >= N+1. C C E (input/output) COMPLEX*16 array, dimension (LDE,*) C On entry, if JOBE = 'G', the leading N-by-N part of this C array must contain the nonsingular descriptor matrix E. C On exit, if JOBE = 'G', the leading NZ-by-NZ part of this C array contains the reduced descriptor matrix e. C If JOBE = 'I', this array 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 NZ (output) INTEGER C The order of the reduced system. C C G (output) COMPLEX*16 C The gain of the reduced system. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in determining if the transformed C d has a "sufficiently" large magnitude. If the user sets C TOL > 0, then the given value of TOL is used. If the user C sets TOL <= 0, then an implicitly computed, default C tolerance, defined by TOLDEF = EPS**(3/4), is used C instead, where EPS is the machine precision (see LAPACK C Library routine DLAMCH). C C Workspace C C ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal value C of LZWORK. C On exit, if INFO = -11, ZWORK(1) returns the minimum value C of LZWORK. C C LZWORK INTEGER C The length of the array ZWORK. C LZWORK >= 2*N+1, if JOBE = 'G'; C LZWORK >= N+1, if JOBE = 'I'. C For good performance when JOBE = 'G', LZWORK should be C larger. Specifically, C LZWORK >= MAX( N*NB(ZGEQRF), (N+1)*NB(ZUNMQR) ), C where NB(X) is the optimal block sizes for the LAPACK C Library routine X. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK 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 Householder transformations and Givens rotations are used to C process the matrices. If E is a general matrix, it is first C triangularized using the QR decomposition, and the triangular form C is preserved during the remaining computations. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C V. Sima, May 2021. C C REVISIONS C C V. Sima, June 2021, Nov. 2021. C C KEYWORDS C C Givens rotation, orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, THREE, FOUR, ZERO PARAMETER ( ONE = 1.0D0, THREE = 3.0D0, FOUR = 4.0D0, $ ZERO = 0.0D0 ) COMPLEX*16 CONE, CZERO PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), $ CZERO = ( 0.0D+0, 0.0D+0 ) ) C .. Scalar Arguments .. CHARACTER JOBE INTEGER INFO, LDDCBA, LDE, LZWORK, N, NZ DOUBLE PRECISION TOL COMPLEX*16 G C .. Array Arguments .. COMPLEX*16 DCBA(LDDCBA,*), E(LDE,*), ZWORK(*) C .. Local Scalars .. CHARACTER JOBT LOGICAL DESCR, LQUERY INTEGER I, IMAX, ITAU, IWRK, J, JF, MAXWRK, MINWRK, N1, $ NC DOUBLE PRECISION ABSD, MAXA, NRMB, NRMC, TOLDEF COMPLEX*16 TAU C .. Local Arrays .. DOUBLE PRECISION DWORK(1) C .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH, DZNRM2, ZLANGE COMPLEX*16 ZLADIV EXTERNAL DLAMCH, DZNRM2, IZAMAX, LSAME, ZLADIV, ZLANGE C .. External Subroutines .. EXTERNAL TG01OB, XERBLA, ZCOPY, ZGEQRF, ZLARF, ZLARFG, $ ZLASET, ZSWAP, ZUNMQR C .. Intrinsic Functions .. INTRINSIC ABS, DCMPLX, DCONJG, INT, MAX, MIN C .. Executable Statements .. C DESCR = LSAME( JOBE, 'G' ) INFO = 0 N1 = N + 1 C C Test the input scalar arguments. C IF ( .NOT.DESCR .AND. .NOT.LSAME( JOBE, 'I' ) ) THEN INFO = -1 ELSE IF ( N.LT.0 ) THEN INFO = -2 ELSE IF ( LDDCBA.LT.N1 ) THEN INFO = -4 ELSE IF ( LDE.LT.1 .OR. ( DESCR .AND. LDE.LT.MAX( 1, N ) ) ) THEN INFO = -6 ELSE IF( DESCR ) THEN MINWRK = 2*N + 1 ELSE IF( N.EQ.0 ) THEN MINWRK = 1 ELSE MINWRK = N1 END IF MAXWRK = MINWRK LQUERY = LZWORK.EQ.-1 IF ( LQUERY ) THEN IF ( DESCR ) THEN CALL ZGEQRF( N, N, E, LDE, DCBA, ZWORK, -1, INFO ) MAXWRK = MAX( MAXWRK, INT( ZWORK(1) ) ) CALL ZUNMQR( 'Left', 'Conjugate', N, N1, N, E, LDE, DCBA, $ DCBA, LDDCBA, ZWORK, -1, INFO ) ZWORK(1) = DCMPLX( MAX( MAXWRK, INT( ZWORK(1) ) ) ) ELSE ZWORK(1) = DCMPLX( MAXWRK ) END IF RETURN ELSE IF( LZWORK.LT.MINWRK ) THEN ZWORK(1) = DCMPLX( MINWRK ) INFO = -11 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'TG01OZ', -INFO ) RETURN END IF C C Quick return if possible. C NZ = N IF( N.EQ.0 ) THEN G = DCBA(1,1) ZWORK(1) = CONE RETURN END IF C TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance. C TOLDEF = DLAMCH( 'Precision' )**( THREE/FOUR ) END IF C C Check if the reduction is needed. C G = CONE MAXA = ZLANGE( 'MAX', N, N, DCBA(2,2), LDDCBA, DWORK ) NRMB = DZNRM2( N, DCBA(2,1), 1 ) NRMC = DZNRM2( N, DCBA(1,2), N1 ) C IF( ABS( DCBA(1,1) )*( ONE + MAXA ).LE.TOLDEF*NRMB*NRMC ) THEN IF( DESCR ) THEN C C Triangularize E. C Workspace: need 2*N + 1; C prefer MAX( N*NB(ZGEQRF), (N+1)*NB(ZUNMQR) ). C ITAU = 1 IWRK = ITAU + N CALL ZGEQRF( N, N, E, LDE, ZWORK(ITAU), ZWORK(IWRK), $ LZWORK-N, INFO ) MAXWRK = MAX( MAXWRK, INT( ZWORK(IWRK) ) ) CALL ZUNMQR( 'Left', 'Conjugate', N, N1, N, E, LDE, $ ZWORK(ITAU), DCBA(2,1), LDDCBA, ZWORK(IWRK), $ LZWORK-N, INFO ) MAXWRK = MAX( MAXWRK, INT( ZWORK(IWRK) ) ) IF( N.GT.1 ) $ CALL ZLASET( 'Lower', N-1, N-1, CZERO, CZERO, E(2,1), $ LDE ) JOBT = 'Upper' ELSE JOBT = JOBE END IF C DO 10 I = 1, N C C Perform one-step deflation of [ D C; B A-s*E ] with D = 0. C NC = NZ + 1 IF( .NOT.DESCR ) THEN C C Ensure that the currently first entry of B is nonzero, C to maximize the identity portion of the Householder C transformation. C IF( DCBA(I+1,I).EQ.CZERO ) THEN C C Bring the largest entry of B in the first position. C IMAX = IZAMAX( NZ, DCBA(I+1,I), 1 ) + I CALL ZSWAP( NC, DCBA(I+1,I), LDDCBA, DCBA(IMAX,I), $ LDDCBA ) CALL ZSWAP( NC, DCBA(I,I+1), 1, DCBA(I,IMAX), 1 ) END IF C C Find and apply the Householder transformation setting C to zero all entries of the current B, but the first. C CALL ZLARFG( NZ, DCBA(I+1,I), DCBA(MIN(I+2,N1),I), 1, $ TAU ) G = G*DCBA(I+1,I) DCBA(I+1,I) = CONE CALL ZLARF( 'Left', NZ, NZ, DCBA(I+1,I), 1, $ DCONJG( TAU ), DCBA(I+1,I+1), LDDCBA, $ ZWORK ) CALL ZLARF( 'Right', NC, NZ, DCBA(I+1,I), 1, TAU, $ DCBA(I,I+1), LDDCBA, ZWORK ) ELSE CALL TG01OB( JOBT, NZ, DCBA(I,I), LDDCBA, E(I,I), LDE, $ INFO ) G = ZLADIV( G*DCBA(I+1,I), E(I,I) ) END IF C C Reduce DCBA (delete the second row and first column of the C current DCBA matrix). Actually, the first row is copied over C the second, and then the first row and column are removed. C CALL ZCOPY( NZ, DCBA(I,I+1), LDDCBA, DCBA(I+1,I+1), LDDCBA ) C C Terminate when [ D; B ] = 0, [ D C ] = 0, or D is large C enough. C NZ = NZ - 1 ABSD = ABS( DCBA(I+1,I+1) ) NRMB = DZNRM2( NZ, DCBA(I+2,I+1), 1 ) NRMC = DZNRM2( NZ, DCBA(I+1,I+2), N1 ) IF( ABSD.EQ.ZERO .AND. ( NRMB.EQ.ZERO .OR. NRMC.EQ.ZERO ) ) $ THEN NZ = 0 GO TO 20 END IF MAXA = ZLANGE( 'MAX', NZ, NZ, DCBA(I+2,I+2), LDDCBA, DWORK ) IF( ABSD*( ONE + MAXA ).GT.TOLDEF*NRMB*NRMC ) THEN GO TO 20 END IF 10 CONTINUE C I = N C 20 CONTINUE C C Move the results in the leading positions. C JF = 1 C DO 30 J = I + 1, N1 CALL ZCOPY( NZ+1, DCBA(I+1,J), 1, DCBA(1,JF), 1 ) JF = JF + 1 30 CONTINUE C IF( DESCR ) THEN JF = 1 C DO 40 J = I + 1, N CALL ZCOPY( NZ, E(I+1,J), 1, E(1,JF), 1 ) JF = JF + 1 40 CONTINUE C END IF C END IF C G = G*DCBA(1,1) ZWORK(1) = DCMPLX( MAXWRK ) C RETURN C *** Last line of TG01OZ *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09ID.f0000644000000000000000000000013215012430707016145 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09ID.f0000644000175000017500000012442015012430707017344 0ustar00lilgelilge00000000000000 SUBROUTINE AB09ID( DICO, JOBC, JOBO, JOB, WEIGHT, EQUIL, ORDSEL, $ N, M, P, NV, PV, NW, MW, NR, ALPHA, ALPHAC, $ ALPHAO, A, LDA, B, LDB, C, LDC, D, LDD, $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, $ NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, $ IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr,Dr) for an original C state-space representation (A,B,C,D) by using the frequency C weighted square-root or balancing-free square-root C Balance & Truncate (B&T) or Singular Perturbation Approximation C (SPA) model reduction methods. The algorithm tries to minimize C the norm of the frequency-weighted error C C ||V*(G-Gr)*W|| C C where G and Gr are the transfer-function matrices of the original C and reduced order models, respectively, and V and W are C frequency-weighting transfer-function matrices. V and W must not C have poles on the imaginary axis for a continuous-time C system or on the unit circle for a discrete-time system. C If G is unstable, only the ALPHA-stable part of G is reduced. C In case of possible pole-zero cancellations in V*G and/or G*W, C the absolute values of parameters ALPHAO and/or ALPHAC must be C different from 1. 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 JOBC CHARACTER*1 C Specifies the choice of frequency-weighted controllability C Grammian as follows: C = 'S': choice corresponding to a combination method [4] C of the approaches of Enns [1] and Lin-Chiu [2,3]; C = 'E': choice corresponding to the stability enhanced C modified combination method of [4]. C C JOBO CHARACTER*1 C Specifies the choice of frequency-weighted observability C Grammian as follows: C = 'S': choice corresponding to a combination method [4] C of the approaches of Enns [1] and Lin-Chiu [2,3]; C = 'E': choice corresponding to the stability enhanced C modified combination method of [4]. C C JOB CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root Balance & Truncate method; C = 'F': use the balancing-free square-root C Balance & Truncate method; C = 'S': use the square-root Singular Perturbation C Approximation method; C = 'P': use the balancing-free square-root C Singular Perturbation Approximation method. C C WEIGHT CHARACTER*1 C Specifies the type of frequency weighting, as follows: C = 'N': no weightings are used (V = I, W = I); C = 'L': only left weighting V is used (W = I); C = 'R': only right weighting W is used (V = I); C = 'B': both left and right weightings V and W are used. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL1. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e., the order of the 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 NV (input) INTEGER C The order of the matrix AV. Also the number of rows of C the matrix BV and the number of columns of the matrix CV. C NV represents the dimension of the state vector of the C system with the transfer-function matrix V. NV >= 0. C C PV (input) INTEGER C The number of rows of the matrices CV and DV. PV >= 0. C PV represents the dimension of the output vector of the C system with the transfer-function matrix V. C C NW (input) INTEGER C The order of the matrix AW. Also the number of rows of C the matrix BW and the number of columns of the matrix CW. C NW represents the dimension of the state vector of the C system with the transfer-function matrix W. NW >= 0. C C MW (input) INTEGER C The number of columns of the matrices BW and DW. MW >= 0. C MW represents the dimension of the input vector of the C system with the transfer-function matrix W. C C NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of the C resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. For a system with NU ALPHA-unstable C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), C NR is set as follows: if ORDSEL = 'F', NR is equal to C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order C on entry, NMIN is the number of frequency-weighted Hankel C singular values greater than NS*EPS*S1, EPS is the C machine precision (see LAPACK Library Routine DLAMCH) C and S1 is the largest Hankel singular value (computed C in HSV(1)); NR can be further reduced to ensure C HSV(NR-NU) > HSV(NR+1-NU); C if ORDSEL = 'A', NR is the sum of NU and the number of C Hankel singular values greater than MAX(TOL1,NS*EPS*S1). C C ALPHA (input) DOUBLE PRECISION C Specifies the ALPHA-stability boundary for the eigenvalues C of the state dynamics matrix A. For a continuous-time C system (DICO = 'C'), ALPHA <= 0 is the boundary value for C the real parts of eigenvalues, while for a discrete-time C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the C boundary value for the moduli of eigenvalues. C The ALPHA-stability domain does not include the boundary. C C ALPHAC (input) DOUBLE PRECISION C Combination method parameter for defining the C frequency-weighted controllability Grammian (see METHOD); C ABS(ALPHAC) <= 1. C C ALPHAO (input) DOUBLE PRECISION C Combination method parameter for defining the C frequency-weighted observability Grammian (see METHOD); C ABS(ALPHAO) <= 1. 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, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the C reduced order system. C The resulting A has a block-diagonal form with two blocks. C For a system with NU ALPHA-unstable eigenvalues and C NS ALPHA-stable eigenvalues (NU+NS = N), the leading C NU-by-NU block contains the unreduced part of A C corresponding to ALPHA-unstable eigenvalues. C The trailing (NR+NS-N)-by-(NR+NS-N) block contains C the reduced part of A corresponding to ALPHA-stable C eigenvalues. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. 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 original input/output matrix D. C On exit, if INFO = 0, the leading P-by-M part of this C array contains the input/output matrix Dr of the reduced C order system. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,P). C C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV C part of this array must contain the state matrix AV of C the system with the transfer-function matrix V. C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and C INFO = 0, the leading NVR-by-NVR part of this array C contains the state matrix of a minimal realization of V C in a real Schur form. NVR is returned in IWORK(2). C AV is not referenced if WEIGHT = 'R' or 'N', C or MIN(N,M,P) = 0. C C LDAV INTEGER C The leading dimension of array AV. C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; C LDAV >= 1, if WEIGHT = 'R' or 'N'. C C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part C of this array must contain the input matrix BV of the C system with the transfer-function matrix V. C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and C INFO = 0, the leading NVR-by-P part of this array contains C the input matrix of a minimal realization of V. C BV is not referenced if WEIGHT = 'R' or 'N', C or MIN(N,M,P) = 0. C C LDBV INTEGER C The leading dimension of array BV. C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; C LDBV >= 1, if WEIGHT = 'R' or 'N'. C C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) C On entry, if WEIGHT = 'L' or 'B', the leading PV-by-NV C part of this array must contain the output matrix CV of C the system with the transfer-function matrix V. C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and C INFO = 0, the leading PV-by-NVR part of this array C contains the output matrix of a minimal realization of V. C CV is not referenced if WEIGHT = 'R' or 'N', C or MIN(N,M,P) = 0. C C LDCV INTEGER C The leading dimension of array CV. C LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; C LDCV >= 1, if WEIGHT = 'R' or 'N'. C C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) C If WEIGHT = 'L' or 'B', the leading PV-by-P part of this C array must contain the feedthrough matrix DV of the system C with the transfer-function matrix V. C DV is not referenced if WEIGHT = 'R' or 'N', C or MIN(N,M,P) = 0. C C LDDV INTEGER C The leading dimension of array DV. C LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; C LDDV >= 1, if WEIGHT = 'R' or 'N'. C C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW C part of this array must contain the state matrix AW of C the system with the transfer-function matrix W. C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and C INFO = 0, the leading NWR-by-NWR part of this array C contains the state matrix of a minimal realization of W C in a real Schur form. NWR is returned in IWORK(3). C AW is not referenced if WEIGHT = 'L' or 'N', C or MIN(N,M,P) = 0. C C LDAW INTEGER C The leading dimension of array AW. C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; C LDAW >= 1, if WEIGHT = 'L' or 'N'. C C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,MW) C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-MW C part of this array must contain the input matrix BW of the C system with the transfer-function matrix W. C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and C INFO = 0, the leading NWR-by-MW part of this array C contains the input matrix of a minimal realization of W. C BW is not referenced if WEIGHT = 'L' or 'N', C or MIN(N,M,P) = 0. C C LDBW INTEGER C The leading dimension of array BW. C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; C LDBW >= 1, if WEIGHT = 'L' or 'N'. C C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part C of this array must contain the output matrix CW of the C system with the transfer-function matrix W. C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and C INFO = 0, the leading M-by-NWR part of this array contains C the output matrix of a minimal realization of W. C CW is not referenced if WEIGHT = 'L' or 'N', C or MIN(N,M,P) = 0. C C LDCW INTEGER C The leading dimension of array CW. C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; C LDCW >= 1, if WEIGHT = 'L' or 'N'. C C DW (input) DOUBLE PRECISION array, dimension (LDDW,MW) C If WEIGHT = 'R' or 'B', the leading M-by-MW part of this C array must contain the feedthrough matrix DW of the system C with the transfer-function matrix W. C DW is not referenced if WEIGHT = 'L' or 'N', C or MIN(N,M,P) = 0. C C LDDW INTEGER C The leading dimension of array DW. C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; C LDDW >= 1, if WEIGHT = 'L' or 'N'. C C NS (output) INTEGER C The dimension of the ALPHA-stable subsystem. C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, the leading NS elements of this array contain C the frequency-weighted Hankel singular values, ordered C decreasingly, of the ALPHA-stable part of the original C system. C C Tolerances C C TOL1 DOUBLE PRECISION C If ORDSEL = 'A', TOL1 contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL1 = c*S1, where c is a constant in the C interval [0.00001,0.001], and S1 is the largest C frequency-weighted Hankel singular value of the C ALPHA-stable part of the original system (computed C in HSV(1)). C If TOL1 <= 0 on entry, the used default value is C TOL1 = NS*EPS*S1, where NS is the number of C ALPHA-stable eigenvalues of A and EPS is the machine C precision (see LAPACK Library Routine DLAMCH). C If ORDSEL = 'F', the value of TOL1 is ignored. C C TOL2 DOUBLE PRECISION C The tolerance for determining the order of a minimal C realization of the ALPHA-stable part of the given system. C The recommended value is TOL2 = NS*EPS*S1. C This value is used by default if TOL2 <= 0 on entry. C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. C C Workspace C C IWORK INTEGER array, dimension C ( MAX( 3, LIWRK1, LIWRK2, LIWRK3 ) ), where C LIWRK1 = 0, if JOB = 'B'; C LIWRK1 = N, if JOB = 'F'; C LIWRK1 = 2*N, if JOB = 'S' or 'P'; C LIWRK2 = 0, if WEIGHT = 'R' or 'N' or NV = 0; C LIWRK2 = NV+MAX(P,PV), if WEIGHT = 'L' or 'B' and NV > 0; C LIWRK3 = 0, if WEIGHT = 'L' or 'N' or NW = 0; C LIWRK3 = NW+MAX(M,MW), if WEIGHT = 'R' or 'B' and NW > 0. C On exit, if INFO = 0, IWORK(1) contains the order of a C minimal realization of the stable part of the system, C IWORK(2) and IWORK(3) contain the actual orders C of the state space realizations of V and W, respectively. 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( LMINL, LMINR, LRCF, C 2*N*N + MAX( 1, LLEFT, LRIGHT, 2*N*N+5*N, C N*MAX(M,P) ) ), C where C LMINL = 0, if WEIGHT = 'R' or 'N' or NV = 0; otherwise, C LMINL = MAX(LLCF,NV+MAX(NV,3*P)) if P = PV; C LMINL = MAX(P,PV)*(2*NV+MAX(P,PV))+ C MAX(LLCF,NV+MAX(NV,3*P,3*PV)) if P <> PV; C LRCF = 0, and C LMINR = 0, if WEIGHT = 'L' or 'N' or NW = 0; otherwise, C LMINR = NW+MAX(NW,3*M) if M = MW; C LMINR = 2*NW*MAX(M,MW)+NW+MAX(NW,3*M,3*MW) if M <> MW; C LLCF = PV*(NV+PV)+PV*NV+MAX(NV*(NV+5), PV*(PV+2), C 4*PV, 4*P); C LRCF = MW*(NW+MW)+MAX(NW*(NW+5),MW*(MW+2),4*MW,4*M) C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) C if WEIGHT = 'L' or 'B' and PV > 0; C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) C if WEIGHT = 'R' or 'B' and MW > 0; C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than NSMIN, the sum of the order of the C ALPHA-unstable part and the order of a minimal C realization of the ALPHA-stable part of the given C system; in this case, the resulting NR is set equal C to NSMIN; C = 2: with ORDSEL = 'F', the selected order NR corresponds C to repeated singular values for the ALPHA-stable C part, which are neither all included nor all C excluded from the reduced model; in this case, the C resulting NR is automatically decreased to exclude C all repeated singular values; C = 3: with ORDSEL = 'F', the selected order NR is less C than the order of the ALPHA-unstable part of the C given system; in this case NR is set equal to the C order of the ALPHA-unstable part. C = 10+K: K violations of the numerical stability condition C occured during the assignment of eigenvalues in the C SLICOT Library routines SB08CD and/or 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 computation of the ordered real Schur form of A C failed; C = 2: the separation of the ALPHA-stable/unstable C diagonal blocks failed because of very close C eigenvalues; C = 3: the reduction to a real Schur form of the state C matrix of a minimal realization of V failed; C = 4: a failure was detected during the ordering of the C real Schur form of the state matrix of a minimal C realization of V or in the iterative process to C compute a left coprime factorization with inner C denominator; C = 5: if DICO = 'C' and the matrix AV has an observable C eigenvalue on the imaginary axis, or DICO = 'D' and C AV has an observable eigenvalue on the unit circle; C = 6: the reduction to a real Schur form of the state C matrix of a minimal realization of W failed; C = 7: a failure was detected during the ordering of the C real Schur form of the state matrix of a minimal C realization of W or in the iterative process to C compute a right coprime factorization with inner C denominator; C = 8: if DICO = 'C' and the matrix AW has a controllable C eigenvalue on the imaginary axis, or DICO = 'D' and C AW has a controllable eigenvalue on the unit circle; C = 9: the computation of eigenvalues failed; C = 10: the computation of Hankel singular values failed. C C METHOD C C Let G be the transfer-function matrix of the original C linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) + Du(t), (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09ID determines C the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) + Dr*u(t), (2) C C such that the corresponding transfer-function matrix Gr minimizes C the norm of the frequency-weighted error C C V*(G-Gr)*W, (3) C C where V and W are transfer-function matrices without poles on the C imaginary axis in continuous-time case or on the unit circle in C discrete-time case. C C The following procedure is used to reduce G: C C 1) Decompose additively G, of order N, as C C G = G1 + G2, C C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and C G2 = (A2,B2,C2,0), of order NU, has only ALPHA-unstable poles. C C 2) Compute for G1 a B&T or SPA frequency-weighted approximation C G1r of order NR-NU using the combination method or the C modified combination method of [4]. C C 3) Assemble the reduced model Gr as C C Gr = G1r + G2. C C For the frequency-weighted reduction of the ALPHA-stable part, C several methods described in [4] can be employed in conjunction C with the combination method and modified combination method C proposed in [4]. C C If JOB = 'B', the square-root B&T method is used. C If JOB = 'F', the balancing-free square-root version of the C B&T method is used. C If JOB = 'S', the square-root version of the SPA method is used. C If JOB = 'P', the balancing-free square-root version of the C SPA method is used. C C For each of these methods, left and right truncation matrices C are determined using the Cholesky factors of an input C frequency-weighted controllability Grammian P and an output C frequency-weighted observability Grammian Q. C P and Q are computed from the controllability Grammian Pi of G*W C and the observability Grammian Qo of V*G. Using special C realizations of G*W and V*G, Pi and Qo are computed in the C partitioned forms C C Pi = ( P11 P12 ) and Qo = ( Q11 Q12 ) , C ( P12' P22 ) ( Q12' Q22 ) C C where P11 and Q11 are the leading N-by-N parts of Pi and Qo, C respectively. Let P0 and Q0 be non-negative definite matrices C defined below C -1 C P0 = P11 - ALPHAC**2*P12*P22 *P21 , C -1 C Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21. C C The frequency-weighted controllability and observability C Grammians, P and Q, respectively, are defined as follows: C P = P0 if JOBC = 'S' (standard combination method [4]); C P = P1 >= P0 if JOBC = 'E', where P1 is the controllability C Grammian defined to enforce stability for a modified combination C method of [4]; C Q = Q0 if JOBO = 'S' (standard combination method [4]); C Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability C Grammian defined to enforce stability for a modified combination C method of [4]. C C If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of C Grammians corresponds to the method of Enns [1], while if C ALPHAC = ALPHAO = 1, the choice of Grammians corresponds C to the method of Lin and Chiu [2,3]. C C If JOBC = 'S' and ALPHAC = 1, no pole-zero cancellations must C occur in G*W. If JOBO = 'S' and ALPHAO = 1, no pole-zero C cancellations must occur in V*G. The presence of pole-zero C cancellations leads to meaningless results and must be avoided. C C The frequency-weighted Hankel singular values HSV(1), ...., C HSV(N) are computed as the square roots of the eigenvalues C of the product P*Q. C C REFERENCES C C [1] Enns, D. C Model reduction with balanced realizations: An error bound C and a frequency weighted generalization. C Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. C C [2] Lin, C.-A. and Chiu, T.-Y. C Model reduction via frequency-weighted balanced realization. C Control Theory and Advanced Technology, vol. 8, C pp. 341-351, 1992. C C [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. C New results on frequency weighted balanced reduction C technique. C Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. C C [4] Varga, A. and Anderson, B.D.O. C Square-root balancing-free methods for the frequency-weighted C balancing related model reduction. C (report in preparation) C C NUMERICAL ASPECTS C C The implemented methods rely on accuracy enhancing square-root C techniques. C C CONTRIBUTORS C C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. C D. Sima, University of Bucharest, August 2000. C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. C C REVISIONS C C A. Varga, Australian National University, Canberra, November 2000. C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, C Sep. 2001. C C KEYWORDS C C Frequency weighting, model reduction, multivariable system, C state-space model, state-space representation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION C100, ONE, ZERO PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, JOB, JOBC, JOBO, ORDSEL, WEIGHT INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, MW, $ N, NR, NS, NV, NW, P, PV DOUBLE PRECISION ALPHA, ALPHAC, ALPHAO, TOL1, TOL2 C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), $ HSV(*) C .. Local Scalars .. LOGICAL BTA, DISCR, FIXORD, FRWGHT, LEFTW, RIGHTW, $ SCALE, SPA INTEGER IERR, IWARNL, KBR, KBV, KBW, KCR, KCV, KCW, KDR, $ KDV, KI, KL, KT, KTI, KU, KW, LCF, LDW, LW, NMR, $ NN, NNQ, NNR, NNV, NNW, NRA, NU, NU1, NVR, NWR, $ PPV, WRKOPT DOUBLE PRECISION ALPWRK, MAXRED, SCALEC, SCALEO C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL AB09IX, AB09IY, DLACPY, SB08CD, SB08DD, TB01ID, $ TB01KD, TB01PD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, SQRT C .. Executable Statements .. C INFO = 0 IWARN = 0 DISCR = LSAME( DICO, 'D' ) BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) SCALE = LSAME( EQUIL, 'S' ) FIXORD = LSAME( ORDSEL, 'F' ) LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) FRWGHT = LEFTW .OR. RIGHTW C LW = 1 NN = N*N NNV = N + NV NNW = N + NW PPV = MAX( P, PV ) C IF( LEFTW .AND. PV.GT.0 ) THEN LW = MAX( LW, NNV*( NNV + MAX( NNV, PV ) + 5 ) ) ELSE LW = MAX( LW, N*( P + 5 ) ) END IF C IF( RIGHTW .AND. MW.GT.0 ) THEN LW = MAX( LW, NNW*( NNW + MAX( NNW, MW ) + 5 ) ) ELSE LW = MAX( LW, N*( M + 5 ) ) END IF LW = 2*NN + MAX( LW, 2*NN + 5*N, N*MAX( M, P ) ) C IF( LEFTW .AND. NV.GT.0 ) THEN LCF = PV*( NV + PV ) + PV*NV + $ MAX( NV*( NV + 5 ), PV*( PV + 2 ), 4*PPV ) IF( PV.EQ.P ) THEN LW = MAX( LW, LCF, NV + MAX( NV, 3*P ) ) ELSE LW = MAX( LW, PPV*( 2*NV + PPV ) + $ MAX( LCF, NV + MAX( NV, 3*PPV ) ) ) END IF END IF C IF( RIGHTW .AND. NW.GT.0 ) THEN IF( MW.EQ.M ) THEN LW = MAX( LW, NW + MAX( NW, 3*M ) ) ELSE LW = MAX( LW, 2*NW*MAX( M, MW ) + $ NW + MAX( NW, 3*M, 3*MW ) ) END IF LW = MAX( LW, MW*( NW + MW ) + $ MAX( NW*( NW + 5 ), MW*( MW + 2 ), 4*MW, 4*M ) ) END IF C C Check the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) $ THEN INFO = -2 ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) $ THEN INFO = -3 ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN INFO = -4 ELSE IF( .NOT. ( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN INFO = -5 ELSE IF( .NOT. ( SCALE .OR. LSAME( EQUIL, 'N' ) ) ) THEN INFO = -6 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN INFO = -7 ELSE IF( N.LT.0 ) THEN INFO = -8 ELSE IF( M.LT.0 ) THEN INFO = -9 ELSE IF( P.LT.0 ) THEN INFO = -10 ELSE IF( NV.LT.0 ) THEN INFO = -11 ELSE IF( PV.LT.0 ) THEN INFO = -12 ELSE IF( NW.LT.0 ) THEN INFO = -13 ELSE IF( MW.LT.0 ) THEN INFO = -14 ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -15 ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN INFO = -16 ELSE IF( ABS( ALPHAC ).GT.ONE ) THEN INFO = -17 ELSE IF( ABS( ALPHAO ).GT.ONE ) THEN INFO = -18 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -20 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -22 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -24 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -26 ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN INFO = -28 ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN INFO = -30 ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.PV ) ) THEN INFO = -32 ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.PV ) ) THEN INFO = -34 ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN INFO = -36 ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN INFO = -38 ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN INFO = -40 ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN INFO = -42 ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN INFO = -46 ELSE IF( LDWORK.LT.LW ) THEN INFO = -49 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09ID', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 ) THEN NR = 0 NS = 0 IWORK(1) = 0 IWORK(2) = NV IWORK(3) = NW DWORK(1) = ONE RETURN END IF C IF( SCALE ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C Workspace: N. C MAXRED = C100 CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Correct the value of ALPHA to ensure stability. C ALPWRK = ALPHA IF( DISCR ) THEN IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) ELSE IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) END IF C C Allocate working storage. C KU = 1 KL = KU + NN KI = KL + N KW = KI + N C C Reduce A to a block-diagonal real Schur form, with the C ALPHA-unstable part in the leading diagonal position, using a C non-orthogonal similarity transformation, A <- inv(T)*A*T, and C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. C C Workspace needed: N*(N+2); C Additional workspace: need 3*N; C prefer larger. C CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) C IF( IERR.NE.0 ) THEN IF( IERR.NE.3 ) THEN INFO = 1 ELSE INFO = 2 END IF RETURN END IF C WRKOPT = INT( DWORK(KW) ) + KW - 1 C C Determine NRA, the desired order for the reduction of stable part. C IWARNL = 0 NS = N - NU IF( FIXORD ) THEN NRA = MAX( 0, NR-NU ) IF( NR.LT.NU ) $ IWARNL = 3 ELSE NRA = 0 END IF C C Finish if only unstable part is present. C IF( NS.EQ.0 ) THEN NR = NU DWORK(1) = WRKOPT IWORK(1) = 0 IWORK(2) = NV IWORK(3) = NW RETURN END IF C NVR = NV IF( LEFTW .AND. NV.GT.0 ) THEN C C Compute a left-coprime factorization with inner denominator C of a minimal realization of V. The resulting AV is in C real Schur form. C Workspace needed: real LV+MAX( 1, LCF, C NV + MAX( NV, 3*P, 3*PV ) ), C where C LV = 0 if P = PV and C LV = MAX(P,PV)*(2*NV+MAX(P,PV)) C otherwise; C LCF = PV*(NV+PV) + C MAX( 1, PV*NV + MAX( NV*(NV+5), C PV*(PV+2),4*PV,4*P ) ); C prefer larger; C integer NV + MAX(P,PV). C IF( P.EQ.PV ) THEN KW = 1 CALL TB01PD( 'Minimal', 'Scale', NV, P, PV, AV, LDAV, $ BV, LDBV, CV, LDCV, NVR, ZERO, $ IWORK, DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) KBR = 1 KDR = KBR + PV*NVR KW = KDR + PV*PV CALL SB08CD( DICO, NVR, P, PV, AV, LDAV, BV, LDBV, CV, LDCV, $ DV, LDDV, NNQ, NNR, DWORK(KBR), MAX( 1, NVR ), $ DWORK(KDR), PV, ZERO, DWORK(KW), LDWORK-KW+1, $ IWARN, IERR ) ELSE LDW = MAX( P, PV ) KBV = 1 KCV = KBV + NV*LDW KW = KCV + NV*LDW CALL DLACPY( 'Full', NV, P, BV, LDBV, DWORK(KBV), NV ) CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KCV), LDW ) CALL TB01PD( 'Minimal', 'Scale', NV, P, PV, AV, LDAV, $ DWORK(KBV), NV, DWORK(KCV), LDW, NVR, ZERO, $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) KDV = KW KBR = KDV + LDW*LDW KDR = KBR + PV*NVR KW = KDR + PV*PV CALL DLACPY( 'Full', PV, P, DV, LDDV, DWORK(KDV), LDW ) CALL SB08CD( DICO, NVR, P, PV, AV, LDAV, DWORK(KBV), NV, $ DWORK(KCV), LDW, DWORK(KDV), LDW, NNQ, NNR, $ DWORK(KBR), MAX( 1, NVR ), DWORK(KDR), PV, $ ZERO, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) CALL DLACPY( 'Full', NVR, P, DWORK(KBV), NV, BV, LDBV ) CALL DLACPY( 'Full', PV, NVR, DWORK(KCV), LDW, CV, LDCV ) CALL DLACPY( 'Full', PV, P, DWORK(KDV), LDW, DV, LDDV ) END IF IF( IERR.NE.0 ) THEN INFO = IERR + 2 RETURN END IF NVR = NNQ WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) IF( IWARN.GT.0 ) $ IWARN = 10 + IWARN END IF C NWR = NW IF( RIGHTW .AND. NW.GT.0 ) THEN C C Compute a minimal realization of W. C Workspace needed: real LW+MAX(1, NW + MAX(NW, 3*M, 3*MW)); C where C LW = 0, if M = MW and C LW = 2*NW*MAX(M,MW), otherwise; C prefer larger; C integer NW + MAX(M,MW). C IF( M.EQ.MW ) THEN KW = 1 CALL TB01PD( 'Minimal', 'Scale', NW, MW, M, AW, LDAW, $ BW, LDBW, CW, LDCW, NWR, ZERO, IWORK, DWORK, $ LDWORK, INFO ) ELSE LDW = MAX( M, MW ) KBW = 1 KCW = KBW + NW*LDW KW = KCW + NW*LDW CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KBW), NW ) CALL DLACPY( 'Full', M, NW, CW, LDCW, DWORK(KCW), LDW ) CALL TB01PD( 'Minimal', 'Scale', NW, MW, M, AW, LDAW, $ DWORK(KBW), NW, DWORK(KCW), LDW, NWR, ZERO, $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) CALL DLACPY( 'Full', NWR, MW, DWORK(KBW), NW, BW, LDBW ) CALL DLACPY( 'Full', M, NWR, DWORK(KCW), LDW, CW, LDCW ) END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) END IF C IF( RIGHTW .AND. NWR.GT.0 ) THEN C C Compute a right-coprime factorization with inner denominator C of the minimal realization of W. The resulting AW is in C real Schur form. C C Workspace needed: MW*(NW+MW) + C MAX( 1, NW*(NW+5), MW*(MW+2), 4*MW, 4*M ); C prefer larger. C LDW = MAX( 1, MW ) KCR = 1 KDR = KCR + NWR*LDW KW = KDR + MW*LDW CALL SB08DD( DICO, NWR, MW, M, AW, LDAW, BW, LDBW, CW, LDCW, $ DW, LDDW, NNQ, NNR, DWORK(KCR), LDW, DWORK(KDR), $ LDW, ZERO, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) IF( IERR.NE.0 ) THEN INFO = IERR + 5 RETURN END IF NWR = NNQ WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) IF( IWARN.GT.0 ) $ IWARN = 10 + IWARN END IF C NU1 = NU + 1 C C Allocate working storage. C KT = 1 KTI = KT + NN KW = KTI + NN C C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R C of the controllability and observability Grammians, respectively. C Real workspace: need 2*N*N + MAX( 1, LLEFT, LRIGHT ), C where C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) C if WEIGHT = 'L' or 'B' and PV > 0; C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) C if WEIGHT = 'R' or 'B' and MW > 0; C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. C prefer larger. C CALL AB09IY( DICO, JOBC, JOBO, WEIGHT, NS, M, P, NVR, PV, NWR, $ MW, ALPHAC, ALPHAO, A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, AV, LDAV, BV, LDBV, CV, LDCV, $ DV, LDDV, AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, $ SCALEC, SCALEO, DWORK(KTI), N, DWORK(KT), N, $ DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 9 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) C C Compute a BTA or SPA of the stable part. C Real workspace: need 2*N*N + MAX( 1, 2*N*N+5*N, N*MAX(M,P) ). C CALL AB09IX( DICO, JOB, 'Schur', ORDSEL, NS, M, P, NRA, $ SCALEC, SCALEO, A(NU1,NU1), LDA, B(NU1,1), LDB, $ C(1,NU1), LDC, D, LDD, DWORK(KTI), N, DWORK(KT), N, $ NMR, HSV, TOL1, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, $ IWARN, IERR ) IWARN = MAX( IWARN, IWARNL ) IF( IERR.NE.0 ) THEN INFO = 10 RETURN END IF NR = NRA + NU C DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) IWORK(1) = NMR IWORK(2) = NVR IWORK(3) = NWR C RETURN C *** Last line of AB09ID *** END control-4.1.2/src/slicot/src/PaxHeaders/IB01PX.f0000644000000000000000000000013215012430707016200 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/IB01PX.f0000644000175000017500000003662015012430707017403 0ustar00lilgelilge00000000000000 SUBROUTINE IB01PX( JOB, NOBR, N, M, L, UF, LDUF, UN, LDUN, UL, $ LDUL, PGAL, LDPGAL, K, LDK, R, LDR, X, B, LDB, $ D, LDD, TOL, IWORK, DWORK, LDWORK, IWARN, $ INFO ) C C PURPOSE C C To build and solve the least squares problem T*X = Kv, and C estimate the matrices B and D of a linear time-invariant (LTI) C state space model, using the solution X, and the singular C value decomposition information and other intermediate results, C provided by other routines. C C The matrix T is computed as a sum of Kronecker products, C C T = T + kron(Uf(:,(i-1)*m+1:i*m),N_i), for i = 1 : s, C C (with T initialized by zero), where Uf is the triangular C factor of the QR factorization of the future input part (see C SLICOT Library routine IB01ND), N_i is given by the i-th block C row of the matrix C C [ Q_11 Q_12 ... Q_1,s-2 Q_1,s-1 Q_1s ] [ I_L 0 ] C [ Q_12 Q_13 ... Q_1,s-1 Q_1s 0 ] [ ] C N = [ Q_13 Q_14 ... Q_1s 0 0 ] * [ ], C [ : : : : : ] [ ] C [ Q_1s 0 ... 0 0 0 ] [ 0 GaL ] C C and where C C [ -L_1|1 ] [ M_i-1 - L_1|i ] C Q_11 = [ ], Q_1i = [ ], i = 2:s, C [ I_L - L_2|1 ] [ -L_2|i ] C C are (n+L)-by-L matrices, and GaL is built from the first n C relevant singular vectors, GaL = Un(1:L(s-1),1:n), computed C by IB01ND. C C The vector Kv is vec(K), with the matrix K defined by C C K = [ K_1 K_2 K_3 ... K_s ], C C where K_i = K(:,(i-1)*m+1:i*m), i = 1:s, is (n+L)-by-m. C The given matrices are Uf, GaL, and C C [ L_1|1 ... L_1|s ] C L = [ ], (n+L)-by-L*s, C [ L_2|1 ... L_2|s ] C C M = [ M_1 ... M_s-1 ], n-by-L*(s-1), and C K, (n+L)-by-m*s. C C Matrix M is the pseudoinverse of the matrix GaL, computed by C SLICOT Library routine IB01PD. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies which of the matrices B and D should be C computed, as follows: C = 'B': compute the matrix B, but not the matrix D; C = 'D': compute both matrices B and D. C C Input/Output Parameters C C NOBR (input) INTEGER C The number of block rows, s, in the input and output C Hankel matrices processed by other routines. NOBR > 1. C C N (input) INTEGER C The order of the system. NOBR > N > 0. C C M (input) INTEGER C The number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L > 0. C C UF (input/output) DOUBLE PRECISION array, dimension C ( LDUF,M*NOBR ) C On entry, the leading M*NOBR-by-M*NOBR upper triangular C part of this array must contain the upper triangular C factor of the QR factorization of the future input part, C as computed by SLICOT Library routine IB01ND. C The strict lower triangle need not be set to zero. C On exit, the leading M*NOBR-by-M*NOBR upper triangular C part of this array is unchanged, and the strict lower C triangle is set to zero. C C LDUF INTEGER C The leading dimension of the array UF. C LDUF >= MAX( 1, M*NOBR ). C C UN (input) DOUBLE PRECISION array, dimension ( LDUN,N ) C The leading L*(NOBR-1)-by-N part of this array must C contain the matrix GaL, i.e., the leading part of the C first N columns of the matrix Un of relevant singular C vectors. C C LDUN INTEGER C The leading dimension of the array UN. C LDUN >= L*(NOBR-1). C C UL (input/output) DOUBLE PRECISION array, dimension C ( LDUL,L*NOBR ) C On entry, the leading (N+L)-by-L*NOBR part of this array C must contain the given matrix L. C On exit, if M > 0, the leading (N+L)-by-L*NOBR part of C this array is overwritten by the matrix C [ Q_11 Q_12 ... Q_1,s-2 Q_1,s-1 Q_1s ]. C C LDUL INTEGER C The leading dimension of the array UL. LDUL >= N+L. C C PGAL (input) DOUBLE PRECISION array, dimension C ( LDPGAL,L*(NOBR-1) ) C The leading N-by-L*(NOBR-1) part of this array must C contain the pseudoinverse of the matrix GaL, computed by C SLICOT Library routine IB01PD. C C LDPGAL INTEGER C The leading dimension of the array PGAL. LDPGAL >= N. C C K (input) DOUBLE PRECISION array, dimension ( LDK,M*NOBR ) C The leading (N+L)-by-M*NOBR part of this array must C contain the given matrix K. C C LDK INTEGER C The leading dimension of the array K. LDK >= N+L. C C R (output) DOUBLE PRECISION array, dimension ( LDR,M*(N+L) ) C The leading (N+L)*M*NOBR-by-M*(N+L) part of this array C contains details of the complete orthogonal factorization C of the coefficient matrix T of the least squares problem C which is solved for getting the system matrices B and D. C C LDR INTEGER C The leading dimension of the array R. C LDR >= MAX( 1, (N+L)*M*NOBR ). C C X (output) DOUBLE PRECISION array, dimension C ( (N+L)*M*NOBR ) C The leading M*(N+L) elements of this array contain the C least squares solution of the system T*X = Kv. C The remaining elements are used as workspace (to store the C corresponding part of the vector Kv = vec(K)). C C B (output) DOUBLE PRECISION array, dimension ( LDB,M ) C The leading N-by-M part of this array contains the system C input matrix. C C LDB INTEGER C The leading dimension of the array B. LDB >= N. C C D (output) DOUBLE PRECISION array, dimension ( LDD,M ) C If JOB = 'D', the leading L-by-M part of this array C contains the system input-output matrix. C If JOB = 'B', this array is not referenced. C C LDD INTEGER C The leading dimension of the array D. C LDD >= L, if JOB = 'D'; C LDD >= 1, if JOB = 'B'. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used for estimating the rank of C matrices. If the user sets TOL > 0, then the given value C of TOL is used as a lower bound for the reciprocal C condition number; an m-by-n matrix whose estimated C condition number is less than 1/TOL is considered to C be of full rank. If the user sets TOL <= 0, then an C implicitly computed, default tolerance, defined by C TOLDEF = m*n*EPS, is used instead, where EPS is the C relative machine precision (see LAPACK Library routine C DLAMCH). C C Workspace C C IWORK INTEGER array, dimension ( M*(N+L) ) C C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK, and, if M > 0, DWORK(2) contains the C reciprocal condition number of the triangular factor of C the matrix T. C On exit, if INFO = -26, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX( (N+L)*(N+L), 4*M*(N+L)+1 ). C For good performance, LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 4: the least squares problem to be solved has a C rank-deficient coefficient matrix. 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 T is computed, evaluating the sum of Kronecker C products, and then the linear system T*X = Kv is solved in a C least squares sense. The matrices B and D are then directly C obtained from the least squares solution. C C REFERENCES C C [1] Verhaegen M., and Dewilde, P. C Subspace Model Identification. Part 1: The output-error C state-space model identification class of algorithms. C Int. J. Control, 56, pp. 1187-1210, 1992. C C [2] Van Overschee, P., and De Moor, B. C N4SID: Two Subspace Algorithms for the Identification C of Combined Deterministic-Stochastic Systems. C Automatica, Vol.30, No.1, pp. 75-93, 1994. C C [3] Van Overschee, P. C Subspace Identification : Theory - Implementation - C Applications. C Ph. D. Thesis, Department of Electrical Engineering, C Katholieke Universiteit Leuven, Belgium, Feb. 1995. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C C CONTRIBUTOR C C V. Sima, Katholieke Universiteit Leuven, Feb. 2000. C C REVISIONS C C V. Sima, Katholieke Universiteit Leuven, Sep. 2001. C C KEYWORDS C C Identification methods; least squares solutions; multivariable C systems; QR decomposition; singular value decomposition. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION TOL INTEGER INFO, IWARN, L, LDB, LDD, LDK, LDPGAL, LDR, $ LDUF, LDUL, LDUN, LDWORK, M, N, NOBR CHARACTER JOB C .. Array Arguments .. DOUBLE PRECISION B(LDB, *), D(LDD, *), DWORK(*), K(LDK, *), $ PGAL(LDPGAL, *), R(LDR, *), UF(LDUF, *), $ UL(LDUL, *), UN(LDUN, *), X(*) INTEGER IWORK( * ) C .. Local Scalars .. DOUBLE PRECISION RCOND, TOLL INTEGER I, IERR, J, JWORK, LDUN2, LNOBR, LP1, MAXWRK, $ MINWRK, MKRON, MNOBR, NKRON, NP1, NPL, RANK LOGICAL WITHB, WITHD C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DGELSY, DGEMM, DLACPY, DLASET, DTRCON, MB01VD, $ XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C C Decode the scalar input parameters. C WITHD = LSAME( JOB, 'D' ) WITHB = LSAME( JOB, 'B' ) .OR. WITHD MNOBR = M*NOBR LNOBR = L*NOBR LDUN2 = LNOBR - L LP1 = L + 1 NP1 = N + 1 NPL = N + L IWARN = 0 INFO = 0 C C Check the scalar input parameters. C IF( .NOT.WITHB ) THEN INFO = -1 ELSE IF( NOBR.LE.1 ) THEN INFO = -2 ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( L.LE.0 ) THEN INFO = -5 ELSE IF( LDUF.LT.MAX( 1, MNOBR ) ) THEN INFO = -7 ELSE IF( LDUN.LT.LDUN2 ) THEN INFO = -9 ELSE IF( LDUL.LT.NPL ) THEN INFO = -11 ELSE IF( LDPGAL.LT.N ) THEN INFO = -13 ELSE IF( LDK.LT.NPL ) THEN INFO = -15 ELSE IF( LDR.LT.MAX( 1, MNOBR*NPL ) ) THEN INFO = -17 ELSE IF( LDB.LT.N ) THEN INFO = -20 ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L ) ) THEN INFO = -22 ELSE C C Compute workspace. C (Note: Comments in the code beginning "Workspace:" describe the C minimal amount of workspace needed at that point in the code, C 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 MINWRK = MAX( NPL*NPL, 4*M*NPL + 1 ) C IF ( LDWORK.LT.MINWRK ) THEN INFO = -26 DWORK( 1 ) = MINWRK END IF END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'IB01PX', -INFO ) RETURN END IF C C Quick return if possible. C IF( M.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Construct the matrix [ Q_11 Q_12 ... Q_1,s-1 Q_1s ] in UL. C DO 20 J = 1, L C DO 10 I = 1, NPL UL(I,J) = -UL(I,J) 10 CONTINUE C UL(N+J,J) = ONE + UL(N+J,J) 20 CONTINUE C DO 50 J = LP1, LNOBR C DO 30 I = 1, N UL(I,J) = PGAL(I,J-L) - UL(I,J) 30 CONTINUE C DO 40 I = NP1, NPL UL(I,J) = -UL(I,J) 40 CONTINUE C 50 CONTINUE C C Compute the coefficient matrix T using Kronecker products. C Workspace: (N+L)*(N+L). C In the same loop, vectorize K in X. C CALL DLASET( 'Full', MNOBR*NPL, M*NPL, ZERO, ZERO, R, LDR ) CALL DLASET( 'Lower', MNOBR-1, MNOBR-1, ZERO, ZERO, UF(2,1), $ LDUF ) JWORK = NPL*L + 1 C DO 60 I = 1, NOBR CALL DLACPY( 'Full', NPL, L, UL(1,(I-1)*L+1), LDUL, DWORK, $ NPL ) IF ( I.LT.NOBR ) THEN CALL DGEMM ( 'NoTranspose', 'NoTranspose', NPL, N, $ L*(NOBR-I), ONE, UL(1,I*L+1), LDUL, UN, LDUN, $ ZERO, DWORK(JWORK), NPL ) ELSE CALL DLASET( 'Full', NPL, N, ZERO, ZERO, DWORK(JWORK), NPL ) END IF CALL MB01VD( 'NoTranspose', 'NoTranspose', MNOBR, M, NPL, $ NPL, ONE, ONE, UF(1,(I-1)*M+1), LDUF, DWORK, $ NPL, R, LDR, MKRON, NKRON, IERR ) CALL DLACPY( 'Full', NPL, M, K(1,(I-1)*M+1), LDK, $ X((I-1)*NKRON+1), NPL ) 60 CONTINUE C C Compute the tolerance. C TOLL = TOL IF( TOLL.LE.ZERO ) $ TOLL = MKRON*NKRON*DLAMCH( 'Precision' ) C C Solve the least square problem T*X = vec(K). C Workspace: need 4*M*(N+L)+1; C prefer 3*M*(N+L)+(M*(N+L)+1)*NB. C DO 70 I = 1, NKRON IWORK(I) = 0 70 CONTINUE C CALL DGELSY( MKRON, NKRON, 1, R, LDR, X, MKRON, IWORK, TOLL, RANK, $ DWORK, LDWORK, IERR ) MAXWRK = DWORK(1) C C Compute the reciprocal of the condition number of the triangular C factor R of T. C Workspace: need 3*M*(N+L). C CALL DTRCON( '1-norm', 'Upper', 'NonUnit', NKRON, R, LDR, RCOND, $ DWORK, IWORK, IERR ) C IF ( RANK.LT.NKRON ) THEN C C The least squares problem is rank-deficient. C IWARN = 4 END IF C C Construct the matrix D, if needed. C IF ( WITHD ) $ CALL DLACPY( 'Full', L, M, X, NPL, D, LDD ) C C Construct the matrix B. C CALL DLACPY( 'Full', N, M, X(LP1), NPL, B, LDB ) C C Return optimal workspace in DWORK(1) and reciprocal condition C number in DWORK(2). C DWORK(1) = MAX( MINWRK, MAXWRK ) DWORK(2) = RCOND C RETURN C C *** Last line of IB01PX *** END control-4.1.2/src/slicot/src/PaxHeaders/MD03BD.f0000644000000000000000000000013015012430707016144 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MD03BD.f0000644000175000017500000013736315012430707017357 0ustar00lilgelilge00000000000000 SUBROUTINE MD03BD( XINIT, SCALE, COND, FCN, QRFACT, LMPARM, M, N, $ ITMAX, FACTOR, NPRINT, IPAR, LIPAR, DPAR1, $ LDPAR1, DPAR2, LDPAR2, X, DIAG, NFEV, NJEV, $ FTOL, XTOL, GTOL, TOL, IWORK, DWORK, LDWORK, $ IWARN, INFO ) C C PURPOSE C C To minimize the sum of the squares of m nonlinear functions, e, in C n variables, x, by a modification of the Levenberg-Marquardt C algorithm. The user must provide a subroutine FCN which calculates C the functions and the Jacobian (possibly by finite differences). C In addition, specialized subroutines QRFACT, for QR factorization C with pivoting of the Jacobian, and LMPARM, for the computation of C Levenberg-Marquardt parameter, exploiting the possible structure C of the Jacobian matrix, should be provided. Template C implementations of these routines are included in SLICOT Library. C C ARGUMENTS C C Mode Parameters C C XINIT CHARACTER*1 C Specifies how the variables x are initialized, as follows: C = 'R' : the array X is initialized to random values; the C entries DWORK(1:4) are used to initialize the C random number generator: the first three values C are converted to integers between 0 and 4095, and C the last one is converted to an odd integer C between 1 and 4095; C = 'G' : the given entries of X are used as initial values C of variables. C C SCALE CHARACTER*1 C Specifies how the variables will be scaled, as follows: C = 'I' : use internal scaling; C = 'S' : use specified scaling factors, given in DIAG. C C COND CHARACTER*1 C Specifies whether the condition of the linear systems C involved should be estimated, as follows: C = 'E' : use incremental condition estimation to find the C numerical rank; C = 'N' : do not use condition estimation, but check the C diagonal entries of matrices for zero values. C C Function Parameters C C FCN EXTERNAL C Subroutine which evaluates the functions and the Jacobian. C FCN must be declared in an external statement in the user C calling program, and must have the following interface: C C SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, C $ DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, DWORK, C $ LDWORK, INFO ) C C where C C IFLAG (input/output) INTEGER C On entry, this parameter must contain a value C defining the computations to be performed: C = 0 : Optionally, print the current iterate X, C function values E, and Jacobian matrix J, C or other results defined in terms of these C values. See the argument NPRINT of MD03BD. C Do not alter E and J. C = 1 : Calculate the functions at X and return C this vector in E. Do not alter J. C = 2 : Calculate the Jacobian at X and return C this matrix in J. Also return NFEVL C (see below). Do not alter E. C = 3 : Do not compute neither the functions nor C the Jacobian, but return in LDJ and C IPAR/DPAR1,DPAR2 (some of) the integer/real C parameters needed. C On exit, the value of this parameter should not be C changed by FCN unless the user wants to terminate C execution of MD03BD, in which case IFLAG must be C set to a negative integer. C C M (input) INTEGER C The number of functions. M >= 0. C C N (input) INTEGER C The number of variables. M >= N >= 0. C C IPAR (input/output) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of C the Jacobian matrix or needed for problem solving. C IPAR is an input parameter, except for IFLAG = 3 C on entry, when it is also an output parameter. C On exit, if IFLAG = 3, IPAR(1) contains the length C of the array J, for storing the Jacobian matrix, C and the entries IPAR(2:5) contain the workspace C required by FCN for IFLAG = 1, FCN for IFLAG = 2, C QRFACT, and LMPARM, respectively. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 5. C C DPAR1 (input/output) DOUBLE PRECISION array, dimension C (LDPAR1,*) or (LDPAR1) C A first set of real parameters needed for C describing or solving the problem. C DPAR1 can also be used as an additional array for C intermediate results when computing the functions C or the Jacobian. For control problems, DPAR1 could C store the input trajectory of a system. C C LDPAR1 (input) INTEGER C The leading dimension or the length of the array C DPAR1, as convenient. LDPAR1 >= 0. (LDPAR1 >= 1, C if leading dimension.) C C DPAR2 (input/output) DOUBLE PRECISION array, dimension C (LDPAR2,*) or (LDPAR2) C A second set of real parameters needed for C describing or solving the problem. C DPAR2 can also be used as an additional array for C intermediate results when computing the functions C or the Jacobian. For control problems, DPAR2 could C store the output trajectory of a system. C C LDPAR2 (input) INTEGER C The leading dimension or the length of the array C DPAR2, as convenient. LDPAR2 >= 0. (LDPAR2 >= 1, C if leading dimension.) C C X (input) DOUBLE PRECISION array, dimension (N) C This array must contain the value of the C variables x where the functions or the Jacobian C must be evaluated. C C NFEVL (input/output) INTEGER C The number of function evaluations needed to C compute the Jacobian by a finite difference C approximation. C NFEVL is an input parameter if IFLAG = 0, or an C output parameter if IFLAG = 2. If the Jacobian is C computed analytically, NFEVL should be set to a C non-positive value. C C E (input/output) DOUBLE PRECISION array, C dimension (M) C This array contains the value of the (error) C functions e evaluated at X. C E is an input parameter if IFLAG = 0 or 2, or an C output parameter if IFLAG = 1. C C J (input/output) DOUBLE PRECISION array, dimension C (LDJ,NC), where NC is the number of columns C needed. C This array contains a possibly compressed C representation of the Jacobian matrix evaluated C at X. If full Jacobian is stored, then NC = N. C J is an input parameter if IFLAG = 0, or an output C parameter if IFLAG = 2. C C LDJ (input/output) INTEGER C The leading dimension of array J. LDJ >= 1. C LDJ is essentially used inside the routines FCN, C QRFACT and LMPARM. C LDJ is an input parameter, except for IFLAG = 3 C on entry, when it is an output parameter. C It is assumed in MD03BD that LDJ is not larger C than needed. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C The workspace array for subroutine FCN. C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C C LDWORK (input) INTEGER C The size of the array DWORK (as large as needed C in the subroutine FCN). LDWORK >= 1. C C INFO INTEGER C Error indicator, set to a negative value if an C input (scalar) argument is erroneous, and to C positive values for other possible errors in the C subroutine FCN. The LAPACK Library routine XERBLA C should be used in conjunction with negative INFO. C INFO must be zero if the subroutine finished C successfully. C C Parameters marked with "(input)" must not be changed. C C QRFACT EXTERNAL C Subroutine which computes the QR factorization with C (block) column pivoting of the Jacobian matrix, J*P = Q*R. C QRFACT must be declared in an external statement in the C calling program, and must have the following interface: C C SUBROUTINE QRFACT( N, IPAR, LIPAR, FNORM, J, LDJ, E, C $ JNORMS, GNORM, IPVT, DWORK, LDWORK, C $ INFO ) C C where C C N (input) INTEGER C The number of columns of the Jacobian matrix J. C N >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of C the Jacobian matrix. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 0. C C FNORM (input) DOUBLE PRECISION C The Euclidean norm of the vector e. FNORM >= 0. C C J (input/output) DOUBLE PRECISION array, dimension C (LDJ, NC), where NC is the number of columns. C On entry, the leading NR-by-NC part of this array C must contain the (compressed) representation C of the Jacobian matrix J, where NR is the number C of rows of J (function of IPAR entries). C On exit, the leading N-by-NC part of this array C contains a (compressed) representation of the C upper triangular factor R of the Jacobian matrix. C For efficiency of the later calculations, the C matrix R is delivered with the leading dimension C MAX(1,N), possibly much smaller than the value C of LDJ on entry. C C LDJ (input/output) INTEGER C The leading dimension of array J. C On entry, LDJ >= MAX(1,NR). C On exit, LDJ >= MAX(1,N). C C E (input/output) DOUBLE PRECISION array, dimension C (NR) C On entry, this array contains the error vector e. C On exit, this array contains the updated vector C Z*Q'*e, where Z is a block row permutation matrix C (possibly identity) used in the QR factorization C of J. (See, for example, the SLICOT Library C routine NF01BS, Section METHOD.) C C JNORMS (output) DOUBLE PRECISION array, dimension (N) C This array contains the Euclidean norms of the C columns of the Jacobian matrix (in the original C order). C C GNORM (output) DOUBLE PRECISION C If FNORM > 0, the 1-norm of the scaled vector C J'*e/FNORM, with each element i further divided C by JNORMS(i) (if JNORMS(i) is nonzero). C If FNORM = 0, the returned value of GNORM is 0. C C IPVT (output) INTEGER array, dimension (N) C This array defines the permutation matrix P such C that J*P = Q*R. Column j of P is column IPVT(j) of C the identity matrix. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C The workspace array for subroutine QRFACT. C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C C LDWORK (input) INTEGER C The size of the array DWORK (as large as needed C in the subroutine QRFACT). LDWORK >= 1. C C INFO INTEGER C Error indicator, set to a negative value if an C input (scalar) argument is erroneous, and to C positive values for other possible errors in the C subroutine QRFACT. The LAPACK Library routine C XERBLA should be used in conjunction with negative C INFO. INFO must be zero if the subroutine finished C successfully. C C Parameters marked with "(input)" must not be changed. C C LMPARM EXTERNAL C Subroutine which determines a value for the Levenberg- C Marquardt parameter PAR such that if x solves the system C C J*x = b , sqrt(PAR)*D*x = 0 , C C in the least squares sense, where J is an m-by-n matrix, C D is an n-by-n nonsingular diagonal matrix, and b is an C m-vector, and if DELTA is a positive number, DXNORM is C the Euclidean norm of D*x, then either PAR is zero and C C ( DXNORM - DELTA ) .LE. 0.1*DELTA , C C or PAR is positive and C C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . C C It is assumed that a block QR factorization, with column C pivoting, of J is available, that is, J*P = Q*R, where P C is a permutation matrix, Q has orthogonal columns, and C R is an upper triangular matrix (possibly stored in a C compressed form), with diagonal elements of nonincreasing C magnitude for each block. On output, LMPARM also provides C a (compressed) representation of an upper triangular C matrix S, such that C C P'*(J'*J + PAR*D*D)*P = S'*S . C C LMPARM must be declared in an external statement in the C calling program, and must have the following interface: C C SUBROUTINE LMPARM( COND, N, IPAR, LIPAR, R, LDR, IPVT, C $ DIAG, QTB, DELTA, PAR, RANKS, X, RX, C $ TOL, DWORK, LDWORK, INFO ) C C where C C COND CHARACTER*1 C Specifies whether the condition of the linear C systems involved should be estimated, as follows: C = 'E' : use incremental condition estimation C to find the numerical rank; C = 'N' : do not use condition estimation, but C check the diagonal entries for zero C values; C = 'U' : use the ranks already stored in RANKS C (for R). C C N (input) INTEGER C The order of the matrix R. N >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of C the Jacobian matrix. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 0. C C R (input/output) DOUBLE PRECISION array, dimension C (LDR, NC), where NC is the number of columns. C On entry, the leading N-by-NC part of this array C must contain the (compressed) representation (Rc) C of the upper triangular matrix R. C On exit, the full upper triangular part of R C (in representation Rc), is unaltered, and the C remaining part contains (part of) the (compressed) C representation of the transpose of the upper C triangular matrix S. C C LDR (input) INTEGER C The leading dimension of array R. C LDR >= MAX(1,N). C C IPVT (input) INTEGER array, dimension (N) C This array must define the permutation matrix P C such that J*P = Q*R. Column j of P is column C IPVT(j) of the identity matrix. C C DIAG (input) DOUBLE PRECISION array, dimension (N) C This array must contain the diagonal elements of C the matrix D. DIAG(I) <> 0, I = 1,...,N. C C QTB (input) DOUBLE PRECISION array, dimension (N) C This array must contain the first n elements of C the vector Q'*b. C C DELTA (input) DOUBLE PRECISION C An upper bound on the Euclidean norm of D*x. C DELTA > 0. C C PAR (input/output) DOUBLE PRECISION C On entry, PAR must contain an initial estimate of C the Levenberg-Marquardt parameter. PAR >= 0. C On exit, it contains the final estimate of this C parameter. C C RANKS (input or output) INTEGER array, dimension (r), C where r is the number of diagonal blocks R_k in R, C corresponding to the block column structure of J. C On entry, if COND = 'U' and N > 0, this array must C contain the numerical ranks of the submatrices C R_k, k = 1:r. The number r is defined in terms of C the entries of IPAR. C On exit, if N > 0, this array contains the C numerical ranks of the submatrices S_k, k = 1:r. C C X (output) DOUBLE PRECISION array, dimension (N) C This array contains the least squares solution of C the system J*x = b, sqrt(PAR)*D*x = 0. C C RX (output) DOUBLE PRECISION array, dimension (N) C This array contains the matrix-vector product C -R*P'*x. C C TOL (input) DOUBLE PRECISION C If COND = 'E', the tolerance to be used for C finding the ranks of the submatrices R_k and S_k. C If the user sets TOL > 0, then the given value of C TOL is used as a lower bound for the reciprocal C condition number; a (sub)matrix whose estimated C condition number is less than 1/TOL is considered C to be of full rank. If the user sets TOL <= 0, C then an implicitly computed, default tolerance, C defined by TOLDEF = N*EPS, is used instead, C where EPS is the machine precision (see LAPACK C Library routine DLAMCH). C This parameter is not relevant if COND = 'U' C or 'N'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C The workspace array for subroutine LMPARM. C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C C LDWORK (input) INTEGER C The size of the array DWORK (as large as needed C in the subroutine LMPARM). LDWORK >= 1. C C INFO INTEGER C Error indicator, set to a negative value if an C input (scalar) argument is erroneous, and to C positive values for other possible errors in the C subroutine LMPARM. The LAPACK Library routine C XERBLA should be used in conjunction with negative C INFO. INFO must be zero if the subroutine finished C successfully. C C Parameters marked with "(input)" must not be changed. C C Input/Output Parameters C C M (input) INTEGER C The number of functions. M >= 0. C C N (input) INTEGER C The number of variables. M >= N >= 0. C C ITMAX (input) INTEGER C The maximum number of iterations. ITMAX >= 0. C C FACTOR (input) DOUBLE PRECISION C The value used in determining the initial step bound. This C bound is set to the product of FACTOR and the Euclidean C norm of DIAG*X if nonzero, or else to FACTOR itself. C In most cases FACTOR should lie in the interval (.1,100). C A generally recommended value is 100. FACTOR > 0. C C NPRINT (input) INTEGER C This parameter enables controlled printing of iterates if C it is positive. In this case, FCN is called with IFLAG = 0 C at the beginning of the first iteration and every NPRINT C iterations thereafter and immediately prior to return, C with X, E, and J available for printing. Note that when C called immediately prior to return, J normally contains C the result returned by QRFACT and LMPARM (the compressed C R and S factors). If NPRINT is not positive, no special C calls of FCN with IFLAG = 0 are made. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters needed, for instance, for C describing the structure of the Jacobian matrix, which C are handed over to the routines FCN, QRFACT and LMPARM. C The first five entries of this array are modified C internally by a call to FCN (with IFLAG = 3), but are C restored on exit. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 5. C C DPAR1 (input/output) DOUBLE PRECISION array, dimension C (LDPAR1,*) or (LDPAR1) C A first set of real parameters needed for describing or C solving the problem. This argument is not used by MD03BD C routine, but it is passed to the routine FCN. C C LDPAR1 (input) INTEGER C The leading dimension or the length of the array DPAR1, as C convenient. LDPAR1 >= 0. (LDPAR1 >= 1, if leading C dimension.) C C DPAR2 (input/output) DOUBLE PRECISION array, dimension C (LDPAR2,*) or (LDPAR2) C A second set of real parameters needed for describing or C solving the problem. This argument is not used by MD03BD C routine, but it is passed to the routine FCN. C C LDPAR2 (input) INTEGER C The leading dimension or the length of the array DPAR2, as C convenient. LDPAR2 >= 0. (LDPAR2 >= 1, if leading C dimension.) C C X (input/output) DOUBLE PRECISION array, dimension (N) C On entry, if XINIT = 'G', this array must contain the C vector of initial variables x to be optimized. C If XINIT = 'R', this array need not be set before entry, C and random values will be used to initialize x. C On exit, if INFO = 0, this array contains the vector of C values that (approximately) minimize the sum of squares of C error functions. The values returned in IWARN and C DWORK(1:4) give details on the iterative process. C C DIAG (input/output) DOUBLE PRECISION array, dimension (N) C On entry, if SCALE = 'S', this array must contain some C positive entries that serve as multiplicative scale C factors for the variables x. DIAG(I) > 0, I = 1,...,N. C If SCALE = 'I', DIAG is internally set. C On exit, this array contains the scale factors used C (or finally used, if SCALE = 'I'). C C NFEV (output) INTEGER C The number of calls to FCN with IFLAG = 1. If FCN is C properly implemented, this includes the function C evaluations needed for finite difference approximation C of the Jacobian. C C NJEV (output) INTEGER C The number of calls to FCN with IFLAG = 2. C C Tolerances C C FTOL DOUBLE PRECISION C If FTOL >= 0, the tolerance which measures the relative C error desired in the sum of squares. Termination occurs C when both the actual and predicted relative reductions in C the sum of squares are at most FTOL. If the user sets C FTOL < 0, then SQRT(EPS) is used instead FTOL, where C EPS is the machine precision (see LAPACK Library routine C DLAMCH). C C XTOL DOUBLE PRECISION C If XTOL >= 0, the tolerance which measures the relative C error desired in the approximate solution. Termination C occurs when the relative error between two consecutive C iterates is at most XTOL. If the user sets XTOL < 0, C then SQRT(EPS) is used instead XTOL. C C GTOL DOUBLE PRECISION C If GTOL >= 0, the tolerance which measures the C orthogonality desired between the function vector e and C the columns of the Jacobian J. Termination occurs when C the cosine of the angle between e and any column of the C Jacobian J is at most GTOL in absolute value. If the user C sets GTOL < 0, then EPS is used instead GTOL. C C TOL DOUBLE PRECISION C If COND = 'E', the tolerance to be used for finding the C ranks of the matrices of linear systems to be solved. If C the user sets TOL > 0, then the given value of TOL is used C as a lower bound for the reciprocal condition number; a C (sub)matrix whose estimated condition number is less than C 1/TOL is considered to be of full rank. If the user sets C TOL <= 0, then an implicitly computed, default tolerance, C defined by TOLDEF = N*EPS, is used instead. C This parameter is not relevant if COND = 'N'. C C Workspace C C IWORK INTEGER array, dimension (N+r), where r is the number C of diagonal blocks R_k in R (see description of LMPARM). C On output, if INFO = 0, the first N entries of this array C define a permutation matrix P such that J*P = Q*R, where C J is the final calculated Jacobian, Q is an orthogonal C matrix (not stored), and R is upper triangular with C diagonal elements of nonincreasing magnitude (possibly C for each block column of J). Column j of P is column C IWORK(j) of the identity matrix. If INFO = 0, the entries C N+1:N+r of this array contain the ranks of the final C submatrices S_k (see description of LMPARM). C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK, DWORK(2) returns the residual error norm (the C sum of squares), DWORK(3) returns the number of iterations C performed, and DWORK(4) returns the final Levenberg C factor. If INFO = 0, N > 0, and IWARN >= 0, the elements C DWORK(5) to DWORK(4+M) contain the final matrix-vector C product Z*Q'*e, and the elements DWORK(5+M) to C DWORK(4+M+N*NC) contain the (compressed) representation of C final upper triangular matrices R and S (if IWARN <> 4). C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= max( 4, M + max( size(J) + C max( DW( FCN|IFLAG = 1 ), C DW( FCN|IFLAG = 2 ), C DW( QRFACT ) + N ), C N*NC + N + C max( M + DW( FCN|IFLAG = 1 ), C N + DW( LMPARM ) ) ) ), C where size(J) is the size of the Jacobian (provided by FCN C in IPAR(1), for IFLAG = 3), and DW( f ) is the workspace C needed by the routine f, where f is FCN, QRFACT, or LMPARM C (provided by FCN in IPAR(2:5), for IFLAG = 3). C C Warning Indicator C C IWARN INTEGER C < 0: the user set IFLAG = IWARN in the subroutine FCN; C = 1: both actual and predicted relative reductions in C the sum of squares are at most FTOL; C = 2: relative error between two consecutive iterates is C at most XTOL; C = 3: conditions for IWARN = 1 and IWARN = 2 both hold; C = 4: the cosine of the angle between e and any column of C the Jacobian is at most GTOL in absolute value; C = 5: the number of iterations has reached ITMAX without C satisfying any convergence condition; C = 6: FTOL is too small: no further reduction in the sum C of squares is possible; C = 7: XTOL is too small: no further improvement in the C approximate solution x is possible; C = 8: GTOL is too small: e is orthogonal to the columns of C the Jacobian to machine precision. C In all these cases, DWORK(1:4) are set as described above. 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: user-defined routine FCN returned with INFO <> 0 C for IFLAG = 1; C = 2: user-defined routine FCN returned with INFO <> 0 C for IFLAG = 2; C = 3: user-defined routine QRFACT returned with INFO <> 0; C = 4: user-defined routine LMPARM returned with INFO <> 0. C C METHOD C C If XINIT = 'R', the initial value for x is set to a vector of C pseudo-random values uniformly distributed in (-1,1). C C The Levenberg-Marquardt algorithm (described in [1,3]) is used for C optimizing the variables x. This algorithm needs the Jacobian C matrix J, which is provided by the subroutine FCN. A trust region C method is used. The algorithm tries to update x by the formula C C x = x - p, C C using an approximate solution of the system of linear equations C C (J'*J + PAR*D*D)*p = J'*e, C C with e the error function vector, and D a diagonal nonsingular C matrix, where either PAR = 0 and C C ( norm( D*x ) - DELTA ) <= 0.1*DELTA , C C or PAR > 0 and C C ABS( norm( D*x ) - DELTA ) <= 0.1*DELTA . C C DELTA is the radius of the trust region. If the Gauss-Newton C direction is not acceptable, then an iterative algorithm obtains C improved lower and upper bounds for the Levenberg-Marquardt C parameter PAR. Only a few iterations are generally needed for C convergence of the algorithm. The trust region radius DELTA C and the Levenberg factor PAR are updated based on the ratio C between the actual and predicted reduction in the sum of squares. C C REFERENCES C C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. C User's Guide for MINPACK-1. C Applied Math. Division, Argonne National Laboratory, Argonne, C Illinois, Report ANL-80-74, 1980. C C [2] Golub, G.H. and van Loan, C.F. C Matrix Computations. Third Edition. C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, C 1996. C C [3] More, J.J. C The Levenberg-Marquardt algorithm: implementation and theory. C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg C and New York, pp. 105-116, 1978. C C NUMERICAL ASPECTS C C The Levenberg-Marquardt algorithm described in [3] is scaling C invariant and globally convergent to (maybe local) minima. C The convergence rate near a local minimum is quadratic, if the C Jacobian is computed analytically, and linear, if the Jacobian C is computed numerically. C C FURTHER COMMENTS C C This routine is a more general version of the subroutines LMDER C and LMDER1 from the MINPACK package [1], which enables to exploit C the structure of the problem, and optionally use condition C estimation. Unstructured problems could be solved as well. C C Template SLICOT Library implementations for FCN, QRFACT and C LMPARM routines are: C MD03BF, MD03BA, and MD03BB, respectively, for standard problems; C NF01BF, NF01BS, and NF01BP, respectively, for optimizing the C parameters of Wiener systems (structured problems). C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. C C REVISIONS C C V. Sima, Feb. 15, 2004. C C KEYWORDS C C Least-squares approximation, Levenberg-Marquardt algorithm, C matrix operations, optimization. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, FOUR, P1, P5, P25, P75, P0001 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0, $ P1 = 1.0D-1, P5 = 5.0D-1, P25 = 2.5D-1, $ P75 = 7.5D-1, P0001 = 1.0D-4 ) C .. Scalar Arguments .. CHARACTER COND, SCALE, XINIT INTEGER INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LDWORK, $ LIPAR, M, N, NFEV, NJEV, NPRINT DOUBLE PRECISION FACTOR, FTOL, GTOL, TOL, XTOL C .. Array Arguments .. INTEGER IPAR(*), IWORK(*) DOUBLE PRECISION DIAG(*), DPAR1(*), DPAR2(*), DWORK(*), X(*) C .. Local Scalars .. LOGICAL BADSCL, INIT, ISCAL, SSCAL INTEGER E, IFLAG, INFOL, ITER, IW1, IW2, IW3, J, JAC, $ JW1, JW2, JWORK, L, LDJ, LDJSAV, LFCN1, LFCN2, $ LLMP, LQRF, NC, NFEVL, SIZEJ, WRKOPT DOUBLE PRECISION ACTRED, DELTA, DIRDER, EPSMCH, FNORM, FNORM1, $ FTDEF, GNORM, GTDEF, PAR, PNORM, PRERED, RATIO, $ TEMP, TEMP1, TEMP2, TOLDEF, XNORM, XTDEF C .. Local Arrays .. INTEGER SEED(4) C .. External Functions .. DOUBLE PRECISION DLAMCH, DNRM2 LOGICAL LSAME EXTERNAL DLAMCH, DNRM2, LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLARNV, FCN, LMPARM, QRFACT, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD, SQRT C .. C .. Executable Statements .. C C Check the scalar input parameters. C INIT = LSAME( XINIT, 'R' ) ISCAL = LSAME( SCALE, 'I' ) SSCAL = LSAME( SCALE, 'S' ) INFO = 0 IWARN = 0 IF( .NOT.( INIT .OR. LSAME( XINIT, 'G' ) ) ) THEN INFO = -1 ELSEIF( .NOT.( ISCAL .OR. SSCAL ) ) THEN INFO = -2 ELSEIF( .NOT.( LSAME( COND, 'E' ) .OR. LSAME( COND, 'N' ) ) ) THEN INFO = -3 ELSEIF( M.LT.0 ) THEN INFO = -7 ELSEIF( N.LT.0 .OR. N.GT.M ) THEN INFO = -8 ELSEIF( ITMAX.LT.0 ) THEN INFO = -9 ELSEIF( FACTOR.LE.ZERO ) THEN INFO = -10 ELSEIF( LIPAR.LT.5 ) THEN INFO = -13 ELSEIF( LDPAR1.LT.0 ) THEN INFO = -15 ELSEIF( LDPAR2.LT.0 ) THEN INFO = -17 ELSEIF ( LDWORK.LT.4 ) THEN INFO = -28 ELSEIF ( SSCAL ) THEN BADSCL = .FALSE. C DO 10 J = 1, N BADSCL = BADSCL .OR. DIAG(J).LE.ZERO 10 CONTINUE C IF ( BADSCL ) $ INFO = -19 END IF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MD03BD', -INFO ) RETURN ENDIF C C Quick return if possible. C NFEV = 0 NJEV = 0 IF ( N.EQ.0 ) THEN DWORK(1) = FOUR DWORK(2) = ZERO DWORK(3) = ZERO DWORK(4) = ZERO RETURN END IF C C Call FCN to get the size of the array J, for storing the Jacobian C matrix, the leading dimension LDJ and the workspace required C by FCN for IFLAG = 1 and IFLAG = 2, QRFACT and LMPARM. The C entries DWORK(1:4) should not be modified by the special call of C FCN below, if XINIT = 'R' and the values in DWORK(1:4) are C explicitly desired for initialization of the random number C generator. C IFLAG = 3 IW1 = IPAR(1) IW2 = IPAR(2) IW3 = IPAR(3) JW1 = IPAR(4) JW2 = IPAR(5) C CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, $ X, NFEVL, DWORK, DWORK, LDJSAV, DWORK, LDWORK, INFOL ) SIZEJ = IPAR(1) LFCN1 = IPAR(2) LFCN2 = IPAR(3) LQRF = IPAR(4) LLMP = IPAR(5) IF ( LDJSAV.GT.0 ) THEN NC = SIZEJ/LDJSAV ELSE NC = SIZEJ END IF C IPAR(1) = IW1 IPAR(2) = IW2 IPAR(3) = IW3 IPAR(4) = JW1 IPAR(5) = JW2 C C Check the workspace length. C E = 1 JAC = E + M JW1 = JAC + SIZEJ JW2 = JW1 + N IW1 = JAC + N*NC IW2 = IW1 + N IW3 = IW2 + N JWORK = IW2 + M C L = MAX( 4, M + MAX( SIZEJ + MAX( LFCN1, LFCN2, N + LQRF ), $ N*NC + N + MAX( M + LFCN1, N + LLMP ) ) ) IF ( LDWORK.LT.L ) THEN INFO = -28 CALL XERBLA( 'MD03BD', -INFO ) RETURN ENDIF C C Set default tolerances. EPSMCH is the machine precision. C EPSMCH = DLAMCH( 'Epsilon' ) FTDEF = FTOL XTDEF = XTOL GTDEF = GTOL TOLDEF = TOL IF ( MIN( FTDEF, XTDEF, GTDEF, TOLDEF ).LE.ZERO ) THEN IF ( FTDEF.LT.ZERO ) $ FTDEF = SQRT( EPSMCH ) IF ( XTDEF.LT.ZERO ) $ XTDEF = SQRT( EPSMCH ) IF ( GTDEF.LT.ZERO ) $ GTDEF = EPSMCH IF ( TOLDEF.LE.ZERO ) $ TOLDEF = DBLE( N )*EPSMCH ENDIF WRKOPT = 1 C C Initialization. C IF ( INIT ) THEN C C SEED is the initial state of the random number generator. C SEED(4) must be odd. C SEED(1) = MOD( INT( DWORK(1) ), 4096 ) SEED(2) = MOD( INT( DWORK(2) ), 4096 ) SEED(3) = MOD( INT( DWORK(3) ), 4096 ) SEED(4) = MOD( 2*INT( DWORK(4) ) + 1, 4096 ) CALL DLARNV( 2, SEED, N, X ) ENDIF C C Initialize Levenberg-Marquardt parameter and iteration counter. C PAR = ZERO ITER = 1 C C Evaluate the function at the starting point C and calculate its norm. C Workspace: need: M + SIZEJ + LFCN1; C prefer: larger. C IFLAG = 1 CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, $ X, NFEVL, DWORK(E), DWORK(JAC), LDJ, DWORK(JW1), $ LDWORK-JW1+1, INFOL ) C IF ( INFOL.NE.0 ) THEN INFO = 1 RETURN END IF WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) NFEV = 1 FNORM = DNRM2( M, DWORK(E), 1 ) IF ( IFLAG.LT.0 .OR. FNORM.EQ.ZERO ) $ GO TO 90 C C Beginning of the outer loop. C 20 CONTINUE C C Calculate the Jacobian matrix. C Workspace: need: M + SIZEJ + LFCN2; C prefer: larger. C LDJ = LDJSAV IFLAG = 2 CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEVL, DWORK(E), DWORK(JAC), LDJ, $ DWORK(JW1), LDWORK-JW1+1, INFOL ) C IF ( INFOL.NE.0 ) THEN INFO = 2 RETURN END IF IF ( ITER.EQ.1 ) $ WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) IF ( NFEVL.GT.0 ) $ NFEV = NFEV + NFEVL NJEV = NJEV + 1 IF ( IFLAG.LT.0 ) $ GO TO 90 C C If requested, call FCN to enable printing of iterates. C IF ( NPRINT.GT.0 ) THEN IFLAG = 0 IF ( MOD( ITER-1, NPRINT ).EQ.0 ) THEN CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, $ DWORK(JW1), LDWORK-JW1+1, INFOL ) C IF ( IFLAG.LT.0 ) $ GO TO 90 END IF END IF C C Compute the QR factorization of the Jacobian. C Workspace: need: M + SIZEJ + N + LQRF; C prefer: larger. C CALL QRFACT( N, IPAR, LIPAR, FNORM, DWORK(JAC), LDJ, DWORK(E), $ DWORK(JW1), GNORM, IWORK, DWORK(JW2), $ LDWORK-JW2+1, INFOL ) IF ( INFOL.NE.0 ) THEN INFO = 3 RETURN END IF C C On the first iteration and if SCALE = 'I', scale according C to the norms of the columns of the initial Jacobian. C IF ( ITER.EQ.1 ) THEN WRKOPT = MAX( WRKOPT, INT( DWORK(JW2) ) + JW2 - 1 ) IF ( ISCAL ) THEN C DO 30 J = 1, N DIAG(J) = DWORK(JW1+J-1) IF ( DIAG(J).EQ.ZERO ) $ DIAG(J) = ONE 30 CONTINUE C END IF C C On the first iteration, calculate the norm of the scaled C x and initialize the step bound DELTA. C DO 40 J = 1, N DWORK(IW1+J-1) = DIAG(J)*X(J) 40 CONTINUE C XNORM = DNRM2( N, DWORK(IW1), 1 ) DELTA = FACTOR*XNORM IF ( DELTA.EQ.ZERO ) $ DELTA = FACTOR ELSE C C Rescale if necessary. C IF ( ISCAL ) THEN C DO 50 J = 1, N DIAG(J) = MAX( DIAG(J), DWORK(JW1+J-1) ) 50 CONTINUE C END IF END IF C C Test for convergence of the gradient norm. C IF ( GNORM.LE.GTDEF ) $ IWARN = 4 IF ( IWARN.NE.0 ) $ GO TO 90 C C Beginning of the inner loop. C 60 CONTINUE C C Determine the Levenberg-Marquardt parameter and the C direction p, and compute -R*P'*p. C Workspace: need: M + N*NC + 2*N + LLMP; C prefer: larger. C CALL LMPARM( COND, N, IPAR, LIPAR, DWORK(JAC), LDJ, $ IWORK, DIAG, DWORK(E), DELTA, PAR, IWORK(N+1), $ DWORK(IW1), DWORK(IW2), TOLDEF, DWORK(IW3), $ LDWORK-IW3+1, INFOL ) IF ( INFOL.NE.0 ) THEN INFO = 4 RETURN END IF IF ( ITER.EQ.1 ) $ WRKOPT = MAX( WRKOPT, INT( DWORK(IW3) ) + IW3 - 1 ) C TEMP1 = DNRM2( N, DWORK(IW2), 1 )/FNORM C C Store the direction p and x - p. C DO 70 J = 0, N - 1 DWORK(IW2+J) = DIAG(J+1)*DWORK(IW1+J) DWORK(IW1+J) = X(J+1) - DWORK(IW1+J) 70 CONTINUE C C Compute the norm of scaled p and the scaled predicted C reduction and the scaled directional derivative. C PNORM = DNRM2( N, DWORK(IW2), 1 ) TEMP2 = ( SQRT( PAR )*PNORM )/FNORM PRERED = TEMP1**2 + TEMP2**2/P5 DIRDER = -( TEMP1**2 + TEMP2**2 ) C C On the first iteration, adjust the initial step bound. C IF ( ITER.EQ.1 ) $ DELTA = MIN( DELTA, PNORM ) C C Evaluate the function at x - p and calculate its norm. C Workspace: need: 2*M + N*NC + N + LFCN1; C prefer: larger. C IFLAG = 1 CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, DWORK(IW1), NFEVL, DWORK(IW2), DWORK(JAC), $ LDJ, DWORK(JWORK), LDWORK-JWORK+1, INFOL ) IF ( INFOL.NE.0 ) THEN INFO = 1 RETURN END IF C NFEV = NFEV + 1 IF ( IFLAG.LT.0 ) $ GO TO 90 FNORM1 = DNRM2( M, DWORK(IW2), 1 ) C C Compute the scaled actual reduction. C ACTRED = -ONE IF ( P1*FNORM1.LT.FNORM ) $ ACTRED = ONE - ( FNORM1/FNORM )**2 C C Compute the ratio of the actual to the predicted reduction. C RATIO = ZERO IF ( PRERED.NE.ZERO ) $ RATIO = ACTRED/PRERED C C Update the step bound. C IF ( RATIO.LE.P25 ) THEN IF ( ACTRED.GE.ZERO ) THEN TEMP = P5 ELSE TEMP = P5*DIRDER/( DIRDER + P5*ACTRED ) END IF IF ( P1*FNORM1.GE.FNORM .OR. TEMP.LT.P1 ) $ TEMP = P1 DELTA = TEMP*MIN( DELTA, PNORM/P1 ) PAR = PAR/TEMP ELSE IF ( PAR.EQ.ZERO .OR. RATIO.GE.P75 ) THEN DELTA = PNORM/P5 PAR = P5*PAR END IF END IF C C Test for successful iteration. C IF ( RATIO.GE.P0001 ) THEN C C Successful iteration. Update x, e, and their norms. C DO 80 J = 1, N X(J) = DWORK(IW1+J-1) DWORK(IW1+J-1) = DIAG(J)*X(J) 80 CONTINUE C CALL DCOPY( M, DWORK(IW2), 1, DWORK(E), 1 ) XNORM = DNRM2( N, DWORK(IW1), 1 ) FNORM = FNORM1 ITER = ITER + 1 END IF C C Tests for convergence. C IF ( ABS( ACTRED ).LE.FTDEF .AND. PRERED.LE.FTDEF .AND. $ P5*RATIO.LE.ONE ) $ IWARN = 1 IF ( DELTA.LE.XTDEF*XNORM ) $ IWARN = 2 IF ( ABS( ACTRED ).LE.FTDEF .AND. PRERED.LE.FTDEF .AND. $ P5*RATIO.LE.ONE .AND. IWARN.EQ.2 ) $ IWARN = 3 IF ( IWARN.NE.0 ) $ GO TO 90 C C Tests for termination and stringent tolerances. C IF ( ITER.GE.ITMAX ) $ IWARN = 5 IF ( ABS( ACTRED ).LE.EPSMCH .AND. PRERED.LE.EPSMCH .AND. $ P5*RATIO.LE.ONE ) $ IWARN = 6 IF ( DELTA.LE.EPSMCH*XNORM ) $ IWARN = 7 IF ( GNORM.LE.EPSMCH ) $ IWARN = 8 IF ( IWARN.NE.0 ) $ GO TO 90 C C End of the inner loop. Repeat if unsuccessful iteration. C IF ( RATIO.LT.P0001 ) GO TO 60 C C End of the outer loop. C GO TO 20 C 90 CONTINUE C C Termination, either normal or user imposed. C Note that DWORK(JAC) normally contains the results returned by C QRFACT and LMPARM (the compressed R and S factors). C IF ( IFLAG.LT.0 ) $ IWARN = IFLAG IF ( NPRINT.GT.0 ) THEN IFLAG = 0 CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, $ DWORK(JWORK), LDWORK-JWORK+1, INFOL ) IF ( IFLAG.LT.0 ) $ IWARN = IFLAG END IF C IF ( IWARN.GE.0 ) THEN DO 100 J = M + N*NC, 1, -1 DWORK(4+J) = DWORK(J) 100 CONTINUE END IF DWORK(1) = WRKOPT DWORK(2) = FNORM DWORK(3) = ITER DWORK(4) = PAR C RETURN C *** Last line of MD03BD *** END control-4.1.2/src/slicot/src/PaxHeaders/AB09AD.f0000644000000000000000000000013215012430707016135 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB09AD.f0000644000175000017500000003030615012430707017333 0ustar00lilgelilge00000000000000 SUBROUTINE AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA, $ B, LDB, C, LDC, HSV, TOL, IWORK, DWORK, LDWORK, $ IWARN, INFO ) C C PURPOSE C C To compute a reduced order model (Ar,Br,Cr) for a stable original C state-space representation (A,B,C) by using either the square-root C or the balancing-free square-root Balance & Truncate (B & T) C model reduction method. 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 JOB CHARACTER*1 C Specifies the model reduction approach to be used C as follows: C = 'B': use the square-root Balance & Truncate method; C = 'N': use the balancing-free square-root C Balance & Truncate method. C C EQUIL CHARACTER*1 C Specifies whether the user wishes to preliminarily C equilibrate the triplet (A,B,C) as follows: C = 'S': perform equilibration (scaling); C = 'N': do not perform equilibration. C C ORDSEL CHARACTER*1 C Specifies the order selection method as follows: C = 'F': the resulting order NR is fixed; C = 'A': the resulting order NR is automatically determined C on basis of the given tolerance TOL. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, i.e. C the order of the 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 NR (input/output) INTEGER C On entry with ORDSEL = 'F', NR is the desired order of the C resulting reduced order system. 0 <= NR <= N. C On exit, if INFO = 0, NR is the order of the resulting C reduced order model. NR is set as follows: C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR C is the desired order on entry and NMIN is the order of a C minimal realization of the given system; NMIN is C determined as the number of Hankel singular values greater C than N*EPS*HNORM(A,B,C), where EPS is the machine C precision (see LAPACK Library Routine DLAMCH) and C HNORM(A,B,C) is the Hankel norm of the system (computed C in HSV(1)); C if ORDSEL = 'A', NR is equal to the number of Hankel C singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)). 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, if INFO = 0, the leading NR-by-NR part of this C array contains the state dynamics matrix Ar of the reduced C order system. 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 original input/state matrix B. C On exit, if INFO = 0, the leading NR-by-M part of this C array contains the input/state matrix Br of the reduced C order system. 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 original state/output matrix C. C On exit, if INFO = 0, the leading P-by-NR part of this C array contains the state/output matrix Cr of the reduced C order system. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C HSV (output) DOUBLE PRECISION array, dimension (N) C If INFO = 0, it contains the Hankel singular values of C the original system ordered decreasingly. HSV(1) is the C Hankel norm of the system. C C Tolerances C C TOL DOUBLE PRECISION C If ORDSEL = 'A', TOL contains the tolerance for C determining the order of reduced system. C For model reduction, the recommended value is C TOL = c*HNORM(A,B,C), where c is a constant in the C interval [0.00001,0.001], and HNORM(A,B,C) is the C Hankel-norm of the given system (computed in HSV(1)). C For computing a minimal realization, the recommended C value is TOL = N*EPS*HNORM(A,B,C), where EPS is the C machine precision (see LAPACK Library Routine DLAMCH). C This value is used by default if TOL <= 0 on entry. C If ORDSEL = 'F', the value of TOL is ignored. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C LIWORK = 0, if JOB = 'B'; C LIWORK = N, if JOB = 'N'. 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,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2). C For optimum performance LDWORK should be larger. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: with ORDSEL = 'F', the selected order NR is greater C than the order of a minimal realization of the C given system. In this case, the resulting NR is C set automatically to a value corresponding to the C order of a minimal realization of the system. 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 the real Schur form failed; C = 2: the state matrix A is not stable (if DICO = 'C') C or not convergent (if DICO = 'D'); C = 3: the computation of Hankel singular values failed. C C METHOD C C Let be the stable linear system C C d[x(t)] = Ax(t) + Bu(t) C y(t) = Cx(t) (1) C C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) C for a discrete-time system. The subroutine AB09AD determines for C the given system (1), the matrices of a reduced order system C C d[z(t)] = Ar*z(t) + Br*u(t) C yr(t) = Cr*z(t) (2) C C such that C C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], C C where G and Gr are transfer-function matrices of the systems C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the C infinity-norm of G. C C If JOB = 'B', the square-root Balance & Truncate method of [1] C is used and, for DICO = 'C', the resulting model is balanced. C By setting TOL <= 0, the routine can be used to compute balanced C minimal state-space realizations of stable systems. C C If JOB = 'N', the balancing-free square-root version of the C Balance & Truncate method [2] is used. C By setting TOL <= 0, the routine can be used to compute minimal C state-space realizations of stable systems. C C REFERENCES C C [1] Tombs M.S. and Postlethwaite I. C Truncated balanced realization of stable, non-minimal C state-space systems. C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. C C [2] Varga A. C Efficient minimal realization procedure based on balancing. C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), C Vol. 2, pp. 42-46. C C NUMERICAL ASPECTS C C The implemented methods rely on accuracy enhancing square-root or C balancing-free square-root techniques. C 3 C The algorithms require less than 30N floating point operations. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C March 1998. C Based on the RASP routines SRBT and SRBFT. C C REVISIONS C C May 2, 1998. C November 11, 1998, V. Sima, Research Institute for Informatics, C Bucharest. C C KEYWORDS C C Balancing, minimal state-space representation, model reduction, C multivariable system, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, C100 PARAMETER ( ONE = 1.0D0, C100 = 100.0D0 ) C .. Scalar Arguments .. CHARACTER DICO, EQUIL, JOB, ORDSEL INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NR, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) C .. Local Scalars .. LOGICAL FIXORD INTEGER IERR, KI, KR, KT, KTI, KW, NN DOUBLE PRECISION MAXRED, WRKOPT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL AB09AX, TB01ID, TB01WD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C .. Executable Statements .. C INFO = 0 IWARN = 0 FIXORD = LSAME( ORDSEL, 'F' ) C C Test the input scalar arguments. C IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN INFO = -1 ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN INFO = -2 ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. $ LSAME( EQUIL, 'N' ) ) ) THEN INFO = -3 ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) 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( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN INFO = -8 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -10 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -12 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -14 ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + $ ( N*( N + 1 ) )/2 ) ) THEN INFO = -19 END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB09AD', -INFO ) RETURN END IF C C Quick return if possible. C IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN NR = 0 DWORK(1) = ONE RETURN END IF C C Allocate working storage. C NN = N*N KT = 1 KR = KT + NN KI = KR + N KW = KI + N C IF( LSAME( EQUIL, 'S' ) ) THEN C C Scale simultaneously the matrices A, B and C: C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a C diagonal matrix. C MAXRED = C100 CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, $ DWORK, INFO ) END IF C C Reduce A to the real Schur form using an orthogonal similarity C transformation A <- T'*A*T and apply the transformation to C B and C: B <- T'*B and C <- C*T. C CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) IF( IERR.NE.0 ) THEN INFO = 1 RETURN END IF C WRKOPT = DWORK(KW) + DBLE( KW-1 ) KTI = KT + NN KW = KTI + NN C CALL AB09AX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, C, $ LDC, HSV, DWORK(KT), N, DWORK(KTI), N, TOL, IWORK, $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) C IF( IERR.NE.0 ) THEN INFO = IERR + 1 RETURN END IF C DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) C RETURN C *** Last line of AB09AD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02CD.f0000644000000000000000000000013215012430707016144 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02CD.f0000644000175000017500000005266315012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L, $ LDL, CS, LCS, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute the Cholesky factor and the generator and/or the C Cholesky factor of the inverse of a symmetric positive definite C (s.p.d.) block Toeplitz matrix T, defined by either its first C block row, or its first block column, depending on the routine C parameter TYPET. Transformation information is stored. C C ARGUMENTS C C Mode Parameters C C JOB CHARACTER*1 C Specifies the output of the routine, as follows: C = 'G': only computes the generator G of the inverse; C = 'R': computes the generator G of the inverse and the C Cholesky factor R of T, i.e., if TYPET = 'R', C then R'*R = T, and if TYPET = 'C', then R*R' = T; C = 'L': computes the generator G and the Cholesky factor L C of the inverse, i.e., if TYPET = 'R', then C L'*L = inv(T), and if TYPET = 'C', then C L*L' = inv(T); C = 'A': computes the generator G, the Cholesky factor L C of the inverse and the Cholesky factor R of T; C = 'O': only computes the Cholesky factor R of T. C C TYPET CHARACTER*1 C Specifies the type of T, as follows: C = 'R': T contains the first block row of an s.p.d. block C Toeplitz matrix; if demanded, the Cholesky factors C R and L are upper and lower triangular, C respectively, and G contains the transposed C generator of the inverse; C = 'C': T contains the first block column of an s.p.d. C block Toeplitz matrix; if demanded, the Cholesky C factors R and L are lower and upper triangular, C respectively, and G contains the generator of the C inverse. This choice results in a column oriented C algorithm which is usually faster. C Note: in the sequel, the notation x / y means that C x corresponds to TYPET = 'R' and y corresponds to C TYPET = 'C'. C C Input/Output Parameters C C K (input) INTEGER C The number of rows / columns in T, which should be equal C to the blocksize. K >= 0. C C N (input) INTEGER C The number of blocks in T. N >= 0. C C T (input/output) DOUBLE PRECISION array, dimension C (LDT,N*K) / (LDT,K) C On entry, the leading K-by-N*K / N*K-by-K part of this C array must contain the first block row / column of an C s.p.d. block Toeplitz matrix. C On exit, if INFO = 0, then the leading K-by-N*K / N*K-by-K C part of this array contains, in the first K-by-K block, C the upper / lower Cholesky factor of T(1:K,1:K), and in C the remaining part, the Householder transformations C applied during the process. C C LDT INTEGER C The leading dimension of the array T. C LDT >= MAX(1,K), if TYPET = 'R'; C LDT >= MAX(1,N*K), if TYPET = 'C'. C C G (output) DOUBLE PRECISION array, dimension C (LDG,N*K) / (LDG,2*K) C If INFO = 0 and JOB = 'G', 'R', 'L', or 'A', the leading C 2*K-by-N*K / N*K-by-2*K part of this array contains, in C the first K-by-K block of the second block row / column, C the lower right block of L (necessary for updating C factorizations in SLICOT Library routine MB02DD), and C in the remaining part, the generator of the inverse of T. C Actually, to obtain a generator one has to set C G(K+1:2*K, 1:K) = 0, if TYPET = 'R'; C G(1:K, K+1:2*K) = 0, if TYPET = 'C'. C C LDG INTEGER C The leading dimension of the array G. C LDG >= MAX(1,2*K), if TYPET = 'R' and C JOB = 'G', 'R', 'L', or 'A'; C LDG >= MAX(1,N*K), if TYPET = 'C' and C JOB = 'G', 'R', 'L', or 'A'; C LDG >= 1, if JOB = 'O'. C C R (output) DOUBLE PRECISION array, dimension (LDR,N*K) C If INFO = 0 and JOB = 'R', 'A', or 'O', then the leading C N*K-by-N*K part of this array contains the upper / lower C Cholesky factor of T. C The elements in the strictly lower / upper triangular part C are not referenced. C C LDR INTEGER C The leading dimension of the array R. C LDR >= MAX(1,N*K), if JOB = 'R', 'A', or 'O'; C LDR >= 1, if JOB = 'G', or 'L'. C C L (output) DOUBLE PRECISION array, dimension (LDL,N*K) C If INFO = 0 and JOB = 'L', or 'A', then the leading C N*K-by-N*K part of this array contains the lower / upper C Cholesky factor of the inverse of T. C The elements in the strictly upper / lower triangular part C are not referenced. C C LDL INTEGER C The leading dimension of the array L. C LDL >= MAX(1,N*K), if JOB = 'L', or 'A'; C LDL >= 1, if JOB = 'G', 'R', or 'O'. C C CS (output) DOUBLE PRECISION array, dimension (LCS) C If INFO = 0, then the leading 3*(N-1)*K part of this C array contains information about the hyperbolic rotations C and Householder transformations applied during the C process. This information is needed for updating the C factorizations in SLICOT Library routine MB02DD. C C LCS INTEGER C The length of the array CS. LCS >= 3*(N-1)*K. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -16, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1,(N-1)*K). 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: the reduction algorithm failed. The Toeplitz matrix C associated with T is not (numerically) positive C definite. C C METHOD C C Householder transformations and modified hyperbolic rotations C are used in the Schur algorithm [1], [2]. C C REFERENCES C C [1] Kailath, T. and Sayed, A. C Fast Reliable Algorithms for Matrices with Structure. C SIAM Publications, Philadelphia, 1999. C C [2] Kressner, D. and Van Dooren, P. C Factorizations and linear system solvers for matrices with C Toeplitz structure. C SLICOT Working Note 2000-2, 2000. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C 3 2 C The algorithm requires 0(K N ) floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, July 2000, C February 2004. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOB, TYPET INTEGER INFO, K, LCS, LDG, LDL, LDR, LDT, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*), $ T(LDT,*) C .. Local Scalars .. INTEGER I, IERR, MAXWRK, STARTI, STARTR, STARTT LOGICAL COMPG, COMPL, COMPR, ISROW C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLACPY, DLASET, DPOTRF, DTRSM, MB02CX, MB02CY, $ XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 COMPL = LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'A' ) COMPG = LSAME( JOB, 'G' ) .OR. LSAME( JOB, 'R' ) .OR. COMPL COMPR = LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) .OR. $ LSAME( JOB, 'O' ) ISROW = LSAME( TYPET, 'R' ) C C Check the scalar input parameters. C IF ( .NOT.( COMPG .OR. COMPR ) ) THEN INFO = -1 ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN INFO = -2 ELSE IF ( K.LT.0 ) THEN INFO = -3 ELSE IF ( N.LT.0 ) THEN INFO = -4 ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN INFO = -6 ELSE IF ( LDG.LT.1 .OR. $ ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K ) $ .OR. ( .NOT.ISROW .AND. LDG.LT.N*K ) ) ) ) THEN INFO = -8 ELSE IF ( LDR.LT.1 .OR. ( COMPR .AND. ( LDR.LT.N*K ) ) ) THEN INFO = -10 ELSE IF ( LDL.LT.1 .OR. ( COMPL .AND. ( LDL.LT.N*K ) ) ) THEN INFO = -12 ELSE IF ( LCS.LT.3*( N - 1 )*K ) THEN INFO = -14 ELSE IF ( LDWORK.LT.MAX( 1, ( N - 1 )*K ) ) THEN DWORK(1) = MAX( 1, ( N - 1 )*K ) INFO = -16 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02CD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( K, N ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C MAXWRK = 1 IF ( ISROW ) THEN C C T is the first block row of a block Toeplitz matrix. C Bring T to proper form by triangularizing its first block. C CALL DPOTRF( 'Upper', K, T, LDT, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C IF ( N.GT.1 ) $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) C C Initialize the output matrices. C IF ( COMPG ) THEN CALL DLASET( 'All', 2*K, N*K, ZERO, ZERO, G, LDG ) CALL DLASET( 'All', 1, K, ONE, ONE, G(K+1,1), LDG+1 ) CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, K, $ ONE, T, LDT, G(K+1,1), LDG ) IF ( N.GT.1 ) $ CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, G(K+1,K+1), $ LDG ) CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, G, LDG ) END IF C IF ( COMPL ) THEN CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, L, LDL ) END IF C IF ( COMPR ) THEN CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR ) END IF C C Processing the generator. C IF ( COMPG ) THEN C C Here we use G as working array for holding the generator. C T contains the second row of the generator. C G contains in its first block row the second row of the C inverse generator. C The second block row of G is partitioned as follows: C C [ First block of the inverse generator, ... C First row of the generator, ... C The rest of the blocks of the inverse generator ] C C The reason for the odd partitioning is that the first block C of the inverse generator will be thrown out at the end and C we want to avoid reordering. C C (N-1)*K locations of DWORK are used by SLICOT Library C routine MB02CY. C DO 10 I = 2, N STARTR = ( I - 1 )*K + 1 STARTI = ( N - I + 1 )*K + 1 STARTT = 3*( I - 2 )*K + 1 C C Transformations acting on the generator: C CALL MB02CX( 'Row', K, K, K, G(K+1,K+1), LDG, $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, $ LDWORK, IERR ) C IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) IF ( N.GT.I ) THEN CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, $ G(K+1,2*K+1), LDG, T(1,STARTR+K), LDT, $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, $ LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) END IF C IF ( COMPR ) THEN CALL DLACPY( 'Upper', K, (N-I+1)*K, G(K+1,K+1), LDG, $ R(STARTR,STARTR), LDR) END IF C C Transformations acting on the inverse generator: C CALL DLASET( 'All', K, K, ZERO, ZERO, G(K+1,STARTI), $ LDG ) CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1), $ LDG, G(1,STARTR), LDG, T(1,STARTR), LDT, $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K, $ G(K+1,STARTI), LDG, G, LDG, T(1,STARTR), $ LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C IF ( COMPL ) THEN CALL DLACPY( 'All', K, (I-1)*K, G(K+1,STARTI), LDG, $ L(STARTR,1), LDL ) CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, $ L(STARTR,(I-1)*K+1), LDL ) END IF 10 CONTINUE C ELSE C C Here R is used as working array for holding the generator. C Again, T contains the second row of the generator. C The current row of R contains the first row of the C generator. C IF ( N.GT.1 ) $ CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, R(K+1,K+1), $ LDR ) C DO 20 I = 2, N STARTR = ( I - 1 )*K + 1 STARTT = 3*( I - 2 )*K + 1 CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR, $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, $ LDWORK, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) IF ( N.GT.I ) THEN CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, $ R(STARTR,STARTR+K), LDR, T(1,STARTR+K), $ LDT, T(1,STARTR), LDT, CS(STARTT), 3*K, $ DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C CALL DLACPY( 'Upper', K, (N-I)*K, R(STARTR,STARTR), $ LDR, R(STARTR+K,STARTR+K), LDR ) END IF 20 CONTINUE C END IF C ELSE C C T is the first block column of a block Toeplitz matrix. C Bring T to proper form by triangularizing its first block. C CALL DPOTRF( 'Lower', K, T, LDT, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C IF ( N.GT.1 ) $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) C C Initialize the output matrices. C IF ( COMPG ) THEN CALL DLASET( 'All', N*K, 2*K, ZERO, ZERO, G, LDG ) CALL DLASET( 'All', 1, K, ONE, ONE, G(1,K+1), LDG+1 ) CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', K, K, $ ONE, T, LDT, G(1,K+1), LDG ) IF ( N.GT.1 ) $ CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, G(K+1,K+1), $ LDG ) CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, G, LDG ) END IF C IF ( COMPL ) THEN CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, L, LDL ) END IF C IF ( COMPR ) THEN CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR ) END IF C C Processing the generator. C IF ( COMPG ) THEN C C Here we use G as working array for holding the generator. C T contains the second column of the generator. C G contains in its first block column the second column of C the inverse generator. C The second block column of G is partitioned as follows: C C [ First block of the inverse generator; ... C First column of the generator; ... C The rest of the blocks of the inverse generator ] C C The reason for the odd partitioning is that the first block C of the inverse generator will be thrown out at the end and C we want to avoid reordering. C C (N-1)*K locations of DWORK are used by SLICOT Library C routine MB02CY. C DO 30 I = 2, N STARTR = ( I - 1 )*K + 1 STARTI = ( N - I + 1 )*K + 1 STARTT = 3*( I - 2 )*K + 1 C C Transformations acting on the generator: C CALL MB02CX( 'Column', K, K, K, G(K+1,K+1), LDG, $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, $ LDWORK, IERR ) C IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) IF ( N.GT.I ) THEN CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, $ K, G(2*K+1,K+1), LDG, T(STARTR+K,1), LDT, $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, $ LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) END IF C IF ( COMPR ) THEN CALL DLACPY( 'Lower', (N-I+1)*K, K, G(K+1,K+1), LDG, $ R(STARTR,STARTR), LDR) END IF C C Transformations acting on the inverse generator: C CALL DLASET( 'All', K, K, ZERO, ZERO, G(STARTI,K+1), $ LDG ) CALL MB02CY( 'Column', 'Triangular', K, K, K, K, $ G(1,K+1), LDG, G(STARTR,1), LDG, $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, $ LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K, $ G(STARTI,K+1), LDG, G, LDG, T(STARTR,1), $ LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C IF ( COMPL ) THEN CALL DLACPY( 'All', (I-1)*K, K, G(STARTI,K+1), LDG, $ L(1,STARTR), LDL ) CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, $ L((I-1)*K+1,STARTR), LDL ) END IF 30 CONTINUE C ELSE C C Here R is used as working array for holding the generator. C Again, T contains the second column of the generator. C The current column of R contains the first column of the C generator. C IF ( N.GT.1 ) $ CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, R(K+1,K+1), $ LDR ) C DO 40 I = 2, N STARTR = ( I - 1 )*K + 1 STARTT = 3*( I - 2 )*K + 1 CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR, $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, $ LDWORK, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) IF ( N.GT.I ) THEN CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, $ K, R(STARTR+K,STARTR), LDR, $ T(STARTR+K,1), LDT, T(STARTR,1), LDT, $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) C CALL DLACPY( 'Lower', (N-I)*K, K, R(STARTR,STARTR), $ LDR, R(STARTR+K,STARTR+K), LDR ) END IF 40 CONTINUE C END IF END IF C DWORK(1) = MAXWRK C RETURN C C *** Last line of MB02CD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB10JD.f0000644000000000000000000000013215012430707016160 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB10JD.f0000644000175000017500000002463215012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE SB10JD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, E, $ LDE, NSYS, DWORK, LDWORK, INFO ) C C PURPOSE C C To convert the descriptor state-space system C C E*dx/dt = A*x + B*u C y = C*x + D*u C C into regular state-space form C C dx/dt = Ad*x + Bd*u C y = Cd*x + Dd*u . C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the descriptor 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 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 matrix A of the descriptor system. C On exit, the leading NSYS-by-NSYS part of this array C contains the state matrix Ad of the converted system. C C LDA INTEGER C The leading dimension of the 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 matrix B of the descriptor system. C On exit, the leading NSYS-by-M part of this array C contains the input matrix Bd of the converted system. C C LDB INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) C On entry, the leading NP-by-N part of this array must C contain the output matrix C of the descriptor system. C On exit, the leading NP-by-NSYS part of this array C contains the output matrix Cd of the converted system. C C LDC INTEGER C The leading dimension of the array C. LDC >= max(1,NP). C C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) C On entry, the leading NP-by-M part of this array must C contain the matrix D of the descriptor system. C On exit, the leading NP-by-M part of this array contains C the matrix Dd of the converted system. C C LDD INTEGER C The leading dimension of the array D. LDD >= max(1,NP). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading N-by-N part of this array must C contain the matrix E of the descriptor system. C On exit, this array contains no useful information. C C LDE INTEGER C The leading dimension of the array E. LDE >= max(1,N). C C NSYS (output) INTEGER C The order of the converted state-space system. C C Workspace 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 >= max( 1, 2*N*N + 2*N + N*MAX( 5, N + M + NP ) ). C For good performance, LDWORK 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 iteration for computing singular value C decomposition did not converge. C C METHOD C C The routine performs the transformations described in [1]. C C REFERENCES C C [1] Chiang, R.Y. and Safonov, M.G. C Robust Control Toolbox User's Guide. C The MathWorks Inc., Natick, Mass., 1992. C C CONTRIBUTORS C C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1999. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, C Feb. 2001. C C KEYWORDS C C Descriptor systems, state-space models. 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, LDB, LDC, LDD, LDE, LDWORK, M, N, $ NP, NSYS C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), DWORK( * ), E( LDE, * ) C .. C .. Local Scalars .. INTEGER I, IA12, IA21, IB2, IC2, INFO2, IS, ISA, IU, $ IV, IWRK, J, K, LWA, LWAMAX, MINWRK, NS1 DOUBLE PRECISION EPS, SCALE, TOL C .. C .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH C .. C .. External Subroutines .. EXTERNAL DGEMM, DGESVD, DLACPY, DLASET, DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, SQRT C .. C .. Executable Statements .. C C Decode and Test input parameters. 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( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN INFO = -9 ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN INFO = -11 ELSE IF( LDE.LT.MAX( 1, N ) ) THEN INFO = -13 END IF C C Compute workspace. C MINWRK = MAX( 1, 2*N*( N + 1 ) + N*MAX( 5, N + M + NP ) ) IF( LDWORK.LT.MINWRK ) THEN INFO = -16 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB10JD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN NSYS = 0 DWORK( 1 ) = ONE RETURN END IF C C Set tol. C EPS = DLAMCH( 'Epsilon' ) TOL = SQRT( EPS ) C C Workspace usage. C IS = 0 IU = IS + N IV = IU + N*N C IWRK = IV + N*N C C Compute the SVD of E. C Additional workspace: need 5*N; prefer larger. C CALL DGESVD( 'S', 'S', N, N, E, LDE, DWORK( IS+1 ), DWORK( IU+1 ), $ N, DWORK( IV+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK, $ INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 1 RETURN END IF LWAMAX = MAX( MINWRK, INT( DWORK( IWRK+1 ) + IWRK ) ) C C Determine the rank of E. C NS1 = 0 DO 10 I = 1, N IF( DWORK( IS+I ).GT.TOL ) NS1 = NS1 + 1 10 CONTINUE IF( NS1.GT.0 ) THEN C C Transform A. C Additional workspace: need N*max(N,M,NP). C CALL DGEMM( 'T', 'N', N, N, N, ONE, DWORK( IU+1 ), N, A, LDA, $ ZERO, DWORK( IWRK+1 ), N ) CALL DGEMM( 'N', 'T', N, N, N, ONE, DWORK( IWRK+1 ), N, $ DWORK( IV+1 ), N, ZERO, A, LDA ) C C Transform B. C CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IWRK+1 ), N ) CALL DGEMM( 'T', 'N', N, M, N, ONE, DWORK( IU+1 ), N, $ DWORK( IWRK+1 ), N, ZERO, B, LDB ) C C Transform C. C CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWRK+1 ), NP ) CALL DGEMM( 'N', 'T', NP, N, N, ONE, DWORK( IWRK+1 ), NP, $ DWORK( IV+1 ), N, ZERO, C, LDC ) C K = N - NS1 IF( K.GT.0 ) THEN ISA = IU + K*K IV = ISA + K IWRK = IV + K*MAX( K, NS1 ) C C Compute the SVD of A22. C Additional workspace: need 5*K; prefer larger. C CALL DGESVD( 'S', 'S', K, K, A( NS1+1, NS1+1 ), LDA, $ DWORK( ISA+1 ), DWORK( IU+1 ), K, $ DWORK( IV+1 ), K, DWORK( IWRK+1 ), LDWORK-IWRK, $ INFO2 ) IF( INFO2.NE.0 ) THEN INFO = 1 RETURN END IF IA12 = IWRK IB2 = IA12 + NS1*K IC2 = IB2 + K*M C LWA = INT( DWORK( IWRK+1 ) ) + IWRK LWAMAX = MAX( LWA, LWAMAX, IC2 + K*NP ) C C Compute the transformed A12. C CALL DGEMM( 'N', 'T', NS1, K, K, ONE, A( 1, NS1+1 ), LDA, $ DWORK( IV+1 ), K, ZERO, DWORK( IA12+1 ), NS1 ) C C Compute CC2. C CALL DGEMM( 'N', 'T', NP, K, K, ONE, C( 1, NS1+1 ), LDC, $ DWORK( IV+1 ), K, ZERO, DWORK( IC2+1 ), NP ) C C Compute the transformed A21. C IA21 = IV CALL DGEMM( 'T', 'N', K, NS1, K, ONE, DWORK( IU+1 ), K, $ A( NS1+1, 1 ), LDA, ZERO, DWORK( IA21+1 ), K ) C C Compute BB2. C CALL DGEMM( 'T', 'N', K, M, K, ONE, DWORK( IU+1 ), K, $ B( NS1+1, 1 ), LDB, ZERO, DWORK( IB2+1 ), K ) C C Compute A12*pinv(A22) and CC2*pinv(A22). C DO 20 J = 1, K SCALE = ZERO IF( DWORK( ISA+J ).GT.TOL ) SCALE = ONE/DWORK( ISA+J ) CALL DSCAL( NS1, SCALE, DWORK( IA12+(J-1)*NS1+1 ), 1 ) CALL DSCAL( NP, SCALE, DWORK( IC2+(J-1)*NP+1 ), 1 ) 20 CONTINUE C C Compute Ad. C CALL DGEMM( 'N', 'N', NS1, NS1, K, -ONE, DWORK( IA12+1 ), $ NS1, DWORK( IA21+1 ), K, ONE, A, LDA ) C C Compute Bd. C CALL DGEMM( 'N', 'N', NS1, M, K, -ONE, DWORK( IA12+1 ), NS1, $ DWORK( IB2+1 ), K, ONE, B, LDB ) C C Compute Cd. C CALL DGEMM( 'N', 'N', NP, NS1, K, -ONE, DWORK( IC2+1 ), NP, $ DWORK( IA21+1 ), K, ONE, C, LDC ) C C Compute Dd. C CALL DGEMM( 'N', 'N', NP, M, K, -ONE, DWORK( IC2+1 ), NP, $ DWORK( IB2+1 ), K, ONE, D, LDD ) END IF DO 30 I = 1, NS1 SCALE = ONE/SQRT( DWORK( IS+I ) ) CALL DSCAL( NS1, SCALE, A( I, 1 ), LDA ) CALL DSCAL( M, SCALE, B( I, 1 ), LDB ) 30 CONTINUE DO 40 J = 1, NS1 SCALE = ONE/SQRT( DWORK( IS+J ) ) CALL DSCAL( NS1, SCALE, A( 1, J ), 1 ) CALL DSCAL( NP, SCALE, C( 1, J ), 1 ) 40 CONTINUE NSYS = NS1 ELSE CALL DLASET( 'F', N, N, ZERO, -ONE/EPS, A, LDA ) CALL DLASET( 'F', N, M, ZERO, ZERO, B, LDB ) CALL DLASET( 'F', NP, N, ZERO, ZERO, C, LDC ) NSYS = N END IF DWORK( 1 ) = DBLE( LWAMAX ) RETURN C *** Last line of SB10JD *** END control-4.1.2/src/slicot/src/PaxHeaders/TB01VY.f0000644000000000000000000000013215012430707016222 xustar0030 mtime=1747595719.985100819 30 atime=1747595719.985100819 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/TB01VY.f0000644000175000017500000002250715012430707017424 0ustar00lilgelilge00000000000000 SUBROUTINE TB01VY( APPLY, N, M, L, THETA, LTHETA, A, LDA, B, LDB, $ C, LDC, D, LDD, X0, DWORK, LDWORK, INFO ) C C PURPOSE C C To convert the linear discrete-time system given as its output C normal form [1], with parameter vector THETA, into the state-space C representation (A, B, C, D), with the initial state x0. C C ARGUMENTS C C Mode Parameters C C APPLY CHARACTER*1 C Specifies whether or not the parameter vector should be C transformed using a bijective mapping, as follows: C = 'A' : apply the bijective mapping to the N vectors in C THETA corresponding to the matrices A and C; C = 'N' : do not apply the bijective mapping. C The transformation performed when APPLY = 'A' allows C to get rid of the constraints norm(THETAi) < 1, i = 1:N. C A call of the SLICOT Library routine TB01VD associated to C a call of TB01VY must use the same value of APPLY. 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 number of system inputs. M >= 0. C C L (input) INTEGER C The number of system outputs. L >= 0. C C THETA (input) DOUBLE PRECISION array, dimension (LTHETA) C The leading N*(L+M+1)+L*M part of this array must contain C the parameter vector that defines a system (A, B, C, D), C with the initial state x0. The parameters are: C C THETA(1:N*L) : parameters for A, C; C THETA(N*L+1:N*(L+M)) : parameters for B; C THETA(N*(L+M)+1:N*(L+M)+L*M) : parameters for D; C THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0. C C LTHETA INTEGER C The length of array THETA. LTHETA >= N*(L+M+1)+L*M. C C A (output) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array contains the system C state matrix corresponding to the output normal form with C parameter vector THETA. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,N). C C B (output) DOUBLE PRECISION array, dimension (LDB,M) C The leading N-by-M part of this array contains the system C input matrix corresponding to the output normal form with C parameter vector THETA. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C C (output) DOUBLE PRECISION array, dimension (LDC,N) C The leading L-by-N part of this array contains the system C output matrix corresponding to the output normal form with C parameter vector THETA. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,L). C C D (output) DOUBLE PRECISION array, dimension (LDD,M) C The leading L-by-M part of this array contains the system C input/output matrix corresponding to the output normal C form with parameter vector THETA. C C LDD INTEGER C The leading dimension of array D. LDD >= MAX(1,L). C C X0 (output) DOUBLE PRECISION array, dimension (N) C This array contains the initial state of the system, x0, C corresponding to the output normal form with parameter C vector THETA. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= N*(N+L+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 parameters characterizing A and C are used to build N C orthogonal transformations, which are then applied to recover C these matrices. C C CONTRIBUTORS C C A. Riedel, R. Schneider, Chemnitz University of Technology, C Oct. 2000, during a stay at University of Twente, NL. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, C Feb. 2002, Feb. 2004. C C KEYWORDS C C Asymptotically stable, output normal form, parameter estimation, C similarity transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 ) C .. Scalar Arguments .. CHARACTER APPLY INTEGER INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M, $ N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), THETA(*), X0(*) C .. Local Scalars .. DOUBLE PRECISION FACTOR, RI, TI, TOBYPI INTEGER CA, JWORK, I, IN, J, K, LDCA LOGICAL LAPPLY C .. External Functions .. EXTERNAL DNRM2, LSAME DOUBLE PRECISION DNRM2 LOGICAL LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLACPY, DSCAL, $ XERBLA C .. Intrinsic Functions .. INTRINSIC ATAN, MAX, SQRT C .. C .. Executable Statements .. C C Check the scalar input parameters. C LAPPLY = LSAME( APPLY, 'A' ) C INFO = 0 IF ( .NOT.( LAPPLY .OR. LSAME( APPLY, 'N' ) ) ) THEN INFO = -1 ELSEIF ( N.LT.0 ) THEN INFO = -2 ELSEIF ( M.LT.0 ) THEN INFO = -3 ELSEIF ( L.LT.0 ) THEN INFO = -4 ELSEIF ( LTHETA.LT.( N*( L + M + 1 ) + L*M ) ) THEN INFO = -6 ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -8 ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 ELSEIF ( LDC.LT.MAX( 1, L ) ) THEN INFO = -12 ELSEIF ( LDD.LT.MAX( 1, L ) ) THEN INFO = -14 ELSEIF ( LDWORK.LT.N*( N + L + 1 ) ) THEN INFO = -17 ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'TB01VY', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( MAX( N, M, L ).EQ.0 ) $ RETURN C IF ( M.GT.0 ) THEN C C Copy the matrix B from THETA. C CALL DLACPY( 'Full', N, M, THETA(N*L+1), N, B, LDB ) C C Copy the matrix D. C CALL DLACPY( 'Full', L, M, THETA(N*(L+M)+1), L, D, LDD ) ENDIF C IF ( N.EQ.0 ) THEN RETURN ELSE IF ( L.EQ.0 ) THEN CALL DCOPY( N, THETA(N*M+1), 1, X0, 1 ) RETURN END IF C C Initialize the indices in the workspace. C LDCA = N + L C CA = 1 C JWORK = CA + N*LDCA TOBYPI = HALF/ATAN( ONE ) C C Generate the matrices C and A from their parameters. C Start with the block matrix [0; I], where 0 is a block of zeros C of size L-by-N, and I is the identity matrix of order N. C DWORK(CA) = ZERO CALL DCOPY( N*(L+N), DWORK(CA), 0, DWORK(CA), 1 ) DWORK(CA+L) = ONE CALL DCOPY( N, DWORK(CA+L), 0, DWORK(CA+L), LDCA+1 ) C C Now, read out THETA(1 : N*L) and perform the transformations C defined by the parameters in THETA. C DO 30 I = N, 1, -1 C C Save THETAi in the first column of C and use the copy for C further processing. C CALL DCOPY( L, THETA((I-1)*L+1), 1, C, 1 ) TI = DNRM2( L, C, 1 ) IF ( LAPPLY .AND. TI.NE.ZERO ) THEN C C Apply the bijective mapping which guarantees that TI < 1. C FACTOR = TOBYPI*ATAN( TI )/TI C C Scale THETAi and apply the same scaling on TI. C CALL DSCAL( L, FACTOR, C, 1 ) TI = TI*FACTOR END IF C C RI = sqrt( 1 - TI**2 ). C RI = SQRT( ( ONE - TI )*( ONE + TI ) ) C C Multiply a certain part of DWORK(CA) with Ui' from the left, C where Ui = [ -THETAi, Si; RI, THETAi' ] is (L+1)-by-(L+1), but C Ui is not stored. C CALL DGEMV( 'Transpose', L, N, -ONE, DWORK(CA+N-I), LDCA, C, 1, $ ZERO, DWORK(JWORK), 1 ) C IF ( TI.GT.ZERO ) THEN CALL DGER( L, N, (ONE-RI)/TI/TI, C, 1, DWORK(JWORK), 1, $ DWORK(CA+N-I), LDCA ) ELSE C C The call below is for the limiting case. C CALL DGER( L, N, HALF, C, 1, DWORK(JWORK), 1, $ DWORK(CA+N-I), LDCA ) ENDIF C CALL DGER( L, N, ONE, C, 1, DWORK(CA+N-I+L), LDCA, $ DWORK(CA+N-I), LDCA ) CALL DAXPY( N, RI, DWORK(CA+N-I+L), LDCA, DWORK(JWORK), 1 ) C C Move these results to their appropriate locations. C DO 20 J = 1, N IN = CA + N - I + ( J - 1 )*LDCA DO 10 K = IN + L, IN + 1, -1 DWORK(K) = DWORK(K-1) 10 CONTINUE DWORK(IN) = DWORK(JWORK+J-1) 20 CONTINUE C 30 CONTINUE C C Now, DWORK(CA) = [C; A]. Copy to C and A. C DO 40 I = 1, N CALL DCOPY( L, DWORK(CA+(I-1)*LDCA), 1, C(1,I), 1 ) CALL DCOPY( N, DWORK(CA+L+(I-1)*LDCA), 1, A(1,I), 1 ) 40 CONTINUE C C Copy the initial state x0. C CALL DCOPY( N, THETA(N*(L+M)+L*M+1), 1, X0, 1 ) C RETURN C C *** Last line of TB01VY *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01MD.f0000644000000000000000000000013015012430707016154 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MC01MD.f0000644000175000017500000001000415012430707017345 0ustar00lilgelilge00000000000000 SUBROUTINE MC01MD( DP, ALPHA, K, P, Q, INFO ) C C PURPOSE C C To calculate, for a given real polynomial P(x) and a real scalar C alpha, the leading K coefficients of the shifted polynomial C K-1 C P(x) = q(1) + q(2) * (x-alpha) + ... + q(K) * (x-alpha) + ... C C using Horner's algorithm. C C ARGUMENTS C C Input/Output Parameters C C DP (input) INTEGER C The degree of the polynomial P(x). DP >= 0. C C ALPHA (input) DOUBLE PRECISION C The scalar value alpha of the problem. C C K (input) INTEGER C The number of coefficients of the shifted polynomial to be C computed. 1 <= K <= DP+1. C C P (input) DOUBLE PRECISION array, dimension (DP+1) C This array must contain the coefficients of P(x) in C increasing powers of x. C C Q (output) DOUBLE PRECISION array, dimension (DP+1) C The leading K elements of this array contain the first C K coefficients of the shifted polynomial in increasing C powers of (x - alpha), and the next (DP-K+1) elements C are used as internal workspace. 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 Given the real polynomial C 2 DP C P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x , C C the routine computes the leading K coefficients of the shifted C polynomial C K-1 C P(x) = q(1) + q(2) * (x - alpha) + ... + q(K) * (x - alpha) C C as follows. C C Applying Horner's algorithm (see [1]) to P(x), i.e. dividing P(x) C by (x-alpha), yields C C P(x) = q(1) + (x-alpha) * D(x), C C where q(1) is the value of the constant term of the shifted C polynomial and D(x) is the quotient polynomial of degree (DP-1) C given by C 2 DP-1 C D(x) = d(2) + d(3) * x + d(4) * x + ... + d(DP+1) * x . C C Applying Horner's algorithm to D(x) and subsequent quotient C polynomials yields q(2) and q(3), q(4), ..., q(K) respectively. C C It follows immediately that q(1) = P(alpha), and in general C (i-1) C q(i) = P (alpha) / (i - 1)! for i = 1, 2, ..., K. C C REFERENCES C C [1] STOER, J. and BULIRSCH, R. C Introduction to Numerical Analysis. C Springer-Verlag. 1980. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01AD by A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Elementary polynomial operations, polynomial operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER DP, INFO, K DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION P(*), Q(*) C .. Local Scalars .. INTEGER I, J C .. External Subroutines .. EXTERNAL DCOPY, XERBLA C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 IF( DP.LT.0 ) THEN INFO = -1 ELSE IF( K.LE.0 .OR. K.GT.DP+1 ) THEN INFO = -3 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MC01MD', -INFO ) RETURN END IF C CALL DCOPY( DP+1, P, 1, Q, 1 ) IF ( DP.EQ.0 .OR. ALPHA.EQ.ZERO ) $ RETURN C DO 40 J = 1, K C DO 20 I = DP, J, -1 Q(I) = Q(I) + ALPHA*Q(I+1) 20 CONTINUE C 40 CONTINUE C RETURN C *** Last line of MC01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01QD.f0000644000000000000000000000013215012430707016161 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01QD.f0000644000175000017500000002121215012430707017353 0ustar00lilgelilge00000000000000 SUBROUTINE MB01QD( TYPE, M, N, KL, KU, CFROM, CTO, NBL, NROWS, A, $ LDA, INFO ) C C PURPOSE C C To multiply the M by N real matrix A by the real scalar CTO/CFROM. C This is done without over/underflow as long as the final result C CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that C A may be full, (block) upper triangular, (block) lower triangular, C (block) upper Hessenberg, or banded. C C ARGUMENTS C C Mode Parameters C C TYPE CHARACTER*1 C TYPE indices the storage type of the input matrix. C = 'G': A is a full matrix. C = 'L': A is a (block) lower triangular matrix. C = 'U': A is a (block) upper triangular matrix. C = 'H': A is a (block) upper Hessenberg matrix. C = 'B': A is a symmetric band matrix with lower bandwidth C KL and upper bandwidth KU and with the only the C lower half stored. C = 'Q': A is a symmetric band matrix with lower bandwidth C KL and upper bandwidth KU and with the only the C upper half stored. C = 'Z': A is a band matrix with lower bandwidth KL and C upper bandwidth KU. 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 KL (input) INTEGER C The lower bandwidth of A. Referenced only if TYPE = 'B', C 'Q' or 'Z'. C C KU (input) INTEGER C The upper bandwidth of A. Referenced only if TYPE = 'B', C 'Q' or 'Z'. C C CFROM (input) DOUBLE PRECISION C CTO (input) DOUBLE PRECISION C The matrix A is multiplied by CTO/CFROM. A(I,J) is C computed without over/underflow if the final result C CTO*A(I,J)/CFROM can be represented without over/ C underflow. CFROM must be nonzero. C C NBL (input) INTEGER C The number of diagonal blocks of the matrix A, if it has a C block structure. To specify that matrix A has no block C structure, set NBL = 0. NBL >= 0. C C NROWS (input) INTEGER array, dimension max(1,NBL) C NROWS(i) contains the number of rows and columns of the C i-th diagonal block of matrix A. The sum of the values C NROWS(i), for i = 1: NBL, should be equal to min(M,N). C The array NROWS is not referenced if NBL = 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C The matrix to be multiplied by CTO/CFROM. See TYPE for C the storage type. C C LDA (input) INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C Error Indicator C C INFO INTEGER C Not used in this implementation. C C METHOD C C Matrix A is multiplied by the real scalar CTO/CFROM, taking into C account the specified storage mode of the matrix. C MB01QD is a version of the LAPACK routine DLASCL, modified for C dealing with block triangular, or block Hessenberg matrices. C For efficiency, no tests of the input scalar parameters are C performed. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. C .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, KL, KU, LDA, M, N, NBL DOUBLE PRECISION CFROM, CTO C .. C .. Array Arguments .. INTEGER NROWS ( * ) DOUBLE PRECISION A( LDA, * ) C .. C .. Local Scalars .. LOGICAL DONE, NOBLC INTEGER I, IFIN, ITYPE, J, JFIN, JINI, K, K1, K2, K3, $ K4 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. C .. Executable Statements .. C IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE ITYPE = 6 END IF C C Quick return if possible. C IF( MIN( M, N ).EQ.0 ) $ RETURN C C Get machine parameters. C SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM C CFROMC = CFROM CTOC = CTO C 10 CONTINUE CFROM1 = CFROMC*SMLNUM CTO1 = CTOC / BIGNUM IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF C NOBLC = NBL.EQ.0 C IF( ITYPE.EQ.0 ) THEN C C Full matrix C DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE C ELSE IF( ITYPE.EQ.1 ) THEN C IF ( NOBLC ) THEN C C Lower triangular matrix C DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE C ELSE C C Block lower triangular matrix C JFIN = 0 DO 80 K = 1, NBL JINI = JFIN + 1 JFIN = JFIN + NROWS( K ) DO 70 J = JINI, JFIN DO 60 I = JINI, M A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE 80 CONTINUE END IF C ELSE IF( ITYPE.EQ.2 ) THEN C IF ( NOBLC ) THEN C C Upper triangular matrix C DO 100 J = 1, N DO 90 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 90 CONTINUE 100 CONTINUE C ELSE C C Block upper triangular matrix C JFIN = 0 DO 130 K = 1, NBL JINI = JFIN + 1 JFIN = JFIN + NROWS( K ) IF ( K.EQ.NBL ) JFIN = N DO 120 J = JINI, JFIN DO 110 I = 1, MIN( JFIN, M ) A( I, J ) = A( I, J )*MUL 110 CONTINUE 120 CONTINUE 130 CONTINUE END IF C ELSE IF( ITYPE.EQ.3 ) THEN C IF ( NOBLC ) THEN C C Upper Hessenberg matrix C DO 150 J = 1, N DO 140 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE C ELSE C C Block upper Hessenberg matrix C JFIN = 0 DO 180 K = 1, NBL JINI = JFIN + 1 JFIN = JFIN + NROWS( K ) C IF ( K.EQ.NBL ) THEN JFIN = N IFIN = N ELSE IFIN = JFIN + NROWS( K+1 ) END IF C DO 170 J = JINI, JFIN DO 160 I = 1, MIN( IFIN, M ) A( I, J ) = A( I, J )*MUL 160 CONTINUE 170 CONTINUE 180 CONTINUE END IF C ELSE IF( ITYPE.EQ.4 ) THEN C C Lower half of a symmetric band matrix C K3 = KL + 1 K4 = N + 1 DO 200 J = 1, N DO 190 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 190 CONTINUE 200 CONTINUE C ELSE IF( ITYPE.EQ.5 ) THEN C C Upper half of a symmetric band matrix C K1 = KU + 2 K3 = KU + 1 DO 220 J = 1, N DO 210 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 210 CONTINUE 220 CONTINUE C ELSE IF( ITYPE.EQ.6 ) THEN C C Band matrix C K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 240 J = 1, N DO 230 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 230 CONTINUE 240 CONTINUE C END IF C IF( .NOT.DONE ) $ GO TO 10 C RETURN C *** Last line of MB01QD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04QB.f0000644000000000000000000000013215012430707016162 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04QB.f0000644000175000017500000003725215012430707017367 0ustar00lilgelilge00000000000000 SUBROUTINE MB04QB( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K, $ V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To overwrite general real m-by-n matrices C and D, or their C transposes, with C C [ op(C) ] C Q * [ ] if TRANQ = 'N', or C [ op(D) ] C C T [ op(C) ] C Q * [ ] if TRANQ = 'T', C [ op(D) ] C C where Q is defined as the product of symplectic reflectors and C Givens rotations, C C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). C C Blocked version. C C ARGUMENTS C C Mode Parameters C C TRANC CHARACTER*1 C Specifies the form of op( C ) as follows: C = 'N': op( C ) = C; C = 'T': op( C ) = C'; C = 'C': op( C ) = C'. C C TRAND CHARACTER*1 C Specifies the form of op( D ) as follows: C = 'N': op( D ) = D; C = 'T': op( D ) = D'; C = 'C': op( D ) = D'. C C TRANQ CHARACTER*1 C = 'N': apply Q; C = 'T': apply Q'. C C STOREV CHARACTER*1 C Specifies how the vectors which define the concatenated C Householder reflectors contained in V are stored: C = 'C': columnwise; C = 'R': rowwise. C C STOREW CHARACTER*1 C Specifies how the vectors which define the concatenated C Householder reflectors contained in W are stored: C = 'C': columnwise; C = 'R': rowwise. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrices op(C) and op(D). C M >= 0. C C N (input) INTEGER C The number of columns of the matrices op(C) and op(D). C N >= 0. C C K (input) INTEGER C The number of elementary reflectors whose product defines C the matrix Q. M >= K >= 0. C C V (input) DOUBLE PRECISION array, dimension C (LDV,K) if STOREV = 'C', C (LDV,M) if STOREV = 'R' C On entry with STOREV = 'C', the leading M-by-K part of C this array must contain in its columns the vectors which C define the elementary reflectors F(i). C On entry with STOREV = 'R', the leading K-by-M part of C this array must contain in its rows the vectors which C define the elementary reflectors F(i). C C LDV INTEGER C The leading dimension of the array V. C LDV >= MAX(1,M), if STOREV = 'C'; C LDV >= MAX(1,K), if STOREV = 'R'. C C W (input) DOUBLE PRECISION array, dimension C (LDW,K) if STOREW = 'C', C (LDW,M) if STOREW = 'R' C On entry with STOREW = 'C', the leading M-by-K part of C this array must contain in its columns the vectors which C define the elementary reflectors H(i). C On entry with STOREW = 'R', the leading K-by-M part of C this array must contain in its rows the vectors which C define the elementary reflectors H(i). C C LDW INTEGER C The leading dimension of the array W. C LDW >= MAX(1,M), if STOREW = 'C'; C LDW >= MAX(1,K), if STOREW = 'R'. C C C (input/output) DOUBLE PRECISION array, dimension C (LDC,N) if TRANC = 'N', C (LDC,M) if TRANC = 'T' or TRANC = 'C' C On entry with TRANC = 'N', the leading M-by-N part of C this array must contain the matrix C. C On entry with TRANC = 'C' or TRANC = 'T', the leading C N-by-M part of this array must contain the transpose of C the matrix C. C On exit with TRANC = 'N', the leading M-by-N part of C this array contains the updated matrix C. C On exit with TRANC = 'C' or TRANC = 'T', the leading C N-by-M part of this array contains the transpose of the C updated matrix C. C C LDC INTEGER C The leading dimension of the array C. C LDC >= MAX(1,M), if TRANC = 'N'; C LDC >= MAX(1,N), if TRANC = 'T' or TRANC = 'C'. C C D (input/output) DOUBLE PRECISION array, dimension C (LDD,N) if TRAND = 'N', C (LDD,M) if TRAND = 'T' or TRAND = 'C' C On entry with TRAND = 'N', the leading M-by-N part of C this array must contain the matrix D. C On entry with TRAND = 'C' or TRAND = 'T', the leading C N-by-M part of this array must contain the transpose of C the matrix D. C On exit with TRAND = 'N', the leading M-by-N part of C this array contains the updated matrix D. C On exit with TRAND = 'C' or TRAND = 'T', the leading C N-by-M part of this array contains the transpose of the C updated matrix D. C C LDD INTEGER C The leading dimension of the array D. C LDD >= MAX(1,M), if TRAND = 'N'; C LDD >= MAX(1,N), if TRAND = 'T' or TRAND = 'C'. C C CS (input) DOUBLE PRECISION array, dimension (2*K) C On entry, the first 2*K elements of this array must C contain the cosines and sines of the symplectic Givens C rotations G(i). C C TAU (input) DOUBLE PRECISION array, dimension (K) C On entry, the first K elements of this array must C contain the scalar factors of the elementary reflectors C F(i). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -20, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,N). 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] Kressner, D. C Block algorithms for orthogonal symplectic factorizations. C BIT, 43 (4), pp. 775-790, 2003. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSMSB). C V. Sima, Aug. 2011, Nov. 2011. C C KEYWORDS C C Elementary matrix operations, orthogonal symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) C .. Scalar Arguments .. CHARACTER STOREV, STOREW, TRANC, TRAND, TRANQ INTEGER INFO, K, LDC, LDD, LDV, LDW, LDWORK, M, N C .. Array Arguments .. DOUBLE PRECISION C(LDC,*), CS(*), D(LDD,*), DWORK(*), TAU(*), $ V(LDV,*), W(LDW,*) C .. Local Scalars .. CHARACTER*1 SIDE LOGICAL LCOLV, LCOLW, LQUERY, LTRC, LTRD, LTRQ INTEGER I, IB, IC, ID, IERR, JC, JD, KI, KK, MINWRK, NB, $ NBMIN, NX, PDRS, PDT, PDW, WRKOPT C .. External Functions .. INTEGER UE01MD LOGICAL LSAME EXTERNAL LSAME, UE01MD C .. External Subroutines .. EXTERNAL DORMQR, MB04QC, MB04QF, MB04QU, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN, SQRT C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 LCOLV = LSAME( STOREV, 'C' ) LCOLW = LSAME( STOREW, 'C' ) LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' ) LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' ) LTRQ = LSAME( TRANQ, 'T' ) C C Check the scalar input parameters. C IF ( .NOT.( LTRC .OR. LSAME( TRANC, 'N' ) ) ) THEN INFO = -1 ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN INFO = -2 ELSE IF ( .NOT.( LTRQ .OR. LSAME( TRANQ, 'N' ) ) ) THEN INFO = -3 ELSE IF ( .NOT.( LCOLV .OR. LSAME( STOREV, 'R' ) ) ) THEN INFO = -4 ELSE IF ( .NOT.( LCOLW .OR. LSAME( STOREW, 'R' ) ) ) THEN INFO = -5 ELSE IF ( M.LT.0 ) THEN INFO = -6 ELSE IF ( N.LT.0 ) THEN INFO = -7 ELSE IF ( K.LT.0 .OR. K.GT.M ) THEN INFO = -8 ELSE IF ( ( LCOLV .AND. LDV.LT.MAX( 1, M ) ) .OR. $ ( .NOT.LCOLV .AND. LDV.LT.MAX( 1, K ) ) ) THEN INFO = -10 ELSE IF ( ( LCOLW .AND. LDW.LT.MAX( 1, M ) ) .OR. $ ( .NOT.LCOLW .AND. LDW.LT.MAX( 1, K ) ) ) THEN INFO = -12 ELSE IF ( ( LTRC .AND. LDC.LT.MAX( 1, N ) ) .OR. $ ( .NOT.LTRC .AND. LDC.LT.MAX( 1, M ) ) ) THEN INFO = -14 ELSE IF ( ( LTRD .AND. LDD.LT.MAX( 1, N ) ) .OR. $ ( .NOT.LTRD .AND. LDD.LT.MAX( 1, M ) ) ) THEN INFO = -16 ELSE LQUERY = LDWORK.EQ.-1 MINWRK = MAX( 1, N ) IF ( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN DWORK(1) = DBLE( MINWRK ) INFO = -20 ELSE IF ( N.EQ.0 ) THEN WRKOPT = ONE ELSE I = MAX( 1, M, N ) IF ( LTRC ) THEN SIDE = 'R' IC = N JC = M ELSE SIDE = 'L' IC = M JC = N END IF CALL DORMQR( SIDE, TRANC, IC, JC, K, DWORK, I, DWORK, $ DWORK, I, DWORK, -1, INFO ) WRKOPT = MAX( MINWRK, INT( DWORK(1) ) ) NB = MIN( INT( WRKOPT/N ), N ) WRKOPT = MAX( WRKOPT, 9*N*NB + 15*NB*NB ) END IF IF ( LQUERY ) THEN DWORK(1) = DBLE( WRKOPT ) RETURN END IF END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04QB', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( K, M, N ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C NBMIN = 2 NX = 0 IF ( NB.GT.1 .AND. NB.LT.K ) THEN C C Determine when to cross over from blocked to unblocked code. C NX = MAX( 0, UE01MD( 3, 'MB04QB', TRANC // TRAND // TRANQ, M, $ N, K ) ) IF ( NX.LT.K ) THEN C C Determine if workspace is large enough for blocked code. C IF ( LDWORK.LT.WRKOPT ) THEN C C Not enough workspace to use optimal NB: reduce NB and C determine the minimum value of NB. C NB = INT( ( SQRT( DBLE( 81*N*N + 60*LDWORK ) ) $ - DBLE( 9*N ) ) / 30.0D0 ) NBMIN = MAX( 2, UE01MD( 2, 'MB04QB', TRANC // TRAND // $ TRANQ, M, N, K ) ) END IF END IF END IF C PDRS = 1 PDT = PDRS + 6*NB*NB PDW = PDT + 9*NB*NB IC = 1 JC = 1 ID = 1 JD = 1 C IF ( LTRQ ) THEN C C Use blocked code initially. C IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN DO 10 I = 1, K - NX, NB IB = MIN( K-I+1, NB ) C C Form the triangular factors of the symplectic block C reflector SH. C CALL MB04QF( 'Forward', STOREV, STOREW, M-I+1, IB, $ V(I,I), LDV, W(I,I), LDW, CS(2*I-1), TAU(I), $ DWORK(PDRS), NB, DWORK(PDT), NB, $ DWORK(PDW) ) C C Apply SH' to [ op(C)(i:m,:); op(D)(i:m,:) ] from the C left. C IF ( LTRC ) THEN JC = I ELSE IC = I END IF IF ( LTRD ) THEN JD = I ELSE ID = I END IF CALL MB04QC( 'No Structure', TRANC, TRAND, TRANQ, $ 'Forward', STOREV, STOREW, M-I+1, N, IB, $ V(I,I), LDV, W(I,I), LDW, DWORK(PDRS), NB, $ DWORK(PDT), NB, C(IC,JC), LDC, D(ID,JD), $ LDD, DWORK(PDW) ) 10 CONTINUE ELSE I = 1 END IF C C Use unblocked code to update last or only block. C IF ( I.LE.K ) THEN IF ( LTRC ) THEN JC = I ELSE IC = I END IF IF ( LTRD ) THEN JD = I ELSE ID = I END IF CALL MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M-I+1, N, $ K-I+1, V(I,I), LDV, W(I,I), LDW, C(IC,JC), LDC, $ D(ID,JD), LDD, CS(2*I-1), TAU(I), DWORK, $ LDWORK, IERR ) END IF ELSE IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN C C Use blocked code after the last block. C The first kk columns are handled by the block method. C KI = ( ( K-NX-1 ) / NB )*NB KK = MIN( K, KI+NB ) ELSE KK = 0 END IF C C Use unblocked code for the last or only block. C IF ( KK.LT.K ) THEN IF ( LTRC ) THEN JC = KK + 1 ELSE IC = KK + 1 END IF IF ( LTRD ) THEN JD = KK + 1 ELSE ID = KK + 1 END IF CALL MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M-KK, N, $ K-KK, V(KK+1,KK+1), LDV, W(KK+1,KK+1), LDW, $ C(IC,JC), LDC, D(ID,JD), LDD, CS(2*KK+1), $ TAU(KK+1), DWORK, LDWORK, IERR ) END IF C C Blocked code. C IF ( KK.GT.0 ) THEN DO 20 I = KI + 1, 1, -NB IB = MIN( NB, K-I+1 ) C C Form the triangular factors of the symplectic block C reflector SH. C CALL MB04QF( 'Forward', STOREV, STOREW, M-I+1, IB, $ V(I,I), LDV, W(I,I), LDW, CS(2*I-1), TAU(I), $ DWORK(PDRS), NB, DWORK(PDT), NB, $ DWORK(PDW) ) C C Apply SH to [ op(C)(i:m,:); op(D)(i:m,:) ] from C the left. C IF ( LTRC ) THEN JC = I ELSE IC = I END IF IF ( LTRD ) THEN JD = I ELSE ID = I END IF CALL MB04QC( 'No Structure', TRANC, TRAND, TRANQ, $ 'Forward', STOREV, STOREW, M-I+1, N, IB, $ V(I,I), LDV, W(I,I), LDW, DWORK(PDRS), NB, $ DWORK(PDT), NB, C(IC,JC), LDC, D(ID,JD), $ LDD, DWORK(PDW) ) 20 CONTINUE END IF END IF DWORK(1) = DBLE( WRKOPT ) C RETURN C *** Last line of MB04QB *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04RD.f0000644000000000000000000000013215012430707016173 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB04RD.f0000644000175000017500000003136715012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To solve for X the discrete-time Sylvester equation C C X + AXB = C, C C with at least one of the matrices A or B in Schur form and the C other in Hessenberg or Schur form (both either upper or lower); C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, C respectively. C C ARGUMENTS C C Mode Parameters C C ABSCHU CHARACTER*1 C Indicates whether A and/or B is/are in Schur or C Hessenberg form as follows: C = 'A': A is in Schur form, B is in Hessenberg form; C = 'B': B is in Schur form, A is in Hessenberg form; C = 'S': Both A and B are in Schur form. C C ULA CHARACTER*1 C Indicates whether A is in upper or lower Schur form or C upper or lower Hessenberg form as follows: C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and C upper Schur form otherwise; C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and C lower Schur form otherwise. C C ULB CHARACTER*1 C Indicates whether B is in upper or lower Schur form or C upper or lower Hessenberg form as follows: C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and C upper Schur form otherwise; C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and C lower Schur form otherwise. 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) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must contain the C coefficient matrix A of the equation. 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 M-by-M part of this array must contain the C coefficient matrix B of the equation. 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, if INFO = 0, the leading N-by-M part of this C array contains the solution matrix X of the problem. C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,N). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used to test for near singularity in C the Sylvester equation. If the user sets TOL > 0, then the C given value of TOL is used as a lower bound for the C reciprocal condition number; a matrix whose estimated C condition number is less than 1/TOL is considered to be C nonsingular. If the user sets TOL <= 0, then a default C tolerance, defined by TOLDEF = EPS, is used instead, where C EPS is the machine precision (see LAPACK Library routine C DLAMCH). C This parameter is not referenced if ABSCHU = 'S', C ULA = 'U', and ULB = 'U'. C C Workspace C C IWORK INTEGER array, dimension (2*MAX(M,N)) C This parameter is not referenced if ABSCHU = 'S', C ULA = 'U', and ULB = 'U'. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C C LDWORK INTEGER C The length of the array DWORK. C LDWORK = 2*N, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. 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 a (numerically) singular matrix T was encountered C during the computation of the solution matrix X. C That is, the estimated reciprocal condition number C of T is less than or equal to TOL. C C METHOD C C Matrices A and B are assumed to be in (upper or lower) Hessenberg C or Schur form (with at least one of them in Schur form). The C solution matrix X is then computed by rows or columns via the back C substitution scheme proposed by Golub, Nash and Van Loan (see C [1]), which involves the solution of triangular systems of C equations that are constructed recursively and which may be nearly C singular if A and -B have almost reciprocal eigenvalues. If near C singularity is detected, then the routine returns with the Error C Indicator (INFO) set to 1. 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 2 2 C The algorithm requires approximately 5M N + 0.5MN operations in C 2 2 C the worst case and 2.5M N + 0.5MN operations in the best case C (where M is the order of the matrix in Hessenberg form and N is C the order of the matrix in Schur form) and is mixed stable (see C [1]). C C CONTRIBUTORS C C D. Sima, University of Bucharest, May 2000. C C REVISIONS C C V. Sima, Katholieke Univ. Leuven, Belgium, June 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 .. CHARACTER ABSCHU, ULA, ULB INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) C .. Local Scalars .. CHARACTER ABSCHR LOGICAL LABSCB, LABSCS, LULA, LULB INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, $ LDW, MAXMN DOUBLE PRECISION SCALE, TOL1 C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH, LSAME C .. External Subroutines .. EXTERNAL DCOPY, SB04PY, SB04RV, SB04RW, SB04RX, SB04RY, $ XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C INFO = 0 MAXMN = MAX( M, N ) LABSCB = LSAME( ABSCHU, 'B' ) LABSCS = LSAME( ABSCHU, 'S' ) LULA = LSAME( ULA, 'U' ) LULB = LSAME( ULB, 'U' ) C C Test the input scalar arguments. C IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN INFO = -1 ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN INFO = -2 ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDWORK.LT.2*N .OR. $ ( LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) .AND. $ .NOT.( LABSCS .AND. LULA .AND. LULB ) ) ) THEN INFO = -15 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB04RD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MAXMN.EQ.0 ) $ RETURN C IF ( LABSCS .AND. LULA .AND. LULB ) THEN C C If both matrices are in a real Schur form, use SB04PY. C CALL SB04PY( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, $ B, LDB, C, LDC, SCALE, DWORK, INFO ) IF ( SCALE.NE.ONE ) $ INFO = 1 RETURN END IF C LDW = 2*MAXMN JWORK = LDW*LDW + 3*LDW + 1 TOL1 = TOL IF ( TOL1.LE.ZERO ) $ TOL1 = DLAMCH( 'Epsilon' ) C C Choose the smallest of both matrices as the one in Hessenberg C form when possible. C ABSCHR = ABSCHU IF ( LABSCS ) THEN IF ( N.GT.M ) THEN ABSCHR = 'A' ELSE ABSCHR = 'B' END IF END IF IF ( LSAME( ABSCHR, 'B' ) ) THEN C C B is in Schur form: recursion on the columns of B. C IF ( LULB ) THEN C C B is upper: forward recursion. C IBEG = 1 IEND = M FWD = 1 INCR = 0 ELSE C C B is lower: backward recursion. C IBEG = M IEND = 1 FWD = -1 INCR = -1 END IF I = IBEG C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN C C Test for 1-by-1 or 2-by-2 diagonal block in the Schur C form. C IF ( I.EQ.IEND ) THEN ISTEP = 1 ELSE IF ( B(I+FWD,I).EQ.ZERO ) THEN ISTEP = 1 ELSE ISTEP = 2 END IF END IF C IF ( ISTEP.EQ.1 ) THEN CALL SB04RW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, $ A, LDA, DWORK(JWORK), DWORK ) CALL SB04RY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), $ TOL1, IWORK, DWORK, LDW, INFO ) IF ( INFO.EQ.1 ) $ RETURN CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) ELSE IPINCR = I + INCR CALL SB04RV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, $ A, LDA, DWORK(JWORK), DWORK ) CALL SB04RX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, $ IWORK, DWORK, LDW, INFO ) IF ( INFO.EQ.1 ) $ RETURN CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) END IF I = I + FWD*ISTEP GO TO 20 END IF C END WHILE 20 ELSE C C A is in Schur form: recursion on the rows of A. C IF ( LULA ) THEN C C A is upper: backward recursion. C IBEG = N IEND = 1 FWD = -1 INCR = -1 ELSE C C A is lower: forward recursion. C IBEG = 1 IEND = N FWD = 1 INCR = 0 END IF I = IBEG C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN C C Test for 1-by-1 or 2-by-2 diagonal block in the Schur C form. C IF ( I.EQ.IEND ) THEN ISTEP = 1 ELSE IF ( A(I,I+FWD).EQ.ZERO ) THEN ISTEP = 1 ELSE ISTEP = 2 END IF END IF C IF ( ISTEP.EQ.1 ) THEN CALL SB04RW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, $ B, LDB, DWORK(JWORK), DWORK ) CALL SB04RY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), $ TOL1, IWORK, DWORK, LDW, INFO ) IF ( INFO.EQ.1 ) $ RETURN CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) ELSE IPINCR = I + INCR CALL SB04RV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, $ B, LDB, DWORK(JWORK), DWORK ) CALL SB04RX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, $ IWORK, DWORK, LDW, INFO ) IF ( INFO.EQ.1 ) $ RETURN CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) END IF I = I + FWD*ISTEP GO TO 40 END IF C END WHILE 40 END IF C RETURN C *** Last line of SB04RD *** END control-4.1.2/src/slicot/src/PaxHeaders/AG08BD.f0000644000000000000000000000013215012430707016142 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AG08BD.f0000644000175000017500000005156415012430707017351 0ustar00lilgelilge00000000000000 SUBROUTINE AG08BD( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB, $ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, $ NINFE, NKROL, INFZ, KRONR, INFE, KRONL, $ TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To extract from the system pencil C C ( A-lambda*E B ) C S(lambda) = ( ) C ( C D ) C C a regular pencil Af-lambda*Ef which has the finite Smith zeros of C S(lambda) as generalized eigenvalues. The routine also computes C the orders of the infinite Smith zeros and determines the singular C and infinite Kronecker structure of system pencil, i.e., the right C and left Kronecker indices, and the multiplicities of infinite C eigenvalues. C C ARGUMENTS C C Mode Parameters C C EQUIL CHARACTER*1 C Specifies whether the user wishes to balance the system C matrix as follows: C = 'S': Perform balancing (scaling); C = 'N': Do not perform balancing. C C Input/Output Parameters C C L (input) INTEGER C The number of rows of matrices A, B, and E. L >= 0. C C N (input) INTEGER C The number of columns of matrices A, E, and C. N >= 0. C C M (input) INTEGER C The number of columns of matrix B. M >= 0. C C P (input) INTEGER C The number of rows of matrix C. P >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading L-by-N part of this array must C contain the state dynamics matrix A of the system. C On exit, the leading NFZ-by-NFZ part of this array C contains the matrix Af of the reduced pencil. C C LDA INTEGER C The leading dimension of array A. LDA >= MAX(1,L). C C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) C On entry, the leading L-by-N part of this array must C contain the descriptor matrix E of the system. C On exit, the leading NFZ-by-NFZ part of this array C contains the matrix Ef of the reduced pencil. C C LDE INTEGER C The leading dimension of array E. LDE >= MAX(1,L). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) C On entry, the leading L-by-M part of this array must C contain the input/state matrix B of the system. C On exit, this matrix does not contain useful information. C C LDB INTEGER C The leading dimension of array B. C LDB >= MAX(1,L) if M > 0; C LDB >= 1 if M = 0. 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 C of the system. C On exit, this matrix does not contain useful information. 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 NFZ (output) INTEGER C The number of finite zeros. C C NRANK (output) INTEGER C The normal rank of the system pencil. C C NIZ (output) INTEGER C The number of infinite zeros. C C DINFZ (output) INTEGER C The maximal multiplicity of infinite Smith zeros. C C NKROR (output) INTEGER C The number of right Kronecker indices. C C NINFE (output) INTEGER C The number of elementary infinite blocks. C C NKROL (output) INTEGER C The number of left Kronecker indices. C C INFZ (output) INTEGER array, dimension (N+1) 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 of C degree i in the Smith form, where i = 1,2,...,DINFZ. C C KRONR (output) INTEGER array, dimension (N+M+1) C The leading NKROR elements of this array contain the C right Kronecker (column) indices. C C INFE (output) INTEGER array, dimension (1+MIN(L+P,N+M)) C The leading NINFE elements of INFE contain the C multiplicities of infinite eigenvalues. C C KRONL (output) INTEGER array, dimension (L+P+1) C The leading NKROL elements of this array contain the C left Kronecker (row) 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 If the user sets TOL <= 0, then default tolerances are C used instead, as follows: TOLDEF = L*N*EPS in TG01FD C (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS C in the rest, where EPS is the machine precision C (see LAPACK Library routine DLAMCH). TOL < 1. C C Workspace C C IWORK INTEGER array, dimension (N+max(1,M)) C On output, IWORK(1) contains the normal rank of the C transfer function matrix. 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( 4*(L+N), LDW ), if EQUIL = 'S', C LDWORK >= LDW, if EQUIL = 'N', where C LDW = max(L+P,M+N)*(M+N) + max(1,5*max(L+P,M+N)). 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 descriptor C system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which C has the finite zeros of the system as generalized eigenvalues. C The procedure has the following main computational steps: C C (a) construct the (L+P)-by-(N+M) system pencil C C S(lambda) = ( B A )-lambda*( 0 E ); C ( D C ) ( 0 0 ) C C (b) reduce S(lambda) to S1(lambda) with the same finite C zeros and right Kronecker structure but with E C upper triangular and nonsingular; C C (c) reduce S1(lambda) to S2(lambda) with the same finite C zeros and right Kronecker structure but with D of C full row rank; C C (d) reduce S2(lambda) to S3(lambda) with the same finite zeros C and with D square invertible; C C (e) perform a unitary transformation on the columns of C C S3(lambda) = (A-lambda*E B) in order to reduce it to C ( C D) C C (Af-lambda*Ef X), with Y and Ef square invertible; C ( 0 Y) C C (f) compute the right and left Kronecker indices of the system C matrix, which together with the multiplicities of the C finite and infinite eigenvalues constitute the C complete set of structural invariants under strict C equivalence transformations of a linear system. C C REFERENCES C C [1] P. Misra, P. Van Dooren and A. Varga. C Computation of structural invariants of generalized C state-space systems. C Automatica, 30, pp. 1921-1936, 1994. C C NUMERICAL ASPECTS C C The algorithm is backward stable (see [1]). C C FURTHER COMMENTS C C In order to compute the finite Smith zeros of the system C explicitly, a call to this routine may be followed by a C call to the LAPACK Library routines DGEGV or DGGEV. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, C May 1999. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999, C Jan. 2009, Mar. 2009, Apr. 2009, Apr. 2011, Feb. 2017. C A. Varga, DLR Oberpfaffenhofen, Nov. 1999, Feb. 2002, Mar. 2002. C C KEYWORDS C C Generalized eigenvalue problem, Kronecker indices, multivariable C system, orthogonal transformation, structural invariant. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. CHARACTER EQUIL INTEGER DINFZ, INFO, L, LDA, LDB, LDC, LDD, LDE, LDWORK, $ M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), $ DWORK(*), E(LDE,*) C .. Local Scalars .. LOGICAL LEQUIL, LQUERY INTEGER I, I0, I1, II, IPD, ITAU, J, JWORK, KABCD, $ LABCD2, LDABCD, LDW, MM, MU, N2, NN, NSINFE, NU, $ NUMU, PP, WRKOPT DOUBLE PRECISION SVLMAX, TOLER C .. Local Arrays .. DOUBLE PRECISION DUM(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL AG08BY, DLACPY, DLASET, DORMRZ, DTZRZF, MA02BD, $ MA02CD, TB01XD, TG01AD, TG01FD, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX, MIN C .. Executable Statements .. C INFO = 0 LDABCD = MAX( L+P, N+M ) LABCD2 = LDABCD*( N+M ) 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( L.LT.0 ) 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, L ) ) THEN INFO = -7 ELSE IF( LDE.LT.MAX( 1, L ) ) THEN INFO = -9 ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN INFO = -11 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -13 ELSE IF( LDD.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( TOL.GE.ONE ) THEN INFO = -27 ELSE I0 = MIN( L+P, M+N ) I1 = MIN( L, N ) II = MIN( M, P ) LDW = LABCD2 + MAX( 1, 5*LDABCD ) IF( LEQUIL ) $ LDW = MAX( 4*( L + N ), LDW ) IF( LQUERY ) THEN I = MAX( 1, LDABCD+I1 ) J = MAX( 1, LDABCD ) CALL TG01FD( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, $ LDB, C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, $ IWORK, DWORK, -1, INFO ) WRKOPT = MAX( LDW, INT( DWORK(1) ) ) SVLMAX = ZERO CALL AG08BY( .TRUE., I1, M+N, P+L, SVLMAX, DWORK, I, E, LDE, $ NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, TOL, $ IWORK, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) ) CALL AG08BY( .FALSE., I1, II, M+N, SVLMAX, DWORK, I, E, LDE, $ NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, TOL, $ IWORK, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) ) CALL DTZRZF( II, I1+II, DWORK, J, DWORK, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LABCD2 + II + INT( DWORK(1) ) ) CALL DORMRZ( 'Right', 'Transpose', I1, I1+II, II, I1, DWORK, $ J, DWORK, DWORK, J, DWORK, -1, INFO ) WRKOPT = MAX( WRKOPT, LABCD2 + II + INT( DWORK(1) ) ) ELSE IF( LDWORK.LT.LDW ) THEN INFO = -30 END IF END IF C IF( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AG08BD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT RETURN END IF C NIZ = 0 NKROL = 0 NKROR = 0 C C Quick return if possible. C IF( MAX( L, N, M, P ).EQ.0 ) THEN NFZ = 0 DINFZ = 0 NINFE = 0 NRANK = 0 IWORK(1) = 0 DWORK(1) = ONE RETURN 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 KABCD = 1 JWORK = KABCD + LABCD2 C C If required, balance the system pencil. C Workspace: need 4*(L+N). C IF( LEQUIL ) THEN CALL TG01AD( 'A', L, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, $ C, LDC, DWORK, DWORK(L+1), DWORK(L+N+1), INFO ) WRKOPT = 4*(L+N) END IF C C Reduce the system matrix to QR form, C C ( A11-lambda*E11 A12 B1 ) C ( A21 A22 B2 ) , C ( C1 C2 D ) C C with E11 invertible and upper triangular. C Real workspace: need max( 1, N+P, min(L,N)+max(3*N-1,M,L) ); C prefer larger. C Integer workspace: N. C CALL TG01FD( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, LDB, $ C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, IWORK, DWORK, $ LDWORK, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) C C Construct the system pencil C C MM NN C ( B1 A12 A11-lambda*E11 ) NN C S1(lambda) = ( B2 A22 A21 ) L-NN C ( D C2 C1 ) P C C of dimension (L+P)-by-(M+N). C Workspace: need LABCD2 = max( L+P, N+M )*( N+M ). C N2 = N - NN MM = M + N2 PP = P + ( L - NN ) CALL DLACPY( 'Full', L, M, B, LDB, DWORK(KABCD), LDABCD ) CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KABCD+L), LDABCD ) CALL DLACPY( 'Full', L, N2, A(1,NN+1), LDA, $ DWORK(KABCD+LDABCD*M), LDABCD ) CALL DLACPY( 'Full', P, N2, C(1,NN+1), LDC, $ DWORK(KABCD+LDABCD*M+L), LDABCD ) CALL DLACPY( 'Full', L, NN, A, LDA, $ DWORK(KABCD+LDABCD*MM), LDABCD ) CALL DLACPY( 'Full', P, NN, C, LDC, $ DWORK(KABCD+LDABCD*MM+L), LDABCD ) C C If required, set tolerance. C TOLER = TOL IF( TOLER.LE.ZERO ) THEN TOLER = DBLE( ( L + P )*( M + N ) ) * DLAMCH( 'Precision' ) END IF SVLMAX = DLANGE( 'Frobenius', NN+PP, NN+MM, DWORK(KABCD), LDABCD, $ DWORK(JWORK) ) C C Extract the reduced pencil S2(lambda) C C ( Bc Ac-lambda*Ec ) C ( Dc Cc ) C C having the same finite Smith zeros as the system pencil C S(lambda) but with Dc, a MU-by-MM full row rank C left upper trapezoidal matrix, and Ec, an NU-by-NU C upper triangular nonsingular matrix. C C Real workspace: need max( min(P+L,M+N)+max(min(L,N),3*(M+N)-1), C 5*(P+L), 1 ) + LABCD2; C prefer larger. C Integer workspace: MM, MM <= M+N; PP <= P+L. C CALL AG08BY( .TRUE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, $ TOLER, IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Set the number of simple (nondynamic) infinite eigenvalues C and the normal rank of the system pencil. C NSINFE = MU NRANK = NN + MU C C Pertranspose the system. C CALL TB01XD( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ), $ DWORK(KABCD+LDABCD*MM), LDABCD, $ DWORK(KABCD), LDABCD, $ DWORK(KABCD+LDABCD*MM+NU), LDABCD, $ DWORK(KABCD+NU), LDABCD, INFO ) CALL MA02BD( 'Right', NU+MM, MM, DWORK(KABCD), LDABCD ) CALL MA02BD( 'Left', MM, NU+MM, DWORK(KABCD+NU), LDABCD ) CALL MA02CD( NU, 0, MAX( 0, NU-1 ), E, LDE ) C IF( MU.NE.MM ) THEN NN = NU PP = MM MM = MU KABCD = KABCD + ( PP - MM )*LDABCD C C Extract the reduced pencil S3(lambda), C C ( Br Ar-lambda*Er ) , C ( Dr Cr ) C C having the same finite Smith zeros as the pencil S(lambda), C but with Dr, an MU-by-MU invertible upper triangular matrix, C and Er, an NU-by-NU upper triangular nonsingular matrix. C C Workspace: need max( 1, 5*(M+N) ) + LABCD2. C prefer larger. C No integer workspace necessary. C CALL AG08BY( .FALSE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, $ E, LDE, NU, MU, I0, I1, NKROR, IWORK, KRONR, $ TOLER, IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO ) C WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) END IF C IF( NU.NE.0 ) THEN C C Perform a unitary transformation on the columns of C ( Br Ar-lambda*Er ) C ( Dr Cr ) C in order to reduce it to C ( * Af-lambda*Ef ) C ( Y 0 ) C with Y and Ef square invertible. C C Compute Af by reducing ( Br Ar ) to ( * Af ) . C ( Dr Cr ) ( Y 0 ) C NUMU = NU + MU IPD = KABCD + NU ITAU = JWORK JWORK = ITAU + MU C C Workspace: need LABCD2 + 2*min(M,P); C prefer LABCD2 + min(M,P) + min(M,P)*NB. C CALL DTZRZF( MU, NUMU, DWORK(IPD), LDABCD, DWORK(ITAU), $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Workspace: need LABCD2 + min(M,P) + min(L,N); C prefer LABCD2 + min(M,P) + min(L,N)*NB. C CALL DORMRZ( 'Right', 'Transpose', NU, NUMU, MU, NU, $ DWORK(IPD), LDABCD, DWORK(ITAU), DWORK(KABCD), $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) C C Save Af. C CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+LDABCD*MU), LDABCD, A, $ LDA ) C C Compute Ef by applying the saved transformations from previous C reduction to ( 0 Er ) . C CALL DLASET( 'Full', NU, MU, ZERO, ZERO, DWORK(KABCD), LDABCD ) CALL DLACPY( 'Full', NU, NU, E, LDE, DWORK(KABCD+LDABCD*MU), $ LDABCD ) C CALL DORMRZ( 'Right', 'Transpose', NU, NUMU, MU, NU, $ DWORK(IPD), LDABCD, DWORK(ITAU), DWORK(KABCD), $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) C C Save Ef. C CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+LDABCD*MU), LDABCD, E, $ LDE ) END IF C NFZ = NU C C Set right Kronecker indices (column indices). C DO 10 I = 1, NKROR IWORK(I) = KRONR(I) 10 CONTINUE C J = 0 DO 30 I = 1, NKROR DO 20 II = J + 1, J + IWORK(I) KRONR(II) = I - 1 20 CONTINUE J = J + IWORK(I) 30 CONTINUE C NKROR = J C C Set left Kronecker indices (row indices). C DO 40 I = 1, NKROL IWORK(I) = KRONL(I) 40 CONTINUE C J = 0 DO 60 I = 1, NKROL DO 50 II = J + 1, J + IWORK(I) KRONL(II) = I - 1 50 CONTINUE J = J + IWORK(I) 60 CONTINUE C NKROL = J C C Determine the number of simple infinite blocks C as the difference between the number of infinite blocks C of order greater than one and the order of Dr. C NINFE = 0 DO 70 I = 1, DINFZ NINFE = NINFE + INFZ(I) 70 CONTINUE NINFE = NSINFE - NINFE DO 80 I = 1, NINFE INFE(I) = 1 80 CONTINUE C C Set the structure of infinite eigenvalues. C DO 100 I = 1, DINFZ DO 90 II = NINFE + 1, NINFE + INFZ(I) INFE(II) = I + 1 90 CONTINUE NINFE = NINFE + INFZ(I) 100 CONTINUE C IWORK(1) = NSINFE DWORK(1) = WRKOPT RETURN C *** Last line of AG08BD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03QY.f0000644000000000000000000000013215012430707016210 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03QY.f0000644000175000017500000001143415012430707017407 0ustar00lilgelilge00000000000000 SUBROUTINE MB03QY( N, L, A, LDA, U, LDU, E1, E2, INFO ) 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 control-4.1.2/src/slicot/src/PaxHeaders/MA02MD.f0000644000000000000000000000013215012430707016155 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MA02MD.f0000644000175000017500000001252215012430707017353 0ustar00lilgelilge00000000000000 DOUBLE PRECISION FUNCTION MA02MD( NORM, UPLO, N, A, LDA, DWORK ) C C PURPOSE C C To compute the value of the one norm, or the Frobenius norm, or C the infinity norm, or the element of largest absolute value C of a real skew-symmetric matrix. C C Note that for this kind of matrices the infinity norm is equal C to the one norm. C C FUNCTION VALUE C C MA02MD DOUBLE PRECISION C The computed norm. C C ARGUMENTS C C Mode Parameters C C NORM CHARACTER*1 C Specifies the value to be returned in MA02MD: C = '1' or 'O': one norm of A; C = 'F' or 'E': Frobenius norm of A; C = 'I': infinity norm of A; C = 'M': max(abs(A(i,j)). C C UPLO CHARACTER*1 C Specifies whether the upper or lower triangular part of C the skew-symmetric matrix A is to be referenced. C = 'U': Upper triangular part of A is referenced; C = 'L': Lower triangular part of A is referenced. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. When N = 0, MA02MD is C set to zero. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The skew-symmetric matrix A. If UPLO = 'U', the leading C N-by-N strictly upper triangular part of A contains the C strictly upper triangular part of the matrix A, and the C lower triangular part of A is not referenced. C If UPLO = 'L', the leading N-by-N strictly lower C triangular part of A contains the strictly lower C triangular part of the matrix A, and the upper triangular C part of A is not referenced. C The diagonal of A need not be set to zero. C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)), C where LDWORK >= N when NORM = 'I' or '1' or 'O'; C otherwise, DWORK is not referenced. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2015. C Based on LAPACK reference routine DLANSY. C C REVISIONS C C V. Sima, Jan. 2016. C C KEYWORDS C C Elementary matrix operations, skew-symmetric matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO, ZERO PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) C .. C .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER LDA, N C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), DWORK( * ) C .. C .. Local Scalars .. INTEGER I, J DOUBLE PRECISION ABSA, SCALE, SUM, VALUE C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL DLASSQ C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C .. C .. Executable Statements .. C IF( N.LE.1 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN C C Find max(abs(A(i,j))). C VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 2, N DO 10 I = 1, J-1 VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE DO 40 J = 1, N-1 DO 30 I = J+1, N VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 30 CONTINUE 40 CONTINUE END IF C ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN C C Find normI(A) ( = norm1(A), since A is skew-symmetric). C VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN DWORK( 1 ) = ZERO DO 60 J = 2, N SUM = ZERO DO 50 I = 1, J-1 ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA DWORK( I ) = DWORK( I ) + ABSA 50 CONTINUE DWORK( J ) = SUM 60 CONTINUE DO 70 I = 1, N VALUE = MAX( VALUE, DWORK( I ) ) 70 CONTINUE ELSE DO 80 I = 1, N DWORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N-1 SUM = DWORK( J ) DO 90 I = J+1, N ABSA = ABS( A( I, J ) ) SUM = SUM + ABSA DWORK( I ) = DWORK( I ) + ABSA 90 CONTINUE VALUE = MAX( VALUE, SUM ) 100 CONTINUE VALUE = MAX( VALUE, DWORK( N ) ) END IF C ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN C C Find normF(A). C SCALE = ZERO SUM = ONE IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) 110 CONTINUE ELSE DO 120 J = 1, N-1 CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) 120 CONTINUE END IF VALUE = SCALE*SQRT( TWO*SUM ) END IF C MA02MD = VALUE RETURN C C *** Last line of MA02MD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB01BY.f0000644000000000000000000000013015012430707016173 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB01BY.f0000644000175000017500000002317315012430707017377 0ustar00lilgelilge00000000000000 SUBROUTINE SB01BY( N, M, S, P, A, B, F, TOL, DWORK, INFO ) 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, ZERO PARAMETER ( FOUR = 4.0D0, ONE = 1.0D0, THREE = 3.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 control-4.1.2/src/slicot/src/PaxHeaders/MB04SU.f0000644000000000000000000000013215012430707016207 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04SU.f0000644000175000017500000001706215012430707017411 0ustar00lilgelilge00000000000000 SUBROUTINE MB04SU( M, N, A, LDA, B, LDB, CS, TAU, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To compute a symplectic QR decomposition of a real 2M-by-N matrix C [A; B], C C [ A ] [ R11 R12 ] C [ ] = Q * R = Q [ ], C [ B ] [ R21 R22 ] C C where Q is a symplectic orthogonal matrix, R11 is upper triangular C and R21 is strictly upper triangular. C If [A; B] is symplectic then, theoretically, R21 = 0 and C R22 = inv(R11)^T. Unblocked version. C C ARGUMENTS C C Input/Output Parameters C C M (input) INTEGER C The number of rows of A and B. M >= 0. C C N (input) INTEGER C The number of columns of A and B. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading M-by-N part of this array must C contain the matrix A. C On exit, the leading M-by-N part of this array contains C the matrix [ R11 R12 ] and, in the zero parts of R, C information about the elementary reflectors used to C compute the symplectic QR decomposition. C C LDA INTEGER C The leading dimension of the 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 matrix [ R21 R22 ] and, in the zero parts of B, C information about the elementary reflectors used to C compute the symplectic QR decomposition. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1,M). C C CS (output) DOUBLE PRECISION array, dimension (2 * min(M,N)) C On exit, the first 2*min(M,N) elements of this array C contain the cosines and sines of the symplectic Givens C rotations used to compute the symplectic QR decomposition. C C TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) C On exit, the first min(M,N) elements of this array C contain the scalar factors of some of the elementary C reflectors. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -10, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,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 METHOD C C The matrix Q is represented as a product of symplectic reflectors C and Givens rotations C C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ), C C where k = min(m,n). C C Each H(i) has the form C C H(i) = I - tau * w * w' C C where tau is a real scalar, and w is a real vector with C w(1:i-1) = 0 and w(i) = 1; w(i+1:m) is stored on exit in C B(i+1:m,i), and tau in B(i,i). C C Each F(i) has the form C C F(i) = I - nu * v * v' C C where nu 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 nu in TAU(i). C C Each G(i) is a Givens rotation acting on rows i of A and B, C where the cosine is stored in CS(2*i-1) and the sine in C CS(2*i). C C REFERENCES C C [1] Bunse-Gerstner, A. C Matrix factorizations for symplectic QR-like methods. C Linear Algebra Appl., 83, pp. 49-77, 1986. C C [2] Byers, R. C Hamiltonian and Symplectic Algorithms for the Algebraic C Riccati Equation. C Ph.D. Dissertation, Center for Applied Mathematics, C Cornell University, Ithaca, NY, 1983. C C NUMERICAL ASPECTS C C The algorithm requires C 8*M*N*N - 8/3*N*N*N + 2*M*N + 6*N*N + 8/3*N, if M >= N, C 8*M*M*N - 8/3*M*M*M + 14*M*N - 6*M*M + 8/3*N, if M <= N, C floating point operations and is numerically backward stable. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESQR). C C KEYWORDS C C Elementary matrix operations, orthogonal symplectic matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDB, LDWORK, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), CS(*), DWORK(*), TAU(*) C .. Local Scalars .. INTEGER I, K DOUBLE PRECISION ALPHA, NU, TEMP C .. External Subroutines .. EXTERNAL DLARF, DLARFG, DLARTG, DROT, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C C .. Executable Statements .. C C Check the scalar input parameters. 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 ( LDB.LT.MAX( 1, M ) ) THEN INFO = -6 ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN DWORK(1) = DBLE( MAX( 1, N ) ) INFO = -10 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04SU', -INFO ) RETURN END IF C C Quick return if possible. C K = MIN( M,N ) IF ( K.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C DO 10 I = 1, K C C Generate elementary reflector H(i) to annihilate B(i+1:m,i). C ALPHA = B(I,I) CALL DLARFG( M-I+1, ALPHA, B(MIN( I+1,M ),I), 1, NU ) C C Apply H(i) to A(i:m,i:n) and B(i:m,i+1:n) from the left. C B(I,I) = ONE CALL DLARF( 'Left', M-I+1, N-I+1, B(I,I), 1, NU, A(I,I), LDA, $ DWORK ) IF ( I.LT.N ) $ CALL DLARF( 'Left', M-I+1, N-I, B(I,I), 1, NU, B(I,I+1), $ LDB, DWORK ) B(I,I) = NU C C Generate symplectic Givens rotation G(i) to annihilate C B(i,i). C TEMP = A(I,I) CALL DLARTG( TEMP, ALPHA, CS(2*I-1), CS(2*I), A(I,I) ) IF ( I.LT.N ) THEN C C Apply G(i) to [ A(i,i+1:n); B(i,i+1:n) ] from the left. C CALL DROT( N-I, A(I,I+1), LDA, B(I,I+1), LDB, CS(2*I-1), $ CS(2*I) ) END IF C C Generate elementary reflector F(i) to annihilate A(i+1:m,i). C CALL DLARFG( M-I+1, A(I,I), A(MIN( I+1,M ),I), 1, TAU(I) ) IF ( I.LT.N ) THEN C C Apply F(i) to A(i:m,i+1:n) and B(i:m,i+1:n) from the C left. C TEMP = 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 ) CALL DLARF( 'Left', M-I+1, N-I, A(I,I), 1, TAU(I), B(I,I+1), $ LDB, DWORK ) A(I,I) = TEMP END IF 10 CONTINUE DWORK(1) = DBLE(MAX( 1, N )) RETURN C *** Last line of MB04SU *** END control-4.1.2/src/slicot/src/PaxHeaders/MB05ND.f0000644000000000000000000000013215012430707016162 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB05ND.f0000644000175000017500000002603415012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE MB05ND( N, DELTA, A, LDA, EX, LDEX, EXINT, LDEXIN, $ TOL, IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute C C (a) F(delta) = exp(A*delta) and C C (b) H(delta) = Int[F(s) ds] from s = 0 to s = delta, C C where A is a real N-by-N matrix and delta is a scalar value. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C DELTA (input) DOUBLE PRECISION C The scalar value delta of the problem. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must contain the C matrix A of the problem. (Array A need not be set if C DELTA = 0.) C C LDA INTEGER C The leading dimension of array A. LDA >= max(1,N). C C EX (output) DOUBLE PRECISION array, dimension (LDEX,N) C The leading N-by-N part of this array contains an C approximation to F(delta). C C LDEX INTEGER C The leading dimension of array EX. LDEX >= MAX(1,N). C C EXINT (output) DOUBLE PRECISION array, dimension (LDEXIN,N) C The leading N-by-N part of this array contains an C approximation to H(delta). C C LDEXIN INTEGER C The leading dimension of array EXINT. LDEXIN >= MAX(1,N). C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in determining the order of the C Pade approximation to H(t), where t is a scale factor C determined by the routine. A reasonable value for TOL may C be SQRT(EPS), where EPS is the machine precision (see C LAPACK Library routine DLAMCH). 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) returns the optimal value C of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,N*(N+1)). C For optimum performance LDWORK should be larger (2*N*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 > 0: if INFO = i, the (i,i) element of the denominator of C the Pade approximation is zero, so the denominator C is exactly singular; C = N+1: if DELTA = (delta * frobenius norm of matrix A) is C probably too large to permit meaningful computation. C That is, DELTA > SQRT(BIG), where BIG is a C representable number near the overflow threshold of C the machine (see LAPACK Library Routine DLAMCH). C C METHOD C C This routine uses a Pade approximation to H(t) for some small C value of t (where 0 < t <= delta) and then calculates F(t) from C H(t). Finally, the results are re-scaled to give F(delta) and C H(delta). For a detailed description of the implementation of this C algorithm see [1]. C C REFERENCES C C [1] Benson, C.J. C The numerical evaluation of the matrix exponential and its C integral. C Report 82/03, Control Systems Research Group, C School of Electronic Engineering and Computer C Science, Kingston Polytechnic, January 1982. C C [2] Ward, R.C. C Numerical computation of the matrix exponential with accuracy C estimate. C SIAM J. Numer. Anal., 14, pp. 600-610, 1977. C C [3] Moler, C.B. and Van Loan, C.F. C Nineteen Dubious Ways to Compute the Exponential of a Matrix. C SIAM Rev., 20, pp. 801-836, 1978. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. C Supersedes Release 2.0 routine MB05BD by C.J. Benson, Kingston C Polytechnic, January 1982. C C REVISIONS C C - C C KEYWORDS C C Continuous-time system, matrix algebra, matrix exponential, C matrix operations, Pade approximation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, ONE64, THREE, FOUR8 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, $ ONE64 = 1.64D0, THREE = 3.0D0, FOUR8 = 4.8D0 ) C .. Scalar Arguments .. INTEGER INFO, LDA, LDEX, LDEXIN, LDWORK, N DOUBLE PRECISION DELTA, TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), DWORK(*), EX(LDEX,*), EXINT(LDEXIN,*) C .. Local Scalars .. INTEGER I, I2IQ1, IJ, IQ, J, JSCAL, KK, L, NN DOUBLE PRECISION COEFFD, COEFFN, DELSC, EPS, ERR, F2IQ1, $ FNORM, FNORM2, QMAX, SMALL C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGESV, DLACPY, $ DLASET, DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, EXP, MAX, MOD, SQRT C .. Executable Statements .. C INFO = 0 NN = N*N C C Test the input scalar arguments. C IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDEX.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDEXIN.LT.MAX( 1, N ) ) THEN INFO = -8 ELSE IF( LDWORK.LT.MAX( 1, NN + N ) ) THEN INFO = -12 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MB05ND', -INFO ) RETURN END IF C C Quick return if possible. C DWORK(1) = ONE IF ( N.EQ.0 ) $ RETURN C CALL DLASET( 'Full', N, N, ZERO, ZERO, EX, LDEX ) CALL DLASET( 'Full', N, N, ZERO, ZERO, EXINT, LDEXIN ) C IF ( DELTA.EQ.ZERO ) THEN CALL DLASET( 'Upper', N, N, ZERO, ONE, EX, LDEX ) RETURN END IF C IF ( N.EQ.1 ) THEN EX(1,1) = EXP( DELTA*A(1,1) ) IF ( A(1,1).EQ.ZERO ) THEN EXINT(1,1) = DELTA ELSE EXINT(1,1) = ( ( ONE/A(1,1) )*EX(1,1) ) - ( ONE/A(1,1) ) END IF RETURN END IF C C Set some machine parameters. C EPS = DLAMCH( 'Epsilon' ) SMALL = DLAMCH( 'Safe minimum' )/EPS C C First calculate the Frobenius norm of A, and the scaling factor. C FNORM = DELTA*DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) C IF ( FNORM.GT.SQRT( ONE/SMALL ) ) THEN INFO = N + 1 RETURN END IF C JSCAL = 0 DELSC = DELTA C WHILE ( FNORM >= HALF ) DO 20 CONTINUE IF ( FNORM.GE.HALF ) THEN JSCAL = JSCAL + 1 DELSC = DELSC*HALF FNORM = FNORM*HALF GO TO 20 END IF C END WHILE 20 C C Calculate the order of the Pade approximation needed to satisfy C the requested relative error TOL. C FNORM2 = FNORM**2 IQ = 1 QMAX = FNORM/THREE ERR = DELTA/DELSC*FNORM2**2/FOUR8 C WHILE ( ERR > TOL*( 2*IQ + 3 - FNORM )/1.64 and QMAX >= EPS ) DO 40 CONTINUE IF ( ERR.GT.TOL*( DBLE( 2*IQ + 3 ) - FNORM )/ONE64 ) THEN IQ = IQ + 1 QMAX = QMAX*DBLE( IQ + 1 )*FNORM/DBLE( 2*IQ*( 2*IQ + 1 ) ) IF ( QMAX.GE.EPS ) THEN ERR = ERR*FNORM2*DBLE( 2*IQ + 5 )/DBLE( ( 2*IQ + 3 )**2 $ *( 2*IQ + 4 ) ) GO TO 40 END IF END IF C END WHILE 40 C C Initialise DWORK (to contain succesive powers of A), C EXINT (to contain the numerator) and C EX (to contain the denominator). C I2IQ1 = 2*IQ + 1 F2IQ1 = DBLE( I2IQ1 ) COEFFD = -DBLE( IQ )/F2IQ1 COEFFN = HALF/F2IQ1 IJ = 1 C DO 80 J = 1, N C DO 60 I = 1, N DWORK(IJ) = DELSC*A(I,J) EXINT(I,J) = COEFFN*DWORK(IJ) EX(I,J) = COEFFD*DWORK(IJ) IJ = IJ + 1 60 CONTINUE C EXINT(J,J) = EXINT(J,J) + ONE EX(J,J) = EX(J,J) + ONE 80 CONTINUE C DO 140 KK = 2, IQ C C Calculate the next power of A*DELSC, and update the numerator C and denominator. C COEFFD = -COEFFD*DBLE( IQ+1-KK )/DBLE( KK*( I2IQ1+1-KK ) ) IF ( MOD( KK, 2 ).EQ.0 ) THEN COEFFN = COEFFD/DBLE( KK + 1 ) ELSE COEFFN = -COEFFD/DBLE( I2IQ1 - KK ) END IF IJ = 1 C IF ( LDWORK.GE.2*NN ) THEN C C Enough space for a BLAS 3 calculation. C CALL DGEMM( 'No transpose', 'No transpose', N, N, N, DELSC, $ A, LDA, DWORK, N, ZERO, DWORK(NN+1), N ) CALL DCOPY( NN, DWORK(NN+1), 1, DWORK, 1 ) C DO 100 J = 1, N CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 ) CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 ) IJ = IJ + N 100 CONTINUE C ELSE C C Not enough space for a BLAS 3 calculation. Use BLAS 2. C DO 120 J = 1, N CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, DWORK(IJ), $ 1, ZERO, DWORK(NN+1), 1 ) CALL DCOPY( N, DWORK(NN+1), 1, DWORK(IJ), 1 ) CALL DSCAL( N, DELSC, DWORK(IJ), 1 ) CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 ) CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 ) IJ = IJ + N 120 CONTINUE C END IF 140 CONTINUE C C We now have numerator in EXINT, denominator in EX. C C Solve the set of N systems of linear equations for the columns of C EXINT using the LU factorization of EX. C CALL DGESV( N, N, EX, LDEX, IWORK, EXINT, LDEXIN, INFO ) IF ( INFO.NE.0 ) $ RETURN C C Now we can form EX from EXINT using the formula: C EX = EXINT * A + I C DO 160 J = 1, N CALL DSCAL( N, DELSC, EXINT(1,J), 1 ) 160 CONTINUE C CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, EXINT, $ LDEXIN, A, LDA, ZERO, EX, LDEX ) C DO 180 J = 1, N EX(J,J) = EX(J,J) + ONE 180 CONTINUE C C EX and EXINT have been evaluated at DELSC, so the results C must be re-scaled to give the function values at DELTA. C C EXINT(2t) = EXINT(t) * ^ EX(t) + I [ C EX(2t) = EX(t) * EX(t) C C DWORK is used to accumulate products. C DO 200 L = 1, JSCAL CALL DLACPY( 'Full', N, N, EXINT, LDEXIN, DWORK, N ) CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, $ DWORK, N, EX, LDEX, ONE, EXINT, LDEXIN ) CALL DLACPY( 'Full', N, N, EX, LDEX, DWORK, N ) CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, $ DWORK, N, DWORK, N, ZERO, EX, LDEX ) 200 CONTINUE C DWORK(1) = 2*NN RETURN C *** Last line of MB05ND *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04PU.f0000644000000000000000000000013215012430707016204 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04PU.f0000644000175000017500000002703215012430707017404 0ustar00lilgelilge00000000000000 SUBROUTINE MB04PU( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To reduce a Hamiltonian matrix, C C [ A G ] C H = [ T ] , C [ Q -A ] C C where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices, C to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U C is computed so that C C T [ Aout Gout ] C U H U = [ T ] , C [ Qout -Aout ] C C where Aout is upper Hessenberg and Qout is diagonal. C Unblocked version. C C ARGUMENTS C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C ILO (input) INTEGER C It is assumed that A is already upper triangular and Q is C zero in rows and columns 1:ILO-1. ILO is normally set by a C previous call to MB04DD; otherwise it should be set to 1. C 1 <= ILO <= N, if N > 0; ILO = 1, if 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. C On exit, the leading N-by-N part of this array contains C the matrix Aout and, in the zero part of Aout, C information about the elementary reflectors used to C compute the PVL factorization. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C QG (input/output) DOUBLE PRECISION array, dimension C (LDQG,N+1) C On entry, the leading N-by-N+1 part of this array must C contain the lower triangular part of the matrix Q and C the upper triangular part of the matrix G. C On exit, the leading N-by-N+1 part of this array contains C the diagonal of the matrix Qout, the upper triangular part C of the matrix Gout and, in the zero parts of Qout, C information about the elementary reflectors used to C compute the PVL factorization. C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= MAX(1,N). C C CS (output) DOUBLE PRECISION array, dimension (2N-2) C On exit, the first 2N-2 elements of this array contain the C cosines and sines of the symplectic Givens rotations used C to compute the PVL factorization. C C TAU (output) DOUBLE PRECISION array, dimension (N-1) C On exit, the first N-1 elements of this array contain the C scalar factors of some of the elementary reflectors. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -10, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,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 matrix U is represented as a product of symplectic reflectors C and Givens rotations C C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) C .... C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). C C Each H(i) has the form C C H(i) = I - tau * v * v' C C where tau is a real scalar, and v is a real vector with C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in C QG(i+2:n,i), and tau in QG(i+1,i). C C Each F(i) has the form C C F(i) = I - nu * w * w' C C where nu is a real scalar, and w is a real vector with C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in C A(i+2:n,i), and nu in TAU(i). C C Each G(i) is a Givens rotation acting on rows i+1 and n+i+1, C where the cosine is stored in CS(2*i-1) and the sine in C CS(2*i). C C NUMERICAL ASPECTS C C The algorithm requires 40/3 N**3 + O(N) floating point operations C and is strongly backward stable. C C REFERENCES C C [1] C. F. VAN LOAN: C A symplectic method for approximating all the eigenvalues of C a Hamiltonian matrix. C Linear Algebra and its Applications, 61, pp. 233-251, 1984. C C CONTRIBUTORS C C D. Kressner (Technical Univ. Berlin, Germany) and C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. C C REVISIONS C C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DHAPVL). C C KEYWORDS C C Elementary matrix operations, Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) C .. Scalar Arguments .. INTEGER ILO, INFO, LDA, LDQG, LDWORK, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION ALPHA, C, MU, NU, S, TEMP, TTEMP C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. External Subroutines .. EXTERNAL DAXPY, DLARF, DLARFG, DLARTG, DROT, DSYMV, $ DSYR2, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN C C .. Executable Statements .. C C Check the scalar input parameters. C INFO = 0 IF ( N.LT.0 ) THEN INFO = -1 ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN INFO = -2 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF ( LDWORK.LT.MAX( 1, N-1 ) ) THEN DWORK(1) = DBLE( MAX( 1, N-1 ) ) INFO = -10 END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB04PU', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.LE.ILO ) THEN DWORK(1) = ONE RETURN END IF C DO 10 I = ILO, N-1 C C Generate elementary reflector H(i) to annihilate QG(i+2:n,i). C ALPHA = QG(I+1,I) CALL DLARFG( N-I, ALPHA, QG(MIN( I+2,N ),I), 1, NU ) IF ( NU.NE.ZERO ) THEN QG(I+1,I) = ONE C C Apply H(i) from both sides to QG(i+1:n,i+1:n). C Compute x := nu * QG(i+1:n,i+1:n) * v. C CALL DSYMV( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, QG(I+1,I), $ 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( N-I, DWORK, 1, QG(I+1,I), 1 ) CALL DAXPY( N-I, MU, QG(I+1,I), 1, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C QG := QG - v * w' - w * v'. C CALL DSYR2( 'Lower', N-I, -ONE, QG(I+1,I), 1, DWORK, 1, $ QG(I+1,I+1), LDQG ) C C Apply H(i) from the right hand side to QG(1:i,i+2:n+1). C CALL DLARF( 'Right', I, N-I, QG(I+1,I), 1, NU, QG(1,I+2), $ LDQG, DWORK ) C C Apply H(i) from both sides to QG(i+1:n,i+2:n+1). C Compute x := nu * QG(i+1:n,i+2:n+1) * v. C CALL DSYMV( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, QG(I+1,I), $ 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * nu * (x'*v) * v. C MU = -HALF*NU*DDOT( N-I, DWORK, 1, QG(I+1,I), 1 ) CALL DAXPY( N-I, MU, QG(I+1,I), 1, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) - v * w' - w * v'. C CALL DSYR2( 'Upper', N-I, -ONE, QG(I+1,I), 1, DWORK, 1, $ QG(I+1,I+2), LDQG ) C C Apply H(i) from the left hand side to A(i+1:n,i:n). C CALL DLARF( 'Left', N-I, N-I+1, QG(I+1,I), 1, NU, $ A(I+1,I), LDA, DWORK ) C C Apply H(i) from the right hand side to A(1:n,i+1:n). C CALL DLARF( 'Right', N, N-I, QG(I+1,I), 1, NU, $ A(1,I+1), LDA, DWORK ) END IF QG(I+1,I) = NU C C Generate symplectic Givens rotation G(i) to annihilate C QG(i+1,i). C TEMP = A(I+1,I) CALL DLARTG( TEMP, ALPHA, C, S, A(I+1,I) ) C C Apply G(i) to [A(I+1,I+2:N); QG(I+2:N,I+1)']. C CALL DROT( N-I-1, A(I+1,I+2), LDA, QG(I+2,I+1), 1, C, S ) C C Apply G(i) to [A(1:I,I+1) QG(1:I,I+2)]. C CALL DROT(I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) C C Apply G(i) to [A(I+2:N,I+1) QG(I+1, I+3:N+1)'] from the right. C CALL DROT(N-I-1, A(I+2,I+1), 1, QG(I+1,I+3), LDQG, C, S ) C C Fix the diagonal part. C TEMP = A(I+1,I+1) TTEMP = QG(I+1,I+2) A(I+1,I+1) = C*TEMP + S*QG(I+1,I+1) QG(I+1,I+2) = C*TTEMP - S * TEMP QG(I+1,I+1) = -S*TEMP + C*QG(I+1,I+1) TTEMP = -S*TTEMP - C*TEMP TEMP = A(I+1,I+1) QG(I+1,I+1) = C*QG(I+1,I+1) + S*TTEMP A(I+1,I+1) = C*TEMP + S*QG(I+1,I+2) QG(I+1,I+2) = -S*TEMP + C*QG(I+1,I+2) CS(2*I-1) = C CS(2*I) = S C C Generate elementary reflector F(i) to annihilate A(i+2:n,i). C CALL DLARFG( N-I, A(I+1,I), A(MIN( I+2,N ),I), 1, NU ) IF ( NU.NE.ZERO ) THEN TEMP = A(I+1,I) A(I+1,I) = ONE C C Apply F(i) from the left hand side to A(i+1:n,i+1:n). C CALL DLARF( 'Left', N-I, N-I, A(I+1,I), 1, NU, A(I+1,I+1), $ LDA, DWORK ) C C Apply G(i) from the right hand side to A(1:n,i+1:n). C CALL DLARF( 'Right', N, N-I, A(I+1,I), 1, NU, $ A(1,I+1), LDA, DWORK ) C C Apply G(i) from both sides to QG(i+1:n,i+1:n). C Compute x := nu * QG(i+1:n,i+1:n) * v. C CALL DSYMV( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, A(I+1,I), $ 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * tau * (x'*v) * v. C MU = -HALF*NU*DDOT( N-I, DWORK, 1, A(I+1,I), 1 ) CALL DAXPY( N-I, MU, A(I+1,I), 1, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C QG := QG - v * w' - w * v'. C CALL DSYR2( 'Lower', N-I, -ONE, A(I+1,I), 1, DWORK, 1, $ QG(I+1,I+1), LDQG ) C C Apply G(i) from the right hand side to QG(1:i,i+2:n+1). C CALL DLARF( 'Right', I, N-I, A(I+1,I), 1, NU, QG(1,I+2), $ LDQG, DWORK ) C C Apply G(i) from both sides to QG(i+1:n,i+2:n+1). C Compute x := nu * QG(i+1:n,i+2:n+1) * v. C CALL DSYMV( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, A(I+1,I), $ 1, ZERO, DWORK, 1 ) C C Compute w := x - 1/2 * tau * (x'*v) * v. C MU = -HALF*NU*DDOT( N-I, DWORK, 1, A(I+1,I), 1 ) CALL DAXPY( N-I, MU, A(I+1,I), 1, DWORK, 1 ) C C Apply the transformation as a rank-2 update: C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) - v * w' - w * v'. C CALL DSYR2( 'Upper', N-I, -ONE, A(I+1,I), 1, DWORK, 1, $ QG(I+1,I+2), LDQG ) A(I+1,I) = TEMP END IF TAU(I) = NU 10 CONTINUE DWORK(1) = DBLE( MAX( 1, N-1 ) ) RETURN C *** Last line of MB04PU *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03DD.f0000644000000000000000000000013215012430707016146 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03DD.f0000644000175000017500000005575715012430707017365 0ustar00lilgelilge00000000000000 SUBROUTINE MB03DD( UPLO, N1, N2, PREC, A, LDA, B, LDB, Q1, LDQ1, $ Q2, LDQ2, DWORK, LDWORK, INFO ) C C PURPOSE C C To compute orthogonal matrices Q1 and Q2 for a real 2-by-2, C 3-by-3, or 4-by-4 regular block upper triangular pencil C C ( A11 A12 ) ( B11 B12 ) C aA - bB = a ( ) - b ( ), (1) C ( 0 A22 ) ( 0 B22 ) C C such that the pencil a(Q2' A Q1) - b(Q2' B Q1) is still in block C upper triangular form, but the eigenvalues in Spec(A11, B11), C Spec(A22, B22) are exchanged, where Spec(X,Y) denotes the spectrum C of the matrix pencil (X,Y) and the notation M' denotes the C transpose of the matrix M. C C Optionally, to upper triangularize the real regular pencil in C block lower triangular form C C ( A11 0 ) ( B11 0 ) C aA - bB = a ( ) - b ( ), (2) C ( A21 A22 ) ( B21 B22 ) C C while keeping the eigenvalues in the same diagonal position. C C ARGUMENTS C C Mode Parameters C C UPLO CHARACTER*1 C Specifies if the pencil is in lower or upper block C triangular form on entry, as follows: C = 'U': Upper block triangular, eigenvalues are exchanged C on exit; C = 'T': Upper block triangular, B triangular, eigenvalues C are exchanged on exit; C = 'L': Lower block triangular, eigenvalues are not C exchanged on exit. C C Input/Output Parameters C C N1 (input/output) INTEGER C Size of the upper left block, N1 <= 2. C If UPLO = 'U' or UPLO = 'T' and INFO = 0, or UPLO = 'L' C and INFO <> 0, N1 and N2 are exchanged on exit; otherwise, C N1 is unchanged on exit. C C N2 (input/output) INTEGER C Size of the lower right block, N2 <= 2. C If UPLO = 'U' or UPLO = 'T' and INFO = 0, or UPLO = 'L' C and INFO <> 0, N1 and N2 are exchanged on exit; otherwise, C N2 is unchanged on exit. C C PREC (input) DOUBLE PRECISION C The machine precision, (relative machine precision)*base. C See the LAPACK Library routine DLAMCH. C C A (input/output) DOUBLE PRECISION array, dimension C (LDA, N1+N2) C On entry, the leading (N1+N2)-by-(N1+N2) part of this C array must contain the matrix A of the pencil aA - bB. C On exit, if N1 = N2 = 1, this array is unchanged, if C UPLO = 'U' or UPLO = 'T', but, if UPLO = 'L', it contains C [ 0 1 ] C the matrix J' A J, where J = [ -1 0 ]; otherwise, this C array contains the transformed quasi-triangular matrix in C generalized real Schur form. C C LDA INTEGER C The leading dimension of the array A. LDA >= N1+N2. C C B (input/output) DOUBLE PRECISION array, dimension C (LDB, N1+N2) C On entry, the leading (N1+N2)-by-(N1+N2) part of this C array must contain the matrix B of the pencil aA - bB. C On exit, if N1 = N2 = 1, this array is unchanged, if C UPLO = 'U' or UPLO = 'T', but, if UPLO = 'L', it contains C the matrix J' B J; otherwise, this array contains the C transformed upper triangular matrix in generalized real C Schur form. C C LDB INTEGER C The leading dimension of the array B. LDB >= N1+N2. C C Q1 (output) DOUBLE PRECISION array, dimension (LDQ1, N1+N2) C The leading (N1+N2)-by-(N1+N2) part of this array contains C the first orthogonal transformation matrix. C C LDQ1 INTEGER C The leading dimension of the array Q1. LDQ1 >= N1+N2. C C Q2 (output) DOUBLE PRECISION array, dimension (LDQ2, N1+N2) C The leading (N1+N2)-by-(N1+N2) part of this array contains C the second orthogonal transformation matrix. C C LDQ2 INTEGER C The leading dimension of the array Q2. LDQ2 >= N1+N2. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C If N1+N2 = 2 then DWORK is not referenced. C C LDWORK INTEGER C The dimension of the array DWORK. C If N1+N2 = 2, then LDWORK = 0; otherwise, C LDWORK >= 16*N1 + 10*N2 + 23, if UPLO = 'U'; C LDWORK >= 7*N1 + 7*N2 + 16, if UPLO = 'T'; C LDWORK >= 10*N1 + 16*N2 + 23, if UPLO = 'L'. C For good performance LDWORK should be generally larger. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C = 3: the QZ iteration failed in the LAPACK routine DGGES C (if UPLO <> 'T') or DHGEQZ (if UPLO = 'T'); C = 4: another error occured during execution of DHGEQZ; C = 5: reordering of aA - bB in the LAPACK routine DTGSEN C failed because the transformed matrix pencil aA - bB C would be too far from generalized Schur form; C the problem is very ill-conditioned. C C METHOD C C The algorithm uses orthogonal transformations as described in [2] C (page 30). The QZ algorithm is used for N1 = 2 or N2 = 2, but it C always acts on an upper block triangular pencil. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical computation of deflating subspaces of skew- C Hamiltonian/Hamiltonian pencils. C SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002. C C [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H. C Numerical Solution of Real Skew-Hamiltonian/Hamiltonian C Eigenproblems. C Tech. Rep., Technical University Chemnitz, Germany, C Nov. 2007. C C NUMERICAL ASPECTS C C The algorithm is numerically backward stable. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, October 16, 2008. C C REVISIONS C C V. Sima, July 2009 (SLICOT version of the routine DBTUEX). C V. Sima, Nov. 2009, Oct. 2010, Nov. 2010, Mar. 2016, Apr. 2016, C May 2016. C M. Voigt, Jan. 2012. C C KEYWORDS C C Block triangular pencil, eigenvalue exchange. C C ****************************************************************** C DOUBLE PRECISION ZERO, ONE, TEN, HUND PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1, $ HUND = 1.0D+2 ) C C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDA, LDB, LDQ1, LDQ2, LDWORK, N1, N2 DOUBLE PRECISION PREC C C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), $ Q1( LDQ1, * ), Q2( LDQ2, * ) C C .. Local Scalars .. LOGICAL AEVINF, EVINF, LTRIU, LUPLO INTEGER CNT, EVSEL, I, IAEV, IDUM, IEVS, ITMP, J, M DOUBLE PRECISION A11, A22, ABSAEV, ABSEV, ADIF, B11, B22, CO, $ CO1, E, G, MX, NRA, NRB, SFMIN, SI, SI1, TMP, $ TOL, TOLB C C .. Local Arrays .. LOGICAL BWORK( 1 ), OUT( 2 ), SLCT( 4 ) INTEGER IDM( 2 ) DOUBLE PRECISION AS( 2, 2 ), BS( 2, 2 ), DUM( 8 ) C C .. External Functions .. LOGICAL LSAME, SB02OW DOUBLE PRECISION DLAMCH, DLANGE, DLANHS EXTERNAL DLAMCH, DLANGE, DLANHS, LSAME, SB02OW C C .. External Subroutines .. EXTERNAL DCOPY, DGGES, DHGEQZ, DLACPY, DLAG2, DLARTG, $ DLASET, DROT, DSWAP, DTGEX2, DTGSEN, MB01QD C C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN C C .. Executable Statements .. C C Decode the input arguments. C LTRIU = LSAME( UPLO, 'T' ) LUPLO = LSAME( UPLO, 'U' ) .OR. LTRIU C C For efficiency, the input arguments are not tested. C INFO = 0 C C Computations. 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 M = N1 + N2 IF( M.GT.2 ) THEN IF( .NOT.LUPLO ) THEN C C Make the pencil upper block triangular. C Quick return if A21 = 0 and B21 = 0. C IF( DLANGE( '1-norm', N2, N1, A( N1+1, 1 ), LDA, DWORK ) $ .EQ.ZERO .AND. $ DLANGE( '1-norm', N2, N1, B( N1+1, 1 ), LDB, DWORK ) $ .EQ.ZERO ) THEN IF( N1.EQ.2 ) THEN CALL DGGES( 'Vectors', 'Vectors', 'Not sorted', $ SB02OW, N1, A, LDA, B, LDB, IDUM, DWORK, $ DWORK( M+1 ), DWORK( 2*M+1 ), Q2, LDQ2, $ Q1, LDQ1, DWORK( 3*M+1 ), LDWORK-2*M, $ BWORK, INFO ) IF( INFO.NE.0 ) THEN IF( INFO.GE.1 .AND. INFO.LE.N1 ) THEN INFO = 3 RETURN ELSE INFO = 4 RETURN END IF END IF IF( N2.EQ.1 ) THEN Q1( 3, 3 ) = ONE Q2( 3, 3 ) = ONE END IF END IF IF( N2.EQ.2 ) THEN CALL DGGES( 'Vectors', 'Vectors', 'Not sorted', $ SB02OW, N2, A( N1+1, N1+1 ), LDA, $ B( N1+1, N1+1 ), LDB, IDUM, DWORK( N1+1 ), $ DWORK( M+N1+1 ), DWORK( 2*M+N1+1 ), $ Q2( N1+1, N1+1 ), LDQ2, Q1( N1+1, N1+1 ), $ LDQ1, DWORK( 3*M+1 ), LDWORK-2*M, BWORK, $ INFO ) IF( INFO.NE.0 ) THEN IF( INFO.GE.1 .AND. INFO.LE.N2 ) THEN INFO = 3 RETURN ELSE INFO = 4 RETURN END IF END IF IF( N1.EQ.1 ) THEN Q1( 1, 1 ) = ONE Q2( 1, 1 ) = ONE END IF END IF CALL DLASET( 'Full', N2, N1, ZERO, ZERO, Q1( N1+1, 1 ), $ LDQ1 ) CALL DLASET( 'Full', N1, N2, ZERO, ZERO, Q1( 1, N1+1 ), $ LDQ1 ) CALL DLASET( 'Full', N2, N1, ZERO, ZERO, Q2( N1+1, 1 ), $ LDQ2 ) CALL DLASET( 'Full', N1, N2, ZERO, ZERO, Q2( 1, N1+1 ), $ LDQ2 ) RETURN END IF IF( N1.EQ.1 ) THEN DUM( 1 ) = A( 1, 1 ) DUM( 2 ) = A( 2, 1 ) A( 1, 1 ) = A( 2, 2 ) A( 2, 1 ) = A( 3, 2 ) A( 1, 2 ) = A( 2, 3 ) A( 2, 2 ) = A( 3, 3 ) A( 1, 3 ) = DUM( 2 ) A( 2, 3 ) = A( 3, 1 ) A( 3, 3 ) = DUM( 1 ) A( 3, 1 ) = ZERO A( 3, 2 ) = ZERO DUM( 1 ) = B( 1, 1 ) DUM( 2 ) = B( 2, 1 ) B( 1, 1 ) = B( 2, 2 ) B( 2, 1 ) = B( 3, 2 ) B( 1, 2 ) = B( 2, 3 ) B( 2, 2 ) = B( 3, 3 ) B( 1, 3 ) = DUM( 2 ) B( 2, 3 ) = B( 3, 1 ) B( 3, 3 ) = DUM( 1 ) B( 3, 1 ) = ZERO B( 3, 2 ) = ZERO ELSE IF( N2.EQ.1 ) THEN DUM( 1 ) = A( 3, 2 ) DUM( 2 ) = A( 3, 3 ) A( 2, 3 ) = A( 1, 2 ) A( 3, 3 ) = A( 2, 2 ) A( 2, 2 ) = A( 1, 1 ) A( 3, 2 ) = A( 2, 1 ) A( 1, 1 ) = DUM( 2 ) A( 1, 2 ) = A( 3, 1 ) A( 1, 3 ) = DUM( 1 ) A( 2, 1 ) = ZERO A( 3, 1 ) = ZERO DUM( 1 ) = B( 3, 2 ) DUM( 2 ) = B( 3, 3 ) B( 2, 3 ) = B( 1, 2 ) B( 3, 3 ) = B( 2, 2 ) B( 2, 2 ) = B( 1, 1 ) B( 3, 2 ) = B( 2, 1 ) B( 1, 1 ) = DUM( 2 ) B( 1, 2 ) = B( 3, 1 ) B( 1, 3 ) = DUM( 1 ) B( 2, 1 ) = ZERO B( 3, 1 ) = ZERO ELSE C DO 10 J = 1, N1 CALL DSWAP( N1, A( 1, J ), 1, A( N1+1, N1+J ), 1 ) CALL DSWAP( N1, A( 1, N1+J ), 1, A( N1+1, J ), 1 ) CALL DSWAP( N1, B( 1, J ), 1, B( N1+1, N1+J ), 1 ) CALL DSWAP( N1, B( 1, N1+J ), 1, B( N1+1, J ), 1 ) 10 CONTINUE C END IF C ITMP = N1 N1 = N2 N2 = ITMP END IF C C Apply the QZ algorithm and order the eigenvalues in C DWORK(1:3*N1) to the top. C Note that N1 and N2 are interchanged for UPLO = 'L'. C IEVS = 3*N1 + 1 IAEV = IEVS + 3*N1 IF( N1.EQ.1 ) THEN DWORK( 1 ) = A( 1, 1 )*SIGN( ONE, B( 1, 1 ) ) DWORK( 2 ) = ZERO DWORK( 3 ) = ABS( B( 1, 1 ) ) ELSE SFMIN = DLAMCH( 'Safemin' ) Q1( 1, 1 ) = A( 1, 1 ) Q1( 2, 1 ) = A( 2, 1 ) Q1( 1, 2 ) = A( 1, 2 ) Q1( 2, 2 ) = A( 2, 2 ) Q2( 1, 1 ) = B( 1, 1 ) Q2( 2, 1 ) = B( 2, 1 ) Q2( 1, 2 ) = B( 1, 2 ) Q2( 2, 2 ) = B( 2, 2 ) IF( .NOT.LTRIU .AND. B( 2, 1 ).NE.ZERO ) THEN C C Triangularize B11 and update A11. C A11 = ABS( Q1( 1, 1 ) ) A22 = ABS( Q1( 2, 2 ) ) B11 = ABS( Q2( 1, 1 ) ) B22 = ABS( Q2( 2, 2 ) ) MX = MAX( A11 + ABS( Q1( 2, 1 ) ), $ A22 + ABS( Q1( 1, 2 ) ), $ B11 + ABS( Q2( 2, 1 ) ), $ B22 + ABS( Q2( 1, 2 ) ), SFMIN ) Q1( 1, 1 ) = Q1( 1, 1 ) / MX Q1( 2, 1 ) = Q1( 2, 1 ) / MX Q1( 1, 2 ) = Q1( 1, 2 ) / MX Q1( 2, 2 ) = Q1( 2, 2 ) / MX Q2( 1, 1 ) = Q2( 1, 1 ) / MX Q2( 2, 1 ) = Q2( 2, 1 ) / MX Q2( 1, 2 ) = Q2( 1, 2 ) / MX Q2( 2, 2 ) = Q2( 2, 2 ) / MX CALL DLARTG( Q2( 1, 1 ), Q2( 2, 1 ), CO, SI, E ) CALL DLARTG( Q2( 2, 2 ), Q2( 2, 1 ), CO1, SI1, G ) IF( ABS( CO *B( 2, 1 ) - SI *B( 1, 1 ) ).LE. $ ABS( CO1*B( 2, 1 ) - SI1*B( 2, 2 ) ) ) THEN CALL DROT( 2, Q1( 1, 1 ), LDQ1, Q1( 2, 1 ), LDQ1, CO, $ SI ) Q2( 1, 1 ) = E TMP = Q2( 1, 2 ) Q2( 1, 2 ) = SI*Q2( 2, 2 ) + CO*TMP Q2( 2, 2 ) = CO*Q2( 2, 2 ) - SI*TMP ELSE CALL DROT( 2, Q1( 1, 2 ), 1, Q1( 1, 1 ), 1, CO1, SI1 ) Q2( 2, 2 ) = G TMP = Q2( 1, 2 ) Q2( 1, 2 ) = SI1*Q2( 1, 1 ) + CO1*TMP Q2( 1, 1 ) = CO1*Q2( 1, 1 ) - SI1*TMP END IF Q2( 2, 1 ) = ZERO END IF CALL DLAG2( Q1, LDQ1, Q2, LDQ2, SFMIN*HUND, DWORK( 2*N1+1 ), $ DWORK( 2*N1+2 ), DWORK( 1 ), DWORK( 2 ), $ DWORK( N1+1 ) ) DWORK( N1+2 ) = -DWORK( N1+1 ) END IF C ITMP = IAEV + 3*M CALL DCOPY( 3*N1, DWORK, 1, DWORK( IEVS ), 1 ) IF( LTRIU ) THEN C C Workspace: need 10*N1 + 4*N2. C CALL DHGEQZ( 'Schur', 'Identity', 'Identity', M, 1, M, A, $ LDA, B, LDB, DWORK( IAEV ), DWORK( IAEV+M ), $ DWORK( IAEV+2*M ), Q2, LDQ2, Q1, LDQ1, $ DWORK( ITMP ), LDWORK-ITMP+1, INFO ) IF( INFO.GE.1 .AND. INFO.LE.M ) THEN INFO = 3 RETURN ELSE IF( INFO.NE.0 ) THEN INFO = 4 RETURN END IF ELSE C C Workspace: need 16*N1 + 10*N2 + 23; C prefer larger. C CALL DGGES( 'Vectors', 'Vectors', 'Not sorted', SB02OW, M, $ A, LDA, B, LDB, IDUM, DWORK( IAEV ), $ DWORK( IAEV+M ), DWORK( IAEV+2*M ), Q2, LDQ2, $ Q1, LDQ1, DWORK( ITMP ), LDWORK-ITMP+1, BWORK, $ INFO ) IF( INFO.NE.0 ) THEN IF( INFO.GE.1 .AND. INFO.LE.M ) THEN INFO = 3 RETURN ELSE INFO = 4 RETURN END IF END IF END IF C TOL = PREC TOLB = TEN*PREC EVSEL = 0 DO 20 I = 1, M SLCT( I ) = .TRUE. 20 CONTINUE C C WHILE( EVSEL.EQ.0 ) DO C 30 CONTINUE IF( EVSEL.EQ.0 ) THEN CNT = 0 OUT( 1 ) = .FALSE. OUT( 2 ) = .FALSE. C DO 50 I = IAEV, IAEV + M - 1 AEVINF = ABS( DWORK( 2*M+I ) ).LT.PREC* $ ( ABS( DWORK( I ) ) + ABS( DWORK( M+I ) ) ) DO 40 J = 1, N1 C C Check if an eigenvalue is selected and check if it C is infinite. C EVINF = ABS( DWORK( 2*N1+J ) ).LT.PREC* $ ( ABS( DWORK( J ) ) + ABS( DWORK( N1+J ) ) ) IF( ( .NOT. EVINF .OR. AEVINF ) .AND. $ ( .NOT.AEVINF .OR. EVINF ) .AND. $ .NOT. OUT( J ) ) THEN IF( .NOT.EVINF .OR. .NOT.AEVINF ) THEN ADIF = ABS( DWORK( J )/DWORK( 2*N1+J ) - $ DWORK( I )/DWORK( 2*M+I ) ) + $ ABS( DWORK( N1+J )/DWORK( 2*N1+J ) - $ DWORK( M+I )/DWORK( 2*M+I ) ) ABSEV = ABS( DWORK( J )/DWORK( 2*N1+J ) ) + $ ABS( DWORK( N1+J )/DWORK( 2*N1+J ) ) ABSAEV = ABS( DWORK( I )/DWORK( 2*M+I ) ) + $ ABS( DWORK( M+I )/DWORK( 2*M+I ) ) IF( ADIF.LE.TOL*MAX( TOLB, ABSEV, ABSAEV ) ) $ THEN SLCT( I-IAEV+1 ) = .FALSE. OUT( J ) = .TRUE. CNT = CNT + 1 END IF ELSE SLCT( I-IAEV+1 ) = .FALSE. OUT( J ) = .TRUE. CNT = CNT + 1 END IF END IF 40 CONTINUE 50 CONTINUE C IF( CNT.EQ.N1 ) THEN EVSEL = 1 ELSE C C CNT < N1, too few eigenvalues selected. C TOL = TEN*TOL CALL DCOPY( 3*N1, DWORK( IEVS ), 1, DWORK, 1 ) END IF GO TO 30 END IF C END WHILE 30 C C Workspace: need 7*N1 + 7*N2 + 16; C prefer larger. C ITMP = 3*M + 1 NRA = DLANHS( '1-norm', M, A, LDA, DWORK ) NRB = DLANHS( '1-norm', M, B, LDB, DWORK ) IDM( 1 ) = 2 IDM( 2 ) = 2 CALL MB01QD( 'Hess', M, M, 0, 0, NRA, ONE, 2, IDM, A, LDA, $ INFO ) CALL MB01QD( 'Hess', M, M, 0, 0, NRB, ONE, 2, IDM, B, LDB, $ INFO ) CALL DTGSEN( 0, .TRUE., .TRUE., SLCT, M, A, LDA, B, LDB, DWORK, $ DWORK( M+1 ), DWORK( 2*M+1 ), Q2, LDQ2, Q1, LDQ1, $ IDUM, TMP, TMP, DUM, DWORK( ITMP ), LDWORK-ITMP+1, $ IDM, 1, INFO ) IF( INFO.EQ.1 ) THEN INFO = 5 RETURN END IF C CALL MB01QD( 'Hess', M, M, 0, 0, ONE, NRA, 0, IDM, A, LDA, $ INFO ) CALL MB01QD( 'Hess', M, M, 0, 0, ONE, NRB, 0, IDM, B, LDB, $ INFO ) C C Interchange N1 and N2. C ITMP = N1 N1 = N2 N2 = ITMP C IF( .NOT.LUPLO ) THEN C C Permute the rows of Q1 and Q2. C IF( N1.EQ.1 ) THEN C DO 60 J = 1, M TMP = Q1( 3, J ) Q1( 3, J ) = Q1( 2, J ) Q1( 2, J ) = Q1( 1, J ) Q1( 1, J ) = TMP TMP = Q2( 3, J ) Q2( 3, J ) = Q2( 2, J ) Q2( 2, J ) = Q2( 1, J ) Q2( 1, J ) = TMP 60 CONTINUE C ELSE IF( N2.EQ.1 ) THEN C DO 70 J = 1, M TMP = Q1( 1, J ) Q1( 1, J ) = Q1( 2, J ) Q1( 2, J ) = Q1( 3, J ) Q1( 3, J ) = TMP TMP = Q2( 1, J ) Q2( 1, J ) = Q2( 2, J ) Q2( 2, J ) = Q2( 3, J ) Q2( 3, J ) = TMP 70 CONTINUE C ELSE C DO 80 J = 1, M CALL DSWAP( N1, Q1( 1, J ), 1, Q1( N1+1, J ), 1 ) CALL DSWAP( N1, Q2( 1, J ), 1, Q2( N1+1, J ), 1 ) 80 CONTINUE C END IF END IF ELSE C C 2-by-2 case. C IF( .NOT.LUPLO .AND. A( 2, 1 ).EQ.ZERO $ .AND. B( 2, 1 ).EQ.ZERO ) THEN CALL DLASET( 'Full', M, M, ZERO, ONE, Q1, LDQ1 ) CALL DLASET( 'Full', M, M, ZERO, ONE, Q2, LDQ2 ) RETURN ELSE IF( LUPLO ) THEN CALL DLASET( 'Full', M, M, ZERO, ONE, Q1, LDQ1 ) CALL DLASET( 'Full', M, M, ZERO, ONE, Q2, LDQ2 ) ELSE TMP = A( 1, 1 ) A( 1, 1 ) = A( 2, 2 ) A( 2, 2 ) = TMP A( 1, 2 ) = -A( 2, 1 ) A( 2, 1 ) = ZERO TMP = B( 1, 1 ) B( 1, 1 ) = B( 2, 2 ) B( 2, 2 ) = TMP B( 1, 2 ) = -B( 2, 1 ) B( 2, 1 ) = ZERO Q1( 1, 1 ) = ZERO Q1( 2, 1 ) = -ONE Q1( 1, 2 ) = ONE Q1( 2, 2 ) = ZERO Q2( 1, 1 ) = ZERO Q2( 2, 1 ) = -ONE Q2( 1, 2 ) = ONE Q2( 2, 2 ) = ZERO END IF A11 = A( 1, 1 ) A22 = A( 2, 2 ) B11 = B( 1, 1 ) B22 = B( 2, 2 ) MX = MAX( ABS( A11 ), ABS( A22 ), ABS( A( 1, 2 ) ), $ ABS( B11 ), ABS( B22 ), ABS( B( 1, 2 ) ), $ DLAMCH( 'Safemin' ) ) AS( 1, 1 ) = A11 / MX AS( 2, 1 ) = ZERO AS( 1, 2 ) = A( 1, 2 ) / MX AS( 2, 2 ) = A22 / MX BS( 1, 1 ) = B11 / MX BS( 2, 2 ) = B22 / MX BS( 1, 2 ) = B( 1, 2 ) / MX CALL DLACPY( 'Full', M, M, A, LDA, AS, 2 ) CALL DLACPY( 'Full', M, M, B, LDB, BS, 2 ) CALL DTGEX2( .TRUE., .TRUE., M, AS, 2, BS, 2, Q2, LDQ2, Q1, $ LDQ1, 1, 1, 1, DUM, 8, ITMP ) C END IF C RETURN C *** Last line of MB03DD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02FD.f0000644000000000000000000000013215012430707016147 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02FD.f0000644000175000017500000003077215012430707017354 0ustar00lilgelilge00000000000000 SUBROUTINE MB02FD( TYPET, K, N, P, S, T, LDT, R, LDR, DWORK, $ LDWORK, INFO ) C C PURPOSE C C To compute the incomplete Cholesky (ICC) factor of a symmetric C positive definite (s.p.d.) block Toeplitz matrix T, defined by C either its first block row, or its first block column, depending C on the routine parameter TYPET. C C By subsequent calls of this routine, further rows / columns of C the Cholesky factor can be added. C Furthermore, the generator of the Schur complement of the leading C (P+S)*K-by-(P+S)*K block in T is available, which can be used, C e.g., for measuring the quality of the ICC factorization. C C ARGUMENTS C C Mode Parameters C C TYPET CHARACTER*1 C Specifies the type of T, as follows: C = 'R': T contains the first block row of an s.p.d. block C Toeplitz matrix; the ICC factor R is upper C trapezoidal; C = 'C': T contains the first block column of an s.p.d. C block Toeplitz matrix; the ICC factor R is lower C trapezoidal; this choice leads to better C localized memory references and hence a faster C algorithm. C Note: in the sequel, the notation x / y means that C x corresponds to TYPET = 'R' and y corresponds to C TYPET = 'C'. C C Input/Output Parameters C C K (input) INTEGER C The number of rows / columns in T, which should be equal C to the blocksize. K >= 0. C C N (input) INTEGER C The number of blocks in T. N >= 0. C C P (input) INTEGER C The number of previously computed block rows / columns C of R. 0 <= P <= N. C C S (input) INTEGER C The number of block rows / columns of R to compute. C 0 <= S <= N-P. C C T (input/output) DOUBLE PRECISION array, dimension C (LDT,(N-P)*K) / (LDT,K) C On entry, if P = 0, then the leading K-by-N*K / N*K-by-K C part of this array must contain the first block row / C column of an s.p.d. block Toeplitz matrix. C If P > 0, the leading K-by-(N-P)*K / (N-P)*K-by-K must C contain the negative generator of the Schur complement of C the leading P*K-by-P*K part in T, computed from previous C calls of this routine. C On exit, if INFO = 0, then the leading K-by-(N-P)*K / C (N-P)*K-by-K part of this array contains, in the first C K-by-K block, the upper / lower Cholesky factor of C T(1:K,1:K), in the following S-1 K-by-K blocks, the C Householder transformations applied during the process, C and in the remaining part, the negative generator of the C Schur complement of the leading (P+S)*K-by(P+S)*K part C in T. C C LDT INTEGER C The leading dimension of the array T. C LDT >= MAX(1,K), if TYPET = 'R'; C LDT >= MAX(1,(N-P)*K), if TYPET = 'C'. C C R (input/output) DOUBLE PRECISION array, dimension C (LDR, N*K) / (LDR, S*K ) if P = 0; C (LDR, (N-P+1)*K) / (LDR, (S+1)*K ) if P > 0. C On entry, if P > 0, then the leading K-by-(N-P+1)*K / C (N-P+1)*K-by-K part of this array must contain the C nonzero blocks of the last block row / column in the C ICC factor from a previous call of this routine. Note that C this part is identical with the positive generator of C the Schur complement of the leading P*K-by-P*K part in T. C If P = 0, then R is only an output parameter. C On exit, if INFO = 0 and P = 0, then the leading C S*K-by-N*K / N*K-by-S*K part of this array contains the C upper / lower trapezoidal ICC factor. C On exit, if INFO = 0 and P > 0, then the leading C (S+1)*K-by-(N-P+1)*K / (N-P+1)*K-by-(S+1)*K part of this C array contains the upper / lower trapezoidal part of the C P-th to (P+S)-th block rows / columns of the ICC factor. C The elements in the strictly lower / upper trapezoidal C part are not referenced. C C LDR INTEGER C The leading dimension of the array R. C LDR >= MAX(1, S*K ), if TYPET = 'R' and P = 0; C LDR >= MAX(1, (S+1)*K ), if TYPET = 'R' and P > 0; C LDR >= MAX(1, N*K ), if TYPET = 'C' and P = 0; C LDR >= MAX(1, (N-P+1)*K ), if TYPET = 'C' and P > 0. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -11, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(1,(N+1)*K,4*K), if P = 0; C LDWORK >= MAX(1,(N-P+2)*K,4*K), if P > 0. 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: the reduction algorithm failed; the Toeplitz matrix C associated with T is not (numerically) positive C definite in its leading (P+S)*K-by-(P+S)*K part. C C METHOD C C Householder transformations and modified hyperbolic rotations C are used in the Schur algorithm [1], [2]. C C REFERENCES C C [1] Kailath, T. and Sayed, A. C Fast Reliable Algorithms for Matrices with Structure. C SIAM Publications, Philadelphia, 1999. C C [2] Kressner, D. and Van Dooren, P. C Factorizations and linear system solvers for matrices with C Toeplitz structure. C SLICOT Working Note 2000-2, 2000. C C NUMERICAL ASPECTS C C The implemented method is numerically stable. C 3 C The algorithm requires 0(K S (N-P)) floating point operations. C C CONTRIBUTOR C C D. Kressner, Technical Univ. Berlin, Germany, April 2001. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001, C Mar. 2004. C C KEYWORDS C C Elementary matrix operations, Householder transformation, matrix C operations, Toeplitz matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER TYPET INTEGER INFO, K, LDR, LDT, LDWORK, N, P, S C .. Array Arguments .. DOUBLE PRECISION DWORK(*), R(LDR,*), T(LDT,*) C .. Local Scalars .. INTEGER COUNTR, I, IERR, MAXWRK, ST, STARTR LOGICAL ISROW C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DLACPY, DPOTRF, DTRSM, MB02CX, MB02CY, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C C .. Executable Statements .. C C Decode the scalar input parameters. C INFO = 0 ISROW = LSAME( TYPET, 'R' ) C C Check the scalar input parameters. C IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN INFO = -1 ELSE IF ( K.LT.0 ) THEN INFO = -2 ELSE IF ( N.LT.0 ) THEN INFO = -3 ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN INFO = -4 ELSE IF ( S.LT.0 .OR. S.GT.( N-P ) ) THEN INFO = -5 ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. $ ( .NOT.ISROW .AND. LDT.LT.( N-P )*K ) ) THEN INFO = -7 ELSE IF ( LDR.LT.1 .OR. $ ( ISROW .AND. P.EQ.0 .AND. ( LDR.LT.S*K ) ) .OR. $ ( ISROW .AND. P.GT.0 .AND. ( LDR.LT.( S+1 )*K ) ) .OR. $ ( .NOT.ISROW .AND. P.EQ.0 .AND. ( LDR.LT.N*K ) ) .OR. $ ( .NOT.ISROW .AND. P.GT.0 .AND. ( LDR.LT.( N-P+1 )*K ) ) ) THEN INFO = -9 ELSE IF ( P.EQ.0 ) THEN COUNTR = ( N + 1 )*K ELSE COUNTR = ( N - P + 2 )*K END IF COUNTR = MAX( COUNTR, 4*K ) IF ( LDWORK.LT.MAX( 1, COUNTR ) ) THEN DWORK(1) = MAX( 1, COUNTR ) INFO = -11 END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB02FD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( MIN( K, N, S ).EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C MAXWRK = 1 C IF ( ISROW ) THEN C IF ( P.EQ.0 ) THEN C C T is the first block row of a block Toeplitz matrix. C Bring T to proper form by triangularizing its first block. C CALL DPOTRF( 'Upper', K, T, LDT, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C IF ( N.GT.1 ) $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR ) C IF ( S.EQ.1 ) THEN DWORK(1) = ONE RETURN END IF C ST = 2 COUNTR = ( N - 1 )*K ELSE ST = 1 COUNTR = ( N - P )*K END IF C STARTR = 1 C DO 10 I = ST, S CALL DLACPY( 'Upper', K, COUNTR, R(STARTR,STARTR), LDR, $ R(STARTR+K,STARTR+K), LDR ) STARTR = STARTR + K COUNTR = COUNTR - K CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR, $ T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1), $ LDWORK-3*K, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) CALL MB02CY( 'Row', 'NoStructure', K, K, COUNTR, K, $ R(STARTR,STARTR+K), LDR, T(1,STARTR+K), LDT, $ T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1), $ LDWORK-3*K, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) 10 CONTINUE C ELSE C IF ( P.EQ.0 ) THEN C C T is the first block column of a block Toeplitz matrix. C Bring T to proper form by triangularizing its first block. C CALL DPOTRF( 'Lower', K, T, LDT, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C IF ( N.GT.1 ) $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR ) C IF ( S.EQ.1 ) THEN DWORK(1) = ONE RETURN END IF C ST = 2 COUNTR = ( N - 1 )*K ELSE ST = 1 COUNTR = ( N - P )*K END IF C STARTR = 1 C DO 20 I = ST, S CALL DLACPY( 'Lower', COUNTR, K, R(STARTR,STARTR), LDR, $ R(STARTR+K,STARTR+K), LDR ) STARTR = STARTR + K COUNTR = COUNTR - K CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR, $ T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1), $ LDWORK-3*K, IERR ) IF ( IERR.NE.0 ) THEN C C Error return: The matrix is not positive definite. C INFO = 1 RETURN END IF C MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) CALL MB02CY( 'Column', 'NoStructure', K, K, COUNTR, K, $ R(STARTR+K,STARTR), LDR, T(STARTR+K,1), LDT, $ T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1), $ LDWORK-3*K, IERR ) MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) 20 CONTINUE C END IF C DWORK(1) = MAXWRK C RETURN C C *** Last line of MB02FD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB02WD.f0000644000000000000000000000013215012430707016170 xustar0030 mtime=1747595719.965100097 30 atime=1747595719.965100097 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB02WD.f0000644000175000017500000003504315012430707017371 0ustar00lilgelilge00000000000000 SUBROUTINE MB02WD( FORM, F, N, IPAR, LIPAR, DPAR, LDPAR, ITMAX, $ A, LDA, B, INCB, X, INCX, TOL, DWORK, LDWORK, $ IWARN, INFO ) C C PURPOSE C C To solve the system of linear equations Ax = b, with A symmetric, C positive definite, or, in the implicit form, f(A, x) = b, where C y = f(A, x) is a symmetric positive definite linear mapping C from x to y, using the conjugate gradient (CG) algorithm without C preconditioning. C C ARGUMENTS C C Mode Parameters C C FORM CHARACTER*1 C Specifies the form of the system of equations, as C follows: C = 'U' : Ax = b, the upper triagular part of A is used; C = 'L' : Ax = b, the lower triagular part of A is used; C = 'F' : the implicit, function form, f(A, x) = b. C C Function Parameters C C F EXTERNAL C If FORM = 'F', then F is a subroutine which calculates the C value of f(A, x), for given A and x. C If FORM <> 'F', then F is not called. C C F must have the following interface: C C SUBROUTINE F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, X, C $ INCX, DWORK, LDWORK, INFO ) C C where C C N (input) INTEGER C The dimension of the vector x. N >= 0. C C IPAR (input) INTEGER array, dimension (LIPAR) C The integer parameters describing the structure of C the matrix A. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 0. C C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) C The real parameters needed for solving the C problem. C C LDPAR (input) INTEGER C The length of the array DPAR. LDPAR >= 0. C C A (input) DOUBLE PRECISION array, dimension C (LDA, NC), where NC is the number of columns. C The leading NR-by-NC part of this array must C contain the (compressed) representation of the C matrix A, where NR is the number of rows of A C (function of IPAR entries). C C LDA (input) INTEGER C The leading dimension of the array A. C LDA >= MAX(1,NR). C C X (input/output) DOUBLE PRECISION array, dimension C (1+(N-1)*INCX) C On entry, this incremented array must contain the C vector x. C On exit, this incremented array contains the value C of the function f, y = f(A, x). C C INCX (input) INTEGER C The increment for the elements of X. INCX > 0. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C The workspace array for subroutine F. C C LDWORK (input) INTEGER C The size of the array DWORK (as large as needed C in the subroutine F). C C INFO INTEGER C Error indicator, set to a negative value if an C input scalar argument is erroneous, and to C positive values for other possible errors in the C subroutine F. The LAPACK Library routine XERBLA C should be used in conjunction with negative INFO. C INFO must be zero if the subroutine finished C successfully. C C Parameters marked with "(input)" must not be changed. C C Input/Output Parameters C C N (input) INTEGER C The dimension of the vector x. N >= 0. C If FORM = 'U' or FORM = 'L', N is also the number of rows C and columns of the matrix A. C C IPAR (input) INTEGER array, dimension (LIPAR) C If FORM = 'F', the integer parameters describing the C structure of the matrix A. C This parameter is ignored if FORM = 'U' or FORM = 'L'. C C LIPAR (input) INTEGER C The length of the array IPAR. LIPAR >= 0. C C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) C If FORM = 'F', the real parameters needed for solving C the problem. C This parameter is ignored if FORM = 'U' or FORM = 'L'. C C LDPAR (input) INTEGER C The length of the array DPAR. LDPAR >= 0. C C ITMAX (input) INTEGER C The maximal number of iterations to do. ITMAX >= 0. C C A (input) DOUBLE PRECISION array, C dimension (LDA, NC), if FORM = 'F', C dimension (LDA, N), otherwise. C If FORM = 'F', the leading NR-by-NC part of this array C must contain the (compressed) representation of the C matrix A, where NR and NC are the number of rows and C columns, respectively, of the matrix A. The array A is C not referenced by this routine itself, except in the C calls to the routine F. C If FORM <> 'F', the leading N-by-N part of this array C must contain the matrix A, assumed to be symmetric; C only the triangular part specified by FORM is referenced. C C LDA (input) INTEGER C The leading dimension of array A. C LDA >= MAX(1,NR), if FORM = 'F'; C LDA >= MAX(1,N), if FORM = 'U' or FORM = 'L'. C C B (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCB) C The incremented vector b. C C INCB (input) INTEGER C The increment for the elements of B. INCB > 0. C C X (input/output) DOUBLE PRECISION array, dimension C (1+(N-1)*INCX) C On entry, this incremented array must contain an initial C approximation of the solution. If an approximation is not C known, setting all elements of x to zero is recommended. C On exit, this incremented array contains the computed C solution x of the system of linear equations. C C INCX (input) INTEGER C The increment for the elements of X. INCX > 0. C C Tolerances C C TOL DOUBLE PRECISION C If TOL > 0, absolute tolerance for the iterative process. C The algorithm will stop if || Ax - b ||_2 <= TOL. Since C it is advisable to use a relative tolerance, say TOLER, C TOL should be chosen as TOLER*|| b ||_2. C If TOL <= 0, a default relative tolerance, C TOLDEF = N*EPS*|| b ||_2, is used, where EPS is the C machine precision (see LAPACK Library routine DLAMCH). C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the number of C iterations performed and DWORK(2) returns the remaining C residual, || Ax - b ||_2. C C LDWORK INTEGER C The length of the array DWORK. C LDWORK >= MAX(2,3*N + DWORK(F)), if FORM = 'F', C where DWORK(F) is the workspace needed by F; C LDWORK >= MAX(2,3*N), if FORM = 'U' or FORM = 'L'. C C Warning Indicator C C IWARN INTEGER C = 0: no warning; C = 1: the algorithm finished after ITMAX > 0 iterations, C without achieving the desired precision TOL; C = 2: ITMAX is zero; in this case, DWORK(2) is not set. 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, then F returned with INFO = i. C C METHOD C C The following CG iteration is used for solving Ax = b: C C Start: q(0) = r(0) = Ax - b C C < q(k), r(k) > C ALPHA(k) = - ---------------- C < q(k), Aq(k) > C x(k+1) = x(k) - ALPHA(k) * q(k) C r(k+1) = r(k) - ALPHA(k) * Aq(k) C < r(k+1), r(k+1) > C BETA(k) = -------------------- C < r(k) , r(k) > C q(k+1) = r(k+1) + BETA(k) * q(k) C C where <.,.> denotes the scalar product. C C REFERENCES C C [1] Golub, G.H. and van Loan, C.F. C Matrix Computations. Third Edition. C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, C 1996. C C [2] Luenberger, G. C Introduction to Linear and Nonlinear Programming. C Addison-Wesley, Reading, MA, p.187, York, 1973. C C NUMERICAL ASPECTS C C Since the residuals are orthogonal in the scalar product C = y'Ax, the algorithm is theoretically finite. But rounding C errors cause a loss of orthogonality, so a finite termination C cannot be guaranteed. However, one can prove [2] that C C || x-x_k ||_A := sqrt( (x-x_k)' * A * (x-x_k) ) C C sqrt( kappa_2(A) ) - 1 C <= 2 || x-x_0 ||_A * ------------------------ , C sqrt( kappa_2(A) ) + 1 C C where kappa_2 is the condition number. C C The approximate number of floating point operations is C (k*(N**2 + 15*N) + N**2 + 3*N)/2, if FORM <> 'F', C k*(f + 7*N) + f, if FORM = 'F', C where k is the number of CG iterations performed, and f is the C number of floating point operations required by the subroutine F. C C CONTRIBUTORS C C A. Riedel, R. Schneider, Chemnitz University of Technology, C Oct. 2000, during a stay at University of Twente, NL. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, C March, 2002. C C KEYWORDS C C Conjugate gradients, convergence, linear system of equations, C matrix operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER FORM INTEGER INCB, INCX, INFO, ITMAX, IWARN, LDA, LDPAR, $ LDWORK, LIPAR, N DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(*), DPAR(*), DWORK(*), X(*) INTEGER IPAR(*) C .. Local Scalars .. DOUBLE PRECISION ALPHA, BETA, RES, RESOLD, TOLDEF INTEGER AQ, DWLEFT, K, R LOGICAL MAT C .. External Functions .. DOUBLE PRECISION DDOT, DLAMCH, DNRM2 LOGICAL LSAME EXTERNAL DDOT, DLAMCH, DNRM2, LSAME C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSCAL, DSYMV, F, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Decode the scalar input parameters. C MAT = LSAME( FORM, 'U' ) .OR. LSAME( FORM, 'L' ) C C Check the scalar input parameters. C IWARN = 0 INFO = 0 IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN INFO = -1 ELSEIF ( N.LT.0 ) THEN INFO = -3 ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN INFO = -5 ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN INFO = -7 ELSEIF ( ITMAX.LT.0 ) THEN INFO = -8 ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.N ) ) THEN INFO = -10 ELSEIF ( INCB.LE.0 ) THEN INFO = -12 ELSEIF ( INCX.LE.0 ) THEN INFO = -14 ELSEIF ( LDWORK.LT.MAX( 2, 3*N ) ) THEN INFO = -17 ENDIF C C Return if there are illegal arguments. C IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB02WD', -INFO ) RETURN ENDIF C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = ZERO DWORK(2) = ZERO RETURN ENDIF C IF ( ITMAX.EQ.0 ) THEN DWORK(1) = ZERO IWARN = 2 RETURN ENDIF C C Set default tolerance, if needed. C TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) $ TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' )*DNRM2( N, B, INCB ) C C Initialize local variables. C K = 0 C C Vector q is stored in DWORK(1), A*q or f(A, q) in DWORK(AQ), C and r in DWORK(R). The workspace for F starts in DWORK(DWLEFT). C AQ = N + 1 R = N + AQ DWLEFT = N + R C C Prepare the first iteration, initialize r and q. C IF ( MAT ) THEN CALL DCOPY( N, B, INCB, DWORK(R), 1 ) CALL DSYMV( FORM, N, ONE, A, LDA, X, INCX, -ONE, DWORK(R), 1 ) ELSE CALL DCOPY( N, X, INCX, DWORK(R), 1 ) CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(R), 1, $ DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO ) IF ( INFO.NE.0 ) $ RETURN CALL DAXPY( N, -ONE, B, INCB, DWORK(R), 1 ) ENDIF CALL DCOPY( N, DWORK(R), 1, DWORK, 1 ) C RES = DNRM2( N, DWORK(R), 1 ) C C Do nothing if x is already the solution. C IF ( RES.LE.TOLDEF ) GOTO 20 C C Begin of the iteration loop. C C WHILE ( RES.GT.TOLDEF .AND. K.LE.ITMAX ) DO 10 CONTINUE C C Calculate A*q or f(A, q). C IF ( MAT ) THEN CALL DSYMV( FORM, N, ONE, A, LDA, DWORK, 1, ZERO, DWORK(AQ), $ 1 ) ELSE CALL DCOPY( N, DWORK, 1, DWORK(AQ), 1 ) CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(AQ), 1, $ DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO ) IF ( INFO.NE.0 ) $ RETURN ENDIF C C Calculate ALPHA(k). C ALPHA = DDOT( N, DWORK, 1, DWORK(R), 1 ) / $ DDOT( N, DWORK, 1, DWORK(AQ), 1 ) C C x(k+1) = x(k) - ALPHA(k)*q(k). C CALL DAXPY( N, -ALPHA, DWORK, 1, X, INCX ) C C r(k+1) = r(k) - ALPHA(k)*(A*q(k)). C CALL DAXPY( N, -ALPHA, DWORK(AQ), 1, DWORK(R), 1 ) C C Save RES and calculate a new RES. C RESOLD = RES RES = DNRM2( N, DWORK(R), 1 ) C C Exit if tolerance is reached. C IF ( RES.LE.TOLDEF ) GOTO 20 C C Calculate BETA(k). C BETA = ( RES/RESOLD )**2 C C q(k+1) = r(k+1) + BETA(k)*q(k). C CALL DSCAL( N, BETA, DWORK, 1 ) CALL DAXPY( N, ONE, DWORK(R), 1, DWORK, 1 ) C C End of the iteration loop. C K = K + 1 IF ( K.LT.ITMAX ) GOTO 10 C END WHILE 10 C C Tolerance was not reached! C IWARN = 1 C 20 CONTINUE C DWORK(1) = K DWORK(2) = RES C C *** Last line of MB02WD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB01RD.f0000644000000000000000000000013215012430707016162 xustar0030 mtime=1747595719.961099953 30 atime=1747595719.961099953 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB01RD.f0000644000175000017500000002534115012430707017363 0ustar00lilgelilge00000000000000 SUBROUTINE MB01RD( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, $ X, LDX, DWORK, LDWORK, INFO ) 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 M x N + 1/2 x N 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, Sep. 2013. 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 control-4.1.2/src/slicot/src/PaxHeaders/AB01MD.f0000644000000000000000000000013215012430707016141 xustar0030 mtime=1747595719.953099663 30 atime=1747595719.953099663 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/AB01MD.f0000644000175000017500000003211415012430707017336 0ustar00lilgelilge00000000000000 SUBROUTINE AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, TAU, TOL, $ DWORK, LDWORK, INFO ) C C PURPOSE C C To find a controllable realization for the linear time-invariant C single-input system C C dX/dt = A * X + B * U, C C where A is an N-by-N matrix and B is an N element vector which C are reduced by this routine to orthogonal canonical form using C (and optionally accumulating) orthogonal similarity C transformations. C C ARGUMENTS C C Mode Parameters C C JOBZ CHARACTER*1 C Indicates whether the user wishes to accumulate in a C matrix Z the orthogonal similarity transformations for C reducing the system, as follows: C = 'N': Do not form Z and do not store the orthogonal C transformations; C = 'F': Do not form Z, but store the orthogonal C transformations in the factored form; C = 'I': Z is initialized to the unit matrix and the C orthogonal transformation matrix Z is returned. C C Input/Output Parameters C C N (input) INTEGER C The order of the original state-space representation, C i.e. 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 part of this array must C contain the original state dynamics matrix A. C On exit, the leading NCONT-by-NCONT upper Hessenberg C part of this array contains the canonical form of the C state dynamics matrix, given by Z' * A * Z, of a C controllable realization for the original system. The C elements below 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/output) DOUBLE PRECISION array, dimension (N) C On entry, the original input/state vector B. C On exit, the leading NCONT elements of this array contain C canonical form of the input/state vector, given by Z' * B, C with all elements but B(1) set to zero. C C NCONT (output) INTEGER C The order of the controllable state-space representation. C C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) C If JOBZ = 'I', then the leading N-by-N part of this array C contains the matrix of accumulated orthogonal similarity C transformations which reduces the given system to C orthogonal canonical form. C If JOBZ = 'F', the elements below the diagonal, with the C array TAU, represent the orthogonal transformation matrix C as a product of elementary reflectors. The transformation C matrix can then be obtained by calling the LAPACK Library C routine DORGQR. C If JOBZ = 'N', the array Z is not referenced and can be C supplied as a dummy array (i.e. set parameter LDZ = 1 and C declare this array to be Z(1,1) in the calling program). C C LDZ INTEGER C The leading dimension of array Z. If JOBZ = 'I' or C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. C C TAU (output) DOUBLE PRECISION array, dimension (N) C The elements of TAU contain the scalar factors of the C elementary reflectors used in the reduction of B and A. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance to be used in determining the C controllability of (A,B). If the user sets TOL > 0, then C the given value of TOL is used as an absolute tolerance; C elements with absolute value less than TOL are considered C neglijible. If the user sets TOL <= 0, then an implicitly C computed, default tolerance, defined by C TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead, C where EPS is the machine precision (see LAPACK Library C routine DLAMCH). 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 length of the array DWORK. LDWORK >= MAX(1,N). 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 C METHOD C C The Householder matrix which reduces all but the first element C of vector B to zero is found and this orthogonal similarity C transformation is applied to the matrix A. The resulting A is then C reduced to upper Hessenberg form by a sequence of Householder C transformations. Finally, the order of the controllable state- C space representation (NCONT) is determined by finding the position C of the first sub-diagonal element of A which is below an C appropriate zero threshold, either TOL or TOLDEF (see parameter C TOL); if NORM(B) is smaller than this threshold, NCONT is set to C zero, and no computations for reducing the system to orthogonal C canonical form are performed. C C REFERENCES C C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. C Orthogonal Invariants and Canonical Forms for Linear C Controllable Systems. C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. C C [2] Hammarling, S.J. C Notes on the use of orthogonal similarity transformations in C control. C NPL Report DITC 8/82, August 1982. C C [3] Paige, C.C C Properties of numerical algorithms related to computing C controllability. C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations and is backward stable. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1996. C Supersedes Release 2.0 routine AB01AD by T.W.C. Williams, C Kingston Polytechnic, United Kingdom, October 1982. C C REVISIONS C C V. Sima, February 16, 1998, October 19, 2001, February 2, 2005. C C KEYWORDS C C Controllability, minimal realization, orthogonal canonical form, C orthogonal transformation. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER JOBZ INTEGER INFO, LDA, LDZ, LDWORK, N, NCONT DOUBLE PRECISION TOL C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(*), DWORK(*), TAU(*), Z(LDZ,*) C .. Local Scalars .. LOGICAL LJOBF, LJOBI, LJOBZ INTEGER ITAU, J DOUBLE PRECISION ANORM, B1, BNORM, FANORM, FBNORM, H, THRESH, $ TOLDEF, WRKOPT C .. Local Arrays .. DOUBLE PRECISION NBLK(1) C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE, LSAME C .. External Subroutines .. EXTERNAL DGEHRD, DLACPY, DLARF, DLARFG, DLASET, DORGQR, $ MB01PD, XERBLA C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX C .. Executable Statements .. C INFO = 0 LJOBF = LSAME( JOBZ, 'F' ) LJOBI = LSAME( JOBZ, 'I' ) LJOBZ = LJOBF.OR.LJOBI C C Test the input scalar arguments. C IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX(1,N) ) THEN INFO = -4 ELSE IF( .NOT.LJOBZ .AND. LDZ.LT.1 .OR. $ LJOBZ .AND. LDZ.LT.MAX(1,N) ) THEN INFO = -8 ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN INFO = -12 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'AB01MD', -INFO ) RETURN END IF C C Quick return if possible. C NCONT = 0 DWORK(1) = ONE IF ( N.EQ.0 ) $ RETURN 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 WRKOPT = ONE C C Calculate the absolute norms of A and B (used for scaling). C ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) BNORM = DLANGE( 'M', N, 1, B, N, DWORK ) C C Return if matrix B is zero. C IF( BNORM.EQ.ZERO ) THEN IF( LJOBF ) THEN CALL DLASET( 'F', N, N, ZERO, ZERO, Z, LDZ ) CALL DLASET( 'F', N, 1, ZERO, ZERO, TAU, N ) ELSE IF( LJOBI ) THEN CALL DLASET( 'F', N, N, ZERO, ONE, Z, LDZ ) END IF RETURN END IF C C Scale (if needed) the matrices A and B. C CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) CALL MB01PD( 'S', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) C C Calculate the Frobenius norm of A and the 1-norm of B (used for C controllability test). C FANORM = DLANGE( 'F', N, N, A, LDA, DWORK ) FBNORM = DLANGE( '1', N, 1, B, N, DWORK ) C TOLDEF = TOL IF ( TOLDEF.LE.ZERO ) THEN C C Use the default tolerance in controllability determination. C THRESH = DBLE(N)*DLAMCH( 'EPSILON' ) TOLDEF = THRESH*MAX( FANORM, FBNORM ) END IF C ITAU = 1 IF ( FBNORM.GT.TOLDEF ) THEN C C B is not negligible compared with A. C IF ( N.GT.1 ) THEN C C Transform B by a Householder matrix Z1: store vector C describing this temporarily in B and in the local scalar H. C CALL DLARFG( N, B(1), B(2), 1, H ) C B1 = B(1) B(1) = ONE C C Form Z1 * A * Z1. C CALL DLARF( 'R', N, N, B, 1, H, A, LDA, DWORK ) CALL DLARF( 'L', N, N, B, 1, H, A, LDA, DWORK ) C B(1) = B1 TAU(1) = H ITAU = ITAU + 1 ELSE B1 = B(1) END IF C C Reduce modified A to upper Hessenberg form by an orthogonal C similarity transformation with matrix Z2. C Workspace: need N; prefer N*NB. C CALL DGEHRD( N, 1, N, A, LDA, TAU(ITAU), DWORK, LDWORK, INFO ) WRKOPT = DWORK(1) C IF ( LJOBZ ) THEN C C Save the orthogonal transformations used, so that they could C be accumulated by calling DORGQR routine. C IF ( N.GT.1 ) $ CALL DLACPY( 'F', N-1, 1, B(2), N-1, Z(2,1), LDZ ) IF ( N.GT.2 ) $ CALL DLACPY( 'L', N-2, N-2, A(3,1), LDA, Z(3,2), LDZ ) IF ( LJOBI ) THEN C C Form the orthogonal transformation matrix Z = Z1 * Z2. C Workspace: need N; prefer N*NB. C CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) WRKOPT = MAX( WRKOPT, DWORK(1) ) END IF END IF C C Annihilate the lower part of A and B. C IF ( N.GT.2 ) $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) IF ( N.GT.1 ) $ CALL DLASET( 'F', N-1, 1, ZERO, ZERO, B(2), N-1 ) C C Find NCONT by checking sizes of the sub-diagonal elements of C transformed A. C IF ( TOL.LE.ZERO ) TOLDEF = THRESH*MAX( FANORM, ABS( B1 ) ) C J = 1 C C WHILE ( J < N and ABS( A(J+1,J) ) > TOLDEF ) DO C 10 CONTINUE IF ( J.LT.N ) THEN IF ( ABS( A(J+1,J) ).GT.TOLDEF ) THEN J = J + 1 GO TO 10 END IF END IF C C END WHILE 10 C C First negligible sub-diagonal element found, if any: set NCONT. C NCONT = J IF ( J.LT.N ) A(J+1,J) = ZERO C C Undo scaling of A and B. C CALL MB01PD( 'U', 'H', NCONT, NCONT, 0, 0, ANORM, 0, NBLK, A, $ LDA, INFO ) CALL MB01PD( 'U', 'G', 1, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) IF ( NCONT.LT.N ) $ CALL MB01PD( 'U', 'G', N, N-NCONT, 0, 0, ANORM, 0, NBLK, $ A(1,NCONT+1), LDA, INFO ) ELSE C C B is negligible compared with A. No computations for reducing C the system to orthogonal canonical form have been performed, C except scaling (which is undoed). C IF( LJOBF ) THEN CALL DLASET( 'F', N, N, ZERO, ZERO, Z, LDZ ) CALL DLASET( 'F', N, 1, ZERO, ZERO, TAU, N ) ELSE IF( LJOBI ) THEN CALL DLASET( 'F', N, N, ZERO, ONE, Z, LDZ ) END IF CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, $ INFO ) CALL MB01PD( 'U', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) END IF C C Set optimal workspace dimension. C DWORK(1) = WRKOPT C RETURN C *** Last line of AB01MD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB03TD.f0000644000000000000000000000013215012430707016174 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB03TD.f0000644000175000017500000004713115012430707017376 0ustar00lilgelilge00000000000000 SUBROUTINE SB03TD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, $ RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, $ INFO ) C C PURPOSE C C To solve the real continuous-time Lyapunov matrix equation C C op(A)'*X + X*op(A) = scale*C, C C estimate the conditioning, and compute an error bound on the C solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N, C the right hand side C and the solution X are N-by-N symmetric C matrices (C = C', X = X'), and scale is an output scale factor, C set less than or equal to 1 to avoid overflow in X. C C ARGUMENTS C C Mode Parameters 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 = 'C': Compute the reciprocal condition number only; C = 'E': Compute the error bound only; C = 'A': Compute all: the solution, separation, reciprocal C condition number, and the error bound. 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, T and U (if LYAPUN = 'O') contain the C factors from the real Schur factorization of the C matrix A; C = 'N': The Schur factorization of A will be computed C and the factors will be stored in T and U (if C LYAPUN = 'O'). 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 UPLO CHARACTER*1 C Specifies which part of the symmetric matrix C is to be C used, as follows: C = 'U': Upper triangular part; C = 'L': Lower triangular part. C C LYAPUN CHARACTER*1 C Specifies whether or not the original or "reduced" C Lyapunov equations should be solved, as follows: C = 'O': Solve the original Lyapunov equations, updating C the right-hand sides and solutions with the C matrix U, e.g., X <-- U'*X*U; C = 'R': Solve reduced Lyapunov equations only, without C updating the right-hand sides and solutions. C This means that a real Schur form T of A appears C in the equation, instead of A. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrices A, X, and C. N >= 0. C C SCALE (input or output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'E', SCALE is an input argument: C the scale factor, set by a Lyapunov solver. C 0 <= SCALE <= 1. C If JOB = 'X' or JOB = 'A', SCALE is an output argument: C the scale factor, scale, set less than or equal to 1 to C prevent the solution overflowing. C If JOB = 'S', this argument is not used. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the C leading N-by-N part of this array must contain the C original matrix A. C If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is C not referenced. C C LDA INTEGER C The leading dimension of the array A. C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and C JOB <> 'X'; C LDA >= 1, otherwise. C C T (input/output) DOUBLE PRECISION array, dimension C (LDT,N) C If FACT = 'F', then on entry the leading N-by-N upper C Hessenberg part of this array must contain the upper C quasi-triangular matrix T in Schur canonical form from a C Schur factorization of A. C If FACT = 'N', then this array need not be set on input. C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the C leading N-by-N upper Hessenberg part of this array C contains the upper quasi-triangular matrix T in Schur C canonical form from a Schur factorization of A. C The contents of array T is not modified if FACT = 'F'. C C LDT INTEGER C The leading dimension of the array T. LDT >= MAX(1,N). C C U (input or output) DOUBLE PRECISION array, dimension C (LDU,N) C If LYAPUN = 'O' and FACT = 'F', then U is an input C argument and on entry, the leading N-by-N part of this C array must contain the orthogonal matrix U from a real C Schur factorization of A. C If LYAPUN = 'O' and FACT = 'N', then U is an output C argument and on exit, if INFO = 0 or INFO = N+1, it C contains the orthogonal N-by-N matrix from a real Schur C factorization of A. C If LYAPUN = 'R', the array U is not referenced. C C LDU INTEGER C The leading dimension of the array U. C LDU >= 1, if LYAPUN = 'R'; C LDU >= MAX(1,N), if LYAPUN = 'O'. C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper C triangular part of this array must contain the upper C triangular part of the matrix C of the original Lyapunov C equation (with matrix A), if LYAPUN = 'O', or of the C reduced Lyapunov equation (with matrix T), if C LYAPUN = 'R'. C If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower C triangular part of this array must contain the lower C triangular part of the matrix C of the original Lyapunov C equation (with matrix A), if LYAPUN = 'O', or of the C reduced Lyapunov equation (with matrix T), if C LYAPUN = 'R'. C The remaining strictly triangular part of this array is C used as workspace. C If JOB = 'X', then this array may be identified with X C in the call of this routine. C If JOB = 'S', the array C is not referenced. C C LDC INTEGER C The leading dimension of the array C. C LDC >= 1, if JOB = 'S'; C LDC >= MAX(1,N), otherwise. C C X (input or output) DOUBLE PRECISION array, dimension C (LDX,N) C If JOB = 'C' or 'E', then X is an input argument and on C entry, the leading N-by-N part of this array must contain C the symmetric solution matrix X of the original Lyapunov C equation (with matrix A), if LYAPUN = 'O', or of the C reduced Lyapunov equation (with matrix T), if C LYAPUN = 'R'. C If JOB = 'X' or 'A', then X is an output argument and on C exit, if INFO = 0 or INFO = N+1, the leading N-by-N part C of this array contains the symmetric solution matrix X of C of the original Lyapunov equation (with matrix A), if C LYAPUN = 'O', or of the reduced Lyapunov equation (with C matrix T), if LYAPUN = 'R'. C If JOB = 'S', the array X is not referenced. C C LDX INTEGER C The leading dimension of the array X. C LDX >= 1, if JOB = 'S'; C LDX >= MAX(1,N), otherwise. C C SEP (output) DOUBLE PRECISION C If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or C INFO = N+1, SEP contains the estimated separation of the C matrices op(A) and -op(A)', sep(op(A),-op(A)'). C If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEP is not C referenced. C C RCOND (output) DOUBLE PRECISION C If JOB = 'C' or JOB = 'A', an estimate of the reciprocal C condition number of the continuous-time Lyapunov equation. C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. C If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not C referenced. C C FERR (output) DOUBLE PRECISION C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1, C FERR contains an estimated forward error bound for the C solution X. If XTRUE is the true solution, FERR bounds the C relative error in the computed solution, measured in the C Frobenius norm: norm(X - XTRUE)/norm(XTRUE). C If N = 0 or X = 0, FERR is set to 0. C If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not C 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 the C 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. C If JOB = 'X', then C LDWORK >= MAX(1,N*N), if FACT = 'F'; C LDWORK >= MAX(1,MAX(N*N,3*N)), if FACT = 'N'. C If JOB = 'S' or JOB = 'C', then C LDWORK >= MAX(1,2*N*N), if FACT = 'F'; C LDWORK >= MAX(1,2*N*N,3*N), if FACT = 'N'. C If JOB = 'E', or JOB = 'A', and LYAPUN = 'O', then C LDWORK >= MAX(1,3*N*N); C If JOB = 'E', or JOB = 'A', and LYAPUN = 'R', then C LDWORK >= MAX(1,3*N*N+N-1). C For optimum performance LDWORK should sometimes 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, i <= N, the QR algorithm failed to C complete the reduction to Schur canonical form (see C LAPACK Library routine DGEES); on exit, the matrix C T(i+1:N,i+1:N) contains the partially converged C Schur form, and the elements i+1:n of WR and WI C contain the real and imaginary parts, respectively, C of the converged eigenvalues; this error is unlikely C to appear; C = N+1: if the matrices T and -T' have common or very C close eigenvalues; perturbed values were used to C solve Lyapunov equations, but the matrix T, if given C (for FACT = 'F'), is unchanged. C C METHOD C C After reducing matrix A to real Schur canonical form (if needed), C the Bartels-Stewart algorithm is used. A set of equivalent linear C algebraic systems of equations of order at most four are formed C and solved using Gaussian elimination with complete pivoting. C C The condition number of the continuous-time Lyapunov equation is C estimated as C C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), C C where Omega and Theta are linear operators defined by C C Omega(W) = op(A)'*W + W*op(A), C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). C C The routine estimates the quantities C C sep(op(A),-op(A)') = 1 / norm(inv(Omega)) C C and norm(Theta) using 1-norm condition estimators. C C The forward error bound is estimated using a practical error bound C similar to the one proposed in [2]. C C REFERENCES C C [1] 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 [2] Higham, N.J. C Perturbation theory and backward error for AX-XB=C. C BIT, vol. 33, pp. 124-136, 1993. C C NUMERICAL ASPECTS C 3 C The algorithm requires 0(N ) operations. C The accuracy of the estimates obtained depends on the solution C accuracy and on the properties of the 1-norm estimator. C C FURTHER COMMENTS C C The separation of op(A) and -op(A)' can also be 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) ). C C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker C product. The routine 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 CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. C This is an extended and improved version of Release 3.0 routine C SB03RD. C C REVISIONS C C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. C C KEYWORDS C C Lyapunov equation, orthogonal transformation, real Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, HALF PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) C .. C .. Scalar Arguments .. CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N DOUBLE PRECISION FERR, RCOND, SCALE, SEP C .. C .. Array Arguments .. INTEGER IWORK( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), $ T( LDT, * ), U( LDU, * ), WI( * ), WR( * ), $ X( LDX, * ) C .. C .. Local Scalars .. LOGICAL JOBA, JOBC, JOBE, JOBS, JOBX, LOWER, NOFACT, $ NOTRNA, UPDATE CHARACTER CFACT, JOBL, SJOB INTEGER LDW, NN, SDIM DOUBLE PRECISION THNORM C .. C .. Local Arrays .. LOGICAL BWORK( 1 ) C .. C .. External Functions .. LOGICAL LSAME, SELECT EXTERNAL LSAME, SELECT C .. C .. External Subroutines .. EXTERNAL DGEES, DLACPY, DSCAL, MA02ED, MB01RU, SB03MY, $ SB03QD, SB03QY, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC DBLE, INT, MAX C .. C .. Executable Statements .. C C Decode option parameters. C JOBX = LSAME( JOB, 'X' ) JOBS = LSAME( JOB, 'S' ) JOBC = LSAME( JOB, 'C' ) JOBE = LSAME( JOB, 'E' ) JOBA = LSAME( JOB, 'A' ) NOFACT = LSAME( FACT, 'N' ) NOTRNA = LSAME( TRANA, 'N' ) LOWER = LSAME( UPLO, 'L' ) UPDATE = LSAME( LYAPUN, 'O' ) C C Compute workspace. C NN = N*N IF( JOBX ) THEN LDW = NN ELSE IF( JOBS .OR. JOBC ) THEN LDW = 2*NN ELSE LDW = 3*NN END IF IF( ( JOBE .OR. JOBA ).AND. .NOT.UPDATE ) $ LDW = LDW + N - 1 IF( NOFACT ) $ LDW = MAX( LDW, 3*N ) C C Test the scalar input parameters. C INFO = 0 IF( .NOT.( JOBX .OR. JOBS .OR. JOBC .OR. JOBE .OR. JOBA ) ) THEN INFO = -1 ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN INFO = -2 ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. $ LSAME( TRANA, 'C' ) ) ) THEN INFO = -3 ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN INFO = -4 ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN INFO = -5 ELSE IF( N.LT.0 ) THEN INFO = -6 ELSE IF( ( JOBC .OR. JOBE ) .AND. $ ( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) )THEN INFO = -7 ELSE IF( LDA.LT.1 .OR. $ ( LDA.LT.N .AND. ( ( UPDATE .AND. .NOT.JOBX ) .OR. $ NOFACT ) ) ) THEN INFO = -9 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -11 ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN INFO = -13 ELSE IF( LDC.LT.1 .OR. ( .NOT.JOBS .AND. LDC.LT.N ) ) THEN INFO = -15 ELSE IF( LDX.LT.1 .OR. ( .NOT.JOBS .AND. LDX.LT.N ) ) THEN INFO = -17 ELSE IF( LDWORK.LT.1 .OR. ( LDWORK.LT.LDW ) ) THEN INFO = -25 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'SB03TD', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN IF( JOBX .OR. JOBA ) $ SCALE = ONE IF( JOBC .OR. JOBA ) $ RCOND = ONE IF( JOBE .OR. JOBA ) $ FERR = ZERO DWORK( 1 ) = ONE RETURN END IF C IF( NOFACT ) THEN C C Compute the Schur factorization of A. C Workspace: need 3*N; C prefer larger. C CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) IF( UPDATE ) THEN SJOB = 'V' ELSE SJOB = 'N' END IF CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, WR, $ WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) IF( INFO.GT.0 ) $ RETURN CFACT = 'F' ELSE CFACT = FACT END IF C IF( JOBX .OR. JOBA ) THEN C C Copy the right-hand side in X. C CALL DLACPY( UPLO, N, N, C, LDC, X, LDX ) C IF( UPDATE ) THEN C C Transform the right-hand side. C Workspace: need N*N. C CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, U, $ LDU, X, LDX, DWORK, LDWORK, INFO ) CALL DSCAL( N, HALF, X, LDX+1 ) END IF C C Fill in the remaining triangle of X. C CALL MA02ED( UPLO, N, X, LDX ) C C Solve the transformed equation. C CALL SB03MY( TRANA, N, T, LDT, X, LDX, SCALE, INFO ) IF( INFO.GT.0 ) $ INFO = N + 1 C IF( UPDATE ) THEN C C Transform back the solution. C CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, X, LDX, $ U, LDU, X, LDX, DWORK, LDWORK, INFO ) CALL DSCAL( N, HALF, X, LDX+1 ) C C Fill in the remaining triangle of X. C CALL MA02ED( UPLO, N, X, LDX ) END IF END IF C IF( JOBS ) THEN C C Estimate sep(op(A),-op(A)'). C Workspace: 2*N*N. C CALL SB03QY( 'Separation', TRANA, LYAPUN, N, T, LDT, U, LDU, X, $ LDX, SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) C ELSE IF( .NOT.JOBX ) THEN C C Estimate the reciprocal condition and/or the error bound. C Workspace: 2*N*N, if JOB = 'C'; C 3*N*N + a*(N-1), where: C a = 1, if JOB = 'E' or JOB = 'A', and LYAPUN = 'R'; C a = 0, otherwise. C IF( JOBA ) THEN JOBL = 'B' ELSE JOBL = JOB END IF CALL SB03QD( JOBL, CFACT, TRANA, UPLO, LYAPUN, N, SCALE, A, $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, RCOND, $ FERR, IWORK, DWORK, LDWORK, INFO ) LDW = MAX( LDW, INT( DWORK( 1 ) ) ) END IF C DWORK( 1 ) = DBLE( LDW ) C RETURN C *** Last line of SB03TD *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04NY.f0000644000000000000000000000013215012430707016206 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04NY.f0000644000175000017500000002606415012430707017412 0ustar00lilgelilge00000000000000 SUBROUTINE MB04NY( M, N, V, INCV, TAU, A, LDA, B, LDB, DWORK ) 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 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 B( J, 6 ) = B( J, 6 ) - SUM*T6 140 CONTINUE GO TO 210 150 CONTINUE C C Special code for 8 x 8 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 IV = IV + INCV V7 = V( IV ) T7 = TAU*V7 DO 160 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 ) + $ V7*B( J, 7 ) 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 B( J, 6 ) = B( J, 6 ) - SUM*T6 B( J, 7 ) = B( J, 7 ) - SUM*T7 160 CONTINUE GO TO 210 170 CONTINUE C C Special code for 9 x 9 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 IV = IV + INCV V7 = V( IV ) T7 = TAU*V7 IV = IV + INCV V8 = V( IV ) T8 = TAU*V8 DO 180 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 ) + $ V7*B( J, 7 ) + V8*B( J, 8 ) 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 B( J, 6 ) = B( J, 6 ) - SUM*T6 B( J, 7 ) = B( J, 7 ) - SUM*T7 B( J, 8 ) = B( J, 8 ) - SUM*T8 180 CONTINUE GO TO 210 190 CONTINUE C C Special code for 10 x 10 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 IV = IV + INCV V7 = V( IV ) T7 = TAU*V7 IV = IV + INCV V8 = V( IV ) T8 = TAU*V8 IV = IV + INCV V9 = V( IV ) T9 = TAU*V9 DO 200 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 ) + $ V7*B( J, 7 ) + V8*B( J, 8 ) + V9*B( J, 9 ) 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 B( J, 6 ) = B( J, 6 ) - SUM*T6 B( J, 7 ) = B( J, 7 ) - SUM*T7 B( J, 8 ) = B( J, 8 ) - SUM*T8 B( J, 9 ) = B( J, 9 ) - SUM*T9 200 CONTINUE 210 CONTINUE RETURN C *** Last line of MB04NY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03IZ.f0000644000000000000000000000013215012430707016201 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03IZ.f0000644000175000017500000006042715012430707017406 0ustar00lilgelilge00000000000000 SUBROUTINE MB03IZ( COMPQ, COMPU, N, A, LDA, C, LDC, D, LDD, B, $ LDB, F, LDF, Q, LDQ, U1, LDU1, U2, LDU2, NEIG, $ TOL, INFO ) C C PURPOSE C C To move the eigenvalues with strictly negative real parts of an C N-by-N complex skew-Hamiltonian/Hamiltonian pencil aS - bH in C structured Schur form, with C C ( 0 I ) C S = J Z' J' Z, where J = ( ), C ( -I 0 ) C C to the leading principal subpencil, while keeping the triangular C form. On entry, we have C C ( A D ) ( B F ) C Z = ( ), H = ( ), C ( 0 C ) ( 0 -B' ) C C where A and B are upper triangular and C is lower triangular. C Z and H are transformed by a unitary symplectic matrix U and a C unitary matrix Q such that C C ( Aout Dout ) C Zout = U' Z Q = ( ), and C ( 0 Cout ) C (1) C ( Bout Fout ) C Hout = J Q' J' H Q = ( ), C ( 0 -Bout' ) C C where Aout, Bout and Cout remain in triangular form. The notation C M' denotes the conjugate transpose of the matrix M. C Optionally, if COMPQ = 'I' or COMPQ = 'U', the unitary matrix Q C that fulfills (1) is computed. C Optionally, if COMPU = 'I' or COMPU = 'U', the unitary symplectic C matrix C C ( U1 U2 ) C U = ( ) C ( -U2 U1 ) C C that fulfills (1) is computed. C C ARGUMENTS C C Mode Parameters C C COMPQ CHARACTER*1 C Specifies whether or not the unitary transformations C should be accumulated in the array Q, as follows: C = 'N': Q is not computed; C = 'I': the array Q is initialized internally to the unit C matrix, and the unitary matrix Q is returned; C = 'U': the array Q contains a unitary matrix Q0 on C entry, and the matrix Q0*Q is returned, where Q C is the product of the unitary transformations C that are applied to the pencil aS - bH to reorder C the eigenvalues. C C COMPU CHARACTER*1 C Specifies whether or not the unitary symplectic C transformations should be accumulated in the arrays U1 and C U2, as follows: C = 'N': U1 and U2 are not computed; C = 'I': the arrays U1 and U2 are initialized internally, C and the submatrices U1 and U2 defining the C unitary symplectic matrix U are returned; C = 'U': the arrays U1 and U2 contain the corresponding C submatrices of a unitary symplectic matrix U0 C on entry, and the updated submatrices U1 and U2 C of the matrix product U0*U are returned, where U C is the product of the unitary symplectic C transformations that are applied to the pencil C aS - bH to reorder the eigenvalues. C C Input/Output Parameters C C N (input) INTEGER C The order of the pencil aS - bH. N >= 0, even. C C A (input/output) COMPLEX*16 array, dimension (LDA, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular matrix A. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Aout. C The strictly lower triangular part of this array is not C referenced. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1, N/2). C C C (input/output) COMPLEX*16 array, dimension (LDC, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the lower triangular matrix C. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Cout. C The strictly upper triangular part of this array is not C referenced. C C LDC INTEGER C The leading dimension of the array C. LDC >= MAX(1, N/2). C C D (input/output) COMPLEX*16 array, dimension (LDD, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the matrix D. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Dout. C C LDD INTEGER C The leading dimension of the array D. LDD >= MAX(1, N/2). C C B (input/output) COMPLEX*16 array, dimension (LDB, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular matrix B. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Bout. C The strictly lower triangular part of this array is not C referenced. C C LDB INTEGER C The leading dimension of the array B. LDB >= MAX(1, N/2). C C F (input/output) COMPLEX*16 array, dimension (LDF, N/2) C On entry, the leading N/2-by-N/2 part of this array must C contain the upper triangular part of the Hermitian matrix C F. C On exit, the leading N/2-by-N/2 part of this array C contains the transformed matrix Fout. C The strictly lower triangular part of this array is not C referenced. C C LDF INTEGER C The leading dimension of the array F. LDF >= MAX(1, N/2). C C Q (input/output) COMPLEX*16 array, dimension (LDQ, N) C On entry, if COMPQ = 'U', then the leading N-by-N part of C this array must contain a given matrix Q0, and on exit, C the leading N-by-N part of this array contains the product C of the input matrix Q0 and the transformation matrix Q C used to transform the matrices S and H. C On exit, if COMPQ = 'I', then the leading N-by-N part of C this array contains the unitary transformation matrix Q. C If COMPQ = 'N' this array is not referenced. C C LDQ INTEGER C The leading dimension of the array Q. C LDQ >= 1, if COMPQ = 'N'; C LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'. C C U1 (input/output) COMPLEX*16 array, dimension (LDU1, N/2) C On entry, if COMPU = 'U', then the leading N/2-by-N/2 part C of this array must contain the upper left block of a C given matrix U0, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper left block U1 of C the product of the input matrix U0 and the transformation C matrix U used to transform the matrices S and H. C On exit, if COMPU = 'I', then the leading N/2-by-N/2 part C of this array contains the upper left block U1 of the C unitary symplectic transformation matrix U. C If COMPU = 'N' this array is not referenced. C C LDU1 INTEGER C The leading dimension of the array U1. C LDU1 >= 1, if COMPU = 'N'; C LDU1 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'. C C U2 (input/output) COMPLEX*16 array, dimension (LDU2, N/2) C On entry, if COMPU = 'U', then the leading N/2-by-N/2 part C of this array must contain the upper right block of a C given matrix U0, and on exit, the leading N/2-by-N/2 part C of this array contains the updated upper right block U2 of C the product of the input matrix U0 and the transformation C matrix U used to transform the matrices S and H. C On exit, if COMPU = 'I', then the leading N/2-by-N/2 part C of this array contains the upper right block U2 of the C unitary symplectic transformation matrix U. C If COMPU = 'N' this array is not referenced. C C LDU2 INTEGER C The leading dimension of the array U2. C LDU2 >= 1, if COMPU = 'N'; C LDU2 >= MAX(1, N/2), if COMPU = 'I' or COMPU = 'U'. C C NEIG (output) INTEGER C The number of eigenvalues in aS - bH with strictly C negative real part. C C Tolerances C C TOL DOUBLE PRECISION C The tolerance used to decide the sign of the eigenvalues. C If the user sets TOL > 0, then the given value of TOL is C used. If the user sets TOL <= 0, then an implicitly C computed, default tolerance, defined by MIN(N,10)*EPS, is C used instead, where EPS is the machine precision (see C LAPACK Library routine DLAMCH). A larger value might be C needed for pencils with multiple eigenvalues. C C Error Indicator C C INFO INTEGER C = 0: succesful exit; C < 0: if INFO = -i, the i-th argument had an illegal value. C C METHOD C C The algorithm reorders the eigenvalues like the following scheme: C C Step 1: Reorder the eigenvalues in the subpencil aC'*A - bB. C I. Reorder the eigenvalues with negative real parts to the C top. C II. Reorder the eigenvalues with positive real parts to the C bottom. C C Step 2: Reorder the remaining eigenvalues with negative real C parts. C I. Exchange the eigenvalues between the last diagonal block C in aC'*A - bB and the last diagonal block in aS - bH. C II. Move the eigenvalues in the N/2-th place to the (MM+1)-th C place, where MM denotes the current number of eigenvalues C with negative real parts in aC'*A - bB. C C The algorithm uses a sequence of unitary transformations as C described on page 38 in [1]. To achieve those transformations the C elementary SLICOT Library subroutines MB03CZ and MB03GZ are called C for the corresponding matrix structures. C C REFERENCES C C [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H. C Numerical Computation of Deflating Subspaces of Embedded C Hamiltonian Pencils. C Tech. Rep. SFB393/99-15, Technical University Chemnitz, C Germany, June 1999. C C NUMERICAL ASPECTS C 3 C The algorithm is numerically backward stable and needs O(N ) C complex floating point operations. C C CONTRIBUTOR C C Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet C Chemnitz, April 29, 2009. C V. Sima, Aug. 2009 (SLICOT version of the routine ZHAFNX). C C REVISIONS C C V. Sima, Dec. 2010, Jan. 2011. C M. Voigt, Jan. 2012. C C KEYWORDS C C Eigenvalue reordering, upper triangular matrix, C skew-Hamiltonian/Hamiltonian pencil, structured Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, TEN PARAMETER ( ZERO = 0.0D+0, TEN = 1.0D+1 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ) ) C C .. Scalar Arguments .. CHARACTER COMPQ, COMPU INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDQ, LDU1, LDU2, $ N, NEIG DOUBLE PRECISION TOL C C .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), $ D( LDD, * ), F( LDF, * ), Q( LDQ, * ), $ U1( LDU1, * ), U2( LDU2, * ) C C .. Local Scalars .. LOGICAL LCMPQ, LCMPU, LINIQ, LINIU, LUPDQ, LUPDU INTEGER IUPD, J, K, M, MM, MP, UPDS DOUBLE PRECISION CO1, CO2, CO3, EPS, NRMA, NRMB COMPLEX*16 CJF, SI1, SI2, SI3, TMP C C .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) COMPLEX*16 HLP( 2, 2 ) C C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANTR EXTERNAL DLAMCH, LSAME, ZLANTR C C .. External Subroutines .. EXTERNAL MB03CZ, MB03GZ, XERBLA, ZLASET, ZROT C C .. Intrinsic Functions .. INTRINSIC DBLE, DCONJG, MAX, MIN, MOD C C .. Executable Statements .. C C Decode the input arguments. C M = N/2 NEIG = 0 LINIQ = LSAME( COMPQ, 'I' ) LUPDQ = LSAME( COMPQ, 'U' ) LCMPQ = LINIQ .OR. LUPDQ LINIU = LSAME( COMPU, 'I' ) LUPDU = LSAME( COMPU, 'U' ) LCMPU = LINIU .OR. LUPDU C C Test the input arguments. C INFO = 0 IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( COMPU, 'N' ) .OR. LCMPU ) ) THEN INFO = -2 ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDD.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( LDB.LT.MAX( 1, M ) ) THEN INFO = -11 ELSE IF( LDF.LT.MAX( 1, M ) ) THEN INFO = -13 ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN INFO = -15 ELSE IF( LDU1.LT.1 .OR. ( LCMPU .AND. LDU1.LT.M ) ) THEN INFO = -17 ELSE IF( LDU2.LT.1 .OR. ( LCMPU .AND. LDU2.LT.M ) ) THEN INFO = -19 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'MB03IZ', -INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) THEN RETURN END IF C EPS = TOL IF ( EPS.LE.ZERO ) THEN C C Use the default tolerance. C EPS = MIN( DBLE( N ), TEN )*DLAMCH( 'Precision' ) END IF C C STEP 0. Initializations. C IF( LINIQ ) THEN IUPD = M + 1 UPDS = M CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ ) ELSE IF( LUPDQ ) THEN IUPD = 1 UPDS = N END IF C IF( LINIU ) THEN CALL ZLASET( 'Full', M, M, CZERO, CONE, U1, LDU1 ) CALL ZLASET( 'Full', M, M, CZERO, CZERO, U2, LDU2 ) END IF C C STEP 1. Reorder the eigenvalues in the subpencil aC'*A - bB. C MM = 0 MP = M + 1 NRMA = ZLANTR( 'One', 'Upper', 'Non-Unit', M, M, A, LDA, DUM )* $ ZLANTR( 'One', 'Lower', 'Non-Unit', M, M, C, LDC, DUM ) NRMB = ZLANTR( 'One', 'Upper', 'Non-Unit', M, M, B, LDB, DUM ) C C I. Reorder the eigenvalues with negative real parts to the top. C DO 20 K = 1, M IF( DBLE( B( K, K )*C( K, K )*DCONJG( A( K, K ) ) )*NRMB.LE. $ -EPS*NRMA ) THEN DO 10 J = K - 1, MM + 1, -1 C C Perform eigenvalue exchange. C HLP( 1, 1 ) = DCONJG( C( J, J ) ) HLP( 1, 2 ) = DCONJG( C( J+1, J ) ) HLP( 2, 2 ) = DCONJG( C( J+1, J+1 ) ) C CALL MB03CZ( HLP, 2, A( J, J ), LDA, B( J, J ), $ LDB, CO1, SI1, CO2, SI2, CO3, SI3 ) C C Update A, C, and D. C CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 ) A( J, J ) = CO2*A( J, J ) + $ SI2*A( J+1, J+1 )*DCONJG( SI1 ) A( J+1, J+1 ) = CO1*A( J+1, J+1 ) CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, $ CO2, -SI2 ) C CALL ZROT( M, D( 1, J+1 ), 1, D( 1, J ), 1, CO3, SI3 ) CALL ZROT( M, D( J, 1 ), LDD, D( J+1, 1 ), LDD, CO2, -SI2 $ ) C CALL ZROT( M-J, C( J+1, J+1 ), 1, C( J+1, J ), 1, CO3, $ SI3 ) C( J+1, J+1 ) = CO2*C( J+1, J+1 ) + $ SI3*C( J, J )*DCONJG( SI2 ) C( J, J ) = CO3*C( J, J ) CALL ZROT( J, C( J, 1 ), LDC, C( J+1, 1 ), LDC, CO2, $ -SI2 ) C C Update B and F. C CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 ) B( J, J ) = CO3*B( J, J ) + $ SI3*B( J+1, J+1 )*DCONJG( SI1 ) B( J+1, J+1 ) = CO1*B( J+1, J+1 ) CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, $ CO3, -SI3 ) C CJF = DCONJG( F( J, J+1 ) ) TMP = CO3*CJF - DCONJG( SI3 )*F( J+1, J+1 ) CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO3, SI3 ) F( J, J ) = CO3*F( J, J ) - SI3*TMP F( J+1, J+1 ) = CO3*F( J+1, J+1 ) + SI3*CJF CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF, $ CO3, -SI3 ) C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, $ SI1 ) CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ), $ 1, CO3, SI3 ) END IF C IF( LCMPU ) THEN C C Update U. C CALL ZROT( M, U1( 1, J+1 ), 1, U1( 1, J ), 1, CO2, SI2 $ ) IF( LUPDU ) THEN CALL ZROT( M, U2( 1, J+1 ), 1, U2( 1, J ), 1, CO2, $ SI2 ) END IF END IF 10 CONTINUE MM = MM + 1 END IF 20 CONTINUE C C II. Reorder the eigenvalues with positive real parts to the bottom. C DO 40 K = M, MM + 1, -1 IF( DBLE( B( K, K )*C( K, K )*DCONJG( A( K, K ) ) )*NRMB.GE. $ EPS*NRMA ) THEN DO 30 J = K, MP - 2 C C Perform eigenvalue exchange. C HLP( 1, 1 ) = DCONJG( C( J, J ) ) HLP( 1, 2 ) = DCONJG( C( J+1, J ) ) HLP( 2, 2 ) = DCONJG( C( J+1, J+1 ) ) C CALL MB03CZ( HLP, 2, A( J, J ), LDA, B( J, J ), $ LDB, CO1, SI1, CO2, SI2, CO3, SI3 ) C C Update A, C, and D. C CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 ) A( J, J ) = CO2*A( J, J ) + $ SI2*A( J+1, J+1 )*DCONJG( SI1 ) A( J+1, J+1 ) = CO1*A( J+1, J+1 ) CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, $ CO2, -SI2 ) C CALL ZROT( M, D( 1, J+1 ), 1, D( 1, J ), 1, CO3, SI3 ) CALL ZROT( M, D( J, 1 ), LDD, D( J+1, 1 ), LDD, CO2, -SI2 $ ) C CALL ZROT( M-J, C( J+1, J+1 ), 1, C( J+1, J ), 1, CO3, $ SI3 ) C( J+1, J+1 ) = CO2*C( J+1, J+1 ) + $ SI3*C( J, J )*DCONJG( SI2 ) C( J, J ) = CO3*C( J, J ) CALL ZROT( J, C( J, 1 ), LDC, C( J+1, 1 ), LDC, CO2, $ -SI2 ) C C Update B and F. C CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 ) B( J, J ) = CO3*B( J, J ) + $ SI3*B( J+1, J+1 )*DCONJG( SI1 ) B( J+1, J+1 ) = CO1*B( J+1, J+1 ) CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, $ CO3, -SI3 ) C CJF = DCONJG( F( J, J+1 ) ) TMP = CO3*CJF - DCONJG( SI3 )*F( J+1, J+1 ) CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO3, SI3 ) F( J, J ) = CO3*F( J, J ) - SI3*TMP F( J+1, J+1 ) = CO3*F( J+1, J+1 ) + SI3*CJF CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF, $ CO3, -SI3 ) C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( UPDS, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, $ SI1 ) CALL ZROT( UPDS, Q( IUPD, M+J+1 ), 1, Q( IUPD, M+J ), $ 1, CO3, SI3 ) END IF C IF( LCMPU ) THEN C C Update U. C CALL ZROT( M, U1( 1, J+1 ), 1, U1( 1, J ), 1, CO2, SI2 $ ) IF( LUPDU ) THEN CALL ZROT( M, U2( 1, J+1 ), 1, U2( 1, J ), 1, CO2, $ SI2 ) END IF END IF 30 CONTINUE MP = MP - 1 END IF 40 CONTINUE C C The remaining M-MP+1 eigenvalues with negative real part are now in C the bottom right subpencil of aS - bH. C C STEP 2. Reorder the remaining M-MP+1 eigenvalues. C DO 60 K = M, MP, -1 C C I. Exchange the eigenvalues between two diagonal blocks. C C Perform eigenvalue exchange. C CALL MB03GZ( A( M, M ), D( M, M ), C( M, M ), B( M, M ), $ F( M, M ), CO1, SI1, CO2, SI2 ) C C Update A, C, and D. C CALL ZROT( M, D( 1, M ), 1, A( 1, M ), 1, CO1, SI1 ) TMP = -DCONJG( SI1 )*C( M, M ) C( M, M ) = CO1*C( M, M ) CALL ZROT( M, D( M, 1 ), LDD, C( M, 1 ), LDC, CO2, $ -DCONJG( SI2 ) ) A( M, M ) = CO2*A( M, M ) - DCONJG( SI2 )*TMP C C Update B and F. C TMP = -DCONJG( B( M, M ) ) CALL ZROT( M, F( 1, M ), 1, B( 1, M ), 1, CO1, SI1 ) B( M, M ) = B( M, M )*CO1 + TMP*DCONJG( SI1 )**2 F( M, M ) = F( M, M )*CO1 - TMP*DCONJG( SI1 )*CO1 C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( N, Q( 1, N ), 1, Q( 1, M ), 1, CO1, SI1 ) END IF C IF( LCMPU ) THEN C C Update U. C CALL ZROT( M, U2( 1, M ), 1, U1( 1, M ), 1, CO2, SI2 ) END IF C C II. Move the eigenvalue in the M-th diagonal position to the C (MM+1)-th position. C MM = MM + 1 DO 50 J = M - 1, MM, -1 C C Perform eigenvalue exchange. C HLP( 1, 1 ) = DCONJG( C( J, J ) ) HLP( 1, 2 ) = DCONJG( C( J+1, J ) ) HLP( 2, 2 ) = DCONJG( C( J+1, J+1 ) ) C CALL MB03CZ( HLP, 2, A( J, J ), LDA, B( J, J ), LDB, CO1, $ SI1, CO2, SI2, CO3, SI3 ) C C Update A, C, and D. C CALL ZROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO1, SI1 ) A( J, J ) = CO2*A( J, J ) + $ SI2*A( J+1, J+1 )*DCONJG( SI1 ) A( J+1, J+1 ) = CO1*A( J+1, J+1 ) CALL ZROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO2, $ -SI2 ) C CALL ZROT( M, D( 1, J+1 ), 1, D( 1, J ), 1, CO3, SI3 ) CALL ZROT( M, D( J, 1 ), LDD, D( J+1, 1 ), LDD, CO2, -SI2 ) C CALL ZROT( M-J, C( J+1, J+1 ), 1, C( J+1, J ), 1, CO3, SI3 ) C( J+1, J+1 ) = CO2*C( J+1, J+1 ) + $ SI3*C( J, J )*DCONJG( SI2 ) C( J, J ) = CO3*C( J, J ) CALL ZROT( J, C( J, 1 ), LDC, C( J+1, 1 ), LDC, CO2, -SI2 ) C C Update B and F. C CALL ZROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO1, SI1 ) B( J, J ) = CO3*B( J, J ) + $ SI3*B( J+1, J+1 )*DCONJG( SI1 ) B( J+1, J+1 ) = CO1*B( J+1, J+1 ) CALL ZROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, CO3, $ -SI3 ) C CJF = DCONJG( F( J, J+1 ) ) TMP = CO3*CJF - DCONJG( SI3 )*F( J+1, J+1 ) CALL ZROT( J, F( 1, J+1 ), 1, F( 1, J ), 1, CO3, SI3 ) F( J, J ) = CO3*F( J, J ) - SI3*TMP F( J+1, J+1 ) = CO3*F( J+1, J+1 ) + SI3*CJF CALL ZROT( M-J, F( J, J+1 ), LDF, F( J+1, J+1 ), LDF, CO3, $ -SI3 ) C IF( LCMPQ ) THEN C C Update Q. C CALL ZROT( N, Q( 1, J+1 ), 1, Q( 1, J ), 1, CO1, SI1 ) CALL ZROT( N, Q( 1, M+J+1 ), 1, Q( 1, M+J ), 1, CO3, SI3 $ ) END IF C IF( LCMPU ) THEN C C Update U. C CALL ZROT( M, U1( 1, J+1 ), 1, U1( 1, J ), 1, CO2, SI2 ) CALL ZROT( M, U2( 1, J+1 ), 1, U2( 1, J ), 1, CO2, SI2 ) END IF 50 CONTINUE 60 CONTINUE C NEIG = MM C RETURN C *** Last line of MB03IZ *** END control-4.1.2/src/slicot/src/PaxHeaders/SB02MV.f0000644000000000000000000000013015012430707016204 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB02MV.f0000644000175000017500000000231515012430707017403 0ustar00lilgelilge00000000000000 LOGICAL FUNCTION SB02MV( REIG, IEIG ) C C PURPOSE C C To select the stable eigenvalues for solving the continuous-time C algebraic Riccati equation. C C ARGUMENTS C C Input/Output Parameters C C REIG (input) DOUBLE PRECISION C The real part of the current eigenvalue considered. C C IEIG (input) DOUBLE PRECISION C The imaginary part of the current eigenvalue considered. C C METHOD C C The function value SB02MV is set to .TRUE. for a stable eigenvalue C and to .FALSE., otherwise. C C REFERENCES C C None. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTOR C C V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. C C REVISIONS C C - C C KEYWORDS C C Algebraic Riccati equation, closed loop system, continuous-time C system, optimal regulator, Schur form. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. DOUBLE PRECISION IEIG, REIG C .. Executable Statements .. C SB02MV = REIG.LT.ZERO C RETURN C *** Last line of SB02MV *** END control-4.1.2/src/slicot/src/PaxHeaders/MB04YW.f0000644000000000000000000000013215012430707016217 xustar0030 mtime=1747595719.973100386 30 atime=1747595719.973100386 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB04YW.f0000644000175000017500000004172515012430707017424 0ustar00lilgelilge00000000000000 SUBROUTINE MB04YW( QRIT, UPDATU, UPDATV, M, N, L, K, SHIFT, D, E, $ U, LDU, V, LDV, DWORK ) C C PURPOSE C C To perform either one QR or QL iteration step onto the unreduced C bidiagonal submatrix Jk: C C |D(l) E(l) 0 ... 0 | C | 0 D(l+1) E(l+1) . | C Jk = | . . | C | . . | C | . E(k-1)| C | 0 ... ... D(k) | C C with k <= p and l >= 1, p = MIN(M,N), of the bidiagonal matrix J: C C |D(1) E(1) 0 ... 0 | C | 0 D(2) E(2) . | C J = | . . |. C | . . | C | . E(p-1)| C | 0 ... ... D(p) | C C Hereby, Jk is transformed to S' Jk T with S and T products of C Givens rotations. These Givens rotations S (respectively, T) are C postmultiplied into U (respectively, V), if UPDATU (respectively, C UPDATV) is .TRUE.. C C ARGUMENTS C C Mode Parameters C C QRIT LOGICAL C Indicates whether a QR or QL iteration step is to be C taken (from larger end diagonal element towards smaller), C as follows: C = .TRUE. : QR iteration step (chase bulge from top to C bottom); C = .FALSE.: QL iteration step (chase bulge from bottom to C top). C C UPDATU LOGICAL C Indicates whether the user wishes to accumulate in a C matrix U the left-hand Givens rotations S, as follows: C = .FALSE.: Do not form U; C = .TRUE. : The given matrix U is updated (postmultiplied) C by the left-hand Givens rotations S. C C UPDATV LOGICAL C Indicates whether the user wishes to accumulate in a C matrix V the right-hand Givens rotations S, as follows: C = .FALSE.: Do not form V; C = .TRUE. : The given matrix V is updated (postmultiplied) C by the right-hand Givens rotations T. C C Input/Output Parameters C C M (input) INTEGER C The number of rows of the matrix U. M >= 0. C C N (input) INTEGER C The number of rows of the matrix V. N >= 0. C C L (input) INTEGER C The index of the first diagonal entry of the considered C unreduced bidiagonal submatrix Jk of J. C C K (input) INTEGER C The index of the last diagonal entry of the considered C unreduced bidiagonal submatrix Jk of J. C C SHIFT (input) DOUBLE PRECISION C Value of the shift used in the QR or QL iteration step. C C D (input/output) DOUBLE PRECISION array, dimension (p) C where p = MIN(M,N) C On entry, D must contain the diagonal entries of the C bidiagonal matrix J. C On exit, D contains the diagonal entries of the C transformed bidiagonal matrix S' J T. C C E (input/output) DOUBLE PRECISION array, dimension (p-1) C On entry, E must contain the superdiagonal entries of J. C On exit, E contains the superdiagonal entries of the C transformed matrix S' J T. C C U (input/output) DOUBLE PRECISION array, dimension (LDU,p) C On entry, if UPDATU = .TRUE., U must contain the M-by-p C left transformation matrix. C On exit, if UPDATU = .TRUE., the Givens rotations S on the C left have been postmultiplied into U, i.e., U * S is C returned. C U is not referenced if UPDATU = .FALSE.. C C LDU INTEGER C The leading dimension of the array U. C LDU >= max(1,M) if UPDATU = .TRUE.; C LDU >= 1 if UPDATU = .FALSE.. C C V (input/output) DOUBLE PRECISION array, dimension (LDV,p) C On entry, if UPDATV = .TRUE., V must contain the N-by-p C right transformation matrix. C On exit, if UPDATV = .TRUE., the Givens rotations T on the C right have been postmultiplied into V, i.e., V * T is C returned. C V is not referenced if UPDATV = .FALSE.. C C LDV INTEGER C The leading dimension of the array V. C LDV >= max(1,N) if UPDATV = .TRUE.; C LDV >= 1 if UPDATV = .FALSE.. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)) C LDWORK >= 4*MIN(M,N)-4, if UPDATU = UPDATV = .TRUE.; C LDWORK >= 2*MIN(M,N)-2, if C UPDATU = .TRUE. and UPDATV = .FALSE. or C UPDATV = .TRUE. and UPDATU = .FALSE.; C LDWORK >= 1, if UPDATU = UPDATV = .FALSE.. C C METHOD C C QR iterations diagonalize the bidiagonal matrix by zeroing the C super-diagonal elements of Jk from bottom to top. C QL iterations diagonalize the bidiagonal matrix by zeroing the C super-diagonal elements of Jk from top to bottom. C The routine overwrites Jk with the bidiagonal matrix S' Jk T, C where S and T are products of Givens rotations. C T is essentially the orthogonal matrix that would be obtained by C applying one implicit symmetric shift QR (QL) step onto the matrix C Jk'Jk. This step factors the matrix (Jk'Jk - shift*I) into a C product of an orthogonal matrix T and a upper (lower) triangular C matrix. See [1,Sec.8.2-8.3] and [2] for more details. C C REFERENCES C C [1] Golub, G.H. and Van Loan, C.F. C Matrix Computations. C The Johns Hopkins University Press, Baltimore, Maryland, 1983. C C [2] Bowdler, H., Martin, R.S. and Wilkinson, J.H. C The QR and QL algorithms for symmetric matrices. C Numer. Math., 11, pp. 293-306, 1968. C C [3] Demmel, J. and Kahan, W. C Computing small singular values of bidiagonal matrices with C guaranteed high relative accuracy. C SIAM J. Sci. Statist. Comput., 11, pp. 873-912, 1990. 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, June 1997. C Supersedes Release 2.0 routines MB04QY and MB04QZ by S. Van C Huffel, Katholieke University Leuven, Belgium. C This subroutine is based on the QR/QL step implemented in LAPACK C routine DBDSQR. C C REVISIONS C C - C C KEYWORDS C C Bidiagonal matrix, orthogonal transformation, singular values. C C ****************************************************************** C DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. LOGICAL QRIT, UPDATU, UPDATV INTEGER K, L, LDU, LDV, M, N DOUBLE PRECISION SHIFT C .. C .. Array Arguments .. DOUBLE PRECISION D( * ), DWORK( * ), E( * ), U( LDU, * ), $ V( LDV, * ) C .. C .. Local Scalars .. INTEGER I, IROT, NCV, NM1, NM12, NM13 DOUBLE PRECISION COSL, COSR, CS, F, G, H, OLDCS, OLDSN, R, SINL, $ SINR, SN C .. C .. External Subroutines .. EXTERNAL DLARTG, DLASR C .. C .. Intrinsic Functions .. INTRINSIC ABS, MIN, SIGN C .. C .. Executable Statements .. C C For speed, no tests of the input scalar arguments are done. C C Quick return if possible. C NCV = MIN( M, N ) IF ( NCV.LE.1 .OR. L.EQ.K ) $ RETURN C NM1 = NCV - 1 NM12 = NM1 + NM1 NM13 = NM12 + NM1 IF ( .NOT.UPDATV ) THEN NM12 = 0 NM13 = NM1 END IF C C If SHIFT = 0, do simplified QR iteration. C IF( SHIFT.EQ.ZERO ) THEN IF( QRIT ) THEN C C Chase bulge from top to bottom. C Save cosines and sines for later U and/or V updates, C if needed. C CS = ONE OLDCS = ONE CALL DLARTG( D( L )*CS, E( L ), CS, SN, R ) CALL DLARTG( OLDCS*R, D( L+1 )*SN, OLDCS, OLDSN, D( L ) ) IF ( UPDATV ) THEN DWORK( 1 ) = CS DWORK( 1+NM1 ) = SN END IF IF ( UPDATU ) THEN DWORK( 1+NM12 ) = OLDCS DWORK( 1+NM13 ) = OLDSN END IF IROT = 1 C DO 110 I = L + 1, K - 1 CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) E( I-1 ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) IROT = IROT + 1 IF ( UPDATV ) THEN DWORK( IROT ) = CS DWORK( IROT+NM1 ) = SN END IF IF ( UPDATU ) THEN DWORK( IROT+NM12 ) = OLDCS DWORK( IROT+NM13 ) = OLDSN END IF 110 CONTINUE C H = D( K )*CS D( K ) = H*OLDCS E( K-1 ) = H*OLDSN C C Update U and/or V. C IF( UPDATV ) $ CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ), $ DWORK( NCV ), V( 1, L ), LDV ) IF( UPDATU ) $ CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ), $ DWORK( NM13+1 ), U( 1, L ), LDU ) C ELSE C C Chase bulge from bottom to top. C Save cosines and sines for later U and/or V updates, C if needed. C CS = ONE OLDCS = ONE CALL DLARTG( D( K )*CS, E( K-1 ), CS, SN, R ) CALL DLARTG( OLDCS*R, D( K-1 )*SN, OLDCS, OLDSN, D( K ) ) IF ( UPDATV ) THEN DWORK( K-L ) = OLDCS DWORK( K-L+NM1 ) = -OLDSN END IF IF ( UPDATU ) THEN DWORK( K-L+NM12 ) = CS DWORK( K-L+NM13 ) = -SN END IF IROT = K - L C DO 120 I = K - 1, L + 1, -1 CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) E( I ) = OLDSN*R CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) IROT = IROT - 1 IF ( UPDATV ) THEN DWORK( IROT ) = OLDCS DWORK( IROT+NM1 ) = -OLDSN END IF IF ( UPDATU ) THEN DWORK( IROT+NM12 ) = CS DWORK( IROT+NM13 ) = -SN END IF 120 CONTINUE C H = D( L )*CS D( L ) = H*OLDCS E( L ) = H*OLDSN C C Update U and/or V. C IF( UPDATV ) $ CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ), $ DWORK( NCV ), V( 1, L ), LDV ) IF( UPDATU ) $ CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ), $ DWORK( NM13+1 ), U( 1, L ), LDU ) END IF ELSE C C Use nonzero shift. C IF( QRIT ) THEN C C Chase bulge from top to bottom. C Save cosines and sines for later U and/or V updates, C if needed. C F = ( ABS( D( L ) ) - SHIFT )* $ ( SIGN( ONE, D( L ) ) + SHIFT / D( L ) ) G = E( L ) CALL DLARTG( F, G, COSR, SINR, R ) F = COSR*D( L ) + SINR*E( L ) E( L ) = COSR*E( L ) - SINR*D( L ) G = SINR*D( L+1 ) D( L+1 ) = COSR*D( L+1 ) CALL DLARTG( F, G, COSL, SINL, R ) D( L ) = R F = COSL*E( L ) + SINL*D( L+1 ) D( L+1 ) = COSL*D( L+1 ) - SINL*E( L ) G = SINL*E( L+1 ) E( L+1 ) = COSL*E( L+1 ) IF ( UPDATV ) THEN DWORK( 1 ) = COSR DWORK( 1+NM1 ) = SINR END IF IF ( UPDATU ) THEN DWORK( 1+NM12 ) = COSL DWORK( 1+NM13 ) = SINL END IF IROT = 1 C DO 130 I = L + 1, K - 2 CALL DLARTG( F, G, COSR, SINR, R ) E( I-1 ) = R F = COSR*D( I ) + SINR*E( I ) E( I ) = COSR*E( I ) - SINR*D( I ) G = SINR*D( I+1 ) D( I+1 ) = COSR*D( I+1 ) CALL DLARTG( F, G, COSL, SINL, R ) D( I ) = R F = COSL*E( I ) + SINL*D( I+1 ) D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) G = SINL*E( I+1 ) E( I+1 ) = COSL*E( I+1 ) IROT = IROT + 1 IF ( UPDATV ) THEN DWORK( IROT ) = COSR DWORK( IROT+NM1 ) = SINR END IF IF ( UPDATU ) THEN DWORK( IROT+NM12 ) = COSL DWORK( IROT+NM13 ) = SINL END IF 130 CONTINUE C IF ( L.LT.K-1 ) THEN CALL DLARTG( F, G, COSR, SINR, R ) E( K-2 ) = R F = COSR*D( K-1 ) + SINR*E( K-1 ) E( K-1 ) = COSR*E( K-1 ) - SINR*D( K-1 ) G = SINR*D( K ) D( K ) = COSR*D( K ) CALL DLARTG( F, G, COSL, SINL, R ) D( K-1 ) = R F = COSL*E( K-1 ) + SINL*D( K ) D( K ) = COSL*D( K ) - SINL*E( K-1 ) IROT = IROT + 1 IF ( UPDATV ) THEN DWORK( IROT ) = COSR DWORK( IROT+NM1 ) = SINR END IF IF ( UPDATU ) THEN DWORK( IROT+NM12 ) = COSL DWORK( IROT+NM13 ) = SINL END IF END IF E( K-1 ) = F C C Update U and/or V. C IF( UPDATV ) $ CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ), $ DWORK( NCV ), V( 1, L ), LDV ) IF( UPDATU ) $ CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ), $ DWORK( NM13+1 ), U( 1, L ), LDU ) C ELSE C C Chase bulge from bottom to top. C Save cosines and sines for later U and/or V updates, C if needed. C F = ( ABS( D( K ) ) - SHIFT )* $ ( SIGN( ONE, D( K ) ) + SHIFT / D( K ) ) G = E( K-1 ) IF ( L.LT.K-1 ) THEN CALL DLARTG( F, G, COSR, SINR, R ) F = COSR*D( K ) + SINR*E( K-1 ) E( K-1 ) = COSR*E( K-1 ) - SINR*D( K ) G = SINR*D( K-1 ) D( K-1 ) = COSR*D( K-1 ) CALL DLARTG( F, G, COSL, SINL, R ) D( K ) = R F = COSL*E( K-1 ) + SINL*D( K-1 ) D( K-1 ) = COSL*D( K-1 ) - SINL*E( K-1 ) G = SINL*E( K-2 ) E( K-2 ) = COSL*E( K-2 ) IF ( UPDATV ) THEN DWORK( K-L ) = COSL DWORK( K-L+NM1 ) = -SINL END IF IF ( UPDATU ) THEN DWORK( K-L+NM12 ) = COSR DWORK( K-L+NM13 ) = -SINR END IF IROT = K - L ELSE IROT = K - L + 1 END IF C DO 140 I = K - 1, L + 2, -1 CALL DLARTG( F, G, COSR, SINR, R ) E( I ) = R F = COSR*D( I ) + SINR*E( I-1 ) E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) G = SINR*D( I-1 ) D( I-1 ) = COSR*D( I-1 ) CALL DLARTG( F, G, COSL, SINL, R ) D( I ) = R F = COSL*E( I-1 ) + SINL*D( I-1 ) D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) G = SINL*E( I-2 ) E( I-2 ) = COSL*E( I-2 ) IROT = IROT - 1 IF ( UPDATV ) THEN DWORK( IROT ) = COSL DWORK( IROT+NM1 ) = -SINL END IF IF ( UPDATU ) THEN DWORK( IROT+NM12 ) = COSR DWORK( IROT+NM13 ) = -SINR END IF 140 CONTINUE C CALL DLARTG( F, G, COSR, SINR, R ) E( L+1 ) = R F = COSR*D( L+1 ) + SINR*E( L ) E( L ) = COSR*E( L ) - SINR*D( L+1 ) G = SINR*D( L ) D( L ) = COSR*D( L ) CALL DLARTG( F, G, COSL, SINL, R ) D( L+1 ) = R F = COSL*E( L ) + SINL*D( L ) D( L ) = COSL*D( L ) - SINL*E( L ) IROT = IROT - 1 IF ( UPDATV ) THEN DWORK( IROT ) = COSL DWORK( IROT+NM1 ) = -SINL END IF IF ( UPDATU ) THEN DWORK( IROT+NM12 ) = COSR DWORK( IROT+NM13 ) = -SINR END IF E( L ) = F C C Update U and/or V if desired. C IF( UPDATV ) $ CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ), $ DWORK( NCV ), V( 1, L ), LDV ) IF( UPDATU ) $ CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ), $ DWORK( NM13+1 ), U( 1, L ), LDU ) END IF END IF C RETURN C *** Last line of MB04YW *** END control-4.1.2/src/slicot/src/PaxHeaders/SB04MD.f0000644000000000000000000000013215012430707016166 xustar0030 mtime=1747595719.981100675 30 atime=1747595719.981100675 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB04MD.f0000644000175000017500000003041615012430707017366 0ustar00lilgelilge00000000000000 SUBROUTINE SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, $ DWORK, LDWORK, INFO ) 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 If LDWORK = -1, then a workspace query is assumed; the C routine only calculates the optimal size of the DWORK C array, returns this value as the first entry of the DWORK C array, and no error message related to LDWORK is issued by C 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 > 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 V. Sima, Research Institute for Informatics, Bucharest, July 2011. 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 .. LOGICAL LQUERY INTEGER I, IEIG, IFAIL, IHI, ILO, IND, ITAU, JWORK, $ MINDW, SDIM, WRKOPT C .. Local Arrays .. LOGICAL BWORK(1) C .. External Functions .. LOGICAL SELECT EXTERNAL SELECT 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 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( 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 ILO = 1 IHI = N MINDW = MAX( 1, 2*N*N + 8*N, 5*M, N + M ) IF( LQUERY ) THEN CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, $ SDIM, DWORK, DWORK, Z, LDZ, DWORK, -1, BWORK, $ IFAIL ) WRKOPT = MAX( MINDW, 2*M + INT( DWORK(1) ) ) CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK, DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) ) CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, $ DWORK, C, LDC, DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) ) CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, $ DWORK, C, LDC, DWORK, -1, IFAIL ) WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) ) ELSE IF( LDWORK.LT.MINDW ) THEN INFO = -13 END IF END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'SB04MD', -INFO ) RETURN ELSE IF( LQUERY ) THEN DWORK(1) = WRKOPT 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 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 DWORK(1) = WRKOPT RETURN C *** Last line of SB04MD *** END control-4.1.2/src/slicot/src/PaxHeaders/FB01RD.f0000644000000000000000000000013215012430707016153 xustar0030 mtime=1747595719.957099808 30 atime=1747595719.957099808 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/FB01RD.f0000644000175000017500000004575615012430707017370 0ustar00lilgelilge00000000000000 SUBROUTINE FB01RD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B, $ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL, $ IWORK, DWORK, LDWORK, INFO ) C C PURPOSE C C To calculate a combined measurement and time update of one C iteration of the time-invariant Kalman filter. This update is C given for the square root covariance filter, using the condensed C observer Hessenberg form. C C ARGUMENTS C C Mode Parameters C C JOBK CHARACTER*1 C Indicates whether the user wishes to compute the Kalman C filter gain matrix K as follows: C i C = 'K': K is computed and stored in array K; C i C = 'N': K is not required. C i C C MULTBQ CHARACTER*1 1/2 C Indicates how matrices B and Q are to be passed to C i i C the routine as follows: C = 'P': Array Q is not used and the array B must contain C 1/2 C the product B Q ; C i i C = 'N': Arrays B and Q must contain the matrices as C described below. C C Input/Output Parameters C C N (input) INTEGER C The actual state dimension, i.e., the order of the C matrices S and A. N >= 0. C i-1 C C M (input) INTEGER C The actual input dimension, i.e., the order of the matrix C 1/2 C Q . M >= 0. C i C C P (input) INTEGER C The actual output dimension, i.e., the order of the matrix C 1/2 C R . P >= 0. C i C C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) C On entry, the leading N-by-N lower triangular part of this C array must contain S , the square root (left Cholesky C i-1 C factor) of the state covariance matrix at instant (i-1). C On exit, the leading N-by-N lower triangular part of this C array contains S , the square root (left Cholesky factor) C i C of the state covariance matrix at instant i. C The strict upper triangular part of this array is not C referenced. C C LDS INTEGER C The leading dimension of array S. LDS >= MAX(1,N). C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The leading N-by-N part of this array must contain A, C the state transition matrix of the discrete system in C lower observer Hessenberg form (e.g., as produced by C SLICOT Library Routine TB01ND). 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 B , C 1/2 i C the input weight matrix (or the product B Q if C i i C MULTBQ = 'P') of the discrete system at instant i. C C LDB INTEGER C The leading dimension of array B. LDB >= MAX(1,N). C C Q (input) DOUBLE PRECISION array, dimension (LDQ,*) C If MULTBQ = 'N', then the leading M-by-M lower triangular C 1/2 C part of this array must contain Q , the square root C i C (left Cholesky factor) of the input (process) noise C covariance matrix at instant i. C The strict upper triangular part of this array is not C referenced. C Otherwise, Q is not referenced and can be supplied as a C dummy array (i.e., set parameter LDQ = 1 and declare this C array to be Q(1,1) in the calling program). C C LDQ INTEGER C The leading dimension of array Q. C LDQ >= MAX(1,M) if MULTBQ = 'N'; C LDQ >= 1 if MULTBQ = 'P'. C C C (input) DOUBLE PRECISION array, dimension (LDC,N) C The leading P-by-N part of this array must contain C, C the output weight matrix of the discrete system in lower C observer Hessenberg form (e.g., as produced by SLICOT C Library routine TB01ND). C C LDC INTEGER C The leading dimension of array C. LDC >= MAX(1,P). C C R (input/output) DOUBLE PRECISION array, dimension (LDR,P) C On entry, the leading P-by-P lower triangular part of this C 1/2 C array must contain R , the square root (left Cholesky C i C factor) of the output (measurement) noise covariance C matrix at instant i. C On exit, the leading P-by-P lower triangular part of this C 1/2 C array contains (RINOV ) , the square root (left Cholesky C i C factor) of the covariance matrix of the innovations at C instant i. C The strict upper triangular part of this array is not C referenced. C C LDR INTEGER C The leading dimension of array R. LDR >= MAX(1,P). C C K (output) DOUBLE PRECISION array, dimension (LDK,P) C If JOBK = 'K', and INFO = 0, then the leading N-by-P part C of this array contains K , the Kalman filter gain matrix C i C at instant i. C If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the C leading N-by-P part of this array contains AK , a matrix C i C related to the Kalman filter gain matrix at instant i (see C -1/2 C METHOD). Specifically, AK = A P C'(RINOV') . C i i|i-1 i C C LDK INTEGER C The leading dimension of array K. LDK >= MAX(1,N). C C Tolerances C C TOL DOUBLE PRECISION C If JOBK = 'K', then TOL is used to test for near C 1/2 C singularity of the matrix (RINOV ) . If the user sets C i C TOL > 0, then the given value of TOL is used as a C lower bound for the reciprocal condition number of that C matrix; a matrix whose estimated condition number is less C than 1/TOL is considered to be nonsingular. If the user C sets TOL <= 0, then an implicitly computed, default C tolerance, defined by TOLDEF = P*P*EPS, is used instead, C where EPS is the machine precision (see LAPACK Library C routine DLAMCH). C Otherwise, TOL is not referenced. C C Workspace C C IWORK INTEGER array, dimension (LIWORK) C where LIWORK = P if JOBK = 'K', C and LIWORK = 1 otherwise. C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal value C of LDWORK. If INFO = 0 and JOBK = 'K', DWORK(2) returns C an estimate of the reciprocal of the condition number C 1/2 C (in the 1-norm) of (RINOV ) . C i C C LDWORK The length of the array DWORK. C LDWORK >= MAX(1,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2)), C if JOBK = 'N'; C LDWORK >= MAX(2,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2),3*P), C if JOBK = 'K'. 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/2 C = 1: if JOBK = 'K' and the matrix (RINOV ) is singular, C i 1/2 C i.e., the condition number estimate of (RINOV ) C i C (in the 1-norm) exceeds 1/TOL. The matrices S, AK , C 1/2 i C and (RINOV ) have been computed. C i C C METHOD C C The routine performs one recursion of the square root covariance C filter algorithm, summarized as follows: C C | 1/2 | | 1/2 | C | R 0 C x S | | (RINOV ) 0 0 | C | i i-1 | | i | C | 1/2 | T = | | C | 0 B x Q A x S | | AK S 0 | C | i i i-1 | | i i | C C (Pre-array) (Post-array) C C where T is unitary and (A,C) is in lower observer Hessenberg form. C C An example of the pre-array is given below (where N = 6, P = 2 C and M = 3): C C |x | | x | C |x x | | x x | C |____|______|____________| C | | x x x| x x x | C | | x x x| x x x x | C | | x x x| x x x x x | C | | x x x| x x x x x x| C | | x x x| x x x x x x| C | | x x x| x x x x x x| C C The corresponding state covariance matrix P is then C i|i-1 C factorized as C C P = S S' C i|i-1 i i C C and one combined time and measurement update for the state X C i|i-1 C is given by C C X = A X + K (Y - C X ) C i+1|i i|i-1 i i i|i-1 C C -1/2 C where K = AK (RINOV ) is the Kalman filter gain matrix and Y C i i i i C is the observed output of the system. C C The triangularization is done entirely via Householder C transformations exploiting the zero pattern of the pre-array. C C REFERENCES C C [1] Anderson, B.D.O. and Moore, J.B. C Optimal Filtering. C Prentice Hall, Englewood Cliffs, New Jersey, 1979. C C [2] Van Dooren, P. and Verhaegen, M.H.G. C Condensed Forms for Efficient Time-Invariant Kalman Filtering. C SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988. C C [3] Verhaegen, M.H.G. and Van Dooren, P. C Numerical Aspects of Different Kalman Filter Implementations. C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. C C [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. C Algorithm 675: FORTRAN Subroutines for Computing the Square C Root Covariance Filter and Square Root Information Filter in C Dense or Hessenberg Forms. C ACM Trans. Math. Software, 15, pp. 243-256, 1989. C C NUMERICAL ASPECTS C C The algorithm requires C C 3 2 2 3 C 1/6 x N + N x (3/2 x P + M) + 2 x N x P + 2/3 x P C C operations and is backward stable (see [3]). C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. C Supersedes Release 2.0 routine FB01FD by M. Vanbegin, C P. Van Dooren, and M.H.G. Verhaegen. C C REVISIONS C C February 20, 1998, November 20, 2003, February 14, 2004. C C KEYWORDS C C Kalman filtering, observer Hessenberg form, optimal filtering, C orthogonal transformation, recursive estimation, square-root C covariance filtering, square-root filtering. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) C .. Scalar Arguments .. CHARACTER JOBK, MULTBQ INTEGER INFO, LDA, LDB, LDC, LDK, LDQ, LDR, LDS, LDWORK, $ M, N, P DOUBLE PRECISION TOL C .. Array Arguments .. INTEGER IWORK(*) DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), $ K(LDK,*), Q(LDQ,*), R(LDR,*), S(LDS,*) C .. Local Scalars .. LOGICAL LJOBK, LMULTB INTEGER I, II, ITAU, JWORK, N1, PL, PN, WRKOPT DOUBLE PRECISION RCOND C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DTRMM, DTRMV, MB02OD, MB04JD, $ MB04LD, XERBLA C .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN C .. Executable Statements .. C PN = P + N N1 = MAX( 1, N ) INFO = 0 LJOBK = LSAME( JOBK, 'K' ) LMULTB = LSAME( MULTBQ, 'P' ) C C Test the input scalar arguments. C IF( .NOT.LJOBK .AND. .NOT.LSAME( JOBK, 'N' ) ) THEN INFO = -1 ELSE IF( .NOT.LMULTB .AND. .NOT.LSAME( MULTBQ, 'N' ) ) 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( LDS.LT.N1 ) THEN INFO = -7 ELSE IF( LDA.LT.N1 ) THEN INFO = -9 ELSE IF( LDB.LT.N1 ) THEN INFO = -11 ELSE IF( LDQ.LT.1 .OR. ( .NOT.LMULTB .AND. LDQ.LT.M ) ) THEN INFO = -13 ELSE IF( LDC.LT.MAX( 1, P ) ) THEN INFO = -15 ELSE IF( LDR.LT.MAX( 1, P ) ) THEN INFO = -17 ELSE IF( LDK.LT.N1 ) THEN INFO = -19 ELSE IF( ( LJOBK .AND. LDWORK.LT.MAX( 2, PN*N + N, PN*N + 2*P, $ N*(N + M + 2), 3*P ) ) .OR. $ ( .NOT.LJOBK .AND. LDWORK.LT.MAX( 1, PN*N + N, PN*N + 2*P, $ N*(N + M + 2) ) ) ) THEN INFO = -23 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'FB01RD', -INFO ) RETURN END IF C C Quick return if possible. C IF ( N.EQ.0 ) THEN IF ( LJOBK ) THEN DWORK(1) = TWO DWORK(2) = ONE ELSE DWORK(1) = ONE END IF RETURN END IF C C Construction of the needed part of the pre-array in DWORK. C To save workspace, only the blocks (1,3), (2,2), and (2,3) will be C constructed as shown below. C C Storing C x S and A x S in the (1,1) and (2,1) blocks of DWORK, C respectively. The lower trapezoidal structure of [ C' A' ]' is C fully exploited. Specifically, if P <= N, the following partition C is used: C C [ C1 0 ] [ S1 0 ] C [ A1 A3 ] [ S2 S3 ], C [ A2 A4 ] C C where C1, S1, and A2 are P-by-P matrices, A1 and S2 are C (N-P)-by-P, A3 and S3 are (N-P)-by-(N-P), A4 is P-by-(N-P), and C C1, S1, A3, and S3 are lower triangular. The left hand side C matrix above is stored in the workspace. If P > N, the partition C is: C C [ C1 ] C [ C2 ] [ S ], C [ A ] C C where C1 and C2 are N-by-N and (P-N)-by-N matrices, respectively, C and C1 and S are lower triangular. C C Workspace: need (P+N)*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, 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 DLACPY( 'Lower', P, MIN( N, P ), C, LDC, DWORK, PN ) CALL DLACPY( 'Full', N, MIN( N, P ), A, LDA, DWORK(P+1), PN ) IF ( N.GT.P ) $ CALL DLACPY( 'Lower', N, N-P, A(1,P+1), LDA, DWORK(P*PN+P+1), $ PN ) C C [ C1 0 ] C Compute [ ] x S or C1 x S as a product of lower triangular C [ A1 A3 ] C matrices. C Workspace: need (P+N+1)*N. C II = 1 PL = N*PN + 1 WRKOPT = PL + N - 1 C DO 10 I = 1, N CALL DCOPY( N-I+1, S(I,I), 1, DWORK(PL), 1 ) CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', N-I+1, $ DWORK(II), PN, DWORK(PL), 1 ) CALL DCOPY( N-I+1, DWORK(PL), 1, DWORK(II), 1 ) II = II + PN + 1 10 CONTINUE C C Compute [ A2 A4 ] x S. C CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', P, N, $ ONE, S, LDS, DWORK(N+1), PN ) C C Triangularization (2 steps). C C Step 1: annihilate the matrix C x S (hence C1 x S1, if P <= N). C Workspace: need (N+P)*N + 2*P. C ITAU = PL JWORK = ITAU + P C CALL MB04LD( 'Lower', P, N, N, R, LDR, DWORK, PN, DWORK(P+1), PN, $ K, LDK, DWORK(ITAU), DWORK(JWORK) ) WRKOPT = MAX( WRKOPT, PN*N + 2*P ) C C Now, the workspace for C x S is no longer needed. C Adjust the leading dimension of DWORK, to save space for the C following computations, and make room for B x Q. C CALL DLACPY( 'Full', N, N, DWORK(P+1), PN, DWORK, N ) C DO 20 I = N*( N - 1 ) + 1, 1, -N CALL DCOPY( N, DWORK(I), 1, DWORK(I+N*M), 1 ) 20 CONTINUE C C Storing B x Q in the (1,1) block of DWORK. C Workspace: need N*(M+N). C CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) IF ( .NOT.LMULTB ) $ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', N, M, $ ONE, Q, LDQ, DWORK, N ) C C Step 2: LQ triangularization of the matrix [ B x Q A x S ], where C A x S was modified at Step 1. C Workspace: need N*(N+M+2); C prefer N*(N+M+1)+(P+1)*NB, where NB is the optimal C block size for DGELQF (called in MB04JD). C ITAU = N*( M + N ) + 1 JWORK = ITAU + N C CALL MB04JD( N, M+N, MAX( N-P-1, 0 ), 0, DWORK, N, DWORK, N, $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, INFO ) WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) C C Output S and K (if needed) and set the optimal workspace C dimension (and the reciprocal of the condition number estimate). C CALL DLACPY( 'Lower', N, N, DWORK, N, S, LDS ) C IF ( LJOBK ) THEN C C Compute K. C Workspace: need 3*P. C CALL MB02OD( 'Right', 'Lower', 'No transpose', 'Non-unit', $ '1-norm', N, P, ONE, R, LDR, K, LDK, RCOND, TOL, $ IWORK, DWORK, INFO ) IF ( INFO.EQ.0 ) THEN WRKOPT = MAX( WRKOPT, 3*P ) DWORK(2) = RCOND END IF END IF C DWORK(1) = WRKOPT C RETURN C *** Last line of FB01RD *** END control-4.1.2/src/slicot/src/PaxHeaders/SB01FY.f0000644000000000000000000000013015012430707016177 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/SB01FY.f0000644000175000017500000002174015012430707017401 0ustar00lilgelilge00000000000000 SUBROUTINE SB01FY( DISCR, N, M, A, LDA, B, LDB, F, LDF, V, LDV, $ INFO ) C C PURPOSE C C To compute the inner denominator of a right-coprime factorization C of a system of order N, where N is either 1 or 2. Specifically, C given the N-by-N unstable system state matrix A and the N-by-M C system input matrix B, an M-by-N state-feedback matrix F and C an M-by-M matrix V are constructed, such that the system C (A + B*F, B*V, F, V) is inner. C C ARGUMENTS C C Mode Parameters C C DISCR LOGICAL C Specifies the type of system as follows: C = .FALSE.: continuous-time system; C = .TRUE. : discrete-time system. 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 or 2. C C M (input) INTEGER C The number of columns of the matrices B and V, and also C the number of rows of the matrix F. M >= 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 whose eigenvalues must have positive C real parts if DISCR = .FALSE. or moduli greater than unity C if DISCR = .TRUE.. C C LDA INTEGER C The leading dimension of array A. LDA >= 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 array B. LDB >= N. 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 matrix F which assigns one eigenvalue (if N = 1) C or two eigenvalues (if N = 2) of the matrix A + B*F in C symmetric positions with respect to the imaginary axis C (if DISCR = .FALSE.) or the unit circle (if C DISCR = .TRUE.). C C LDF INTEGER C The leading dimension of array F. LDF >= MAX(1,M). C C V (output) DOUBLE PRECISION array, dimension (LDV,M) C The leading M-by-M upper triangular part of this array C contains the input/output matrix V of the resulting inner C system in upper triangular form. C If DISCR = .FALSE., the resulting V is an identity matrix. C C LDV INTEGER C The leading dimension of array V. LDF >= MAX(1,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 = 2: if A is stable or at the stability limit; C = 3: if N = 2 and A has a pair of real eigenvalues. C C CONTRIBUTOR C C A. Varga, German Aerospace Center, C DLR Oberpfaffenhofen, July 1998. C Based on the RASP routine RCFID2. C C REVISIONS C C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. C Feb. 1999, A. Varga, DLR Oberpfaffenhofen. C C KEYWORDS C C Coprime factorization, eigenvalue, eigenvalue assignment, C feedback control, pole placement, state-space model. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ONE, TWO, ZERO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) C .. Scalar Arguments .. LOGICAL DISCR INTEGER INFO, LDA, LDB, LDF, LDV, M, N C .. Array Arguments .. DOUBLE PRECISION A(LDA,*), B(LDB,*), F(LDF,*), V(LDV,*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION CS, R11, R12, R22, SCALE, SN, TEMP C .. Local Arrays .. DOUBLE PRECISION AT(2,2), DUMMY(2,2), U(2,2) C .. External Functions .. DOUBLE PRECISION DLAPY2, DLAPY3 EXTERNAL DLAPY2, DLAPY3 C .. External Subroutines .. EXTERNAL DLARFG, DLASET, DLATZM, DROTG, DTRTRI, MA02AD, $ MB04OX, SB03OY C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Executable Statements .. C C For efficiency reasons, the parameters are not checked. C INFO = 0 C C Compute an N-by-N upper triangular R such that R'*R = B*B' and C find an upper triangular matrix U in the equation C C A'*U'*U + U'*U*A = R'*R if DISCR = .FALSE. or C A'*U'*U*A - U'*U = R'*R if DISCR = .TRUE. . C CALL MA02AD( 'Full', N, M, B, LDB, F, LDF ) C IF( N.EQ.1 ) THEN C C The N = 1 case. C IF( M.GT.1 ) $ CALL DLARFG( M, F(1,1), F(2,1), 1, TEMP ) R11 = ABS( F(1,1) ) C C Make sure A is unstable or divergent and find U. C IF( DISCR ) THEN TEMP = ABS( A(1,1) ) IF( TEMP.LE.ONE ) THEN INFO = 2 RETURN ELSE TEMP = R11 / SQRT( ( TEMP - ONE )*( TEMP + ONE ) ) END IF ELSE IF( A(1,1).LE.ZERO ) THEN INFO = 2 RETURN ELSE TEMP = R11 / SQRT( ABS( TWO*A(1,1) ) ) END IF END IF U(1,1) = TEMP SCALE = ONE ELSE C C The N = 2 case. C IF( M.GT.1 ) THEN CALL DLARFG( M, F(1,1), F(2,1), 1, TEMP ) CALL DLATZM( 'Left', M, N-1, F(2,1), 1, TEMP, F(1,2), $ F(2,2), LDF, V ) END IF R11 = F(1,1) R12 = F(1,2) IF( M.GT.2 ) $ CALL DLARFG( M-1, F(2,2), F(3,2), 1, TEMP ) IF( M.EQ.1 ) THEN R22 = ZERO ELSE R22 = F(2,2) END IF AT(1,1) = A(1,1) AT(1,2) = A(2,1) AT(2,1) = A(1,2) AT(2,2) = A(2,2) U(1,1) = R11 U(1,2) = R12 U(2,2) = R22 CALL SB03OY( DISCR, .FALSE., -1, AT, 2, U, 2, DUMMY, 2, $ SCALE, INFO ) IF( INFO.NE.0 ) THEN IF( INFO.NE.4 ) THEN INFO = 2 ELSE INFO = 3 END IF RETURN END IF END IF C C Check the controllability of the pair (A,B). C C Warning. Only an exact controllability check is performed. C If the pair (A,B) is nearly uncontrollable, then C the computed results may be inaccurate. C DO 10 I = 1, N IF( U(I,I).EQ.ZERO ) THEN INFO = 1 RETURN END IF 10 CONTINUE C C Set V = I. C CALL DLASET( 'Upper', M, M, ZERO, ONE, V, LDV ) C IF( DISCR ) THEN C C Compute an upper triangular matrix V such that C -1 C V*V' = (I+B'*inv(U'*U)*B) . C C First compute F = B'*inv(U) and the Cholesky factorization C of I + F*F'. C DO 20 I = 1, M F(I,1) = B(1,I)/U(1,1)*SCALE 20 CONTINUE IF( N.EQ.2 ) THEN DO 30 I = 1, M F(I,2) = ( B(2,I) - F(I,1)*U(1,2) )/U(2,2)*SCALE 30 CONTINUE CALL MB04OX( M, V, LDV, F(1,2), 1 ) END IF CALL MB04OX( M, V, LDV, F(1,1), 1 ) CALL DTRTRI( 'Upper', 'NonUnit', M, V, LDV, INFO ) END IF C C Compute the feedback matrix F as: C C 1) If DISCR = .FALSE. C C F = -B'*inv(U'*U); C C 2) If DISCR = .TRUE. C -1 C F = -B'*(U'*U+B*B') *A. C IF( N.EQ.1 ) THEN IF( DISCR ) THEN TEMP = -A(1,1) R11 = DLAPY2( U(1,1), R11 ) DO 40 I = 1, M F(I,1) = ( ( B(1,I)/R11 )/R11 )*TEMP 40 CONTINUE ELSE R11 = U(1,1) DO 50 I = 1, M F(I,1) = -( ( B(1,I)/R11 )/R11 ) 50 CONTINUE END IF ELSE C C Set R = U if DISCR = .FALSE. or compute the Cholesky C factorization of R'*R = U'*U+B*B' if DISCR = .TRUE.. C IF( DISCR ) THEN TEMP = U(1,1) CALL DROTG( R11, TEMP, CS, SN ) TEMP = -SN*R12 + CS*U(1,2) R12 = CS*R12 + SN*U(1,2) R22 = DLAPY3( R22, TEMP, U(2,2) ) ELSE R11 = U(1,1) R12 = U(1,2) R22 = U(2,2) END IF C C Compute F = -B'*inv(R'*R). C DO 60 I = 1, M F(I,1) = -B(1,I)/R11 F(I,2) = -( B(2,I) + F(I,1)*R12 )/R22 F(I,2) = F(I,2)/R22 F(I,1) = ( F(I,1) - F(I,2)*R12 )/R11 60 CONTINUE IF( DISCR ) THEN C C Compute F <-- F*A. C DO 70 I = 1, M TEMP = F(I,1)*A(1,1) + F(I,2)*A(2,1) F(I,2) = F(I,1)*A(1,2) + F(I,2)*A(2,2) F(I,1) = TEMP 70 CONTINUE END IF END IF C RETURN C *** Last line of SB01FY *** END control-4.1.2/src/slicot/src/PaxHeaders/MB03XZ.f0000644000000000000000000000013215012430707016220 xustar0030 mtime=1747595719.969100241 30 atime=1747595719.969100241 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MB03XZ.f0000644000175000017500000006772115012430707017431 0ustar00lilgelilge00000000000000 SUBROUTINE MB03XZ( BALANC, JOB, JOBU, N, A, LDA, QG, LDQG, U1, $ LDU1, U2, LDU2, WR, WI, ILO, SCALE, DWORK, $ LDWORK, ZWORK, LZWORK, BWORK, INFO ) C C PURPOSE C C To compute the eigenvalues of a Hamiltonian matrix, C C [ A G ] H H C H = [ H ], G = G , Q = Q , (1) C [ Q -A ] C C where A, G and Q are complex n-by-n matrices. C C Due to the structure of H, if lambda is an eigenvalue, then C -conjugate(lambda) is also an eigenvalue. This does not mean that C purely imaginary eigenvalues are necessarily multiple. The routine C computes the eigenvalues of H using an embedding to a real skew- C Hamiltonian matrix He, C C [ Ae Ge ] T T C He = [ T ], Ge = -Ge , Qe = -Qe , (2) C [ Qe Ae ] C C where Ae, Ge, and Qe are real 2*n-by-2*n matrices, defined by C C [ Im(A) Re(A) ] C Ae = [ ], C [ -Re(A) Im(A) ] C C [ triu(Im(G)) Re(G) ] C triu(Ge) = [ ], C [ 0 triu(Im(G)) ] C C [ tril(Im(Q)) 0 ] C tril(Qe) = [ ], C [ -Re(Q) tril(Im(Q)) ] C C and triu and tril denote the upper and lower triangle, C respectively. Then, an orthogonal symplectic matrix Ue is used to C reduce He to the structured real Schur form C C T [ Se De ] T C Ue He Ue = [ T ], De = -De , (3) C [ 0 Se ] C C where Ue is a 4n-by-4n real symplectic matrix, and Se is upper C quasi-triangular (real Schur form). C C Optionally, if JOB = 'S', or JOB = 'G', the matrix i*He is further C transformed to the structured complex Schur form C C H [ Sc Gc ] H C U (i*He) U = [ H ], Gc = Gc , (4) C [ 0 -Sc ] C C where U is a 4n-by-4n unitary symplectic matrix, and Sc is upper C triangular (Schur form). C C The algorithm is backward stable and preserves the spectrum C structure in finite precision arithmetic. C C Optionally, a symplectic balancing transformation to improve the C conditioning of eigenvalues is computed (see the SLICOT Library C routine MB04DZ). In this case, the matrix He in decompositions (3) C and (4) must be replaced by the balanced matrix. C C ARGUMENTS C C Mode Parameters C C BALANC CHARACTER*1 C Indicates how H should be diagonally scaled and/or C permuted to reduce its norm. C = 'N': Do not diagonally scale or permute; C = 'P': Perform symplectic permutations to make the matrix C closer to skew-Hamiltonian Schur form. Do not C diagonally scale; C = 'S': Diagonally scale the matrix, i.e., replace A, G and C Q by D*A*D**(-1), D*G*D and D**(-1)*Q*D**(-1) where C D is a diagonal matrix chosen to make the rows and C columns of H more equal in norm. Do not permute; C = 'B': Both diagonally scale and permute A, G and Q. C Permuting does not change the norm of H, but scaling does. C C JOB CHARACTER*1 C Indicates whether the user wishes to compute the full C decomposition (4) or the eigenvalues only, as follows: C = 'E': compute the eigenvalues only; C = 'S': compute the matrix Sc of (4); C = 'G': compute the matrices Sc and Gc of (4). C C JOBU CHARACTER*1 C Indicates whether or not the user wishes to compute the C symplectic matrix Ue of (3), if JOB = 'E', or U of (4), C if JOB = 'S' or JOB = 'G', as follows: C = 'N': the matrix Ue or U is not computed; C = 'U': the matrix Ue or U is computed. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C A (input/output) COMPLEX*16 array, dimension (LDA,K) C where K = N, if JOB = 'E', and K = 2*N, if JOB <> 'E'. C On entry, the leading N-by-N part of this array must C contain the matrix A. C On exit, if JOB = 'E', the leading N-by-N part of this C array is unchanged, if BALANC = 'N', or it contains the C balanced (permuted and/or scaled) matrix A, if C BALANC <> 'N'. C On exit, if JOB = 'S' or JOB = 'G', the leading 2*N-by-2*N C upper triangular part of this array contains the matrix Sc C (complex Schur form) of decomposition (4). C C LDA INTEGER C The leading dimension of the array A. LDA >= max(1,K). C C QG (input/output) COMPLEX*16 array, dimension C (LDQG,min(K+1,2*N)) C On entry, the leading N-by-N+1 part of this array must C contain in columns 1:N the lower triangular part of the C matrix Q and in columns 2:N+1 the upper triangular part C of the matrix G. C On exit, if JOB <> 'G', the leading N-by-N+1 part of this C array is unchanged, if BALANC = 'N', or it contains the C balanced (permuted and/or scaled) parts of the matrices C Q and G (as above), if BALANC <> 'N'. C On exit, JOB = 'G', the leading 2*N-by-2*N upper C triangular part of this array contains the upper C triangular part of the matrix Gc in the decomposition (4). C C LDQG INTEGER C The leading dimension of the array QG. LDQG >= max(1,K). C C U1 (output) COMPLEX*16 array, dimension (LDU1,2*N) C On exit, if JOB = 'S' or JOB = 'G', and JOBU = 'U', the C leading 2*N-by-2*N part of this array contains the (1,1) C block of the unitary symplectic matrix U of the C decomposition (4). C If JOB = 'E' or JOBU = 'N', this array is not referenced. C C LDU1 INTEGER C The leading dimension of the array U1. LDU1 >= 1. C LDU1 >= 2*N, if JOBU = 'U'. C C U2 (output) COMPLEX*16 array, dimension (LDU2,2*N) C On exit, if JOB = 'S' or JOB = 'G', and JOBU = 'U', the C leading 2*N-by-2*N part of this array contains the (1,2) C block of the unitary symplectic matrix U of the C decomposition (4). C If JOB = 'E' or JOBU = 'N', this array is not referenced. C C LDU2 INTEGER C The leading dimension of the array U2. LDU2 >= 1. C LDU2 >= 2*N, if JOBU = 'U'. C C WR (output) DOUBLE PRECISION array, dimension (2*N) C WI (output) DOUBLE PRECISION array, dimension (2*N) C On exit, the leading 2*N elements of WR and WI contain the C real and imaginary parts, respectively, of the eigenvalues C of the Hamiltonian matrix H. C C ILO (output) INTEGER C ILO is an integer value determined when H was balanced. C The balanced A(I,J) = 0 if I > J and J = 1,...,ILO-1. C The balanced Q(I,J) = 0 if J = 1,...,ILO-1 or C I = 1,...,ILO-1. C C SCALE (output) DOUBLE PRECISION array, dimension (N) C On exit, if BALANC <> 'N', the leading N elements of this C array contain details of the permutation and/or scaling C factors applied when balancing H, see MB04DZ. C This array is not referenced if BALANC = 'N'. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK, and DWORK(2) returns the 1-norm of the C (scaled, if BALANC = 'S' or 'B') Hamiltonian matrix. C Moreover, the next locations of this array have the C following content: C - The leading 2*N-by-2*N upper Hessenberg part in the C locations 3:2+4*N*N contains the upper Hessenberg part of C the real Schur matrix Se in the decomposition (3); C - the leading 2*N-by-2*N upper triangular part in the C locations 3+4*N*N+2*N:2+8*N*N+2*N contains the upper C triangular part of the skew-symmetric matrix De in the C decomposition (3). C - If JOBU = 'U', the leading 2*N-by-2*N part in the C locations 3+8*N*N+2*N:2+12*N*N+2*N contains the (1,1) C block of the orthogonal symplectic matrix Ue of C decomposition (3). C - the leading 2*N-by-2*N part in the locations C 3+12*N*N+2*N:2+16*N*N+2*N contains the (2,1) block of the C orthogonal symplectic matrix Ue. C On exit, if INFO = -18, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The dimension of the array DWORK. C LDWORK >= MAX( 12*N**2 + 4*N, 8*N**2 + 12*N ) + 2, C if JOB = 'E' and JOBU = 'N'; C LDWORK >= MAX( 2, 12*N**2 + 4*N, 8*N**2 + 12*N ), C if JOB = 'S' or 'G' and JOBU = 'N'; C LDWORK >= 20*N**2 + 12*N + 2, C if JOB = 'E' and JOBU = 'U'; C LDWORK >= MAX( 2, 20*N**2 + 12*N ), C if JOB = 'S' or 'G' and JOBU = 'U'. C For good performance, LDWORK must generally 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 ZWORK COMPLEX*16 array, dimension (LZWORK) C On exit, if INFO = 0, ZWORK(1) returns the optimal C value of LZWORK. C On exit, if INFO = -20, ZWORK(1) returns the minimum C value of LZWORK. C C LZWORK INTEGER C The dimension of the array ZWORK. C LZWORK >= 1, if JOB = 'E'; C LZWORK >= MAX( 1, 12*N - 6 ), if JOB = 'S' and JOBU = 'N'; C LZWORK >= MAX( 1, 12*N - 2 ), if JOB = 'G' or JOBU = 'U'. C C If LZWORK = -1, then a workspace query is assumed; C the routine only calculates the optimal size of the C ZWORK array, returns this value as the first entry of C the ZWORK array, and no error message related to LZWORK C is issued by XERBLA. C C BWORK LOGICAL array, dimension (LBWORK) C LBWORK >= 0, if JOB = 'E'; C LBWORK >= 2*N-1, if JOB = 'S' or JOB = 'G'. 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 C all the eigenvalues; elements i+1:2*N of WR and C WI contain eigenvalues which have converged; C = 2*N+1: the QR algorithm failed to compute the C eigenvalues of a 2-by-2 real block. C C METHOD C C First, the extended matrix He in (2) is built. Then, the C structured real Schur form in (3) is computed, using the SLICOT C Library routine MB03XS. The eigenvalues of Se immediately give C the eigenvalues of H. Finally, if required, Se is further C transformed by using the complex QR algorithm to triangularize C its 2-by-2 blocks, and Ge and U are updated, to obtain (4). C C REFERENCES C C [1] Benner, P., Mehrmann, V. and Xu, H. C A note on the numerical solution of complex Hamiltonian and C skew-Hamiltonian eigenvalue problems. C Electr. Trans. Num. Anal., 8, pp. 115-126, 1999. C C [2] Van Loan, C.F. C A symplectic method for approximating all the eigenvalues of C a Hamiltonian matrix. C Linear Algebra and its Applications, 61, pp. 233-251, 1984. C C CONTRIBUTORS C C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2011. C C REVISIONS C C V. Sima, Dec. 2011, Sep. 2012, Oct. 2012. C C KEYWORDS C C Schur form, eigenvalues, skew-Hamiltonian matrix. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) C .. Scalar Arguments .. CHARACTER BALANC, JOB, JOBU INTEGER ILO, INFO, LDA, LDQG, LDU1, LDU2, LDWORK, $ LZWORK, N C .. Array Arguments .. LOGICAL BWORK( * ) DOUBLE PRECISION DWORK( * ), SCALE( * ), WI( * ), WR( * ) COMPLEX*16 A( LDA, * ), QG( LDQG, * ), U1( LDU1, * ), $ U2( LDU2, * ), ZWORK( * ) C .. Local Scalars .. LOGICAL LQUERY, LSCAL, SCALEH, WANTG, WANTS, WANTU, $ WANTUS INTEGER I, I1, IA, IERR, IEV, IQG, IS, IU, IU1, IU2, $ IUB, IW, IW1, IWRK, J, J1, J2, JM1, JP2, K, $ MINDB, MINDW, MINZW, N2, NB, NC, NC1, NN, NN2, $ OPTDW, OPTZW DOUBLE PRECISION BIGNUM, CSCALE, EPS, HNR1, HNRM, NRMB, SMLNUM COMPLEX*16 TMP C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, MA02IZ EXTERNAL DLAMCH, LSAME, MA02IZ C .. External Subroutines .. EXTERNAL DCOPY, DLABAD, DLACPY, DLASCL, MB03XS, MB04DZ, $ XERBLA, ZGEMM, ZGEQRF, ZLACPY, ZLAHQR, ZLASCL, $ ZLASET C .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, SQRT C C .. Executable Statements .. C C Decode the scalar input parameters. C NN = N*N N2 = 2*N NN2 = N2*N2 INFO = 0 LSCAL = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'S' ) .OR. $ LSAME( BALANC, 'B' ) WANTG = LSAME( JOB, 'G' ) WANTS = LSAME( JOB, 'S' ) .OR. WANTG WANTU = LSAME( JOBU, 'U' ) C WANTUS = WANTS .AND. WANTU C IF ( WANTS ) THEN K = N2 ELSE K = N END IF C IF ( N.EQ.0 ) THEN MINDW = 2 ELSE IF ( WANTU ) THEN MINDB = 4*NN2 + N2 IF ( WANTS ) THEN MINDW = MAX( 2, 20*NN + 12*N ) ELSE MINDW = 20*NN + 12*N + 2 END IF ELSE MINDB = 2*NN2 + N2 IF ( WANTS ) THEN MINDW = MAX( 2, 12*NN + 4*N, 8*NN + 12*N ) ELSE MINDW = MAX( 12*NN + 4*N, 8*NN + 12*N ) + 2 END IF END IF IF ( WANTG .OR. WANTU ) THEN MINZW = MAX( 1, 12*N - 2 ) ELSE IF ( WANTS ) THEN MINZW = MAX( 1, 12*N - 6 ) ELSE MINZW = 1 END IF LQUERY = LDWORK.EQ.-1 .OR. LZWORK.EQ.-1 C C Test the scalar input parameters. C IF ( .NOT.LSCAL .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN INFO = -1 ELSE IF ( .NOT.WANTS .AND. .NOT.LSAME( JOB, 'E' ) ) THEN INFO = -2 ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN INFO = -3 ELSE IF ( N.LT.0 ) THEN INFO = -4 ELSE IF ( LDA.LT.MAX( 1, K ) ) THEN INFO = -6 ELSE IF ( LDQG.LT.MAX( 1, K ) ) THEN INFO = -8 ELSE IF ( LDU1.LT.1 .OR. ( WANTUS .AND. LDU1.LT.N2 ) ) THEN INFO = -10 ELSE IF ( LDU2.LT.1 .OR. ( WANTUS .AND. LDU2.LT.N2 ) ) THEN INFO = -12 ELSE IF ( .NOT. LQUERY ) THEN IF ( LDWORK.LT.MINDW ) THEN DWORK( 1 ) = MINDW INFO = -18 ELSE IF ( LZWORK.LT.MINZW ) THEN ZWORK( 1 ) = MINZW INFO = -20 END IF END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03XZ', -INFO ) RETURN ELSE IF ( N.GT.0 ) THEN C C Set the pointers for the inputs and outputs of MB03XS. C IF ( WANTS ) THEN IA = 1 ELSE IA = 3 END IF IQG = IA + NN2 IF ( WANTU ) THEN IU1 = IQG + NN2 + N2 IU2 = IU1 + NN2 IWRK = IU2 + NN2 ELSE IU1 = IQG IU2 = IQG IWRK = IQG + NN2 + N2 END IF C C Compute optimal workspace. C OPTZW = MINZW IF ( WANTS ) THEN CALL ZGEQRF( N2, N2, ZWORK, N2, ZWORK, ZWORK, -1, INFO ) I = INT( ZWORK( 1 ) ) NB = MAX( I/N2, 2 ) END IF C IF ( LQUERY ) THEN CALL MB03XS( JOBU, N2, DWORK, N2, DWORK, N2, DWORK, N2, $ DWORK, N2, WI, WR, DWORK, -1, INFO ) OPTDW = MAX( MINDW, MINDB + INT( DWORK( 1 ) ) ) DWORK( 1 ) = OPTDW ZWORK( 1 ) = OPTZW RETURN END IF END IF C C Quick return if possible. C ILO = 1 IF ( N.EQ.0 ) THEN DWORK( 1 ) = TWO DWORK( 2 ) = ZERO ZWORK( 1 ) = CONE RETURN END IF C EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SQRT( SMLNUM ) / EPS BIGNUM = ONE / SMLNUM C C Scale H if maximal element is outside range [SMLNUM,BIGNUM]. C HNRM = MA02IZ( 'Hamiltonian', 'MaxElement', N, A, LDA, QG, LDQG, $ DWORK ) SCALEH = .FALSE. IF ( HNRM.GT.ZERO .AND. HNRM.LT.SMLNUM ) THEN SCALEH = .TRUE. CSCALE = SMLNUM ELSE IF ( HNRM.GT.BIGNUM ) THEN SCALEH = .TRUE. CSCALE = BIGNUM END IF IF ( SCALEH ) THEN CALL ZLASCL( 'General', 0, 0, HNRM, CSCALE, N, N, A, LDA, IERR ) CALL ZLASCL( 'General', 0, 0, HNRM, CSCALE, N, N+1, QG, LDQG, $ IERR ) END IF C C Balance the matrix and compute the 1-norm. C IF ( LSCAL ) THEN CALL MB04DZ( BALANC, N, A, LDA, QG, LDQG, ILO, SCALE, IERR ) ELSE ILO = 1 END IF C C Real workspace: need 2*N. C HNR1 = MA02IZ( 'Hamiltonian', '1-norm', N, A, LDA, QG, LDQG, $ DWORK ) C C Set up the embeddings of the matrix H. C C Real workspace: need w1 = 8*N**2 + 2*N, if JOBU = 'N'; C w1 = 16*N**2 + 2*N, if JOBU = 'U'. C C Build the embedding of A. C IW = IA IS = IW + N2*N DO 30 J = 1, N IW1 = IW DO 10 I = 1, N DWORK( IW ) = DIMAG( A( I, J ) ) IW = IW + 1 10 CONTINUE C DO 20 I = 1, N DWORK( IW ) = -DBLE( A( I, J ) ) DWORK( IS ) = -DWORK( IW ) IW = IW + 1 IS = IS + 1 20 CONTINUE CALL DCOPY( N, DWORK( IW1 ), 1, DWORK( IS ), 1 ) IS = IS + N 30 CONTINUE C C Build the embedding of G and Q. C IW = IQG DO 60 J = 1, N + 1 DO 40 I = 1, N DWORK( IW ) = DIMAG( QG( I, J ) ) IW = IW + 1 40 CONTINUE C IW = IW + J - 1 IS = IW DO 50 I = J, N DWORK( IW ) = -DBLE( QG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N2 50 CONTINUE 60 CONTINUE C IW1 = IW I1 = IW DO 80 J = 2, N + 1 IS = I1 I1 = I1 + 1 DO 70 I = 1, J - 1 DWORK( IW ) = DBLE( QG( I, J ) ) DWORK( IS ) = DWORK( IW ) IW = IW + 1 IS = IS + N2 70 CONTINUE IW = IW + N2 - J + 1 80 CONTINUE CALL DLACPY( 'Full', N, N+1, DWORK( IQG ), N2, DWORK( IW1-N ), $ N2 ) C C Compute the eigenvalues and real skew-Hamiltonian Schur form of C the embedded skew-Hamiltonian matrix. C C Real workspace: need w1 + w2, where C w2 = max( 4*N**2 + 2*N, C 10*N ), if JOBU = 'N'; C w2 = 4*N**2 + 10*N, if JOBU = 'U'. C prefer larger. C CALL MB03XS( JOBU, N2, DWORK( IA ), N2, DWORK( IQG ), N2, $ DWORK( IU1 ), N2, DWORK( IU2 ), N2, WI, WR, $ DWORK( IWRK ), LDWORK-IWRK+1, INFO ) IF ( INFO.NE.0 ) $ RETURN C OPTDW = MAX( MINDW, INT( DWORK(IWRK) ) + IWRK - 1 ) C C Return if further reduction is not required. C IF ( .NOT.WANTS ) THEN IF ( SCALEH ) THEN C C Undo scaling. C CALL DLASCL( 'Hessenberg', 0, 0, CSCALE, HNRM, N2, N2, $ DWORK( IA ), N2, IERR ) IF ( WANTG ) $ CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N2, N2, $ DWORK( IQG+N2 ), N2, IERR ) CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N2, 1, WR, N2, $ IERR ) CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N2, 1, WI, N2, $ IERR ) HNR1 = HNR1 * HNRM / CSCALE END IF GO TO 190 END IF C C Convert the results to complex datatype. G starts now in the C first column of QG. C Only the upper triangular part of G is used below. C IW = IA DO 100 J = 1, N2 DO 90 I = 1, MIN( J+1, N2 ) A( I, J ) = DCMPLX( ZERO, DWORK( IW ) ) IW = IW + 1 90 CONTINUE IW = IW + N2 - MIN( J+1, N2 ) 100 CONTINUE C IF ( WANTG ) THEN IW = IQG + N2 DO 120 J = 1, N2 DO 110 I = 1, J - 1 QG( I, J ) = DCMPLX( ZERO, DWORK( IW ) ) IW = IW + 1 110 CONTINUE QG( J, J ) = CZERO IW = IW + N2 - J + 1 120 CONTINUE END IF C IF ( WANTU ) THEN C C Set the transformation matrix. C IW = IU1 DO 140 J = 1, N2 DO 130 I = 1, N2 U1( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 130 CONTINUE 140 CONTINUE C DO 160 J = 1, N2 DO 150 I = 1, N2 U2( I, J ) = DCMPLX( DWORK( IW ) ) IW = IW + 1 150 CONTINUE 160 CONTINUE END IF C C Triangularize the 2-by-2 diagonal blocks in Se using the complex C version of the QR algorithm. C C Set up pointers on the outputs of ZLAHQR. C A block algorithm is used for large N2. C IEV = 1 IU = 3 IWRK = IU + 4*( N2 - 1 ) C J = 1 J2 = MIN( N2, NB ) C WHILE( J.LT.N2 ) DO 170 CONTINUE IF ( J.LT.N2 ) THEN NRMB = ABS( A( J, J ) ) + ABS( A( J+1, J+1 ) ) IF ( ABS( A( J+1, J ) ).GT.NRMB*EPS ) THEN C C Triangularization step. C Workspace: need 8*N - 2 (complex). C NC = MAX( J2-J-1, 0 ) NC1 = MAX( J2-J+1, 0 ) JM1 = MAX( J-1, 1 ) JP2 = MIN( J+2, N2 ) CALL ZLASET( 'Full', 2, 2, CZERO, CONE, ZWORK( IU ), 2 ) CALL ZLAHQR( .TRUE., .TRUE., 2, 1, 2, A( J, J ), LDA, $ ZWORK( IEV ), 1, 2, ZWORK( IU ), 2, INFO ) IF ( INFO.GT.0 ) THEN INFO = N2 + 1 RETURN END IF C C Update A. C Workspace: need 12*N - 6. C CALL ZGEMM( 'No Transpose', 'No Transpose', J-1, 2, 2, $ CONE, A( 1, J ), LDA, ZWORK( IU ), 2, CZERO, $ ZWORK( IWRK ), JM1 ) CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, A( 1, J ), $ LDA ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, NC, $ 2, CONE, ZWORK( IU ), 2, A( J, JP2 ), LDA, $ CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, A( J, JP2 ), $ LDA ) C IF ( WANTG ) THEN C C Update G. C Workspace: need 12*N - 2. C TMP = QG( J+1, J ) QG( J+1, J ) = -QG( J, J+1 ) CALL ZGEMM( 'No Transpose', 'No Transpose', J+1, 2, 2, $ CONE, QG( 1, J ), LDQG, ZWORK( IU ), 2, $ CZERO, ZWORK( IWRK ), J+1 ) CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, $ QG( 1, J ), LDQG ) CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC1, 2, CONE, ZWORK( IU ), 2, QG( J, J ), $ LDQG, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC1, ZWORK( IWRK ), 2, $ QG( J, J ), LDQG ) QG( J+1, J ) = TMP END IF C IF ( WANTU ) THEN C C Update U. C Workspace: need 12*N - 2. C CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, $ CONE, U1( 1, J ), LDU1, ZWORK( IU ), 2, $ CZERO, ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, $ U1( 1, J ), LDU1 ) CALL ZGEMM( 'No Transpose', 'No Transpose', N2, 2, 2, $ CONE, U2( 1, J ), LDU2, ZWORK( IU ), 2, $ CZERO, ZWORK( IWRK ), N2 ) CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, $ U2( 1, J ), LDU2 ) END IF C BWORK( J ) = .TRUE. J = J + 2 IU = IU + 4 ELSE BWORK( J ) = .FALSE. A( J+1, J ) = CZERO J = J + 1 END IF C IF ( J.GE.J2 .AND. J.LT.N2 ) THEN J1 = J2 + 1 J2 = MIN( N2, J1 + NB - 1 ) NC = J2 - J1 + 1 C C Update the columns J1 to J2 of A and QG for previous C transformations. C I = 1 IUB = 3 C WHILE( I.LT.J ) DO 180 CONTINUE IF ( I.LT.J ) THEN IF ( BWORK( I ) ) THEN CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', 2, $ NC, 2, CONE, ZWORK( IUB ), 2, A( I, J1 ), $ LDA, CZERO, ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ A( I, J1 ), LDA ) C IF ( WANTG ) THEN CALL ZGEMM( 'Conjugate Transpose', 'No Transpose', $ 2, NC, 2, CONE, ZWORK( IUB ), 2, $ QG( I, J1 ), LDQG, CZERO, $ ZWORK( IWRK ), 2 ) CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, $ QG( I, J1 ), LDQG ) END IF C IUB = IUB + 4 C I = I + 2 ELSE I = I + 1 END IF GO TO 180 END IF C END WHILE 180 END IF GO TO 170 END IF C END WHILE 170 C IF ( SCALEH ) THEN C C Undo scaling. C CALL ZLASCL( 'Hessenberg', 0, 0, CSCALE, HNRM, N2, N2, A, LDA, $ IERR ) If ( WANTG ) $ CALL ZLASCL( 'General', 0, 0, CSCALE, HNRM, N2, N2, QG(1,2), $ LDQG, IERR ) CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N2, 1, WR, N2, $ IERR ) CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N2, 1, WI, N2, $ IERR ) HNR1 = HNR1 * HNRM / CSCALE END IF C 190 CONTINUE DWORK( 1 ) = DBLE( OPTDW ) DWORK( 2 ) = HNR1 ZWORK( 1 ) = OPTZW RETURN C *** Last line of MB03XZ *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01RD.f0000644000000000000000000000013015012430707016161 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MC01RD.f0000644000175000017500000001732215012430707017364 0ustar00lilgelilge00000000000000 SUBROUTINE MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO ) C C PURPOSE C C To compute the coefficients of the polynomial C C P(x) = P1(x) * P2(x) + alpha * P3(x), C C where P1(x), P2(x) and P3(x) are given real polynomials and alpha C is a real scalar. C C Each of the polynomials P1(x), P2(x) and P3(x) may be the zero C polynomial. C C ARGUMENTS C C Input/Output Parameters C C DP1 (input) INTEGER C The degree of the polynomial P1(x). DP1 >= -1. C C DP2 (input) INTEGER C The degree of the polynomial P2(x). DP2 >= -1. C C DP3 (input/output) INTEGER C On entry, the degree of the polynomial P3(x). DP3 >= -1. C On exit, the degree of the polynomial P(x). C C ALPHA (input) DOUBLE PRECISION C The scalar value alpha of the problem. C C P1 (input) DOUBLE PRECISION array, dimension (lenp1) C where lenp1 = DP1 + 1 if DP1 >= 0 and 1 otherwise. C If DP1 >= 0, then this array must contain the C coefficients of P1(x) in increasing powers of x. C If DP1 = -1, then P1(x) is taken to be the zero C polynomial, P1 is not referenced and can be supplied C as a dummy array. C C P2 (input) DOUBLE PRECISION array, dimension (lenp2) C where lenp2 = DP2 + 1 if DP2 >= 0 and 1 otherwise. C If DP2 >= 0, then this array must contain the C coefficients of P2(x) in increasing powers of x. C If DP2 = -1, then P2(x) is taken to be the zero C polynomial, P2 is not referenced and can be supplied C as a dummy array. C C P3 (input/output) DOUBLE PRECISION array, dimension (lenp3) C where lenp3 = MAX(DP1+DP2,DP3,0) + 1. C On entry, if DP3 >= 0, then this array must contain the C coefficients of P3(x) in increasing powers of x. C On entry, if DP3 = -1, then P3(x) is taken to be the zero C polynomial. C On exit, the leading (DP3+1) elements of this array C contain the coefficients of P(x) in increasing powers of x C unless DP3 = -1 on exit, in which case the coefficients of C P(x) (the zero polynomial) are not stored in the array. C This is the case, for instance, when ALPHA = 0.0 and C P1(x) or P2(x) is the zero polynomial. 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 Given real polynomials C C DP1 i DP2 i C P1(x) = SUM a(i+1) * x , P2(x) = SUM b(i+1) * x and C i=0 i=0 C C DP3 i C P3(x) = SUM c(i+1) * x , C i=0 C C the routine computes the coefficents of P(x) = P1(x) * P2(x) + C DP3 i C alpha * P3(x) = SUM d(i+1) * x as follows. C i=0 C C Let e(i) = c(i) for 1 <= i <= DP3+1 and e(i) = 0 for i > DP3+1. C Then if DP1 >= DP2, C C i C d(i) = SUM a(k) * b(i-k+1) + f(i), for i = 1, ..., DP2+1, C k=1 C C i C d(i) = SUM a(k) * b(i-k+1) + f(i), for i = DP2+2, ..., DP1+1 C k=i-DP2 C C and C DP1+1 C d(i) = SUM a(k) * b(i-k+1) + f(i) for i = DP1+2,...,DP1+DP2+1, C k=i-DP2 C C where f(i) = alpha * e(i). C C Similar formulas hold for the case DP1 < DP2. C C NUMERICAL ASPECTS C C None. C C CONTRIBUTORS C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01FD by C. Klimann and C A.J. Geurts. C C REVISIONS C C - C C KEYWORDS C C Elementary polynomial operations, polynomial operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER DP1, DP2, DP3, INFO DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION P1(*), P2(*), P3(*) C .. Local Scalars .. INTEGER D1, D2, D3, DMAX, DMIN, DSUM, E3, I, J, K, L C .. External Functions .. DOUBLE PRECISION DDOT EXTERNAL DDOT C .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Executable Statements .. C C Test the input scalar arguments. C INFO = 0 IF( DP1.LT.-1 ) THEN INFO = -1 ELSE IF( DP2.LT.-1 ) THEN INFO = -2 ELSE IF( DP3.LT.-1 ) THEN INFO = -3 END IF C IF ( INFO.NE.0 ) THEN C C Error return. C CALL XERBLA( 'MC01RD', -INFO ) RETURN END IF C C Computation of the exact degree of the polynomials, i.e., Di such C that either Di = -1 or Pi(Di+1) is non-zero. C D1 = DP1 C WHILE ( D1 >= 0 and P1(D1+1) = 0 ) DO 20 IF ( D1.GE.0 ) THEN IF ( P1(D1+1).EQ.ZERO ) THEN D1 = D1 - 1 GO TO 20 END IF END IF C END WHILE 20 D2 = DP2 C WHILE ( D2 >= 0 and P2(D2+1) = 0 ) DO 40 IF ( D2.GE.0 ) THEN IF ( P2(D2+1).EQ.ZERO ) THEN D2 = D2 - 1 GO TO 40 END IF END IF C END WHILE 40 IF ( ALPHA.EQ.ZERO ) THEN D3 = -1 ELSE D3 = DP3 END IF C WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO 60 IF ( D3.GE.0 ) THEN IF ( P3(D3+1).EQ.ZERO ) THEN D3 = D3 - 1 GO TO 60 END IF END IF C END WHILE 60 C C Computation of P3(x) := ALPHA * P3(x). C CALL DSCAL( D3+1, ALPHA, P3, 1 ) C IF ( ( D1.EQ.-1 ) .OR. ( D2.EQ.-1 ) ) THEN DP3 = D3 RETURN END IF C C P1(x) and P2(x) are non-zero polynomials. C DSUM = D1 + D2 DMAX = MAX( D1, D2 ) DMIN = DSUM - DMAX C IF ( D3.LT.DSUM ) THEN P3(D3+2) = ZERO CALL DCOPY( DSUM-D3-1, P3(D3+2), 0, P3(D3+3), 1 ) D3 = DSUM END IF C IF ( ( D1.EQ.0 ) .OR. ( D2.EQ.0 ) ) THEN C C D1 or D2 is zero. C IF ( D1.NE.0 ) THEN CALL DAXPY( D1+1, P2(1), P1, 1, P3, 1 ) ELSE CALL DAXPY( D2+1, P1(1), P2, 1, P3, 1 ) END IF ELSE C C D1 and D2 are both nonzero. C C First part of the computation. C DO 80 I = 1, DMIN + 1 P3(I) = P3(I) + DDOT( I, P1, 1, P2, -1 ) 80 CONTINUE C C Second part of the computation. C DO 100 I = DMIN + 2, DMAX + 1 IF ( D1.GT.D2 ) THEN K = I - D2 P3(I) = P3(I) + DDOT( DMIN+1, P1(K), 1, P2, -1 ) ELSE K = I - D1 P3(I) = P3(I) + DDOT( DMIN+1, P2(K), -1, P1, 1 ) END IF 100 CONTINUE C C Third part of the computation. C E3 = DSUM + 2 C DO 120 I = DMAX + 2, DSUM + 1 J = E3 - I K = I - DMIN L = I - DMAX IF ( D1.GT.D2 ) THEN P3(I) = P3(I) + DDOT( J, P1(K), 1, P2(L), -1 ) ELSE P3(I) = P3(I) + DDOT( J, P1(L), -1, P2(K), 1 ) END IF 120 CONTINUE C END IF C C Computation of the exact degree of P3(x). C C WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO 140 IF ( D3.GE.0 ) THEN IF ( P3(D3+1).EQ.ZERO ) THEN D3 = D3 - 1 GO TO 140 END IF END IF C END WHILE 140 DP3 = D3 C RETURN C *** Last line of MC01RD *** END control-4.1.2/src/slicot/src/PaxHeaders/MC01ND.f0000644000000000000000000000013015012430707016155 xustar0029 mtime=1747595719.97710053 29 atime=1747595719.97710053 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/src/MC01ND.f0000644000175000017500000000601115012430707017351 0ustar00lilgelilge00000000000000 SUBROUTINE MC01ND( DP, XR, XI, P, VR, VI, INFO ) C C PURPOSE C C To compute the value of the real polynomial P(x) at a given C complex point x = x0 using Horner's algorithm. C C ARGUMENTS C C Input/Output Parameters C C DP (input) INTEGER C The degree of the polynomial P(x). DP >= 0. C C XR (input) DOUBLE PRECISION C XI (input) DOUBLE PRECISION C The real and imaginary parts, respectively, of x0. C C P (input) DOUBLE PRECISION array, dimension (DP+1) C This array must contain the coefficients of the polynomial C P(x) in increasing powers of x. C C VR (output) DOUBLE PRECISION C VI (output) DOUBLE PRECISION C The real and imaginary parts, respectively, of P(x0). 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 Given the real polynomial C 2 DP C P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x , C C the routine computes the value of P(x0) using the recursion C C q(DP+1) = p(DP+1), C q(i) = x0*q(i+1) + p(i) for i = DP, DP-1, ..., 1, C C which is known as Horner's algorithm (see [1]). Then q(1) = P(x0). C C REFERENCES C C [1] STOER, J and BULIRSCH, R. C Introduction to Numerical Analysis. C Springer-Verlag. 1980. C C NUMERICAL ASPECTS C C The algorithm requires DP operations for real arguments and 4*DP C for complex arguments. C C CONTRIBUTOR C C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. C Supersedes Release 2.0 routine MC01BD by Serge Steer. C C REVISIONS C C - C C KEYWORDS C C Elementary polynomial operations, polynomial operations. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) C .. Scalar Arguments .. INTEGER DP, INFO DOUBLE PRECISION VI, VR, XI, XR C .. Array Arguments .. DOUBLE PRECISION P(*) C .. Local Scalars .. INTEGER I DOUBLE PRECISION T C .. External Subroutines .. EXTERNAL XERBLA C .. Executable Statements .. C C Test the input scalar arguments. C IF( DP.LT.0 ) THEN INFO = -1 C C Error return. C CALL XERBLA( 'MC01ND', -INFO ) RETURN END IF C INFO = 0 VR = P(DP+1) VI = ZERO C IF ( DP.EQ.0 ) $ RETURN C IF ( XI.EQ.ZERO ) THEN C C X real. C DO 20 I = DP, 1, -1 VR = VR*XR + P(I) 20 CONTINUE C ELSE C C X complex. C DO 40 I = DP, 1, -1 T = VR*XR - VI*XI + P(I) VI = VI*XR + VR*XI VR = T 40 CONTINUE C END IF C RETURN C *** Last line of MC01ND *** END control-4.1.2/src/slicot/PaxHeaders/LICENSE0000644000000000000000000000013215012430707015344 xustar0030 mtime=1747595719.993101108 30 atime=1747595719.993101108 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/LICENSE0000644000175000017500000000275215012430707016546 0ustar00lilgelilge00000000000000BSD 3-Clause License Copyright (c) 2020, SLICOT All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. control-4.1.2/src/slicot/PaxHeaders/README.md0000644000000000000000000000007315012430645015623 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/README.md0000644000175000017500000000133015012430645017010 0ustar00lilgelilge00000000000000In the distributed control package archive `control-x.y.z.tar.gz`, this directory contains some source files of the [SLICOT-Reference library](https://github.com/SLICOT/SLICOT-Reference), which are compiled for the target system while installing the control package for Octave. The SLICOT files are available under the *BSD 3-Clause License* which can be found in the file `LICENSE` in the distributed version of this directory or [in the SLICOT repository](https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE). The original `README.md` is available as `README-SLICOT.md` in the distributed version of the directory or also [in the SLICOT repository](https://github.com/SLICOT/SLICOT-Reference/blob/main/README.md). control-4.1.2/src/slicot/PaxHeaders/README-SLICOT.md0000644000000000000000000000013215012430707016611 xustar0030 mtime=1747595719.993101108 30 atime=1747595719.993101108 30 ctime=1747595720.873132883 control-4.1.2/src/slicot/README-SLICOT.md0000644000175000017500000000613415012430707020011 0ustar00lilgelilge00000000000000# SLICOT Library [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.6463090.svg)](https://doi.org/10.5281/zenodo.6463090) [![License](https://img.shields.io/badge/License-BSD_3--Clause-blue.svg)](https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE) **SLICOT** - _Subroutine Library In COntrol Theory_ - is a general purpose basic mathematical library for control theoretical computations. The library provides tools to perform essential system analysis and synthesis tasks. The main emphasis in SLICOT is on numerical reliability of implemented algorithms and the numerical robustness and efficiency of routines. Providing algorithmic flexibility and the use of rigorous implementation and documentation standards are other SLICOT features. The SLICOT Library is available as standard Fortran 77 code in double precision. Each user-callable subroutine for control computations is accompanied by an example program which illustrates the use of the subroutine and can act as a template for the user's own routines. The SLICOT Library is organized by chapters, sections and subsections. The following chapters are currently included: A : Analysis Routines B : Benchmark and Test Problems D : Data Analysis F : Filtering I : Identification M : Mathematical Routines N : Nonlinear Systems (not yet available, except for some auxiliary routines for Wiener systems) S : Synthesis Routines T : Transformation Routines U : Utility Routines SLICOT Library Root Directory contains few, basic files for the SLICOT Library distribution and generation. When distributed, SLICOT software comes with several filled-in subdirectories (benchmark_data, doc, examples, src, and src_aux), and the following files in this root directory: - this file, README.md, - the contributors to the library and financial support, Contributors.md, - the license file, LICENSE, and - the main SLICOT Library documentation index, libindex.html. After software installation, this directory will also contain the library files slicot.a and lpkaux.a, or slicot.lib and lpkaux.lib, for Unix or Windows platforms, respectively. The library files could then be linked in applications programs, as usual. Specific examples are contained in the directory examples. The on-line documentation of the SLICOT user's callable routines is accessible via the main SLICOT Library documentation index, libindex.html. This file also contains a link to the documentation of the lower-level, support routines. The SLICOT Library is built on LAPACK (Linear Algebra PACKage) and BLAS (Basic Linear Algebra Subprograms) collections. Therefore, these packages should be available on the platform used. Basic References: 1. P. Benner, V. Mehrmann, V. Sima, S. Van Huffel, and A. Varga, "SLICOT - A Subroutine Library in Systems and Control Theory", Applied and Computational Control, Signals, and Circuits (Birkhauser), Vol. 1, Ch. 10, pp. 505-546, 1999. 2. S. Van Huffel, V. Sima, A. Varga, S. Hammarling, and F. Delebecque, "Development of High Performance Numerical Software for Control", IEEE Control Systems Magazine, Vol. 24, Nr. 1, Feb., pp. 60-76, 2004. control-4.1.2/src/PaxHeaders/sl_tg01id.cc0000644000000000000000000000007315012430645015144 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/sl_tg01id.cc0000644000175000017500000001120115012430645016327 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Staircase observability form for descriptor models. Uses SLICOT TG01ID by courtesy of NICONET e.V. Author: Lukas Reichlin Created: September 2010 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (tg01id, TG01ID) (char& JOBOBS, char& COMPQ, char& COMPZ, F77_INT& N, F77_INT& M, F77_INT& P, double* A, F77_INT& LDA, double* E, F77_INT& LDE, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* Q, F77_INT& LDQ, double* Z, F77_INT& LDZ, F77_INT& NOBSV, F77_INT& NIUOBS, F77_INT& NLBLCK, F77_INT* CTAU, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_tg01id__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_tg01id__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_tg01id__ (@dots{})\n" "Wrapper for SLICOT function TG01ID.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 5) { print_usage (); } else { // arguments in char jobobs = 'O'; char compq = 'I'; char compz = 'I'; Matrix a = args(0).matrix_value (); Matrix e = args(1).matrix_value (); Matrix b = args(2).matrix_value (); Matrix c = args(3).matrix_value (); double tol = args(4).double_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || e.any_element_is_inf_or_nan ()) error ("__sl_tg01id__: inputs must not contain NaN or Inf\n"); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT lde = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, m, p); F77_INT ldq = max (1, n); F77_INT ldz = max (1, n); b.resize (ldb, max (m, p)); // arguments out Matrix q (ldq, n); Matrix z (ldz, n); F77_INT nobsv; F77_INT niuobs; F77_INT nlblck; OCTAVE_LOCAL_BUFFER (F77_INT, ctau, n); // workspace F77_INT ldwork = max (n, 2*p); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, p); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT info; // SLICOT routine TG01ID F77_XFCN (tg01id, TG01ID, (jobobs, compq, compz, n, m, p, a.fortran_vec (), lda, e.fortran_vec (), lde, b.fortran_vec (), ldb, c.fortran_vec (), ldc, q.fortran_vec (), ldq, z.fortran_vec (), ldz, nobsv, niuobs, nlblck, ctau, tol, iwork, dwork, info)); if (f77_exception_encountered) error ("__sl_tg01id__: exception in SLICOT subroutine TG01ID"); if (info != 0) error ("__sl_tg01id__: TG01ID returned info = %d", static_cast (info)); // resize a.resize (n, n); e.resize (n, n); b.resize (n, m); c.resize (p, n); q.resize (n, n); z.resize (n, n); // return values retval(0) = a; retval(1) = e; retval(2) = b; retval(3) = c; retval(4) = q; retval(5) = z; retval(6) = octave_value (nobsv); } return retval; } control-4.1.2/src/PaxHeaders/sl_ab13ad.cc0000644000000000000000000000007415012430645015110 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/sl_ab13ad.cc0000644000175000017500000001000515012430645016273 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Hankel singular values. Uses SLICOT AB13AD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: January 2010 Version: 0.4 */ #include #include "common.h" extern "C" { int F77_FUNC (ab13ad, AB13AD) (char& DICO, char& EQUIL, F77_INT& N, F77_INT& M, F77_INT& P, double& ALPHA, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, F77_INT& NS, double* HSV, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ab13ad__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ab13ad__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ab13ad__ (@dots{})\n" "Wrapper for SLICOT function AB13AD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 6) { print_usage (); } else { // arguments in char dico; char equil; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); F77_INT discrete = args(3).int_value (); double alpha = args(4).double_value (); const F77_INT scaled = args(5).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan ()) error ("__sl_ab13ad__: inputs must not contain NaN or Inf\n"); if (discrete == 0) dico = 'C'; else dico = 'D'; if (scaled == 0) equil = 'S'; else equil = 'N'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, TO_F77_INT (a.rows ())); F77_INT ldb = max (1, TO_F77_INT (b.rows ())); F77_INT ldc = max (1, TO_F77_INT (c.rows ())); // arguments out F77_INT ns = 0; ColumnVector hsv (n); // workspace F77_INT ldwork = max (1, n*(max (n, m, p) + 5) + n*(n+1)/2); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT info = 0; // SLICOT routine AB13AD F77_XFCN (ab13ad, AB13AD, (dico, equil, n, m, p, alpha, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, ns, hsv.fortran_vec (), dwork, ldwork, info)); if (f77_exception_encountered) error ("hsvd: __sl_ab13ad__: exception in SLICOT subroutine AB13AD"); if (info != 0) error ("hsvd: __sl_ab13ad__: AB13AD returned info = %d", static_cast (info)); // resize hsv.resize (ns); // return values retval(0) = hsv; retval(1) = octave_value (ns); } return retval; } control-4.1.2/src/PaxHeaders/common.h0000644000000000000000000000007415012430645014511 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/common.h0000644000175000017500000000376615012430645015714 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Common code for oct-files. Author: Lukas Reichlin Created: February 2012 Version: 0.2 */ #ifndef COMMON_H #define COMMON_H #include #if defined (OCTAVE_HAVE_F77_INT_TYPE) # define TO_F77_INT(x) octave::to_f77_int (x) #else typedef octave_idx_type F77_INT; # define TO_F77_INT(x) (x) typedef octave_idx_type F77_LOGICAL; #endif F77_INT max (F77_INT a, F77_INT b); F77_INT max (F77_INT a, F77_INT b, F77_INT c); F77_INT max (F77_INT a, F77_INT b, F77_INT c, F77_INT d); F77_INT max (F77_INT a, F77_INT b, F77_INT c, F77_INT d, F77_INT e); F77_INT min (F77_INT a, F77_INT b); void error_msg (const char name[], octave_idx_type index, octave_idx_type max, const char* msg[]); void warning_msg (const char name[], octave_idx_type index, octave_idx_type max, const char* msg[]); void warning_msg (const char name[], octave_idx_type index, octave_idx_type max, const char* msg[], octave_idx_type offset); // FIXME: Keep until Octave 4.2 and older are no longer supported. // This conditional defines f77_exception_encountered as a dummy constant // to preserve code that needed to check its value to work correctly in older // versions of Octave. #if defined (OCTAVE_MAJOR_VERSION) && OCTAVE_MAJOR_VERSION >= 6 static const int f77_exception_encountered = 0; #endif #include "config.h" #endif control-4.1.2/src/PaxHeaders/sl_tg01ad.cc0000644000000000000000000000007315012430645015134 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/sl_tg01ad.cc0000644000175000017500000000744715012430645016340 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Balance descriptor state-space model. Uses SLICOT TG01AD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: June 2011 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (tg01ad, TG01AD) (char& JOB, F77_INT& L, F77_INT& N, F77_INT& M, F77_INT& P, double& TRESH, double* A, F77_INT& LDA, double* E, F77_INT& LDE, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* LSCALE, double *RSCALE, double* DWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_tg01ad__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_tg01ad__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_tg01ad__ (@dots{})\n" "Wrapper for SLICOT function TG01AD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 5) { print_usage (); } else { // arguments in char job = 'A'; Matrix a = args(0).matrix_value (); Matrix e = args(1).matrix_value (); Matrix b = args(2).matrix_value (); Matrix c = args(3).matrix_value (); double tresh = args(4).double_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || e.any_element_is_inf_or_nan ()) error ("__sl_tg01ad__: inputs must not contain NaN or Inf\n"); F77_INT l = TO_F77_INT (a.rows ()); F77_INT n = TO_F77_INT (a.columns ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, l); F77_INT lde = max (1, l); F77_INT ldb = max (1, l); F77_INT ldc = max (1, p); // arguments out ColumnVector lscale (l); ColumnVector rscale (n); // workspace OCTAVE_LOCAL_BUFFER (double, dwork, 3*(l+n)); // error indicators F77_INT info = 0; // SLICOT routine TG01AD F77_XFCN (tg01ad, TG01AD, (job, l, n, m, p, tresh, a.fortran_vec (), lda, e.fortran_vec (), lde, b.fortran_vec (), ldb, c.fortran_vec (), ldc, lscale.fortran_vec (), rscale.fortran_vec (), dwork, info)); if (f77_exception_encountered) error ("ss: prescale: __sl_tg01ad__: exception in SLICOT subroutine TG01AD"); if (info != 0) error ("ss: prescale: __sl_tg01ad__: TG01AD returned info = %d", static_cast (info)); // return values retval(0) = a; retval(1) = e; retval(2) = b; retval(3) = c; retval(4) = lscale; retval(5) = rscale; } return retval; } control-4.1.2/src/PaxHeaders/sl_sb16bd.cc0000644000000000000000000000007315012430645015135 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/sl_sb16bd.cc0000644000175000017500000001734515012430645016337 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . TODO Uses SLICOT SB16BD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: November 2011 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (sb16bd, SB16BD) (char& DICO, char& JOBD, char& JOBMR, char& JOBCF, char& EQUIL, char& ORDSEL, F77_INT& N, F77_INT& M, F77_INT& P, F77_INT& NCR, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* F, F77_INT& LDF, double* G, F77_INT& LDG, double* DC, F77_INT& LDDC, double* HSV, double& TOL1, double& TOL2, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb16bd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb16bd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb16bd__ (@dots{})\n" "Wrapper for SLICOT function SB16BD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 15) { print_usage (); } else { // arguments in char dico; char jobd; char jobmr; char jobcf; char equil; char ordsel; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); const F77_INT idico = args(4).int_value (); const F77_INT iequil = args(5).int_value (); F77_INT ncr = args(6).int_value (); const F77_INT iordsel = args(7).int_value (); const F77_INT ijobd = args(8).int_value (); const F77_INT ijobmr = args(9).int_value (); Matrix f = args(10).matrix_value (); Matrix g = args(11).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan () || f.any_element_is_inf_or_nan () || g.any_element_is_inf_or_nan ()) error ("__sl_sb16bd__: inputs must not contain NaN or Inf\n"); const F77_INT ijobcf = args(12).int_value (); double tol1 = args(13).double_value (); double tol2 = args(14).double_value (); if (idico == 0) dico = 'C'; else dico = 'D'; if (iequil == 0) equil = 'S'; else equil = 'N'; if (iordsel == 0) ordsel = 'F'; else ordsel = 'A'; if (ijobd == 0) jobd = 'Z'; else jobd = 'D'; if (ijobcf == 0) jobcf = 'L'; else jobcf = 'R'; switch (ijobmr) { case 0: jobmr = 'B'; break; case 1: jobmr = 'F'; break; case 2: jobmr = 'S'; break; case 3: jobmr = 'P'; break; default: error ("__sl_sb16bd__: argument jobmr invalid"); } F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); F77_INT ldd; if (jobd == 'Z') ldd = 1; else ldd = max (1, p); F77_INT ldf = max (1, m); F77_INT ldg = max (1, n); F77_INT lddc = max (1, m); // arguments out Matrix dc (lddc, p); ColumnVector hsv (n); // workspace F77_INT liwork; F77_INT pm; F77_INT ldwork; F77_INT lwr = max (1, n*(2*n+max(n,m+p)+5)+n*(n+1)/2); switch (jobmr) { case 'B': pm = 0; break; case 'F': pm = n; break; default: // if JOBMR = 'S' or 'P' pm = max (1, 2*n); } if (ordsel == 'F' && ncr == n) { liwork = 0; ldwork = p*n; } else if (jobcf == 'L') { liwork = max (pm, m); ldwork = (n+m)*(m+p) + max (lwr, 4*m); } else // if JOBCF = 'R' { liwork = max (pm, p); ldwork = (n+p)*(m+p) + max (lwr, 4*p); } OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT iwarn = 0; F77_INT info = 0; // SLICOT routine SB16BD F77_XFCN (sb16bd, SB16BD, (dico, jobd, jobmr, jobcf, equil, ordsel, n, m, p, ncr, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, f.fortran_vec (), ldf, g.fortran_vec (), ldg, dc.fortran_vec (), lddc, hsv.fortran_vec (), tol1, tol2, iwork, dwork, ldwork, iwarn, info)); if (f77_exception_encountered) error ("cfconred: exception in SLICOT subroutine SB16BD"); static const char* err_msg[] = { "0: OK", "1: the reduction of A-L*C to a real Schur form " "failed", "2: the matrix A-L*C is not stable (if DICO = 'C'), " "or not convergent (if DICO = 'D')", "3: the computation of Hankel singular values failed", "4: the reduction of A-B*F to a real Schur form " "failed", "5: the matrix A-B*F is not stable (if DICO = 'C'), " "or not convergent (if DICO = 'D')"}; static const char* warn_msg[] = { "0: OK", "1: with ORDSEL = 'F', the selected order NCR is " "greater than the order of a minimal " "realization of the controller."}; error_msg ("cfconred", info, 5, err_msg); warning_msg ("cfconred", iwarn, 1, warn_msg); // resize a.resize (ncr, ncr); // Ac g.resize (ncr, p); // Bc f.resize (m, ncr); // Cc dc.resize (m, p); // Dc // return values retval(0) = a; retval(1) = g; retval(2) = f; retval(3) = dc; retval(4) = octave_value (ncr); retval(5) = hsv; } return retval; } control-4.1.2/src/PaxHeaders/src_aux0000644000000000000000000000007415012430645014437 xustar0030 atime=1747595720.873132883 30 ctime=1747595720.873132883 control-4.1.2/src/src_aux/0000755000175000017500000000000015012430645015703 5ustar00lilgelilge00000000000000control-4.1.2/src/src_aux/PaxHeaders/README.md0000644000000000000000000000007315012430645015772 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/src_aux/README.md0000644000175000017500000000515215012430645017165 0ustar00lilgelilge00000000000000**Purpose** This directory `src_aux` contains deprecated auxiliary LAPACK source files which are used by some SLICOT routines. For now, this directory includes - `dgegs` The deprecated routines `dlatzm` and `zlatzm` are already provided with the SLICOT-Reference files. **Copyright** ``` Copyright (c) 1992-2025 The University of Tennessee and The University of Tennessee Research Foundation. All rights reserved. Copyright (c) 2000-2025 The University of California Berkeley. All rights reserved. Copyright (c) 2006-2025 The University of Colorado Denver. All rights reserved. ``` **License** The LAPACK files are licensed by a [BSD 3-Clause License](https://raw.githubusercontent.com/Reference-LAPACK/lapack/refs/heads/master/LICENSE): Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer listed in this license in the documentation and/or other materials provided with the distribution. - Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. The copyright holders provide no reassurances that the source code provided does not infringe any patent, copyright, or any other intellectual property rights of third parties. The copyright holders disclaim any liability to any recipient for claims brought against recipient by any third party for infringement of that parties intellectual property rights. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. control-4.1.2/src/src_aux/PaxHeaders/dgegs.f0000644000000000000000000000007315012430645015753 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/src_aux/dgegs.f0000644000175000017500000004164215012430645017152 0ustar00lilgelilge00000000000000*> \brief DGEGS computes the eigenvalues, real Schur form, and, optionally, the left and/or right Schur vectors of a real matrix pair (A,B) * * =========== DOCUMENTATION =========== * * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * *> Download DGEGS + dependencies *> *> [TGZ] *> *> [ZIP] *> *> [TXT] * * Definition: * =========== * * SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, * ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, * LWORK, INFO ) * * .. Scalar Arguments .. * CHARACTER JOBVSL, JOBVSR * INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N * .. * .. Array Arguments .. * DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), * $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), * $ VSR( LDVSR, * ), WORK( * ) * .. * * *> \par Purpose: * ============= *> *> \verbatim *> *> This routine is deprecated and has been replaced by routine DGGES. *> *> DGEGS computes the eigenvalues, real Schur form, and, optionally, *> left and or/right Schur vectors of a real matrix pair (A,B). *> Given two square matrices A and B, the generalized real Schur *> factorization has the form *> *> A = Q*S*Z**T, B = Q*T*Z**T *> *> where Q and Z are orthogonal matrices, T is upper triangular, and S *> is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal *> blocks, the 2-by-2 blocks corresponding to complex conjugate pairs *> of eigenvalues of (A,B). The columns of Q are the left Schur vectors *> and the columns of Z are the right Schur vectors. *> *> If only the eigenvalues of (A,B) are needed, the driver routine *> DGEGV should be used instead. See DGEGV for a description of the *> eigenvalues of the generalized nonsymmetric eigenvalue problem *> (GNEP). *> \endverbatim * * Arguments: * ========== * *> \param[in] JOBVSL *> \verbatim *> JOBVSL is CHARACTER*1 *> = 'N': do not compute the left Schur vectors; *> = 'V': compute the left Schur vectors (returned in VSL). *> \endverbatim *> *> \param[in] JOBVSR *> \verbatim *> JOBVSR is CHARACTER*1 *> = 'N': do not compute the right Schur vectors; *> = 'V': compute the right Schur vectors (returned in VSR). *> \endverbatim *> *> \param[in] N *> \verbatim *> N is INTEGER *> The order of the matrices A, B, VSL, and VSR. N >= 0. *> \endverbatim *> *> \param[in,out] A *> \verbatim *> A is DOUBLE PRECISION array, dimension (LDA, N) *> On entry, the matrix A. *> On exit, the upper quasi-triangular matrix S from the *> generalized real Schur factorization. *> \endverbatim *> *> \param[in] LDA *> \verbatim *> LDA is INTEGER *> The leading dimension of A. LDA >= max(1,N). *> \endverbatim *> *> \param[in,out] B *> \verbatim *> B is DOUBLE PRECISION array, dimension (LDB, N) *> On entry, the matrix B. *> On exit, the upper triangular matrix T from the generalized *> real Schur factorization. *> \endverbatim *> *> \param[in] LDB *> \verbatim *> LDB is INTEGER *> The leading dimension of B. LDB >= max(1,N). *> \endverbatim *> *> \param[out] ALPHAR *> \verbatim *> ALPHAR is DOUBLE PRECISION array, dimension (N) *> The real parts of each scalar alpha defining an eigenvalue *> of GNEP. *> \endverbatim *> *> \param[out] ALPHAI *> \verbatim *> ALPHAI is DOUBLE PRECISION array, dimension (N) *> The imaginary parts of each scalar alpha defining an *> eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th *> eigenvalue is real; if positive, then the j-th and (j+1)-st *> eigenvalues are a complex conjugate pair, with *> ALPHAI(j+1) = -ALPHAI(j). *> \endverbatim *> *> \param[out] BETA *> \verbatim *> BETA is DOUBLE PRECISION array, dimension (N) *> The scalars beta that define the eigenvalues of GNEP. *> Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and *> beta = BETA(j) represent the j-th eigenvalue of the matrix *> pair (A,B), in one of the forms lambda = alpha/beta or *> mu = beta/alpha. Since either lambda or mu may overflow, *> they should not, in general, be computed. *> \endverbatim *> *> \param[out] VSL *> \verbatim *> VSL is DOUBLE PRECISION array, dimension (LDVSL,N) *> If JOBVSL = 'V', the matrix of left Schur vectors Q. *> Not referenced if JOBVSL = 'N'. *> \endverbatim *> *> \param[in] LDVSL *> \verbatim *> LDVSL is INTEGER *> The leading dimension of the matrix VSL. LDVSL >=1, and *> if JOBVSL = 'V', LDVSL >= N. *> \endverbatim *> *> \param[out] VSR *> \verbatim *> VSR is DOUBLE PRECISION array, dimension (LDVSR,N) *> If JOBVSR = 'V', the matrix of right Schur vectors Z. *> Not referenced if JOBVSR = 'N'. *> \endverbatim *> *> \param[in] LDVSR *> \verbatim *> LDVSR is INTEGER *> The leading dimension of the matrix VSR. LDVSR >= 1, and *> if JOBVSR = 'V', LDVSR >= N. *> \endverbatim *> *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) *> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. *> \endverbatim *> *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= max(1,4*N). *> For good performance, LWORK must generally be larger. *> To compute the optimal value of LWORK, call ILAENV to get *> blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: *> NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR *> The optimal LWORK is 2*N + N*(NB+1). *> *> If LWORK = -1, then a workspace query is assumed; the routine *> only calculates the optimal size of the WORK array, returns *> this value as the first entry of the WORK array, and no error *> message related to LWORK is issued by XERBLA. *> \endverbatim *> *> \param[out] INFO *> \verbatim *> INFO is INTEGER *> = 0: successful exit *> < 0: if INFO = -i, the i-th argument had an illegal value. *> = 1,...,N: *> The QZ iteration failed. (A,B) are not in Schur *> form, but ALPHAR(j), ALPHAI(j), and BETA(j) should *> be correct for j=INFO+1,...,N. *> > N: errors that usually indicate LAPACK problems: *> =N+1: error return from DGGBAL *> =N+2: error return from DGEQRF *> =N+3: error return from DORMQR *> =N+4: error return from DORGQR *> =N+5: error return from DGGHRD *> =N+6: error return from DHGEQZ (other than failed *> iteration) *> =N+7: error return from DGGBAK (computing VSL) *> =N+8: error return from DGGBAK (computing VSR) *> =N+9: error return from DLASCL (various places) *> \endverbatim * * Authors: * ======== * *> \author Univ. of Tennessee *> \author Univ. of California Berkeley *> \author Univ. of Colorado Denver *> \author NAG Ltd. * *> \ingroup doubleGEeigen * * ===================================================================== SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, $ LWORK, INFO ) * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. CHARACTER JOBVSL, JOBVSR INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ), $ VSR( LDVSR, * ), WORK( * ) * .. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO, $ IRIGHT, IROWS, ITAU, IWORK, LOPT, LWKMIN, $ LWKOPT, NB, NB1, NB2, NB3 DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, $ SAFMIN, SMLNUM * .. * .. External Subroutines .. EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY, $ DLASCL, DLASET, DORGQR, DORMQR, XERBLA * .. * .. External Functions .. LOGICAL LSAME INTEGER ILAENV DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. INTRINSIC INT, MAX * .. * .. Executable Statements .. * * Decode the input arguments * IF( LSAME( JOBVSL, 'N' ) ) THEN IJOBVL = 1 ILVSL = .FALSE. ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN IJOBVL = 2 ILVSL = .TRUE. ELSE IJOBVL = -1 ILVSL = .FALSE. END IF * IF( LSAME( JOBVSR, 'N' ) ) THEN IJOBVR = 1 ILVSR = .FALSE. ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN IJOBVR = 2 ILVSR = .TRUE. ELSE IJOBVR = -1 ILVSR = .FALSE. END IF * * Test the input arguments * LWKMIN = MAX( 4*N, 1 ) LWKOPT = LWKMIN WORK( 1 ) = LWKOPT LQUERY = ( LWORK.EQ.-1 ) INFO = 0 IF( IJOBVL.LE.0 ) THEN INFO = -1 ELSE IF( IJOBVR.LE.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN INFO = -12 ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN INFO = -14 ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN INFO = -16 END IF * IF( INFO.EQ.0 ) THEN NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 ) NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 ) NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 ) NB = MAX( NB1, NB2, NB3 ) LOPT = 2*N + N*( NB+1 ) WORK( 1 ) = LOPT END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEGS ', -INFO ) RETURN ELSE IF( LQUERY ) THEN RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Get machine constants * EPS = DLAMCH( 'E' )*DLAMCH( 'B' ) SAFMIN = DLAMCH( 'S' ) SMLNUM = N*SAFMIN / EPS BIGNUM = ONE / SMLNUM * * Scale A if max element outside range [SMLNUM,BIGNUM] * ANRM = DLANGE( 'M', N, N, A, LDA, WORK ) 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 ) THEN CALL DLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Scale B if max element outside range [SMLNUM,BIGNUM] * BNRM = DLANGE( 'M', N, N, B, LDB, WORK ) ILBSCL = .FALSE. IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN BNRMTO = SMLNUM ILBSCL = .TRUE. ELSE IF( BNRM.GT.BIGNUM ) THEN BNRMTO = BIGNUM ILBSCL = .TRUE. END IF * IF( ILBSCL ) THEN CALL DLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * * Permute the matrix to make it more nearly triangular * Workspace layout: (2*N words -- "work..." not actually used) * left_permutation, right_permutation, work... * ILEFT = 1 IRIGHT = N + 1 IWORK = IRIGHT + N CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), WORK( IWORK ), IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 1 GO TO 10 END IF * * Reduce B to triangular form, and initialize VSL and/or VSR * Workspace layout: ("work..." must have at least N words) * left_permutation, right_permutation, tau, work... * IROWS = IHI + 1 - ILO ICOLS = N + 1 - ILO ITAU = IWORK IWORK = ITAU + IROWS CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ), $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 2 GO TO 10 END IF * CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB, $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ), $ LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 3 GO TO 10 END IF * IF( ILVSL ) THEN CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL ) CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB, $ VSL( ILO+1, ILO ), LDVSL ) CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL, $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK, $ IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN INFO = N + 4 GO TO 10 END IF END IF * IF( ILVSR ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR ) * * Reduce to generalized Hessenberg form * CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL, $ LDVSL, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 5 GO TO 10 END IF * * Perform QZ algorithm, computing Schur vectors if desired * Workspace layout: ("work..." must have at least 1 word) * left_permutation, right_permutation, work... * IWORK = ITAU CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, $ WORK( IWORK ), LWORK+1-IWORK, IINFO ) IF( IINFO.GE.0 ) $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 ) IF( IINFO.NE.0 ) THEN IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN INFO = IINFO ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN INFO = IINFO - N ELSE INFO = N + 6 END IF GO TO 10 END IF * * Apply permutation to VSL and VSR * IF( ILVSL ) THEN CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSL, LDVSL, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 7 GO TO 10 END IF END IF IF( ILVSR ) THEN CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ), $ WORK( IRIGHT ), N, VSR, LDVSR, IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 8 GO TO 10 END IF END IF * * Undo scaling * IF( ILASCL ) THEN CALL DLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAI, N, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * IF( ILBSCL ) THEN CALL DLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF CALL DLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, $ IINFO ) IF( IINFO.NE.0 ) THEN INFO = N + 9 RETURN END IF END IF * 10 CONTINUE WORK( 1 ) = LWKOPT * RETURN * * End of DGEGS * END control-4.1.2/src/PaxHeaders/sl_sb16ad.cc0000644000000000000000000000007315012430645015134 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/sl_sb16ad.cc0000644000175000017500000002431215012430645016326 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Controller reduction based on Balance & Truncate (B&T) or Singular Perturbation Approximation (SPA) method. Uses SLICOT SB16AD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: November 2011 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (sb16ad, SB16AD) (char& DICO, char& JOBC, char& JOBO, char& JOBMR, char& WEIGHT, char& EQUIL, char& ORDSEL, F77_INT& N, F77_INT& M, F77_INT& P, F77_INT& NC, F77_INT& NCR, double& ALPHA, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* AC, F77_INT& LDAC, double* BC, F77_INT& LDBC, double* CC, F77_INT& LDCC, double* DC, F77_INT& LDDC, F77_INT& NCS, double* HSVC, double& TOL1, double& TOL2, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb16ad__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb16ad__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb16ad__ (@dots{})\n" "Wrapper for SLICOT function SB16AD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 19) { print_usage (); } else { // arguments in char dico; char jobc; char jobo; char jobmr; char weight; char equil; char ordsel; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); const F77_INT idico = args(4).int_value (); const F77_INT iequil = args(5).int_value (); F77_INT ncr = args(6).int_value (); const F77_INT iordsel = args(7).int_value (); double alpha = args(8).double_value (); const F77_INT ijobmr = args(9).int_value (); Matrix ac = args(10).matrix_value (); Matrix bc = args(11).matrix_value (); Matrix cc = args(12).matrix_value (); Matrix dc = args(13).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan () || ac.any_element_is_inf_or_nan () || bc.any_element_is_inf_or_nan () || cc.any_element_is_inf_or_nan () || dc.any_element_is_inf_or_nan ()) error ("__sl_sb16ad__: inputs must not contain NaN or Inf\n"); const F77_INT iweight = args(14).int_value (); const F77_INT ijobc = args(15).int_value (); const F77_INT ijobo = args(16).int_value (); double tol1 = args(17).double_value (); double tol2 = args(18).double_value (); if (idico == 0) dico = 'C'; else dico = 'D'; if (iequil == 0) equil = 'S'; else equil = 'N'; if (iordsel == 0) ordsel = 'F'; else ordsel = 'A'; if (ijobc == 0) jobc = 'S'; else jobc = 'E'; if (ijobo == 0) jobo = 'S'; else jobo = 'E'; switch (ijobmr) { case 0: jobmr = 'B'; break; case 1: jobmr = 'F'; break; case 2: jobmr = 'S'; break; case 3: jobmr = 'P'; break; default: error ("__sl_sb16ad__: argument jobmr invalid"); } switch (iweight) { case 0: weight = 'N'; break; case 1: weight = 'O'; break; case 2: weight = 'I'; break; case 3: weight = 'P'; break; default: error ("__sl_sb16ad__: argument weight invalid"); } F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT nc = TO_F77_INT (ac.rows ()); F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); F77_INT ldd = max (1, p); F77_INT ldac = max (1, nc); F77_INT ldbc = max (1, nc); F77_INT ldcc = max (1, m); F77_INT lddc = max (1, m); // arguments out F77_INT ncs; ColumnVector hsvc (n); // workspace F77_INT liwork; F77_INT liwrk1; F77_INT liwrk2; switch (jobmr) { case 'B': liwrk1 = 0; break; case 'F': liwrk1 = nc; break; default: liwrk1 = 2*nc; } if (weight == 'N') liwrk2 = 0; else liwrk2 = 2*(m+p); liwork = max (1, liwrk1, liwrk2); F77_INT ldwork; F77_INT lfreq; F77_INT lsqred; if (weight == 'N') { if (equil == 'N') // if WEIGHT = 'N' and EQUIL = 'N' lfreq = nc*(max (m, p) + 5); else // if WEIGHT = 'N' and EQUIL = 'S' lfreq = max (n, nc*(max (m, p) + 5)); } else // if WEIGHT = 'I' or 'O' or 'P' { lfreq = (n+nc)*(n+nc+2*m+2*p) + max ((n+nc)*(n+nc+max(n+nc,m,p)+7), (m+p)*(m+p+4)); } lsqred = max (1, 2*nc*nc+5*nc); ldwork = 2*nc*nc + max (1, lfreq, lsqred); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT iwarn = 0; F77_INT info = 0; // SLICOT routine SB16AD F77_XFCN (sb16ad, SB16AD, (dico, jobc, jobo, jobmr, weight, equil, ordsel, n, m, p, nc, ncr, alpha, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, ac.fortran_vec (), ldac, bc.fortran_vec (), ldbc, cc.fortran_vec (), ldcc, dc.fortran_vec (), lddc, ncs, hsvc.fortran_vec (), tol1, tol2, iwork, dwork, ldwork, iwarn, info)); if (f77_exception_encountered) error ("conred: exception in SLICOT subroutine SB16AD"); static const char* err_msg[] = { "0: OK", "1: the closed-loop system is not well-posed; " "its feedthrough matrix is (numerically) singular", "2: the computation of the real Schur form of the " "closed-loop state matrix failed", "3: the closed-loop state matrix is not stable", "4: the solution of a symmetric eigenproblem failed", "5: the computation of the ordered real Schur form " "of Ac failed", "6: the separation of the ALPHA-stable/unstable " "diagonal blocks failed because of very close eigenvalues", "7: the computation of Hankel singular values failed"}; static const char* warn_msg[] = { "0: OK", "1: with ORDSEL = 'F', the selected order NCR is greater " "than NSMIN, the sum of the order of the " "ALPHA-unstable part and the order of a minimal " "realization of the ALPHA-stable part of the given " "controller; in this case, the resulting NCR is set " "equal to NSMIN.", "2: with ORDSEL = 'F', the selected order NCR " "corresponds to repeated singular values for the " "ALPHA-stable part of the controller, which are " "neither all included nor all excluded from the " "reduced model; in this case, the resulting NCR is " "automatically decreased to exclude all repeated " "singular values.", "3: with ORDSEL = 'F', the selected order NCR is less " "than the order of the ALPHA-unstable part of the " "given controller. In this case NCR is set equal to " "the order of the ALPHA-unstable part."}; error_msg ("conred", info, 7, err_msg); warning_msg ("conred", iwarn, 3, warn_msg); // resize ac.resize (ncr, ncr); bc.resize (ncr, p); // p: number of plant outputs cc.resize (m, ncr); // m: number of plant inputs hsvc.resize (ncs); // return values retval(0) = ac; retval(1) = bc; retval(2) = cc; retval(3) = dc; retval(4) = octave_value (ncr); retval(5) = hsvc; retval(6) = octave_value (ncs); } return retval; } control-4.1.2/src/PaxHeaders/sl_sb01bd.cc0000644000000000000000000000007415012430645015130 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/sl_sb01bd.cc0000644000175000017500000001307515012430645016325 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Pole assignment for a given matrix pair (A,B). Uses SLICOT SB01BD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: November 2009 Version: 0.6 */ #include #include "common.h" extern "C" { int F77_FUNC (sb01bd, SB01BD) (char& DICO, F77_INT& N, F77_INT& M, F77_INT& NP, double& ALPHA, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* WR, double* WI, F77_INT& NFP, F77_INT& NAP, F77_INT& NUP, double* F, F77_INT& LDF, double* Z, F77_INT& LDZ, double& TOL, double* DWORK, F77_INT& LDWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb01bd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb01bd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb01bd__ (@dots{})\n" "Wrapper for SLICOT function SB01BD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 7) { print_usage (); } else { // arguments in char dico; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); ColumnVector wr = args(2).column_vector_value (); ColumnVector wi = args(3).column_vector_value (); F77_INT discrete = args(4).int_value (); double alpha = args(5).double_value (); double tol = args(6).double_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan ()) error ("__sl_sb01bd__: inputs must not contain NaN or Inf\n"); if (discrete == 1) dico = 'D'; else dico = 'C'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT np = TO_F77_INT (wr.rows ()); F77_INT lda = max (1, TO_F77_INT (a.rows ())); F77_INT ldb = max (1, TO_F77_INT (b.rows ())); F77_INT ldf = max (1, m); F77_INT ldz = max (1, n); // arguments out F77_INT nfp; F77_INT nap; F77_INT nup; Matrix f (ldf, n); Matrix z (ldz, n); // workspace F77_INT ldwork = max (1, 5*m, 5*n, 2*n+4*m); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT iwarn; F77_INT info; // SLICOT routine SB01BD 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.fortran_vec (), ldz, tol, dwork, ldwork, iwarn, info)); if (f77_exception_encountered) error ("place: __sl_sb01bd__: exception in SLICOT subroutine SB01BD"); static const char* err_msg[] = { "0: OK", "1: the reduction of A to a real Schur form failed.", "2: a failure was detected during the ordering of the " "real Schur form of A, or in the iterative process " "for reordering the eigenvalues of Z'*(A + B*F)*Z " "along the diagonal.", "3: the number of eigenvalues to be assigned is less " "than the number of possibly assignable eigenvalues; " "NAP eigenvalues have been properly assigned, " "but some assignable eigenvalues remain unmodified.", "4: an attempt is made to place a complex conjugate " "pair on the location of a real eigenvalue. This " "situation can only appear when N-NFP is odd, " "NP > N-NFP-NUP is even, and for the last real " "eigenvalue to be modified there exists no available " "real eigenvalue to be assigned. However, NAP " "eigenvalues have been already properly assigned."}; static const char* warn_msg[] = { "0: OK", /* 0+%d: %d */ "violations of the numerical stability condition " "NORM(F) <= 100*NORM(A)/NORM(B) occurred during the " "assignment of eigenvalues."}; error_msg ("place", info, 4, err_msg); warning_msg ("place", iwarn, 0, warn_msg, 0); // return values retval(0) = f; retval(1) = octave_value (nfp); retval(2) = octave_value (nap); retval(3) = octave_value (nup); retval(4) = z; } return retval; } control-4.1.2/src/PaxHeaders/sl_ab09hd.cc0000644000000000000000000000007415012430645015124 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/sl_ab09hd.cc0000644000175000017500000001760415012430645016323 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Model reduction based on balanced stochastic truncation method. Uses SLICOT AB09HD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: October 2011 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (ab09hd, AB09HD) (char& DICO, char& JOB, char& EQUIL, char& ORDSEL, F77_INT& N, F77_INT& M, F77_INT& P, F77_INT& NR, double& ALPHA, double& BETA, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, F77_INT& NS, double* HSV, double& TOL1, double& TOL2, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ab09hd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ab09hd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ab09hd__ (@dots{})\n" "Wrapper for SLICOT function AB09HD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 13) { print_usage (); } else { // arguments in char dico; char job; char equil; char ordsel; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_ab09hd__: inputs must not contain NaN or Inf\n"); const F77_INT idico = args(4).int_value (); const F77_INT iequil = args(5).int_value (); const F77_INT ijob = args(6).int_value (); F77_INT nr = args(7).int_value (); const F77_INT iordsel = args(8).int_value (); double alpha = args(9).double_value (); double beta = args(10).double_value (); double tol1 = args(11).double_value (); double tol2 = args(12).double_value (); switch (ijob) { case 0: job = 'B'; break; case 1: job = 'F'; break; case 2: job = 'S'; break; case 3: job = 'P'; break; default: error ("__sl_ab09hd__: argument job invalid"); } if (idico == 0) dico = 'C'; else dico = 'D'; if (iequil == 0) equil = 'S'; else equil = 'N'; if (iordsel == 0) ordsel = 'F'; else ordsel = 'A'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); F77_INT ldd = max (1, p); // arguments out F77_INT ns; ColumnVector hsv (n); // workspace F77_INT liwork = max (1, 2*n); F77_INT mb; if (beta == 0) mb = m; else mb = m + p; F77_INT ldwork = 2*n*n + mb*(n+p) + max (2, n*(max (n,mb,p)+5), 2*n*p + max (p*(mb+2), 10*n*(n+1))); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, 2*n); // error indicators F77_INT iwarn = 0; F77_INT info = 0; // SLICOT routine AB09HD F77_XFCN (ab09hd, AB09HD, (dico, job, equil, ordsel, n, m, p, nr, alpha, beta, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, ns, hsv.fortran_vec (), tol1, tol2, iwork, dwork, ldwork, bwork, iwarn, info)); if (f77_exception_encountered) error ("bstmodred: exception in SLICOT subroutine AB09HD"); static const char* err_msg[] = { "0: OK", "1: the computation of the ordered real Schur form of A " "failed", "2: the reduction of the Hamiltonian matrix to real " "Schur form failed", "3: the reordering of the real Schur form of the " "Hamiltonian matrix failed", "4: the Hamiltonian matrix has less than N stable " "eigenvalues", "5: the coefficient matrix U11 in the linear system " "X*U11 = U21 to determine X is singular to working " "precision", "6: BETA = 0 and D has not a maximal row rank", "7: the computation of Hankel singular values failed", "8: the separation of the ALPHA-stable/unstable diagonal " "blocks failed because of very close eigenvalues", "9: the resulting order of reduced stable part is less " "than the number of unstable zeros of the stable " "part"}; static const char* warn_msg[] = { "0: OK", "1: with ORDSEL = 'F', the selected order NR is greater " "than NSMIN, the sum of the order of the " "ALPHA-unstable part and the order of a minimal " "realization of the ALPHA-stable part of the given " "system; in this case, the resulting NR is set equal " "to NSMIN.", "2: with ORDSEL = 'F', the selected order NR corresponds " "to repeated singular values for the ALPHA-stable " "part, which are neither all included nor all " "excluded from the reduced model; in this case, the " "resulting NR is automatically decreased to exclude " "all repeated singular values.", "3: with ORDSEL = 'F', the selected order NR is less " "than the order of the ALPHA-unstable part of the " "given system; in this case NR is set equal to the " "order of the ALPHA-unstable part."}; error_msg ("bstmodred", info, 9, err_msg); warning_msg ("bstmodred", iwarn, 3, warn_msg); // resize a.resize (nr, nr); b.resize (nr, m); c.resize (p, nr); hsv.resize (ns); // return values retval(0) = a; retval(1) = b; retval(2) = c; retval(3) = d; retval(4) = octave_value (nr); retval(5) = hsv; retval(6) = octave_value (ns); } return retval; } control-4.1.2/src/PaxHeaders/is_matrix.cc0000644000000000000000000000007415012430645015356 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/is_matrix.cc0000644000175000017500000000347515012430645016556 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Return true if all arguments are matrices and false otherwise. Author: Lukas Reichlin Created: June 2012 Version: 0.2 */ #include #include "config.h" // PKG_ADD: autoload ("is_matrix", "__control_helper_functions__.oct"); DEFUN_DLD (is_matrix, args, nargout, "-*- texinfo -*-\n" "@deftypefn {Loadable Function} {} is_matrix (@var{a}, @dots{})@*\n" "Return true if all arguments are matrices and false otherwise.@*\n" "@var{[]} is a valid matrix.@*\n" "Avoid nasty stuff like @code{true = isreal (\"a\")}@*\n" "@seealso{is_real_matrix, is_real_square_matrix, is_real_vector, is_real_scalar}@*\n" "@end deftypefn") { octave_value retval = true; octave_idx_type nargin = args.length (); if (nargin == 0) { print_usage (); } else { for (octave_idx_type i = 0; i < nargin; i++) { if (args(i).ndims () != 2 || ! args(i).OV_ISNUMERIC () || ! (args(i).OV_ISCOMPLEX () || args(i).OV_ISREAL ())) { retval = false; break; } } } return retval; } control-4.1.2/src/PaxHeaders/is_real_vector.cc0000644000000000000000000000007415012430645016357 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/is_real_vector.cc0000644000175000017500000000356515012430645017557 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Return true if all arguments are real-valued vectors and false otherwise. Author: Lukas Reichlin Created: September 2010 Version: 0.2 */ #include #include "config.h" // PKG_ADD: autoload ("is_real_vector", "__control_helper_functions__.oct"); DEFUN_DLD (is_real_vector, args, nargout, "-*- texinfo -*-\n" "@deftypefn {Loadable Function} {} is_real_vector (@var{a}, @dots{})@*\n" "Return true if all arguments are real-valued vectors and false otherwise.@*\n" "@var{[]} is not a valid vector.@*\n" "Avoid nasty stuff like @code{true = isreal (\"a\")}@*\n" "@seealso{is_real_square_matrix, is_real_matrix, is_real_scalar}@*\n" "@end deftypefn") { octave_value retval = true; octave_idx_type nargin = args.length (); if (nargin == 0) { print_usage (); } else { for (octave_idx_type i = 0; i < nargin; i++) { if (args(i).ndims () != 2 || ! (args(i).rows () == 1 || args(i).columns () == 1) || ! args(i).OV_ISNUMERIC () || ! args(i).OV_ISREAL ()) { retval = false; break; } } } return retval; } control-4.1.2/src/PaxHeaders/sl_sb10zd.cc0000644000000000000000000000007315012430645015157 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/sl_sb10zd.cc0000644000175000017500000001300715012430645016350 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Positive feedback controller for a discrete-time system (D != 0). Uses SLICOT SB10ZD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: August 2011 Version: 0.4 */ #include #include "common.h" extern "C" { int F77_FUNC (sb10zd, SB10ZD) (F77_INT& N, F77_INT& M, F77_INT& NP, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double& FACTOR, double* AK, F77_INT& LDAK, double* BK, F77_INT& LDBK, double* CK, F77_INT& LDCK, double* DK, F77_INT& LDDK, double* RCOND, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb10zd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb10zd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb10zd__ (@dots{})\n" "Wrapper for SLICOT function SB10ZD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 6) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_sb10zd__: inputs must not contain NaN or Inf\n"); double factor = args(4).double_value (); double tol = args(5).double_value (); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT np = TO_F77_INT (c.rows ()); // np: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, np); F77_INT ldd = max (1, np); F77_INT ldak = max (1, n); F77_INT ldbk = max (1, n); F77_INT ldck = max (1, m); F77_INT lddk = max (1, m); // arguments out Matrix ak (ldak, n); Matrix bk (ldbk, np); Matrix ck (ldck, n); Matrix dk (lddk, np); ColumnVector rcond (6); // workspace F77_INT liwork = 2 * max (n, m+np); F77_INT ldwork = 16*n*n + 5*m*m + 7*np*np + 6*m*n + 7*m*np + 7*n*np + 6*n + 2*(m + np) + max (14*n+23, 16*n, 2*m-1, 2*np-1); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, 2*n); // error indicator F77_INT info; // SLICOT routine SB10ZD F77_XFCN (sb10zd, SB10ZD, (n, m, np, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, factor, ak.fortran_vec (), ldak, bk.fortran_vec (), ldbk, ck.fortran_vec (), ldck, dk.fortran_vec (), lddk, rcond.fortran_vec (), tol, iwork, dwork, ldwork, bwork, info)); if (f77_exception_encountered) error ("ncfsyn: __sl_sb10zd__: exception in SLICOT subroutine SB10ZD"); static const char* err_msg[] = { "0: OK", "1: the P-Riccati equation is not solved successfully", "2: the Q-Riccati equation is not solved successfully", "3: the iteration to compute eigenvalues or singular " "values failed to converge", "4: the matrix (gamma^2-1)*In - P*Q is singular", "5: the matrix Rx + Bx'*X*Bx is singular", "6: the matrix Ip + D*Dk is singular", "7: the matrix Im + Dk*D is singular", "8: the matrix Ip - D*Dk is singular", "9: the matrix Im - Dk*D is singular", "10: the closed-loop system is unstable"}; error_msg ("ncfsyn", info, 10, err_msg); // resizing ak.resize (n, n); bk.resize (n, np); ck.resize (m, n); dk.resize (m, np); // return values retval(0) = ak; retval(1) = bk; retval(2) = ck; retval(3) = dk; retval(4) = rcond; } return retval; } control-4.1.2/src/PaxHeaders/Makefile.conf.in0000644000000000000000000000007415012430645016041 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/Makefile.conf.in0000644000175000017500000000003315012430645017224 0ustar00lilgelilge00000000000000HAVE_DGGES := @HAVE_DGGES@ control-4.1.2/src/PaxHeaders/sl_ib01cd.cc0000644000000000000000000000007415012430645015117 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/sl_ib01cd.cc0000644000175000017500000001600315012430645016306 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Compute initial state vector x0 Uses IB01CD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: May 2012 Version: 0.2 */ #include #include #include "common.h" extern "C" { int F77_FUNC (ib01cd, IB01CD) (char& JOBX0, char& COMUSE, char& JOB, F77_INT& N, F77_INT& M, F77_INT& L, F77_INT& NSMP, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* U, F77_INT& LDU, double* Y, F77_INT& LDY, double* X0, double* V, F77_INT& LDV, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& IWARN, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ib01cd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ib01cd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ib01cd__ (@dots{})\n" "Wrapper for SLICOT function IB01CD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 7) { print_usage (); } else { // arguments in char jobx0 = 'X'; char comuse = 'U'; char jobbd = 'D'; const Cell y_cell = args(0).cell_value (); const Cell u_cell = args(1).cell_value (); Matrix a = args(2).matrix_value (); Matrix b = args(3).matrix_value (); Matrix c = args(4).matrix_value (); Matrix d = args(5).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_ib01cd__: inputs must not contain NaN or Inf\n"); double rcond = args(6).double_value (); double tol_c = rcond; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT l = TO_F77_INT (c.rows ()); // l: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, l); F77_INT ldd = max (1, l); // m and l are equal for all experiments, checked by iddata class F77_INT n_exp = TO_F77_INT (y_cell.numel ()); // number of experiments // arguments out Cell x0_cell (n_exp, 1); // cell of initial state vectors x0 // repeat for every experiment in the dataset // compute individual initial state vector x0 for every experiment for (F77_INT i = 0; i < n_exp; i++) { Matrix y = y_cell.elem(i).matrix_value (); Matrix u = u_cell.elem(i).matrix_value (); if (y.any_element_is_inf_or_nan () || u.any_element_is_inf_or_nan ()) error ("__sl_ib01cd__: inputs must not contain NaN or Inf\n"); F77_INT nsmp = TO_F77_INT (y.rows ()); // nsmp: number of samples F77_INT ldv = max (1, n); F77_INT ldu; if (m == 0) ldu = 1; else // m > 0 ldu = nsmp; F77_INT ldy = nsmp; // arguments out ColumnVector x0 (n); Matrix v (ldv, n); // workspace F77_INT liwork_c = n; // if JOBX0 = 'X' and COMUSE <> 'C' F77_INT ldwork_c; F77_INT t = nsmp; F77_INT ldw1_c = 2; F77_INT ldw2_c = t*l*(n + 1) + 2*n + max (2*n*n, 4*n); F77_INT ldw3_c = n*(n + 1) + 2*n + max (n*l*(n + 1) + 2*n*n + l*n, 4*n); ldwork_c = ldw1_c + n*( n + m + l ) + max (5*n, ldw1_c, min (ldw2_c, ldw3_c)); OCTAVE_LOCAL_BUFFER (F77_INT, iwork_c, liwork_c); OCTAVE_LOCAL_BUFFER (double, dwork_c, ldwork_c); // error indicators F77_INT iwarn_c = 0; F77_INT info_c = 0; // SLICOT routine IB01CD F77_XFCN (ib01cd, IB01CD, (jobx0, comuse, jobbd, n, m, l, nsmp, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, u.fortran_vec (), ldu, y.fortran_vec (), ldy, x0.fortran_vec (), v.fortran_vec (), ldv, tol_c, iwork_c, dwork_c, ldwork_c, iwarn_c, info_c)); if (f77_exception_encountered) error ("__sl_ib01cd__: exception in SLICOT subroutine IB01CD"); static const char* err_msg_c[] = { "0: OK", "1: the QR algorithm failed to compute all the " "eigenvalues of the matrix A (see LAPACK Library " "routine DGEES); the locations DWORK(i), for " "i = g+1:g+N*N, contain the partially converged " "Schur form", "2: the singular value decomposition (SVD) algorithm did " "not converge"}; static const char* warn_msg_c[] = { "0: OK", "1: warning message not specified", "2: warning message not specified", "3: warning message not specified", "4: the least squares problem to be solved has a " "rank-deficient coefficient matrix", "5: warning message not specified", "6: the matrix A is unstable; the estimated x(0) " "and/or B and D could be inaccurate"}; error_msg ("__sl_ib01cd__", info_c, 2, err_msg_c); warning_msg ("__sl_ib01cd__", iwarn_c, 6, warn_msg_c); x0_cell.elem(i) = x0; // add x0 from the current experiment to cell of initial state vectors } // return values retval(0) = x0_cell; } return retval; } control-4.1.2/src/PaxHeaders/sl_sg03ad.cc0000644000000000000000000000007315012430645015135 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/sl_sg03ad.cc0000644000175000017500000001057415012430645016334 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Solution of generalized Lyapunov equations. Uses SLICOT SG03AD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: January 2010 Version: 0.3 */ #include #include "common.h" extern "C" { int F77_FUNC (sg03ad, SG03AD) (char& DICO, char& JOB, char& FACT, char& TRANS, char& UPLO, F77_INT& N, double* A, F77_INT& LDA, double* E, F77_INT& LDE, double* Q, F77_INT& LDQ, double* Z, F77_INT& LDZ, double* X, F77_INT& LDX, double& SCALE, double& SEP, double& FERR, double* ALPHAR, double* ALPHAI, double* BETA, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sg03ad__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sg03ad__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sg03ad__ (@dots{})\n" "Wrapper for SLICOT function SG03AD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 4) { print_usage (); } else { // arguments in char dico; char job = 'X'; char fact = 'N'; char trans = 'T'; char uplo = 'U'; // ?!? Matrix a = args(0).matrix_value (); Matrix e = args(1).matrix_value (); Matrix x = args(2).matrix_value (); F77_INT discrete = args(3).int_value (); if (a.any_element_is_inf_or_nan () || e.any_element_is_inf_or_nan () || x.any_element_is_inf_or_nan ()) error ("__sl_sg03ad__: inputs must not contain NaN or Inf\n"); if (discrete == 0) dico = 'C'; else dico = 'D'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT lda = max (1, n); F77_INT lde = max (1, n); F77_INT ldq = max (1, n); F77_INT ldz = max (1, n); F77_INT ldx = max (1, n); // arguments out double scale; double sep = 0; double ferr = 0; Matrix q (ldq, n); Matrix z (ldz, n); ColumnVector alphar (n); ColumnVector alphai (n); ColumnVector beta (n); // workspace F77_INT* iwork = 0; // not referenced because job = X F77_INT ldwork = max (1, 8*n+16); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT info; // SLICOT routine SG03AD F77_XFCN (sg03ad, SG03AD, (dico, job, fact, trans, uplo, n, a.fortran_vec (), lda, e.fortran_vec (), lde, q.fortran_vec (), ldq, z.fortran_vec (), ldz, x.fortran_vec (), ldx, scale, sep, ferr, alphar.fortran_vec (), alphai.fortran_vec (), beta.fortran_vec (), iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("lyap: __sl_sg03ad__: exception in SLICOT subroutine SG03AD"); if (info != 0) error ("lyap: __sl_sg03ad__: SG03AD returned info = %d", static_cast (info)); // return values retval(0) = x; retval(1) = octave_value (scale); } return retval; } control-4.1.2/src/PaxHeaders/sl_sb10hd.cc0000644000000000000000000000007315012430645015135 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/sl_sb10hd.cc0000644000175000017500000001277315012430645016337 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . H2 optimal state controller for a continuous-time system. Uses SLICOT SB10HD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: November 2009 Version: 0.6 */ #include #include "common.h" extern "C" { int F77_FUNC (sb10hd, SB10HD) (F77_INT& N, F77_INT& M, F77_INT& NP, F77_INT& NCON, F77_INT& NMEAS, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* AK, F77_INT& LDAK, double* BK, F77_INT& LDBK, double* CK, F77_INT& LDCK, double* DK, F77_INT& LDDK, double* RCOND, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb10hd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb10hd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb10hd__ (@dots{})\n" "Wrapper for SLICOT function SB10HD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 6) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_sb10hd__: inputs must not contain NaN or Inf\n"); F77_INT ncon = args(4).int_value (); F77_INT nmeas = args(5).int_value (); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT np = TO_F77_INT (c.rows ()); // np: number of outputs F77_INT lda = max (1, TO_F77_INT (a.rows ())); F77_INT ldb = max (1, TO_F77_INT (b.rows ())); F77_INT ldc = max (1, TO_F77_INT (c.rows ())); F77_INT ldd = max (1, TO_F77_INT (d.rows ())); F77_INT ldak = max (1, n); F77_INT ldbk = max (1, n); F77_INT ldck = max (1, ncon); F77_INT lddk = max (1, ncon); double tol = 0; // arguments out Matrix ak (ldak, n); Matrix bk (ldbk, nmeas); Matrix ck (ldck, n); Matrix dk (lddk, nmeas); ColumnVector rcond (4); // workspace F77_INT m2 = ncon; F77_INT m1 = m - m2; F77_INT np1 = np - nmeas; F77_INT np2 = nmeas; F77_INT q = max (m1, m2, np1, np2); F77_INT ldwork = 2*q*(3*q + 2*n) + max (1, q*(q + max (n, 5) + 1), n*(14*n + 12 + 2*q) + 5); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, max (2*n, n*n)); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, 2*n); // error indicator F77_INT info; // SLICOT routine SB10HD F77_XFCN (sb10hd, SB10HD, (n, m, np, ncon, nmeas, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, ak.fortran_vec (), ldak, bk.fortran_vec (), ldbk, ck.fortran_vec (), ldck, dk.fortran_vec (), lddk, rcond.fortran_vec (), tol, iwork, dwork, ldwork, bwork, info)); if (f77_exception_encountered) error ("h2syn: __sl_sb10hd__: exception in SLICOT subroutine SB10HD"); static const char* err_msg[] = { "0: OK", "1: the matrix D12 had not full column rank in " "respect to the tolerance TOL", "2: the matrix D21 had not full row rank in respect " "to the tolerance TOL", "3: the singular value decomposition (SVD) algorithm " "did not converge (when computing the SVD of one of " "the matrices D12 or D21)", "4: the X-Riccati equation was not solved successfully", "5: the Y-Riccati equation was not solved successfully"}; error_msg ("h2syn", info, 5, err_msg); // return values retval(0) = ak; retval(1) = bk; retval(2) = ck; retval(3) = dk; retval(4) = rcond; } return retval; } control-4.1.2/src/PaxHeaders/sl_tg01hd.cc0000644000000000000000000000007315012430645015143 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/sl_tg01hd.cc0000644000175000017500000001113315012430645016332 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Staircase controllability form for descriptor models. Uses SLICOT TG01HD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: September 2010 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (tg01hd, TG01HD) (char& JOBCON, char& COMPQ, char& COMPZ, F77_INT& N, F77_INT& M, F77_INT& P, double* A, F77_INT& LDA, double* E, F77_INT& LDE, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* Q, F77_INT& LDQ, double* Z, F77_INT& LDZ, F77_INT& NCONT, F77_INT& NIUCON, F77_INT& NRBLCK, F77_INT* RTAU, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_tg01hd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_tg01hd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_tg01hd__ (@dots{})\n" "Wrapper for SLICOT function TG01HD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 5) { print_usage (); } else { // arguments in char jobcon = 'C'; char compq = 'I'; char compz = 'I'; Matrix a = args(0).matrix_value (); Matrix e = args(1).matrix_value (); Matrix b = args(2).matrix_value (); Matrix c = args(3).matrix_value (); double tol = args(4).double_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || e.any_element_is_inf_or_nan ()) error ("__sl_tg01hd__: inputs must not contain NaN or Inf\n"); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT lde = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); F77_INT ldq = max (1, n); F77_INT ldz = max (1, n); // arguments out Matrix q (ldq, n); Matrix z (ldz, n); F77_INT ncont; F77_INT niucon; F77_INT nrblck; OCTAVE_LOCAL_BUFFER (F77_INT, rtau, n); // workspace F77_INT ldwork = max (n, 2*m); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, m); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT info; // SLICOT routine TG01HD F77_XFCN (tg01hd, TG01HD, (jobcon, compq, compz, n, m, p, a.fortran_vec (), lda, e.fortran_vec (), lde, b.fortran_vec (), ldb, c.fortran_vec (), ldc, q.fortran_vec (), ldq, z.fortran_vec (), ldz, ncont, niucon, nrblck, rtau, tol, iwork, dwork, info)); if (f77_exception_encountered) error ("__sl_tg01hd__: exception in SLICOT subroutine TG01HD"); if (info != 0) error ("__sl_tg01hd__: TG01HD returned info = %d", static_cast (info)); // resize a.resize (n, n); e.resize (n, n); b.resize (n, m); c.resize (p, n); q.resize (n, n); z.resize (n, n); // return values retval(0) = a; retval(1) = e; retval(2) = b; retval(3) = c; retval(4) = q; retval(5) = z; retval(6) = octave_value (ncont); } return retval; } control-4.1.2/src/PaxHeaders/sl_sb10jd.cc0000644000000000000000000000007315012430645015137 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/sl_sb10jd.cc0000644000175000017500000000750615012430645016337 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Convert descriptor state-space system into regular state-space form. Uses SLICOT SB10JD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: September 2011 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (sb10jd, SB10JD) (F77_INT& N, F77_INT& M, F77_INT& NP, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, double* E, F77_INT& LDE, F77_INT& NSYS, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb10jd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb10jd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb10jd__ (@dots{})\n" "Wrapper for SLICOT function SB10JD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 5) { print_usage (); } else { // arguments in Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); Matrix e = args(4).matrix_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_sb10jd__: inputs must not contain NaN or Inf\n"); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT np = TO_F77_INT (c.rows ()); // np: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, np); F77_INT ldd = max (1, np); F77_INT lde = max (1, n); // arguments out F77_INT nsys; // workspace F77_INT ldwork = max (1, 2*n*n + 2*n + n*max (5, n + m + np)); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT info; // SLICOT routine SB10JD F77_XFCN (sb10jd, SB10JD, (n, m, np, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, e.fortran_vec (), lde, nsys, dwork, ldwork, info)); if (f77_exception_encountered) error ("__sl_sb10jd__: exception in SLICOT subroutine SB10JD"); if (info != 0) error ("__sl_sb10jd__: SB10JD returned info = %d", static_cast (info)); // resize a.resize (nsys, nsys); b.resize (nsys, m); c.resize (np, nsys); // return values retval(0) = a; retval(1) = b; retval(2) = c; retval(3) = d; } return retval; } control-4.1.2/src/PaxHeaders/sl_are.cc0000644000000000000000000000007415012430645014624 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/sl_are.cc0000644000175000017500000002206515012430645016020 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Solve algebraic Riccati equation. Uses SLICOT SB02RD and SB02MT by courtesy of NICONET e.V. Author: Lukas Reichlin Created: December 2012 Version: 0.2 */ #include #include "common.h" #include extern "C" { int F77_FUNC (sb02mt, SB02MT) (char& JOBG, char& JOBL, char& FACT, char& UPLO, F77_INT& N, F77_INT& M, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* Q, F77_INT& LDQ, double* R, F77_INT& LDR, double* L, F77_INT& LDL, F77_INT* IPIV, F77_INT& OUFACT, double* G, F77_INT& LDG, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); int F77_FUNC (sb02rd, SB02RD) (char& JOB, char& DICO, char& HINV, char& TRANA, char& UPLO, char& SCAL, char& SORT, char& FACT, char& LYAPUN, F77_INT& N, double* A, F77_INT& LDA, double* T, F77_INT& LDT, double* V, F77_INT& LDV, double* G, F77_INT& LDG, double* Q, F77_INT& LDQ, double* X, F77_INT& LDX, double& SEP, double& RCOND, double& FERR, double* WR, double* WI, double* S, F77_INT& LDS, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_are__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_are__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb02mt__ (@dots{})\n" "Wrapper for SLICOT function SB02MT.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 7) { print_usage (); } else { // SB02MT // arguments in char dico; char jobg = 'G'; char jobl; char fact = 'N'; char uplo = 'U'; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix q = args(2).matrix_value (); Matrix r = args(3).matrix_value (); Matrqx l = args(4).matrix_value (); rF77_INT discrete l args(5).int_value (); F77_INT ijobl = args(6).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || q.any_element_is_inf_or_nan () || r.any_element_is_inf_or_nan () || l.any_element_is_inf_or_nan ()) error ("__sl_are__: inputs must not contain NaN or Inf\n"); if (discrete == 0) dico = 'C'; else dico = 'D'; if (ijobl == 0) jobl = 'Z'; else jobl = 'N'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldq = max (1, n); F77_INT ldr = max (1, m); F77_INT ldl = max (1, n); // arguments out F77_INT ldg = max (1, n); Matrix g (ldg, n); // unused output arguments OCTAVE_LOCAL_BUFFER (F77_INT, ipiv, m); F77_INT oufact; // workspace OCTAVE_LOCAL_BUFFER (F77_INT, iwork_a, m); F77_INT ldwork_a = max (2, 3*m, n*m); OCTAVE_LOCAL_BUFFER (double, dwork_a, ldwork_a); // error indicator F77_INT info; // SLICOT routine SB02MT F77_XFCN (sb02mt, SB02MT, (jobg, jobl, fact, uplo, n, m, a.fortran_vec (), lda, b.fortran_vec (), ldb, q.fortran_vec (), ldq, r.fortran_vec (), ldr, l.fortran_vec (), ldl, ipiv, oufact, g.fortran_vec (), ldg, iwork_a, dwork_a, ldwork_a, info)); if (f77_exception_encountered) error ("are: __sl_are__: exception in SLICOT subroutine SB02MT"); if (info != 0) { if (info < 0) error ("are: sb02mt: the %d-th argument had an illegal value", info); else if (info == m+1) error ("are: sb02mt: the matrix R is numerically singular"); else error ("are: sb02mt: the %d-th element (1 <= %d <= %d) of the d factor is " "exactly zero; the UdU' (or LdL') factorization has " "been completed, but the block diagonal matrix d is " "exactly singular", info, info, m); } // SB02RD // arguments in char job = 'A'; char hinv = 'D'; char trana = 'N'; char scal = 'G'; char sort = 'S'; char lyapun = 'O'; F77_INT ldt = max (1, n); F77_INT ldv = max (1, n); F77_INT ldx = max (1, n); F77_INT lds = max (1, 2*n); // arguments out Matrix x (ldx, n); double sep; double rcond; double ferr; ColumnVector wr (2*n); ColumnVector wi (2*n); // unused output arguments Matrix t (ldt, n); Matrix v (ldv, n); Matrix s (lds, 2*n); // workspace F77_INT liwork_b = max (2*n, n*n); OCTAVE_LOCAL_BUFFER (F77_INT, iwork_b, liwork_b); F77_INT ldwork_b = 5 + max (1, 4*n*n + 8*n); OCTAVE_LOCAL_BUFFER (double, dwork_b, ldwork_b); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork_b, 2*n); // SLICOT routine SB02RD F77_XFCN (sb02rd, SB02RD, (job, dico, hinv, trana, uplo, scal, sort, fact, lyapun, n, a.fortran_vec (), lda, t.fortran_vec (), ldt, v.fortran_vec (), ldv, g.fortran_vec (), ldg, q.fortran_vec (), ldq, x.fortran_vec (), ldx, sep, rcond, ferr, wr.fortran_vec (), wi.fortran_vec (), s.fortran_vec (), lds, iwork_b, dwork_b, ldwork_b, bwork_b, info)); static const char* err_msg[] = { "0: OK", "1: matrix A is (numerically) singular in discrete-" "time case", "2: the Hamiltonian or symplectic matrix H cannot be " "reduced to real Schur form", "3: the real Schur form of the Hamiltonian or " "symplectic matrix H cannot be appropriately ordered", "4: the Hamiltonian or symplectic matrix H has less " "than N stable eigenvalues", "5: if the N-th order system of linear algebraic " "equations, from which the solution matrix X would " "be obtained, is singular to working precision", "6: the QR algorithm failed to complete the reduction " "of the matrix Ac to Schur canonical form, T", "7: if T and -T' have some almost equal eigenvalues, if " "DICO = 'C', or T has almost reciprocal eigenvalues, " "if DICO = 'D'; perturbed values were used to solve " "Lyapunov equations, but the matrix T, if given (for " "FACT = 'F'), is unchanged. (This is a warning " "indicator.)"}; error_msg ("are", info, 7, err_msg); // resize x.resize (n, n); wr.resize (n); wi.resize (n); // assemble complex vector - adapted from DEFUN complex in data.cc ComplexColumnVector pole (n, Complex ()); for (F77_INT i = 0; i < n; i++) pole.xelem (i) = Complex (wr(i), wi(i)); // return value retval(0) = x; retval(1) = pole; retval(2) = octave_value (ferr); retval(3) = octave_value (rcond); retval(4) = octave_value (sep); } return retval; } control-4.1.2/src/PaxHeaders/lti_input_idx.cc0000644000000000000000000000007415012430645016232 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/lti_input_idx.cc0000644000175000017500000000660015012430645017423 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . First, this function implemented the following Octave function in C++ function [mat_idx, opt_idx] = __lti_input_idx__ (varargin) str_idx = find (cellfun (@ischar, varargin)); if (isempty (str_idx)) mat_idx = 1 : nargin; opt_idx = []; else mat_idx = 1 : str_idx(1)-1; opt_idx = str_idx(1) : nargin; endif endfunction Later on, the C++ function was extended such that it recognizes classes in some cases. See comment block in the code for details. I know this looks like a horrible definition for a function, but it is exactly the behavior I need. Author: Lukas Reichlin Created: October 2015 Version: 0.1 */ #include #include "config.h" // PKG_ADD: autoload ("__lti_input_idx__", "__control_helper_functions__.oct"); DEFUN_DLD (__lti_input_idx__, args, , "-*- texinfo -*-\n" "@deftypefn {Loadable Function} {[@var{mat_idx}, @var{opt_idx}, @var{obj_flg}] =} __lti_input_idx__ (@var{args})@*\n" "Return some indices for cell @var{args}. For internal use only.@*\n" "Read the source code in @code{lti_input_idx.cc} for details.@*\n" "@end deftypefn") { octave_value_list retval; octave_idx_type nargin = args.length (); // first, check whether a cell is passed if (nargin == 1 && args(0).is_defined () && args(0).OV_ISCELL ()) { octave_idx_type len = args(0).cell_value().numel(); octave_idx_type idx = len; octave_idx_type offset = 0; // if the cell is not empty, look for the first string for (octave_idx_type i = 0; i < len; i++) { if (args(0).cell_value().elem(i).is_string ()) { idx = i; break; } } // ** If the element before the first string is an object, // then this object belongs to the option index. // ss (d, ltisys, 'key', val) // ** If there is no string at all in cell args(0), check // whether the last element in args(0) is an object. // If so, this object also belongs to the option index. // tf (num, den, ltisys) // ** All other objects (before built-in types (except chars) // and after strings) are not recognized as objects. // ss (a, b, ltisys, c, d, 'key', val, 'lti', ltisys) if (len > 0 && idx > 0 && args(0).cell_value().elem(idx-1).OV_ISOBJECT ()) { offset = 1; } #if OCTAVE_MAJOR_VERSION > 6 octave::range mat_idx (1, idx-offset); octave::range opt_idx (idx+1-offset, len); #else Range mat_idx (1, idx-offset); Range opt_idx (idx+1-offset, len); #endif retval(2) = offset; // abused as logical in the LTI constructors retval(1) = opt_idx; retval(0) = mat_idx; } else { print_usage (); } return retval; } control-4.1.2/src/PaxHeaders/sl_ab04md.cc0000644000000000000000000000007415012430645015124 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/sl_ab04md.cc0000644000175000017500000000761215012430645016321 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Discrete-time <--> continuous-time systems conversion by a bilinear transformation. Uses SLICOT AB04MD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: September 2011 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (ab04md, AB04MD) (char& TYPE, F77_INT& N, F77_INT& M, F77_INT& P, double& ALPHA, double& BETA, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* D, F77_INT& LDD, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_ab04md__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_ab04md__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_ab04md__ (@dots{})\n" "Wrapper for SLICOT function AB04MD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 7) { print_usage (); } else { // arguments in char type; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); Matrix d = args(3).matrix_value (); double alpha = args(4).double_value (); double beta = args(5).double_value (); F77_INT discrete = args(6).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || d.any_element_is_inf_or_nan ()) error ("__sl_ab04md__: inputs must not contain NaN or Inf\n"); if (discrete == 0) type = 'C'; else type = 'D'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); F77_INT ldd = max (1, p); // workspace F77_INT ldwork = max (1, n); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, n); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT info; // SLICOT routine AB04MD F77_XFCN (ab04md, AB04MD, (type, n, m, p, alpha, beta, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, d.fortran_vec (), ldd, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("__sl_ab04md__: exception in SLICOT subroutine AB04MD"); if (info != 0) error ("__sl_ab04md__: AB04MD returned info = %d", static_cast (info)); // return values retval(0) = a; retval(1) = b; retval(2) = c; retval(3) = d; } return retval; } control-4.1.2/src/PaxHeaders/sl_sb02od.cc0000644000000000000000000000007415012430645015146 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/sl_sb02od.cc0000644000175000017500000001542415012430645016343 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Solve algebraic Riccati equation. Uses SLICOT SB02OD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: February 2010 Version: 0.5 */ #include #include "common.h" #include extern "C" { int F77_FUNC (sb02od, SB02OD) (char& DICO, char& JOBB, char& FACT, char& UPLO, char& JOBL, char& SORT, F77_INT& N, F77_INT& M, F77_INT& P, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* Q, F77_INT& LDQ, double* R, F77_INT& LDR, double* L, F77_INT& LDL, double& RCOND, double* X, F77_INT& LDX, double* ALFAR, double* ALFAI, double* BETA, double* S, F77_INT& LDS, double* T, F77_INT& LDT, double* U, F77_INT& LDU, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_LOGICAL* BWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb02od__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb02od__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb02od__ (@dots{})\n" "Wrapper for SLICOT function SB02OD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 7) { print_usage (); } else { // arguments in char dico; char jobb = 'B'; char fact = 'N'; char uplo = 'U'; char jobl; char sort = 'S'; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix q = args(2).matrix_value (); Matrix r = args(3).matrix_value (); Matrix l = args(4).matrix_value (); F77_INT discrete = args(5).int_value (); F77_INT ijobl = args(6).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || q.any_element_is_inf_or_nan () || r.any_element_is_inf_or_nan () || l.any_element_is_inf_or_nan ()) error ("__sl_sb02od__: inputs must not contain NaN or Inf\n"); if (discrete == 0) dico = 'C'; else dico = 'D'; if (ijobl == 0) jobl = 'Z'; else jobl = 'N'; F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = 0; // p: number of outputs, not used because FACT = 'N' F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldq = max (1, n); F77_INT ldr = max (1, m); F77_INT ldl = max (1, n); // arguments out double rcond; F77_INT ldx = max (1, n); Matrix x (ldx, n); F77_INT nu = 2*n; ColumnVector alfar (nu); ColumnVector alfai (nu); ColumnVector beta (nu); F77_INT lds = max (1, 2*n + m); Matrix s (lds, lds); // unused output arguments F77_INT ldt = max (1, 2*n + m); OCTAVE_LOCAL_BUFFER (double, t, ldt * 2*n); F77_INT ldu = max (1, 2*n); OCTAVE_LOCAL_BUFFER (double, u, ldu * 2*n); // tolerance double tol = 0; // use default value // workspace F77_INT liwork = max (1, m, 2*n); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, liwork); F77_INT ldwork = max (7*(2*n + 1) + 16, 16*n, 2*n + m, 3*m); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); OCTAVE_LOCAL_BUFFER (F77_LOGICAL, bwork, 2*n); // error indicator F77_INT info; // SLICOT routine SB02OD F77_XFCN (sb02od, SB02OD, (dico, jobb, fact, uplo, jobl, sort, n, m, p, a.fortran_vec (), lda, b.fortran_vec (), ldb, q.fortran_vec (), ldq, r.fortran_vec (), ldr, l.fortran_vec (), ldl, rcond, x.fortran_vec (), ldx, alfar.fortran_vec (), alfai.fortran_vec (), beta.fortran_vec (), s.fortran_vec (), lds, t, ldt, u, ldu, tol, iwork, dwork, ldwork, bwork, info)); if (f77_exception_encountered) error ("are: __sl_sb02od__: exception in SLICOT subroutine SB02OD"); static const char* err_msg[] = { "0: OK", "1: the computed extended matrix pencil is singular, " "possibly due to rounding errors", "2: the QZ (or QR) algorithm failed", "3: reordering of the (generalized) eigenvalues " "failed", "4: after reordering, roundoff changed values of " "some complex eigenvalues so that leading eigenvalues " "in the (generalized) Schur form no longer satisfy " "the stability condition; this could also be caused " "due to scaling", "5: the computed dimension of the solution does not " "equal N", "6: a singular matrix was encountered during the " "computation of the solution matrix X"}; error_msg ("are", info, 6, err_msg); // assemble complex vector - adapted from DEFUN complex in data.cc alfar.resize (n); alfai.resize (n); beta.resize (n); ColumnVector poler (n); ColumnVector polei (n); poler = quotient (alfar, beta); polei = quotient (alfai, beta); ComplexColumnVector pole (n, Complex ()); for (F77_INT i = 0; i < n; i++) pole.xelem (i) = Complex (poler(i), polei(i)); // return value retval(0) = x; retval(1) = pole; } return retval; } control-4.1.2/src/PaxHeaders/config.h.in0000644000000000000000000000013015012430710015055 xustar0029 mtime=1747595720.86513257 29 atime=1747595720.86513257 30 ctime=1747595720.873132883 control-4.1.2/src/config.h.in0000644000175000017500000000162115012430710016253 0ustar00lilgelilge00000000000000/* config.h.in. Generated from configure.ac by autoheader. */ #include "undef-ah-octave.h" /* macro for alternative Octave symbols */ #undef OV_ISCELL /* macro for alternative Octave symbols */ #undef OV_ISCOMPLEX /* macro for alternative Octave symbols */ #undef OV_ISNUMERIC /* macro for alternative Octave symbols */ #undef OV_ISOBJECT /* macro for alternative Octave symbols */ #undef OV_ISREAL /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the home page for this package. */ #undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION #include "oct-alt-includes.h" control-4.1.2/src/PaxHeaders/sl_tg01fd.cc0000644000000000000000000000007315012430645015141 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/sl_tg01fd.cc0000644000175000017500000001137015012430645016333 0ustar00lilgelilge00000000000000/* Copyright (C) 2013-2015 Thomas Vasileiou 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 LTI Syncope. If not, see . Orthogonal reduction of a descriptor system to a SVD-like coordinate form. Uses SLICOT TG01FD by courtesy of NICONET e.V. Author: Thomas Vasileiou Created: September 2013 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (tg01fd, TG01FD) (char& COMPQ, char& COMPZ, char& JOBA, F77_INT& L, F77_INT& N, F77_INT& M, F77_INT& P, double* A, F77_INT& LDA, double* E, F77_INT& LDE, double* B, F77_INT& LDB, double* C, F77_INT& LDC, double* Q, F77_INT& LDQ, double* Z, F77_INT& LDZ, F77_INT& RANKE, F77_INT& RNKA22, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_tg01fd__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_tg01fd__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_tg01fd__ (@dots{})\n" "Wrapper for SLICOT function TG01FD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 6) { print_usage (); } else { // arguments in char compq; char compz; char joba = 'T'; Matrix a = args(0).matrix_value (); Matrix e = args(1).matrix_value (); Matrix b = args(2).matrix_value (); Matrix c = args(3).matrix_value (); const F77_INT qz_flag = args(4).int_value (); double tol = args(5).double_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan () || e.any_element_is_inf_or_nan ()) error ("__sl_tg01fd__: inputs must not contain NaN or Inf\n"); if (qz_flag == 0) { compq = 'N'; compz = 'N'; } else { compq = 'I'; compz = 'I'; } F77_INT l = TO_F77_INT (a.rows ()); F77_INT n = l; F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, l); F77_INT lde = max (1, l); F77_INT ldb = max (1, l); F77_INT ldc = max (1, p); F77_INT ldq = max (1, l); F77_INT ldz = max (1, n); // arguments out Matrix q(l, l, 0.); Matrix z(n, n, 0.); Matrix empty(0, 0); F77_INT ranke, rnka22; // workspace F77_INT ldwork = max (1, n+p, min (l,n) + max (3*n-1, m, l)); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, n); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT info = 0; // SLICOT routine TG01FD F77_XFCN (tg01fd, TG01FD, (compq, compz, joba, l, n, m, p, a.fortran_vec (), lda, e.fortran_vec (), lde, b.fortran_vec (), ldb, c.fortran_vec (), ldc, q.fortran_vec (), ldq, z.fortran_vec (), ldz, ranke, rnka22, tol, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("__sl_tg01fd__: exception in SLICOT subroutine TG01FD"); if (info != 0) error ("__sl_tg01fd__: TG01FD returned info = %d", static_cast (info)); // return values retval(0) = a; retval(1) = e; retval(2) = b; retval(3) = c; retval(4) = octave_value (ranke); retval(5) = octave_value (rnka22); if (qz_flag == 0) { retval(6) = empty; retval(7) = empty; } else { retval(6) = q; retval(7) = z; } } return retval; } control-4.1.2/src/PaxHeaders/sl_tb01ud.cc0000644000000000000000000000007315012430645015153 xustar0029 atime=1747595719.94909952 30 ctime=1747595720.873132883 control-4.1.2/src/sl_tb01ud.cc0000644000175000017500000001012515012430645016342 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Orthogonal canonical form. Uses SLICOT TB01UD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: October 2011 Version: 0.2 */ #include #include "common.h" extern "C" { int F77_FUNC (tb01ud, TB01UD) (char& JOBZ, F77_INT& N, F77_INT& M, F77_INT& P, double* A, F77_INT& LDA, double* B, F77_INT& LDB, double* C, F77_INT& LDC, F77_INT& NCONT, F77_INT& INDCON, F77_INT* NBLK, double* Z, F77_INT& LDZ, double* TAU, double& TOL, F77_INT* IWORK, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_tb01ud__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_tb01ud__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_tb01ud__ (@dots{})\n" "Wrapper for SLICOT function TB01UD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 4) { print_usage (); } else { // arguments in char jobz = 'I'; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); Matrix c = args(2).matrix_value (); double tol = args(3).double_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan () || c.any_element_is_inf_or_nan ()) error ("__sl_tb01ud__: inputs must not contain NaN or Inf\n"); F77_INT n = TO_F77_INT (a.rows ()); // n: number of states F77_INT m = TO_F77_INT (b.columns ()); // m: number of inputs F77_INT p = TO_F77_INT (c.rows ()); // p: number of outputs F77_INT lda = max (1, n); F77_INT ldb = max (1, n); F77_INT ldc = max (1, p); F77_INT ldz = max (1, n); // arguments out Matrix z (ldz, n); F77_INT ncont; F77_INT indcon; OCTAVE_LOCAL_BUFFER (F77_INT, nblk, n); OCTAVE_LOCAL_BUFFER (double, tau, n); // workspace F77_INT ldwork = max (1, n, 3*m, p); OCTAVE_LOCAL_BUFFER (F77_INT, iwork, m); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicators F77_INT info; // SLICOT routine TB01UD F77_XFCN (tb01ud, TB01UD, (jobz, n, m, p, a.fortran_vec (), lda, b.fortran_vec (), ldb, c.fortran_vec (), ldc, ncont, indcon, nblk, z.fortran_vec (), ldz, tau, tol, iwork, dwork, ldwork, info)); if (f77_exception_encountered) error ("__sl_tb01ud__: exception in SLICOT subroutine TB01UD"); if (info != 0) error ("__sl_tb01ud__: TB01UD returned info = %d", static_cast (info)); // resize a.resize (n, n); b.resize (n, m); c.resize (p, n); z.resize (n, n); // return values retval(0) = a; retval(1) = b; retval(2) = c; retval(3) = z; retval(4) = octave_value (ncont); } return retval; } control-4.1.2/src/PaxHeaders/configure.ac0000644000000000000000000000007415012430645015336 xustar0030 atime=1747595720.061103563 30 ctime=1747595720.873132883 control-4.1.2/src/configure.ac0000644000175000017500000000454615012430645016536 0ustar00lilgelilge00000000000000# -*- Autoconf -*- # Process this file with autoconf to produce a configure script. AC_PREREQ([2.71]) AC_INIT([control],[4.1.2]) AC_CONFIG_SRCDIR([sl_ab01od.cc]) AC_CONFIG_HEADERS([config.h]) # Avoid warnings for redefining AH-generated preprocessor symbols of # Octave. AH_TOP([#include "undef-ah-octave.h"]) AC_CONFIG_MACRO_DIRS([m4]) # Checks for programs. AC_CHECK_PROG(MKOCTFILE, mkoctfile, mkoctfile) if test -z "$MKOCTFILE"; then AC_MSG_ERROR([mkoctfile not found], 1); fi AC_CHECK_PROG(OCTAVE_CONFIG, octave-config, octave-config) if test -z "$OCTAVE_CONFIG"; then AC_MSG_ERROR([octave-config not found], 1); fi AC_PROG_CXX # Start of checks for Octave features, preparations for checks. OCTLIBDIR=${OCTLIBDIR:-`$OCTAVE_CONFIG -p OCTLIBDIR`} ## We need Octaves include path both with and without '/octave' ## appended. The path without '/octave' is needed to selectively test ## for Octave headers, like octave/....h. The path with '/octave' is ## needed since some Octave headers contain include directives for ## other Octave headers with <> instead of "". OCTINCLUDEDIR=${OCTINCLUDEDIR:-`$MKOCTFILE -p INCFLAGS`} AC_LANG_PUSH([C++]) TCXXFLAGS=$CXXFLAGS TLDFLAGS=$LDFLAGS TLIBS=$LIBS TCPPFLAGS=$CPPFLAGS LDFLAGS="-L$OCTLIBDIR $LDFLAGS" LIBS="-loctinterp $LIBS" # CXXFLAGS= CPPFLAGS="$OCTINCLUDEDIR $CPPFLAGS" ## Simple symbol alternatives of different Octave versions. OF_OCTAVE_LIST_ALT_SYMS([ [dnl [is_real_type], [isreal], [[octave_value ().isreal ();]], [OV_ISREAL], [], [] ], [dnl [is_cell], [iscell], [[octave_value ().iscell ();]], [OV_ISCELL], [], [] ], [dnl [is_object], [isobject], [[octave_value ().isobject ();]], [OV_ISOBJECT], [], [] ], [dnl [is_complex_type], [iscomplex], [[octave_value ().iscomplex ();]], [OV_ISCOMPLEX], [], [] ], [dnl [is_numeric_type], [isnumeric], [[octave_value ().isnumeric ();]], [OV_ISNUMERIC], [], [] ] ], [oct-alt-includes.h]) LIBS=$TLIBS LDFLAGS=$TLDFLAGS CXXFLAGS=$TCXXFLAGS CPPFLAGS=$TCPPFLAGS AC_LANG_POP([C++]) # End of checks for Octave features. # Test for newer DGGES routine in LAPACK AC_LANG_PUSH([Fortran 77]) AC_SEARCH_LIBS(dgges, lapack,[HAVE_DGGES=1],[HAVE_DGGES=0]) AC_LANG_POP([Fortran 77]) AC_SUBST(HAVE_DGGES) # Output results and subst variables in Makefile.conf.in AC_CONFIG_FILES([Makefile.conf]) AC_OUTPUT control-4.1.2/src/PaxHeaders/__control_helper_functions__.cc0000644000000000000000000000007415012430645021262 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/__control_helper_functions__.cc0000644000175000017500000000120015012430645022442 0ustar00lilgelilge00000000000000#include "is_real_scalar.cc" #include "is_real_vector.cc" #include "is_real_matrix.cc" #include "is_real_square_matrix.cc" #include "is_matrix.cc" #include "is_zp_vector.cc" #include "lti_input_idx.cc" // stub function to avoid gen_doc_cache warning upon package installation DEFUN_DLD (__control_helper_functions__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __control_helper_functions__ (@dots{})\n" "Helper functions for the control package.@*\n" "For internal use only.\n" "@end deftypefn") { octave_value_list retval; error ("__control_helper_functions__: for internal use only"); return retval; } control-4.1.2/src/PaxHeaders/sl_sb03od.cc0000644000000000000000000000007415012430645015147 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/src/sl_sb03od.cc0000644000175000017500000000751315012430645016344 0ustar00lilgelilge00000000000000/* Copyright (C) 2009-2016 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 LTI Syncope. If not, see . Square-root solver for Lyapunov equations. Uses SLICOT SB03OD by courtesy of NICONET e.V. Author: Lukas Reichlin Created: January 2010 Version: 0.3 */ #include #include "common.h" extern "C" { int F77_FUNC (sb03od, SB03OD) (char& DICO, char& FACT, char& TRANS, F77_INT& N, F77_INT& M, double* A, F77_INT& LDA, double* Q, F77_INT& LDQ, double* B, F77_INT& LDB, double& SCALE, double* WR, double* WI, double* DWORK, F77_INT& LDWORK, F77_INT& INFO); } // PKG_ADD: autoload ("__sl_sb03od__", "__control_slicot_functions__.oct"); DEFUN_DLD (__sl_sb03od__, args, nargout, "-*- texinfo -*-\n" "@deftypefn {} __sl_sb03od__ (@dots{})\n" "Wrapper for SLICOT function SB03OD.@*\n" "For internal use only.\n" "@end deftypefn") { octave_idx_type nargin = args.length (); octave_value_list retval; if (nargin != 3) { print_usage (); } else { // arguments in char dico; char fact = 'N'; char trans = 'N'; // char trans = 'T'; Matrix a = args(0).matrix_value (); Matrix b = args(1).matrix_value (); F77_INT discrete = args(2).int_value (); if (a.any_element_is_inf_or_nan () || b.any_element_is_inf_or_nan ()) error ("__sl_sb03od__: inputs must not contain NaN or Inf\n"); if (discrete == 0) dico = 'C'; else dico = 'D'; F77_INT n = TO_F77_INT (a.rows ()); F77_INT m = TO_F77_INT (b.rows ()); // F77_INT m = TO_F77_INT (b.columns ()); F77_INT lda = max (1, n); F77_INT ldq = max (1, n); F77_INT ldb = max (1, n, m); // F77_INT ldb = max (1, n); b.resize (ldb, n); // b.resize (ldb, max (m, n)); // arguments out double scale; Matrix q (ldq, n); ColumnVector wr (n); ColumnVector wi (n); // workspace F77_INT ldwork = max (1, 4*n + min (m, n)); OCTAVE_LOCAL_BUFFER (double, dwork, ldwork); // error indicator F77_INT info; // SLICOT routine SB03OD F77_XFCN (sb03od, SB03OD, (dico, fact, trans, n, m, a.fortran_vec (), lda, q.fortran_vec (), ldq, b.fortran_vec (), ldb, scale, wr.fortran_vec (), wi.fortran_vec (), dwork, ldwork, info)); if (f77_exception_encountered) error ("lyapchol: __sl_sb03od__: exception in SLICOT subroutine SB03OD"); if (info != 0) error ("lyapchol: __sl_sb03od__: SB03OD returned info = %d", static_cast (info)); // resize b.resize (n, n); // return values retval(0) = b; // b has been overwritten by cholesky factor u retval(1) = octave_value (scale); } return retval; } control-4.1.2/PaxHeaders/README.md0000644000000000000000000000007415012430645013540 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/README.md0000644000175000017500000000503615012430645014733 0ustar00lilgelilge00000000000000# Octave control package This is the official repository for the control package for GNU Octave. ## About The **control** package is a collection of functions for control systems design and analysis. As of 24.03.2023, the developemnt of the **control** package was moved from [SourceForge](https://sourceforge.net/p/octave/control/ci/default/tree/) and [Mercurial](https://en.wikipedia.org/wiki/Mercurial) to [GitHub](https://github.com/gnu-octave/pkg-control) and [Git](https://en.wikipedia.org/wiki/Git). Links related to the control package - [License and copyright information](https://github.com/gnu-octave/pkg-control/blob/main/COPYING) - [Releases](https://github.com/gnu-octave/pkg-control/releases) - [Documentation](https://gnu-octave.github.io/pkg-control) ## Used Library SLICOT Control uses some routines of the [SLICOT-Reference library](https://github.com/SLICOT/SLICOT-Reference) (Copyright (c) 2020, SLICOT). The sources of the used routines are included in the released control package archive `control-x.y.z.tar.gz` in the directory `src/slicot-src` and are compiled for the target system while installing the control package for Octave. The SLICOT files are available under the *BSD 3-Clause License* which can be found - in the file `src/slicot-src/LICENSE` (together with README files) in the package archive `control-x.y.z.tar.gz`, - in the file `doc/SLICOT/LICENSE` (together with README files) in the package installation directory, or - in the [SLICOT-Reference repository](https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE). ## Installing the control package ### Installing released package version The easiest way to install the newest control package is to type `pkg install -forge control` Alternatively, you may download the package archive file `control-x.y.z.tar.gz` of one of the [releases](https://github.com/gnu-octave/pkg-control/releases) and install it by typing `pkg install control-x.y.z.tar.gz` ### Creating and installing package archives You can also clone this repository (using the option `--recurse-submodules` since SLICOT is included as git submodule) and build the package archive file by yourself. For this, you can use the following commands: - `make dist`
Create the package archive file in the directory `target` which can be installed in Octave afterwards - `make install`
Install the package - `make help`
Show all targets for `make` ## Contributing to the control package Information on how to contribute to the control package can be found in [this document](CONTRIBUTING.md).control-4.1.2/PaxHeaders/post_install.m0000644000000000000000000000007415012430645015152 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/post_install.m0000644000175000017500000000064115012430645016342 0ustar00lilgelilge00000000000000function post_install (d) fprintf ('\n'); fprintf ('The control package was installed into the directory\n'); fprintf ('%s.\n', d.dir); fprintf ('License and copyright information can be found in '); fprintf ('\"packinfo/COPYING\".\n'); fprintf ('\n'); fprintf ('If the control package was updated in this Octave\n'); fprintf ('session, you might have to restart Octave.\n'); fprintf ('\n'); end control-4.1.2/PaxHeaders/COPYING0000644000000000000000000000007415012430645013314 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/COPYING0000644000175000017500000011152115012430645014504 0ustar00lilgelilge00000000000000----------------------------------------------------------------------------- 1. License information ----------------------------------------------------------------------------- Git Repository * slicot-reference: submodule, Copyright (c) 2020, SLICOT BSD 3-Clause (see Sec. 3) * src/src_aux: See src/src_aux/README.md * other files: Copyright see individual files GPLv3+ (see Sec. 2) Distributed package archive control-x.y.z.tar.gz * src/slicot: Copyright (c) 2020, SLICOT BSD 3-Clause (see Sec. 3) * src/src_aux: See src/src_aux/README.md * other files: Copyright see individual files GPLv3+ (see Sec. 2) ----------------------------------------------------------------------------- 2. GPLv3+ License ----------------------------------------------------------------------------- GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . ----------------------------------------------------------------------------- 3. BSD 3-Clause License ----------------------------------------------------------------------------- Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. control-4.1.2/PaxHeaders/inst0000644000000000000000000000007415012430645013161 xustar0030 atime=1747595720.873132883 30 ctime=1747595720.873132883 control-4.1.2/inst/0000755000175000017500000000000015012430645014425 5ustar00lilgelilge00000000000000control-4.1.2/inst/PaxHeaders/__remove_leading_zeros__.m0000644000000000000000000000007415012430645020412 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__remove_leading_zeros__.m0000644000175000017500000000230215012430645021576 0ustar00lilgelilge00000000000000## Copyright (C) 2024 Torsten Lilge ## ## This file is part of GNU Octave's Control Package. ## ## This file 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 file 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Remove leading zeros from a polynomial or a cell array of polynomials. ## polynomials of length one are not changed. For internal use only. ## Author: Torsten Lilge function p = __remove_leading_zeros__ (p) if (isa (p, "cell")) p = cellfun (@__remove_leading_zeros__, p, "uniformoutput", false); return; endif idx = find (p != 0); if (isempty (idx)) return; else p = p(idx(1):end); endif endfunction control-4.1.2/inst/PaxHeaders/sensitivity.m0000644000000000000000000000007415012430645016006 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/sensitivity.m0000644000175000017500000001107315012430645017177 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{Ms}, @var{ws}] =} sensitivity (@var{L}) ## @deftypefnx{Function File} {[@var{Ms}, @var{ws}] =} sensitivity (@var{P}, @var{C}) ## @deftypefnx{Function File} {[@var{Ms}, @var{ws}] =} sensitivity (@var{P}, @var{C1}, @var{C2}, @dots{}) ## Return sensitivity margin @var{Ms}. ## The quantity @var{Ms} is simply the inverse of the shortest ## distance from the Nyquist curve to the critical point -1. ## Reasonable values of @var{Ms} are in the range from 1.3 to 2. ## @iftex ## @tex ## $$ M_s = ||S(j\\omega)||_{\\infty} $$ ## @end tex ## @end iftex ## @ifnottex ## ## @example ## Ms = ||S(jw)|| ## inf ## @end example ## ## @end ifnottex ## If no output arguments are given, the critical distance 1/Ms ## is plotted on a Nyquist diagram. ## In contrast to gain and phase margin as computed by function ## @command{margin}, the sensitivity @var{Ms} is a more robust ## criterion to assess the stability of a feedback system. ## ## @strong{Inputs} ## @table @var ## @item L ## Open loop transfer function. ## @var{L} can be any type of @acronym{LTI} system, but it must be square. ## @item P ## Plant model. Any type of @acronym{LTI} system. ## @item C ## Controller model. Any type of @acronym{LTI} system. ## @item C1, C2, @dots{} ## If several controllers are specified, function @command{sensitivity} ## computes the sensitivity @var{Ms} for each of them in combination ## with plant @var{P}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item Ms ## Sensitivity margin @var{Ms} as defined in [1]. ## Scalar value. ## If several controllers are specified, @var{Ms} becomes ## a row vector with as many entries as controllers. ## @item ws ## The frequency [rad/s] corresponding to the sensitivity peak. ## Scalar value. ## If several controllers are specified, @var{ws} becomes ## a row vector with as many entries as controllers. ## @end table ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB13DD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @strong{References}@* ## [1] Astr@"om, K. and H@"agglund, T. (1995) ## PID Controllers: ## Theory, Design and Tuning, ## Second Edition. ## Instrument Society of America. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: August 2012 ## Version: 0.2 function [ret, ws] = sensitivity (G, varargin) if (nargin == 0) print_usage (); elseif (nargin == 1) # L := G L = G; I = eye (size (L)); S = feedback (I, L); # S = inv (I + L), S = feedback (I, L*-I, "+") [Ms, ws] = norm (S, inf); else # P := G, C := varargin L = cellfun (@(C) G*C, varargin, "uniformoutput", false); I = cellfun (@(L) eye (size (L)), L, "uniformoutput", false); S = cellfun (@feedback, I, L, "uniformoutput", false); [Ms, ws] = cellfun (@(S) norm (S, inf), S); endif if (nargout == 0) ## TODO: don't show entire Nyquist curve if critical distance becomes small on plot if (length (Ms) > 1) error ("sensitivity: plotting only works for a single controller"); endif if (! iscell (L)) L = {L}; endif if (! issiso (L{1})) error ("sensitivity: Nyquist plot requires SISO systems"); endif [H, w] = __frequency_response__ ("sensitivity", L); H = H{1}(:); re = real (H); im = imag (H); Hs = freqresp (L{1}, ws); res = real (Hs); ims = imag (Hs); plot (re, im, "b", [-1, res], [0, ims], "r") axis ("equal") xlim (__axis_margin__ (xlim)) ylim (__axis_margin__ (ylim)) grid ("on") title (sprintf ("Sensitivity Ms = %g (at %g rad/s)", Ms, ws)) xlabel ("Real Axis") ylabel ("Imaginary Axis") else ret = Ms; endif endfunction control-4.1.2/inst/PaxHeaders/__adjust_labels__.m0000644000000000000000000000007415012430645017024 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__adjust_labels__.m0000644000175000017500000000313515012430645020215 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Check whether a cell contains the required number of strings. ## Used by set and __set__. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function name = __adjust_labels__ (name, req_len) if (iscell (name)) name = reshape (name, [], 1); else # catch the siso case, name = {name}; # e.g. sys = set (sys, "inname", "u_1") endif if (! iscellstr (name)) error ("lti: set: require string or cell of strings"); endif if (numel (name) != req_len) if (numel (name) == 1 && req_len > 1) if (isempty (name{1})) # delete names quickly name = repmat ({""}, req_len, 1); else name = strseq (name{1}, 1:req_len); endif else error ("lti: set: cell must contain %d strings", req_len); endif endif endfunction control-4.1.2/inst/PaxHeaders/ltimodels.m0000644000000000000000000000007415012430645015410 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/ltimodels.m0000644000175000017500000003616615012430645016613 0ustar00lilgelilge00000000000000## Copyright (C) 2009 Luca Favatella ## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} test ltimodels ## @deftypefnx {Function File} ltimodels ## @deftypefnx {Function File} ltimodels (@var{systype}) ## Test suite and help for @acronym{LTI} models. ## ## Some test are based on the @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT library}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 0.2 function ltimodels (systype = "general") %if (nargin > 1) print_usage (); %endif ## TODO: write documentation if (! ischar (systype)) error ("ltimodels: argument must be a string"); endif systype = lower (systype); switch (systype) case "ss" str = {"State Space (SS) Models"... "-----------------------"... ""}; case "tf" str = {"Transfer Function (TF) Models"... "-----------------------------"... ""}; otherwise # general str = {"Linear Time Invariant (LTI) Models"... "----------------------------------"... ""}; endswitch disp (""); disp (char (str)); endfunction ## ============================================================================== ## LTI Tests ## ============================================================================== ## isct, isdt %!shared ltisys %! ltisys = tf (12); %!assert (ltisys.ts, 0); %!assert (isstaticgain (ltisys)); %!assert (isct (ltisys)); %!assert (! isdt (ltisys)); %!shared ltisys %! ltisys = ss (17); %!assert (ltisys.ts, 0); %!assert (isstaticgain (ltisys)); %!assert (! isdt (ltisys)); %!assert (isct (ltisys)); %!shared ltisys %! ltisys = tf ({[0 9],[0 0 10]},{2,5},2); %!assert (ltisys.ts, 2); %!assert (isstaticgain (ltisys)); %!assert (isdt (ltisys)); %!assert (! isct (ltisys)); %!shared ltisys %! ltisys = tf (1, [1 1]); %!assert (ltisys.ts, 0); %!assert (isct (ltisys)); %!assert (! isdt (ltisys)); %!shared ltisys, ts %! ts = 0.1; %! ltisys = ss (-1, 1, 1, 0, ts); %!assert (ltisys.ts, ts); %!assert (! isct (ltisys)); %!assert (isdt (ltisys)); %!shared ltisys %! ltisys = ss ([],[],[], 3); %!assert (ltisys.ts, 0); %!assert (isstaticgain (ltisys)); %!assert (isct (ltisys)); %!assert (! isdt (ltisys)); ## ============================================================================== ## TF Tests ## ============================================================================== ## ============================================================================== ## SS Tests ## ============================================================================== ## ## The following tests are based on the SLICOT (http://www.slicot.org) library. ## SLICOT needs BLAS and LAPACK libraries which are also prerequisites for ## Octave itself. In case of failing tests, it is highly recommended to use ## Netlib's reference BLAS (http://www.netlib.org/blas/) and LAPACK ## (http://www.netlib.org/lapack/) for building Octave and the control ## package. Using other libs may lead to sign changes in some entries of the ## state-space matrices. ## In general, these sign changes are not 'wrong' and can be regarded as the ## result of state transformations. Such state transformations (but not ## input/output transformations) have influence on the input-output ## behaviour of the system. ## ## For more details, please refer to the discusison for bug #45008 at ## https://savannah.gnu.org/bugs/?45008 ## ## staircase (SLICOT AB01OD) %!shared Ac, Bc, Ace, Bce %! A = [ 17.0 24.0 1.0 8.0 15.0 %! 23.0 5.0 7.0 14.0 16.0 %! 4.0 6.0 13.0 20.0 22.0 %! 10.0 12.0 19.0 21.0 3.0 %! 11.0 18.0 25.0 2.0 9.0 ]; %! %! B = [ -1.0 -4.0 %! 4.0 9.0 %! -9.0 -16.0 %! 16.0 25.0 %! -25.0 -36.0 ]; %! %! tol = 0; %! %! A = A.'; # There's a little mistake in the example %! # program of routine AB01OD in SLICOT 5.0 %! %! [Ac, Bc, U, ncont] = __sl_ab01od__ (A, B, tol); %! %! Ace = [ 12.8848 3.2345 11.8211 3.3758 -0.8982 %! 4.4741 -12.5544 5.3509 5.9403 1.4360 %! 14.4576 7.6855 23.1452 26.3872 -29.9557 %! 0.0000 1.4805 27.4668 22.6564 -0.0072 %! 0.0000 0.0000 -30.4822 0.6745 18.8680 ]; %! %! Bce = [ 31.1199 47.6865 %! 3.2480 0.0000 %! 0.0000 0.0000 %! 0.0000 0.0000 %! 0.0000 0.0000 ]; %! %!assert <45008> (Ac, Ace, 1e-4); %!assert (Bc, Bce, 1e-4); ## controllability staircase form of descriptor state-space models (SLICOT TG01HD) %!shared ac, ec, bc, cc, q, z, ncont, ac_e, ec_e, bc_e, cc_e, q_e, z_e, ncont_e %! %! a = [ 2 0 2 0 -1 3 1 %! 0 1 0 0 1 0 0 %! 0 0 0 1 0 0 1 %! 0 0 2 0 -1 3 1 %! 0 0 0 1 0 0 1 %! 0 1 0 0 1 0 0 %! 0 0 0 1 0 0 1 ]; %! %! e = [ 0 0 1 0 0 0 0 %! 0 0 0 0 0 1 0 %! 0 0 0 0 0 0 1 %! 0 0 0 0 0 0 1 %! 0 0 0 1 0 0 0 %! 0 0 1 0 -1 0 0 %! 1 3 0 2 0 0 0 ]; %! %! b = [ 2 1 0 %! 0 0 0 %! 0 0 0 %! 0 0 0 %! 0 0 0 %! 0 0 0 %! 1 2 3 ]; %! %! c = [ 1 0 0 1 0 0 1 %! 0 -1 1 0 -1 1 0 ]; %! %! tol = 0; %! %! [ac, ec, bc, cc, q, z, ncont] = __sl_tg01hd__ (a, e, b, c, tol); %! %! ncont_e = 3; %! %! ac_e = [ 0.0000 0.0000 0.0000 0.0000 -1.2627 0.4334 0.4666 %! 0.0000 2.0000 0.0000 -3.7417 -0.8520 0.2924 -0.4342 %! 0.0000 0.0000 1.7862 0.3780 -0.2651 -0.7723 0.0000 %! 0.0000 0.0000 0.0000 3.7417 0.8520 -0.2924 0.4342 %! 0.0000 0.0000 0.0000 0.0000 -1.5540 0.5334 0.5742 %! 0.0000 0.0000 0.0000 0.0000 -0.6533 0.2242 0.2414 %! 0.0000 0.0000 0.0000 0.0000 -0.5892 0.2022 0.2177 ]; %! %! ec_e = [ -1.8325 1.0000 2.3752 0.0000 -0.8214 0.2819 1.8016 %! 0.4887 0.0000 0.3770 -0.5345 0.1874 0.5461 0.0000 %! -0.1728 0.0000 -0.1333 -1.1339 0.1325 0.3861 0.0000 %! 0.0000 0.0000 0.0000 0.0000 0.8520 -0.2924 0.4342 %! 0.0000 0.0000 0.0000 0.0000 -1.0260 -0.1496 0.0000 %! 0.0000 0.0000 0.0000 0.0000 0.0000 1.1937 0.0000 %! 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 ]; %! %! bc_e = [ 1.0000 2.0000 3.0000 %! 2.0000 1.0000 0.0000 %! 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 ]; %! %! cc_e = [ 0.0000 1.0000 0.0000 0.0000 -1.2627 0.4334 0.4666 %! 0.3665 0.0000 -0.9803 -1.6036 0.1874 0.5461 0.0000 ]; %! %! q_e = [ 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.7071 0.0000 0.2740 -0.6519 0.0000 %! 0.0000 0.0000 0.0000 0.0000 0.8304 0.3491 -0.4342 %! 0.0000 0.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 0.0000 0.4003 0.1683 0.9008 %! 0.0000 0.0000 0.7071 0.0000 -0.2740 0.6519 0.0000 %! 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 ]; %! %! z_e = [ 0.0000 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 %! -0.6108 0.0000 0.7917 0.0000 0.0000 0.0000 0.0000 %! 0.4887 0.0000 0.3770 -0.5345 0.1874 0.5461 0.0000 %! 0.0000 0.0000 0.0000 0.0000 -0.4107 0.1410 0.9008 %! 0.6108 0.0000 0.4713 0.2673 -0.1874 -0.5461 0.0000 %! -0.1222 0.0000 -0.0943 -0.8018 -0.1874 -0.5461 0.0000 %! 0.0000 0.0000 0.0000 0.0000 -0.8520 0.2924 -0.4342 ]; %! %!assert <45008> (ac, ac_e, 1e-4); %!assert <45008> (ec, ec_e, 1e-4); %!assert <45008> (bc, bc_e, 1e-4); %!assert <45008> (cc, cc_e, 1e-4); %!assert <45008> (q, q_e, 1e-4); %!assert <45008> (z, z_e, 1e-4); %!assert (ncont, ncont_e); ## observability staircase form of descriptor state-space models (SLICOT TG01ID) %!shared ao, eo, bo, co, q, z, nobsv, ao_e, eo_e, bo_e, co_e, q_e, z_e, nobsv_e %! %! a = [ 2 0 0 0 0 0 0 %! 0 1 0 0 0 1 0 %! 2 0 0 2 0 0 0 %! 0 0 1 0 1 0 1 %! -1 1 0 -1 0 1 0 %! 3 0 0 3 0 0 0 %! 1 0 1 1 1 0 1 ]; %! %! e = [ 0 0 0 0 0 0 1 %! 0 0 0 0 0 0 3 %! 1 0 0 0 0 1 0 %! 0 0 0 0 1 0 2 %! 0 0 0 0 0 -1 0 %! 0 1 0 0 0 0 0 %! 0 0 1 1 0 0 0 ]; %! %! b = [ 1 0 %! 0 -1 %! 0 1 %! 1 0 %! 0 -1 %! 0 1 %! 1 0 ]; %! %! c = [ 2 0 0 0 0 0 1 %! 1 0 0 0 0 0 2 %! 0 0 0 0 0 0 3 ]; %! %! tol = 0; %! %! [ao, eo, bo, co, q, z, nobsv] = __sl_tg01id__ (a, e, b, c, tol); %! %! nobsv_e = 3; %! %! ao_e = [ 0.2177 0.2414 0.5742 0.4342 0.0000 -0.4342 0.4666 %! 0.2022 0.2242 0.5334 -0.2924 -0.7723 0.2924 0.4334 %! -0.5892 -0.6533 -1.5540 0.8520 -0.2651 -0.8520 -1.2627 %! 0.0000 0.0000 0.0000 3.7417 0.3780 -3.7417 0.0000 %! 0.0000 0.0000 0.0000 0.0000 1.7862 0.0000 0.0000 %! 0.0000 0.0000 0.0000 0.0000 0.0000 2.0000 0.0000 %! 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 ]; %! %! eo_e = [ 1.0000 0.0000 0.0000 0.4342 0.0000 0.0000 1.8016 %! 0.0000 1.1937 -0.1496 -0.2924 0.3861 0.5461 0.2819 %! 0.0000 0.0000 -1.0260 0.8520 0.1325 0.1874 -0.8214 %! 0.0000 0.0000 0.0000 0.0000 -1.1339 -0.5345 0.0000 %! 0.0000 0.0000 0.0000 0.0000 -0.1333 0.3770 2.3752 %! 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 %! 0.0000 0.0000 0.0000 0.0000 -0.1728 0.4887 -1.8325 ]; %! %! bo_e = [ 0.4666 0.0000 %! 0.4334 0.5461 %! -1.2627 0.1874 %! 0.0000 -1.6036 %! 0.0000 -0.9803 %! 1.0000 0.0000 %! 0.0000 0.3665 ]; %! %! co_e = [ 0.0000 0.0000 0.0000 0.0000 0.0000 2.0000 1.0000 %! 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 2.0000 %! 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 3.0000 ]; %! %! q_e = [ 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 %! 0.0000 0.0000 0.0000 0.0000 0.7917 0.0000 -0.6108 %! 0.0000 0.5461 0.1874 -0.5345 0.3770 0.0000 0.4887 %! 0.9008 0.1410 -0.4107 0.0000 0.0000 0.0000 0.0000 %! 0.0000 -0.5461 -0.1874 0.2673 0.4713 0.0000 0.6108 %! 0.0000 -0.5461 -0.1874 -0.8018 -0.0943 0.0000 -0.1222 %! -0.4342 0.2924 -0.8520 0.0000 0.0000 0.0000 0.0000 ]; %! %! z_e = [ 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 %! 0.0000 -0.6519 0.2740 0.0000 0.7071 0.0000 0.0000 %! -0.4342 0.3491 0.8304 0.0000 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 %! 0.9008 0.1683 0.4003 0.0000 0.0000 0.0000 0.0000 %! 0.0000 0.6519 -0.2740 0.0000 0.7071 0.0000 0.0000 %! 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 1.0000 ]; %! %!assert <45008> (ao, ao_e, 1e-4); %!assert <45008> (eo, eo_e, 1e-4); %!assert <45008> (bo, bo_e, 1e-4); %!assert <45008> (co, co_e, 1e-4); %!assert <45008> (q, q_e, 1e-4); %!assert <45008> (z, z_e, 1e-4); %!assert (nobsv, nobsv_e); ## ss2tf conversion by Slicot TB04BD ## Test provided by Slicot %!shared NUM, DEN, NUMe, DENe %! A = [ -1.0 0.0 0.0 %! 0.0 -2.0 0.0 %! 0.0 0.0 -3.0 ]; %! %! B = [ 0.0 1.0 -1.0 %! 1.0 1.0 0.0 ].'; %! %! C = [ 0.0 1.0 1.0 %! 1.0 1.0 1.0 ]; %! %! D = [ 1.0 0.0 %! 0.0 1.0 ]; %! %! [NUM, DEN] = tfdata (ss (A, B, C, D)); %! ## remove possibly existing idendical pole/zero pairs %! for i=1:2 %! for j=1:2 %! gcdij = polygcd (NUM{i,j},DEN{i,j}); %! if length (gcdij) > 1 %! NUM{i,j} = deconv (NUM{i,j}, gcdij); %! DEN{i,j} = deconv (DEN{i,j}, gcdij); %! endif %! endfor %! endfor %! %! NUMe = {[1, 5, 7], [0 1]; [0 0 1], [1, 5, 5]}; %! %! DENe = {[1, 5, 6], [1, 2]; [1, 5, 6], [1, 3, 2]}; %! %!assert (NUM, NUMe, 1e-4); %!assert (DEN, DENe, 1e-4); ## ss2tf conversion by Slicot TB04BD ## Trivial test %!shared NUM, DEN, NUMe, DENe %! A = [ 0 ]; %! %! B = [ 1 ]; %! %! C = [ 1 ]; %! %! D = [ 0 ]; %! %! [NUM, DEN] = tfdata (ss (A, B, C, D)); %! %! NUMe = {[0, 1]}; %! %! DENe = {[1, 0]}; %! %!assert (NUM, NUMe, 1e-4); %!assert (DEN, DENe, 1e-4); ## transfer function to state-space conversion ## test from SLICOT TD04AD %!shared Mo, Me %! INDEX = [ 3 3 ]; %! %! DCOEFF = [ 1.0 6.0 11.0 6.0 %! 1.0 6.0 11.0 6.0 ]; %! %! UCOEFF = zeros (2, 2, 4); %! %! u11 = [ 1.0 6.0 12.0 7.0 ]; %! u12 = [ 0.0 1.0 4.0 3.0 ]; %! u21 = [ 0.0 0.0 1.0 1.0 ]; %! u22 = [ 1.0 8.0 20.0 15.0 ]; %! %! UCOEFF(1,1,:) = u11; %! UCOEFF(1,2,:) = u12; %! UCOEFF(2,1,:) = u21; %! UCOEFF(2,2,:) = u22; %! %! [Ao, Bo, Co, Do] = __sl_td04ad__ (UCOEFF, DCOEFF, INDEX, 0); %! %! Ae = [ 0.5000 -0.8028 0.9387 %! 4.4047 -2.3380 2.5076 %! -5.5541 1.6872 -4.1620 ]; %! %! Be = [ -0.2000 -1.2500 %! 0.0000 -0.6097 %! 0.0000 2.2217 ]; %! %! Ce = [ 0.0000 -0.8679 0.2119 %! 0.0000 0.0000 0.9002 ]; %! %! De = [ 1.0000 0.0000 %! 0.0000 1.0000 ]; %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [Ae, Be; Ce, De]; %! %!assert (Mo, Me, 1e-4); control-4.1.2/inst/PaxHeaders/btamodred.m0000644000000000000000000000007415012430645015355 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/btamodred.m0000644000175000017500000002563615012430645016560 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{Gr}, @var{info}] =} btamodred (@var{G}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} btamodred (@var{G}, @var{nr}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} btamodred (@var{G}, @var{opt}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} btamodred (@var{G}, @var{nr}, @var{opt}, @dots{}) ## ## Model order reduction by frequency weighted Balanced Truncation Approximation (BTA) method. ## The aim of model reduction is to find an @acronym{LTI} system @var{Gr} of order ## @var{nr} (nr < n) such that the input-output behaviour of @var{Gr} ## approximates the one from original system @var{G}. ## ## BTA is an absolute error method which tries to minimize ## @iftex ## @tex ## $$ || G - G_r ||_{\\infty} = \\min $$ ## $$ || V \\ (G - G_r) \\ W ||_{\\infty} = \\min $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## ||G-Gr|| = min ## inf ## ## ||V (G-Gr) W|| = min ## inf ## @end example ## @end ifnottex ## where @var{V} and @var{W} denote output and input weightings. ## ## ## @strong{Inputs} ## @table @var ## @item G ## @acronym{LTI} model to be reduced. ## @item nr ## The desired order of the resulting reduced order system @var{Gr}. ## If not specified, @var{nr} is chosen automatically according ## to the description of key @var{'order'}. ## @item @dots{} ## Optional pairs of keys and values. @code{"key1", value1, "key2", value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item Gr ## Reduced order state-space model. ## @item info ## Struct containing additional information. ## @table @var ## @item info.n ## The order of the original system @var{G}. ## @item info.ns ## The order of the @var{alpha}-stable subsystem of the original system @var{G}. ## @item info.hsv ## The Hankel singular values of the @var{alpha}-stable part of ## the original system @var{G}, ordered decreasingly. ## @item info.nu ## The order of the @var{alpha}-unstable subsystem of both the original ## system @var{G} and the reduced-order system @var{Gr}. ## @item info.nr ## The order of the obtained reduced order system @var{Gr}. ## @end table ## @end table ## ## ## @strong{Option Keys and Values} ## @table @var ## @item 'order', 'nr' ## The desired order of the resulting reduced order system @var{Gr}. ## If not specified, @var{nr} is chosen automatically such that states with ## Hankel singular values @var{info.hsv} > @var{tol1} are retained. ## ## @item 'left', 'output' ## @acronym{LTI} model of the left/output frequency weighting @var{V}. ## Default value is an identity matrix. ## ## @item 'right', 'input' ## @acronym{LTI} model of the right/input frequency weighting @var{W}. ## Default value is an identity matrix. ## ## @item 'method' ## Approximation method for the L-infinity norm to be used as follows: ## @table @var ## @item 'sr', 'b' ## Use the square-root Balance & Truncate method. ## @item 'bfsr', 'f' ## Use the balancing-free square-root Balance & Truncate method. Default method. ## @end table ## ## @item 'alpha' ## Specifies the ALPHA-stability boundary for the eigenvalues ## of the state dynamics matrix @var{G.A}. For a continuous-time ## system, ALPHA <= 0 is the boundary value for ## the real parts of eigenvalues, while for a discrete-time ## system, 0 <= ALPHA <= 1 represents the ## boundary value for the moduli of eigenvalues. ## The ALPHA-stability domain does not include the boundary. ## Default value is 0 for continuous-time systems and ## 1 for discrete-time systems. ## ## @item 'tol1' ## If @var{'order'} is not specified, @var{tol1} contains the tolerance for ## determining the order of the reduced model. ## For model reduction, the recommended value of @var{tol1} is ## c*info.hsv(1), where c lies in the interval [0.00001, 0.001]. ## Default value is info.ns*eps*info.hsv(1). ## If @var{'order'} is specified, the value of @var{tol1} is ignored. ## ## @item 'tol2' ## The tolerance for determining the order of a minimal ## realization of the ALPHA-stable part of the given ## model. TOL2 <= TOL1. ## If not specified, ns*eps*info.hsv(1) is chosen. ## ## @item 'gram-ctrb' ## Specifies the choice of frequency-weighted controllability ## Grammian as follows: ## @table @var ## @item 'standard' ## Choice corresponding to a combination method [4] ## of the approaches of Enns [1] and Lin-Chiu [2,3]. Default method. ## @item 'enhanced' ## Choice corresponding to the stability enhanced ## modified combination method of [4]. ## @end table ## ## @item 'gram-obsv' ## Specifies the choice of frequency-weighted observability ## Grammian as follows: ## @table @var ## @item 'standard' ## Choice corresponding to a combination method [4] ## of the approaches of Enns [1] and Lin-Chiu [2,3]. Default method. ## @item 'enhanced' ## Choice corresponding to the stability enhanced ## modified combination method of [4]. ## @end table ## ## @item 'alpha-ctrb' ## Combination method parameter for defining the ## frequency-weighted controllability Grammian. ## abs(alphac) <= 1. ## If alphac = 0, the choice of ## Grammian corresponds to the method of Enns [1], while if ## alphac = 1, the choice of Grammian corresponds ## to the method of Lin and Chiu [2,3]. ## Default value is 0. ## ## @item 'alpha-obsv' ## Combination method parameter for defining the ## frequency-weighted observability Grammian. ## abs(alphao) <= 1. ## If alphao = 0, the choice of ## Grammian corresponds to the method of Enns [1], while if ## alphao = 1, the choice of Grammian corresponds ## to the method of Lin and Chiu [2,3]. ## Default value is 0. ## ## @item 'equil', 'scale' ## Boolean indicating whether equilibration (scaling) should be ## performed on system @var{G} prior to order reduction. ## This is done by state transformations. ## Default value is true if @code{G.scaled == false} and ## false if @code{G.scaled == true}. ## Note that for @acronym{MIMO} models, proper scaling of both inputs and outputs ## is of utmost importance. The input and output scaling can @strong{not} ## be done by the equilibration option or the @command{prescale} function ## because these functions perform state transformations only. ## Furthermore, signals should not be scaled simply to a certain range. ## For all inputs (or outputs), a certain change should be of the same ## importance for the model. ## @end table ## ## ## Approximation Properties: ## @itemize @bullet ## @item ## Guaranteed stability of reduced models ## @item ## Lower guaranteed error bound ## @item ## Guaranteed a priori error bound ## @iftex ## @tex ## $$ \\sigma_{r+1} \\leq || (G-G_r) ||_{\\infty} \\leq 2 \\sum_{j=r+1}^{n} \\sigma_j $$ ## @end tex ## @end iftex ## @end itemize ## ## ## @strong{References}@* ## [1] Enns, D. ## @cite{Model reduction with balanced realizations: An error bound ## and a frequency weighted generalization}. ## Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. ## ## [2] Lin, C.-A. and Chiu, T.-Y. ## @cite{Model reduction via frequency-weighted balanced realization}. ## Control Theory and Advanced Technology, vol. 8, ## pp. 341-351, 1992. ## ## [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. ## @cite{New results on frequency weighted balanced reduction ## technique}. ## Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. ## ## [4] Varga, A. and Anderson, B.D.O. ## @cite{Square-root balancing-free methods for the frequency-weighted ## balancing related model reduction}. ## (report in preparation) ## ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB09ID}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2011 ## Version: 0.1 function [Gr, info] = btamodred (varargin) [Gr, info] = __modred_ab09id__ ("bta", varargin{:}); endfunction %!shared Mo, Me, Info, HSVe %! A = [ -26.4000, 6.4023, 4.3868; %! 32.0000, 0, 0; %! 0, 8.0000, 0 ]; %! %! B = [ 16 %! 0 %! 0 ]; %! %! C = [ 9.2994 1.1624 0.1090 ]; %! %! D = [ 0 ]; %! %! G = ss (A, B, C, D); % "scaled", false %! %! AV = [ -1.0000, 0, 4.0000, -9.2994, -1.1624, -0.1090; %! 0, 2.0000, 0, -9.2994, -1.1624, -0.1090; %! 0, 0, -3.0000, -9.2994, -1.1624, -0.1090; %! 16.0000, 16.0000, 16.0000, -26.4000, 6.4023, 4.3868; %! 0, 0, 0, 32.0000, 0, 0; %! 0, 0, 0, 0, 8.0000, 0 ]; %! %! BV = [ 1 %! 1 %! 1 %! 0 %! 0 %! 0 ]; %! %! CV = [ 1 1 1 0 0 0 ]; %! %! DV = [ 0 ]; %! %! V = ss (AV, BV, CV, DV); %! %! [Gr, Info] = btamodred (G, 2, "left", V); %! %! Ae = [ 9.1900 0.0000 %! 0.0000 -34.5297 ]; %! %! Be = [ -11.9593 %! -16.9329 ]; %! %! Ce = [ -2.8955 -6.9152 ]; %! %! De = [ 0.0000 ]; %! %! # Since btamodred approximates the input/output behavior only %! # input/output behavior is tested using n first Markov parameters. %! # The state space representaton might have different signs %! # of the states. %! # By multiplying the matrices for the Markov parameters, numeric errors %! # would propagate, therefor the accuracy of the results are limited to %! # the accuracy of the given expected results %! %! [Ao,Bo,Co,Do] = ssdata (Gr); %! Ao = round (Ao*1e4)/1e4; %! Bo = round (Bo*1e4)/1e4; %! Co = round (Co*1e4)/1e4; %! Do = round (Do*1e4)/1e4; %! %! n = size(Ao,1); %! m = size(Bo,2); %! p = size(Co,1); %! Mo = zeros (p,(n+1)*m); %! Me = zeros (p,(n+1)*m); %! Mo(:,1:m) = Do; %! Me(:,1:m) = De; %! %! Aoi = eye (n,n); %! Aei = eye (n,n); %! for i = 1:n %! Mo(:,(i-1)*m+1:i*m) = Co*Aoi*Bo; %! Me(:,(i-1)*m+1:i*m) = Ce*Aei*Be; %! Aoi = Aoi*Ao; %! Aei = Aei*Ae; %! endfor %! %! HSVe = [ 3.8253 0.2005 ].'; %! %!assert (Mo, Me, 1e-4); %!assert (Info.hsv, HSVe, 1e-4); control-4.1.2/inst/PaxHeaders/ctrbf.m0000644000000000000000000000007415012430645014514 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/ctrbf.m0000644000175000017500000000713715012430645015713 0ustar00lilgelilge00000000000000## Copyright (C) 2010 Benjamin Fernandez ## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{sysbar}, @var{T}, @var{K}] =} ctrbf (@var{sys}) ## @deftypefnx{Function File} {[@var{sysbar}, @var{T}, @var{K}] =} ctrbf (@var{sys}, @var{tol}) ## @deftypefnx{Function File} {[@var{Abar}, @var{Bbar}, @var{Cbar}, @var{T}, @var{K}] =} ctrbf (@var{A}, @var{B}, @var{C}) ## @deftypefnx{Function File} {[@var{Abar}, @var{Bbar}, @var{Cbar}, @var{T}, @var{K}] =} ctrbf (@var{A}, @var{B}, @var{C}, @var{TOL}) ## If Co=ctrb(A,B) has rank r <= n = SIZE(A,1), then there is a ## similarity transformation Tc such that Tc = [t1 t2] where t1 ## is the controllable subspace and t2 is orthogonal to t1 ## ## @example ## @group ## Abar = Tc \\ A * Tc , Bbar = Tc \\ B , Cbar = C * Tc ## @end group ## @end example ## ## and the transformed system has the form ## ## @example ## @group ## | Ac A12| | Bc | ## Abar = |----------|, Bbar = | ---|, Cbar = [Cc | Cnc]. ## | 0 Anc| | 0 | ## @end group ## @end example ## ## where (Ac,Bc) is controllable, and Cc(sI-Ac)^(-1)Bc = C(sI-A)^(-1)B. ## and the system is stabilizable if Anc has no eigenvalues in ## the right half plane. The last output K is a vector of length n ## containing the number of controllable states. ## @end deftypefn ## Author: Benjamin Fernandez ## Created: 2010-04-30 ## Version: 0.1 function [ac, bc, cc, z, ncont] = ctrbf (a, b = [], c, tol = []) if (nargin < 1 || nargin > 4) print_usage (); endif islti = isa (a, "lti"); if (islti) if (nargin > 2) print_usage (); endif sys = a; tol = b; [a, b, c] = ssdata (sys); else if (nargin < 3) print_usage (); endif sys = ss (a, b, c); [a, b, c] = ssdata (sys); endif if (isempty (tol)) tol = 0; # default tolerance elseif (! is_real_scalar (tol)) error ("ctrbf: tol must be a real scalar"); endif [ac, bc, cc, z, ncont] = __sl_tb01ud__ (a, b, c, tol); if (islti) ac = set (sys, "a", ac, "b", bc, "c", cc, "scaled", false); bc = z; cc = ncont; endif endfunction %!shared Ao, Bo, Co, Zo, Ae, Be, Ce, Ze, NCONT %! A = [ -1.0 0.0 0.0 %! -2.0 -2.0 -2.0 %! -1.0 0.0 -3.0 ]; %! %! B = [ 1.0 0.0 0.0 %! 0.0 2.0 1.0 ].'; %! %! C = [ 0.0 2.0 1.0 %! 1.0 0.0 0.0 ]; %! %! [Ao, Bo, Co, Zo, NCONT] = ctrbf (A, B, C); %! %! Ae = [ -3.0000 2.2361 %! 0.0000 -1.0000 ]; %! %! Be = [ 0.0000 -2.2361 %! 1.0000 0.0000 ]; %! %! Ce = [ -2.2361 0.0000 %! 0.0000 1.0000 ]; %! %! Ze = [ 0.0000 1.0000 0.0000 %! -0.8944 0.0000 -0.4472 %! -0.4472 0.0000 0.8944 ]; %! %!assert (Ao(1:NCONT, 1:NCONT), Ae, 1e-4); %!assert (Bo(1:NCONT, :), Be, 1e-4); %!assert (Co(:, 1:NCONT), Ce, 1e-4); %!assert (Zo, Ze, 1e-4); control-4.1.2/inst/PaxHeaders/cfconred.m0000644000000000000000000000007415012430645015177 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/cfconred.m0000644000175000017500000002735515012430645016402 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{Kr}, @var{info}] =} cfconred (@var{G}, @var{F}, @var{L}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} cfconred (@var{G}, @var{F}, @var{L}, @var{ncr}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} cfconred (@var{G}, @var{F}, @var{L}, @var{opt}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} cfconred (@var{G}, @var{F}, @var{L}, @var{ncr}, @var{opt}, @dots{}) ## ## Reduction of state-feedback-observer based controller by coprime factorization (CF). ## Given a plant @var{G}, state feedback gain @var{F} and full observer gain @var{L}, ## determine a reduced order controller @var{Kr}. ## ## @strong{Inputs} ## @table @var ## @item G ## @acronym{LTI} model of the open-loop plant (A,B,C,D). ## It has m inputs, p outputs and n states. ## @item F ## Stabilizing state feedback matrix (m-by-n). ## @item L ## Stabilizing observer gain matrix (n-by-p). ## @item ncr ## The desired order of the resulting reduced order controller @var{Kr}. ## If not specified, @var{ncr} is chosen automatically according ## to the description of key @var{'order'}. ## @item @dots{} ## Optional pairs of keys and values. @code{"key1", value1, "key2", value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item Kr ## State-space model of reduced order controller. ## @item info ## Struct containing additional information. ## @table @var ## @item info.hsv ## The Hankel singular values of the extended system?!?. ## The @var{n} Hankel singular values are ordered decreasingly. ## @item info.ncr ## The order of the obtained reduced order controller @var{Kr}. ## @end table ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'order', 'ncr' ## The desired order of the resulting reduced order controller @var{Kr}. ## If not specified, @var{ncr} is chosen automatically such that states with ## Hankel singular values @var{info.hsv} > @var{tol1} are retained. ## ## @item 'method' ## Order reduction approach to be used as follows: ## @table @var ## @item 'sr-bta', 'b' ## Use the square-root Balance & Truncate method. ## @item 'bfsr-bta', 'f' ## Use the balancing-free square-root Balance & Truncate method. Default method. ## @item 'sr-spa', 's' ## Use the square-root Singular Perturbation Approximation method. ## @item 'bfsr-spa', 'p' ## Use the balancing-free square-root Singular Perturbation Approximation method. ## @end table ## ## @item 'cf' ## Specifies whether left or right coprime factorization is ## to be used as follows: ## @table @var ## @item 'left', 'l' ## Use left coprime factorization. Default method. ## @item 'right', 'r' ## Use right coprime factorization. ## @end table ## ## @item 'feedback' ## Specifies whether @var{F} and @var{L} are fed back positively or negatively: ## @table @var ## @item '+' ## A+BK and A+LC are both Hurwitz matrices. ## @item '-' ## A-BK and A-LC are both Hurwitz matrices. Default value. ## @end table ## ## @item 'tol1' ## If @var{'order'} is not specified, @var{tol1} contains the tolerance for ## determining the order of the reduced system. ## For model reduction, the recommended value of @var{tol1} is ## c*info.hsv(1), where c lies in the interval [0.00001, 0.001]. ## Default value is n*eps*info.hsv(1). ## If @var{'order'} is specified, the value of @var{tol1} is ignored. ## ## @item 'tol2' ## The tolerance for determining the order of a minimal ## realization of the coprime factorization controller. ## TOL2 <= TOL1. ## If not specified, n*eps*info.hsv(1) is chosen. ## ## @item 'equil', 'scale' ## Boolean indicating whether equilibration (scaling) should be ## performed on system @var{G} prior to order reduction. ## Default value is true if @code{G.scaled == false} and ## false if @code{G.scaled == true}. ## Note that for @acronym{MIMO} models, proper scaling of both inputs and outputs ## is of utmost importance. The input and output scaling can @strong{not} ## be done by the equilibration option or the @command{prescale} function ## because these functions perform state transformations only. ## Furthermore, signals should not be scaled simply to a certain range. ## For all inputs (or outputs), a certain change should be of the same ## importance for the model. ## @end table ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB16BD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: December 2011 ## Version: 0.1 function [Kr, info] = cfconred (G, F, L, varargin) if (nargin < 3) print_usage (); endif if (! isa (G, "lti")) error ("cfconred: first argument must be an LTI system"); endif if (! is_real_matrix (F)) error ("cfconred: second argument must be a real matrix"); endif if (! is_real_matrix (L)) error ("cfconred: third argument must be a real matrix"); endif if (nargin > 3) # cfconred (G, F, L, ...) if (is_real_scalar (varargin{1})) # cfconred (G, F, L, nr) varargin = horzcat (varargin(2:end), {"order"}, varargin(1)); endif if (isstruct (varargin{1})) # cfconred (G, F, L, opt, ...), cfconred (G, F, L, nr, opt, ...) varargin = horzcat (__opt2cell__ (varargin{1}), varargin(2:end)); endif ## order placed at the end such that nr from cfconred (G, F, L, nr, ...) ## and cfconred (G, F, L, nr, opt, ...) overrides possible nr's from ## key/value-pairs and inside opt struct (later keys override former keys, ## nr > key/value > opt) endif nkv = numel (varargin); # number of keys and values if (rem (nkv, 2)) error ("cfconred: keys and values must come in pairs"); endif [a, b, c, d, tsam, scaled] = ssdata (G); [p, m] = size (G); n = rows (a); [mf, nf] = size (F); [nl, pl] = size (L); dt = isdt (G); jobd = any (d(:)); if (mf != m || nf != n) error ("cfconred: dimensions of state-feedback matrix (%dx%d) and plant (%dx%d, %d states) don't match", ... mf, nf, p, m, n); endif if (nl != n || pl != p) error ("cfconred: dimensions of observer matrix (%dx%d) and plant (%dx%d, %d states) don't match", ... nl, pl, p, m, n); endif ## default arguments tol1 = 0.0; tol2 = 0.0; jobcf = 0; jobmr = 2; # balancing-free BTA equil = scaled; # equil: 0 means "S", 1 means "N" ordsel = 1; ncr = 0; negfb = true; # A-BK, A-LC Hurwitz ## handle keys and values for k = 1 : 2 : nkv key = lower (varargin{k}); val = varargin{k+1}; switch (key) case {"order", "ncr", "nr"} [ncr, ordsel] = __modred_check_order__ (val, n); case "tol1" tol1 = __modred_check_tol__ (val, "tol1"); case "tol2" tol2 = __modred_check_tol__ (val, "tol2"); case "cf" switch (lower (val(1))) case "l" jobcf = 0; case "r" jobcf = 1; otherwise error ("cfconred: '%s' is an invalid coprime factorization", val); endswitch case "method" # approximation method switch (tolower (val)) case {"sr-bta", "b"} # 'B': use the square-root Balance & Truncate method jobmr = 0; case {"bfsr-bta", "f"} # 'F': use the balancing-free square-root Balance & Truncate method jobmr = 1; case {"sr-spa", "s"} # 'S': use the square-root Singular Perturbation Approximation method jobmr = 2; case {"bfsr-spa", "p"} # 'P': use the balancing-free square-root Singular Perturbation Approximation method jobmr = 3; otherwise error ("cfconred: '%s' is an invalid approach", val); endswitch case {"equil", "equilibrate", "equilibration", "scale", "scaling"} equil = __modred_check_equil__ (val); case "feedback" negfb = __conred_check_feedback_sign__ (val); otherwise warning ("cfconred: invalid property name '%s' ignored\n", key); endswitch endfor ## A - B*F --> A + B*F ; A - L*C --> A + L*C if (negfb) F = -F; L = -L; endif ## perform model order reduction [acr, bcr, ccr, dcr, ncr, hsv] = __sl_sb16bd__ (a, b, c, d, dt, equil, ncr, ordsel, jobd, jobmr, ... F, L, jobcf, tol1, tol2); ## assemble reduced order controller Kr = ss (acr, bcr, ccr, dcr, tsam); ## assemble info struct info = struct ("ncr", ncr, "hsv", hsv); endfunction %!shared Mo, Me, Info, HSVe %! A = [ 0 1.0000 0 0 0 0 0 0 %! 0 0 0 0 0 0 0 0 %! 0 0 -0.0150 0.7650 0 0 0 0 %! 0 0 -0.7650 -0.0150 0 0 0 0 %! 0 0 0 0 -0.0280 1.4100 0 0 %! 0 0 0 0 -1.4100 -0.0280 0 0 %! 0 0 0 0 0 0 -0.0400 1.850 %! 0 0 0 0 0 0 -1.8500 -0.040 ]; %! %! B = [ 0.0260 %! -0.2510 %! 0.0330 %! -0.8860 %! -4.0170 %! 0.1450 %! 3.6040 %! 0.2800 ]; %! %! C = [ -.996 -.105 0.261 .009 -.001 -.043 0.002 -0.026 ]; %! %! D = [ 0.0 ]; %! %! G = ss (A, B, C, D); % "scaled", false %! %! F = [ 4.4721e-002 6.6105e-001 4.6986e-003 3.6014e-001 1.0325e-001 -3.7541e-002 -4.2685e-002 3.2873e-002 ]; %! %! L = [ 4.1089e-001 %! 8.6846e-002 %! 3.8523e-004 %! -3.6194e-003 %! -8.8037e-003 %! 8.4205e-003 %! 1.2349e-003 %! 4.2632e-003 ]; %! %! [Kr, Info] = cfconred (G, F, L, 4, "method", "bfsr-bta", "cf", "left", "feedback", "+"); %! [Ao, Bo, Co, Do] = ssdata (Kr); %! %! Ae = [ 5.9461e-01 -7.3360e-01 1.9139e-01 -3.3685e-01 %! 5.9599e-01 -1.8394e-02 -1.0883e-01 2.0703e-02 %! 1.2253e+00 2.0431e-01 1.0090e-01 -1.4948e+00 %! -3.3005e-02 -2.4264e-02 1.3440e+00 3.5040e-03 ]; %! %! Be = [ 1.4615e-03 %! -2.0156e-02 %! 1.5922e-02 %! -5.4442e-02 ]; %! %! Ce = [ 0.353400 0.027400 0.033700 -0.032000 ]; %! %! De = [ 0.0000 ]; %! %! HSVe = [ 4.9078 4.8745 3.8455 3.7811 1.2289 1.1785 0.5176 0.1148 ].'; %! %! Mo = [Do, Co*Bo, Co*Ao*Bo, Co*Ao^2*Bo, Co*Ao^3*Bo, Co*Ao^4*Bo]; %! Me = [De, Ce*Be, Ce*Ae*Be, Ce*Ae^2*Be, Ce*Ae^3*Be, Ce*Ae^4*Be]; %! %!assert (Mo, Me, 1e-4); %!assert (Info.hsv, HSVe, 1e-4); control-4.1.2/inst/PaxHeaders/lsim.m0000644000000000000000000000007415012430645014360 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/lsim.m0000644000175000017500000003117615012430645015557 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {} lsim (@var{sys}, @var{u}) ## @deftypefnx{Function File} {} lsim (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}, @var{u}) ## @deftypefnx{Function File} {} lsim (@var{sys1}, @var{'style1'}, @dots{}, @var{sysN}, @var{'styleN'}, @var{u}) ## @deftypefnx{Function File} {} lsim (@var{sys1}, @dots{}, @var{u}, @var{t}) ## @deftypefnx{Function File} {} lsim (@var{sys1}, @dots{}, @var{u}, @var{t}, @var{x0}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} lsim (@var{sys}, @var{u}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} lsim (@var{sys}, @var{u}, @var{t}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} lsim (@var{sys}, @var{u}, @var{t}, @var{x0}) ## Simulate @acronym{LTI} model response to arbitrary inputs. If no output arguments are given, ## the system response is plotted on the screen. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. System must be proper, i.e. it must not have more zeros than poles. ## @item u ## Vector or array of input signal. Needs @code{length(t)} rows and as many columns ## as there are inputs. If @var{sys} is a single-input system, row vectors @var{u} ## of length @code{length(t)} are accepted as well. ## @item t ## Time vector. Should be evenly spaced. If @var{sys} is a continuous-time system ## and @var{t} is a real scalar, @var{sys} is discretized with sampling time ## @code{tsam = t/(rows(u)-1)}. If @var{sys} is a discrete-time system and @var{t} ## is not specified, vector @var{t} is assumed to be @code{0 : tsam : tsam*(rows(u)-1)}. ## @item x0 ## Vector of initial conditions for each state. If not specified, a zero vector is assumed. ## @item 'style' ## Line style and color, e.g. 'r' for a solid red line or '-.k' for a dash-dotted ## black line. See @command{help plot} for details. ## @end table ## ## @strong{Outputs} ## @table @var ## @item y ## Output response array. Has as many rows as time samples (length of t) ## and as many columns as outputs. ## @item t ## Time row vector. It is always evenly spaced. ## @item x ## State trajectories array. Has @code{length (t)} rows and as many columns as states. ## @end table ## ## @seealso{impulse, initial, step} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.5 function [y_r, t_r, x_r] = lsim (varargin) ## TODO: individual initial state vectors 'x0' for each system ## there would be conflicts with other arguments, ## maybe a cell {x0_1, x0_2, ..., x0_N} would be a solution? if (nargin < 2) print_usage (); endif idx = cellfun (@islogical, varargin); tmp = cellfun (@double, varargin(idx), "uniformoutput", false); varargin(idx) = tmp; sys_idx = cellfun (@isa, varargin, {"lti"}); # LTI models mat_idx = cellfun (@is_real_matrix, varargin); # matrices sty_idx = cellfun (@ischar, varargin); # string (style arguments) inv_idx = ! (sys_idx | mat_idx | sty_idx); # invalid arguments if (any (inv_idx)) warning ("lsim: arguments number %s are invalid and are being ignored\n", ... mat2str (find (inv_idx)(:).')); endif if (nnz (sys_idx) == 0) error ("lsim: require at least one LTI model"); endif if (nargout > 0 && (nnz (sys_idx) > 1 || any (sty_idx))) print_usage (); endif if (! size_equal (varargin{sys_idx})) error ("lsim: all LTI models must have equal size"); endif if (any (find (sty_idx) < find (sys_idx)(1))) warning ("lsim: strings in front of first LTI model are being ignored\n"); endif t = []; x0 = []; # default arguments switch (nnz (mat_idx)) case 0 error ("lsim: require input signal 'u'"); case 1 u = varargin{mat_idx}; case 2 [u, t] = varargin{mat_idx}; case 3 [u, t, x0] = varargin{mat_idx}; otherwise print_usage (); endswitch if (is_real_vector (u)) # allow row vectors for single-input systems u = vec (u); elseif (isempty (u)) # ! is_real_matrix (u) already tested error ("lsim: input signal 'u' must be a real-valued matrix"); endif if (! is_real_vector (t) && ! isempty (t)) error ("lsim: time vector 't' must be real-valued or empty"); endif if (! isequal (t, unique (t))) error ("lsim: time vector 't' must be sorted"); endif if (! is_real_vector (x0) && ! isempty (x0)) error ("lsim: initial state vector 'x0' must be empty or a real-valued vector"); endif ## function [y, t, x_arr] = __linear_simulation__ (sys, u, t, x0) [y, t, x] = cellfun (@__linear_simulation__, varargin(sys_idx), {u}, {t}, {x0}, "uniformoutput", false); if (nargout == 0) # plot information ## extract plotting styles tmp = cumsum (sys_idx); tmp(sys_idx | ! sty_idx) = 0; n_sys = nnz (sys_idx); sty = arrayfun (@(x) varargin(tmp == x), 1:n_sys, "uniformoutput", false); ## default plotting styles if empty colororder = get (gca, "colororder"); rc = rows (colororder); def = arrayfun (@(k) {"color", colororder(1+rem (k-1, rc), :)}, 1:n_sys, "uniformoutput", false); idx = cellfun (@isempty, sty); sty(idx) = def(idx); ## get system names for legend ## leg = cellfun (@inputname, find (sys_idx), "uniformoutput", false); leg = cell (1, n_sys); idx = find (sys_idx); for k = 1 : n_sys try leg{k} = inputname (idx(k)); catch leg{k} = ""; # catch case lsim (lticell{:}, ...) end_try_catch endfor [p, m] = size (varargin(sys_idx){1}); ct_idx = cellfun (@isct, varargin(sys_idx)); str = "Linear Simulation Results"; outname = get (varargin(sys_idx){end}, "outname"); outname = __labels__ (outname, "y"); for k = 1 : n_sys # for every system if (ct_idx(k)) # continuous-time system for i = 1 : p # for every output if (p != 1) subplot (p, 1, i); endif plot (t{k}, y{k}(:, i), sty{k}{:}); hold on; # input should be plotted in the background using uistack, which isn't # implemented yet plot (t{k}, u, 'Color', [0.5 0.5 0.5]); # plot input grid on; if (k == n_sys) axis tight ylim (__axis_margin__ (ylim)) ylabel (outname{i}); if (i == 1) title (str); endif endif endfor else # discrete-time system for i = 1 : p # for every output if (p != 1) subplot (p, 1, i); endif stairs (t{k}, y{k}(:, i), sty{k}{:}); hold on; # input should be plotted in the background using uistack, which isn't # implemented yet plot (t{k}, u, 'Color', [0.5 0.5 0.5]); # plot input grid on; if (k == n_sys) axis tight; ylim (__axis_margin__ (ylim)) ylabel (outname{i}); if (i == 1) title (str); endif endif endfor endif endfor xlabel ("Time [s]"); if (p == 1 && m == 1) legend (leg) endif hold off; else # return values y_r = y{1}; t_r = t{1}; x_r = x{1}; endif endfunction function [y, t, x_arr] = __linear_simulation__ (sys, u, t, x0) method = "foh"; [urows, ucols] = size (u); len_t = length (t); if (isct (sys)) # continuous-time system was_ct = 1; if (isempty (t)) # lsim (sys, u, [], ...) error ("lsim: time vector 't' must not be empty"); elseif (len_t == 1) # lsim (sys, u, tfinal, ...) dt = t / (urows - 1); t = vec (linspace (0, t, urows)); elseif ((len_t != urows) && (len_t != ucols)) error ("lsim: length of time vector (%d) doesn't match input signal (%dx%d) or (%dx%d)\n", ... len_t, urows, ucols, ucols, urows); else # lsim (sys, u, t, ...) if (len_t == ucols) u = u'; [urows, ucols] = size (u); endif dt = abs (t(end) - t(1)) / (urows - 1); # assume that t is regularly spaced t = vec (linspace (t(1), t(end), urows)); endif sys = c2d (ss (sys), dt, method); # convert to discrete-time model (in ss for accuracy) else # discrete-time system was_ct = 0; dt = abs (get (sys, "tsam")); # use 1 second as default if tsam is unspecified (-1) if (isempty (t)) # lsim (sys, u) m = length (sys.inputname); # we can not verify shape of u by length t if ((ucols != m) && (urows != m)) error ("lsim: input vector 'u' must have %d columns or rows", m); else if (urows == m) u = u'; [urows, ucols] = size (u); endif endif t = vec (linspace (0, dt*(urows-1), urows)); elseif (len_t == 1) # lsim (sys, u, tfinal) ## TODO: maybe raise warning if abs (tfinal - dt*(urows-1)) > dt t = vec (linspace (0, dt*(urows-1), urows)); elseif ((len_t != urows) && (len_t != ucols)) error ("lsim: length of time vector (%d) doesn't match input signal (%dx%d) or (%dx%d)\n", ... len_t, urows, ucols, ucols, urows); if (len_t == ucols) u = u'; [urows, ucols] = size (u); endif else # lsim (sys, u, t, ...) t = vec (linspace (t(1), t(end), len_t)); endif endif [A, B, C, D] = ssdata (sys); [p, m] = size (D); # number of outputs and inputs n = rows (A); # number of states if (ucols != m) error ("lsim: input vector 'u' must have %d columns", m); endif ## preallocate memory y = zeros (urows, p); x_arr = zeros (urows, n); ## initial conditions if (isempty (x0)) x0 = zeros (n, 1); elseif (n != length (x0) || ! is_real_vector (x0)) error ("lsim: 'x0' must be a vector with %d elements", n); endif x = vec (x0); # make sure that x is a column vector ## When discretization method was foh transform initial state into ## the states representing the foh form. ## The required matrix "Bd1" is stored by c2d in sys.userdata if was_ct && (method == 'foh') && (max (size (sys.userdata)) > 0) x = x - sys.userdata * u(1,:)'; endif ## simulation for k = 1 : urows y(k, :) = C * x + D * u(k, :).'; x_arr(k, :) = x; x = A * x + B * u(k, :).'; endfor ## When discretization method was foh transform back from foh states ## into original state if was_ct && (method == 'foh') && (max (size (sys.userdata)) > 0) x_arr = x_arr + u * sys.userdata'; endif endfunction %!test %! n = 5; %! m = 3; %! p = 2; %! A = diag ([0:-2:-2*(n-1)]); %! B = [ (1:1:n)' (-1:1:n-2)' (2:1:n+1)']; %! C = [1 0 1 0 0 ; 0 1 0 1 1 ]; %! D = zeros (p,m); %! %! sys = ss(A, B, C, D); %! dt = 0.1; %! t = 0:dt:1; %! x0 = zeros(n,1); %! u = [ sin(2*t') cos(3*t') sin(4*t') ]; %! [y1, t1] = lsim(sys, u, t, x0); %! [y2, t2] = lsim(sys, u', t, x0); %! %! sysd = c2d (sys, dt, 'foh'); %! x0 = x0 - sysd.userdata * u(1,:)'; # foh-doscretization %! [y3, t3] = lsim(sysd, u, [], x0); %! [y4, t4] = lsim(sysd, u', [], x0); %! %! assert (y1,y2,1e-4); %! assert (y1,y3,1e-4); %! assert (y1,y4,1e-4); %!demo %! clf; %! A = [-3 0 0; %! 0 -2 1; %! 10 -17 0]; %! B = [4; %! 0; %! 0]; %! C = [0 0 1]; %! D = 0; %! sys = ss(A,B,C,D); %! t = 0:0.01:10; %! u = zeros (length(t) ,1); %! x0 = [0 0.1 0]; %! lsim(sys, u, t, x0); control-4.1.2/inst/PaxHeaders/__frd_dim__.m0000644000000000000000000000007415012430645015614 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__frd_dim__.m0000644000175000017500000000304515012430645017005 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Number of outputs and inputs of transfer function numerator and ## denominator. For internal use only. ## Author: Lukas Reichlin ## Created: February 2010 ## Version: 0.2 function [p, m, l] = __frd_dim__ (H, w) if (! isnumeric (H)) error ("frd: argument 'H' must be a 3-dimensional numeric array"); endif lw = length (w); if (! isempty (w) && (! is_real_vector (w) || any (w < 0) ... || ! issorted (w) || w(1) > w(end) ... || length (unique (w)) != lw)) error ("frd: argument 'w' must be a vector of positive real numbers in ascending order"); endif [p, m, l] = size (H); if (l != lw) error ("frd: arguments 'H' (%dx%dx%d) and 'w' (%d) must have equal length", p, m, l, lw); endif endfunction control-4.1.2/inst/PaxHeaders/Madievski.m0000644000000000000000000000007415012430645015330 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/Madievski.m0000644000175000017500000001253615012430645016526 0ustar00lilgelilge00000000000000%% -*- texinfo -*- %% @deftypefn {Example Script} {} Madievski %% Demonstration of frequency-weighted controller reduction. %% %% The system considered in this example has been studied by Madievski and %% Anderson [1] and comprises four spinning disks. The disks are connected by a %% flexible rod, a motor applies torque to the third disk, and the angular %% displacement of the first disk is the variable of interest. The state-space %% model of eighth order is non-minimumphase and unstable. %% The continuous-time LQG controller used in [1] is open-loop stable and of %% eighth order like the plant. This eighth-order controller shall be reduced by %% frequency-weighted singular perturbation approximation (SPA). %% The major aim of this reduction is the preservation of the closed-loop %% transfer function. This means that the error in approximation of the %% controller @var{K} by the reduced-order controller @var{Kr} is minimized by %% @tex %% $$ \underset{K_r}{\\min} \ || W \ (K - K_r) \ V ||_{\infty} $$ %% @end tex %% @ifnottex %% @example %% min ||W (K-Kr) V|| %% Kr inf %% @end example %% @end ifnottex %% where weights @var{W} and @var{V} are dictated by the requirement to preserve %% (as far as possible) the closed-loop transfer function. In minimizing the %% error, they cause the approximation process for @var{K} to be more accurate at %% certain frequencies. Suggested by [1] is the use of the following stability %% and performance enforcing weights: %% @tex %% $$ W = (I - G K)^{-1} G, \qquad V = (I - G K)^{-1} $$ %% @end tex %% @ifnottex %% @example %% -1 -1 %% W = (I - G K) G, V = (I - G K) %% @end example %% @end ifnottex %% This example script reduces the eighth-order controller to orders four and two %% by the function call %% @code{Kr = spaconred (G, K, nr, 'feedback', '-')} %% where argument @var{nr} denotes the desired order (4 or 2). The key-value %% pair @code{'feedback', '-'} allows the reduction of negative feedback %% controllers while the default setting expects positive feedback controllers. %% The frequency responses of the original and reduced-order controllers are %% depicted in figure 1, the step responses of the closed loop in figure 2. %% There is no visible difference between the step responses of the closed-loop %% systems with original (blue) and fourth order (green) controllers. %% The second order controller (red) causes ripples in the step response, but %% otherwise the behavior of the system is unaltered. This leads to the %% conclusion that function @command{spaconred} is well suited to reduce the %% order of controllers considerably, while stability and performance are %% retained. %% %% @end deftypefn %% %% @*@strong{Reference}@* %% [1] Madievski, A.G. and Anderson, B.D.O. %% @cite{Sampled-Data Controller Reduction Procedure}, %% IEEE Transactions of Automatic Control, %% Vol. 40, No. 11, November 1995 % =============================================================================== % Frequency Weighted Controller Reduction Lukas Reichlin December 2011 % =============================================================================== % Tabula Rasa clear all, close all, clc % Plant Ap1 = [ 0.0 1.0 0.0 0.0 ]; Ap2 = [ -0.015 0.765 -0.765 -0.015 ]; Ap3 = [ -0.028 1.410 -1.410 -0.028 ]; Ap4 = [ -0.04 1.85 -1.85 -0.04 ]; Ap = blkdiag (Ap1, Ap2, Ap3, Ap4); Bp = [ 0.026 -0.251 0.033 -0.886 -4.017 0.145 3.604 0.280 ]; Cp = [ -0.996 -0.105 0.261 0.009 -0.001 -0.043 0.002 -0.026 ]; Dp = [ 0.0 ]; P = ss (Ap, Bp, Cp, Dp); % Controller Ac = [ -0.4077 0.9741 0.1073 0.0131 0.0023 -0.0186 -0.0003 -0.0098 -0.0977 -0.1750 0.0215 -0.0896 -0.0260 0.0057 0.0109 -0.0105 0.0011 0.0218 -0.0148 0.7769 0.0034 -0.0013 -0.0014 0.0011 -0.0361 -0.5853 -0.7701 -0.3341 -0.0915 0.0334 0.0378 -0.0290 -0.1716 -2.6546 -0.0210 -1.4467 -0.4428 1.5611 0.1715 -0.1318 -0.0020 0.0950 0.0029 0.0523 -1.3950 -0.0338 -0.0062 0.0045 0.1607 2.3824 0.0170 1.2979 0.3721 -0.1353 -0.1938 1.9685 -0.0006 0.1837 0.0048 0.1010 0.0289 -0.0111 -1.8619 -0.0311 ]; Bc = [ -0.4105 -0.0868 -0.0004 0.0036 0.0081 -0.0085 -0.0004 -0.0132 ]; Cc = [ -0.0447 -0.6611 -0.0047 -0.3601 -0.1033 0.0375 0.0427 -0.0329 ]; Dc = [ 0.0 ]; K = ss (Ac, Bc, Cc, Dc); % Controller Reduction Kr4 = spaconred (P, K, 4, 'feedback', '-') Kr2 = spaconred (P, K, 2, 'feedback', '-') % Open Loop L = P * K; Lr4 = P * Kr4; Lr2 = P * Kr2; % Closed Loop T = feedback (L); Tr4 = feedback (Lr4); Tr2 = feedback (Lr2); % Frequency Range w = {1e-2, 1e1}; % Bode Plot of Controller figure (1) bode (K, Kr4, Kr2, w) legend ('K (8 states)', 'Kr (4 states)', 'Kr (2 states)', 'Location', 'SouthWest') % Step Response of Closed Loop figure (2) step (T, Tr4, Tr2, 100) legend ('K (8 states)', 'Kr (4 states)', 'Kr (2 states)', 'Location', 'SouthEast')control-4.1.2/inst/PaxHeaders/__ss_dim__.m0000644000000000000000000000007415012430645015466 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__ss_dim__.m0000644000175000017500000000402315012430645016654 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Number of outputs (p), inputs (m) and states (n) of state space matrices. ## For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.3 function [p, m, n] = __ss_dim__ (a, b, c, d, e = []) [arows, acols] = size (a); [brows, bcols] = size (b); [crows, ccols] = size (c); [drows, dcols] = size (d); m = bcols; # = dcols n = arows; # = acols p = crows; # = drows if (arows != acols) error ("ss: system matrix a(%dx%d) is not square", arows, acols); endif if (brows != arows) error ("ss: system matrices a(%dx%d) and b(%dx%d) are incompatible", arows, acols, brows, bcols); endif if (ccols != acols) error ("ss: system matrices a(%dx%d) and c(%dx%d) are incompatible", arows, acols, crows, ccols); endif if (bcols != dcols) error ("ss: system matrices b(%dx%d) and d(%dx%d) are incompatible", brows, bcols, drows, dcols); endif if (crows != drows) error ("ss: system matrices c(%dx%d) and d(%dx%d) are incompatible", crows, ccols, drows, dcols); endif if (! isempty (e) && ! size_equal (e, a)) error ("ss: system matrices a(%dx%d) and e(%dx%d) are incompatible", arows, acols, rows (e), columns (e)); endif endfunction control-4.1.2/inst/PaxHeaders/estim.m0000644000000000000000000000007415012430645014535 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/estim.m0000644000175000017500000001552215012430645015731 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{est} =} estim (@var{sys}, @var{l}) ## @deftypefnx {Function File} {@var{est} =} estim (@var{sys}, @var{l}, @var{sensors}, @var{known}) ## @deftypefnx {Function File} {@var{est} =} estim (@var{sys}, @var{l}, @var{sensors}, @var{known}, @var{type}) ## Return state estimator for a given estimator gain. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @item l ## State feedback matrix. ## @item sensors ## Indices of measured output signals y from @var{sys}. If omitted or empty, ## all outputs are measured. ## @item known ## Indices of known input signals u (deterministic) to @var{sys}. ## All other inputs to @var{sys} are assumed stochastic (w). ## If argument @var{known} is omitted or empty, no inputs u are known. ## @item type ## Type of the estimator for discrete-time systems. If set to 'delayed' the current ## estimation is based on y(k-1), if set to 'current' the current estimation is ## based on the lates mesaruement y(k). If omitted, the 'delayed' version is created. ## @end table ## ## @strong{Outputs} ## @table @var ## @item est ## State-space model of estimator. ## @end table ## ## @strong{Block Diagram} ## @example ## @group ## u +-------+ ^ ## +---------------------------->| |-------> y ## | +-------+ + y | est | ^ ## u ----+--->| |----->(+)------>| |-------> x ## | sys | ^ + +-------+ ## w -------->| | | ## +-------+ | v ## @end group ## @end example ## ## @strong{Remarks} ## ## The argument @var{type} is for discrete-time systems only. If set to 'current', ## the follwong prediction-correction scheme is used: ## @example ## @group ## ^ ^ ## x*(k+1) = A x(k) + B u(k) ## ^ ^ -1 ## x(k) = x*(k) + A L (y(k) - C x*(k) - D u(k)) ## @end group ## @end example ## The inverse fo the system matrix in the above equations is required ## for maintaining the desired observer error dynamics given by (A - LC). ## ## The advantage of this structure is that the current measurement y(k) ## is used for the current estiamted state and not for the next allowing ## the estimator to react to system disturbances faster. L is the ## observer feedback matrix for the common observer structure with ## the matrix (A - LC) being asymptotically stable, i.e. has ## eigenvalues strictly within the unit circle. ## ## @seealso{kalman, lqe, place} ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 0.3 function est = estim (sys, l, sensors = [], known = [], type = 'delayed') if (nargin < 2 || nargin > 5) print_usage (); endif if (! isa (sys, "lti")) error ("estim: first argument must be an LTI system"); endif sys = ss (sys); # needed to get stname from tf models [a, b, c, d, e, tsam] = dssdata (sys, []); [inn, stn, outn, ing, outg] = get (sys, "inname", "stname", "outname", "ingroup", "outgroup"); if (isempty (sensors)) sensors = 1 : rows (c); endif if (ischar (sensors)) sensors = {sensors}; endif if (ischar (known)) known = {known}; endif if (iscell (sensors)) tmp = cellfun (@(x) __str2idx__ (outg, outn, x, "out"), sensors(:), "uniformoutput", false); sensors = vertcat (tmp{:}); endif if (iscell (known)) tmp = cellfun (@(x) __str2idx__ (ing, inn, x, "in"), known(:), "uniformoutput", false); known = vertcat (tmp{:}); endif m = length (known); n = rows (a); p = length (sensors); if (rows (l) != n) error ("estim: system '%s' has %d states, but the state estimator gain '%s' has %d rows", ... inputname (1), n, inputname (2), rows (l)); endif if (columns (l) != p) error ("estim: estimator gain '%s' has %d columns, but argument 'known' contains %d indices", ... inputname (2), columns (l), p); endif b = b(:, known); c = c(sensors, :); d = d(sensors, known); stname = __labels__ (stn, "xhat"); outname = vertcat (__labels__ (outn(sensors(:)), "yhat"), stname); inname = vertcat (__labels__ (inn(known(:)), "u"), __labels__ (outn(sensors(:)), "y")); if strcmp (type, 'current') if isct (sys) warning ("kalman: ignoring 'type' parameter for continuous-time estimator\n"); type = 'delayed'; else if (cond (a) > 1e12) error ("estimd: system '%s' has noninvertibla system matrix", ... inputname (1)); endif endif endif if strcmp (type, 'current') l = inv(a) * l; i_lc = eye(n,n) - l*c; f = a * i_lc; g = [ b-a*l*d, a*l ]; h = [ c*i_lc i_lc ]; j = [ -c*l*d, c*l; -l*d, l ]; ## k = e; else f = a - l*c; g = [b - l*d, l]; h = [c; eye(n)]; j = [d, zeros(p, p); zeros(n, m), zeros(n, p)]; ## k = e; endif est = dss (f, g, h, j, e, tsam); est = set (est, "inname", inname, "stname", stname, "outname", outname); endfunction %!test %! sys = ss (-2, 1, 1, 3); %! est = estim (sys, 5); %! [a, b, c, d] = ssdata (est); %! m = [a, b; c, d]; %! m_exp = [-7, 5; 1, 0; 1, 0]; %! assert (m, m_exp, 1e-4); %!test %! sys = ss (-1, 2, 3, 4); %! est = estim (sys, 5); %! [a, b, c, d] = ssdata (est); %! m = [a, b; c, d]; %! m_exp = [-16, 5; 3, 0; 1, 0]; %! assert (m, m_exp, 1e-4); ## The following test use the same system %!shared A, B, C, D, L, sysd, x0, xo0, u, k, y, x %! A = [ 0 1 0 ; 0 0 1 ; 0.5120 0.640 -0.800]; %! B = [ 0; 0; 1 ]; %! C = [ 0.1 0 0 ]; %! D = 1; %! L = place (A',C',zeros(1,3))'; % Deadbeat %! sysd = ss (A,B,C,D,1); %! x0 = [ .1 .1 .1 ]; %! xo0 = [ 0 0 0 ]; %! k = 0:1:25; %! u = 0.1*sin(0.5*k).*cos(0.4*k).^2; %! [y,t,x] = lsim (sysd, u, k, x0); %!test %! estc = estim (sysd, L, [], 1, 'current'); %! [yoc,t,~] = lsim (estc, [u' y], k, xo0); %! xoc = yoc(:,2:end); %! ec = xoc - x; %! assert (ec(3,:), zeros(1,3), 1e-4); % ed already zero for k = 2 %!test %! estd = estim (sysd, L, [], 1); %! [yod,t,~] = lsim (estd, [u' y], k, xo0); %! xod = yod(:,2:end); %! ed = xod - x; %! assert (ed(1,:), xo0 - x0, 1e-4); % ec not corrected at k = 0 %! assert (ed(4,:), zeros(1,3), 1e-4); % ec zero for k = 3 control-4.1.2/inst/PaxHeaders/sumblk.m0000644000000000000000000000007415012430645014711 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/sumblk.m0000644000175000017500000000707215012430645016106 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{S} =} sumblk (@var{formula}) ## @deftypefnx{Function File} {@var{S} =} sumblk (@var{formula}, @var{n}) ## Create summing junction @var{S} from string @var{formula} ## for name-based interconnections. ## ## @strong{Inputs} ## @table @var ## @item formula ## String containing the formula of the summing junction, ## e.g. @code{e = r - y + d} ## @item n ## Signal size. Default value is 1. ## @end table ## ## @strong{Outputs} ## @table @var ## @item S ## State-space model of the summing junction. ## @end table ## ## @strong{Example} ## @example ## @group ## octave:1> S = sumblk ('e = r - y + d') ## ## S.d = ## r y d ## e 1 -1 1 ## ## Static gain. ## octave:2> S = sumblk ('e = r - y + d', 2) ## ## S.d = ## r1 r2 y1 y2 d1 d2 ## e1 1 0 -1 0 1 0 ## e2 0 1 0 -1 0 1 ## ## Static gain. ## @end group ## @end example ## @seealso{connect} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2013 ## Version: 0.2 function s = sumblk (formula, n = 1) if (nargin == 0 || nargin > 2) print_usage (); endif if (! ischar (formula)) error ("sumblk: require string as first argument"); endif if (! is_real_scalar (n) || n < 1) error ("sumblk: require integer as second argument"); endif if (length (strfind (formula, "=")) != 1) error ("sumblk: formula requires exactly one '='"); endif ## if the first signal has no sign, add a plus if (isempty (regexp (formula, "=\\s*[+-]", "once"))) formula = regexprep (formula, "=", "=+", "once"); endif ## extract operators, remove "=" from formula operator = regexp (formula, "[=+-]", "match"); if (! strcmp (operator{1}, "=")) error ("sumblk: formula has misplaced '='"); endif operator = operator(2:end); formula = formula(formula != "="); ## extract signal names signal = regexp (formula, "\\s*[+-]\\s*", "split"); if (any (cellfun (@isempty, signal))) error ("sumblk: formula is missing some input/output names"); endif outname = signal(1); inname = signal(2:end); signs = ones (1, numel (inname)); signs(strcmp (operator, "-")) = -1; d = kron (signs, eye (n)); s = ss (d); ## NOTE: the dark side returns a tf, but i prefer an ss model ## because in general, transfer functions and mimo ## interconnections don't mix well if (n > 1) outgroup = struct (outname{1}, 1:n); outname = strseq (outname{1}, 1:n); idx = 1 : n*numel (inname); idx = reshape (idx, n, []); idx = num2cell (idx, 1); ingroup = cell2struct (idx, inname, 2); tmp = cellfun (@strseq, inname, {1:n}, "uniformoutput", false); inname = vertcat (tmp{:}); s = set (s, "outgroup", outgroup, "ingroup", ingroup); endif s = set (s, "inname", inname, "outname", outname); endfunction control-4.1.2/inst/PaxHeaders/lqgtrack.m0000644000000000000000000000007415012430645015224 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/lqgtrack.m0000644000175000017500000000706215012430645016420 0ustar00lilgelilge00000000000000## Copyright (C) 2024 Fabio Di Iorio ## ## This file is part of the Control package for GNU Octave. ## ## Octave 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. ## ## Octave 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 Octave; see the file COPYING. If not, ## see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{reg} =} lqgtrack (@var{kest}, @var{k}) ## Form LQG servo controller ## ## @strong{Inputs} ## @table @var ## @item kest ## Kalman estimator ## @item k ## State-feedback gain, including integrator states (m x n+p) ## @end table ## ## @strong{Outputs} ## @table @var ## @item reg ## LQG servo controller. Connect with positive feedback. ## @end table ## ## @strong{Equations} ## @seealso{lqr, kalman, lqg, lqgreg} ## @end deftypefn ## Author: Fabio Di Iorio ## Created: July 2024 ## Version: 0.1 function [reg] = lqgtrack (kest, k) %% TODO: implement variant with additional known inputs: %% reg = lqgtrack (kest, k, controls) % TODO: implement variant with 1dof %% reg = lqgtrack (kest, k, '1dof') if (isa (kest, "lti")) [a, b, c, d, e, Ts] = dssdata (kest, []); else print_usage (); endif [m, ~] = size(k); L = kest.b(:, m+1:end); [n, p] = size(L); C = kest.c(1:p, :); B = kest.b(:, 1:m); D = kest.d(1:p, 1:m); if isct(kest) reg = ss([a-B*k(:,1:(end-p))-L*C+L*D*k(:,1:(end-p)) -B*k(:,(n+1):end)+L*D*k(:,(n+1):end); zeros(p,n) zeros(p,p)], [zeros(n,p) L; ones(p,1) -1.*ones(p,1)], -k, 0,Ts); else reg = ss([a-B*k(:,1:(end-p))-L*C+L*D*k(:,1:(end-p)) -B*k(:,(n+1):end)+L*D*k(:,(n+1):end); zeros(p,n) eye(p,p)], [zeros(n,p) L; Ts.*ones(p,1) -Ts.*ones(p,1)], -k, 0,Ts); endif % set variables names [inn, stn, outn, ing, outg] = get (kest, "inname", "stname", "outname", "ingroup", "outgroup"); stname = cell(n+p,1); for i=1:n stname{i,1} = strcat("xhat",num2str(i)); endfor for i=1:p stname{n+i,1} = strcat("xi",num2str(i)); endfor outname = cell(m,1); for i=1:m outname{i,1} = strcat("u",num2str(i)); endfor inname = cell(2*p,1); for i=1:p inname{i,1} = strcat("r",num2str(i)); endfor for i=1:p inname{p+i,1} = strcat("y",num2str(i)); endfor reg = set (reg, "inname", inname, "stname", stname, "outname", outname); endfunction %!test %! G = zpk([], [-10 -1 -100], 2000); %! sys = ss(G); %! [n, m] = size(sys.b); %! [p, ~] = size(sys.c); %! Q = eye(3+p); %! R = 1; %! S = zeros(3+p,1); %! W = eye(3); %! V = 1; %! N = zeros(3, 1); %! K = lqi(sys, Q, R, S); %! Bn = [sys.b eye(n)]; %! sys_noisy = ss(sys.a, Bn, sys.c, sys.d, sys.ts); %! [est, L1, ~] = kalman(sys_noisy, W, V, N, 1:p, 1:m); %! reg = lqgtrack(est,K); %! assert(real(eig(feedback(reg, sys, 2, 1, 1)))<0); %! Ts = 0.01; %! Gz = zpk([],[-0.1 0.05 0.004], 3, Ts); %! sysz = ss(Gz); %! kz = lqi(sysz, Q, R, S); %! Bn = [sysz.b eye(n)]; %! sys_noisyz = ss(sysz.a, Bn, sysz.c, sysz.d, sysz.ts); %! [estz, L1, ~] = kalman(sys_noisyz, W, V, N, 1:p, 1:m); %! regz = lqgtrack(estz,kz); %! assert(abs(eig(feedback(regz, sysz, 2, 1, 1)))<1); control-4.1.2/inst/PaxHeaders/sigma.m0000644000000000000000000000007415012430645014514 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/sigma.m0000644000175000017500000001032215012430645015701 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} sigma (@var{sys}) ## @deftypefnx {Function File} {} sigma (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}) ## @deftypefnx {Function File} {} sigma (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}, @var{w}) ## @deftypefnx {Function File} {} sigma (@var{sys1}, @var{'style1'}, @dots{}, @var{sysN}, @var{'styleN'}) ## @deftypefnx{Function File} {[@var{sv}, @var{w}] =} sigma (@var{sys}) ## @deftypefnx{Function File} {[@var{sv}, @var{w}] =} sigma (@var{sys}, @var{w}) ## Singular values of frequency response. If no output arguments are given, ## the singular value plot is printed on the screen. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. Multiple inputs and/or outputs (MIMO systems) make practical sense. ## @item w ## Optional vector of frequency values. If @var{w} is not specified, ## it is calculated by the zeros and poles of the system. ## Alternatively, the cell @code{@{wmin, wmax@}} specifies a frequency range, ## where @var{wmin} and @var{wmax} denote minimum and maximum frequencies ## in rad/s. ## @item 'style' ## Line style and color, e.g. 'r' for a solid red line or '-.k' for a dash-dotted ## black line. See @command{help plot} for details. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sv ## Array of singular values. For a system with m inputs and p outputs, the array sv ## has @code{min (m, p)} rows and as many columns as frequency points @code{length (w)}. ## The singular values at the frequency @code{w(k)} are given by @code{sv(:,k)}. ## @item w ## Vector of frequency values used. ## @end table ## ## @seealso{bodemag, svd} ## @end deftypefn ## Author: Lukas Reichlin ## Created: May 2009 ## Version: 1.0 function [sv_r, w_r] = sigma (varargin) if (nargin == 0) print_usage (); endif [H, w, sty, sys_idx] = __frequency_response__ ("sigma", varargin, nargout); numsys = length (sys_idx); sv = cellfun (@(H) cellfun (@svd, H, "uniformoutput", false), H, "uniformoutput", false); sv = cellfun (@(sv) horzcat (sv{:}), sv, "uniformoutput", false); if (! nargout) # plot the information ## get system names and create the legend leg = cell (1, numsys); for k = 1:numsys leg{k} = inputname (sys_idx(k)); endfor ## convert to dB for plotting sv_db = cellfun (@mag2db, sv, "uniformoutput", false); len = numel (H); colororder = get (gca, "colororder"); rc = rows (colororder); def = arrayfun (@(k) {"-", "color", colororder(1+rem (k-1, rc), :)}, 1:len, "uniformoutput", false); idx = cellfun (@isempty, sty); sty(idx) = def(idx); plot_args = horzcat (cellfun (@horzcat, w, sv_db, sty, "uniformoutput", false){:}); ## adjust line colors in legend idx = horzcat (1, cellfun (@rows, sv_db)(1:end-1)); idx = cumsum (idx); ## plot results h = semilogx (plot_args{:}); axis ("tight") ylim (__axis_margin__ (ylim)) grid ("on") title ("Singular Values") xlabel ("Frequency [rad/s]") ylabel ("Singular Values [dB]") legend (h(idx), leg) else # return values sv_r = sv{1}; w_r = reshape (w{1}, [], 1); endif endfunction %!shared sv_exp, w_exp, sv_obs, w_obs %! A = [1, 2; 3, 4]; %! B = [5, 6; 7, 8]; %! C = [4, 3; 2, 1]; %! D = [8, 7; 6, 5]; %! w = [2, 3, 4]; %! sv_exp = [7.9176, 8.6275, 9.4393; %! 0.6985, 0.6086, 0.5195]; %! w_exp = [2; 3; 4]; %! [sv_obs, w_obs] = sigma (ss (A, B, C, D), w); %!assert (sv_obs, sv_exp, 1e-4); %!assert (w_obs, w_exp, 1e-4); control-4.1.2/inst/PaxHeaders/__dss_bilin__.m0000644000000000000000000000007415012430645016156 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__dss_bilin__.m0000644000175000017500000000460315012430645017350 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## 1. Discrete -> continuous ## _ ## E = alpha*E + A ## _ ## A = beta (A - alpha*E) ## _ ## B = sqrt(2*alpha*beta) * B ## _ -1 ## C = sqrt(2*alpha*beta) * C * (alpha*E + A) * E ## _ -1 ## D = D - C * (alpha*E + A) * B ## ## ## 2. Continuous -> discrete ## _ ## E = beta*E - A ## _ ## A = alpha (beta*E + A) ## _ ## B = sqrt(2*alpha*beta) * B ## _ -1 ## C = sqrt(2*alpha*beta) * C * (beta*E - A) * E ## _ -1 ## D = D + C * (beta*E - A) * B ## Special thanks to Andras Varga for the formulae. ## Author: Lukas Reichlin ## Created: October 2011 ## Version: 0.1 function [Ar, Br, Cr, Dr, Er] = __dss_bilin__ (A, B, C, D, E, beta, discrete) if (discrete) EpA = E + A; s2b = sqrt (2*beta); if (rcond (EpA) < eps) error ("d2c: E+A singular"); endif CiEpA = C / EpA; Er = EpA; Ar = beta * (A - E); Br = s2b * B; Cr = s2b * CiEpA * E; Dr = D - CiEpA * B; ## Er = E + A; ## Ar = beta * (A - E); ## Br = sqrt (2*beta) * B; ## Cr = sqrt (2*beta) * C / (E + A) * E; ## Dr = D - C / (E + A) * B; else bEmA = beta*E - A; s2b = sqrt (2*beta); if (rcond (bEmA) < eps) error ("c2d: beta*E-A singular"); endif CibEmA = C / bEmA; Er = bEmA; Ar = beta*E + A; Br = s2b * B; Cr = s2b * CibEmA * E; Dr = D + CibEmA * B; ## Er = beta*E - A; ## Ar = beta*E + A; ## Br = sqrt (2*beta) * B; ## Cr = sqrt (2*beta) * C / (beta*E - A) * E; ## Dr = D + C / (beta*E - A) * B; endif endfunction control-4.1.2/inst/PaxHeaders/lqe.m0000644000000000000000000000007415012430645014175 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/lqe.m0000644000175000017500000001051215012430645015363 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 Lukas F. Reichlin ## Copyright (C) 2012 Megan Zagrobelny ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{l}, @var{p}, @var{e}] =} lqe (@var{sys}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{l}, @var{p}, @var{e}] =} lqe (@var{sys}, @var{q}, @var{r}, @var{s}) ## @deftypefnx {Function File} {[@var{l}, @var{p}, @var{e}] =} lqe (@var{a}, @var{g}, @var{c}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{l}, @var{p}, @var{e}] =} lqe (@var{a}, @var{g}, @var{c}, @var{q}, @var{r}, @var{s}) ## @deftypefnx {Function File} {[@var{l}, @var{p}, @var{e}] =} lqe (@var{a}, @var{[]}, @var{c}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{l}, @var{p}, @var{e}] =} lqe (@var{a}, @var{[]}, @var{c}, @var{q}, @var{r}, @var{s}) ## Kalman filter for continuous-time systems. ## ## @tex ## $$ \dot{x} = A\,x + B\,u + G\,w $$ ## $$ y = C\,x + D\,u + v $$ ## $$ E(w) = 0,\,\, E(v) = 0,\,\, cov(w) = Q,\,\, cov(v) = R,\,\, cov(w,v) = S $$ ## @end tex ## @ifnottex ## @example ## @group ## . ## x = Ax + Bu + Gw (State equation) ## y = Cx + Du + v (Measurement Equation) ## E(w) = 0, E(v) = 0, cov(w) = Q, cov(v) = R, cov(w,v) = S ## @end group ## @end example ## @end ifnottex ## ## @strong{Inputs} ## @table @var ## @item sys ## Continuous or discrete-time @acronym{LTI} model (p-by-m, n states). ## @item a ## State matrix of continuous-time system (n-by-n). ## @item g ## Process noise matrix of continuous-time system (n-by-g). ## If @var{g} is empty @code{[]}, an identity matrix is assumed. ## @item c ## Measurement matrix of continuous-time system (p-by-n). ## @item q ## Process noise covariance matrix (g-by-g). ## @item r ## Measurement noise covariance matrix (p-by-p). ## @item s ## Optional cross term covariance matrix (g-by-p), s = cov(w,v). ## If @var{s} is empty @code{[]} or not specified, a zero matrix is assumed. ## @end table ## ## @strong{Outputs} ## @table @var ## @item l ## Kalman filter gain matrix (n-by-p). ## @item p ## Unique stabilizing solution of the continuous-time Riccati equation (n-by-n). ## Symmetric matrix. If @var{sys} is a discrete-time model, the solution of the ## corresponding discrete-time Riccati equation is returned. ## @item e ## Closed-loop poles (n-by-1). ## @end table ## ## @strong{Equations} ## @tex ## $$ \dot{x} = A\,x + B\,u + L\,(y - C\, - D\,u) $$ ## $$ E = \sigma (A - L\, C) $$ ## @end tex ## @ifnottex ## @example ## @group ## . ## x = Ax + Bu + L(y - Cx -Du) ## ## E = eig(A - L*C) ## ## @end group ## @end example ## @end ifnottex ## @seealso{dare, care, dlqr, lqr, dlqe} ## @end deftypefn ## Author: Lukas Reichlin ## Created: April 2012 ## Version: 0.1 function [l, p, e] = lqe (a, g, c, q = [], r = [], s = []) if (nargin < 3 || nargin > 6) print_usage (); endif if (isa (a, "lti")) [l, p, e] = lqr (a.', g, c, q); # lqe (sys, q, r, s), g=I, works like lqr (sys.', q, r, s).' elseif (isempty (g)) [l, p, e] = lqr (a.', c.', q, r, s); # lqe (a, [], c, q, r, s), g=I, works like lqr (a.', c.', q, r, s).' elseif (columns (g) != rows (q) || ! issquare (q)) error ("lqe: matrices g(%dx%d) and q(%dx%d) have incompatible dimensions", ... rows (g), columns (g), rows (q), columns (q)); elseif (isempty (s)) [l, p, e] = lqr (a.', c.', g*q*g.', r); elseif (columns (g) != rows (s)) error ("lqe: matrices g(%dx%d) and s(%dx%d) have incompatible dimensions", ... rows (g), columns (g), rows (s), columns (s)); else [l, p, e] = lqr (a.', c.', g*q*g.', r, g*s); endif l = l.'; ## NOTE: for discrete-time sys, the solution L' from DARE ## is different to L from DLQE (a, s) endfunction control-4.1.2/inst/PaxHeaders/__str2idx__.m0000644000000000000000000000007415012430645015607 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__str2idx__.m0000644000175000017500000000254415012430645017003 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Get input/output indices from in/outgroup and in/outname. ## For internal use only. ## Author: Lukas Reichlin ## Created: October 2013 ## Version: 0.1 function idx = __str2idx__ (group, name, str, id) if (isfield (group, str)) idx = group.(str)(:); else tmp = strcmp (name, str)(:); switch (nnz (tmp)) case 1 idx = find (tmp); case 0 error ("lti: %sgroup or %sname '%s' not found", id, id, str); otherwise error ("lti: %sname '%s' is ambiguous", id, str); ## FIXME: error for structure arrays endswitch endif endfunction control-4.1.2/inst/PaxHeaders/n4sid.m0000644000000000000000000000007415012430645014435 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/n4sid.m0000644000175000017500000001702415012430645015630 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{sys}, @var{x0}, @var{info}] =} n4sid (@var{dat}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}, @var{info}] =} n4sid (@var{dat}, @var{n}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}, @var{info}] =} n4sid (@var{dat}, @var{opt}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}, @var{info}] =} n4sid (@var{dat}, @var{n}, @var{opt}, @dots{}) ## Estimate state-space model using @acronym{N4SID} algorithm. ## @acronym{N4SID}: Numerical algorithm for Subspace State Space System IDentification. ## If no output arguments are given, the singular values are ## plotted on the screen in order to estimate the system order. ## ## @strong{Inputs} ## @table @var ## @item dat ## iddata set containing the measurements, i.e. time-domain signals. ## @item n ## The desired order of the resulting state-space system @var{sys}. ## If not specified, @var{n} is chosen automatically according ## to the singular values and tolerances. ## @item @dots{} ## Optional pairs of keys and values. @code{'key1', value1, 'key2', value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## ## @strong{Outputs} ## @table @var ## @item sys ## Discrete-time state-space model. ## @item x0 ## Initial state vector. If @var{dat} is a multi-experiment dataset, ## @var{x0} becomes a cell vector containing an initial state vector ## for each experiment. ## @item info ## Struct containing additional information. ## @table @var ## @item info.K ## Kalman gain matrix. ## @item info.Q ## State covariance matrix. ## @item info.Ry ## Output covariance matrix. ## @item info.S ## State-output cross-covariance matrix. ## @item info.L ## Noise variance matrix factor. LL'=Ry. ## @end table ## @end table ## ## ## ## @strong{Option Keys and Values} ## @table @var ## @item 'n' ## The desired order of the resulting state-space system @var{sys}. ## @var{s} > @var{n} > 0. ## ## @item 's' ## The number of block rows @var{s} in the input and output ## block Hankel matrices to be processed. @var{s} > 0. ## In the MOESP theory, @var{s} should be larger than @var{n}, ## the estimated dimension of state vector. ## ## @item 'alg', 'algorithm' ## Specifies the algorithm for computing the triangular ## factor R, as follows: ## @table @var ## @item 'C' ## Cholesky algorithm applied to the correlation ## matrix of the input-output data. Default method. ## @item 'F' ## Fast QR algorithm. ## @item 'Q' ## QR algorithm applied to the concatenated block ## Hankel matrices. ## @end table ## ## @item 'tol' ## Absolute tolerance used for determining an estimate of ## the system order. If @var{tol} >= 0, the estimate is ## indicated by the index of the last singular value greater ## than or equal to @var{tol}. (Singular values less than @var{tol} ## are considered as zero.) When @var{tol} = 0, an internally ## computed default value, @var{tol} = @var{s}*@var{eps}*SV(1), is used, ## where SV(1) is the maximal singular value, and @var{eps} is ## the relative machine precision. ## When @var{tol} < 0, the estimate is indicated by the ## index of the singular value that has the largest ## logarithmic gap to its successor. Default value is 0. ## ## @item 'rcond' ## The tolerance to be used for estimating the rank of ## matrices. If the user sets @var{rcond} > 0, the given value ## of @var{rcond} is used as a lower bound for the reciprocal ## condition number; an m-by-n matrix whose estimated ## condition number is less than 1/@var{rcond} is considered to ## be of full rank. If the user sets @var{rcond} <= 0, then an ## implicitly computed, default tolerance, defined by ## @var{rcond} = m*n*@var{eps}, is used instead, where @var{eps} is the ## relative machine precision. Default value is 0. ## ## @item 'confirm' ## Specifies whether or not the user's confirmation of the ## system order estimate is desired, as follows: ## @table @var ## @item true ## User's confirmation. ## @item false ## No confirmation. Default value. ## @end table ## ## @item 'noiseinput' ## The desired type of noise input channels. ## @table @var ## @item 'n' ## No error inputs. Default value. ## @iftex ## @tex ## $$ x_{k+1} = A x_k + B u_k $$ ## $$ y_k = C x_k + D u_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## x[k+1] = A x[k] + B u[k] ## y[k] = C x[k] + D u[k] ## @end example ## @end ifnottex ## ## @item 'e' ## Return @var{sys} as a (p-by-m+p) state-space model with ## both measured input channels u and noise channels e ## with covariance matrix @var{Ry}. ## @iftex ## @tex ## $$ x_{k+1} = A x_k + B u_k + K e_k $$ ## $$ y_k = C x_k + D u_k + e_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## x[k+1] = A x[k] + B u[k] + K e[k] ## y[k] = C x[k] + D u[k] + e[k] ## @end example ## @end ifnottex ## ## @item 'v' ## Return @var{sys} as a (p-by-m+p) state-space model with ## both measured input channels u and white noise channels v ## with identity covariance matrix. ## @iftex ## @tex ## $$ x_{k+1} = A x_k + B u_k + K L v_k $$ ## $$ y_k = C x_k + D u_k + L v_k $$ ## $$ e = L v, \\ L L^T = R_y $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## x[k+1] = A x[k] + B u[k] + K L v[k] ## y[k] = C x[k] + D u[k] + L v[k] ## e = L v, L L' = Ry ## @end example ## @end ifnottex ## ## @item 'k' ## Return @var{sys} as a Kalman predictor for simulation. ## @iftex ## @tex ## $$ \\widehat{x}_{k+1} = A \\widehat{x}_k + B u_k + K (y_k - \\widehat{y}_k) $$ ## $$ \\widehat{y}_k = C \\widehat{x}_k + D u_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## ^ ^ ^ ## x[k+1] = A x[k] + B u[k] + K(y[k] - y[k]) ## ^ ^ ## y[k] = C x[k] + D u[k] ## @end example ## @end ifnottex ## ## @iftex ## @tex ## $$ \\widehat{x}_{k+1} = (A-KC) \\widehat{x}_k + (B-KD) u_k + K y_k $$ ## $$ \\widehat{y}_k = C \\widehat{x}_k + D u_k + 0 y_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## ^ ^ ## x[k+1] = (A-KC) x[k] + (B-KD) u[k] + K y[k] ## ^ ^ ## y[k] = C x[k] + D u[k] + 0 y[k] ## @end example ## @end ifnottex ## @end table ## @end table ## ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SLICOT IB01AD, IB01BD and IB01CD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: May 2012 ## Version: 0.1 function [sys, x0, info] = n4sid (varargin) if (nargin == 0) print_usage (); endif if (nargout == 0) __slicot_identification__ ("n4sid", nargout, varargin{:}); else [sys, x0, info] = __slicot_identification__ ("n4sid", nargout, varargin{:}); endif endfunction control-4.1.2/inst/PaxHeaders/place.m0000644000000000000000000000007415012430645014500 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/place.m0000644000175000017500000001423615012430645015675 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- 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{info}] =} place (@var{sys}, @var{p}, @var{alpha}) ## @deftypefnx {Function File} {[@var{f}, @var{info}] =} place (@var{a}, @var{b}, @var{p}, @var{alpha}) ## ## Pole assignment for a given matrix pair (@var{A},@var{B}) such that @code{p = eig (A-B*F)}. ## If parameter @var{alpha} is specified, poles with real parts (continuous-time) ## or moduli (discrete-time) below @var{alpha} are left untouched. ## ## @strong{Inputs} ## @table @var ## @item sys ## Continuous- or discrete-time @acronym{LTI} system. ## @item a ## State matrix (n-by-n) of a continuous-time system. ## @item b ## Input matrix (n-by-m) of a continuous-time system. ## @item p ## Desired eigenvalues of the closed-loop system state-matrix @var{A-B*F}. ## @code{length (p) <= rows (A)}. ## @item alpha ## Specifies the maximum admissible value, either for real ## parts or for moduli, of the eigenvalues of @var{A} which will ## not be modified by the eigenvalue assignment algorithm. ## @code{alpha >= 0} for discrete-time systems. ## @end table ## ## @strong{Outputs} ## @table @var ## @item f ## State feedback gain matrix. ## @item info ## Structure containing additional information. ## @item info.nfp ## The number of fixed poles, i.e. eigenvalues of @var{A} having ## real parts less than @var{alpha}, or moduli less than @var{alpha}. ## These eigenvalues are not modified by @command{place}. ## @item info.nap ## The number of assigned eigenvalues. @code{nap = n-nfp-nup}. ## @item info.nup ## The number of uncontrollable eigenvalues detected by the ## eigenvalue assignment algorithm. ## @item info.z ## The orthogonal matrix @var{z} reduces the closed-loop ## system state matrix @code{A + B*F} to upper real Schur form. ## Note the positive sign in @code{A + B*F}. ## @end table ## ## @strong{Note} ## @example ## Place is also suitable to design estimator gains: ## @group ## L = place (A.', C.', p).' ## L = place (sys.', p).' # useful for discrete-time systems ## @end group ## @end example ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB01BD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Special thanks to Peter Benner from TU Chemnitz for his advice. ## Author: Lukas Reichlin ## Created: December 2009 ## Version: 0.5 function [f, info] = place (a, b, p = [], alpha = [], tol = []) if (nargin < 2 || nargin > 5) print_usage (); endif if (isa (a, "lti")) # place (sys, p), place (sys, p, alpha), place (sys, p, alpha, tol) if (nargin > 4) # nargin < 2 already tested print_usage (); endif tol = alpha; alpha = p; p = b; sys = a; [a, b] = ssdata (sys); # descriptor matrice e should be regular discrete = ! isct (sys); else # place (a, b, p), place (a, b, p, alpha), place (a, b, p, alpha, tol) if (nargin < 3) # nargin > 5 already tested print_usage (); endif if (! is_real_square_matrix (a) || ! is_real_matrix (b) || rows (a) != rows (b)) error ("place: matrices a and b not conformal"); endif discrete = 0; # assume continuous system endif if (! isnumeric (p) || ! isvector (p) || isempty (p)) # p could be complex error ("place: p must be a vector"); endif p = sort (reshape (p, [], 1)); # 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 (isempty (alpha)) if (discrete) alpha = 0; else alpha = - norm (a, inf); endif endif if (isempty (tol)) tol = 0; endif [f, nfp, nap, nup, z] = __sl_sb01bd__ (a, b, wr, wi, discrete, alpha, tol); f = -f; # A + B*F --> A - B*F info = struct ("nfp", nfp, "nap", nap, "nup", nup, "z", z); endfunction ## Test from "legacy" control package 1.0.* %!shared A, B, C, P, Kexpected %! A = [0, 1; 3, 2]; %! B = [0; 1]; %! 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); ## FIXME: Test from SLICOT example SB01BD fails with 4 eigenvalues in P %!shared F, F_exp, ev_ol, ev_cl %! 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.1500i %! -0.5000 - 0.1500i]; #%! -2.0000 + 0.0000i #%! -0.4000 + 0.0000i]; %! %! ALPHA = -0.4; %! TOL = 1e-8; %! %! F = place (A, B, P, ALPHA, TOL); %! %! F_exp = - [-0.0876 -4.2138 0.0837 -18.1412 %! -0.0233 18.2483 -0.4259 -4.8120]; %! %! ev_ol = sort (eig (A)); %! ev_cl = sort (eig (A - B*F)); %! %!assert (F, F_exp, 1e-4); %!assert (ev_ol(3:4), ev_cl(3:4), 1e-4); control-4.1.2/inst/PaxHeaders/@tf0000644000000000000000000000007415012430645013672 xustar0030 atime=1747595720.873132883 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/0000755000175000017500000000000015012430645015136 5ustar00lilgelilge00000000000000control-4.1.2/inst/@tf/PaxHeaders/__sys_keys__.m0000644000000000000000000000007415012430645016572 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__sys_keys__.m0000644000175000017500000000321315012430645017760 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{keys}, @var{vals}] =} __sys_keys__ (@var{sys}) ## @deftypefnx {Function File} {[@var{keys}, @var{vals}] =} __sys_keys__ (@var{sys}, @var{aliases}) ## Return the list of keys as well as the assignable values for a tf object sys. ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function [keys, vals] = __sys_keys__ (sys, aliases = false) ## cell vector of tf-specific keys keys = {"num"; "den"; "tfvar"; "inv"}; ## cell vector of tf-specific assignable values vals = {"p-by-m cell array of row vectors (m = number of inputs)"; "p-by-m cell array of row vectors (p = number of outputs)"; "string (usually s or z)"; "logical (true for negative powers of TF variable)"}; if (aliases) ka = {"variable"}; keys = [keys; ka]; endif endfunction control-4.1.2/inst/@tf/PaxHeaders/__set__.m0000644000000000000000000000007415012430645015514 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__set__.m0000644000175000017500000000656415012430645016716 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Set or modify keys of TF objects. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function sys = __set__ (sys, key, val) switch (key) # {, } case "num" if (isstaticgain (sys)) error (["tf: set: tinkering with numerators of static gains is disabled on purpose. " ... "to avoid this error, set the sampling time of your LTI model first."]); elseif (sys.inv) # FIXME: f = filt (1, [1 0 0 1]), f.num = 1 warning ("tf:num-inv", ... "tf: although system is displayed in '%s^-1', numerator 'num' must be specified in '%s'\n", ... sys.tfvar, sys.tfvar); endif num = __adjust_tf_data__ (val, sys.den); __tf_dim__ (num, sys.den); sys.num = num; case "den" if (isstaticgain (sys)) error (["tf: set: tinkering with denominators of static gains is disabled on purpose. " ... "to avoid this error, set the sampling time of your LTI model first."]); elseif (sys.inv) # FIXME: f = filt ([1 0 0 1], 1), f.den = 1 warning ("tf:den-inv", ... "tf: although system is displayed in '%s^-1', denominator 'den' must be specified in '%s'\n", ... sys.tfvar, sys.tfvar); endif [~, den] = __adjust_tf_data__ (sys.num, val); __tf_dim__ (sys.num, den); sys.den = den; case {"tfvar", "variable"} if (ischar (val)) candidates = {"s", "p", "z", "q", "z^-1", "q^-1"}; idx = strcmpi (val, candidates); if (any (idx)) val = candidates{idx}; n = find (idx); if (n > 2 && isct (sys)) error ("tf: set: variable '%s' not allowed for static gains and continuous-time models", val); elseif (n < 3 && isdt (sys)) error ("tf: set: variable '%s' not allowed for static gains and discrete-time models", val); endif if (isscalar (val)) sys.tfvar = val; sys.inv = false; else sys.tfvar = val(1); sys.inv = true; endif else error ("tf: set: the string '%s' is not a valid transfer function variable", val); endif else error ("tf: set: key '%s' requires a string", prop); endif case "inv" if (islogical (val) && isscalar (val) || is_real_scalar (val)) sys.inv = logical (val); else error ("tf: set: key 'inv' must be a scalar logical"); endif otherwise error ("tf: set: invalid key name '%s'", key); endswitch endfunction control-4.1.2/inst/@tf/PaxHeaders/__c2d__.m0000644000000000000000000000007415012430645015371 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__c2d__.m0000644000175000017500000000610215012430645016557 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Convert the continuous TF model into its discrete-time equivalent. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function sys = __c2d__ (sys, tsam, method = "zoh", w0 = 0) if (strncmpi (method, "i", 1)) # "impulse invariant" [~,~,~,D] = ssdata (sys); if (any (D(:))) error ("c2d: impuls invariant discrete-time models only supported for systems without direct feedthrough\n"); endif sys=imp_invar(sys,1/tsam); elseif (strncmpi (method, "m", 1)) # "matched" ## TODO: move this code to @zpk/__c2d__.m once ZPK models are implemented if (! issiso (sys)) error ("tf: c2d: require SISO system for matched pole/zero method"); endif [z_c, p_c, k_c] = zpkdata (sys, "vector"); p_d = exp (p_c * tsam); z_d = exp (z_c * tsam); if (any (! isfinite (p_d)) || any (! isfinite (z_d))) error ("tf: c2d: discrete-time poles and zeros are not finite"); endif ## continuous-time zeros at infinity are mapped to -1 in discrete-time ## except for one. for non-proper transfer functions, no zeros at -1 are added. np = length (p_c); # number of poles nz = length (z_c); # number of finite zeros, np-nz number of infinite zeros z_d = vertcat (z_d, repmat (-1, np-nz-1, 1)); ## the discrete-time gain k_d is matched at a certain frequency (w_c, w_d) ## to continuous-time gain k_c. the dc gain is taken (w_c=0, w_d=1) unless ## there are continuous-time poles/zeros near 0. then w_c=1/tsam is taken. w_c = 0; # dc gain tol = sqrt (eps); # poles/zeros below tol are assumed to be zero while (any (abs ([p_c; z_c] - w_c) < tol)) w_c += 0.1 / tsam; endwhile w_d = exp (w_c * tsam); k_d = real (k_c * prod (w_c - z_c) / prod (w_c - p_c) * prod (w_d - p_d) / prod (w_d - z_d)); tmp = zpk (z_d, p_d, k_d, tsam); sys.num = tmp.num; sys.den = tmp.den; else [p, m] = size (sys); for i = 1 : p for j = 1 : m idx = substruct ("()", {i, j}); tmp = subsref (sys, idx); tmp = c2d (ss (tmp), tsam, method, w0); [num, den] = tfdata (tmp, "tfpoly"); sys.num(i, j) = num; sys.den(i, j) = den; endfor endfor endif sys.tfvar = "z"; endfunction control-4.1.2/inst/@tf/PaxHeaders/vertcat.m0000644000000000000000000000007415012430645015575 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/vertcat.m0000644000175000017500000000355315012430645016772 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Vertical concatenation of @acronym{TF} objects. ## Used by Octave for "[sys1; sys2]". ## Avoids conversion to state-space and back by overriding ## the general vertcat function for @acronym{LTI} objects. ## Author: Lukas Reichlin ## Created: May 2014 ## Version: 0.1 function sys = vertcat (sys, varargin) sys = tf (sys); varargin = cellfun (@tf, varargin, "uniformoutput", false); for k = 1 : (nargin-1) sys1 = sys; sys2 = varargin{k}; sys = tf (); sys.lti = __lti_group__ (sys1.lti, sys2.lti, "vertcat"); [p1, m1] = size (sys1.num); [p2, m2] = size (sys2.num); if (m1 != m2) error ("tf: vertcat: number of system inputs incompatible: [(%dx%d); (%dx%d)]", p1, m1, p2, m2); endif sys.num = [sys1.num; sys2.num]; sys.den = [sys1.den; sys2.den]; if (strcmp (sys1.tfvar, sys2.tfvar)) sys.tfvar = sys1.tfvar; elseif (strcmp (sys1.tfvar, "x")) sys.tfvar = sys2.tfvar; else sys.tfvar = sys1.tfvar; endif if (sys1.inv || sys2.inv) sys.inv = true; endif endfor endfunction control-4.1.2/inst/@tf/PaxHeaders/__d2c__.m0000644000000000000000000000007415012430645015371 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__d2c__.m0000644000175000017500000000432615012430645016565 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Convert the discrete TF model into its continuous-time equivalent. ## Author: Lukas Reichlin ## Created: September 2011 ## Version: 0.2 function sys = __d2c__ (sys, tsam, method = "zoh", w0 = 0) if (strncmpi (method, "m", 1)) # "matched" ## TODO: move this code to @zpk/__d2c__.m once ZPK models are implemented if (! issiso (sys)) error ("tf: d2c: require SISO system for matched pole/zero method"); endif [z_d, p_d, k_d] = zpkdata (sys, "vector"); if (any (abs (p_d) < eps) || any (abs (z_d) < eps)) error ("tf: d2c: discrete-time poles and zeros at 0 not supported because log(0) is -Inf"); endif z_d_orig = z_d; z_d(abs (z_d+1) < sqrt (eps)) = []; p_c = log (p_d) / tsam; z_c = log (z_d) / tsam; w_c = 0; w_d = 1; tol = sqrt (eps); while (any (abs ([p_d; z_d_orig] - w_d) < tol)) w_c += 0.1 / tsam; endwhile w_d = exp (w_c * tsam); k_c = real (k_d * prod (w_d - z_d_orig) / prod (w_d - p_d) * prod (w_c - p_c) / prod (w_c - z_c)); tmp = zpk (z_c, p_c, k_c); sys.num = tmp.num; sys.den = tmp.den; else [p, m] = size (sys); for i = 1 : p for j = 1 : m idx = substruct ("()", {i, j}); tmp = subsref (sys, idx); tmp = d2c (ss (tmp), method, w0); [num, den] = tfdata (tmp, "tfpoly"); sys.num(i, j) = num; sys.den(i, j) = den; endfor endfor endif sys.tfvar = "s"; endfunction control-4.1.2/inst/@tf/PaxHeaders/isstaticgain.m0000644000000000000000000000007415012430645016607 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/isstaticgain.m0000644000175000017500000000437715012430645020011 0ustar00lilgelilge00000000000000## Copyright (C) 2022 Torsten Lilge ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{bool} =} isstaticgain (@var{sys}) ## Determine whether @acronym{LTI} model is a static gain. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. ## @end table ## ## @strong{Outputs} ## @table @var ## @item bool = 0 ## @var{sys} is a dynamical system ## @item bool = 1 ## @var{sys} is a static gain ## @end table ## @end deftypefn ## Author: Torsten Lilge ## Created: October 2022 ## Version: 0.1 function static_gain = isstaticgain (ltisys) if (nargin == 0) print_usage (); endif num = ltisys.num; den = ltisys.den; static_gain = false; if (isempty (den)) # tf (num, []), where [] could be {} as well if (isempty (num)) # tf ([], []) num = den = {}; static_gain = true; elseif (is_real_matrix (num)) # static gain tf (matrix), tf (matrix, []) num = num2cell (num); den = num2cell (ones (size (num))); static_gain = true; endif endif if (! iscell (num)) num = {num}; endif if (! iscell (den)) den = {den}; endif ## Now check for static gain if all tfs have size num and size den of one num_scalar = cellfun (@(p) (find (p != 0, 1) == length (p)) || (length (find (p != 0, 1)) == 0), num); den_scalar = cellfun (@(p) (find (p != 0, 1) == length (p)) || (length (find (p != 0, 1)) == 0), den); if (all (num_scalar) && all (den_scalar)) ## All tf components are of the form b0/a0 (static gain) static_gain = true; endif endfunction control-4.1.2/inst/@tf/PaxHeaders/__pole__.m0000644000000000000000000000007415012430645015660 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__pole__.m0000644000175000017500000000211715012430645017050 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Poles of TF object. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.2 function pol = __pole__ (sys) if (issiso (sys)) pol = roots (sys.den{1}); else warning ("tf: pole: converting to minimal state-space for pole computation of mimo tf\n"); pol = pole (ss (sys)); endif endfunction control-4.1.2/inst/@tf/PaxHeaders/__sys2frd__.m0000644000000000000000000000007415012430645016315 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__sys2frd__.m0000644000175000017500000000220215012430645017500 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## TF to FRD conversion. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function [retsys, retlti] = __sys2frd__ (sys, w = []) if (isempty (w)) # case sys = frd (sys) w = __frequency_vector__ (sys); endif H = freqresp (sys, w); retsys = frd (H, w); # tsam is set below retlti = sys.lti; # preserve lti properties endfunction control-4.1.2/inst/@tf/PaxHeaders/__sys_connect__.m0000644000000000000000000000007415012430645017250 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__sys_connect__.m0000644000175000017500000000721715012430645020446 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{retsys} =} __sys_connect__ (@var{sys}, @var{M}) ## This function is part of the Model Abstraction Layer. No argument checking. ## For internal use only. ## @example ## @group ## Problem: Solve the system equations of ## Y(s) = G(s) E(s) ## E(s) = U(s) + M Y(s) ## in order to build ## Y(s) = H(s) U(s) ## Solution: ## Y(s) = G(s) [I - M G(s)]^-1 U(s) ## = [I - G(s) M]^-1 G(s) U(s) ## @end group ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function sys = __sys_connect__ (sys, M) [p, m] = size (sys); num = sys.num; den = sys.den; ## WARNING: The code below is a cheap hack to quickly enable SISO TF connections. ## FIXME: Check for den = 0, e.g. in feedback (tf (1), tf (-1)) if (p == 2 && m == 2 && num{1,2} == 0 && num{2,1} == 0 ... && M(1,1) == 0 && M(2,2) == 0) ## mtimes, feedback sys.num(1,1) = num{1,1} * den{2,2}; sys.num(1,2) = M(1,2) * num{1,1} * num{2,2}; sys.num(2,1) = M(2,1) * num{1,1} * num{2,2}; sys.num(2,2) = num{2,2} * den{1,1}; sys.den(:) = den{1,1} * den{2,2} - M(1,2) * M(2,1) * num{1,1} * num{2,2}; elseif (p == 3 && m == 4 && num{1,3} == 0 && num{1,4} == 0 ... && num{2,1} == 0 && num{2,2} == 0 && num{2,4} == 0 ... && num{3,1} == 0 && num{3,2} == 0 && num{3,3} == 0 ... && isequal (M, [0, 1, 0; 0, 0, 1; 0, 0, 0; 0, 0, 0])) ## horzcat [sys1, sys2], plus, minus sys.num(:) = tfpoly (0); sys.den(:) = tfpoly (1); sys.num(1,1) = num{1,1}; sys.num(1,2) = num{1,2}; sys.num(1,3) = num{1,1} * num{2,3}; sys.num(1,4) = num{1,2} * num{3,4}; sys.num(2,3) = num{2,3}; sys.num(3,4) = num{3,4}; sys.den(1,3) = den{2,3}; sys.den(1,4) = den{3,4}; sys.den(2,3) = den{2,3}; sys.den(3,4) = den{3,4}; elseif (p == 3 && m == 3 && num{1,3} == 0 ... && num{2,1} == 0 && num{2,2} == 0 && num{2,3} == 1 && den{2,3} == 1 ... && num{3,1} == 0 && num{3,2} == 0 && num{3,3} == 1 && den{3,3} == 1 ... && isequal (M, [0, 1, 0; 0, 0, 1; 0, 0, 0])) ## plus, minus sys.num(1,3) = num{1,1} * den{1,2} + num{1,2} * den{1,1}; sys.den(1,3) = den{1,1} * den{1,2}; elseif (p == 4 && m == 3 && num{1,2} == 0 && num{1,3} == 0 ... && num{2,1} == 0 && num{2,3} == 0 ... && num{3,1} == 0 && num{3,2} == 0 && num{3,3} == 1 && den{3,3} == 1 ... && num{4,1} == 0 && num{4,2} == 0 && num{4,3} == 1 && den{4,3} == 1 ... && isequal (M, [0, 0, 1, 0; 0, 0, 0, 1; 0, 0, 0, 0])) ## vertcat [sys1; sys2] sys.num(1,3) = num{1,1}; sys.num(2,3) = num{2,2}; sys.den(1,3) = den{1,1}; sys.den(2,3) = den{2,2}; else ## MIMO case, convert to state-space and back. warning ("tf: converting to minimal state-space for MIMO TF interconnections\n"); sys = tf (__sys_connect__ (ss (sys), M)); endif endfunction control-4.1.2/inst/@tf/PaxHeaders/display.m0000644000000000000000000000007415012430645015572 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/display.m0000644000175000017500000000624415012430645016767 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Display routine for TF objects. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.4 function display (sys) sysname = inputname (1); [inname, outname, tsam] = __lti_data__ (sys.lti); [inname, m] = __labels__ (inname, "u"); [outname, p] = __labels__ (outname, "y"); disp (""); if (sys.inv && ! isct (sys)) [num, den] = filtdata (sys); # 'num' and 'den' are cells of real-valued vectors else num = sys.num; # 'num' and 'den' are cells of 'tfpoly' objects den = sys.den; endif for nu = 1 : m disp (["Transfer function '", sysname, "' from input '", inname{nu}, "' to output ..."]); disp (""); for ny = 1 : p __disp_frac__ (num{ny, nu}, den{ny, nu}, sys.tfvar, outname{ny}); endfor endfor display (sys.lti); # display sampling time if (isstaticgain (sys)) disp ("Static gain."); elseif (tsam == 0) disp ("Continuous-time model."); else disp ("Discrete-time model."); endif endfunction ## NOTE: * Function handles both 'tfpoly' objects and real-valued vectors. ## * The general 'tfpoly2str' function returns strings with ## negative powers of 'tfvar'. ## * The overloaded 'tfpoly2str' function returns strings with ## positive powers of 'tfvar'. function __disp_frac__ (num, den, tfvar, name) MAX_LEN = 12; # max length of output name tfp = isa (num, "tfpoly"); if (num == tfpoly (0)) str = [" ", name, ": 0"]; elseif ((tfp && den == 1) || (! tfp && isequal (den, 1))) ## elseif (den == tfpoly (1)) doesn't work because it ## would mistakingly accept non-tfpoly denominators like [0, 1] str = [" ", name, ": "]; numstr = tfpoly2str (num, tfvar); str = [str, numstr]; ##elseif (length (den) == 1) # de-comment for non-development use ## str = [" ", name, ": "]; ## num = num * (1/get (den)); ## numstr = tfpoly2str (num, tfvar); ## str = [str, numstr]; else numstr = tfpoly2str (num, tfvar); denstr = tfpoly2str (den, tfvar); fracstr = repmat ("-", 1, max (length (numstr), length (denstr))); str = strjust (strvcat (numstr, fracstr, denstr), "center"); namestr = name(:, 1 : min (MAX_LEN, end)); namestr = [namestr, ": "]; namestr = strjust (strvcat (" ", namestr, " "), "left"); namestr = horzcat (repmat (" ", 3, 1), namestr); str = [namestr, str]; endif disp (str); disp (""); endfunction control-4.1.2/inst/@tf/PaxHeaders/__ctranspose__.m0000644000000000000000000000007415012430645017102 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__ctranspose__.m0000644000175000017500000000312315012430645020270 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Conjugate transpose of TF models. ## Author: Lukas Reichlin ## Created: May 2012 ## Version: 0.1 function sys = __ctranspose__ (sys, ct) num = sys.num; den = sys.den; if (ct) # continuous-time num = cellfun (@conj_ct, num, "uniformoutput", false); den = cellfun (@conj_ct, den, "uniformoutput", false); else # discrete-time ## Both num and den must be the same length ## for the flip command, ## so add leading zeros to the shortest one. ng=get(num{1}); dg=get(den{1}); nng=numel(ng); ndg=numel(dg); if (nng>ndg) dg= [zeros(1,nng-ndg) dg]; else ng= [zeros(1,ndg-nng) ng] ; endif ## the flip effectively replaces every z with 1/z num={tfpoly(flip(ng))}; den={tfpoly(flip(dg))}; endif sys.num = num.'; sys.den = den.'; endfunction control-4.1.2/inst/@tf/PaxHeaders/__minreal__.m0000644000000000000000000000007415012430645016350 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__minreal__.m0000644000175000017500000000407315012430645017543 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Minimal realization of TF models. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.2 function sys = __minreal__ (sys, tol) sqrt_eps = sqrt (eps); # treshold for zero [p, m] = size (sys); for ny = 1 : p for nu = 1 : m sisosys = __sys_prune__ (sys, ny, nu); [zer, gain] = zero (sisosys); pol = pole (sisosys); for k = length (zer) : -1 : 1 # reversed because of deleted zeros [~, idx] = min (abs (zer(k) - pol)); # find best match if (strcmpi (tol, "def")) if (abs (zer(k)) < sqrt_eps) # catch case zer(k) = 0 t = 1000 * eps; else t = 1000 * abs (zer(k)) * sqrt_eps; endif else t = tol; endif if (abs (zer(k) - pol(idx)) < t) zer(k) = []; pol(idx) = []; endif endfor num = real (gain * poly (zer)); den = real (poly (pol)); [n, d] = tfdata (sisosys, "vector"); if (size_equal (num, n) && size_equal (den, d)) if (d(1) != 1) n /= d(1); d /= d(1); endif num = n; den = d; endif sys.num{ny, nu} = tfpoly (num); sys.den{ny, nu} = tfpoly (den); endfor endfor endfunction control-4.1.2/inst/@tf/PaxHeaders/__sys_data__.m0000644000000000000000000000007415012430645016530 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__sys_data__.m0000644000175000017500000000176715012430645017732 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Used by tfdata instead of multiple get calls. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.1 function [num, den, tfvar] = __sys_data__ (sys) num = sys.num; den = sys.den; tfvar = sys.tfvar; endfunction control-4.1.2/inst/@tf/PaxHeaders/__transpose__.m0000644000000000000000000000007415012430645016737 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__transpose__.m0000644000175000017500000000174715012430645020137 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Transpose of TF models. ## Author: Lukas Reichlin ## Created: February 2010 ## Version: 0.1 function sys = __transpose__ (sys) num = sys.num; den = sys.den; sys.num = num.'; sys.den = den.'; endfunction control-4.1.2/inst/@tf/PaxHeaders/__sys_group__.m0000644000000000000000000000007415012430645016753 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__sys_group__.m0000644000175000017500000000356715012430645020155 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Block diagonal concatenation of two TF models. ## This file is part of the Model Abstraction Layer. ## For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function retsys = __sys_group__ (sys1, sys2) % If one system is just a numeric value, create a proper lti system [sys1, sys2] = __numeric_to_lti__ (sys1, sys2); if (! isa (sys1, "tf")) sys1 = tf (sys1); endif if (! isa (sys2, "tf")) sys2 = tf (sys2); endif retsys = tf (); retsys.lti = __lti_group__ (sys1.lti, sys2.lti); [p1, m1] = size (sys1); [p2, m2] = size (sys2); empty12 = tfpolyzeros (p1, m2); empty21 = tfpolyzeros (p2, m1); retsys.num = [sys1.num, empty12 ; empty21, sys2.num]; empty12 = tfpolyones (p1, m2); empty21 = tfpolyones (p2, m1); retsys.den = [sys1.den, empty12 ; empty21, sys2.den]; if (sys1.tfvar == sys2.tfvar) retsys.tfvar = sys1.tfvar; elseif (sys1.tfvar == "x") retsys.tfvar = sys2.tfvar; else retsys.tfvar = sys1.tfvar; endif if (sys1.inv || sys2.inv) retsys.inv = true; endif endfunction control-4.1.2/inst/@tf/PaxHeaders/__sys2ss__.m0000644000000000000000000000007415012430645016167 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__sys2ss__.m0000644000175000017500000001522215012430645017360 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## TF to SS conversion. ## Reference: ## Varga, A.: Computation of irreducible generalized state-space realizations. ## Kybernetika, 26:89-106, 1990 ## Special thanks to Vasile Sima and Andras Varga for their advice. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.8 function [retsys, retlti] = __sys2ss__ (sys) ## TODO: determine appropriate tolerance from number of inputs ## (since we multiply all denominators in a row), index, ... ## default tolerance from TB01UD is TOLDEF = N*N*EPS ## SECRET WISH: a routine which accepts individual denominators for ## each channel and which supports descriptor systems [p, m] = size (sys); [num, den] = tfdata (sys); num = __remove_leading_zeros__ (num); den = __remove_leading_zeros__ (den); len_num = cellfun (@length, num); len_den = cellfun (@length, den); ## check for properness ## tfpoly ensures that there are no leading zeros tmp = len_num > len_den; if (any (tmp(:))) # non-proper transfer function ## separation into strictly proper and polynomial part [numq, numr] = cellfun (@deconv, num, den, "uniformoutput", false); numr = cellfun (@(num_v, len_d) num_v(max(1,end-len_d+2):end), ... numr, num2cell (len_den), "uniformoutput", false); numq = cellfun (@__remove_leading_zeros__, numq, "uniformoutput", false); numr = cellfun (@__remove_leading_zeros__, numr, "uniformoutput", false); ## minimal state-space realization for the proper part [a1, b1, c1] = __proper_tf2ss__ (numr, den, p, m); e1 = eye (size (a1)); ## minimal realization for the polynomial part [e2, a2, b2, c2] = __polynomial_tf2ss__ (numq, p, m); ## assemble irreducible descriptor realization e = blkdiag (e1, e2); a = blkdiag (a1, a2); b = vertcat (b1, b2); c = horzcat (c1, c2); ## fix numerical problems e(abs(e) < 2*eps) = 0; a(abs(a) < 2*eps) = 0; b(abs(b) < 2*eps) = 0; c(abs(c) < 2*eps) = 0; retsys = dss (a, b, c, [], e); else # proper transfer function [a, b, c, d] = __proper_tf2ss__ (num, den, p, m); retsys = ss (a, b, c, d); endif retlti = sys.lti; # preserve lti properties such as tsam endfunction ## transfer function to state-space conversion for proper models function [a, b, c, d] = __proper_tf2ss__ (num, den, p, m) if (p == 1 && m == 1) # Only for SISO systems as the following data preprocessing # for using TD04AD might lead to numerical issues for larger # MIMO systems. # The code in this if-branch is still for MIMO systems but # is only used for SISO-Systems for now. ## new cells for the TF of same row denominators numc = cell (p, m); denc = cell (p, 1); ## multiply all denominators in a row and ## update each numerator accordingly ## except for single-input models and those ## with equal denominators in a row for i = 1 : p if (m == 1 || isequal (den{i,:})) denc(i) = den{i,1}; numc(i,:) = num(i,:); else denc(i) = __conv__ (den{i,:}); for j = 1 : m idx = setdiff (1:m, j); numc(i,j) = __conv__ (num{i,j}, den{i,idx}); endfor endif endfor len_numc = cellfun (@length, numc); len_denc = cellfun (@length, denc); ## create arrays and fill in the data ## in a way that Slicot TD04AD can use max_len_denc = max (len_denc(:)); ucoeff = zeros (p, m, max_len_denc); dcoeff = zeros (p, max_len_denc); index = len_denc-1; for i = 1 : p len = len_denc(i); dcoeff(i, 1:len) = denc{i}; for j = 1 : m ucoeff(i, j, len-len_numc(i,j)+1 : len) = numc{i,j}; endfor endfor tol = min (sqrt (eps), eps*prod (index)); [a, b, c, d] = __sl_td04ad__ (ucoeff, dcoeff, index, tol); else ## MIMO: Create overall system by manually combining the single systems ## in a parallel structure. Use minreal () afterwards for eliminating ## redundant states. a_ij = cell (size (den)); b_ij = cell (size (den)); c_ij = cell (size (den)); d_ij = cell (size (den)); n_systems = zeros (p,m); for i = 1:p % for all outputs for j = 1:m %for all inputs # In the following calls to ssdata , only SISO systems are # involved. Therefore these calls won't end up here (else) # but in the if-branch. [a_ij{i,j},b_ij{i,j},c_ij{i,j},d_ij{i,j}] = ssdata (tf (num{i,j},den{i,j})); n(i,j) = size (a_ij{i,j},1); endfor endfor n_all = sum (n(:)); a = zeros (n_all,n_all); b = zeros (n_all,m); c = zeros (p,n_all); d = zeros (p,m); n_yi = zeros (1,p); a = blkdiag (a_ij'{:}); for i = 1:p n_yi(i) = sum (cellfun (@(x) size (x,1), a_ij(i,:))); b(sum(n_yi(1:i-1))+1:sum(n_yi(1:i-1))+n_yi(i),:) = blkdiag (b_ij{i,:}); c(i,sum(n_yi(1:i-1))+1:sum(n_yi(1:i-1))+n_yi(i),:) = cell2mat (c_ij(i,:)); d(i,:) = cell2mat (d_ij(i,:)); endfor [a,b,c,d] = ssdata (minreal (ss (a,b,c,d))); endif endfunction ## realization of the polynomial part according to Andras' paper function [e2, a2, b2, c2] = __polynomial_tf2ss__ (numq, p, m) len_numq = cellfun (@length, numq); max_len_numq = max (len_numq(:)); numq = cellfun (@(x) prepad (x, max_len_numq, 0, 2), numq, "uniformoutput", false); f = @(y) cellfun (@(x) x(y), numq); s = 1 : max_len_numq; D = arrayfun (f, s, "uniformoutput", false); e2 = diag (ones (p*(max_len_numq-1), 1), -p); a2 = eye (p*max_len_numq); b2 = vertcat (D{:}); c2 = horzcat (zeros (p, p*(max_len_numq-1)), -eye (p)); ## remove uncontrollable part [a2, e2, b2, c2] = __sl_tg01jd__ (a2, e2, b2, c2, 0.0, true, 1, 2); endfunction ## convolution for more than two arguments function vec = __conv__ (vec, varargin) if (nargin == 1) return; else for k = 1 : nargin-1 vec = conv (vec, varargin{k}); endfor endif endfunction control-4.1.2/inst/@tf/PaxHeaders/__make_tf_polys_equally_long__.m0000644000000000000000000000007415012430645022330 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__make_tf_polys_equally_long__.m0000644000175000017500000000223315012430645023517 0ustar00lilgelilge00000000000000## Copyright (C) 2021 Torsten Lilge ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Make all corresponding num and den polynomials of a transfer function ## equally long by adding leading zeros to the shorter one. ## For internal use only. function [num, den] = __make_tf_polys_equally_long__ (sys) num = sys.num; den = sys.den; for i = 1:size (num,1) for j = 1:size (num,2) [num{i,j},den{i,j}] = __make_equally_long__ (num{i,j},den{i,j}); endfor endfor endfunction control-4.1.2/inst/@tf/PaxHeaders/__sys_prune__.m0000644000000000000000000000007415012430645016750 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__sys_prune__.m0000644000175000017500000000225615012430645020144 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Submodel extraction and reordering for TF objects. ## This file is part of the Model Abstraction Layer. ## For internal use only. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.1 function sys = __sys_prune__ (sys, out_idx, in_idx) [sys.lti, out_idx, in_idx] = __lti_prune__ (sys.lti, out_idx, in_idx); sys.num = sys.num(out_idx, in_idx); sys.den = sys.den(out_idx, in_idx); endfunction control-4.1.2/inst/@tf/PaxHeaders/__zero__.m0000644000000000000000000000007415012430645015700 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__zero__.m0000644000175000017500000000232715012430645017073 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Transmission zeros of TF object. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function [zer, gain, info] = __zero__ (sys, ~) if (issiso (sys)) num = get (sys.num{1}); den = get (sys.den{1}); zer = roots (num); gain = num(1) / den(1); info = []; else warning ("tf: zero: converting to minimal state-space for zero computation of mimo tf\n"); [zer, gain, info] = zero (ss (sys)); endif endfunction control-4.1.2/inst/@tf/PaxHeaders/__sys_inverse__.m0000644000000000000000000000007415012430645017272 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__sys_inverse__.m0000644000175000017500000000275115012430645020466 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Inversion of TF models. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function sys = __sys_inverse__ (sys) if (issiso (sys)) # SISO num = sys.num; den = sys.den; if (num{1,1} == 0) # catch case num = 0 sys.num(1,1) = tfpoly (0); sys.den(1,1) = tfpoly (1); else sys.num = den; sys.den = num; endif else # MIMO ## I've calculated TF inversion of 2x2 and 3x3 systems with Sage CAS, ## but the formulae give systems with very high orders, therefore ## I always use the conversion to state-space and back. [num, den] = tfdata (inv (ss (sys)), "tfpoly"); sys.num = num; sys.den = den; endif endfunction control-4.1.2/inst/@tf/PaxHeaders/__times__.m0000644000000000000000000000007415012430645016042 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__times__.m0000644000175000017500000000301115012430645017224 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Hadamard/Schur product of @acronym{TF} objects. ## Used by Octave for "sys1 .* sys2". ## Author: Lukas Reichlin ## Created: April 2014 ## Version: 0.1 function sys = __times__ (sys1, sys2) if (! isa (sys1, "tf")) sys1 = tf (sys1); endif if (! isa (sys2, "tf")) sys2 = tf (sys2); endif sys = tf (); sys.lti = __lti_group__ (sys1.lti, sys2.lti, "times"); sys.num = cellfun (@mtimes, sys1.num, sys2.num, "uniformoutput", false); sys.den = cellfun (@mtimes, sys1.den, sys2.den, "uniformoutput", false); if (sys1.tfvar == sys2.tfvar) sys.tfvar = sys1.tfvar; elseif (sys1.tfvar == "x") sys.tfvar = sys2.tfvar; else sys.tfvar = sys1.tfvar; endif if (sys1.inv || sys2.inv) sys.inv = true; endif endfunction control-4.1.2/inst/@tf/PaxHeaders/__freqresp__.m0000644000000000000000000000007415012430645016550 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__freqresp__.m0000644000175000017500000000270315012430645017741 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Frequency response of TF models. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.5 function H = __freqresp__ (sys, w, cellflag = false) [num, den, tsam] = tfdata (sys, "vector"); if (isct (sys)) # continuous system s = i * w; else # discrete system s = exp (i * w * abs (tsam)); endif s = reshape (s, 1, 1, []); if (issiso (sys)) H = polyval (num, s) ./ polyval (den, s); else H = cellfun (@(x, y) polyval (x, s) ./ polyval (y, s), num, den, "uniformoutput", false); H = cell2mat (H); endif if (cellflag) [p, m] = size (sys); l = length (s); H = mat2cell (H, p, m, ones (1, l))(:); endif endfunction control-4.1.2/inst/@tf/PaxHeaders/tf.m0000644000000000000000000000007415012430645014536 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/tf.m0000644000175000017500000001602015012430645015724 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{s} =} tf (@var{'s'}) ## @deftypefnx {Function File} {@var{z} =} tf (@var{'z'}, @var{tsam}) ## @deftypefnx {Function File} {@var{sys} =} tf (@var{sys}) ## @deftypefnx {Function File} {@var{sys} =} tf (@var{mat}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} tf (@var{num}, @var{den}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} tf (@var{num}, @var{den}, @var{tsam}, @dots{}) ## Create or convert to transfer function model. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model to be converted to transfer function. ## @item mat ## Gain matrix to be converted to static transfer function. ## @item num ## Numerator or cell of numerators. Each numerator must be a row vector ## containing the coefficients of the polynomial in descending powers of ## the transfer function variable. ## num@{i,j@} contains the numerator polynomial from input j to output i. ## In the SISO case, a single vector is accepted as well. ## @item den ## Denominator or cell of denominators. Each denominator must be a row vector ## containing the coefficients of the polynomial in descending powers of ## the transfer function variable. ## den@{i,j@} contains the denominator polynomial from input j to output i. ## In the SISO case, a single vector is accepted as well. ## @item tsam ## Sampling time in seconds. If @var{tsam} is not specified, a continuous-time ## model is assumed. ## @item @dots{} ## Optional pairs of properties and values. ## Type @command{set (tf)} for more information. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Transfer function model. ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'num' ## Numerator. See 'Inputs' for details. ## ## @item 'den' ## Denominator. See 'Inputs' for details. ## ## @item 'tfvar' ## String containing the transfer function variable. ## ## @item 'inv' ## Logical. True for negative powers of the transfer function variable. ## ## @item 'tsam' ## Sampling time. See 'Inputs' for details. ## ## @item 'inname' ## The name of the input channels in @var{sys}. ## Cell vector of length m containing strings. ## Default names are @code{@{'u1', 'u2', ...@}} ## ## @item 'outname' ## The name of the output channels in @var{sys}. ## Cell vector of length p containing strings. ## Default names are @code{@{'y1', 'y2', ...@}} ## ## @item 'ingroup' ## Struct with input group names as field names and ## vectors of input indices as field values. ## Default is an empty struct. ## ## @item 'outgroup' ## Struct with output group names as field names and ## vectors of output indices as field values. ## Default is an empty struct. ## ## @item 'name' ## String containing the name of the model. ## ## @item 'notes' ## String or cell of string containing comments. ## ## @item 'userdata' ## Any data type. ## @end table ## ## @strong{Example} ## @example ## @group ## octave:1> s = tf ('s'); ## octave:2> G = 1/(s+1) ## ## Transfer function 'G' from input 'u1' to output ... ## ## 1 ## y1: ----- ## s + 1 ## ## Continuous-time model. ## ## octave:3> z = tf ('z', 0.2); ## octave:4> H = 0.095/(z-0.9) ## ## Transfer function 'H' from input 'u1' to output ... ## ## 0.095 ## y1: ------- ## z - 0.9 ## ## Sampling time: 0.2 s ## Discrete-time model. ## ## octave:5> num = @{[1, 5, 7], [1]; [1, 7], [1, 5, 5]@}; ## octave:6> den = @{[1, 5, 6], [1, 2]; [1, 8, 6], [1, 3, 2]@}; ## octave:7> sys = tf (num, den) ## ## Transfer function 'sys' from input 'u1' to output ... ## ## s^2 + 5 s + 7 ## y1: ------------- ## s^2 + 5 s + 6 ## ## s + 7 ## y2: ------------- ## s^2 + 8 s + 6 ## ## Transfer function 'sys' from input 'u2' to output ... ## ## 1 ## y1: ----- ## s + 2 ## ## s^2 + 5 s + 5 ## y2: ------------- ## s^2 + 3 s + 2 ## ## Continuous-time model. ## octave:8> ## @end group ## @end example ## ## @seealso{filt, ss, dss} ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.4 function sys = tf (varargin) ## model precedence: frd > ss > zpk > tf > double ## inferiorto ("frd", "ss", "zpk"); # error if de-commented. bug in octave? superiorto ("double"); if (nargin == 1) if (isa (varargin{1}, "tf")) # tf (tfsys) sys = varargin{1}; return; elseif (isa (varargin{1}, "lti")) # tf (ltisys) [sys, lti] = __sys2tf__ (varargin{1}); sys.lti = lti; return; elseif (ischar (varargin{1})) # s = tf ('s') sys = tf ([1, 0], 1, "tfvar", varargin{:}); return; endif elseif (nargin == 2 ... && ischar (varargin{1}) ... && is_zp_vector (varargin{2}) ... && length (varargin{2}) <= 1) # z = tf ('z', tsam) sys = tf ([1, 0], 1, varargin{2}, "tfvar", varargin{[1,3:end]}); return; endif num = {}; den = {}; # default transfer matrix tsam = 0; # default sampling time [mat_idx, opt_idx, obj_flg] = __lti_input_idx__ (varargin); switch (numel (mat_idx)) case 1 num = varargin{mat_idx}; case 2 [num, den] = varargin{mat_idx}; tsam = 0; case 3 [num, den, tsam] = varargin{mat_idx}; if (isempty (tsam) && is_real_matrix (tsam)) tsam = -1; elseif (! issample (tsam, -10)) error ("tf: invalid sampling time"); endif case 0 ## nothing to do here, just prevent case 'otherwise' otherwise print_usage (); endswitch varargin = varargin(opt_idx); if (obj_flg) varargin = horzcat ({"lti"}, varargin); endif [num, den, tsam, tfvar] = __adjust_tf_data__ (num, den, tsam); [p, m] = __tf_dim__ (num, den); # determine number of outputs and inputs tfdata = struct ("num", {num}, "den", {den}, "tfvar", tfvar, "inv", false); # struct for tf-specific data ltisys = lti (p, m, tsam); # parent class for general lti data sys = class (tfdata, "tf", ltisys); # create tf object if (numel (varargin) > 0) # if there are any properties and values, ... sys = set (sys, varargin{:}); # use the general set function endif endfunction control-4.1.2/inst/@tf/PaxHeaders/horzcat.m0000644000000000000000000000007415012430645015577 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/horzcat.m0000644000175000017500000000356015012430645016772 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Horizontal concatenation of @acronym{TF} objects. ## Used by Octave for "[sys1, sys2]". ## Avoids conversion to state-space and back by overriding ## the general horzcat function for @acronym{LTI} objects. ## Author: Lukas Reichlin ## Created: April 2014 ## Version: 0.1 function sys = horzcat (sys, varargin) sys = tf (sys); varargin = cellfun (@tf, varargin, "uniformoutput", false); for k = 1 : (nargin-1) sys1 = sys; sys2 = varargin{k}; sys = tf (); sys.lti = __lti_group__ (sys1.lti, sys2.lti, "horzcat"); [p1, m1] = size (sys1.num); [p2, m2] = size (sys2.num); if (p1 != p2) error ("tf: horzcat: number of system outputs incompatible: [(%dx%d), (%dx%d)]", p1, m1, p2, m2); endif sys.num = [sys1.num, sys2.num]; sys.den = [sys1.den, sys2.den]; if (strcmp (sys1.tfvar, sys2.tfvar)) sys.tfvar = sys1.tfvar; elseif (strcmp (sys1.tfvar, "x")) sys.tfvar = sys2.tfvar; else sys.tfvar = sys1.tfvar; endif if (sys1.inv || sys2.inv) sys.inv = true; endif endfor endfunction control-4.1.2/inst/@tf/PaxHeaders/__get__.m0000644000000000000000000000007415012430645015500 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tf/__get__.m0000644000175000017500000000311515012430645016667 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Access key values of TF objects. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.5 function val = __get__ (sys, key) switch (key) # {, } case {"num","den"} ## Give numerator and denominator of a tf component the same length [num, den] = __make_tf_polys_equally_long__ (sys); ## Get the coefficients of the polys with normalized length if key == "num" val = cellfun (@get, num, "uniformoutput", false); else val = cellfun (@get, den, "uniformoutput", false); endif case {"tfvar", "variable"} val = sys.tfvar; if (sys.inv && isdt (sys)) val = [val, "^-1"]; endif case "inv" val = sys.inv; otherwise error ("tf: get: invalid key name '%s'", key); endswitch endfunction control-4.1.2/inst/PaxHeaders/reg.m0000644000000000000000000000007415012430645014171 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/reg.m0000644000175000017500000000601215012430645015357 0ustar00lilgelilge00000000000000## Copyright (C) 2024 Fabio Di Iorio ## ## This file is part of the Control package for GNU Octave. ## ## Octave 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. ## ## Octave 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 Octave; see the file COPYING. If not, ## see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{reg} =} reg (@var{sys}, @var{k}, @var{l}) ## Form regulator from state-feedback and estimator gains ## ## @strong{Inputs} ## @table @var ## @item sys ## State-space model of the plant ## @item k ## State-feedback gain ## @item l ## Estimator gain ## @end table ## ## @strong{Outputs} ## @table @var ## @item reg ## Dynamic compensator. Connect with positive feedback. ## @end table ## ## @strong{Equations} ## @seealso{place} ## @end deftypefn ## Author: Fabio Di Iorio ## Created: July 2024 ## Version: 0.1 function regsys = reg (sys, k, l) %% TODO: implement variant with additional known inputs: [m, n] = size(k); [~, p] = size(l); if (nargin ~= 3) print_usage (); endif if (~isnumeric(k) || ~isnumeric(l)) print_usage (); endif if (n<1 || m<1 || p<1) print_usage (); endif if (~isa (sys, "lti")) print_usage (); endif A = sys.a; C = sys.c; B = sys.b; D = sys.d; Ts = sys.ts; regsys = ss(A-B*k-l*C-l*D*k, l, -k, 0,Ts); % set variables names [inn, stn, outn, ing, outg] = get (sys, "inname", "stname", "outname", "ingroup", "outgroup"); stname = __labels__ (stn, "xhat"); outname = cell(m,1); for i=1:m outname{i,1} = strcat("u",num2str(i)); endfor inname = cell(p,1); for i=1:p inname{i,1} = strcat("y",num2str(i)); endfor regsys = set (regsys, "inname", inname, "stname", stname, "outname", outname); endfunction %!test %! G = zpk([],[-10 -1 -100], 2000); %! sys = ss(G); %! [n, m] = size(sys.b); %! [p, ~] = size(sys.c); %! Q = eye(3); %! R = 1; %! S = zeros(3, 1); %! W = eye(3); %! V = 1; %! N = zeros(3, 1); %! K = lqr(sys, Q, R, S); %! Bn = [sys.b eye(n)]; %! sys_noisy = ss(sys.a, Bn, sys.c, sys.d, sys.ts); %! [est, L1, ~] = kalman(sys_noisy, W, V, N, 1:p, 1:m); %! Creg = reg(sys, K, L1); %! assert(real(eig(feedback(Creg, sys, 1)))<0); %! Ts = 0.01; %! Gz = zpk([],[-0.1 0.05 0.004], 3, Ts); %! sysz = ss(Gz); %! kz = lqr(sysz, Q, R, S); %! Bn = [sysz.b eye(n)]; %! sys_noisyz = ss(sysz.a, Bn, sysz.c, sysz.d, sysz.ts); %! [estz, L1z, ~] = kalman(sys_noisyz, W, V, N, 1:p, 1:m); %! Cz = reg(sysz, kz, L1z); %! assert(abs(eig(feedback(Cz,sysz,1)))<1); control-4.1.2/inst/PaxHeaders/kalman.m0000644000000000000000000000007415012430645014657 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/kalman.m0000644000175000017500000001635015012430645016053 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{est}, @var{g}, @var{x}] =} kalman (@var{sys}, @var{Q}, @var{R}) ## @deftypefnx {Function File} {[@var{est}, @var{g}, @var{x}] =} kalman (@var{sys}, @var{Q}, @var{R}, @var{S}) ## @deftypefnx {Function File} {[@var{est}, @var{g}, @var{x}] =} kalman (@var{sys}, @var{Q}, @var{R}, @var{[]}, @var{sensors}, @var{known}) ## @deftypefnx {Function File} {[@var{est}, @var{g}, @var{x}] =} kalman (@var{sys}, @var{Q}, @var{R}, @var{S}, @var{sensors}, @var{known}) ## @deftypefnx {Function File} {[@var{est}, @var{g}, @var{x}] =} kalman (@var{sys}, @var{Q}, @var{R}, @var{[]}, @var{sensors}, @var{known}, @var{type}) ## @deftypefnx {Function File} {[@var{est}, @var{g}, @var{x}] =} kalman (@var{sys}, @var{Q}, @var{R}, @var{S}, @var{sensors}, @var{known}, @var{type}) ## Design Kalman estimator for @acronym{LTI} systems. ## ## @strong{Inputs} ## @table @var ## @item sys ## Nominal plant model. ## @item q ## Covariance of white process noise. ## @item r ## Covariance of white measurement noise. ## @item s ## Optional cross term covariance. Default value is 0. ## @item sensors ## Indices of measured output signals y from @var{sys}. If omitted or empty, all outputs are measured. ## @item known ## Indices of known input signals u (deterministic) to @var{sys}. All other inputs to @var{sys} ## are assumed stochastic. If argument @var{known} is omitted or empty, the first m-l inputs to @var{sys} ## are known, where m is the total number of inputs to @var{sys} and l is the size of the quadratic ## matrix @var{Q}. ## @item type ## Type of the estimator for discrete-time systems. If set to 'delayed' the current ## estimation is based on y(k-1), if set to 'current' the current estimation is ## based on the lates mesaruement y(k). If omitted, the 'delayed' version is created. ## @end table ## ## @strong{Outputs} ## @table @var ## @item est ## State-space model of the Kalman estimator. ## @item g ## Estimator gain. ## @item x ## Solution of the Riccati equation. ## @end table ## ## @strong{Block Diagram} ## @example ## @group ## u +-------+ ^ ## +---------------------------->| |-------> y ## | +-------+ + y | est | ^ ## u ----+--->| |----->(+)------>| |-------> x ## | sys | ^ + +-------+ ## w -------->| | | ## +-------+ | v ## ## Q = cov (w, w') R = cov (v, v') S = cov (w, v') ## @end group ## @end example ## ## @seealso{care, dare, estim, lqr} ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 0.3 function [est, K, X] = kalman (sys, Q, R, varargin) if (nargin < 3 || nargin > 7 || ! isa (sys, "lti")) print_usage (); endif ## System in state space [A, B, C, D, E] = dssdata (sys, []); ## Optional parameters: ## The new default for known inputs (deterministic) are not ## backward compatible because previously, all inputs are ## assumed to be stochastic if is empty. However, this would ## result in an error if the number if the number of stochastic ## inputs would not match the dimension of Q. For all valid cases ## the new version is compatibel to the old one. S = []; sensors = 1 : rows (C); deterministic = 1 : columns (B) - size (Q,1); # first inputs deterministic type = 'delayed'; varidxoff = 3; # offset no. of variable and fixed input arguments argidx = varidxoff; # index of last input argument if (nargin > argidx++) S = varargin{argidx-varidxoff}; if (nargin > argidx++) if (! isempty (varargin{argidx-varidxoff})) sensors = varargin{argidx-varidxoff}; endif if (nargin > argidx++) if (! isempty (varargin{argidx-varidxoff})) deterministic = varargin{argidx-varidxoff}; endif if (nargin > argidx++) if (isct (sys)) warning ("kalman: ignoring 'type' parameter for continuous-time estimator\n"); else type = varargin{argidx-varidxoff}; endif endif endif endif endif m = columns (B); m_d = length (deterministic); m_s = size (Q,1); p = length (sensors); p_s = size (R,1); ## plausibility check for parameters if (! issquare (Q)) error ("kalman: second argument Q must be square\n"); endif if (! issquare (R)) error ("kalman: third argument R must be square\n"); endif if (m_s != m - m_d) error ("kalman: number of stochastic inputs (%d) does not match size %d of Q\n",... m - m_d, m_s); endif if (p_s != p) error ("kalman: size %d of measurment noise does not match size %d of R\n",... p, p_s); endif if ((! isempty (S)) && (size (S) != [m_s,p_s])) error ("kalman: size [%d,%d] of S does not match size %d of Q and %d of R\n",... size(S,1), size(S,2), m_s, p_s); endif ## matrices for Kalman filter design stochastic = setdiff (1 : columns (B), deterministic); C = C(sensors, :); G = B(:, stochastic); H = D(sensors, stochastic); if (isempty (S)) Rbar = R + H*Q*H.'; Sbar = G * Q*H.'; else Rbar = R + H*Q*H.'+ H*S + S.'*H.'; Sbar = G * (Q*H.' + S); endif if (isct (sys)) [X, L, K] = care (A.', C.', G*Q*G.', Rbar, Sbar, E.'); else [X, L, K] = dare (A.', C.', G*Q*G.', Rbar, Sbar, E.'); endif K = K.'; est = estim (sys, K, sensors, deterministic, type); endfunction %!test %! sys = ss (-2, 1, 1, 3); %! [est, g, x] = kalman (sys, 1, 1, 1); %! [a, b, c, d] = ssdata (est); %! m = [a, b; c, d]; %! m_exp = [-2.25, 0.25; 1, 0; 1, 0]; %! g_exp = 0.25; %! x_exp = 0; %! assert (m, m_exp, 1e-2); %! assert (g, g_exp, 1e-2); %! assert (x, x_exp, 1e-2); %!shared n, nw, A, B, C, D, Bw, Dw, sys, Q, R, N, Pinf, K %! n = 3; %! nw = 2; %! %! A = [1.1269 -0.4940 0.1129 %! 1.0000 0 0 %! 0 1.0000 0]; %! B = [-0.3832 %! 0.5919 %! 0.5191]; %! Bw = rand(n,nw); %! B = [B Bw]; %! C = [1 0 0]; %! D = [1]; %! Dw = zeros(1,nw); %! D = [D Dw]; %! sys = ss(A,B,C,D,1); %! Q = eye(nw,nw); %! R = 1; %! N = []; %! PP = eye(3,3); %! # asymptotic filter equations %! for i = 1:10 %! Pinf = A*PP*A' + Bw*Q*Bw'; %! K = Pinf*C'*inv(C*Pinf*C'+R); %! PP = (eye(3,3)-K*C)*Pinf; %! endfor; %!test %! [kalmf,L,P] = kalman(sys,Q,R,N,1,1); %! assert (Pinf, P, 1e-4); %! assert (inv(A)*L, K, 1e-4); %! assert (kalmf.a, A-L*C, 1e-4); %!test %! [kalmfc,Lc,Pc] = kalman(sys,Q,R,N,1,1,'current'); %! assert (Pinf, Pc, 1e-4); %! assert (inv(A)*Lc, K, 1e-4); %! assert (kalmfc.a, A-A*K*C, 1e-4); control-4.1.2/inst/PaxHeaders/VLFamp.m0000644000000000000000000000007415012430645014541 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/VLFamp.m0000644000175000017500000004105515012430645015735 0ustar00lilgelilge00000000000000## Copyright (C) 2015 Thomas D. Dean ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {} VLFamp ## @deftypefnx{Function File} {@var{result} =} VLFamp (@var{verbose}) ## Calculations on a two stage preamp for a multi-turn, ## air-core solenoid loop antenna for the reception of ## signals below 30kHz. ## ## The Octave Control Package functions are used extensively to ## approximate the behavior of operational amplifiers and passive ## electrical circuit elements. ## ## This example presents several 'screen' pages of documentation of the ## calculations and some reasoning about why. Plots of the results are ## presented in most cases. ## ## The process is to display a 'screen' page of text followed by the ## calculation and a 'Press return to continue' message. To proceed in ## the example, press return. ^C to exit. ## ## At one point in the calculations, the process may seem to hang, but, ## this is because of extensive calculations. ## ## The returned transfer function is more than 100 characters long so ## will wrap in screens that are narrow and appear jumbled. ## @end deftypefn ## Author: Thomas D. Dean ## Created: June 2015 ## Version: 0.1 function retval = VLFamp (verbose = false) if (nargin > 1) print_usage (); endif clc; disp ("---- VLF Pre-Amplifier Design ----"); disp (""); disp ("This example covers the design of a pre-amplifier for use in"); disp ("receiving radio frequencies below 30kHz."); disp (""); disp ("See http://www.vlf.it for details of Narural Radio Sources"); disp (""); disp ("The Octave Control Package functions are used extensively to"); disp ("approximate the behavior of operational amplifiers and passive"); disp ("electrical circuit elements."); disp (""); disp ("This example presents several 'screen' pages of documentation of the"); disp ("calculations and some reasoning about why. Plots of the results are"); disp ("presented in most cases."); disp (""); disp ("Often, when multiple plots are displayed, they may be overlaid"); disp ("on the screen. You may use the mouse and move them for better viewing."); disp (""); disp ("The process is to display a 'screen' page of text followed by the"); disp ("calculation and a 'Press return to continue' message. To proceed in"); disp ("the example, press return. ^C to exit."); disp (""); disp ("At one point in the calculations, the process may seem to hang, but,"); disp ("this is because of extensive calculations."); disp (""); disp ("The returned transfer function is more than 100 characters long so"); disp ("will wrap in screens that are narrow and appear jumbled."); disp (""); ## input ("Press Return to continue:"); blanks (); ## disp (""); disp ("The amplifier consists of two AD797 op amps and a low pass filter."); disp ("With biasing and blocking capacitors omitted, three blocks remain."); disp (""); disp (""); disp (" Gain = 10"); disp (" +-------------+"); disp (" | | -- Low Pass Filter --"); disp (" ---+ p |"); disp (" Loop | Stage 1 +--+----R3--+--R4--+--R5--+---> To Stage 2"); disp (" | Amplifier | | | | |"); disp (" -+-+ n | | C1 C2 C3"); disp (" | | | | | | |"); disp (" | +-------------+ | Gnd Gnd Gnd"); disp (" | |"); disp (" +----+---R2--------+"); disp (" |"); disp (" R1"); disp (" |"); disp (" Gnd"); disp (""); disp (""); disp (""); disp (" Gain = 10"); disp (" +-------------+"); disp (" | |"); disp (" Gnd--+ p |"); disp (" | Stage 2 +--+----R8--+----> Output"); disp (" | Amplifier | | |"); disp (" From >---+-+ n | | R9"); disp (" Filter | | | | |"); disp (" | +-------------+ | Gnd"); disp (" | |"); disp (" +----+---R6--------+"); disp (" |"); disp (" R7"); disp (" |"); disp (" Gnd"); disp (""); disp (""); disp ("R1 and R2 profide feedback to control the gain of Stage 1."); disp ("R3 through R5 with C1 through C3 form a low pass filter to limit the"); disp (" bandwidth."); disp ("R6 and R7 profide feedback to control the gain of Stage 2."); disp ("R8 and R9 provide impedance matching to the cable and/or receiver,"); disp (" possibly a PC sound card."); disp (""); ## input ("Press Return to continue:"); blanks (); ## disp (""); disp (""); disp ("The graphs in the ad797 datasheet reveal the following parameters:"); disp (""); show ("a0 = 1e7; ## Open Loop Gain"); show ("p1 = 55; ## Pole (Hz)"); show ("p2 = 1e6; ## Pole (Hz)"); show ("z1 = 4.3e6; ## Zero (Hz)"); disp (""); disp ("The open loop transfer function of an op amp with m zeros and n"); disp ("poles is expressed in the form:"); disp (" tf = open_loop_gain * zero_expressions / pole_expressions"); disp ("where "); disp (" zero_expressions = (1+s/z1) * (1+s/z2) * ... * (1+s/zm) "); disp (" pole_expressions = (1+s/p1) * (1+s/p2) * ... * (1+s/pn)"); disp (" z1 ... zm are the m zeros"); disp (" p1 ... pn are the n poles"); disp (""); ## input ("Press Return to continue:"); blanks (); ## disp (""); disp ("The amplifier stages have 1 zero and 2 poles:"); disp (""); show ("s = tf ('s')") disp (""); show ("TFopen = a0 * (1+s/z1) / (1+s/p1) / (1+s/p2)") disp (""); show ("TFopen_norm = minreal (TFopen)") disp (""); disp ("Note: The difference between the op amp expression and the usual"); disp ("Zero-Pole-Gain expression is in the modification of the gain"); disp ("parameter. The gain argument to zpk() is modified by the zeros"); disp ("and poles, so the derived transfer function matches actual"); disp ("measurements."); disp (""); show ("Azpk = zpk ([-z1], [-p1, -p2], 1e7*p1*p2/z1)") ## input ("Press Return to continue:"); blanks (); ## disp (""); disp ("The bode plot of these two open loop transfer functions produce"); disp ("identical results. And, the plots show the same shape as the"); disp ("graphs in the datasheet."); disp (""); show ("figure 1"); show ("bode (TFopen)"); show ("subplot (2,1,1)"); show ("title ('Equation Bode Diagram')"); show ("figure 2"); show ("bode (Azpk)"); show ("subplot (2,1,1)"); show ("title ('ZPK Bode Diagram')"); disp (""); disp ("Two Bode Diagrams should be visible, possibly overlaid."); disp (""); ## input ("Press Return to close the plots and continue:"); blanks (); ## close all; disp (""); disp ("The normalized step response of the ad797 is:"); disp (""); show ("TFnorm = TFopen/dcgain(TFopen)") disp (""); show ("step (TFnorm, 'b')"); show ("title ('AD797 Normalized Open-Loop Step Response')"); show ("ylabel ('Normalized Amplitude')"); disp (""); ## input ("Press Return to close the plot and continue:"); blanks (); ## close all; disp (""); disp ("--- Design Stage 1 of the VLFamp ---"); disp (""); disp ("Resistors R1 and R2 form a feedback system to control the gain of "); disp ("Stage 1. This feedback system returns a portion of the output to the"); disp ("negative input. This is normally expressed as:"); disp (" Vfb = Vout * R1 / (R1 + R2)"); disp ("So, the transfer function of the feedback network is:"); disp (" tf = Vfb / Vout = R1 / (R1 + R2)"); disp ("The effects of the AD797 gain on the input and the feedback may be "); disp ("represented as TFstage1 = Vout/Vp = gain / (1 + dcgain * TFfeedback)."); disp ("If dcgain is sufficiently large, this reduces to"); disp (" TFstage1 = 1 / TFfeedback."); disp ("The dcgain of the AD797 is >> 1, so, the feedback completely controls"); disp ("the output and variations in the dcgain will not effect the Stage gain."); disp (""); disp ("The feedback is added to the AD797 using the feedback function"); disp (""); show ("Gfb = 10"); show ("b = 1 / Gfb"); show ("R1 = 10e3"); show ("R2 = R1 * (1/b - 1)") disp (""); show ("TFstage1 = feedback (TFopen, b)"); disp (""); show ("bodemag (TFopen, 'r', TFstage1, 'b')"); show ("legend ('Open Loop Gain (TFopen)', 'Closed Loop Gain (TFstage1)')"); disp (""); disp ("The use of negative feedback to reduce the low-frequency (LF) gain"); disp ("has led to a corresponding increase in the system bandwidth (defined"); disp ("as the frequency where the gain drops 3dB below its maximum value)."); disp (""); disp ("With this feedback, we have a gain of 10, or 20db up to 10MHz,"); disp ("far more than the frequency range of interest."); disp (""); ## input ("Press Return to close the plot and continue:"); blanks (); ## close all; disp (""); disp ("Since the gain is now dominated by the feedback network, a useful"); disp ("relationship to consider is the sensitivity of this gain to variation"); disp ("in the op amp's open-loop gain."); disp (""); disp ("Before deriving the system sensitivity, however, it is useful to"); disp ("define the loop gain, L(s)=a(s)b(s), which is the total gain a signal"); disp ("experiences traveling around the loop:"); disp (""); disp ("Sensitivity = partial(TFstage1/TFopen)*TFopen/TFstage1"); disp ("or S(s) = 1 / (1 + TFopen(s) * TFstage1(s))"); disp ("or S(s) = 1 / (1 + L(s)), which has the same form as feedback"); disp ("So, use the feedback function to develop the sensitivity."); disp (""); show ("L = TFopen * b") disp (""); show ("Sens = feedback (1, L)") disp (""); show ("figure 1"); show ("bodemag (TFstage1, 'b', Sens, 'g')"); disp (""); disp ("The very small low-frequency sensitivity (more than -100 dB) indicates"); disp ("a design whose closed-loop gain suffers minimally from open-loop gain"); disp ("variation. Such variation in a(s) is common due to manufacturing"); disp ("variability, temperature change, etc."); disp (""); ## input ("Press Return to close the plot and continue:"); blanks (); ## disp (""); disp ("You can check the step response of A(s) using the STEP command:"); disp (""); show ("figure 2"); show ("step (TFstage1)"); disp (""); disp ("The stability margin can be analyzed by plotting the loop gain, L(s)"); disp ("with the margin function."); disp (" "); disp ("This plot may display warning messages, you can safely ignore them."); disp (" "); fflush(stdout); show ("margin (L)"); disp (" "); fflush(stdout); fflush(stderr); disp (" "); disp ("Two plots are displayed, possibly overlaid."); disp (" "); ## input ("Press Return to close the plots and continue:"); blanks (); ## disp (""); disp ("The plot indicates a phase margin of less than 3 degrees. Stage 1"); disp ("needs to be compensated to increase this to an acceptible level,"); disp ("more than 45 degrees, if possible."); disp (""); disp ("Feedback Lead Compensation"); disp (""); disp ("A commonly used method of compensation in this type of circuit is"); disp ("feedback lead compensation. This technique modifies b(s) by adding"); disp ("a capacitor, C, in parallel with the feedback resistor, R2."); disp ("The capacitor value is chosen so as to introduce a phase lead to b(s)"); disp ("near the crossover frequency, thus increasing the amplifier's phase"); disp ("margin."); disp ("The new feedback transfer function is shown below."); disp ("You can approximate a value for C by placing the zero of b(s) at the"); disp ("0dB crossover frequency of L(s):"); disp (""); show ("[Gm, Pm, Wcg, Wcp] = margin (L)"); show ("C = 1/(R2*Wcp)") disp (""); if (C < 1e-12) disp ("The calculated value of C is very small."); disp ("Now, look at a range of values."); endif; disp (" "); disp ("The next plots take some time..."); disp (" "); ## input ("Press Return to close the plot and continue:"); blanks (); ## close all; disp ("The next plots take some time..."); disp (""); show ("K = R1/(R1+R2);"); show ("C = [10:10:200]*1e-12;"); show ("b_array = arrayfun (@(C) tf ([K*R2*C, K], [K*R2*C, 1]), C,'uniformoutput',false);"); show ("A_array = cellfun (@feedback, {TFopen}, b_array, 'uniformoutput', false);"); show ("L_array = cellfun (@mtimes, {TFopen}, b_array, 'uniformoutput', false);"); show ("S_array = cellfun (@feedback, {1}, L_array, 'uniformoutput', false);"); disp (" "); fflush(stdout); show ("[Gm, Pm, Wcg, Wcp] = cellfun (@margin, L_array);"); disp (" "); close all show ("figure 1"); show ("step (TFstage1, 'r', A_array{:})"); show ("figure 2"); show ("bode (TFstage1, A_array{:})"); show ("figure 3"); show ("plot (C, Pm)"); show ("grid"); show ("xlabel ('Compensation Capacitor, C (pF)')"); show ("ylabel ('Phase Margin (deg)')"); show ("figure 4"); show ("step (A_array{C==50e-12}, 'r', A_array{C==100e-12}, 'b', A_array{C==200e-12}, 'g')"); show ("legend ('Compensated (50 pF)', 'Compensated (100 pF)', 'Compensated (200 pF)')"); disp (" "); disp ("Four plots are displayed, possibly overlaid."); disp (" "); ## input ("Press Return to close the plots and continue:"); blanks (); ## close all; disp (""); disp (""); disp (" Gain = 10"); disp (" +-------------+"); disp (" | |"); disp (" ---+ p |"); disp (" Loop | Stage 1 +--+---->"); disp (" | Amplifier | |"); disp (" -+-+ n | |"); disp (" | | | |"); disp (" | +-------------+ |"); disp (" | |"); disp (" +----+------R2-----+"); disp (" | |"); disp (" +-----Ccomp---+"); disp (" |"); disp (" |"); disp (" R1"); disp (" |"); disp (" Gnd"); disp (""); disp ("The selected compensation capacitor is 100pf."); show ("TFcomp = A_array{C==100e-12}"); show ("bode (TFopen, 'b', TFstage1, 'g', TFcomp, 'r')"); show ("legend ('TFopen', 'TFstage1', 'TFcomp')"); disp (""); ## input ("Press Return to close the plot and continue:"); blanks (); ## close all; disp (""); disp ("--- Low Pass Filter Design ---"); disp (""); disp ("The low pass filter is composed of three equal sections."); disp ("Develop one section and put three in series."); disp (""); show ("C = 20e-9"); show ("R = 1000"); show ("TFsection = tf ([1], [C*R, 1])"); disp (""); show ("TFfilter = TFsection * TFsection * TFsection;"); if (verbose) TFfilter endif; disp (""); disp ("---- Final Design ----"); disp (""); disp ("The final configuration is: AD797 --> LP Filter --> AD797"); disp (""); show ("TFpreamp = TFcomp * TFfilter * TFcomp;"); show ("figure 1"); show ("bode (TFpreamp, {1, 1e5})"); show ("figure 2"); show ("margin (TFpreamp)"); disp (""); disp ("Two plots are displayed, possibly overlaid."); disp (""); ## input ("Press Return to close the plots and continue:"); blanks (); ## disp (""); disp ("As can be seen from the plots, the gain margin is almost 30db."); disp ("The phase margin is 230 degrees."); disp (""); ## disp ("Use 'close all' to close the plots."); ## close all blanks (); disp ("The resultant transfer function is over 100 characters long"); disp ("and will appear jumbled on narrower screens."); disp (""); show ("TFpreamp") ## if (nargout > 0) retval = TFpreamp; endif endfunction ## support function to display a command and then ## execute it in the caller's environment. function show (str) disp ([">> ", str]); evalin ("caller", str); endfunction ## support function to insert blank lines in the display function blanks (n = 5) for idx = 1:n disp (""); endfor endfunction control-4.1.2/inst/PaxHeaders/rlocusx.m0000644000000000000000000000007415012430645015113 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/rlocusx.m0000644000175000017500000004727515012430645016321 0ustar00lilgelilge00000000000000## Copyright (C) 2012 - 2020 Torsten Lilge ## ## 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 2 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 Octave; see the file COPYING. If not, see ## . ## -*- texinfo -*- ## @deftypefn {Function File} {} rlocusx (@var{sys}) ## @deftypefnx {Function File} {} rlocusx (@var{sys}, @var{increment}, @var{min_k}, @var{max_k}) ## Interactive root locus plot of the specified SISO system @var{SYS}. ## ## This functions ## directly calls rlocus() from the control package ## which must be installed and loaded. ## In contrast to rlocus(), mouse clicks on the root locus display ## the related gain and all other poles resulting from this gain ## together with damping and frequency of conjugate complex pole pairs.@* ## All possible interaction by mouse clicks or keys are: ## ## @table @asis ## @item Left click: Gain, damping and Frequency ## Displays related gain and all resulting ## closed loop poles together with damping ## and frequency ## @item @kbd{s}: Step response ## Simulates the step response for the gain of ## of the most recently selected pole locations ## @item @kbd{i}: Impulse response ## Simulates the impulse response for the most ## recently selected gain ## @item @kbd{b}: Bode plot ## Provides the open loop bode plot for the most ## recently selected gain ## @item @kbd{m}: Stability margins ## Provides the open loop bode plot with stability ## margins for the most recently selected gain ## @item @kbd{a}: All plots ## Provide sall four aforementioned plots ## @item @kbd{c}: Clear ## Removes all closed loop pole markers and annotations ## @item @kbd{d}: Delete ## Removes all open figures with simulation and ## bode plots ## @item @kbd{x}: Exit ## Exits the interactive mode and re-activates ## the octave prompt ## @end table ## ## There are no output parameters. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. Must be a single-input and single-output (SISO) system. ## @item increment ## The increment used in computing gain values. ## @item min_k ## Minimum value of @var{k}. ## @item max_k ## Maximum value of @var{k}. ## @end table ## ## @strong{Outputs} ## ## Plots the interactive root locus to the screen. @* ## Unlike rlocus(), this function does not have any output parameters. ## For output parameters please directly use rlocus(). ## ## @seealso{rlocus} ## ## @end deftypefn ## Author: Torsten Lilge ## Date: April 2020 ## Version: 0.1 function rlocusx(sys,varargin) global fig_h % Check the input parameters if ( nargin < 1 || nargin >4 ) print_usage(); % wrong number, so print usage end; if (! isa (sys, "lti") || ! issiso (sys)) error ('rlocusx: first argument must be a SISO LTI model'); endif % Call rlocus depending on number of arguments switch (nargin) case 1 [rldata, k_break, rlpol, gvec, real_ax_pts] = rlocus(sys); case 2 % compatibility with matlab kk = varargin{1}; % get the desired gains len_kk = size (kk); if (max (len_kk) < 2) || (min (len_kk) > 1) error ('rlocusx: second parameter has to be a one dimensional list with at least two elements'); endif [rldata, k_break, rlpol, gvec, real_ax_pts] = rlocus(sys,(kk(end)-kk(1))/(max(size(kk))-1),kk(1),kk(end)); case 3 print_usage(); % wrong number, so print usage case 4 kinc=varargin{1}; kstart=varargin{2}; kend=varargin{3}; [rldata, k_break, rlpol, gvec, real_ax_pts] = rlocus(sys,kinc,kstart,kend); endswitch; % Remove additional gain values (why do they exists sometimes?) while ( size(gvec,2) > size(rlpol,2) ) gvec(end) = []; end; % Remove double entries (rlocus sometimes seems to "stuck" at the same gain for % several calculated points; duplicate entries breaks later use of interp1 len_gvec = size(gvec,2); j = 2; while (j <= len_gvec) if (gvec(j) == gvec(j-1)) % if the same as the one before gvec(j) = []; % delete this entry in the gains rlpol(:,j) = []; % and delete the related closed loop poles len_gvec--; else j++; end end % Following calculations are based on open loop data % in "rlocus canonical form" [z,p,V,tsam]=zpkdata(sys,'v'); if ( V < 0 ) V = abs(V); % take the absolute and move the minus into the feedback negfb = 0; % thus, we get pos. feddback else negfb = 1; % neg. feedback is assumed by default end n = length(p); % n: number of open loop poles m = length(z); % m: number of open loop zeros nm= n-m; % we will need the difference more than once % Scaling of the plot: get some min/max values xlim('manual'); % manual scaling x-axis ylim('manual'); % manual scaling y-axis nrl = numel(rlpol); im = reshape(imag(rlpol),[1,nrl]); re = reshape(real(rlpol),[1,nrl]); xmin = min(re); xmax = max(re); ymin = min(im); ymax = max(im); % Intersection of asymptotes if ( nm > 0 ) sigmaw = (sum(p)-sum(z))/nm; xmin = min(xmin,sigmaw); xmax = max(xmax,sigmaw); end % Scale while making sure that all relevant information is included for j=1:m xmin = min(xmin,real(z(j))); xmax = max(xmax,real(z(j))); ymin = min(ymin,imag(z(j))); ymax = max(ymax,imag(z(j))); end; dx = (xmax-xmin)/20; dy = (ymax-ymin)/20; if ( dx < 0.0001 ) dx = dy; end; if ( dy < 0.0001 ) dy = dx; end; xmin = xmin-dx; xmax = xmax+dx; ymin = ymin-dy; ymax = ymax+dy; % Some constants for colors and markers col_z = [0.0000 0.7500 0.0000]; % color of open loop zeros and poles col_p = [0.7500 0.0000 0.0000]; % color of open loop zeros and poles col_clp = [0.1000 0.1000 0.1000]; % color of closed loop poles col_rl1 = [0.0000 0.4470 0.7410]; % color of first branch of rlocus col_rl2 = [0.3010 0.7450 0.9330]; % color of last branch of rlocus col_y = [0.0000 0.4470 0.7410]; % color closed loop output y col_r = [0.8500 0.3250 0.0980]; % color closed loop reference col_cp = [0.4940 0.1840 0.5560]; % color of current cl poles simulated lw = 2; % general line width lw_mark = 2; % line width of markers lw_asym = 1; % line width of asymptotes lw_stab = 1; % line width for region of stability % Marker size depending on engine ms = 10; if (strcmp(graphics_toolkit(),'gnuplot')) ms = 6; endif % define a cell array for storing the figures with the % Title and lables clf (gcf ()); rlocus_fig = gcf (); % remember for resetting focus to this figure name = inputname (1); if (! isempty (name)) name = [name, ' ']; endif title_string = sprintf ('Root loucs %s(K = %.3f .. %.3f)', name, gvec(1), gvec(end)); set (gcf (), 'numbertitle', 'off'); set (gcf (), 'name', title_string); title('click: gain, s/i: step/imp., b/m: bode/margin, a: all, c: clear, d: del fig., x: end'); box on; hold on; % from here on, do not delete what is drawn so far % Draw the stability region and put axes labels depending % on the domain (continuous ot discrete) if ( tsam > 0 ) % discrete time xlabel('Real axis'); % z-plane: just real and imag axis ylabel('Imag. axis'); t = 0:0.05:6.3; plot(cos(t),sin(t),'-k'); % draw the unit circle (stability) else xlabel('Real axis: \sigma'); % s-plane: sigma + j omega ylabel('Imag. axis: \omega'); plot([0,0],[ymin,ymax],'-k'); % draw imag axis (stability) end % Disable legend autoupdate, '' avoids a dummy entry 'data 1' legend ('','autoupdate','off'); % Draw the open poles and zeros plot(real(p),imag(p),'x;open loop poles;','markersize',ms,'linewidth',lw,'color',col_p); plot(real(z),imag(z),'o;open loop zeros;','markersize',ms,'linewidth',lw,'color',col_z); % Draw root locii for j = 1:n if ( j == 1 ) % legend only once form = '-;locus;'; else form = '-'; endif if ( n > 1 ) % each branch in a slightly different color cj = (j-1)/(n-1); else cj = 0; endif col = col_rl2*cj + col_rl1*(1-cj); plot(real(rlpol(j,:)),imag(rlpol(j,:)),form,'linewidth',lw,'color',col); end grid on % Draw the asymptotes if ( nm > 0 ) % only if there are asymptotes aslen = max(abs(sigmaw - [ xmin xmax ymin ymax ])); % the max visible length for j = 1:nm % loop for all asymptotes ang = (2*(j-1)+negfb)*pi/nm; % the angle of the asymptotes endp = [sigmaw,0] + aslen*[cos(ang),sin(ang)]; % the endpoint if ( j == 1 ) % legend only once form = '--;asymptotes;'; else form = '--'; end plot( [sigmaw, endp(1)], [0 endp(2)], form, 'color',[0.4,0.4,0.8] ); % finally plot it end end % Nice shaping and legend xlim([xmin,xmax]); ylim([ymin,ymax]); legend ('location','northwest'); % Possible input values for ginput m_left = 1; % left mouse button b_all = 97; % 'a' b_clr = 99; % 'c' b_del = 100; % 'd' b_exit = 120; % 'x' b_step = 115; % 's' b_imp = 105; % 'i' b_bode = 98; % 'b' b_marg = 109; % 'm' % Data of plots that can could be required for selected closed loop poles fig_h = []; % Keep track of the figure handles that are used % for simulations and bode plots for a specific K, % rows: [K, fig step, fig imp, fog bode, fig margin] % Order of the plots, the first entry is a dummy for directly matching fig_h fig_b = [-1, b_step, b_imp, b_bode, b_marg]; fig_n = {'','Step response (closed loop)','Imp. response (closed loop)',... 'Bode plot (open loop)','Margin plot (open loop)'}; % Some initializations button = 1; % current button, not b_exit first = 1; % counter for closed loop poles handles = []; % list of handels for closed loop poles and text handle_sim_poles = 0; % handles of closed loop poles with extra plots % As long as exit b_exit was not used while (button != b_exit) % loop over all ginput values until 'x' [x,y,button] = ginput(1); % wait for mouse/key event if length (button) == 0 % No button -> figure was closed: Reset fig_h for not accessing % invalid handles in the close callbacks of remaining figures fig_h = []; return; endif if button == b_all % plot all diagrams btns = fig_b; else btns = [button]; endif for b = 1:length(btns) % for all buttons (e.g., selected via "all") but = btns(b); % the current button to handle here switch but % which mousen key or key? % left mouse key: markers and info for related root locus case ( m_left ) s = x+y*i; % actual position in s-plane % rule 12 -> K_WOK, then divide by V (gain in zpk-form) gives real K K_tmp = prod(abs(s-p))/prod(abs(s-z))/V; % check if mouse click was really near to these locations distance = xmax - xmin; for j=1:n % for all poles poles(j) = interp1(gvec',rlpol'(:,j),K_tmp,'extrap'); % look up closed loop poles at our gain if abs (s-poles(j)) < distance distance = abs (s-poles(j)); endif endfor % Plot all poles if we are "quite near" to the poles that belong to % the gain that was calculated from the click position if distance < (xmax - xmin)/25 % Store gain K = K_tmp; % Plot closed loop together with related gain for j=1:n % for all poles x = real(poles(j)); % get real part y = imag(poles(j)); % and imaginary part if ( first ) % legend only once form = 'x;closed loop poles;'; first = 0; else form = 'x'; end % Plot the pole in the s plane h1 = plot (x,y,form, "markersize",ms*2/3,'linewidth',lw_mark,'color',col_clp); % Put the text with related parameters if ( y == 0*i ) % if on real axis rotate text with gain str = sprintf(" K=%.2f",K); % make a string from our gain h2 = text (x,y,str,'color',col_clp,'fontsize',10,'rotation',90); else % if not on real axis, text normal if ( tsam > 0 ) % calc related cont. pole if we s = log(x+y*i)/sys.tsam; % are in discrete time xs= real(s); ys= imag(s); else xs= x; ys= y; endif w0 = abs(xs+ys*i); % get omega_0 D = -xs/w0; % and damping str = sprintf(" K=%.2f, D=%.2f, w_0=%.2f",K,D,w0); h2 = text(x,y,str,'color',col_clp,'fontsize',10); % put the text endif handles = horzcat(handles,[h2 h1]); % store marker & text handles for % being able to remove them later endfor endif % if near enough to the closed loop poles % 's', 'i', 'b', 'm': simulate closed loop or/and plot bode % with most recently selected poles case ({b_step, b_imp, b_bode, b_marg}) if (! isempty (handles)) && (length (handles) >= 2*n) % handles for text and poles are not empty and contains 2n entries % (n poles and n texts), thus simulate and give related poles a % different color % Look for current K in the array of used figures if length (fig_h) == 0 K_exists = 0; K_idx = 0; else [K_exists, K_idx] = ismember (K, fig_h(:,1)); endif [b_exists, b_idx] = ismember (but, fig_b); if ! (K_exists && ishandle (fig_h(K_idx, b_idx))) % The desired figure does not yet exist if ! K_exists % Current K does not exist yet fig_h(end+1,1) = K; % new row K_idx = size (fig_h,1); % Initialize with invalid handles (fig_b is one element too long) fig_h(K_idx,2:2+length (fig_b)-2) = -1*ones (1,length (fig_b)-1); for j = 2:size(fig_h,2) endfor % update color of the related poles handle_sim_poles = handles(end-2*n+1:end); for j = 1:length (handle_sim_poles) set (handle_sim_poles(j), 'color', col_cp); endfor endif % Create figure for desired plot and make sure, it is not hidden % behind the main figure main_pos = get (gcf (), 'position'); fig_h(K_idx, b_idx) = ... figure ('DeleteFcn', {@__sim_fig_close_callback__, handle_sim_poles, col_clp},... 'name',['K = ',num2str(K),': ',fig_n{b_idx}],... 'numbertitle','off',... 'visible', 'off'); child_pos = get (fig_h(K_idx, b_idx), 'position'); for i = 1:2 if (child_pos(i) == main_pos(i)) child_pos(i) = child_pos(i) + (-1)^i*child_pos(i+2)/4; endif endfor set (fig_h(K_idx, b_idx), 'position', child_pos, 'visible', 'on'); % Do the desired plots switch (but) case {b_step, b_imp} % Simulate and plot the closed loop response grid on; hold on; if tsam > 0 xlabel ('k'); else xlabel ('t'); endif closed_loop = feedback (K*sys, 1); if (but == b_step) [y,t] = step (closed_loop); plot ([t(1),t(end)],[1 1],'linewidth',0.75*lw,'color',col_r); if (tsam > 0) [t,y] = stairs (t,y); endif plot (t,y,'linewidth',0.75*lw,'color',col_y); ylabel ('closed loop output and reference'); title ({['Closed loop step response y for K = ',num2str(K)] }); legend ('reference y_r','output y'); elseif (but == b_imp) [y,t] = impulse (closed_loop); if (tsam > 0) [t,y] = stairs (t,y); endif plot (t,y,'linewidth',0.75*lw,'color',col_y); ylabel ('impulse responce output and reference'); title ({['Closed loop impulse response y for K = ',num2str(K)] }); legend ('output y'); endif case {b_bode} % Bode plot of open loop bode (K*sys) case {b_marg} % Bode plot of open loop margin (K*sys) endswitch figure (rlocus_fig) % reset focus to root locus for ginput () endif endif % Delete all closed loop markers case b_clr for j = 1:numel(handles) delete(handles(j)); endfor handles=[]; % Delete all existing figures related to closed loops case b_del % Collect extra figures that have to be closed from fig_h % and close them afterwards since closing will change fig_h % in the close callback figs_to_close = []; for j = 1:size (fig_h,1) for jj = 2:size (fig_h,2) if isfigure (fig_h(j,jj)) figs_to_close(end+1) = fig_h(j,jj); endif endfor endfor % Close the figures and clean up for j = 1:length (figs_to_close) close (figs_to_close(j)); endfor fig_h = []; endswitch endfor endwhile % 'x' -> Cleaning up: Reset fig_h for not accessing invalid handles % in the close callbacks of remaining figures. Reset the hold property, % following plots should delete this remaining one fig_h = []; hold off; endfunction; ## ## Callback when closing figures with the closed loop step response. ## In this callback, the colors of the related closed loop poles together ## with their labels K, D, w0n are reeset to the 'normal' color ## function __sim_fig_close_callback__ (h, e, handles, col_clp) global fig_h % Test whether fig_h is a valid array. If not, main figure may already % be closed if length (fig_h) == 0 return; % Nothing to do here endif % Search for handle of closed figure in our array for j = 1:size (fig_h,1) [h_exists, h_idx] = ismember (h, fig_h(j,:)); if h_exists fig_h(j,h_idx) = -1; % Remove handle of closed figure K_row = j; break; endif endfor % If not found, return (should not happen) if ! exist ('K_row') return; endif % Is there another figure for this K? no_figure = 1; for j = 2:length (fig_h(K_row,:)) if ishandle (fig_h(K_row,j)) no_figure = 0; break; endif endfor if no_figure % No more figure, so reset color of closed loop poles and remove K for j = 1:length (handles) if ishandle (handles(j)) set (handles(j), 'color', col_clp); endif endfor fig_h(K_row,:) = []; endif endfunction control-4.1.2/inst/PaxHeaders/ncfsyn.m0000644000000000000000000000007415012430645014714 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/ncfsyn.m0000644000175000017500000004747215012430645016121 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{K}, @var{N}, @var{gamma}, @var{info}] =} ncfsyn (@var{G}, @var{W1}, @var{W2}, @var{factor}) ## Loop shaping H-infinity synthesis. Compute positive feedback controller using ## the McFarlane/Glover loop shaping design procedure [1]. ## Using a precompensator @var{W1} and/or a postcompensator @var{W2}, the singular values ## of the nominal plant @var{G} are shaped to give a desired open-loop shape. ## The nominal plant @var{G} and shaping functions @var{W1}, @var{W2} are combined to ## form the shaped plant, @var{Gs} where @code{Gs = W2 G W1}. ## We assume that @var{W1} and @var{W2} are such that @var{Gs} contains no hidden modes. ## It is relatively easy to approximate the closed-loop requirements by the following ## open-loop objectives [2]: ## ## @enumerate ## @item For @emph{disturbance rejection} make ## @tex ## \(\underline{\sigma}(W_2 G W_1)\) ## @end tex ## @ifnottex ## @example ## sigma_l (W2 G W1) ## @end example ## @end ifnottex ## large; valid for frequencies at which ## @tex ## \(\underline{\sigma}(G_S) \gg 1\). ## @end tex ## @ifnottex ## @example ## sigma_l (Gs) >> 1. ## @end example ## @end ifnottex ## @item For @emph{noise attenuation} make ## @tex ## \(\overline{\sigma}(W_2 G W_1)\) ## @end tex ## @ifnottex ## @example ## sigma_h (W2 G W1) ## @end example ## @end ifnottex ## small; valid for frequencies at which ## @tex ## \(\overline{\sigma}(G_S) \ll 1\). ## @end tex ## @ifnottex ## @example ## sigma_h (Gs) << 1 ## @end example ## @end ifnottex ## @item For @emph{reference tracking} make ## @tex ## \(\underline{\sigma}(W_2 G W_1)\) ## @end tex ## @ifnottex ## @example ## sigma_l (W2 G W1) ## @end example ## @end ifnottex ## large; valid for frequencies at which ## @tex ## \(\underline{\sigma}(G_S) \gg 1\). ## @end tex ## @ifnottex ## @example ## sigma_l (Gs) >> 1 ## @end example ## @end ifnottex ## @item For @emph{robust stability} to a multiplicative output perturbation ## @tex ## \(G_p = (I + \Delta) G\) ## @end tex ## @ifnottex ## @example ## Gp = (I + Delta) G ## @end example ## @end ifnottex ## make ## @tex ## \(\overline{\sigma}(W_2 G W_1)\) ## @end tex ## @ifnottex ## @example ## sigma_h (W2 G W1) ## @end example ## @end ifnottex ## small; valid for frequencies at which ## @tex ## \(\overline{\sigma}(G_S) \ll 1\). ## @end tex ## @ifnottex ## @example ## sigma_h (Gs) << 1 ## @end example ## @end ifnottex ## @end enumerate ## Then a stabilizing controller @var{Ks} is synthesized for shaped plant @var{Gs}. ## The final positive feedback controller @var{K} is then constructed by combining ## the ## @tex ## \(H_{\infty}\) ## @end tex ## @ifnottex ## @example ## H-infinity ## @end example ## @end ifnottex ## controller @var{Ks} with the shaping functions @var{W1} and @var{W2} ## such that @code{K = W1 Ks W2}. ## In [1] is stated further that the given robust stabilization objective can be ## interpreted as a ## @tex ## \(H_{\infty}\) ## @end tex ## @ifnottex ## @example ## H-infinity ## @end example ## @end ifnottex ## problem formulation of minimizing the ## @tex ## \(H_{\infty}\) ## @end tex ## @ifnottex ## @example ## H-infinity ## @end example ## @end ifnottex ## norm of the frequency weighted gain from disturbances on the plant input and output ## to the controller input and output as follows: ## @tex ## $$ \underset{K}{\min} \, || N(K) ||_{\infty}, $$ ## $$ N = | W_{1}^{-1}; W_2 G | \ (I - K G)^{-1} \ | W_1, \ G W_{2}^{-1} | $$ ## @end tex ## @ifnottex ## @example ## @verbatim ## -1 -1 -1 ## min || N(K) || , N = | W1 | (I - K G) | W1 G W2 | ## K oo | W2 G | ## @end verbatim ## @end example ## @end ifnottex ## ## @code{[K, N] = ncfsyn (G, W1, W2, f)} ## The function @command{ncfsyn} - the somewhat cryptic name stands ## for @emph{normalized coprime factorization synthesis} - allows the specification of ## an additional argument, factor @var{f}. Default value @code{f = 1} implies that an ## optimal controller is required, whereas @code{f > 1} implies that a suboptimal ## controller is required, achieving a performance that is @var{f} times less than optimal. ## ## ## @strong{Inputs} ## @table @var ## @item G ## @acronym{LTI} model of plant. ## @item W1 ## @acronym{LTI} model of precompensator. Model must be SISO or of appropriate size. ## An identity matrix is taken if @var{W1} is not specified or if an empty model ## @code{[]} is passed. ## @item W2 ## @acronym{LTI} model of postcompensator. Model must be SISO or of appropriate size. ## An identity matrix is taken if @var{W2} is not specified or if an empty model ## @code{[]} is passed. ## @item factor ## @code{factor = 1} implies that an optimal controller is required. ## @code{factor > 1} implies that a suboptimal controller is required, ## achieving a performance that is @var{factor} times less than optimal. ## Default value is 1. ## @end table ## ## @strong{Outputs} ## @table @var ## @item K ## State-space model of the H-infinity loop-shaping controller. ## Note that @var{K} is a @emph{positive} feedback controller. ## @item N ## State-space model of the closed loop depicted below. ## @item info ## Structure containing additional information. ## @item info.gamma ## L-infinity norm of @var{N}. @code{gamma = norm (N, inf)}. ## @item info.emax ## Nugap robustness. @code{emax = inv (gamma)}. ## @item info.Gs ## Shaped plant. @code{Gs = W2 * G * W1}. ## @item info.Ks ## Controller for shaped plant. @code{Ks = ncfsyn (Gs)}. ## @item info.rcond ## Estimates of the reciprocal condition numbers of the Riccati equations ## and a few other things. For details, see the description of the ## corresponding SLICOT routine. ## @end table ## ## @strong{Block Diagram of N} ## @example ## @group ## @verbatim ## ^ z1 ^ z2 ## | | ## w1 + | +--------+ | +--------+ ## ----->(+)---+-->| Ks |----+--->(+)---->| Gs |----+ ## ^ + +--------+ ^ +--------+ | ## | w2 | | ## | | ## +-------------------------------------------------+ ## @end verbatim ## @end group ## @end example ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB10ID, SB10KD and SB10ZD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @strong{References}@* ## [1] D. McFarlane and K. Glover, ## @cite{A Loop Shaping Design Procedure Using H-infinity Synthesis}, ## IEEE Transactions on Automatic Control, Vol. 37, No. 6, June 1992.@* ## [2] S. Skogestad and I. Postlethwaite, ## @cite{Multivariable Feedback Control: Analysis and Design: ## Second Edition}. Wiley, Chichester, England, 2005.@* ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: July 2011 ## Version: 0.3 function [K, varargout] = ncfsyn (G, W1 = [], W2 = [], factor = 1.0) if (nargin == 0 || nargin > 4) print_usage (); endif if (! isa (G, "lti")) error ("ncfsyn: first argument must be an LTI system"); endif if (! is_real_scalar (factor) || factor < 1.0) error ("ncfsyn: fourth argument invalid"); endif [p, m] = size (G); W1 = __adjust_weighting__ (W1, m); W2 = __adjust_weighting__ (W2, p); Gs = W2 * G * W1; # shaped plant [a, b, c, d, tsam] = ssdata (Gs); ## synthesis if (isct (Gs)) # continuous-time [ak, bk, ck, dk, rcond] = __sl_sb10id__ (a, b, c, d, factor); elseif (any (d(:))) # discrete-time, d != 0 [ak, bk, ck, dk, rcond] = __sl_sb10zd__ (a, b, c, d, factor, 0.0); else # discrete-time, d == 0 [ak, bk, ck, dk, rcond] = __sl_sb10kd__ (a, b, c, factor); endif ## controller Ks = ss (ak, bk, ck, dk, tsam); K = W1 * Ks * W2; if (nargout > 1) ## FIXME: is this really the same thing as the dark side does? N = blkdiag (eye (p), Ks, Gs); M = [zeros(p,p), zeros(p,m), eye(p); eye(p), zeros(p,m), zeros(p,p); zeros(m,p), eye(m), zeros(m,p)]; in_idx = [1:p, 2*p+(1:m)]; out_idx = 1:p+m; N = mconnect (N, M, in_idx, out_idx); varargout{1} = N; if (nargout > 2) gamma = norm (N, inf); varargout{2} = gamma; if (nargout > 3) varargout{3} = struct ("gamma", gamma, "emax", inv (gamma), "Gs", Gs, "Ks", Ks, "rcond", rcond); endif endif endif endfunction function W = __adjust_weighting__ (W, s) if (isempty (W)) W = ss (eye (s)); else W = ss (W); ## if (! isstable (W)) ## error ("ncfsyn: %s must be stable", inputname (1)); ## endif ## if (! isminimumphase (W)) ## error ("ncfsyn: %s must be minimum-phase", inputname (1)); ## endif [p, m] = size (W); if (m == s && p == s) # model is of correct size return; elseif (m == 1 && p == 1) # model is SISO tmp = cell (s, 1); tmp(1:s) = W; W = blkdiag (tmp{:}); # stack SISO model s times else # model is invalid error ("ncfsyn: %s must have 1 or %d inputs and outputs", inputname (1), s); endif endif endfunction ## continuous-time case, direct access to sb10id %!shared AK, BK, CK, DK, RCOND, AKe, BKe, CKe, DKe, RCONDe %! 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 0.0 %! -5.0 -7.0 %! 4.0 -6.0 %! -3.0 9.0 %! 1.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 ]; %! %! D = [ 1.0 -2.0 %! 0.0 4.0 %! 5.0 -3.0 ]; %! %! FACTOR = 1.0; %! %! [AK, BK, CK, DK, RCOND] = __sl_sb10id__ (A, B, C, D, FACTOR); %! %! AKe = [ -39.0671 9.9293 22.2322 -27.4113 43.8655 %! -6.6117 3.0006 11.0878 -11.4130 15.4269 %! 33.6805 -6.6934 -23.9953 14.1438 -33.4358 %! -32.3191 9.7316 25.4033 -24.0473 42.0517 %! -44.1655 18.7767 34.8873 -42.4369 50.8437 ]; %! %! BKe = [ -10.2905 -16.5382 -10.9782 %! -4.3598 -8.7525 -5.1447 %! 6.5962 1.8975 6.2316 %! -9.8770 -14.7041 -11.8778 %! -9.6726 -22.7309 -18.2692 ]; %! %! CKe = [ -0.6647 -0.0599 -1.0376 0.5619 1.7297 %! -8.4202 3.9573 7.3094 -7.6283 10.6768 ]; %! %! DKe = [ 0.8466 0.4979 -0.6993 %! -1.2226 -4.8689 -4.5056 ]; %! %! RCONDe = [ 0.13861D-01 0.90541D-02 ].'; %! %!assert (AK, AKe, 1e-4); %!assert (BK, BKe, 1e-4); %!assert (CK, CKe, 1e-4); %!assert (DK, DKe, 1e-4); %!assert (RCOND, RCONDe, 1e-4); ## continuous-time case %!shared AK, BK, CK, DK, RCOND, AKe, BKe, CKe, DKe, RCONDe %! 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 0.0 %! -5.0 -7.0 %! 4.0 -6.0 %! -3.0 9.0 %! 1.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 ]; %! %! D = [ 1.0 -2.0 %! 0.0 4.0 %! 5.0 -3.0 ]; %! %! FACTOR = 1.0; %! %! G = ss (A, B, C, D); %! K = ncfsyn (G, [], [], FACTOR); %! [AK, BK, CK, DK] = ssdata (K); %! %! AKe = [ -39.0671 9.9293 22.2322 -27.4113 43.8655 %! -6.6117 3.0006 11.0878 -11.4130 15.4269 %! 33.6805 -6.6934 -23.9953 14.1438 -33.4358 %! -32.3191 9.7316 25.4033 -24.0473 42.0517 %! -44.1655 18.7767 34.8873 -42.4369 50.8437 ]; %! %! BKe = [ -10.2905 -16.5382 -10.9782 %! -4.3598 -8.7525 -5.1447 %! 6.5962 1.8975 6.2316 %! -9.8770 -14.7041 -11.8778 %! -9.6726 -22.7309 -18.2692 ]; %! %! CKe = [ -0.6647 -0.0599 -1.0376 0.5619 1.7297 %! -8.4202 3.9573 7.3094 -7.6283 10.6768 ]; %! %! DKe = [ 0.8466 0.4979 -0.6993 %! -1.2226 -4.8689 -4.5056 ]; %! %! RCONDe = [ 0.13861D-01 0.90541D-02 ]; %! %!assert (AK, AKe, 1e-4); %!assert (BK, BKe, 1e-4); %!assert (CK, CKe, 1e-4); %!assert (DK, DKe, 1e-4); ## discrete-time case D==0, direct access to sb10kd %!shared AK, BK, CK, DK, RCOND, AKe, BKe, CKe, DKe, RCONDe %! A = [ 0.2 0.0 0.3 0.0 -0.3 -0.1 %! -0.3 0.2 -0.4 -0.3 0.0 0.0 %! -0.1 0.1 -0.1 0.0 0.0 -0.3 %! 0.1 0.0 0.0 -0.1 -0.1 0.0 %! 0.0 0.3 0.6 0.2 0.1 -0.4 %! 0.2 -0.4 0.0 0.0 0.2 -0.2 ]; %! %! B = [ -1.0 -2.0 %! 1.0 3.0 %! -3.0 -4.0 %! 1.0 -2.0 %! 0.0 1.0 %! 1.0 5.0 ]; %! %! C = [ 1.0 -1.0 2.0 -2.0 0.0 -3.0 %! -3.0 0.0 1.0 -1.0 1.0 -1.0 ]; %! %! FACTOR = 1.1; %! %! [AK, BK, CK, DK, RCOND] = __sl_sb10kd__ (A, B, C, FACTOR); %! %! AKe = [ 0.0337 0.0222 0.0858 0.1264 -0.1872 0.1547 %! 0.4457 0.0668 -0.2255 -0.3204 -0.4548 -0.0691 %! -0.2419 -0.2506 -0.0982 -0.1321 -0.0130 -0.0838 %! -0.4402 0.3654 -0.0335 -0.2444 0.6366 -0.6469 %! -0.3623 0.3854 0.4162 0.4502 0.0065 0.1261 %! -0.0121 -0.4377 0.0604 0.2265 -0.3389 0.4542 ]; %! %! BKe = [ 0.0931 -0.0269 %! -0.0872 0.1599 %! 0.0956 -0.1469 %! -0.1728 0.0129 %! 0.2022 -0.1154 %! 0.2419 -0.1737 ]; %! %! CKe = [ -0.3677 0.2188 0.0403 -0.0854 0.3564 -0.3535 %! 0.1624 -0.0708 0.0058 0.0606 -0.2163 0.1802 ]; %! %! DKe = [ -0.0857 -0.0246 %! 0.0460 0.0074 ]; %! %! RCONDe = [ 0.11269D-01 0.17596D-01 0.18225D+00 0.75968D-03 ].'; %! %!assert (AK, AKe, 1e-4); %!assert (BK, BKe, 1e-4); %!assert (CK, CKe, 1e-4); %!assert (DK, DKe, 1e-4); %!assert (RCOND, RCONDe, 1e-4); ## discrete-time case D==0 %!shared AK, BK, CK, DK, RCOND, AKe, BKe, CKe, DKe, RCONDe %! A = [ 0.2 0.0 0.3 0.0 -0.3 -0.1 %! -0.3 0.2 -0.4 -0.3 0.0 0.0 %! -0.1 0.1 -0.1 0.0 0.0 -0.3 %! 0.1 0.0 0.0 -0.1 -0.1 0.0 %! 0.0 0.3 0.6 0.2 0.1 -0.4 %! 0.2 -0.4 0.0 0.0 0.2 -0.2 ]; %! %! B = [ -1.0 -2.0 %! 1.0 3.0 %! -3.0 -4.0 %! 1.0 -2.0 %! 0.0 1.0 %! 1.0 5.0 ]; %! %! C = [ 1.0 -1.0 2.0 -2.0 0.0 -3.0 %! -3.0 0.0 1.0 -1.0 1.0 -1.0 ]; %! %! FACTOR = 1.1; %! %! G = ss (A, B, C, [], 1); # value of sampling time doesn't matter %! K = ncfsyn (G, [], [], FACTOR); %! [AK, BK, CK, DK] = ssdata (K); %! %! AKe = [ 0.0337 0.0222 0.0858 0.1264 -0.1872 0.1547 %! 0.4457 0.0668 -0.2255 -0.3204 -0.4548 -0.0691 %! -0.2419 -0.2506 -0.0982 -0.1321 -0.0130 -0.0838 %! -0.4402 0.3654 -0.0335 -0.2444 0.6366 -0.6469 %! -0.3623 0.3854 0.4162 0.4502 0.0065 0.1261 %! -0.0121 -0.4377 0.0604 0.2265 -0.3389 0.4542 ]; %! %! BKe = [ 0.0931 -0.0269 %! -0.0872 0.1599 %! 0.0956 -0.1469 %! -0.1728 0.0129 %! 0.2022 -0.1154 %! 0.2419 -0.1737 ]; %! %! CKe = [ -0.3677 0.2188 0.0403 -0.0854 0.3564 -0.3535 %! 0.1624 -0.0708 0.0058 0.0606 -0.2163 0.1802 ]; %! %! DKe = [ -0.0857 -0.0246 %! 0.0460 0.0074 ]; %! %! RCONDe = [ 0.11269D-01 0.17596D-01 0.18225D+00 0.75968D-03 ].'; %! %!assert (AK, AKe, 1e-4); %!assert (BK, BKe, 1e-4); %!assert (CK, CKe, 1e-4); %!assert (DK, DKe, 1e-4); ## discrete-time case D!=0, direct access to sb10zd %!shared AK, BK, CK, DK, RCOND, AKe, BKe, CKe, DKe, RCONDe %! A = [ 0.2 0.0 3.0 0.0 -0.3 -0.1 %! -3.0 0.2 -0.4 -0.3 0.0 0.0 %! -0.1 0.1 -1.0 0.0 0.0 -3.0 %! 1.0 0.0 0.0 -1.0 -1.0 0.0 %! 0.0 0.3 0.6 2.0 0.1 -0.4 %! 0.2 -4.0 0.0 0.0 0.2 -2.0 ]; %! %! B = [ -1.0 -2.0 %! 1.0 3.0 %! -3.0 -4.0 %! 1.0 -2.0 %! 0.0 1.0 %! 1.0 5.0 ]; %! %! C = [ 1.0 -1.0 2.0 -2.0 0.0 -3.0 %! -3.0 0.0 1.0 -1.0 1.0 -1.0 %! 2.0 4.0 -3.0 0.0 5.0 1.0 ]; %! %! D = [ 10.0 -6.0 %! -7.0 8.0 %! 2.0 -4.0 ]; %! %! FACTOR = 1.1; %! %! [AK, BK, CK, DK, RCOND] = __sl_sb10zd__ (A, B, C, D, FACTOR, 0.0); %! %! AKe = [ 1.0128 0.5101 -0.1546 1.1300 3.3759 0.4911 %! -2.1257 -1.4517 -0.4486 0.3493 -1.5506 -1.4296 %! -1.0930 -0.6026 -0.1344 0.2253 -1.5625 -0.6762 %! 0.3207 0.1698 0.2376 -1.1781 -0.8705 0.2896 %! 0.5017 0.9006 0.0668 2.3613 0.2049 0.3703 %! 1.0787 0.6703 0.2783 -0.7213 0.4918 0.7435 ]; %! %! BKe = [ 0.4132 0.3112 -0.8077 %! 0.2140 0.4253 0.1811 %! -0.0710 0.0807 0.3558 %! -0.0121 -0.2019 0.0249 %! 0.1047 0.1399 -0.0457 %! -0.2542 -0.3472 0.0523 ]; %! %! CKe = [ -0.0372 -0.0456 -0.0040 0.0962 -0.2059 -0.0571 %! 0.1999 0.2994 0.1335 -0.0251 -0.3108 0.2048 ]; %! %! DKe = [ 0.0629 -0.0022 0.0363 %! -0.0228 0.0195 0.0600 ]; %! %! RCONDe = [ 0.27949D-03 0.66679D-03 0.45677D-01 0.23433D-07 0.68495D-01 0.76854D-01 ].'; %! %!assert (AK, AKe, 1e-4); %!assert (BK, BKe, 1e-4); %!assert (CK, CKe, 1e-4); %!assert (DK, DKe, 1e-4); %!assert (RCOND, RCONDe, 1e-4); ## discrete-time case D!=0 %!shared AK, BK, CK, DK, RCOND, AKe, BKe, CKe, DKe, RCONDe %! A = [ 0.2 0.0 3.0 0.0 -0.3 -0.1 %! -3.0 0.2 -0.4 -0.3 0.0 0.0 %! -0.1 0.1 -1.0 0.0 0.0 -3.0 %! 1.0 0.0 0.0 -1.0 -1.0 0.0 %! 0.0 0.3 0.6 2.0 0.1 -0.4 %! 0.2 -4.0 0.0 0.0 0.2 -2.0 ]; %! %! B = [ -1.0 -2.0 %! 1.0 3.0 %! -3.0 -4.0 %! 1.0 -2.0 %! 0.0 1.0 %! 1.0 5.0 ]; %! %! C = [ 1.0 -1.0 2.0 -2.0 0.0 -3.0 %! -3.0 0.0 1.0 -1.0 1.0 -1.0 %! 2.0 4.0 -3.0 0.0 5.0 1.0 ]; %! %! D = [ 10.0 -6.0 %! -7.0 8.0 %! 2.0 -4.0 ]; %! %! FACTOR = 1.1; %! %! G = ss (A, B, C, D, 1); # value of sampling time doesn't matter %! K = ncfsyn (G, [], [], FACTOR); %! [AK, BK, CK, DK] = ssdata (K); %! %! AKe = [ 1.0128 0.5101 -0.1546 1.1300 3.3759 0.4911 %! -2.1257 -1.4517 -0.4486 0.3493 -1.5506 -1.4296 %! -1.0930 -0.6026 -0.1344 0.2253 -1.5625 -0.6762 %! 0.3207 0.1698 0.2376 -1.1781 -0.8705 0.2896 %! 0.5017 0.9006 0.0668 2.3613 0.2049 0.3703 %! 1.0787 0.6703 0.2783 -0.7213 0.4918 0.7435 ]; %! %! BKe = [ 0.4132 0.3112 -0.8077 %! 0.2140 0.4253 0.1811 %! -0.0710 0.0807 0.3558 %! -0.0121 -0.2019 0.0249 %! 0.1047 0.1399 -0.0457 %! -0.2542 -0.3472 0.0523 ]; %! %! CKe = [ -0.0372 -0.0456 -0.0040 0.0962 -0.2059 -0.0571 %! 0.1999 0.2994 0.1335 -0.0251 -0.3108 0.2048 ]; %! %! DKe = [ 0.0629 -0.0022 0.0363 %! -0.0228 0.0195 0.0600 ]; %! %! RCONDe = [ 0.27949D-03 0.66679D-03 0.45677D-01 0.23433D-07 0.68495D-01 0.76854D-01 ].'; %! %!assert (AK, AKe, 1e-4); %!assert (BK, BKe, 1e-4); %!assert (CK, CKe, 1e-4); %!assert (DK, DKe, 1e-4);control-4.1.2/inst/PaxHeaders/__conred_sb16ad__.m0000644000000000000000000000007415012430645016622 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__conred_sb16ad__.m0000644000175000017500000001351515012430645020016 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{Kr}, @var{info}] =} __conred_sb16ad__ (@var{method}, @dots{}) ## Backend for btaconred and spaconred. ## @end deftypefn ## Author: Lukas Reichlin ## Created: December 2011 ## Version: 0.1 function [Kr, info] = __conred_sb16ad__ (method, varargin) if (nargin < 3) print_usage (); endif if (method != "bta" && method != "spa") error ("modred: invalid method"); endif G = varargin{1}; K = varargin{2}; varargin = varargin(3:end); if (! isa (G, "lti")) error ("%sconred: first argument must be an LTI system", method); endif if (! isa (K, "lti")) error ("%sconred: second argument must be an LTI system", method); endif if (nargin > 3) # *conred (G, K, ...) if (is_real_scalar (varargin{1})) # *conred (G, K, nr) varargin = horzcat (varargin(2:end), {"order"}, varargin(1)); endif if (isstruct (varargin{1})) # *conred (G, K, opt, ...), *conred (G, K, nr, opt, ...) varargin = horzcat (__opt2cell__ (varargin{1}), varargin(2:end)); endif ## order placed at the end such that nr from *conred (G, K, nr, ...) ## and *conred (G, K, nr, opt, ...) overrides possible nr's from ## key/value-pairs and inside opt struct (later keys override former keys, ## nr > key/value > opt) endif nkv = numel (varargin); # number of keys and values if (rem (nkv, 2)) error ("%sconred: keys and values must come in pairs", method); endif [a, b, c, d, tsam, scaled] = ssdata (G); [ac, bc, cc, dc, tsamc, scaledc] = ssdata (K); [p, m] = size (G); [pc, mc] = size (K); dt = isdt (G); if (p != mc || m != pc) error ("%sconred: dimensions of controller (%dx%d) and plant (%dx%d) don't match", ... method, pc, mc, p, c); endif ## default arguments alpha = __modred_default_alpha__ (dt); tol1 = 0.0; tol2 = 0.0; jobc = jobo = 0; bf = true; # balancing-free weight = 3; equil = scaled && scaledc; ordsel = 1; ncr = 0; negfb = false; # positive feedback controller ## handle keys and values for k = 1 : 2 : nkv key = lower (varargin{k}); val = varargin{k+1}; switch (key) case "weight" switch (lower (val(1))) case "n" # none weight = 0; case {"l", "o"} # left, output weight = 1; case {"r", "i"} # right, input weight = 2; case {"b", "p"} # both, performance weight = 3; otherwise error ("%sconred: '%s' is an invalid value for key weight", method, val); endswitch case {"order", "ncr", "nr"} [ncr, ordsel] = __modred_check_order__ (val, rows (ac)); case "tol1" tol1 = __modred_check_tol__ (val, "tol1"); case "tol2" tol2 = __modred_check_tol__ (val, "tol2"); case "alpha" alpha = __modred_check_alpha__ (val, dt); case "method" switch (tolower (val)) case "sr" bf = false; case "bfsr" bf = true; otherwise error ("modred: '%s' is an invalid approach", val); endswitch case {"jobc", "gram-ctrb"} jobc = __modred_check_gram__ (val, "gram-ctrb"); case {"jobo", "gram-obsv"} jobo = __modred_check_gram__ (val, "gram-obsv"); case {"equil", "equilibrate", "equilibration", "scale", "scaling"} scaled = __modred_check_equil__ (val); case "feedback" negfb = __conred_check_feedback_sign__ (val); otherwise warning ("%sconred: invalid property name '%s' ignored\n", method, key); endswitch endfor ## handle model reduction approach if (strcmpi (method, "bta") && ! bf) # 'B': use the square-root Balance & Truncate method jobmr = 0; elseif (strcmpi (method, "bta") && bf) # 'F': use the balancing-free square-root Balance & Truncate method jobmr = 1; elseif (strcmpi (method, "spa") && ! bf) # 'S': use the square-root Singular Perturbation Approximation method jobmr = 2; elseif (strcmpi (method, "spa") && bf) # 'P': use the balancing-free square-root Singular Perturbation Approximation method jobmr = 3; else error ("%smodred: invalid jobmr option"); # this should never happen endif ## handle negative feedback controllers if (negfb) [ac, bc, cc, dc] = ssdata (-K); endif ## perform model order reduction [acr, bcr, ccr, dcr, ncr, hsvc, ncs] = __sl_sb16ad__ (a, b, c, d, dt, equil, ncr, ordsel, alpha, jobmr, ... ac, bc, cc, dc, ... weight, jobc, jobo, tol1, tol2); ## assemble reduced order controller Kr = ss (acr, bcr, ccr, dcr, tsamc); ## handle negative feedback controllers if (negfb) Kr = -Kr; endif ## assemble info struct info = struct ("ncr", ncr, "ncs", ncs, "hsvc", hsvc); endfunction control-4.1.2/inst/PaxHeaders/mixsyn.m0000644000000000000000000000007415012430645014743 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/mixsyn.m0000644000175000017500000002357715012430645016150 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{K}, @var{N}, @var{gamma}, @var{info}] =} mixsyn (@var{G}, @var{W1}, @var{W2}, @var{W3}, @dots{}) ## Solve stacked S/KS/T H-infinity problem. ## Mixed-sensitivity is the name given to transfer function shaping problems in which ## the sensitivity function ## @tex ## $$ S = (I + G K)^{-1} $$ ## @end tex ## @ifnottex ## @example ## -1 ## S = (I + G K) ## @end example ## @end ifnottex ## is shaped along with one or more other closed-loop transfer functions such as @var{K S} ## or the complementary sensitivity function ## @tex ## $$ T = I - S = (I + G K)^{-1} G K $$ ## @end tex ## @ifnottex ## @example ## -1 ## T = I - S = (I + G K) ## @end example ## @end ifnottex ## in a typical one degree-of-freedom configuration, where @var{G} denotes the plant and ## @var{K} the (sub-)optimal controller to be found. The shaping of multivariable ## transfer functions is based on the idea that a satisfactory definition of gain ## (range of gain) for a matrix transfer function is given by the singular values ## @tex ## \(\sigma\) ## @end tex ## @ifnottex ## sigma ## @end ifnottex ## of the transfer function. Hence the classical loop-shaping ideas of feedback design ## can be generalized to multivariable systems. In addition to the requirement that ## @var{K} stabilizes @var{G}, the closed-loop objectives are as follows [1]: ## ## @enumerate ## @item For @emph{disturbance rejection} make ## @tex ## \(\overline{\sigma}(S)\) ## @end tex ## @ifnottex ## @example ## sigma_h (S) ## @end example ## @end ifnottex ## small. ## @item For @emph{noise attenuation} make ## @tex ## \(\overline{\sigma}(T)\) ## @end tex ## @ifnottex ## @example ## sigma_h (T) ## @end example ## @end ifnottex ## small. ## @item For @emph{reference tracking} make ## @tex ## \(\overline{\sigma}(T) \approx \underline{\sigma}(T) \approx 1\). ## @end tex ## @ifnottex ## @example ## sigma_h(T) approx sigma_l(T) approx 1 ## @end example ## @end ifnottex ## @item For @emph{input usage (control energy) reduction} make ## @tex ## \(\overline{\sigma}(K S)\) ## @end tex ## @ifnottex ## @example ## sigma_h (K S) ## @end example ## @end ifnottex ## small. ## @item For @emph{robust stability} in the presence of an additive perturbation ## @tex ## \(G_p = G + \Delta\) ## @end tex ## @ifnottex ## @example ## Gp = G + Delta ## @end example ## @end ifnottex ## make ## @tex ## \(\overline{\sigma}(K S)\) ## @end tex ## @ifnottex ## @example ## sigma_h (K S) ## @end example ## @end ifnottex ## small. ## @item For @emph{robust stability} in the presence of a multiplicative output perturbation ## @tex ## \(G_p = (I + \Delta) G\), ## @end tex ## @ifnottex ## Gp = (I+ Delta) G ## @end ifnottex ## make ## @tex ## \(\overline{\sigma}(T)\) ## @end tex ## @ifnottex ## @example ## sigma_h (T) ## @end example ## @end ifnottex ## small. ## @end enumerate ## In order to find a robust controller for the so-called stacked ## @tex ## \(S/KS/T\, H_{\infty}\) ## @end tex ## @ifnottex ## S/KS/T H-infinity ## @end ifnottex ## problem, the user function @command{mixsyn} minimizes the following criterion ## @tex ## $$ \underset{K}{\min} || N(K) ||_{\infty}, \quad N = | W_1 S; \,W_2 K S; \, W_3 T |$$ ## @end tex ## @ifnottex ## @example ## | W1 S | ## min || N(K) || N = | W2 K S | ## K oo | W3 T | ## @end example ## @end ifnottex ## @code{[K, N] = mixsyn (G, W1, W2, W3)}. ## The user-defined weighting functions @var{W1}, @var{W2} and @var{W3} bound the largest ## singular values of the closed-loop transfer functions @var{S} (for performance), ## @var{K S} (to penalize large inputs) and @var{T} (for robustness and to avoid ## sensitivity to noise), respectively [1]. ## A few points are to be considered when choosing the weights. ## The weigths @var{Wi} must all be proper and stable. Therefore if one wishes, ## for example, to minimize @var{S} at low frequencies by a weighting @var{W1} including ## integral action, ## @tex ## \(\frac{1}{s}\) ## @end tex ## @ifnottex ## @example ## 1 ## - ## s ## @end example ## @end ifnottex ## needs to be approximated by ## @tex ## \(\frac{1}{s + \epsilon}, \mbox{ where } \epsilon \ll 1\). ## @end tex ## @ifnottex ## @example ## 1 ## ----- where e << 1. ## s + e ## @end example ## @end ifnottex ## Similarly one might be interested in weighting @var{K S} with a non-proper weight ## @var{W2} to ensure that @var{K} is small outside the system bandwidth. ## The trick here is to replace a non-proper term such as ## @tex ## $$ 1 + \tau_1 s \mbox{ by } \frac{1 + \tau_1 s}{1 + \tau_2 s}, \,\, \tau_2 \ll \tau_1$$ ## @end tex ## @ifnottex ## @example ## 1 + T1 s ## 1 + T1 s by --------, where T2 << T1. ## 1 + T2 s ## @end example ## @end ifnottex ## For more details, see [1], [2]. ## ## ## @strong{Inputs} ## @table @var ## @item G ## @acronym{LTI} model of plant. ## @item W1 ## @acronym{LTI} model of performance weight. Bounds the largest singular values of sensitivity @var{S}. ## Model must be empty @code{[]}, SISO or of appropriate size. ## @item W2 ## @acronym{LTI} model to penalize large control inputs. Bounds the largest singular values of @var{KS}. ## Model must be empty @code{[]}, SISO or of appropriate size. ## @item W3 ## @acronym{LTI} model of robustness and noise sensitivity weight. Bounds the largest singular values of ## complementary sensitivity @var{T}. Model must be empty @code{[]}, SISO or of appropriate size. ## @item @dots{} ## Optional arguments of @command{hinfsyn}. Type @command{help hinfsyn} for more information. ## @end table ## ## All inputs must be proper/realizable. ## Scalars, vectors and matrices are possible instead of @acronym{LTI} models. ## ## @strong{Outputs} ## @table @var ## @item K ## State-space model of the H-infinity (sub-)optimal controller. ## @item N ## State-space model of the lower LFT of @var{P} and @var{K}. ## @item info ## Structure containing additional information. ## @item info.gamma ## L-infinity norm of @var{N}. ## @item info.rcond ## Vector @var{rcond} contains estimates of the reciprocal condition ## numbers of the matrices which are to be inverted and ## estimates of the reciprocal condition numbers of the ## Riccati equations which have to be solved during the ## computation of the controller @var{K}. For details, ## see the description of the corresponding SLICOT routine. ## @end table ## ## @strong{Block Diagram} ## @example ## @group ## ## | W1 S | ## gamma = min||N(K)|| N = | W2 K S | = lft (P, K) ## K inf | W3 T | ## ## +------+ z1 ## +--------------------------------->| W1 |----> ## | +------+ ## | +------+ z2 ## | +----------------->| W2 |----> ## | | +------+ ## r + e | +--------+ u | +--------+ y +------+ z3 ## --->(+)---+->| K(s) |---+->| G(s) |---+->| W3 |----> ## ^ - +--------+ +--------+ | +------+ ## | | ## +------------------------------------+ ## ## +--------+ ## | |-----> z1 (p1x1) z1 = W1 e ## r (px1) ----->| P(s) |-----> z2 (p2x1) z2 = W2 u ## | |-----> z3 (p3x1) z3 = W3 y ## u (mx1) ----->| |-----> e (px1) e = r - y ## +--------+ ## ## +--------+ ## r ----->| |-----> z ## | P(s) | ## u +---->| |-----+ e ## | +--------+ | ## | | ## | +--------+ | ## +-----| K(s) |<----+ ## +--------+ ## ## +--------+ ## r ----->| N(s) |-----> z ## +--------+ ## ## Extended Plant: P = augw (G, W1, W2, W3) ## Controller: K = mixsyn (G, W1, W2, W3) ## Entire System: N = lft (P, K) ## Open Loop: L = G * K ## Closed Loop: T = feedback (L) ## @end group ## @end example ## ## @strong{Algorithm}@* ## Relies on functions @command{augw} and @command{hinfsyn}, ## which use @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB10FD, SB10DD and SB10AD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @strong{References}@* ## [1] Skogestad, S. and Postlethwaite I. (2005) ## @cite{Multivariable Feedback Control: Analysis and Design: ## Second Edition}. Wiley, Chichester, England.@* ## [2] Meinsma, G. (1995) ## @cite{Unstable and nonproper weights in H-infinity control} ## Automatica, Vol. 31, No. 11, pp. 1655-1658 ## ## @seealso{hinfsyn, augw} ## @end deftypefn ## Author: Lukas Reichlin ## Created: December 2009 ## Version: 0.2 function [K, N, gamma, info] = mixsyn (G, W1 = [], W2 = [], W3 = [], varargin) if (nargin == 0) print_usage (); endif [p, m] = size (G); P = augw (G, W1, W2, W3); [K, N, gamma, info] = hinfsyn (P, p, m, varargin{:}); endfunction control-4.1.2/inst/PaxHeaders/fitfrd.m0000644000000000000000000000007415012430645014672 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/fitfrd.m0000644000175000017500000000612715012430645016067 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{sys}, @var{n}] =} fitfrd (@var{dat}, @var{n}) ## @deftypefnx{Function File} {[@var{sys}, @var{n}] =} fitfrd (@var{dat}, @var{n}, @var{flag}) ## Fit frequency response data with a state-space system. ## If requested, the returned system is stable and minimum-phase. ## ## @strong{Inputs} ## @table @var ## @item dat ## @acronym{LTI} model containing frequency response data of a SISO system. ## @item n ## The desired order of the system to be fitted. @code{n <= length(dat.w)}. ## @item flag ## The flag controls whether the returned system is stable and minimum-phase. ## @table @var ## @item 0 ## The system zeros and poles are not constrained. Default value. ## @item 1 ## The system zeros and poles will have negative real parts in the ## continuous-time case, or moduli less than 1 in the discrete-time case. ## @end table ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## State-space model of order @var{n}, fitted to frequency response data @var{dat}. ## @item n ## The order of the obtained system. The value of @var{n} ## could only be modified if inputs @code{n > 0} and @code{flag = 1}. ## @end table ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB10YD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2011 ## Version: 0.1 function [sys, n] = fitfrd (dat, n, flag = 0) if (nargin == 0 || nargin > 3) print_usage (); endif if (! isa (dat, "frd")) dat = frd (dat); endif if (! issiso (dat)) error ("fitfrd: require SISO system"); endif if (! issample (n, 0) || n != round (n)) error ("fitfrd: second argument must be an integer >= 0"); endif [H, w, tsam] = frdata (dat, "vector"); dt = isdt (dat); if (n > length (w)) error ("fitfrd: require n <= length (dat.w)"); endif [a, b, c, d, n] = __sl_sb10yd__ (real (H), imag (H), w, n, dt, logical (flag)); sys = ss (a, b, c, d, tsam); endfunction %!shared Yo, Ye %! SYS = ss (-1, 1, 1, 0); %! T = 0:0.1:50; %! Ye = step (SYS, T); %! W = logspace (-2, 2, 100); %! FR = frd (SYS, W); %! N = 1; %! SYSID = fitfrd (FR, N, 1); %! Yo = step (SYSID, T); %!assert (Yo, Ye, 1e-2); control-4.1.2/inst/PaxHeaders/__labels__.m0000644000000000000000000000007415012430645015452 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__labels__.m0000644000175000017500000000240115012430645016636 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Return default labels if cell "name" contains only empty strings. ## If not, check whether individual strings of the cell "name" are ## empty and mark them with "?". Used by display routines. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function [name, n] = __labels__ (name, variable = "x") n = numel (name); if (n == 0 || isequal ("", name{:})) name = strseq (variable, 1:n); else idx = cellfun (@isempty, name); name(idx) = "?"; endif endfunction control-4.1.2/inst/PaxHeaders/__modred_check_alpha__.m0000644000000000000000000000007415012430645017764 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__modred_check_alpha__.m0000644000175000017500000000241015012430645021150 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## check alpha for model reduction commands ## Author: Lukas Reichlin ## Created: November 2011 ## Version: 0.1 function alpha = __modred_check_alpha__ (alpha, dt) if (! is_real_scalar (alpha)) error ("modred: argument alpha must be a real scalar"); endif if (dt) # discrete-time if (alpha < 0 || alpha > 1) error ("modred: require 0 <= ALPHA <= 1"); endif else # continuous-time if (alpha > 0) error ("modred: require ALPHA <= 0"); endif endif endfunction control-4.1.2/inst/PaxHeaders/impulse.m0000644000000000000000000000007415012430645015072 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/impulse.m0000644000175000017500000001135415012430645016265 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {} impulse (@var{sys}) ## @deftypefnx{Function File} {} impulse (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}) ## @deftypefnx{Function File} {} impulse (@var{sys1}, @var{'style1'}, @dots{}, @var{sysN}, @var{'styleN'}) ## @deftypefnx{Function File} {} impulse (@var{sys1}, @dots{}, @var{t}) ## @deftypefnx{Function File} {} impulse (@var{sys1}, @dots{}, @var{tfinal}) ## @deftypefnx{Function File} {} impulse (@var{sys1}, @dots{}, @var{tfinal}, @var{dt}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} impulse (@var{sys}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} impulse (@var{sys}, @var{t}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} impulse (@var{sys}, @var{tfinal}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} impulse (@var{sys}, @var{tfinal}, @var{dt}) ## Impulse response of @acronym{LTI} system. ## If no output arguments are given, the response is printed on the screen. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @item t ## Time vector. Should be evenly spaced. If not specified, it is calculated by ## the poles of the system to reflect adequately the response transients. ## @item tfinal ## Optional simulation horizon. If not specified, it is calculated by ## the poles of the system to reflect adequately the response transients. ## @item dt ## Optional sampling time. Be sure to choose it small enough to capture transient ## phenomena. If not specified, it is calculated by the poles of the system. ## @item 'style' ## Line style and color, e.g. 'r' for a solid red line or '-.k' for a dash-dotted ## black line. See @command{help plot} for details. ## @end table ## ## @strong{Outputs} ## @table @var ## @item y ## Output response array. Has as many rows as time samples (length of t) ## and as many columns as outputs. ## @item t ## Time row vector. ## @item x ## State trajectories array. Has @code{length (t)} rows and as many columns as states. ## @end table ## ## @strong{Remark} ## ## For the impulse response of a discrete-time system, the input ## sequence @{1/T,0,0,0,...@} and not the unit impulse is considered. ## ## @seealso{initial, lsim, step} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 1.0 function [y_r, t_r, x_r] = impulse (varargin) if (nargin == 0) print_usage (); endif names = cell (1,nargin); for i = 1:nargin names{i} = inputname (i); end [y, t, x] = __time_response__ ("impulse", varargin, names, nargout); if (nargout) y_r = y{1}; t_r = t{1}; x_r = x{1}; endif endfunction ## Test the analogue response to an impulse input. ## In this case the system in converted into state space ## and then discretized. In the test below, the system is ## discretized as transfer function and then transferred into ## state space for simulating the impulse response. The results ## differ in a quantity larger than 2*eps, therefore 10*eps is ## chosen as tolerance. %!test %! t=0:1:4; %! sys=tf(1,[1 2 2 1]); %! y=impulse(sys,t); %! assert (y(1), 0, eps); %! assert (y(2), 0.241686482894434, 2*eps); %! assert (y(3), 0.404040547757057, 2*eps); %! assert (y(4), 0.307384479794317, 2*eps); %! assert (y(5), 0.121908527560869, 6*eps); # error propagation ## Test the discrete response to an impulse input. %!test %! t=0:1:4; %! sys=tf(1,[1 2 2 1]); %! sys2=c2d(sys, 1, "impulse"); %! y=impulse(sys2,t); %! assert (y(1), 0, eps); %! assert (y(2), 0.241686482894434, 4*eps); %! assert (y(3), 0.404040547757057, 6*eps); %! assert (y(4), 0.307384479794317, 8*eps); %! assert (y(5), 0.121908527560869, 10*eps); # error propagation ## test from bug %!test %! s = tf("s"); %! R = 1/s; %! y= impulse(R); %! assert (y(1), 1, eps); %!demo %! clf; %! s = tf('s'); %! g = 1/(2*s^2+3*s+4); %! impulse(g); %! title ("Impulse response of a PT2 transfer function"); %!demo %! clf; %! s = tf('s'); %! g = 1/(2*s^2+3*s+4); %! h = c2d(g,0.1); %! impulse(h); %! title ("Impulse response of a discretized PT2 transfer function"); control-4.1.2/inst/PaxHeaders/spaconred.m0000644000000000000000000000007415012430645015372 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/spaconred.m0000644000175000017500000001747515012430645016577 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{Kr}, @var{info}] =} spaconred (@var{G}, @var{K}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} spaconred (@var{G}, @var{K}, @var{ncr}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} spaconred (@var{G}, @var{K}, @var{opt}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} spaconred (@var{G}, @var{K}, @var{ncr}, @var{opt}, @dots{}) ## ## Controller reduction by frequency-weighted Singular Perturbation Approximation (SPA). ## Given a plant @var{G} and a stabilizing controller @var{K}, determine a reduced ## order controller @var{Kr} such that the closed-loop system is stable and closed-loop ## performance is retained. ## ## The algorithm tries to minimize the frequency-weighted error ## @iftex ## @tex ## $$ || V \\ (K - K_r) \\ W ||_{\\infty} = \\min $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## ||V (K-Kr) W|| = min ## inf ## @end example ## @end ifnottex ## where @var{V} and @var{W} denote output and input weightings. ## ## ## @strong{Inputs} ## @table @var ## @item G ## @acronym{LTI} model of the plant. ## It has m inputs, p outputs and n states. ## @item K ## @acronym{LTI} model of the controller. ## It has p inputs, m outputs and nc states. ## @item ncr ## The desired order of the resulting reduced order controller @var{Kr}. ## If not specified, @var{ncr} is chosen automatically according ## to the description of key @var{'order'}. ## @item @dots{} ## Optional pairs of keys and values. @code{"key1", value1, "key2", value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item Kr ## State-space model of reduced order controller. ## @item info ## Struct containing additional information. ## @table @var ## @item info.ncr ## The order of the obtained reduced order controller @var{Kr}. ## @item info.ncs ## The order of the alpha-stable part of original controller @var{K}. ## @item info.hsvc ## The Hankel singular values of the alpha-stable part of @var{K}. ## The @var{ncs} Hankel singular values are ordered decreasingly. ## @end table ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'order', 'ncr' ## The desired order of the resulting reduced order controller @var{Kr}. ## If not specified, @var{ncr} is chosen automatically such that states with ## Hankel singular values @var{info.hsvc} > @var{tol1} are retained. ## ## @item 'method' ## Order reduction approach to be used as follows: ## @table @var ## @item 'sr', 's' ## Use the square-root Singular Perturbation Approximation method. ## @item 'bfsr', 'p' ## Use the balancing-free square-root Singular Perturbation Approximation method. Default method. ## @end table ## ## @item 'weight' ## Specifies the type of frequency-weighting as follows: ## @table @var ## @item 'none' ## No weightings are used (V = I, W = I). ## ## @item 'left', 'output' ## Use stability enforcing left (output) weighting ## @iftex ## @tex ## $$ V = (I - G K)^{-1} G, \\qquad W = I $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## -1 ## V = (I-G*K) *G , W = I ## @end example ## @end ifnottex ## ## @item 'right', 'input' ## Use stability enforcing right (input) weighting ## @iftex ## @tex ## $$ V = I, \\qquad W = (I - G K)^{-1} G $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## -1 ## V = I , W = (I-G*K) *G ## @end example ## @end ifnottex ## ## @item 'both', 'performance' ## Use stability and performance enforcing weightings ## @iftex ## @tex ## $$ V = (I - G K)^{-1} G, \\qquad W = (I - G K)^{-1} $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## -1 -1 ## V = (I-G*K) *G , W = (I-G*K) ## @end example ## @end ifnottex ## Default value. ## @end table ## ## @item 'feedback' ## Specifies whether @var{K} is a positive or negative feedback controller: ## @table @var ## @item '+' ## Use positive feedback controller. Default value. ## @item '-' ## Use negative feedback controller. ## @end table ## ## @item 'alpha' ## Specifies the ALPHA-stability boundary for the eigenvalues ## of the state dynamics matrix @var{K.A}. For a continuous-time ## controller, ALPHA <= 0 is the boundary value for ## the real parts of eigenvalues, while for a discrete-time ## controller, 0 <= ALPHA <= 1 represents the ## boundary value for the moduli of eigenvalues. ## The ALPHA-stability domain does not include the boundary. ## Default value is 0 for continuous-time controllers and ## 1 for discrete-time controllers. ## ## @item 'tol1' ## If @var{'order'} is not specified, @var{tol1} contains the tolerance for ## determining the order of the reduced controller. ## For model reduction, the recommended value of @var{tol1} is ## c*info.hsvc(1), where c lies in the interval [0.00001, 0.001]. ## Default value is info.ncs*eps*info.hsvc(1). ## If @var{'order'} is specified, the value of @var{tol1} is ignored. ## ## @item 'tol2' ## The tolerance for determining the order of a minimal ## realization of the ALPHA-stable part of the given ## controller. TOL2 <= TOL1. ## If not specified, ncs*eps*info.hsvc(1) is chosen. ## ## @item 'gram-ctrb' ## Specifies the choice of frequency-weighted controllability ## Grammian as follows: ## @table @var ## @item 'standard' ## Choice corresponding to standard Enns' method [1]. Default method. ## @item 'enhanced' ## Choice corresponding to the stability enhanced ## modified Enns' method of [2]. ## @end table ## ## @item 'gram-obsv' ## Specifies the choice of frequency-weighted observability ## Grammian as follows: ## @table @var ## @item 'standard' ## Choice corresponding to standard Enns' method [1]. Default method. ## @item 'enhanced' ## Choice corresponding to the stability enhanced ## modified Enns' method of [2]. ## @end table ## ## @item 'equil', 'scale' ## Boolean indicating whether equilibration (scaling) should be ## performed on @var{G} and @var{K} prior to order reduction. ## Default value is false if both @code{G.scaled == true, K.scaled == true} ## and true otherwise. ## Note that for @acronym{MIMO} models, proper scaling of both inputs and outputs ## is of utmost importance. The input and output scaling can @strong{not} ## be done by the equilibration option or the @command{prescale} function ## because these functions perform state transformations only. ## Furthermore, signals should not be scaled simply to a certain range. ## For all inputs (or outputs), a certain change should be of the same ## importance for the model. ## @end table ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB16AD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: December 2011 ## Version: 0.1 function [Kr, info] = spaconred (varargin) [Kr, info] = __conred_sb16ad__ ("spa", varargin{:}); endfunction ## TODO: add a test control-4.1.2/inst/PaxHeaders/acker.m0000644000000000000000000000007415012430645014501 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/acker.m0000644000175000017500000000522315012430645015672 0ustar00lilgelilge00000000000000## Copyright (C) 2017-2018 Fabian Alexander Wilms ## ## This program is free software; you can redistribute it and/or modify it under ## the terms of the GNU General Public License as published by the Free Software ## Foundation; either version 3 of the License, or (at your option) any later ## version. ## ## This program is distributed in the hope that it will be useful, but WITHOUT ## ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ## FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{k} =} acker (@var{A}, @var{b}, @var{p}) ## Calculates the state feedback matrix of a completely controllable SISO system ## using Ackermann's formula ## ## Given the state-space system ## @tex ## $$ \dot x = Ax + bu $$ ## @end tex ## @ifnottex ## @example ## @group ## . ## x = @var{A}x + @var{b}u ## @end group ## @end example ## @end ifnottex ## ## and the desired eigenvalues of the closed loop in the vector @var{p}, ## the state feedback vector k is calculated in the form ## ## @tex ## $$ k = (k_1 k_2 ... k_n) $$ ## @end tex ## @ifnottex ## @example ## @group ## @var{k} = (k1 k2 ... kn) ## @end group ## @end example ## @end ifnottex ## ## such that the closed loop system matrix ## ## @tex ## $$ A - b\,k $$ ## @end tex ## @ifnottex ## @example ## @group ## @var{A} - @var{b}@var{k} ## @end group ## @end example ## @end ifnottex ## ## has the eigenvalues given in @var{p}. ## ## @seealso{place} ## @end deftypefn ## This function uses equation (4) from the paper ## "Sliding mode control design based on Ackermann's formula", ## DOI: 10.1109/9.661072 ## Author: Fabian Alexander Wilms ## Created: May 2017 ## Revised: March 2022, Torsten Lilge (compacter and faster code) ## Version: 0.2 function k = acker(A, b, p) if (nargin != 3) print_usage (); endif if (! is_real_square_matrix (A) || ! is_real_vector (b) || rows (A) != rows (b)) error ("acker: matrix A and vector b not conformal"); endif if (! isnumeric (p) || ! isvector (p) || isempty (p) || (length (p) != size (A,1))) # p could be complex error ("acker: p must be a vector of size of A, here %d", size (A,1)); endif k = (inv (ctrb (A, b)))(end,:) * polyvalm (poly (p), A); endfunction %!test %! # https://en.wikipedia.org/wiki/Ackermann's_formula#Example %! A = [1 1; 1 2]; %! B = [1; 0]; %! P = roots ([1 11 30]); %! K = acker(A,B,P); %! assert (K, [14 57]); control-4.1.2/inst/PaxHeaders/dlyap.m0000644000000000000000000000007415012430645014525 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/dlyap.m0000644000175000017500000001404715012430645015722 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{x} =} dlyap (@var{a}, @var{b}) ## @deftypefnx{Function File} {@var{x} =} dlyap (@var{a}, @var{b}, @var{c}) ## @deftypefnx{Function File} {@var{x} =} dlyap (@var{a}, @var{b}, @var{[]}, @var{e}) ## Solve discrete-time Lyapunov or Sylvester equations. ## ## @strong{Equations} ## @example ## @group ## AXA' - X + B = 0 (Lyapunov Equation) ## ## AXB - X + C = 0 (Sylvester Equation) ## ## AXA' - EXE' + B = 0 (Generalized Lyapunov Equation) ## @end group ## @end example ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB03MD, SB04QD and SG03AD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @seealso{dlyapchol, lyap, lyapchol} ## @end deftypefn ## Author: Lukas Reichlin ## Created: January 2010 ## Version: 0.2.1 function [x, scale] = dlyap (a, b, c, e) scale = 1; switch (nargin) case 2 # Lyapunov equation if (! is_real_square_matrix (a, b)) ## error ("dlyap: a, b must be real and square"); error ("dlyap: %s, %s must be real and square", ... inputname (1), inputname (2)); endif if (rows (a) != rows (b)) ## error ("dlyap: a, b must have the same number of rows"); error ("dlyap: %s, %s must have the same number of rows", ... inputname (1), inputname (2)); endif if issymmetric (b) ## The 'normal' case where b is symmetric [x, scale] = __sl_sb03md__ (a, -b, true); # AXA' - X = -B ## x /= scale; # 0 < scale <= 1 else ## b is non-symmetric, solve as Sylvester equation x = __sl_sb04qd__ (-a, a', b); # AXB - X = -C (A = a, B = a', C = b) endif case 3 # Sylvester equation if (! is_real_square_matrix (a, b)) ## error ("dlyap: a, b must be real and square"); error ("dlyap: %s, %s must be real and square", ... inputname (1), inputname (2)); endif if (! is_real_matrix (c) || rows (c) != rows (a) || columns (c) != columns (b)) ## error ("dlyap: c must be a real (%dx%d) matrix", rows (a), columns (b)); error ("dlyap: %s must be a real (%dx%d) matrix", ... rows (a), columns (b), inputname (3)); endif x = __sl_sb04qd__ (-a, b, c); # AXB' - X = -C case 4 # generalized Lyapunov equation if (! isempty (c)) print_usage (); endif if (! is_real_square_matrix (a, b, e)) ## error ("dlyap: a, b, e must be real and square"); error ("dlyap: %s, %s, %s must be real and square", ... inputname (1), inputname (2), inputname (4)); endif if (rows (b) != rows (a) || rows (e) != rows (a)) ## error ("dlyap: a, b, e must have the same number of rows"); error ("dlyap: %s, %s, %s must have the same number of rows", ... inputname (1), inputname (2), inputname (4)); endif if (! issymmetric (b)) ## error ("dlyap: b must be symmetric"); error ("dlyap: %s must be symmetric", ... inputname (2)); endif [x, scale] = __sl_sg03ad__ (a, e, -b, true); # AXA' - EXE' = -B ## x /= scale; # 0 < scale <= 1 otherwise print_usage (); endswitch if (scale < 1) warning ("dlyap: solution scaled by %g to prevent overflow\n", scale); endif endfunction ## Lyapunov %!shared X, X_exp %! A = [3.0 1.0 1.0 %! 1.0 3.0 0.0 %! 0.0 0.0 3.0]; %! %! B = [25.0 24.0 15.0 %! 24.0 32.0 8.0 %! 15.0 8.0 40.0]; %! %! X = dlyap (A.', -B); %! %! X_exp = [2.0000 1.0000 1.0000 %! 1.0000 3.0000 0.0000 %! 1.0000 0.0000 4.0000]; %! %!assert (X, X_exp, 1e-4); ## Lyapunov with non-symmetric B %!shared X, X_exp %! A = [3.0 1.0 1.0 %! 1.0 3.0 0.0 %! 0.0 0.0 3.0]; %! %! B = [1.0 0.2 2.0 %! 0.5 0.5 1.0 %! 1.0 -2.0 1.0]; %! %! X = dlyap (A.', -B); %! %! X_exp = [0.1390 -0.0514 0.1831 %! -0.0086 0.0676 0.0422 %! 0.2005 -0.3233 -0.0362]; %! %!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); ## 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 = [ -3.0 -10.0 7.0 %! -10.0 -14.0 -2.0 %! 7.0 -2.0 9.0 ]; %! %! X = dlyap (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); control-4.1.2/inst/PaxHeaders/filt.m0000644000000000000000000000007415012430645014352 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/filt.m0000644000175000017500000001525615012430645015552 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} filt (@var{num}, @var{den}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} filt (@var{num}, @var{den}, @var{tsam}, @dots{}) ## Create discrete-time transfer function model from data in DSP format. ## ## @strong{Inputs} ## @table @var ## @item num ## Numerator or cell of numerators. Each numerator must be a row vector ## containing the coefficients of the polynomial in ascending powers of z^-1. ## num@{i,j@} contains the numerator polynomial from input j to output i. ## In the SISO case, a single vector is accepted as well. ## @item den ## Denominator or cell of denominators. Each denominator must be a row vector ## containing the coefficients of the polynomial in ascending powers of z^-1. ## den@{i,j@} contains the denominator polynomial from input j to output i. ## In the SISO case, a single vector is accepted as well. ## @item tsam ## Sampling time in seconds. If @var{tsam} is not specified, ## default value -1 (unspecified) is taken. ## @item @dots{} ## Optional pairs of properties and values. ## Type @command{set (filt)} for more information. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Discrete-time transfer function model. ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'num' ## Numerator. See 'Inputs' for details. ## ## @item 'den' ## Denominator. See 'Inputs' for details. ## ## @item 'tfvar' ## String containing the transfer function variable. ## ## @item 'inv' ## Logical. True for negative powers of the transfer function variable. ## ## @item 'tsam' ## Sampling time. See 'Inputs' for details. ## ## @item 'inname' ## The name of the input channels in @var{sys}. ## Cell vector of length m containing strings. ## Default names are @code{@{'u1', 'u2', ...@}} ## ## @item 'outname' ## The name of the output channels in @var{sys}. ## Cell vector of length p containing strings. ## Default names are @code{@{'y1', 'y2', ...@}} ## ## @item 'ingroup' ## Struct with input group names as field names and ## vectors of input indices as field values. ## Default is an empty struct. ## ## @item 'outgroup' ## Struct with output group names as field names and ## vectors of output indices as field values. ## Default is an empty struct. ## ## @item 'name' ## String containing the name of the model. ## ## @item 'notes' ## String or cell of string containing comments. ## ## @item 'userdata' ## Any data type. ## @end table ## ## @strong{Example} ## @tex ## $$H(z^{-1}) = \frac{3z^{-1}}{1 + 4z^-1 + 2z^-2}$$ ## @end tex ## @ifnottex ## @example ## @group ## 3 z^-1 ## H(z^-1) = ------------------- ## 1 + 4 z^-1 + 2 z^-2 ## ## @end group ## @end example ## @end ifnottex ## @example ## @group ## octave:1> H = filt ([0, 3], [1, 4, 2]) ## ## Transfer function 'H' from input 'u1' to output ... ## ## 3 z^-1 ## y1: ------------------- ## 1 + 4 z^-1 + 2 z^-2 ## ## Sampling time: unspecified ## Discrete-time model. ## @end group ## @end example ## ## @seealso{tf} ## @end deftypefn ## Author: Lukas Reichlin ## Created: April 2012 ## Version: 0.2 function sys = filt (varargin) if (nargin <= 1) # filt (), filt (sys), filt (mat), filt ('s') sys = tf (varargin{:}); sys = set (sys, "inv", true); return; elseif (nargin == 2 ... && ischar (varargin{1})) # filt ('z', tsam) sys = tf (varargin{:}); return; endif num = {}; den = {}; tsam = -1; # default values [mat_idx, opt_idx, obj_flg] = __lti_input_idx__ (varargin); switch (numel (mat_idx)) case 1 num = varargin{mat_idx}; case 2 [num, den] = varargin{mat_idx}; case 3 [num, den, tsam] = varargin{mat_idx}; if (isempty (tsam) && is_real_matrix (tsam)) tsam = -1; elseif (! issample (tsam, -1)) error ("filt: invalid sampling time"); endif case 0 ## nothing to do here, just prevent case 'otherwise' otherwise print_usage (); endswitch varargin = varargin(opt_idx); if (obj_flg) varargin = horzcat ({"lti"}, varargin); endif if (isempty (den) ... && (isempty (num) || is_real_matrix (num))) sys = tf (num, "inv", true, varargin{:}); return; endif if (! iscell (num)) num = {num}; endif if (! iscell (den)) den = {den}; endif if (! size_equal (num, den) || ndims (num) != 2) error ("filt: cells 'num' and 'den' must be 2-dimensional and of equal size"); endif if (! is_real_vector (num{:}, den{:}, 1)) # last argument 1 needed if num & den are empty error ("filt: arguments 'num' and 'den' must be real-valued vectors or cells thereof"); endif ## convert from z^-1 to z ## expand each channel by z^x, where x is the largest exponent of z^-1 (z^-x) ## remove trailing zeros ## such that polynomials are as short as possible num = cellfun (@__remove_trailing_zeros__, num, "uniformoutput", false); den = cellfun (@__remove_trailing_zeros__, den, "uniformoutput", false); ## make numerator and denominator polynomials equally long ## by adding trailing zeros lnum = cellfun (@length, num, "uniformoutput", false); lden = cellfun (@length, den, "uniformoutput", false); lmax = cellfun (@max, lnum, lden, "uniformoutput", false); num = cellfun (@postpad, num, lmax, "uniformoutput", false); den = cellfun (@postpad, den, lmax, "uniformoutput", false); ## use standard tf constructor ## sys is stored in standard z form, not z^-1 ## so we can mix it with regular transfer function models ## property "inv", true displays sys in z^-1 form sys = tf (num, den, tsam, "inv", true, varargin{:}); endfunction %!shared num, den, n1, d1, n2, d2, n2e, d2e %! num = [0, 3]; %! den = [1, 4, 2]; %! sys = filt (num, den); %! [n1, d1] = filtdata (sys, "vector"); %! [n2, d2] = tfdata (sys, "vector"); %! n2e = [0, 3, 0]; %! d2e = [1, 4, 2]; %!assert (n1, num, 1e-4); %!assert (d1, den, 1e-4); %!assert (n2, n2e, 1e-4); %!assert (d2, d2e, 1e-4);control-4.1.2/inst/PaxHeaders/care.m0000644000000000000000000000007415012430645014326 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/care.m0000644000175000017500000001524215012430645015521 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{x}, @var{l}, @var{g}] =} care (@var{a}, @var{b}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{x}, @var{l}, @var{g}] =} care (@var{a}, @var{b}, @var{q}, @var{r}, @var{s}) ## @deftypefnx {Function File} {[@var{x}, @var{l}, @var{g}] =} care (@var{a}, @var{b}, @var{q}, @var{r}, @var{[]}, @var{e}) ## @deftypefnx {Function File} {[@var{x}, @var{l}, @var{g}] =} care (@var{a}, @var{b}, @var{q}, @var{r}, @var{s}, @var{e}) ## Solve continuous-time algebraic Riccati equation (ARE). ## ## @strong{Inputs} ## @table @var ## @item a ## Real matrix (n-by-n). ## @item b ## Real matrix (n-by-m). ## @item q ## Real matrix (n-by-n). ## @item r ## Real matrix (m-by-m). ## @item s ## Optional real matrix (n-by-m). If @var{s} is not specified, a zero matrix is assumed. ## @item e ## Optional descriptor matrix (n-by-n). If @var{e} is not specified, an identity matrix is assumed. ## @end table ## ## @strong{Outputs} ## @table @var ## @item x ## Unique stabilizing solution of the continuous-time Riccati equation (n-by-n). ## @item l ## Closed-loop poles (n-by-1). ## @item g ## Corresponding gain matrix (m-by-n). ## @end table ## ## @strong{Equations} ## @example ## @group ## -1 ## A'X + XA - XB R B'X + Q = 0 ## ## -1 ## A'X + XA - (XB + S) R (B'X + S') + Q = 0 ## ## -1 ## G = R B'X ## ## -1 ## G = R (B'X + S') ## ## L = eig (A - B*G) ## @end group ## @end example ## @example ## @group ## -1 ## A'XE + E'XA - E'XB R B'XE + Q = 0 ## ## -1 ## A'XE + E'XA - (E'XB + S) R (B'XE + S') + Q = 0 ## ## -1 ## G = R B'XE ## ## -1 ## G = R (B'XE + S) ## ## L = eig (A - B*G, E) ## @end group ## @end example ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB02OD and SG02AD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @seealso{dare, lqr, dlqr, kalman} ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 0.5.1 function [x, l, g] = care (a, b, q, r, s = [], e = []) ## TODO: extract feedback matrix g from SB02OD (and SG02AD) if (nargin < 4 || nargin > 6) print_usage (); endif if (! is_real_square_matrix (a, q, r)) ## error ("care: a, q, r must be real and square"); error ("care: %s, %s, %s must be real and square", ... inputname (1), inputname (3), inputname (4)); endif if (! is_real_matrix (b) || rows (a) != rows (b)) ## error ("care: a and b must have the same number of rows"); error ("care: %s and %s must have the same number of rows", ... inputname (1), inputname (2)); endif if (columns (r) != columns (b)) ## error ("care: b and r must have the same number of columns"); error ("care: %s and %s must have the same number of columns", ... inputname (2), inputname (4)); endif if (! is_real_matrix (s) && ! size_equal (s, b)) ## error ("care: s(%dx%d) must be real and identically dimensioned with b(%dx%d)", ## rows (s), columns (s), rows (b), columns (b)); error ("care: %s(%dx%d) must be real and identically dimensioned with %s(%dx%d)", ... inputname (5), rows (s), columns (s), inputname (2), rows (b), columns (b)); endif if (! isempty (e) && (! is_real_square_matrix (e) || ! size_equal (e, a))) ## error ("care: a and e must have the same number of rows"); error ("care: %s and %s must have the same number of rows", ... inputname (1), inputname (6)); endif ## check stabilizability if (! isstabilizable (a, b, e, [], 0)) ## error ("care: (a, b) not stabilizable"); error ("care: (%s, %s) not stabilizable", ... inputname (1), inputname (2)); endif ## check positive semi-definiteness if (isempty (s)) t = zeros (size (b)); else t = s; endif m = [q, t; t.', r]; if (isdefinite (m) < 0) ## error ("care: require [q, s; s.', r] >= 0"); error ("care: require [%s, %s; %s.', %s] >= 0", ... inputname (3), inputname (5), inputname (5), inputname (4)); endif ## solve the riccati equation if (isempty (e)) if (isempty (s)) [x, l] = __sl_sb02od__ (a, b, q, r, b, false, false); g = r \ (b.'*x); # gain matrix else [x, l] = __sl_sb02od__ (a, b, q, r, s, false, true); g = r \ (b.'*x + s.'); # gain matrix endif else if (isempty (s)) [x, l] = __sl_sg02ad__ (a, e, b, q, r, b, false, false); g = r \ (b.'*x*e); # gain matrix else [x, l] = __sl_sg02ad__ (a, e, b, q, r, s, false, true); g = r \ (b.'*x*e + s.'); # gain matrix endif endif endfunction %!shared x, l, g, xe, le, ge %! a = [-3 2 %! 1 1]; %! %! b = [ 0 %! 1]; %! %! c = [ 1 -1]; %! %! r = 3; %! %! [x, l, g] = care (a, b, c.'*c, r); %! %! xe = [ 0.5895 1.8216 %! 1.8216 8.8188]; %! %! le = [-3.5026 %! -1.4370]; %! %! ge = [ 0.6072 2.9396]; %! %!assert (x, xe, 1e-4); %!assert (l, le, 1e-4); %!assert (g, ge, 1e-4); %!shared x, l, g, xe, le, ge %! a = [ 0.0 1.0 %! 0.0 0.0]; %! %! b = [ 0.0 %! 1.0]; %! %! c = [ 1.0 0.0 %! 0.0 1.0 %! 0.0 0.0]; %! %! d = [ 0.0 %! 0.0 %! 1.0]; %! %! [x, l, g] = care (a, b, c.'*c, d.'*d); %! %! xe = [ 1.7321 1.0000 %! 1.0000 1.7321]; %! %! le = [-0.8660 + 0.5000i %! -0.8660 - 0.5000i]; %! %! ge = [ 1.0000 1.7321]; %! %!assert (x, xe, 1e-4); %!assert (l, le, 1e-4); %!assert (g, ge, 1e-4); %!shared x, xe %! a = [ 0.0 1.0 %! 0.0 0.0 ]; %! %! e = [ 1.0 0.0 %! 0.0 1.0 ]; %! %! b = [ 0.0 %! 1.0 ]; %! %! c = [ 1.0 0.0 %! 0.0 1.0 %! 0.0 0.0 ]; %! %! d = [ 0.0 %! 0.0 %! 1.0 ]; %! %! x = care (a, b, c.'*c, d.'*d, [], e); %! %! xe = [ 1.7321 1.0000 %! 1.0000 1.7321 ]; %! %!assert (x, xe, 1e-4); control-4.1.2/inst/PaxHeaders/__time_response__.m0000644000000000000000000000007415012430645017064 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__time_response__.m0000644000175000017500000004571715012430645020271 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Common code for the time response functions step, impulse and initial. ## Author: Lukas Reichlin ## Created: October 2009 function [y, t, x] = __time_response__ (response, args, names, nout) idx = cellfun (@islogical, args); tmp = cellfun (@double, args(idx), "uniformoutput", false); args(idx) = tmp; sys_idx = cellfun (@isa, args, {"lti"}); # LTI models mat_idx = cellfun (@is_real_matrix, args); # matrices sty_idx = cellfun (@ischar, args); # strings (style arguments) inv_idx = ! (sys_idx | mat_idx | sty_idx); # invalid arguments if (any (inv_idx)) warning ("%s: arguments number %s are invalid and are being ignored\n", ... response, mat2str (find (inv_idx)(:).')); endif if (nnz (sys_idx) == 0) error ("%s: require at least one LTI model\n", response); endif if (nout > 0) if nnz (sys_idx) > 1 error ("%s: with output arguments, only one system is allowed\n", response); endif if any (sty_idx) warning ("%s: with output arguments, all style parameters are ignored\n", response); endif endif if (any (find (sty_idx) < find (sys_idx)(1))) warning ("%s: strings in front of first LTI model are being ignored\n", response); endif tfinal = []; dt = []; x0 = []; # default arguments switch (response) case "initial" switch (nnz (mat_idx)) case 0 error ("initial: require initial state vector 'x0'\n"); case 1 x0 = args{mat_idx}; case 2 [x0, tfinal] = args{mat_idx}; case 3 [x0, tfinal, dt] = args{mat_idx}; otherwise print_usage (response); endswitch if (! is_real_vector (x0)) error ("initial: initial state vector 'x0' must be a real-valued vector\n"); endif case {"step", "impulse", "ramp"} switch (nnz (mat_idx)) case 0 ## nothing to here, just prevent case 'otherwise' case 1 tfinal = args{mat_idx}; case 2 [tfinal, dt] = args{mat_idx}; otherwise print_usage (response); endswitch otherwise error ("time_response: invalid response type '%s'\n", response); endswitch switch (response) case "step" response1 = "zoh"; case "impulse" response1 = "impulse"; otherwise response1 = "zoh"; endswitch if (issample (tfinal) || isempty (tfinal)) ## nothing to do here elseif (is_real_vector (tfinal)) dt = abs (tfinal(end) - tfinal(1)) / (length (tfinal) - 1); tfinal = abs (tfinal(end)); else print_usage (response); endif if (isempty (dt)) ## nothing to do here elseif (issample (dt)) ## nothing to do here else print_usage (response); endif [tfinal, dt] = cellfun (@__sim_horizon__, args(sys_idx), {tfinal}, {dt}, "uniformoutput", false); tfinal = max ([tfinal{:}]); ## handle names and set reasonable names if empty idx_no_name = cellfun (@isempty, names); sys_numbers = find (idx_no_name); names(sys_numbers) = cellstr (arrayfun (@(x) ['Sys ',num2str(x)], ... sys_numbers(:), "uniformoutput", false)); ## discretizaiton of continuous time systems ## do this in state space for more accurate results sys_dt = args(sys_idx); ct_idx = cellfun (@isct, sys_dt); sys_ct = sys_dt(ct_idx); sys_idx_ct = find (ct_idx); ## FIXME: ss can not be applied via cellfun ()? Use a for-loop instead ## "lti: subsasgn: invalid subscripted assignment type '()'" sys_ctss = cell (size (sys_ct)); for i = 1:length (sys_ct) sys_ctss{i} = ss (sys_ct{i}); # impulse response for systems with direct feedthrough needs special care: # get the response without the resulting delta-inpulses in the outputs # and print a warning if strcmp (response1,"impulse") [nz_y, nz_u] = find (sys_ctss{i}.d); if ! isempty (nz_y) # there is at least one direct feedthrough, prepare a warning message msg = ["System \"%s\" has direct feedthrough!\n", ... "The impulse %f*delta(t) is omitted in the impulse response ", ... "from input \"%s\" to output \"%s\"\n"]; endif for jy = 1:length (nz_y) for ju = 1:length (nz_u) # get the names of all input/output channels with feedthrough in = sys_ctss{i}.inputname{nz_u(ju)}; out = sys_ctss{i}.outputname{nz_y(jy)}; if isempty (in) in = ['u', num2str(nz_u(ju))]; # default name endif if isempty (out) out = ['y', num2str(nz_y(jy))]; # default name endif # print the warning warning (msg, names{sys_idx_ct(i)}, sys_ctss{i}.d(jy,ju), in, out); endfor endfor ## compute impulse response for remaining system without feedthrough sys_ctss{i}.d = 0*sys_ctss{i}.d; endif endfor sys_ct2dt = cellfun (@c2d, sys_ctss, dt(ct_idx), {response1}, "uniformoutput", false); sys_dt(ct_idx) = sys_ct2dt; ## time vector: we have to consider the following cases: ## 1. ct system: last sample is tfinal (ensured by __sim_horizon__) ## 2. dt system ## a) nout > 0 (no plotting): last sample is less or equal tfinal ## b) nout > 0 (plotting): last sample is the first greater ## than tfinal (we need xlim([0,tfinal]) for the plot) if nout > 0 dt_extra = cell2mat (dt) .* ct_idx; else dt_extra = cell2mat (dt); end t = cell (size(dt)); for i = 1:length(t) t{i} = vec (0:dt{i}:tfinal); if (ct_idx(i) == 0) && (nout == 0) && (length (t{i}) * dt{i} < tfinal) ## Discrete time system, no plotting, and last sampling is before tfinal t{i}(end+1) = t{i}(end) + dt{i}; end end ## alternative code ## t = cellfun (@(dt) vec (0 : dt : tfinal), dt, "uniformoutput", false); ## function [y, x_arr] = __initial_response__ (sys_dt, t, x0) ## function [y, x_arr] = __step_response__ (sys_dt, t) ## function [y, x_arr] = __impulse_response__ (sys, sys_dt, t) ## function [y, x_arr] = __ramp_response__ (sys_dt, t) switch (response) case "initial" [y, x] = cellfun (@__initial_response__, sys_dt, t, {x0}, "uniformoutput", false); case "step" [y, x] = cellfun (@__step_response__, sys_dt, t, "uniformoutput", false); case "impulse" [y, x] = cellfun (@__impulse_response__, args(sys_idx), sys_dt, t, "uniformoutput", false); case "ramp" [y, x] = cellfun (@__ramp_response__, sys_dt, t, "uniformoutput", false); otherwise error ("time_response: invalid response type\n"); endswitch if (nout == 0) # display plot ## extract plotting styles tmp = cumsum (sys_idx); tmp(sys_idx | ! sty_idx) = 0; n_sys = nnz (sys_idx); sty = arrayfun (@(x) args(tmp == x), 1:n_sys, "uniformoutput", false); ## default plotting styles if empty colororder = get (gca, "colororder"); rc = rows (colororder); def = arrayfun (@(k) {"color", colororder(1+rem (k-1, rc), :)}, 1:n_sys, "uniformoutput", false); idx_no_sty = cellfun (@isempty, sty); sty(idx_no_sty) = def(idx_no_sty); idx_sty = ! idx_no_sty; ## get index for system names (legend) leg_idx = find (sys_idx); ## get max sizes [p, m] = cellfun (@size, args(sys_idx), 'uniformoutput', false); p = cell2mat (p); m = cell2mat (m); rows = max (p); cols = max (m); ## get in/outnames, take ui and yi for more than one system if n_sys == 1 outname = get (args(sys_idx){1}, "outname"); inname = get (args(sys_idx){1}, "inname"); else outname = cell(1,rows); inname = cell(1,cols); endif outname = __labels__ (outname, "y"); inname = __labels__ (inname, "u"); switch (response) case "initial" str = "Response to Initial Conditions"; cols = 1; ## yfinal = zeros (p, 1); case "step" str = "Step Response"; ## yfinal = dcgain (sys_cell{1}); case "impulse" str = "Impulse Response"; ## yfinal = zeros (p, m); case "ramp" str = "Ramp Response"; otherwise error ("time_response: invalid response type '%s'\n", response); endswitch ## get last system present in the subplots last_system = zeros (rows, cols); for i = 1 : rows for j = 1 : cols for k = 1 : n_sys if (p(k) >= i) && (m(k) >= j) last_system(i,j) = k; endif endfor endfor endfor ## loop over all subplots for i = 1 : rows # for every output for j = 1 : cols # for every input (except for initial where cols=1) if last_system(i,j) > 0 # only if there is a system with this in-/output combination subplot (rows, cols, (i-1)*cols+j); box on; for k = 1 : last_system(i,j) # for every system for this in-/output p_sys = size (args(sys_idx){k}, 1); m_sys = size (args(sys_idx){k}, 2); if (p_sys >= i) && (m_sys >= j) # only if system has this in-/output ## determine the text for the legend if we have more than ## one system but only for the forst subplot were all systems ## are included if (n_sys > 1) && (i == 1) && (j == 1) ## we need a legend if (idx_no_sty(k)) ## no style given sty{k}{end+1} = [';',names{leg_idx(k)},';']; else ## already a style given if (length (strfind (sty{k}{1}, ";")) < 2) ## no description included sty{k}{1,1} = [sty{k}{1,1},';',names{leg_idx(k)},';']; endif endif endif if (ct_idx(k)) # continuous-time system plot (t{k}, y{k}(:, i, j), sty{k}{:}); else # discrete-time system [tstep,ystep] = stairs (t{k}, y{k}(:, i, j)); plot (tstep, ystep, sty{k}{:}); endif hold on; if k == last_system(i,j) ## do the following only for last system in this subplot grid on; axis tight xlim ([0, tfinal]); ylim (__axis_margin__ (ylim)) xlabel ("Time [s]"); ylabel (outname{i}); if (! strcmp (response, "initial")) && (rows > 1 || cols > 1) title (inname{j}, "fontweight", "normal"); endif endif endif endfor hold off; endif hold off; endfor endfor if (rows == 1 && cols == 1) title (str); # normal title else # create title manually (create axes object on whole figure and put text) f_pos = get (gcf(), 'position'); fs = get (gca(), 'fontsize'); last_plot = gca (); dummy = axes( 'visible', 'off', 'position', [0 0 1 1]); text (dummy, 0.5, 1-1.2*fs/f_pos(4), str, ... 'fontsize', 1.2*fs, 'fontweight', 'bold', 'horizontalalignment', 'center'); set (gcf (), 'currentaxes', last_plot); # focus back to last subplot endif endif endfunction function [y, x_arr] = __initial_response__ (sys_dt, t, x0) [F, G, C, D] = ssdata (sys_dt); # system must be proper n = rows (F); # number of states m = columns (G); # number of inputs p = rows (C); # number of outputs l_t = length (t); ## preallocate memory y = zeros (l_t, p); x_arr = zeros (l_t, n); ## initial conditions x = reshape (x0, [], 1); # make sure that x is a column vector if (n != length (x0) || ! is_real_vector (x0)) error ("initial: x0 must be a real vector with %d elements\n", n); endif ## simulation for k = 1 : l_t y(k, :) = C * x; x_arr(k, :) = x; x = F * x; endfor endfunction function [y, x_arr] = __step_response__ (sys_dt, t) [F, G, C, D] = ssdata (sys_dt); # system must be proper n = rows (F); # number of states m = columns (G); # number of inputs p = rows (C); # number of outputs l_t = length (t); ## preallocate memory y = zeros (l_t, p, m); x_arr = zeros (l_t, n, m); for j = 1 : m # for every input channel ## initial conditions x = zeros (n, 1); u = zeros (m, 1); u(j) = 1; ## simulation for k = 1 : l_t y(k, :, j) = C * x + D * u; x_arr(k, :, j) = x; x = F * x + G * u; endfor endfor endfunction function [y, x_arr] = __impulse_response__ (sys, sys_dt, t) [F, G, C, D, dt] = ssdata (sys_dt); # system must be proper dt = abs (dt); # use 1 second if tsam is unspecified (-1) n = rows (F); # number of states m = columns (G); # number of inputs p = rows (C); # number of outputs l_t = length (t); ## preallocate memory y = zeros (l_t, p, m); x_arr = zeros (l_t, n, m); for j = 1 : m # for every input channel u = zeros (m, 1); u(j) = 1; ## initial conditions x = zeros (n, 1); # zero by definition y(1, :, j) = D * u / dt; # impulse is 1/dt x_arr(1, :, j) = x; x = G * u / dt; ## simulation for k = 2 : l_t y (k, :, j) = C * x; x_arr(k, :, j) = x; x = F * x; endfor endfor endfunction function [y, x_arr] = __ramp_response__ (sys_dt, t) [F, G, C, D] = ssdata (sys_dt); # system must be proper n = rows (F); # number of states m = columns (G); # number of inputs p = rows (C); # number of outputs l_t = length (t); ## preallocate memory y = zeros (l_t, p, m); x_arr = zeros (l_t, n, m); for j = 1 : m # for every input channel ## initial conditions x = zeros (n, 1); u = zeros (m, l_t); u(j, :) = t; ## simulation for k = 1 : l_t y(k, :, j) = C * x + D * u(:, k); x_arr(k, :, j) = x; x = F * x + G * u(:, k); endfor endfor endfunction function [tfinal, dt] = __sim_horizon__ (sys, tfinal, Ts) ## code based on __stepimp__.m of Kai P. Mueller and A. Scottedward Hodel N_MIN = 100; # min number of points N_MAX = 10000; # max number of points N_DEF = 2000; # default number of points T_DEF = 10; # default simulation time ev = pole (sys); TOL = max (abs (ev))*1.0e-10 + 2*eps; # values below TOL are assumed to be zero, # avoid TOL = 0 n = length (ev); # number of states/poles continuous = isct (sys); discrete = ! continuous; if (discrete) dt = Ts = abs (get (sys, "tsam")); ## perform bilinear transformation on poles in z for k = 1 : n pol = ev(k); if (abs (pol + 1) < TOL) ev(k) = 0; else ev(k) = 2 / Ts * (pol - 1) / (pol + 1); endif endfor TOL = max (abs (ev))*1.0e-10 + 2*eps; # new TOL after bilinear transformation endif ## remove poles near zero from eigenvalue array ev nk = n; for k = 1 : n if (abs (ev(k)) < TOL) ev(k) = 0; nk -= 1; endif endfor if (nk == 0) if (isempty (tfinal)) tfinal = T_DEF; endif if (continuous) dt = tfinal / N_DEF; endif else ev = ev(find (ev)); ev_max = max (abs (ev)); ev_conj_compl = ev (find (imag (ev) > TOL)); if length (ev_conj_compl) > 0 Dw0 = -real (ev_conj_compl); w = imag (ev_conj_compl); t_osc = min ( 12*pi./w, 4./Dw0 ); t_max_osc = max (t_osc); # get max display time for slowest oscillation else t_max_osc = 0; endif if (continuous) dt = 0.1 * pi / ev_max; endif auto_tfinal = 0; % flag for computed or given tfinal if (isempty (tfinal)) ev_min = min (abs (ev)); ev_real_min = min (abs (real (ev))); den = min ([ev_min, ev_real_min]); if (den < TOL) den = max([ev_min, ev_real_min]); endif tfinal = 6 / den; auto_tfinal = 1; # remeber that tfinal was computed, not given by the user tfinal = max (tfinal, t_max_osc); # make sure to show enough oscillations ## round up yy = 10^(ceil (log10 (tfinal)) - 1); tfinal = yy * ceil (tfinal / yy); endif if (continuous) ## Always select N such that tfinal < N*dt =< tfinal+dt N = fix (tfinal / dt) + 1; ## Ensure that tfinal is an integer multiple of dt and by ## the selection of N as above, we alwys reduce dt a little bit dt = tfinal/N; if (N < N_MIN) dt = tfinal / N_MIN; endif if (N > N_MAX) ## N is larger then N_MAX -> increase dt or reduce tfinal if (auto_tfinal) ## tfinal was computed: make it shorter and leave dt as it is in order to ## avoid aliasing tfinal = dt * N_MAX; # adapt tfinal, not dt yy = 10^(ceil (log10 (tfinal)) - 1); # round up again, since tfinal has changed tfinal = yy * ceil (tfinal / yy); else ## tfinal was selected by the user, do not change it, increase dt instead dt = tfinal / N_MAX; endif endif endif endif if (continuous && ! isempty (Ts)) # catch case cont. system with dt specified dt = Ts; endif endfunction control-4.1.2/inst/PaxHeaders/__remove_trailing_zeros__.m0000644000000000000000000000007415012430645020620 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__remove_trailing_zeros__.m0000644000175000017500000000232415012430645022010 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Remove trailing zeros from a polynomial, except for polynomials ## which are of length 1. For internal use only. ## Author: Lukas Reichlin ## Created: April 2012 ## Version: 0.1 function p = __remove_trailing_zeros__ (p) if (isa (p, "cell")) p = cellfun (@__remove_trailing_zeros__, p, "uniformoutput", false); return; endif idx = find (p != 0); if (isempty (idx)) p = 0; else p = p(1 : idx(end)); endif endfunction control-4.1.2/inst/PaxHeaders/lqr.m0000644000000000000000000000007415012430645014212 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/lqr.m0000644000175000017500000000630615012430645015406 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{g}, @var{x}, @var{l}] =} lqr (@var{sys}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{g}, @var{x}, @var{l}] =} lqr (@var{sys}, @var{q}, @var{r}, @var{s}) ## @deftypefnx {Function File} {[@var{g}, @var{x}, @var{l}] =} lqr (@var{a}, @var{b}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{g}, @var{x}, @var{l}] =} lqr (@var{a}, @var{b}, @var{q}, @var{r}, @var{s}) ## @deftypefnx {Function File} {[@var{g}, @var{x}, @var{l}] =} lqr (@var{a}, @var{b}, @var{q}, @var{r}, @var{[]}, @var{e}) ## @deftypefnx {Function File} {[@var{g}, @var{x}, @var{l}] =} lqr (@var{a}, @var{b}, @var{q}, @var{r}, @var{s}, @var{e}) ## Linear-quadratic regulator. ## ## @strong{Inputs} ## @table @var ## @item sys ## Continuous or discrete-time @acronym{LTI} model (p-by-m, n states). ## @item a ## State matrix of continuous-time system (n-by-n). ## @item b ## Input matrix of continuous-time system (n-by-m). ## @item q ## State weighting matrix (n-by-n). ## @item r ## Input weighting matrix (m-by-m). ## @item s ## Optional cross term matrix (n-by-m). If @var{s} is not specified, a zero matrix is assumed. ## @item e ## Optional descriptor matrix (n-by-n). If @var{e} is not specified, an identity matrix is assumed. ## @end table ## ## @strong{Outputs} ## @table @var ## @item g ## State feedback matrix (m-by-n). ## @item x ## Unique stabilizing solution of the continuous-time Riccati equation (n-by-n). ## @item l ## Closed-loop poles (n-by-1). ## @end table ## ## @strong{Equations} ## @tex ## $$ \dot{x} = A\,x + B\,u,\quad x(0) = x_0 $$ ## $$ J(x_0) = \int_0^\infty x^T Q\, x + u^T R\, u + 2\, x^T S\, u \,\, dt $$ ## $$ L = \sigma (A - B\, G) $$ ## @end tex ## @ifnottex ## @example ## @group ## . ## x = A x + B u, x(0) = x0 ## ## inf ## J(x0) = INT (x' Q x + u' R u + 2 x' S u) dt ## 0 ## ## L = eig (A - B*G) ## @end group ## @end example ## @end ifnottex ##@seealso{care, dare, dlqr,lqry,lqi,lqg} ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 0.2 function [g, x, l] = lqr (a, b, q, r = [], s = [], e = []) if (nargin < 3 || nargin > 6) print_usage (); endif if (isa (a, "lti")) s = r; r = q; q = b; [a, b, c, d, e, tsam] = dssdata (a, []); elseif (nargin < 4) print_usage (); else tsam = 0; endif if (issample (tsam, -1)) [x, l, g] = dare (a, b, q, r, s, e); else [x, l, g] = care (a, b, q, r, s, e); endif endfunction control-4.1.2/inst/PaxHeaders/nichols.m0000644000000000000000000000007415012430645015053 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/nichols.m0000644000175000017500000000677115012430645016255 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} nichols (@var{sys}) ## @deftypefnx {Function File} {} nichols (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}) ## @deftypefnx {Function File} {} nichols (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}, @var{w}) ## @deftypefnx {Function File} {} nichols (@var{sys1}, @var{'style1'}, @dots{}, @var{sysN}, @var{'styleN'}) ## @deftypefnx {Function File} {[@var{mag}, @var{pha}, @var{w}] =} nichols (@var{sys}) ## @deftypefnx {Function File} {[@var{mag}, @var{pha}, @var{w}] =} nichols (@var{sys}, @var{w}) ## Nichols chart of frequency response. If no output arguments are given, ## the response is printed on the screen. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. Must be a single-input and single-output (SISO) system. ## @item w ## Optional vector of frequency values. If @var{w} is not specified, ## it is calculated by the zeros and poles of the system. ## Alternatively, the cell @code{@{wmin, wmax@}} specifies a frequency range, ## where @var{wmin} and @var{wmax} denote minimum and maximum frequencies ## in rad/s. ## @item 'style' ## Line style and color, e.g. 'r' for a solid red line or '-.k' for a dash-dotted ## black line. See @command{help plot} for details. ## @end table ## ## @strong{Outputs} ## @table @var ## @item mag ## Vector of magnitude. Has length of frequency vector @var{w}. ## @item pha ## Vector of phase. Has length of frequency vector @var{w}. ## @item w ## Vector of frequency values used. ## @end table ## ## @seealso{bode, nyquist, sigma} ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 1.0 function [mag_r, pha_r, w_r] = nichols (varargin) if (nargin == 0) print_usage (); endif [H, w, sty, sys_idx] = __frequency_response__ ("nichols", varargin, nargout); numsys = length (sys_idx); H = cellfun (@reshape, H, {[]}, {1}, "uniformoutput", false); mag = cellfun (@abs, H, "uniformoutput", false); pha = cellfun (@(H) unwrap (arg (H)) * 180 / pi, H, "uniformoutput", false); if (! nargout) ## get system names and create the legend leg = cell (1, numsys); for k = 1:numsys leg{k} = inputname (sys_idx(k)); endfor ## plot mag_db = cellfun (@mag2db, mag, "uniformoutput", false); plot_args = horzcat (cellfun (@horzcat, pha, mag_db, sty, "uniformoutput", false){:}); plot (plot_args{:}) axis ("tight") xlim (__axis_margin__ (xlim)) ylim (__axis_margin__ (ylim)) grid ("on") title ("Nichols Chart") xlabel ("Phase [deg]") ylabel ("Magnitude [dB]") legend (leg) else ## no plotting, assign values to the output parameters mag_r = mag{1}; pha_r = pha{1}; w_r = w{1}; endif endfunction %!demo %! s = tf('s'); %! g = 1/(2*s^2+3*s+4); %! nichols(g); control-4.1.2/inst/PaxHeaders/@frd0000644000000000000000000000007415012430645014034 xustar0030 atime=1747595720.873132883 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/0000755000175000017500000000000015012430645015300 5ustar00lilgelilge00000000000000control-4.1.2/inst/@frd/PaxHeaders/__sys_keys__.m0000644000000000000000000000007415012430645016734 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__sys_keys__.m0000644000175000017500000000274515012430645020133 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 Lukas F. Reichlin ## ## This program is free software: you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{keys}, @var{vals}] =} __sys_keys__ (@var{sys}) ## @deftypefnx {Function File} {[@var{keys}, @var{vals}] =} __sys_keys__ (@var{sys}, @var{aliases}) ## Return the list of keys as well as the assignable values for a frd object sys. ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.3 function [keys, vals] = __sys_keys__ (sys, aliases = false) ## cell vector of frd-specific keys keys = {"H"; "w"}; ## cell vector of frd-specific assignable values vals = {"p-by-m-by-l array of complex frequency responses"; "l-by-1 vector of real frequencies (l = length (w))"}; if (aliases) ka = {"response"; "frequency"}; keys = [keys; ka]; endif endfunction control-4.1.2/inst/@frd/PaxHeaders/__set__.m0000644000000000000000000000007415012430645015656 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__set__.m0000644000175000017500000000245415012430645017052 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Set or modify keys of FRD objects. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.2 function sys = __set__ (sys, key, val) switch (key) # {, } case {"h", "response"} val = __adjust_frd_data__ (val, sys.w); __frd_dim__ (val, sys.w); sys.H = val; case {"w", "frequency"} [~, val] = __adjust_frd_data__ (sys.H, val); __frd_dim__ (sys.H, val); sys.w = val; otherwise error ("frd: set: invalid key name '%s'", key); endswitch endfunction control-4.1.2/inst/@frd/PaxHeaders/__c2d__.m0000644000000000000000000000007415012430645015533 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__c2d__.m0000644000175000017500000000211615012430645016722 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Convert the continuous FRD object into its discrete-time equivalent. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function sys = __c2d__ (sys, tsam, method = "zoh") error ("frd: c2d: conversion not possible"); ## NOTE: changing just the sampling time wouldn't make sense here endfunction control-4.1.2/inst/@frd/PaxHeaders/__d2c__.m0000644000000000000000000000007415012430645015533 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__d2c__.m0000644000175000017500000000212015012430645016715 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Convert the discrete FRD object into its continuous-time equivalent. ## Author: Lukas Reichlin ## Created: September 2011 ## Version: 0.1 function sys = __d2c__ (sys, tsam, method = "zoh") error ("frd: d2c: conversion not possible"); ## NOTE: changing just the sampling time wouldn't make sense here endfunction control-4.1.2/inst/@frd/PaxHeaders/__sys2tf__.m0000644000000000000000000000007415012430645016315 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__sys2tf__.m0000644000175000017500000000220715012430645017505 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## FRD to TF conversion. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function [retsys, retlti] = __sys2tf__ (sys) error ("frd: frd2tf: system identification not implemented yet"); retsys = tf (num, den, get (sys, "tsam")); # tsam needed to set appropriate tfvar retlti = sys.lti; # preserve lti properties endfunction control-4.1.2/inst/@frd/PaxHeaders/__pole__.m0000644000000000000000000000007415012430645016022 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__pole__.m0000644000175000017500000000170215012430645017211 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Poles of FRD object. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function pol = __pole__ (sys) error ("frd: pole: this is not possible"); endfunction control-4.1.2/inst/@frd/PaxHeaders/__sys_connect__.m0000644000000000000000000000007415012430645017412 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__sys_connect__.m0000644000175000017500000000323215012430645020601 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{retsys} =} __sys_connect__ (@var{sys}, @var{M}) ## This function is part of the Model Abstraction Layer. No argument checking. ## For internal use only. ## @example ## @group ## Problem: Solve the system equations of ## Y(s) = G(s) E(s) ## E(s) = U(s) + M Y(s) ## in order to build ## Y(s) = H(s) U(s) ## Solution: ## Y(s) = G(s) [U(s) + M Y(s)] ## Y(s) = G(s) U(s) + G(s) M Y(s) ## Y(s) = [I - G(s) M]^-1 G(s) U(s) ## \_______ _______/ ## H(s) ## @end group ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function sys = __sys_connect__ (sys, M) ## FIXME: feedback (frd (ss (1)), frd (ss (-1))) [p, m, l] = size (sys.H); I = eye (p); H = mat2cell (sys.H, p, m, ones (1, l))(:); H = cellfun (@(x) (I - x*M) \ x, H, "uniformoutput", false); sys.H = cat (3, H{:}); endfunction control-4.1.2/inst/@frd/PaxHeaders/display.m0000644000000000000000000000007415012430645015734 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/display.m0000644000175000017500000000711615012430645017130 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Display routine for FRD objects. ## Author: Lukas Reichlin ## Created: February 2010 ## Version: 0.2 function display (sys) sysname = inputname (1); [inname, outname, tsam] = __lti_data__ (sys.lti); [inname, m] = __labels__ (inname, "u"); [outname, p] = __labels__ (outname, "y"); w = __freq2str__ (sys.w); disp (""); for k = 1 : m disp (["Frequency response '", sysname, "' from input '", inname{k}, "' to output ..."]); disp (""); __disp_resp__ (sys.H(:,k,:), w, outname); endfor display (sys.lti); # display sampling time if (isstaticgain (sys)) disp ("Static gain."); elseif (tsam == 0) disp ("Continuous-time frequency response."); else disp ("Discrete-time frequency response."); endif endfunction function __disp_resp__ (H, w, outname) p = rows (H); # number of outputs len = size (H, 3); # number of frequencies H = mat2cell (H, ones (1, p), 1, len)(:); H = cellfun (@__resp2str__, H, outname, "uniformoutput", false); tsize = terminal_size (); col_freq = columns (w); col_resp = cellfun (@columns, H); col_max = tsize(2) - col_freq; width = cumsum (col_resp); start = 0; stop = col_max; while (start < width(end)) idx = find (width > start & width <= stop); disp ([w, H{idx}]); disp (""); start = width(idx(end)); stop = start + col_max; endwhile ## FIXME: Handle case where tsize(2) is not enough ## to display frequencies and one output. endfunction function str = __freq2str__ (w, title = "w [rad/s]") len = rows (w); str = __vec2str__ (w); line = repmat ("-", 1, max (columns (str), columns (title))); str = strvcat (title, line, str); space = repmat (" ", len+2, 1); str = [space, str]; endfunction function str = __resp2str__ (H, outname) H = H(:); len = length (H); real_str = __vec2str__ (real (H)); im = imag (H); if (any (im)) imag_str = __vec2str__ (abs (im), "i"); sign_str = repmat (" + ", len, 1); neg = im < 0; sign_str(neg, 2) = "-"; str = [real_str, sign_str, imag_str]; else str = real_str; endif line = repmat ("-", 1, max (columns (str), columns (outname))); str = strvcat (outname, line, str); space = repmat (" ", len+2, 1); str = [space, str]; endfunction function str = __vec2str__ (vec, post) vec = vec(:); tmp = isfinite (vec); tmp = abs (vec(tmp & vec != 0)); if (isempty (tmp) || min (tmp) < 1e-3 || max (tmp) > 1e4) str = arrayfun (@(x) sprintf ("%.3e", x), vec, "uniformoutput", false); elseif (all (floor (tmp) == tmp)) str = arrayfun (@(x) sprintf ("%d", x), vec, "uniformoutput", false); else str = arrayfun (@(x) sprintf ("%.4f", x), vec, "uniformoutput", false); endif str = strjust (char (str), "right"); if (nargin > 1) str = [str, repmat(post, length (vec), 1)]; endif endfunction control-4.1.2/inst/@frd/PaxHeaders/__ctranspose__.m0000644000000000000000000000007415012430645017244 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__ctranspose__.m0000644000175000017500000000210415012430645020430 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Conjugate transpose of FRD objects. ## Author: Lukas Reichlin ## Created: May 2012 ## Version: 0.1 function sys = __ctranspose__ (sys) [p, m, l] = size (sys.H); H = mat2cell (sys.H, p, m, ones (1, l))(:); H = cellfun (@ctranspose, H, "uniformoutput", false); sys.H = cat (3, H{:}); endfunction control-4.1.2/inst/@frd/PaxHeaders/__minreal__.m0000644000000000000000000000007415012430645016512 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__minreal__.m0000644000175000017500000000176215012430645017707 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Minimal realization of FRD objects. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function sys = __minreal__ (sys, tol) warning ("frd: minreal: frequency responses are always minimal\n"); endfunction control-4.1.2/inst/@frd/PaxHeaders/__sys_data__.m0000644000000000000000000000007415012430645016672 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__sys_data__.m0000644000175000017500000000171715012430645020067 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Used by frdata instead of multiple get calls. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function [H, w] = __sys_data__ (sys) H = sys.H; w = sys.w; endfunction control-4.1.2/inst/@frd/PaxHeaders/frd.m0000644000000000000000000000007415012430645015042 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/frd.m0000644000175000017500000001270615012430645016237 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} frd (@var{sys}) ## @deftypefnx {Function File} {@var{sys} =} frd (@var{sys}, @var{w}) ## @deftypefnx {Function File} {@var{sys} =} frd (@var{H}, @var{w}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} frd (@var{H}, @var{w}, @var{tsam}, @dots{}) ## Create or convert to frequency response data. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model to be converted to frequency response data. ## If second argument @var{w} is omitted, the interesting ## frequency range is calculated by the zeros and poles of @var{sys}. ## @item H ## Frequency response array (p-by-m-by-lw). H(i,j,k) contains the ## response from input j to output i at frequency k. In the SISO case, ## a vector (lw-by-1) or (1-by-lw) is accepted as well. ## @item w ## Frequency vector (lw-by-1) in radian per second [rad/s]. ## Frequencies must be in ascending order. ## @item tsam ## Sampling time in seconds. If @var{tsam} is not specified, ## a continuous-time model is assumed. ## @item @dots{} ## Optional pairs of properties and values. ## Type @command{set (frd)} for more information. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Frequency response data object. ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'H' ## Frequency response array. See 'Inputs' for details. ## ## @item 'w' ## Frequency vector. See 'Inputs' for details. ## ## @item 'tsam' ## Sampling time. See 'Inputs' for details. ## ## @item 'inname' ## The name of the input channels in @var{sys}. ## Cell vector of length m containing strings. ## Default names are @code{@{'u1', 'u2', ...@}} ## ## @item 'outname' ## The name of the output channels in @var{sys}. ## Cell vector of length p containing strings. ## Default names are @code{@{'y1', 'y2', ...@}} ## ## @item 'ingroup' ## Struct with input group names as field names and ## vectors of input indices as field values. ## Default is an empty struct. ## ## @item 'outgroup' ## Struct with output group names as field names and ## vectors of output indices as field values. ## Default is an empty struct. ## ## @item 'name' ## String containing the name of the model. ## ## @item 'notes' ## String or cell of string containing comments. ## ## @item 'userdata' ## Any data type. ## @end table ## ## @seealso{dss, ss, tf} ## @end deftypefn ## Author: Lukas Reichlin ## Created: February 2010 ## Version: 0.2 function sys = frd (varargin) ## NOTE: * There's no such thing as a static gain ## because FRD objects are measurements, ## not models. ## * If something like sys1 = frd (5) existed, ## it would cause troubles in cases like ## sys2 = ss (...), sys = sys1 * sys2 ## because sys2 needs to be converted to FRD, ## but sys1 contains no valid frequencies. ## * However, things like frd (ss (5)) should ## be possible. ## model precedence: frd > ss > zpk > tf > double superiorto ("ss", "zpk", "tf", "double"); if (nargin == 1 && isa (varargin{1}, "frd")) sys = varargin{1}; return; elseif (nargin != 0 && nargin <= 2 ... && isa (varargin{1}, "lti")) [sys, lti] = __sys2frd__ (varargin{:}); sys.lti = lti; # preserve lti properties return; endif H = []; w = []; # default frequency response data tsam = -1; # default sampling time [mat_idx, opt_idx, obj_flg] = __lti_input_idx__ (varargin); switch (numel (mat_idx)) case 2 # frd (H, w), frd (H, w, ...) [H, w] = varargin{mat_idx}; tsam = 0; case 3 # frd (H, w, tsam), frd (H, w, tsam, ...) [H, w, tsam] = varargin{mat_idx}; if (isempty (tsam) && is_real_matrix (tsam)) tsam = -1; elseif (! issample (tsam, -10)) error ("frd: invalid sampling time"); endif case 0 # frd () ## nothing to do here, just prevent case 'otherwise' otherwise # sys = frd (H) *must* fail print_usage (); endswitch varargin = varargin(opt_idx); if (obj_flg) varargin = horzcat ({"lti"}, varargin); endif [H, w] = __adjust_frd_data__ (H, w); [p, m] = __frd_dim__ (H, w); # determine number of outputs and inputs frdata = struct ("H", H, "w", w); # struct for frd-specific data ltisys = lti (p, m, tsam); # parent class for general lti data sys = class (frdata, "frd", ltisys); # create frd object if (numel (varargin) > 0) # if there are any properties and values, ... sys = set (sys, varargin{:}); # use the general set function endif endfunction control-4.1.2/inst/@frd/PaxHeaders/__transpose__.m0000644000000000000000000000007415012430645017101 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__transpose__.m0000644000175000017500000000207415012430645020273 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Transpose of FRD objects. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function sys = __transpose__ (sys) [p, m, l] = size (sys.H); H = mat2cell (sys.H, p, m, ones (1, l))(:); H = cellfun (@transpose, H, "uniformoutput", false); sys.H = cat (3, H{:}); endfunction control-4.1.2/inst/@frd/PaxHeaders/__sys_group__.m0000644000000000000000000000007415012430645017115 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__sys_group__.m0000644000175000017500000000466115012430645020313 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Block diagonal concatenation of two FRD models. ## This file is part of the Model Abstraction Layer. ## For internal use only. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.2 function retsys = __sys_group__ (sys1, sys2) % If one system is just a numeric value, create a proper lti system [sys1, sys2] = __numeric_to_lti__ (sys1, sys2); if (! isa (sys1, "frd")) sys1 = frd (sys1, sys2.w); sys1.lti = sys2.lti; endif if (! isa (sys2, "frd")) sys2 = frd (sys2, sys1.w); sys2.lti = sys1.lti; endif retsys = frd (); retsys.lti = __lti_group__ (sys1.lti, sys2.lti); lw1 = length (sys1.w); lw2 = length (sys2.w); [p1, m1, l1] = size (sys1.H); [p2, m2, l2] = size (sys2.H); ## TODO: tolerances for frequencies, i.e. don't check for equality ## find intersection of frequency vectors if (lw1 == lw2 && all (sys1.w == sys2.w)) # identical frequency vectors retsys.w = sys1.w; H1 = sys1.H; H2 = sys2.H; else # differing frequency vectors ## find common frequencies retsys.w = w = intersect (sys1.w, sys2.w); ## indices of common frequencies w1_idx = arrayfun (@(x) find (sys1.w == x), w); w2_idx = arrayfun (@(x) find (sys2.w == x), w); ## extract common responses H1 = sys1.H(:, :, w1_idx); H2 = sys2.H(:, :, w2_idx); endif ## block-diagonal concatenation lw = length (retsys.w); z12 = zeros (p1, m2); z21 = zeros (p2, m1); H1 = mat2cell (H1, p1, m1, ones (1, lw))(:); H2 = mat2cell (H2, p2, m2, ones (1, lw))(:); H = cellfun (@(x, y) [x, z12; z21, y], H1, H2, "uniformoutput", false); retsys.H = cat (3, H{:}); endfunction control-4.1.2/inst/@frd/PaxHeaders/__sys2ss__.m0000644000000000000000000000007415012430645016331 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__sys2ss__.m0000644000175000017500000000207215012430645017521 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## FRD to SS conversion. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function [retsys, retlti] = __sys2ss__ (sys) error ("frd: frd2ss: system identification not implemented yet"); retsys = dss (a, b, c, d, e); retlti = sys.lti; # preserve lti properties endfunction control-4.1.2/inst/@frd/PaxHeaders/__sys_prune__.m0000644000000000000000000000007415012430645017112 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__sys_prune__.m0000644000175000017500000000226415012430645020305 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Submodel extraction and reordering for FRD objects. ## This file is part of the Model Abstraction Layer. ## For internal use only. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.2 function sys = __sys_prune__ (sys, out_idx, in_idx, w_idx = ":") [sys.lti, out_idx, in_idx] = __lti_prune__ (sys.lti, out_idx, in_idx); sys.H = sys.H(out_idx, in_idx, w_idx); sys.w = sys.w(w_idx); endfunction control-4.1.2/inst/@frd/PaxHeaders/__zero__.m0000644000000000000000000000007415012430645016042 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__zero__.m0000644000175000017500000000174015012430645017233 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Transmission zeros of FRD object. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function [zer, gain, info] = __zero__ (sys, ~) error ("frd: zero: this is not possible"); endfunction control-4.1.2/inst/@frd/PaxHeaders/__sys_inverse__.m0000644000000000000000000000007415012430645017434 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__sys_inverse__.m0000644000175000017500000000207015012430645020622 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Inversion of FRD objects. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function sys = __sys_inverse__ (sys) [p, m, l] = size (sys.H); H = mat2cell (sys.H, p, m, ones (1, l))(:); H = cellfun (@inv, H, "uniformoutput", false); sys.H = cat (3, H{:}); endfunction control-4.1.2/inst/@frd/PaxHeaders/__times__.m0000644000000000000000000000007415012430645016204 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__times__.m0000644000175000017500000000205615012430645017376 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Hadamard/Schur product of @acronym{FRD} objects. ## Used by Octave for "sys1 .* sys2". ## Author: Lukas Reichlin ## Created: May 2014 ## Version: 0.1 function sys = __times__ (sys1, sys2) error ("frd: times: Hadamard/Schur product is not implemented for FRD objects"); endfunction control-4.1.2/inst/@frd/PaxHeaders/__freqresp__.m0000644000000000000000000000007415012430645016712 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__freqresp__.m0000644000175000017500000000307215012430645020103 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Frequency response of FRD models :-) ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.3 function H = __freqresp__ (sys, w, cellflag = false) [H, w_sys, tsam] = frdata (sys, "array"); if (! isempty (w)) # freqresp (frdsys, w), sigma (frdsys, w), ... tol = sqrt (eps); w_idx = arrayfun (@(x) find (abs (w_sys - x) < tol), w, "uniformoutput", false); w_idx = vertcat (w_idx{:}); ## NOTE: There are problems when cellfun uses "uniformoutput", true ## and find returns an empty matrix, if (length (w_idx) != numel (w)) error ("frd: freqresp: some frequencies are not within tolerance %g", tol); endif H = H(:, :, w_idx); endif if (cellflag) [p, m, l] = size (H); H = mat2cell (H, p, m, ones (1, l))(:); endif endfunction control-4.1.2/inst/@frd/PaxHeaders/__get__.m0000644000000000000000000000007415012430645015642 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@frd/__get__.m0000644000175000017500000000220515012430645017030 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Access key values of FRD objects. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.2 function val = __get__ (sys, key) switch (key) # {, } case {"h", "response"} val = sys.H; case {"w", "frequency"} val = sys.w; otherwise error ("frd: get: invalid key name '%s'", key); endswitch endfunction control-4.1.2/inst/PaxHeaders/tfpoly2str.m0000644000000000000000000000007415012430645015544 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/tfpoly2str.m0000644000175000017500000000507415012430645016741 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{str} =} tfpoly2str (@var{p}) ## @deftypefnx {Function File} {@var{str} =} tfpoly2str (@var{p}, @var{tfvar}) ## Return the string of polynomial vector @var{p} with string @var{tfvar^-1} ## as variable. Note that there is an almost identical function for the ## @command{tfpoly} class which returns a string with @var{tfvar} ## (not @var{tfvar^-1}) as variable. ## @end deftypefn ## Author: Lukas Reichlin ## Created: May 2012 ## Version: 0.1 function str = tfpoly2str (p, tfvar = "x") ## TODO: simplify this ugly code str = ""; lp = numel (p); if (lp > 0) # first element (lowest order) idx = find (p); # first non-zero element if (isempty (idx)) str = "0"; return; else idx = idx(1); endif a = p(idx); if (a < 0) cs = "-"; else cs = ""; endif if (idx == 1) str = [cs, num2str(abs (a), 4)]; else if (abs (a) == 1) str = [cs, __variable__(tfvar, idx-1)]; else str = [cs, __coefficient__(a), " ", __variable__(tfvar, idx-1)]; endif endif if (lp > idx) # remaining elements of higher order for k = idx+1 : lp a = p(k); if (a != 0) if (a < 0) cs = " - "; else cs = " + "; endif if (abs (a) == 1) str = [str, cs, __variable__(tfvar, k-1)]; else str = [str, cs, __coefficient__(a), " ", __variable__(tfvar, k-1)]; endif endif endfor endif endif endfunction function str = __coefficient__ (a) b = abs (a); if (b == 1) str = ""; else str = num2str (b, 4); endif endfunction function str = __variable__ (tfvar, n) str = [tfvar, "^-", num2str(n)]; endfunction control-4.1.2/inst/PaxHeaders/dlyapchol.m0000644000000000000000000000007415012430645015373 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/dlyapchol.m0000644000175000017500000001024215012430645016561 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{u} =} dlyapchol (@var{a}, @var{b}) ## @deftypefnx{Function File} {@var{u} =} dlyapchol (@var{a}, @var{b}, @var{e}) ## Compute Cholesky factor of discrete-time Lyapunov equations. ## ## @strong{Equations} ## @example ## @group ## A U' U A' - U' U + B B' = 0 (Lyapunov Equation) ## ## A U' U A' - E U' U E' + B B' = 0 (Generalized Lyapunov Equation) ## @end group ## @end example ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB03OD and SG03BD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @seealso{dlyap, lyap, lyapchol} ## @end deftypefn ## Author: Lukas Reichlin ## Created: January 2010 ## Version: 0.2.1 function [u, scale] = dlyapchol (a, b, e) switch (nargin) case 2 if (! is_real_square_matrix (a)) ## error ("dlyapchol: a must be real and square"); error ("dlyapchol: %s must be real and square", ... inputname (1)); endif if (! is_real_matrix (b)) ## error ("dlyapchol: b must be real") error ("dlyapchol: %s must be real", ... inputname (2)) endif if (rows (a) != rows (b)) ## error ("dlyapchol: a and b must have the same number of rows"); error ("dlyapchol: %s and %s must have the same number of rows", ... inputname (1), inputname (2)); endif [u, scale] = __sl_sb03od__ (a.', b.', true); ## NOTE: TRANS = 'T' not suitable because we need U' U, not U U' case 3 if (! is_real_square_matrix (a, e)) ## error ("dlyapchol: a, e must be real and square"); error ("dlyapchol: %s, %s must be real and square", ... inputname (1), inputname (3)); endif if (! is_real_matrix (b)) ## error ("dlyapchol: b must be real"); error ("dlyapchol: %s must be real", ... inputname (2)); endif if (rows (b) != rows (a) || rows (e) != rows (a)) ## error ("dlyapchol: a, b, e must have the same number of rows"); error ("dlyapchol: %s, %s, %s must have the same number of rows", ... inputname (1), inputname (2), inputname (3)); endif [u, scale] = __sl_sg03bd__ (a.', e.', b.', true); ## NOTE: TRANS = 'T' not suitable because we need U' U, not U U' otherwise print_usage (); endswitch if (scale < 1) warning ("dlyapchol: solution scaled by %g to prevent overflow\n", scale); endif endfunction %!shared U, U_exp %! %! A = [ 0.5000 0.5000 -0.5000 %! 0.0000 1.0000 -0.5000 %! 1.0000 -0.5000 0.0000 ]; %! %! B = [ -2.0 ; 1.0 ; -1.0 ]; %! %! U = dlyapchol (A, B); %! %! U_exp = [ 5.6042 5.1284 1.9562 %! 0.0000 3.4313 -1.6716 %! 0.0000 0.0000 2.5621 ]; %! %!assert (U, U_exp, 1e-4); %!shared U, U_exp %! %! A = [ 0.5000 0.5000 -0.5000 %! 0.0000 1.0000 -0.5000 %! 1.0000 -0.5000 0.0000 ]; %! %! B = [ -2.0 ; 1.0 ; -1.0 ]; %! %! E = [ 2.0000 0.0000 0.0000 %! 0.0000 2.0000 0.0000 %! 0.0000 0.0000 2.0000 ]; %! %! U = dlyapchol (A, B, E); %! %! U_exp = [ 1.0488 -0.3546 0.4644 %! 0.0000 0.6560 -0.5187 %! 0.0000 0.0000 0.4099 ]; %! %!assert (U, U_exp, 1e-4); control-4.1.2/inst/PaxHeaders/db2mag.m0000644000000000000000000000007415012430645014550 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/db2mag.m0000644000175000017500000000261315012430645015741 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{mag} =} db2mag (@var{db}) ## Convert Decibels (dB) to Magnitude. ## ## @strong{Inputs} ## @table @var ## @item db ## Decibel (dB) value(s). Both real-valued scalars and matrices are accepted. ## @end table ## ## @strong{Outputs} ## @table @var ## @item mag ## Magnitude value(s). ## @end table ## ## @seealso{mag2db} ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2012 ## Version: 0.1 function mag = db2mag (db) if (nargin != 1 || ! is_real_matrix (db)) print_usage (); endif mag = 10.^(db./20); endfunction %!assert (db2mag (40), 100); %!assert (db2mag (-20), 0.1); control-4.1.2/inst/PaxHeaders/optiPIDctrl.m0000644000000000000000000000007415012430645015611 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/optiPIDctrl.m0000644000175000017500000000122215012430645016775 0ustar00lilgelilge00000000000000% =============================================================================== % optiPIDctrl Lukas Reichlin February 2012 % =============================================================================== % Return PID controller with roll-off for given parameters Kp, Ti and Td. % =============================================================================== function C = optiPIDctrl (Kp, Ti, Td) tau = Td / 10; % roll-off num = Kp * [Ti*Td, Ti, 1]; den = conv ([Ti, 0], [tau^2, 2*tau, 1]); C = tf (num, den); end % =============================================================================== control-4.1.2/inst/PaxHeaders/fwcfconred.m0000644000000000000000000000007415012430645015534 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/fwcfconred.m0000644000175000017500000002400215012430645016721 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{Kr}, @var{info}] =} fwcfconred (@var{G}, @var{F}, @var{L}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} fwcfconred (@var{G}, @var{F}, @var{L}, @var{ncr}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} fwcfconred (@var{G}, @var{F}, @var{L}, @var{opt}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} fwcfconred (@var{G}, @var{F}, @var{L}, @var{ncr}, @var{opt}, @dots{}) ## ## Reduction of state-feedback-observer based controller by frequency-weighted coprime factorization (FW CF). ## Given a plant @var{G}, state feedback gain @var{F} and full observer gain @var{L}, ## determine a reduced order controller @var{Kr} by using stability enforcing frequency weights. ## ## @strong{Inputs} ## @table @var ## @item G ## @acronym{LTI} model of the open-loop plant (A,B,C,D). ## It has m inputs, p outputs and n states. ## @item F ## Stabilizing state feedback matrix (m-by-n). ## @item L ## Stabilizing observer gain matrix (n-by-p). ## @item ncr ## The desired order of the resulting reduced order controller @var{Kr}. ## If not specified, @var{ncr} is chosen automatically according ## to the description of key @var{'order'}. ## @item @dots{} ## Optional pairs of keys and values. @code{"key1", value1, "key2", value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item Kr ## State-space model of reduced order controller. ## @item info ## Struct containing additional information. ## @table @var ## @item info.hsv ## The Hankel singular values of the extended system?!?. ## The @var{n} Hankel singular values are ordered decreasingly. ## @item info.ncr ## The order of the obtained reduced order controller @var{Kr}. ## @end table ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'order', 'ncr' ## The desired order of the resulting reduced order controller @var{Kr}. ## If not specified, @var{ncr} is chosen automatically such that states with ## Hankel singular values @var{info.hsv} > @var{tol1} are retained. ## ## @item 'method' ## Order reduction approach to be used as follows: ## @table @var ## @item 'sr', 'b' ## Use the square-root Balance & Truncate method. ## @item 'bfsr', 'f' ## Use the balancing-free square-root Balance & Truncate method. Default method. ## @end table ## ## @item 'cf' ## Specifies whether left or right coprime factorization is ## to be used as follows: ## @table @var ## @item 'left', 'l' ## Use left coprime factorization. ## @item 'right', 'r' ## Use right coprime factorization. Default method. ## @end table ## ## @item 'feedback' ## Specifies whether @var{F} and @var{L} are fed back positively or negatively: ## @table @var ## @item '+' ## A+BK and A+LC are both Hurwitz matrices. ## @item '-' ## A-BK and A-LC are both Hurwitz matrices. Default value. ## @end table ## ## @item 'tol1' ## If @var{'order'} is not specified, @var{tol1} contains the tolerance for ## determining the order of the reduced system. ## For model reduction, the recommended value of @var{tol1} is ## c*info.hsv(1), where c lies in the interval [0.00001, 0.001]. ## Default value is n*eps*info.hsv(1). ## If @var{'order'} is specified, the value of @var{tol1} is ignored. ## @end table ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB16CD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: December 2011 ## Version: 0.1 function [Kr, info] = fwcfconred (G, F, L, varargin) if (nargin < 3) print_usage (); endif if (! isa (G, "lti")) error ("fwcfconred: first argument must be an LTI system"); endif if (! is_real_matrix (F)) error ("fwcfconred: second argument must be a real matrix"); endif if (! is_real_matrix (L)) error ("fwcfconred: third argument must be a real matrix"); endif if (nargin > 3) # fwcfconred (G, F, L, ...) if (is_real_scalar (varargin{1})) # fwcfconred (G, F, L, nr) varargin = horzcat (varargin(2:end), {"order"}, varargin(1)); endif if (isstruct (varargin{1})) # fwcfconred (G, F, L, opt, ...), fwcfconred (G, F, L, nr, opt, ...) varargin = horzcat (__opt2cell__ (varargin{1}), varargin(2:end)); endif ## order placed at the end such that nr from fwcfconred (G, F, L, nr, ...) ## and fwcfconred (G, F, L, nr, opt, ...) overrides possible nr's from ## key/value-pairs and inside opt struct (later keys override former keys, ## nr > key/value > opt) endif nkv = numel (varargin); # number of keys and values if (rem (nkv, 2)) error ("fwcfconred: keys and values must come in pairs"); endif [a, b, c, d, tsam] = ssdata (G); [p, m] = size (G); n = rows (a); [mf, nf] = size (F); [nl, pl] = size (L); dt = isdt (G); jobd = any (d(:)); if (mf != m || nf != n) error ("fwcfconred: dimensions of state-feedback matrix (%dx%d) and plant (%dx%d, %d states) don't match", ... mf, nf, p, m, n); endif if (nl != n || pl != p) error ("fwcfconred: dimensions of observer matrix (%dx%d) and plant (%dx%d, %d states) don't match", ... nl, pl, p, m, n); endif ## default arguments tol1 = 0.0; jobcf = 1; jobmr = 1; # balancing-free BTA ordsel = 1; ncr = 0; negfb = true; # A-BK, A-LC Hurwitz ## handle keys and values for k = 1 : 2 : nkv key = lower (varargin{k}); val = varargin{k+1}; switch (key) case {"order", "ncr", "nr"} [ncr, ordsel] = __modred_check_order__ (val, n); case {"tol1", "tol"} tol1 = __modred_check_tol__ (val, "tol1"); case "cf" switch (lower (val(1))) case "l" jobcf = 0; case "r" jobcf = 1; otherwise error ("cfconred: '%s' is an invalid coprime factorization", val); endswitch case "method" # approximation method switch (tolower (val)) case {"sr-bta", "b", "sr"} # 'B': use the square-root Balance & Truncate method jobmr = 0; case {"bfsr-bta", "f", "bfsr"} # 'F': use the balancing-free square-root Balance & Truncate method jobmr = 1; otherwise error ("cfconred: '%s' is an invalid approach", val); endswitch case "feedback" negfb = __conred_check_feedback_sign__ (val); otherwise warning ("fwcfconred: invalid property name '%s' ignored\n", key); endswitch endfor ## A - B*F --> A + B*F ; A - L*C --> A + L*C if (negfb) F = -F; L = -L; endif ## perform model order reduction [acr, bcr, ccr, ncr, hsv] = __sl_sb16cd__ (a, b, c, d, dt, ncr, ordsel, jobd, jobmr, ... F, L, jobcf, tol1); ## assemble reduced order controller Kr = ss (acr, bcr, ccr, [], tsam); ## assemble info struct info = struct ("ncr", ncr, "hsv", hsv); endfunction %!shared Mo, Me, Info, HSVe %! A = [ 0 1.0000 0 0 0 0 0 0 %! 0 0 0 0 0 0 0 0 %! 0 0 -0.0150 0.7650 0 0 0 0 %! 0 0 -0.7650 -0.0150 0 0 0 0 %! 0 0 0 0 -0.0280 1.4100 0 0 %! 0 0 0 0 -1.4100 -0.0280 0 0 %! 0 0 0 0 0 0 -0.0400 1.850 %! 0 0 0 0 0 0 -1.8500 -0.040 ]; %! %! B = [ 0.0260 %! -0.2510 %! 0.0330 %! -0.8860 %! -4.0170 %! 0.1450 %! 3.6040 %! 0.2800 ]; %! %! C = [ -.996 -.105 0.261 .009 -.001 -.043 0.002 -0.026 ]; %! %! D = [ 0.0 ]; %! %! G = ss (A, B, C, D); % "scaled", false %! %! F = [ 4.472135954999638e-002 6.610515358414598e-001 4.698598960657579e-003 3.601363251422058e-001 1.032530880771415e-001 -3.754055214487997e-002 -4.268536964759344e-002 3.287284547842979e-002 ]; %! %! L = [ 4.108939884667451e-001 %! 8.684600000000012e-002 %! 3.852317308197148e-004 %! -3.619366874815911e-003 %! -8.803722876359955e-003 %! 8.420521094001852e-003 %! 1.234944428038507e-003 %! 4.263205617645322e-003 ]; %! %! [Kr, Info] = fwcfconred (G, F, L, 2, "method", "bfsr", "cf", "right", "feedback", "+"); %! [Ao, Bo, Co, Do] = ssdata (Kr); %! %! Ae = [ -0.4334 0.4884 %! -0.1950 -0.1093 ]; %! %! Be = [ -0.4231 %! -0.1785 ]; %! %! Ce = [ -0.0326 -0.2307 ]; %! %! De = [ 0.0000 ]; %! %! HSVe = [ 3.3073 0.7274 0.1124 0.0784 0.0242 0.0182 0.0101 0.0094 ].'; %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [Ae, Be; Ce, De]; %! %!assert (Mo, Me, 1e-4); %!assert (Info.hsv, HSVe, 1e-4); control-4.1.2/inst/PaxHeaders/lqry.m0000644000000000000000000000007415012430645014403 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/lqry.m0000644000175000017500000000512215012430645015572 0ustar00lilgelilge00000000000000## Copyright (C) 2024 Fabio Di Iorio ## ## This file is part of the Control package for GNU Octave. ## ## Octave 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. ## ## Octave 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 Octave; see the file COPYING. If not, ## see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{g}, @var{x}, @var{l}] =} lqry (@var{sys}, @var{q}, @var{r}, @var{s}) ## Linear-quadratic regulator with output weighting. ## ## @strong{Inputs} ## @table @var ## @item sys ## Continuous or discrete-time @acronym{LTI} model (p-by-m, n states). ## @item q ## Outputs weighting matrix (p-by-p). ## @item r ## Input weighting matrix (m-by-m). ## @item s ## Optional cross term matrix (p-by-m). If @var{s} is not specified, a zero matrix is assumed. ## @end table ## ## @strong{Outputs} ## @table @var ## @item g ## State feedback matrix (m-by-n). ## @item x ## Unique stabilizing solution of the continuous-time Riccati equation (n-by-n). ## @item l ## Closed-loop poles (n-by-1). ## @end table ## ## @strong{Equations} ## @tex ## $$ \dot{x} = A\,x + B\,u,\quad x(0) = x_0 $$ ## $$ y = C\,x + D\,u $$ ## $$ J(x_0) = \int_0^\infty y^T Q\, y + u^T R\, u + 2\, y^T S\, u \,\, dt $$ ## $$ L = \sigma (A - B\, G) $$ ## @end tex ## @ifnottex ## @example ## @group ## . ## x = A x + B u, x(0) = x0 ## y = C x + D u ## ## inf ## J(x0) = INT (y' Q y + u' R u + 2 y' S u) dt ## 0 ## ## L = eig (A - B*G) ## @end group ## @end example ## @end ifnottex ## ## @seealso{lqr, dare, dlqr} ## @end deftypefn ## Author: Fabio Di Iorio ## Created: June 2024 ## Version: 0.1 function [g, x, l] = lqry (sys, q, r, s = []) if (nargin < 3 || nargin > 4 || ~isa (sys, "lti")) print_usage (); endif Q = q; R = r; N = s; [n, m] = size(sys.b); [p, ~] = size(sys.c); if isempty(N) N=zeros(p,m); endif [A, B, C, D, Ts] = ssdata(sys); [g, x, l] = lqr (sys, C'*Q*C,D'*Q*D+D'*N+N'*D+R,C'*N+C'*Q*D); endfunction %!test %! A = [1 -1; 0 -5]; %! B = [0;1]; %! C = [1 0]; %! D = 0; %! sys = ss(A,B,C,D); %! g = lqry(sys,10,1,1); %! assert(eig(A-B*g)<0,'lqry error') control-4.1.2/inst/PaxHeaders/hsvd.m0000644000000000000000000000007415012430645014360 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/hsvd.m0000644000175000017500000000700715012430645015553 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{hsv} =} hsvd (@var{sys}) ## @deftypefnx{Function File} {@var{hsv} =} hsvd (@var{sys}, @var{"offset"}, @var{offset}) ## @deftypefnx{Function File} {@var{hsv} =} hsvd (@var{sys}, @var{"alpha"}, @var{alpha}) ## Hankel singular values of the stable part of an @acronym{LTI} model. If no output arguments are ## given, the Hankel singular values are displayed in a plot. ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB13AD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: January 2010 ## Version: 0.4 function hsv_r = hsvd (sys, prop = "offset", val = 1e-8) if (nargin != 1 && nargin != 3) print_usage (); endif if (! isa (sys, "lti")) error ("hsvd: first argument must be an LTI system"); endif if (! is_real_scalar (val)) error ("hsvd: third argument must be a real scalar"); endif [a, b, c, ~, ~, scaled] = ssdata (sys); discrete = ! isct (sys); switch (tolower (prop(1))) case "o" # offset if (discrete) alpha = 1 - val; else alpha = - val; endif case "a" # alpha alpha = val; otherwise error ("hsvd: second argument invalid"); endswitch [hsv, ns] = __sl_ab13ad__ (a, b, c, discrete, alpha, scaled); if (nargout) hsv_r = hsv; else bar ((1:ns) + (rows (a) - ns), hsv); title (["Hankel Singular Values of Stable Part of ", inputname(1)]); xlabel ("State"); ylabel ("State Energy"); grid ("on"); endif endfunction %!shared hsv, hsv_exp %! a = [ -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 %! -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 %! 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 %! 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 %! 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 %! 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 %! 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300]; %! %! b = [ 0.0000 0.0000 %! 12.5000 0.0000 %! 0.0000 0.0000 %! 0.0000 0.0000 %! 0.0000 0.0000 %! 0.0000 12.500 %! 0.0000 0.0000]; %! %! c = [ 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000]; %! %! sys = ss (a, b, c, [], "scaled", true); %! hsv = hsvd (sys, "alpha", 0.0); %! %! hsv_exp = [2.5139; 2.0846; 1.9178; 0.7666; 0.5473; 0.0253; 0.0246]; %! %!assert (hsv, hsv_exp, 1e-4); control-4.1.2/inst/PaxHeaders/repsys.m0000644000000000000000000000007415012430645014741 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/repsys.m0000644000175000017500000000275715012430645016143 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{rsys} =} repsys (@var{sys}, @var{m}, @var{n}) ## @deftypefnx {Function File} {@var{rsys} =} repsys (@var{sys}, [@var{m}, @var{n}]) ## @deftypefnx {Function File} {@var{rsys} =} repsys (@var{sys}, @var{m}) ## Form a block transfer matrix of @var{sys} with @var{m} copies vertically ## and @var{n} copies horizontally. If @var{n} is not specified, it is set to @var{m}. ## @code{repsys (sys, 2, 3)} is equivalent to @code{[sys, sys, sys; sys, sys, sys]}. ## @end deftypefn ## Author: Lukas Reichlin ## Created: May 2014 ## Version: 0.1 function sys = repsys (varargin) if (nargin == 0) print_usage (); endif sys = repmat (varargin{:}); # repmat is overloaded for LTI systems endfunction control-4.1.2/inst/PaxHeaders/BMWengine.m0000644000000000000000000000007415012430645015227 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/BMWengine.m0000644000175000017500000000642315012430645016423 0ustar00lilgelilge00000000000000## -*- 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 ## Created: January 2010 ## Version: 0.1.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, [], "scaled", true); otherwise print_usage (); endswitch endfunction control-4.1.2/inst/PaxHeaders/options.m0000644000000000000000000000007415012430645015107 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/options.m0000644000175000017500000000445515012430645016306 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{opt} =} options (@var{'key1'}, @var{value1}, @var{'key2'}, @var{value2}, @dots{}) ## Create options struct @var{opt} from a number of key and value pairs. ## For use with order reduction and system identification functions. ## Option structs are a way to avoid typing the same key and value pairs ## over and over again. ## ## @strong{Inputs} ## @table @var ## @item key, property ## The name of the property. ## @item value ## The value of the property. ## @end table ## ## @strong{Outputs} ## @table @var ## @item opt ## Struct with fields for each key. ## @end table ## ## @strong{Example} ## @example ## @group ## octave:1> opt = options ("method", "spa", "tol", 1e-6) ## opt = ## ## scalar structure containing the fields: ## ## method = spa ## tol = 1.0000e-06 ## ## @end group ## @end example ## @example ## @group ## octave:2> save filename opt ## octave:3> # save the struct 'opt' to file 'filename' for later use ## octave:4> load filename ## octave:5> # load struct 'opt' from file 'filename' ## @end group ## @end example ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2011 ## Version: 0.1 function opt = options (varargin) if (nargin == 0) print_usage (); endif if (rem (nargin, 2)) error ("options: properties and values must come in pairs"); endif ## alternative: opt = struct (varargin{:}); key = reshape (varargin(1:2:end-1), [], 1); val = reshape (varargin(2:2:end), [], 1); opt = cell2struct (val, key, 1); opt = orderfields (opt); endfunction control-4.1.2/inst/PaxHeaders/step.m0000644000000000000000000000007415012430645014367 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/step.m0000644000175000017500000000665215012430645015567 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {} step (@var{sys}) ## @deftypefnx{Function File} {} step (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}) ## @deftypefnx{Function File} {} step (@var{sys1}, @var{'style1'}, @dots{}, @var{sysN}, @var{'styleN'}) ## @deftypefnx{Function File} {} step (@var{sys1}, @dots{}, @var{t}) ## @deftypefnx{Function File} {} step (@var{sys1}, @dots{}, @var{tfinal}) ## @deftypefnx{Function File} {} step (@var{sys1}, @dots{}, @var{tfinal}, @var{dt}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} step (@var{sys}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} step (@var{sys}, @var{t}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} step (@var{sys}, @var{tfinal}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} step (@var{sys}, @var{tfinal}, @var{dt}) ## Step response of @acronym{LTI} system. ## If no output arguments are given, the response is printed on the screen. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @item t ## Time vector. Should be evenly spaced. If not specified, it is calculated by ## the poles of the system to reflect adequately the response transients. ## @item tfinal ## Optional simulation horizon. If not specified, it is calculated by ## the poles of the system to reflect adequately the response transients. ## @item dt ## Optional sampling time. Be sure to choose it small enough to capture transient ## phenomena. If not specified, it is calculated by the poles of the system. ## @item 'style' ## Line style and color, e.g. 'r' for a solid red line or '-.k' for a dash-dotted ## black line. See @command{help plot} for details. ## @end table ## ## @strong{Outputs} ## @table @var ## @item y ## Output response array. Has as many rows as time samples (length of t) ## and as many columns as outputs. ## @item t ## Time row vector. ## @item x ## State trajectories array. Has @code{length (t)} rows and as many columns as states. ## @end table ## ## @seealso{impulse, initial, lsim} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 1.0 function [y_r, t_r, x_r] = step (varargin) if (nargin == 0) print_usage (); endif names = cell (1,nargin); for i = 1:nargin names{i} = inputname (i); end [y, t, x] = __time_response__ ("step", varargin, names, nargout); if (nargout) y_r = y{1}; t_r = t{1}; x_r = x{1}; endif endfunction %!demo %! clf; %! s = tf('s'); %! g = 1/(2*s^2+3*s+4); %! step(g); %! title ("Step response of a PT2 transfer function"); %!demo %! clf; %! s = tf('s'); %! g = 1/(2*s^2+3*s+4); %! h = c2d(g,0.1); %! step(h); %! title ("Step response of a discretized PT2 transfer function"); control-4.1.2/inst/PaxHeaders/dlqr.m0000644000000000000000000000007415012430645014356 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/dlqr.m0000644000175000017500000000606515012430645015554 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{g}, @var{x}, @var{l}] =} dlqr (@var{sys}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{g}, @var{x}, @var{l}] =} dlqr (@var{sys}, @var{q}, @var{r}, @var{s}) ## @deftypefnx {Function File} {[@var{g}, @var{x}, @var{l}] =} dlqr (@var{a}, @var{b}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{g}, @var{x}, @var{l}] =} dlqr (@var{a}, @var{b}, @var{q}, @var{r}, @var{s}) ## @deftypefnx {Function File} {[@var{g}, @var{x}, @var{l}] =} dlqr (@var{a}, @var{b}, @var{q}, @var{r}, @var{[]}, @var{e}) ## @deftypefnx {Function File} {[@var{g}, @var{x}, @var{l}] =} dlqr (@var{a}, @var{b}, @var{q}, @var{r}, @var{s}, @var{e}) ## Linear-quadratic regulator for discrete-time systems. ## ## @strong{Inputs} ## @table @var ## @item sys ## Continuous or discrete-time @acronym{LTI} model (p-by-m, n states). ## @item a ## State transition matrix of discrete-time system (n-by-n). ## @item b ## Input matrix of discrete-time system (n-by-m). ## @item q ## State weighting matrix (n-by-n). ## @item r ## Input weighting matrix (m-by-m). ## @item s ## Optional cross term matrix (n-by-m). If @var{s} is not specified, a zero matrix is assumed. ## @item e ## Optional descriptor matrix (n-by-n). If @var{e} is not specified, an identity matrix is assumed. ## @end table ## ## @strong{Outputs} ## @table @var ## @item g ## State feedback matrix (m-by-n). ## @item x ## Unique stabilizing solution of the discrete-time Riccati equation (n-by-n). ## @item l ## Closed-loop poles (n-by-1). ## @end table ## ## @strong{Equations} ## @example ## @group ## x[k+1] = A x[k] + B u[k], x[0] = x0 ## ## inf ## J(x0) = SUM (x' Q x + u' R u + 2 x' S u) ## k=0 ## ## L = eig (A - B*G) ## @end group ## @end example ## @seealso{dare, care, lqr} ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 0.2 function [g, x, l] = dlqr (a, b, q, r = [], s = [], e = []) if (nargin < 3 || nargin > 6) print_usage (); endif if (isa (a, "lti")) s = r; r = q; q = b; [a, b, c, d, e, tsam] = dssdata (a, []); elseif (nargin < 4) print_usage (); else tsam = 1; # any value > 0 could be used here endif if (issample (tsam, -1)) [x, l, g] = dare (a, b, q, r, s, e); else [x, l, g] = care (a, b, q, r, s, e); endif endfunction control-4.1.2/inst/PaxHeaders/tfpolyones.m0000644000000000000000000000007415012430645015616 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/tfpolyones.m0000644000175000017500000000177615012430645017020 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Return (pxm) cell of tfpoly([1]). For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function ret = tfpolyones (p, m) ret = cell (p, m); one = tfpoly ([1]); ret(:) = {one}; endfunction control-4.1.2/inst/PaxHeaders/hnamodred.m0000644000000000000000000000007415012430645015355 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/hnamodred.m0000644000175000017500000003574515012430645016562 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{Gr}, @var{info}] =} hnamodred (@var{G}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} hnamodred (@var{G}, @var{nr}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} hnamodred (@var{G}, @var{opt}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} hnamodred (@var{G}, @var{nr}, @var{opt}, @dots{}) ## ## Model order reduction by frequency weighted optimal Hankel-norm (HNA) method. ## The aim of model reduction is to find an @acronym{LTI} system @var{Gr} of order ## @var{nr} (nr < n) such that the input-output behaviour of @var{Gr} ## approximates the one from original system @var{G}. ## ## HNA is an absolute error method which tries to minimize ## @iftex ## @tex ## $$ || G - G_r ||_H = \\min $$ ## $$ || V \\ (G - G_r) \\ W ||_H = \\min $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## ||G-Gr|| = min ## H ## ## ||V (G-Gr) W|| = min ## H ## @end example ## @end ifnottex ## where @var{V} and @var{W} denote output and input weightings. ## ## ## @strong{Inputs} ## @table @var ## @item G ## @acronym{LTI} model to be reduced. ## @item nr ## The desired order of the resulting reduced order system @var{Gr}. ## If not specified, @var{nr} is chosen automatically according ## to the description of key @var{"order"}. ## @item @dots{} ## Optional pairs of keys and values. @code{"key1", value1, "key2", value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item Gr ## Reduced order state-space model. ## @item info ## Struct containing additional information. ## @table @var ## @item info.n ## The order of the original system @var{G}. ## @item info.ns ## The order of the @var{alpha}-stable subsystem of the original system @var{G}. ## @item info.hsv ## The Hankel singular values corresponding to the projection @code{op(V)*G1*op(W)}, ## where G1 denotes the @var{alpha}-stable part of the original system @var{G}. ## The @var{ns} Hankel singular values are ordered decreasingly. ## @item info.nu ## The order of the @var{alpha}-unstable subsystem of both the original ## system @var{G} and the reduced-order system @var{Gr}. ## @item info.nr ## The order of the obtained reduced order system @var{Gr}. ## @end table ## @end table ## ## ## @strong{Option Keys and Values} ## @table @var ## @item 'order', 'nr' ## The desired order of the resulting reduced order system @var{Gr}. ## If not specified, @var{nr} is the sum of @var{info.nu} and the number of ## Hankel singular values greater than @code{max(tol1, ns*eps*info.hsv(1)}; ## ## @item 'method' ## Specifies the computational approach to be used. ## Valid values corresponding to this key are: ## @table @var ## @item 'descriptor' ## Use the inverse free descriptor system approach. ## @item 'standard' ## Use the inversion based standard approach. ## @item 'auto' ## Switch automatically to the inverse free ## descriptor approach in case of badly conditioned ## feedthrough matrices in V or W. Default method. ## @end table ## ## ## @item 'left', 'v' ## @acronym{LTI} model of the left/output frequency weighting. ## The weighting must be antistable. ## @iftex ## @math{|| V \\ (G-G_r) \\dots ||_H = \\min} ## @end iftex ## @ifnottex ## @example ## || V (G-Gr) . || = min ## H ## @end example ## @end ifnottex ## ## @item 'right', 'w' ## @acronym{LTI} model of the right/input frequency weighting. ## The weighting must be antistable. ## @iftex ## @math{|| \\dots (G-G_r) \\ W ||_H = \\min} ## @end iftex ## @ifnottex ## @example ## || . (G-Gr) W || = min ## H ## @end example ## @end ifnottex ## ## ## @item 'left-inv', 'inv-v' ## @acronym{LTI} model of the left/output frequency weighting. ## The weighting must have only antistable zeros. ## @iftex ## @math{|| inv(V) \\ (G-G_r) \\dots ||_H = \\min} ## @end iftex ## @ifnottex ## @example ## || inv(V) (G-Gr) . || = min ## H ## @end example ## @end ifnottex ## ## @item 'right-inv', 'inv-w' ## @acronym{LTI} model of the right/input frequency weighting. ## The weighting must have only antistable zeros. ## @iftex ## @math{|| \\dots (G-G_r) \\ inv(W) ||_H = \\min} ## @end iftex ## @ifnottex ## @example ## || . (G-Gr) inv(W) || = min ## H ## @end example ## @end ifnottex ## ## ## @item 'left-conj', 'conj-v' ## @acronym{LTI} model of the left/output frequency weighting. ## The weighting must be stable. ## @iftex ## @math{|| conj(V) \\ (G-G_r) \\dots ||_H = \\min} ## @end iftex ## @ifnottex ## @example ## || V (G-Gr) . || = min ## H ## @end example ## @end ifnottex ## ## @item 'right-conj', 'conj-w' ## @acronym{LTI} model of the right/input frequency weighting. ## The weighting must be stable. ## @iftex ## @math{|| \\dots (G-G_r) \\ conj(W) ||_H = \\min} ## @end iftex ## @ifnottex ## @example ## || . (G-Gr) W || = min ## H ## @end example ## @end ifnottex ## ## ## @item 'left-conj-inv', 'conj-inv-v' ## @acronym{LTI} model of the left/output frequency weighting. ## The weighting must be minimum-phase. ## @iftex ## @math{|| conj(inv(V)) \\ (G-G_r) \\dots ||_H = \\min} ## @end iftex ## @ifnottex ## @example ## || V (G-Gr) . || = min ## H ## @end example ## @end ifnottex ## ## @item 'right-conj-inv', 'conj-inv-w' ## @acronym{LTI} model of the right/input frequency weighting. ## The weighting must be minimum-phase. ## @iftex ## @math{|| \\dots (G-G_r) \\ conj(inv(W)) ||_H = \\min} ## @end iftex ## @ifnottex ## @example ## || . (G-Gr) W || = min ## H ## @end example ## @end ifnottex ## ## ## @item 'alpha' ## Specifies the ALPHA-stability boundary for the eigenvalues ## of the state dynamics matrix @var{G.A}. For a continuous-time ## system, ALPHA <= 0 is the boundary value for ## the real parts of eigenvalues, while for a discrete-time ## system, 0 <= ALPHA <= 1 represents the ## boundary value for the moduli of eigenvalues. ## The ALPHA-stability domain does not include the boundary. ## Default value is 0 for continuous-time systems and ## 1 for discrete-time systems. ## ## @item 'tol1' ## If @var{'order'} is not specified, @var{tol1} contains the tolerance for ## determining the order of the reduced model. ## For model reduction, the recommended value of @var{tol1} is ## c*info.hsv(1), where c lies in the interval [0.00001, 0.001]. ## @var{tol1} < 1. ## If @var{'order'} is specified, the value of @var{tol1} is ignored. ## ## @item 'tol2' ## The tolerance for determining the order of a minimal ## realization of the ALPHA-stable part of the given ## model. @var{tol2} <= @var{tol1} < 1. ## If not specified, ns*eps*info.hsv(1) is chosen. ## ## @item 'equil', 'scale' ## Boolean indicating whether equilibration (scaling) should be ## performed on system @var{G} prior to order reduction. ## Default value is true if @code{G.scaled == false} and ## false if @code{G.scaled == true}. ## Note that for @acronym{MIMO} models, proper scaling of both inputs and outputs ## is of utmost importance. The input and output scaling can @strong{not} ## be done by the equilibration option or the @command{prescale} function ## because these functions perform state transformations only. ## Furthermore, signals should not be scaled simply to a certain range. ## For all inputs (or outputs), a certain change should be of the same ## importance for the model. ## @end table ## ## ## Approximation Properties: ## @itemize @bullet ## @item ## Guaranteed stability of reduced models ## @item ## Lower guaranteed error bound ## @item ## Guaranteed a priori error bound ## @iftex ## @tex ## $$ \\sigma_{r+1} \\leq || (G-G_r) ||_{\\infty} \\leq 2 \\sum_{j=r+1}^{n} \\sigma_j $$ ## @end tex ## @end iftex ## @end itemize ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB09JD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2011 ## Version: 0.1 function [Gr, info] = hnamodred (G, varargin) if (nargin == 0) print_usage (); endif if (! isa (G, "lti")) error ("hnamodred: first argument must be an LTI system"); endif if (nargin > 1) # hnamodred (G, ...) if (is_real_scalar (varargin{1})) # hnamodred (G, nr) varargin = horzcat (varargin(2:end), {"order"}, varargin(1)); endif if (isstruct (varargin{1})) # hnamodred (G, opt, ...), hnamodred (G, nr, opt, ...) varargin = horzcat (__opt2cell__ (varargin{1}), varargin(2:end)); endif ## order placed at the end such that nr from hnamodred (G, nr, ...) ## and hnamodred (G, nr, opt, ...) overrides possible nr's from ## key/value-pairs and inside opt struct (later keys override former keys, ## nr > key/value > opt) endif nkv = numel (varargin); # number of keys and values if (rem (nkv, 2)) error ("hnamodred: keys and values must come in pairs"); endif [a, b, c, d, tsam, scaled] = ssdata (G); [p, m] = size (G); dt = isdt (G); ## default arguments alpha = __modred_default_alpha__ (dt); av = bv = cv = dv = []; jobv = 0; aw = bw = cw = dw = []; jobw = 0; jobinv = 2; tol1 = 0; tol2 = 0; ordsel = 1; nr = 0; ## handle keys and values for k = 1 : 2 : nkv key = lower (varargin{k}); val = varargin{k+1}; switch (key) case {"left", "v", "wo"} [av, bv, cv, dv, jobv] = __modred_check_weight__ (val, dt, p, p); ## TODO: correct error messages for non-square weights case {"right", "w", "wi"} [aw, bw, cw, dw, jobw] = __modred_check_weight__ (val, dt, m, m); case {"left-inv", "inv-v"} [av, bv, cv, dv] = __modred_check_weight__ (val, dt, p, p); jobv = 2; case {"right-inv", "inv-w"} [aw, bw, cw, dw] = __modred_check_weight__ (val, dt, m, m); jobv = 2 case {"left-conj", "conj-v"} [av, bv, cv, dv] = __modred_check_weight__ (val, dt, p, p); jobv = 3; case {"right-conj", "conj-w"} [aw, bw, cw, dw] = __modred_check_weight__ (val, dt, m, m); jobv = 3 case {"left-conj-inv", "conj-inv-v"} [av, bv, cv, dv] = __modred_check_weight__ (val, dt, p, p); jobv = 4; case {"right-conj-inv", "conj-inv-w"} [aw, bw, cw, dw] = __modred_check_weight__ (val, dt, m, m); jobv = 4 case {"order", "nr"} [nr, ordsel] = __modred_check_order__ (val, rows (a)); case "tol1" tol1 = __modred_check_tol__ (val, "tol1"); case "tol2" tol2 = __modred_check_tol__ (val, "tol2"); case "alpha" alpha = __modred_check_alpha__ (val, dt); case "method" switch (tolower (val(1))) case {"d", "n"} # "descriptor" jobinv = 0; case {"s", "i"} # "standard" jobinv = 1; case "a" # {"auto", "automatic"} jobinv = 2; otherwise error ("hnamodred: invalid computational approach"); endswitch case {"equil", "equilibrate", "equilibration", "scale", "scaling"} scaled = __modred_check_equil__ (val); otherwise warning ("hnamodred: invalid property name '%s' ignored\n", key); endswitch endfor ## perform model order reduction [ar, br, cr, dr, nr, hsv, ns] = __sl_ab09jd__ (a, b, c, d, dt, scaled, nr, ordsel, alpha, ... jobv, av, bv, cv, dv, ... jobw, aw, bw, cw, dw, ... jobinv, tol1, tol2); ## assemble reduced order model Gr = ss (ar, br, cr, dr, tsam); ## assemble info struct n = rows (a); nu = n - ns; info = struct ("n", n, "ns", ns, "hsv", hsv, "nu", nu, "nr", nr); endfunction %!shared Mo, Me, Info, HSVe %! A = [ -3.8637 -7.4641 -9.1416 -7.4641 -3.8637 -1.0000 %! 1.0000, 0 0 0 0 0 %! 0 1.0000 0 0 0 0 %! 0 0 1.0000 0 0 0 %! 0 0 0 1.0000 0 0 %! 0 0 0 0 1.0000 0 ]; %! %! B = [ 1 %! 0 %! 0 %! 0 %! 0 %! 0 ]; %! %! C = [ 0 0 0 0 0 1 ]; %! %! D = [ 0 ]; %! %! G = ss (A, B, C, D); # "scaled", false %! %! AV = [ 0.2000 -1.0000 %! 1.0000 0 ]; %! %! BV = [ 1 %! 0 ]; %! %! CV = [ -1.8000 0 ]; %! %! DV = [ 1 ]; %! %! V = ss (AV, BV, CV, DV); %! %! [Gr, Info] = hnamodred (G, "left", V, "tol1", 1e-1, "tol2", 1e-14); %! [Ao, Bo, Co, Do] = ssdata (Gr); %! %! Ae = [ -0.2391 0.3072 1.1630 1.1967 %! -2.9709 -0.2391 2.6270 3.1027 %! 0.0000 0.0000 -0.5137 -1.2842 %! 0.0000 0.0000 0.1519 -0.5137 ]; %! %! Be = [ -1.0497 %! -3.7052 %! 0.8223 %! 0.7435 ]; %! %! Ce = [ -0.4466 0.0143 -0.4780 -0.2013 ]; %! %! De = [ 0.0219 ]; %! %! # Since hnamodred approximates the input/output behavior only %! # input/output behavior is tested using n first Markov parameters. %! # The state space representaton might have different signs %! # of the states. %! # By multiplying the matrices for the Markov parameters, numeric errors %! # would propagate, therefor the accuracy of the results are limited to %! # the accuracy of the given expected results %! %! [Ao,Bo,Co,Do] = ssdata (Gr); %! Ao = round (Ao*1e4)/1e4; %! Bo = round (Bo*1e4)/1e4; %! Co = round (Co*1e4)/1e4; %! Do = round (Do*1e4)/1e4; %! %! n = size(Ao,1); %! m = size(Bo,2); %! p = size(Co,1); %! Mo = zeros (p,(n+1)*m); %! Me = zeros (p,(n+1)*m); %! Mo(:,1:m) = Do; %! Me(:,1:m) = De; %! %! Aoi = eye (n,n); %! Aei = eye (n,n); %! for i = 1:n %! Mo(:,i*m+1:(i+1)*m) = Co*Aoi*Bo; %! Me(:,i*m+1:(i+1)*m) = Ce*Aei*Be; %! Aoi = Aoi*Ao; %! Aei = Aei*Ae; %! endfor %! %! HSVe = [ 2.6790 2.1589 0.8424 0.1929 0.0219 0.0011 ].'; %! %!assert (Mo, Me, 1e-3); %!assert (Info.hsv, HSVe, 1e-4); control-4.1.2/inst/PaxHeaders/__dss2ss__.m0000644000000000000000000000007415012430645015431 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__dss2ss__.m0000644000175000017500000000665115012430645016630 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Convert descriptor state-space system into regular state-space form. ## Author: Lukas Reichlin ## Created: September 2011 ## Version: 0.3 function [a, b, c, d, e] = __dss2ss__ (a, b, c, d, e) if (isempty (e)) return; elseif (rcond (e) < eps) # check for singularity ## check whether regular state-space representation is possible [~, ~, ~, ~, ranke, rnka22] = __sl_tg01fd__ (a, e, b, c, false, 0); if (ranke+rnka22 < rows (a)) error ("dss:improper", "ss: dss2ss: this descriptor system cannot be converted to regular state-space form"); endif endif [a, b, c, d] = __sl_sb10jd__ (a, b, c, d, e); e = []; endfunction ## Test from SLICOT TG01FD %!shared a, b, c, e, ranke, rnka22, q, z, a_exp, b_exp, c_exp, e_exp, q_exp, z_exp %! %! e = [1, 2, 0, 0; 0, 1, 0, 1; 3, 9, 6, 3; 0, 0, 2, 0]; %! a = [-1, 0, 0, 3; 0, 0, 1, 2; 1, 1, 0, 4; 0, 0, 0, 0]; %! b = [1, 0; 0, 0; 0, 1; 1, 1]; %! c = [-1, 0, 1, 0; 0, 1, -1, 1]; %! %! [a, e, b, c, ranke, rnka22, q, z] = __sl_tg01fd__ (a, e, b, c, true, 0.0); %! %! e_exp = [10.1587 5.8230 1.3021 0.0000; %! 0.0000 -2.4684 -0.1896 0.0000; %! 0.0000 0.0000 1.0338 0.0000; %! 0.0000 0.0000 0.0000 0.0000]; %! %! a_exp = [ 2.0278 0.1078 3.9062 -2.1571; %! -0.0980 0.2544 1.6053 -0.1269; %! 0.2713 0.7760 -0.3692 -0.4853; %! 0.0690 -0.5669 -2.1974 0.3086]; %! %! b_exp = [-0.2157 -0.9705; %! 0.3015 0.9516; %! 0.7595 0.0991; %! 1.1339 0.3780]; %! %! c_exp = [ 0.3651 -1.0000 -0.4472 -0.8165; %! -1.0954 1.0000 -0.8944 0.0000]; %! %! q_exp = [-0.2157 -0.5088 0.6109 0.5669; %! -0.1078 -0.2544 -0.7760 0.5669; %! -0.9705 0.1413 -0.0495 -0.1890; %! 0.0000 0.8102 0.1486 0.5669]; %! %! z_exp = [-0.3651 0.0000 0.4472 0.8165; %! -0.9129 0.0000 0.0000 -0.4082; %! 0.0000 -1.0000 0.0000 0.0000; %! -0.1826 0.0000 -0.8944 0.4082]; %! %!assert (a, a_exp, 1e-4); %!assert (e, e_exp, 1e-4); %!assert (b, b_exp, 1e-4); %!assert (c, c_exp, 1e-4); %!assert (q, q_exp, 1e-4); %!assert (z, z_exp, 1e-4); %!assert (ranke, 3); %!assert (rnka22, 1); ## test error %!shared mms %! %! mm = tf ([3, 5, 0], [4, 1]); %! mms = ss (mm); %!error (__dss2ss__ (mms.a, mms.b, mms.c, mms.d, mms.e)); ## Realizable descriptor system with singular E matrix %!test %! A = [1 0; 0 1]; %! B = [1; 0]; %! C = [1 0]; %! D = 0; %! E = [1 0; 0 0]; %! %! sys = dss (A, B, C, D, E); %! [Ao, Bo, Co, Do] = ssdata (sys); %! %! assert (Ao, 1, 1e-4); %! assert (Bo, 1, 1e-4); %! assert (Co, 1, 1e-4); %! assert (Do, 0, 1e-4); control-4.1.2/inst/PaxHeaders/spamodred.m0000644000000000000000000000007415012430645015372 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/spamodred.m0000644000175000017500000002060415012430645016563 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{Gr}, @var{info}] =} spamodred (@var{G}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} spamodred (@var{G}, @var{nr}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} spamodred (@var{G}, @var{opt}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} spamodred (@var{G}, @var{nr}, @var{opt}, @dots{}) ## ## Model order reduction by frequency weighted Singular Perturbation Approximation (SPA). ## The aim of model reduction is to find an @acronym{LTI} system @var{Gr} of order ## @var{nr} (nr < n) such that the input-output behaviour of @var{Gr} ## approximates the one from original system @var{G}. ## ## SPA is an absolute error method which tries to minimize ## @iftex ## @tex ## $$ || G - G_r ||_{\\infty} = \\min $$ ## $$ || V \\ (G - G_r) \\ W ||_{\\infty} = \\min $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## ||G-Gr|| = min ## inf ## ## ||V (G-Gr) W|| = min ## inf ## @end example ## @end ifnottex ## where @var{V} and @var{W} denote output and input weightings. ## ## ## @strong{Inputs} ## @table @var ## @item G ## @acronym{LTI} model to be reduced. ## @item nr ## The desired order of the resulting reduced order system @var{Gr}. ## If not specified, @var{nr} is chosen automatically according ## to the description of key @var{'order'}. ## @item @dots{} ## Optional pairs of keys and values. @code{"key1", value1, "key2", value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item Gr ## Reduced order state-space model. ## @item info ## Struct containing additional information. ## @table @var ## @item info.n ## The order of the original system @var{G}. ## @item info.ns ## The order of the @var{alpha}-stable subsystem of the original system @var{G}. ## @item info.hsv ## The Hankel singular values of the @var{alpha}-stable part of ## the original system @var{G}, ordered decreasingly. ## @item info.nu ## The order of the @var{alpha}-unstable subsystem of both the original ## system @var{G} and the reduced-order system @var{Gr}. ## @item info.nr ## The order of the obtained reduced order system @var{Gr}. ## @end table ## @end table ## ## ## @strong{Option Keys and Values} ## @table @var ## @item 'order', 'nr' ## The desired order of the resulting reduced order system @var{Gr}. ## If not specified, @var{nr} is chosen automatically such that states with ## Hankel singular values @var{info.hsv} > @var{tol1} are retained. ## ## @item 'left', 'output' ## @acronym{LTI} model of the left/output frequency weighting @var{V}. ## Default value is an identity matrix. ## ## @item 'right', 'input' ## @acronym{LTI} model of the right/input frequency weighting @var{W}. ## Default value is an identity matrix. ## ## @item 'method' ## Approximation method for the L-infinity norm to be used as follows: ## @table @var ## @item 'sr', 's' ## Use the square-root Singular Perturbation Approximation method. ## @item 'bfsr', 'p' ## Use the balancing-free square-root Singular Perturbation Approximation method. Default method. ## @end table ## ## @item 'alpha' ## Specifies the ALPHA-stability boundary for the eigenvalues ## of the state dynamics matrix @var{G.A}. For a continuous-time ## system, ALPHA <= 0 is the boundary value for ## the real parts of eigenvalues, while for a discrete-time ## system, 0 <= ALPHA <= 1 represents the ## boundary value for the moduli of eigenvalues. ## The ALPHA-stability domain does not include the boundary. ## Default value is 0 for continuous-time systems and ## 1 for discrete-time systems. ## ## @item 'tol1' ## If @var{'order'} is not specified, @var{tol1} contains the tolerance for ## determining the order of the reduced model. ## For model reduction, the recommended value of @var{tol1} is ## c*info.hsv(1), where c lies in the interval [0.00001, 0.001]. ## Default value is info.ns*eps*info.hsv(1). ## If @var{'order'} is specified, the value of @var{tol1} is ignored. ## ## @item 'tol2' ## The tolerance for determining the order of a minimal ## realization of the ALPHA-stable part of the given ## model. TOL2 <= TOL1. ## If not specified, ns*eps*info.hsv(1) is chosen. ## ## @item 'gram-ctrb' ## Specifies the choice of frequency-weighted controllability ## Grammian as follows: ## @table @var ## @item 'standard' ## Choice corresponding to a combination method [4] ## of the approaches of Enns [1] and Lin-Chiu [2,3]. Default method. ## @item 'enhanced' ## Choice corresponding to the stability enhanced ## modified combination method of [4]. ## @end table ## ## @item 'gram-obsv' ## Specifies the choice of frequency-weighted observability ## Grammian as follows: ## @table @var ## @item 'standard' ## Choice corresponding to a combination method [4] ## of the approaches of Enns [1] and Lin-Chiu [2,3]. Default method. ## @item 'enhanced' ## Choice corresponding to the stability enhanced ## modified combination method of [4]. ## @end table ## ## @item 'alpha-ctrb' ## Combination method parameter for defining the ## frequency-weighted controllability Grammian. ## abs(alphac) <= 1. ## If alphac = 0, the choice of ## Grammian corresponds to the method of Enns [1], while if ## alphac = 1, the choice of Grammian corresponds ## to the method of Lin and Chiu [2,3]. ## Default value is 0. ## ## @item 'alpha-obsv' ## Combination method parameter for defining the ## frequency-weighted observability Grammian. ## abs(alphao) <= 1. ## If alphao = 0, the choice of ## Grammian corresponds to the method of Enns [1], while if ## alphao = 1, the choice of Grammian corresponds ## to the method of Lin and Chiu [2,3]. ## Default value is 0. ## ## @item 'equil', 'scale' ## Boolean indicating whether equilibration (scaling) should be ## performed on system @var{G} prior to order reduction. ## Default value is true if @code{G.scaled == false} and ## false if @code{G.scaled == true}. ## Note that for @acronym{MIMO} models, proper scaling of both inputs and outputs ## is of utmost importance. The input and output scaling can @strong{not} ## be done by the equilibration option or the @command{prescale} function ## because these functions perform state transformations only. ## Furthermore, signals should not be scaled simply to a certain range. ## For all inputs (or outputs), a certain change should be of the same ## importance for the model. ## @end table ## ## ## @strong{References}@* ## [1] Enns, D. ## @cite{Model reduction with balanced realizations: An error bound ## and a frequency weighted generalization}. ## Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. ## ## [2] Lin, C.-A. and Chiu, T.-Y. ## @cite{Model reduction via frequency-weighted balanced realization}. ## Control Theory and Advanced Technology, vol. 8, ## pp. 341-351, 1992. ## ## [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. ## @cite{New results on frequency weighted balanced reduction ## technique}. ## Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. ## ## [4] Varga, A. and Anderson, B.D.O. ## @cite{Square-root balancing-free methods for the frequency-weighted ## balancing related model reduction}. ## (report in preparation) ## ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB09ID}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2011 ## Version: 0.1 function [Gr, info] = spamodred (varargin) [Gr, info] = __modred_ab09id__ ("spa", varargin{:}); endfunction ## TODO: add a test control-4.1.2/inst/PaxHeaders/gensig.m0000644000000000000000000000007415012430645014670 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/gensig.m0000644000175000017500000000537415012430645016070 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{u}, @var{t}] =} gensig (@var{sigtype}, @var{tau}) ## @deftypefnx{Function File} {[@var{u}, @var{t}] =} gensig (@var{sigtype}, @var{tau}, @var{tfinal}) ## @deftypefnx{Function File} {[@var{u}, @var{t}] =} gensig (@var{sigtype}, @var{tau}, @var{tfinal}, @var{tsam}) ## Generate periodic signal. Useful in combination with lsim. ## ## @strong{Inputs} ## @table @var ## @item sigtype = "sin" ## Sine wave. ## @item sigtype = "cos" ## Cosine wave. ## @item sigtype = "square" ## Square wave. ## @item sigtype = "pulse" ## Periodic pulse. ## @item tau ## Duration of one period in seconds. ## @item tfinal ## Optional duration of the signal in seconds. Default duration is 5 periods. ## @item tsam ## Optional sampling time in seconds. Default spacing is tau/64. ## @end table ## ## @strong{Outputs} ## @table @var ## @item u ## Vector of signal values. ## @item t ## Time vector of the signal. ## @end table ## ## @seealso{lsim} ## @end deftypefn ## Author: Lukas Reichlin ## Created: August 2009 ## Version: 0.4 function [u, t] = gensig (sigtype, tau, tfinal, tsam) if (nargin < 2 || nargin > 4) print_usage (); endif if (! ischar (sigtype)) error ("gensig: first argument must be a string"); endif if (! issample (tau)) error ("gensig: second argument is not a valid period"); endif if (nargin < 3) tfinal = 5 * tau; elseif (! issample (tfinal)) error ("gensig: third argument is not a valid final time"); endif if (nargin < 4) tsam = tau / 64; elseif (! issample (tsam)) error ("gensig: fourth argument is not a valid sampling time"); endif t = reshape (0 : tsam : tfinal, [], 1); switch (lower (sigtype(1:2))) case "si" u = sin (2*pi/tau * t); case "co" u = cos (2*pi/tau * t); case "sq" u = double (rem (t, tau) >= tau/2); case "pu" u = double (rem (t, tau) < (1 - 1000*eps) * tsam); otherwise error ("gensig: '%s' is an invalid signal type", sigtype); endswitch endfunction control-4.1.2/inst/PaxHeaders/isstabilizable.m0000644000000000000000000000007415012430645016415 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/isstabilizable.m0000644000175000017500000001251115012430645017604 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{bool} =} isstabilizable (@var{sys}) ## @deftypefnx {Function File} {@var{bool} =} isstabilizable (@var{sys}, @var{tol}) ## @deftypefnx {Function File} {@var{bool} =} isstabilizable (@var{a}, @var{b}) ## @deftypefnx {Function File} {@var{bool} =} isstabilizable (@var{a}, @var{b}, @var{e}) ## @deftypefnx {Function File} {@var{bool} =} isstabilizable (@var{a}, @var{b}, @var{[]}, @var{tol}) ## @deftypefnx {Function File} {@var{bool} =} isstabilizable (@var{a}, @var{b}, @var{e}, @var{tol}) ## @deftypefnx {Function File} {@var{bool} =} isstabilizable (@var{a}, @var{b}, @var{[]}, @var{[]}, @var{dflg}) ## @deftypefnx {Function File} {@var{bool} =} isstabilizable (@var{a}, @var{b}, @var{e}, @var{[]}, @var{dflg}) ## @deftypefnx {Function File} {@var{bool} =} isstabilizable (@var{a}, @var{b}, @var{[]}, @var{tol}, @var{dflg}) ## @deftypefnx {Function File} {@var{bool} =} isstabilizable (@var{a}, @var{b}, @var{e}, @var{tol}, @var{dflg}) ## Logical check for system stabilizability. ## All unstable modes must be controllable or all uncontrollable states must be stable. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. If @var{sys} is not a state-space system, it is converted to ## a minimal state-space realization, so beware of pole-zero cancellations ## which may lead to wrong results! ## @item a ## State transition matrix. ## @item b ## Input matrix. ## @item e ## Descriptor matrix. ## If @var{e} is empty @code{[]} or not specified, an identity matrix is assumed. ## @item tol ## Optional tolerance for stability. Default value is 0. ## @item dflg = 0 ## Matrices (@var{a}, @var{b}) are part of a continuous-time system. Default Value. ## @item dflg = 1 ## Matrices (@var{a}, @var{b}) are part of a discrete-time system. ## @end table ## ## @strong{Outputs} ## @table @var ## @item bool = 0 ## System is not stabilizable. ## @item bool = 1 ## System is stabilizable. ## @end table ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB01OD and TG01HD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @example ## @group ## * Calculate staircase form (SLICOT AB01OD) ## * Extract unobservable part of state transition matrix ## * Calculate eigenvalues of unobservable part ## * Check whether ## real (ev) < -tol*(1 + abs (ev)) continuous-time ## abs (ev) < 1 - tol discrete-time ## @end group ## @end example ## @seealso{isdetectable, isstable, isctrb, isobsv} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.5 function bool = isstabilizable (a, b = [], e = [], tol = [], dflg = 0) if (nargin < 1 || nargin > 5) print_usage (); elseif (isa (a, "lti")) # isstabilizable (sys), isstabilizable (sys, tol) if (nargin > 2) print_usage (); endif if (! isa (a, "ss")) warning ("isstabilizable: converting to minimal state-space realization\n"); endif tol = b; dflg = ! isct (a); [a, b, c, d, e] = dssdata (a, []); elseif (nargin == 1) # isstabilizable (a, b, ...) print_usage (); elseif (! is_real_square_matrix (a) || rows (a) != rows (b)) error ("isstabilizable: a must be square and conformal to b"); elseif (! isempty (e) && (! is_real_square_matrix (e) || ! size_equal (a, e))) error ("isstabilizable: e must be square and conformal to a"); endif if (isempty (tol)) tol = 0; # default tolerance elseif (! is_real_scalar (tol)) error ("isstabilizable: tol must be a real scalar"); endif if (isempty (e)) ## controllability staircase form [ac, ~, ~, ncont] = __sl_ab01od__ (a, b, tol); ## extract uncontrollable part of staircase form uncont_idx = ncont+1 : rows (a); auncont = ac(uncont_idx, uncont_idx); ## calculate poles of uncontrollable part pol = eig (auncont); else ## controllability staircase form - output matrix c has no influence [ac, ec, ~, ~, ~, ~, ncont] = __sl_tg01hd__ (a, e, b, zeros (1, columns (a)), tol); ## extract uncontrollable part of staircase form uncont_idx = ncont+1 : rows (a); auncont = ac(uncont_idx, uncont_idx); euncont = ec(uncont_idx, uncont_idx); ## calculate poles of uncontrollable part pol = eig (auncont, euncont); ## remove infinite poles tolinf = norm ([auncont, euncont], 2); idx = find (abs (pol) < tolinf/eps); pol = pol(idx); endif ## check whether uncontrollable poles are stable bool = __is_stable__ (pol, ! dflg, tol); endfunction control-4.1.2/inst/PaxHeaders/augstate.m0000644000000000000000000000007415012430645015231 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/augstate.m0000644000175000017500000000354115012430645016423 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{augsys} =} augstate (@var{sys}) ## Append state vector x of system @var{sys} to output vector y. ## ## @example ## @group ## . . ## x = A x + B u x = A x + B u ## y = C x + D u => y = C x + D u ## x = I x + O u ## @end group ## @end example ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2015 ## Version: 0.1 function augsys = augstate (sys) if (nargin != 1 || ! isa (sys, "lti")) print_usage (); endif if (! isa (sys, "ss")) warning ("augstate: system not in state-space form\n"); sys = ss (sys); endif [a, b, c, d, e, tsam] = dssdata (sys, []); [inn, stn, outn, ing, outg] = get (sys, "inname", "stname", "outname", "ingroup", "outgroup"); [p, m] = size (d); n = rows (a); caug = vertcat (c, eye (n)); daug = vertcat (d, zeros (n, m)); outname = vertcat (outn, stn); augsys = dss (a, b, caug, daug, e, tsam); augsys = set (augsys, "inname", inn, "stname", stn, "outname", outname, ... "ingroup", ing, "outgroup", outg); endfunction control-4.1.2/inst/PaxHeaders/zpk.m0000644000000000000000000000007415012430645014220 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/zpk.m0000644000175000017500000001071715012430645015415 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{s} =} zpk (@var{'s'}) ## @deftypefnx {Function File} {@var{z} =} zpk (@var{'z'}, @var{tsam}) ## @deftypefnx {Function File} {@var{sys} =} zpk (@var{sys}) ## @deftypefnx {Function File} {@var{sys} =} zpk (@var{k}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} zpk (@var{z}, @var{p}, @var{k}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} zpk (@var{z}, @var{p}, @var{k}, @var{tsam}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} zpk (@var{z}, @var{p}, @var{k}, @var{tsam}, @dots{}) ## Create transfer function model from zero-pole-gain data. ## This is just a stop-gap compatibility wrapper since zpk ## models are not yet implemented. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model to be converted to transfer function. ## @item z ## Cell of vectors containing the zeros for each channel. ## z@{i,j@} contains the zeros from input j to output i. ## In the SISO case, a single vector is accepted as well. ## @item p ## Cell of vectors containing the poles for each channel. ## p@{i,j@} contains the poles from input j to output i. ## In the SISO case, a single vector is accepted as well. ## @item k ## Matrix containing the gains for each channel. ## k(i,j) contains the gain from input j to output i. ## @item tsam ## Sampling time in seconds. If @var{tsam} is not specified, ## a continuous-time model is assumed. ## @item @dots{} ## Optional pairs of properties and values. ## Type @command{set (tf)} for more information. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Transfer function model. ## @end table ## ## @seealso{tf, ss, dss, frd} ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2011 ## Version: 0.2 function sys = zpk (varargin) if (nargin <= 1) # zpk (), zpk (sys), zpk (k), zpk ('s') sys = tf (varargin{:}); return; elseif (nargin == 2 ... && ischar (varargin{1})) # zpk ('z', tsam) sys = tf (varargin{:}); return; endif z = {}; p = {}; k = []; # default values tsam = 0; # default sampling time [mat_idx, opt_idx] = __lti_input_idx__ (varargin); switch (numel (mat_idx)) case 1 k = varargin{mat_idx}; case 3 [z, p, k] = varargin{mat_idx}; case 4 [z, p, k, tsam] = varargin{mat_idx}; if (isempty (tsam) && is_real_matrix (tsam)) tsam = -1; elseif (! issample (tsam, -10)) error ("zpk: invalid sampling time"); endif case 0 ## nothing to do here, just prevent case 'otherwise' otherwise print_usage (); endswitch varargin = varargin(opt_idx); if (isempty (z) && isempty (p) && is_real_matrix (k)) sys = tf (k, varargin{:}); return; endif if (! iscell (z)) z = {z}; endif if (! iscell (p)) p = {p}; endif if (! size_equal (z, p, k)) error ("zpk: arguments 'z', 'p' and 'k' must have equal dimensions"); endif ## NOTE: accept [], scalars and vectors but not matrices as 'z' and 'p' ## because poly (matrix) returns the characteristic polynomial ## if the matrix is square! if (! is_zp_vector (z{:}, 1)) # last argument 1 needed if z is empty cell error ("zpk: first argument 'z' must be a vector or a cell of vectors"); endif if (! is_zp_vector (p{:}, 1)) error ("zpk: second argument 'p' must be a vector or a cell of vectors") endif if (! is_real_matrix (k)) error ("zpk: third argument 'k' must be a real-valued gain matrix"); endif num = cellfun (@(zer, gain) real (gain * poly (zer)), z, num2cell (k), "uniformoutput", false); den = cellfun (@(pol) real (poly (pol)), p, "uniformoutput", false); sys = tf (num, den, tsam, varargin{:}); endfunctioncontrol-4.1.2/inst/PaxHeaders/__modred_default_alpha__.m0000644000000000000000000000007415012430645020333 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__modred_default_alpha__.m0000644000175000017500000000210615012430645021521 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## default alpha for model reduction commands ## Author: Lukas Reichlin ## Created: November 2011 ## Version: 0.1 function alpha = __modred_default_alpha__ (dt) if (dt) # discrete-time alpha = 1; # ALPHA <= 0 else # continuous-time alpha = 0; # 0 <= ALPHA <= 1 endif endfunction control-4.1.2/inst/PaxHeaders/__adjust_iddata__.m0000644000000000000000000000007415012430645017010 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__adjust_iddata__.m0000644000175000017500000000212215012430645020174 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## Author: Lukas Reichlin ## Created: February 2012 ## Version: 0.1 function [y, u] = __adjust_iddata__ (y, u) if (iscell (y)) y = reshape (y, [], 1); else y = {y}; endif if (isempty (u)) u = {}; # avoid [](nx0) and the like elseif (iscell (u)) u = reshape (u, [], 1); else u = {u}; endif endfunction control-4.1.2/inst/PaxHeaders/thiran.m0000644000000000000000000000007415012430645014701 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/thiran.m0000644000175000017500000000740315012430645016074 0ustar00lilgelilge00000000000000## Copyright (C) 2013-2015 Thomas Vasileiou ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} thiran (@var{tau}, @var{tsam}) ## Approximation of continuous-time delay using a discrete-time ## allpass Thiran filter. ## ## Thiran filters can approximate continuous-time delays that are ## non-integer multiples of the sampling time (fractional delays). ## This approximation gives a better matching of the phase shift ## between the continuous- and the discrete-time system. ## If there is no fractional part in the delay, then the standard ## discrete-time delay representation is used. ## ## @strong{Inputs} ## @table @var ## @item tau ## A continuous-time delay, given in time units (seconds). ## @item tsam ## The sampling time of the resulting Thiran filter. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Transfer function model of the resulting filter. ## The order of the filter is determined automatically. ## @end table ## ## @strong{Example} ## @example ## @group ## octave:1> sys = thiran (1.33, 0.5) ## ## Transfer function 'sys' from input 'u1' to output ... ## ## 0.003859 z^3 - 0.03947 z^2 + 0.2787 z + 1 ## y1: ----------------------------------------- ## z^3 + 0.2787 z^2 - 0.03947 z + 0.003859 ## ## Sampling time: 0.5 s ## Discrete-time model. ## @end group ## @end example ## @example ## @group ## octave:2> sys = thiran (1, 0.5) ## ## Transfer function 'sys' from input 'u1' to output ... ## ## 1 ## y1: --- ## z^2 ## ## Sampling time: 0.5 s ## Discrete-time model. ## @end group ## @end example ## ## @seealso{absorbdelay, pade} ## @end deftypefn ## Author: Thomas Vasileiou ## Created: January 2013 ## Version: 0.1 function sys = thiran (del, tsam) ## check args if (nargin != 2) print_usage (); endif if (! issample (del, 0)) error ("thiran: the delay parameter 'tau' must be a non-negative scalar."); endif if (! issample (tsam)) error ("thiran: the second parameter 'tsam' is not a valid sampling time."); endif if (del == 0) sys = tf (1); return; endif ## find fractional and discrete delay N = floor (del/tsam + eps); # put eps or sometimes it misses d = del - N*tsam; ## check if we do need a thiran filter if (d/tsam < eps) sys = tf (1, [1, zeros(1, N)], tsam); else ## make filter order ~ del to ensure stability N = N + 1; # order of the filter d = del/tsam; tmp = ((d-N+(0:N).') * ones (1,N)) ./ (d-N + bsxfun (@plus, 1:N, (0:N).')); a = horzcat (1, (-1).^(1:N) .* bincoeff (N, 1:N) .* prod (tmp)); sys = tf (fliplr (a), a, tsam); endif endfunction %!shared num, den, expc %! expc = [1, 0.5294, -0.04813, 0.004159]; %! sys = thiran (2.4, 1); %! [num, den] = tfdata (sys, "vector"); %!assert (den, expc, 1e-4); %!assert (num, fliplr (expc), 1e-4); %!shared num, den %! sys = thiran (0.5, 0.1); %! [num, den] = tfdata (sys, "vector"); %!assert (den, [1, 0, 0, 0, 0, 0], eps); %!assert (num, [0, 0, 0, 0, 0, 1], eps); %!error (thiran (-1, 1)); %!error (thiran (1, -1)); %!error (thiran ([1 2 3], 1)); control-4.1.2/inst/PaxHeaders/__adjust_frd_data__.m0000644000000000000000000000007415012430645017326 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__adjust_frd_data__.m0000644000175000017500000000322615012430645020520 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Common code for adjusting FRD model data. ## Used by @frd/frd.m and @frd/__set__.m ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function [H, w] = __adjust_frd_data__ (H, w); w = reshape (w, [], 1); lw = length (w); if (ndims (H) != 3 && ! isempty (H)) if (isscalar (H)) H = reshape (H, 1, 1, []); if (lw > 1) H = repmat (H, [1, 1, lw]); # needed for "frd1 + scalar2" or "scalar1 * frd2) endif elseif (isvector (H) && length (H) == lw) # SISO system (H is a vector) H = reshape (H, 1, 1, []); elseif (ismatrix (H)) H = reshape (H, rows (H), []); if (lw > 1) H = repmat (H, [1, 1, lw]); # needed for "frd1 + matrix2" or "matrix1 * frd2) endif else error ("frd: first argument H invalid"); endif elseif (isempty (H)) H = zeros (0, 0, 0); endif endfunction control-4.1.2/inst/PaxHeaders/zgrid.m0000644000000000000000000000007415012430645014533 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/zgrid.m0000644000175000017500000001617015012430645015727 0ustar00lilgelilge00000000000000## Copyright (C) 2022 Torsten Lilge ## ## This program is free software: you can redistribute it and/or modify it ## under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, but ## WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program. If not, see ## . ## -*- texinfo -*- ## @deftypefn {Function File} {} zgrid ## @deftypefnx {Function File} {} zgrid on ## @deftypefnx {Function File} {} zgrid off ## @deftypefnx {Function File} {} zgrid (@var{z}, @var{w}) ## @deftypefnx {Function File} {} zgrid (@var{hax}, @dots{}) ## Display an grid in the complex z-plane. ## ## Control the display of z-plane grid with : ## @itemize ## @item zeta lines corresponding to damping ratios and ## @item omega lines corresponding to undamped natural frequencies ## @end itemize ## ## The function state input may be either @qcode{"on"} or @qcode{"off"} ## for creating or removing the grid. If omitted, a new grid is created ## when it does not exist or the visibility of the current grid is toggled. ## ## The zgrid will automatically plot the grid lines at nice values or ## at constant values specified by two arguments : ## ## @example ## zgrid (@var{Z}, @var{W}) ## @end example ## ## @noindent ## where @var{Z} and @var{W} are : ## @itemize ## @item @var{Z} vector of constant zeta values to plot as lines ## @item @var{W} vector of constant omega values to plot as circles ## @end itemize ## ## Example of usage: ## @example ## zgrid on create the z-plane grid ## zgrid off remove the z-plane grid ## zgrid toggle the z-plane grid visibility ## zgrid ([0.3, 0.8, @dots{}], [0.25*pid, 0.5*pi, @dots{}]) create: ## @example ## @itemize ## @item zeta lines for 0.3, 0.8, @dots{} ## @item omega lines for 0.25*pi/T, 0.5*pi/T, @dots{} [rad/s] ## @end itemize ## @end example ## zgrid (@var{hax}, @qcode{"on"}) create the z-plane grid for the axis ## handle @var{hax} ## @end example ## ## @seealso{grid,sgrid} ## ## @end deftypefn ## Author: Torsten Lilge based on "sgrid" by Stefan Mátéfi-Tempfli ## Created: 2023-05-14 function zgrid(varargin) [hax, varargin, nargs] = __plt_get_axis_arg__("zgrid", varargin{:}); T = 1; if (nargs > 3) print_usage(); endif if (isempty(hax)) hax = gca(); endif hg = findobj(hax, "tag", "zgrid"); if (isempty(hg)) hg = hggroup(hax, "tag", "zgrid"); v_new = 1; else v_new = 0; endif v_z = []; v_w = []; if (nargs == 0) if (v_new) __zgrid_create__(hax, hg, v_z, v_w) else __zgrid_toggle__(hg) endif elseif (nargs == 1) arg1 = varargin{1}; if (! ischar(arg1)) error("zgrid: argument must be a string"); endif if (strcmpi(arg1, "off")) __zgrid_delete__(hg); elseif (strcmpi(arg1, "on")) if (v_new) __zgrid_create__(hax, hg, v_z, v_w) else v_user = get(hg, "userdata"); if (!isempty(v_user.z) | !isempty(v_user.w)) __zgrid_delete_handles__(hg); __zgrid_create__(hax, hg, v_z, v_w) elseif (strcmp(get(hg, "visible"), "off")) set(hg, "visible", "on"); endif endif else print_usage(); endif else v_z = varargin{1}; if (! isnumeric(v_z)) error ("zgrid: Z argument (1) must be numeric"); endif if (any(v_z < 0 | v_z > 1)) error("zgrid: Z argument (1) must have values betwenn 0 .. 1"); endif v_w = varargin{2}; if (! isnumeric(v_w)) error("zgrid: W argument (2) must be numeric"); endif if (any(v_w < 0)) error("zgrid: W argument (2) must have values larger or equal 0"); endif if (any(v_w > pi/T)) error("zgrid: W argument (2) must have values smaller or equal pi"); endif if (v_new) __zgrid_create__(hax, hg,v_z, v_w) else v_user = get(hg, "userdata"); if (!isequal(v_z, v_user.z) || !isequal(v_w, v_user.w) || (v_user.cl != [xlim() ylim()])) __zgrid_delete_handles__(hg); __zgrid_create__(hax, hg, v_z, v_w) elseif (strcmp(get(hg, "visible"), "off")) set(hg, "visible", "on"); endif endif endif endfunction ##---------------------------------------------------- function __zgrid_create__(hax, hg, v_z, v_w) hold on; box on; v_user.z = v_z; v_user.w = v_w; v_user.cl = [ xlim() ylim() ]; set(hg, "userdata", v_user); T = 1; w_max = pi/T; d_w = pi/T/10; if (isempty(v_w)) v_w = d_w:d_w:w_max; endif d_D = (v_user.cl(4)-v_user.cl(3))/50; D_max = 1; D = 0:d_D:D_max; clear ('i'); for iw = 1:length(v_w) z = exp (T*(-D.*v_w(iw))) .* exp (T*i*v_w(iw).*sqrt (1-D.^2)); z = [ conj(z) flip(z) ]; plot (z, ":k", "linewidth", 0.6, "parent", hg); z_vis = __zgrid_visible__(z,v_user.cl); if (! isempty (z_vis)) num = sprintf ("%1.1f \\pi/T", v_w(iw)*T/pi); zt = z_vis(end); % exp (T*i*v_w(iw)); text (real (zt), imag (zt), num, "parent", hg); endif endfor d_D = 0.1; d_w = pi/T/50; if (isempty(v_z)) v_z = 0:d_D:D_max-eps; endif clear ('i'); wt = 0.25*pi/T; for (iz = 1:length(v_z)) % Compute w for reaching the negative real axis (pi/T for D = 1): % T*w_end*sqrt(1-D^2) == pi w_end = pi/T/sqrt(1-v_z(iz)^2); w = [ 0:d_w:w_max w_max:(w_end-w_max)/10:w_end ]; z = exp (T*(-v_z(iz).*w)) .* exp (i*T*w.*sqrt (1-v_z(iz).^2)); plot (z,":k", "linewidth", 0.6, "parent", hg); plot (conj (z), ":k", "linewidth", 0.6, "parent", hg); z_vis = __zgrid_visible__(z,v_user.cl); if (! isempty (z_vis)) num = sprintf ("%1.1f", v_z(iz)); zt_idx = find (imag (z_vis) == max (imag (z_vis))); if zt_idx > 3 zt_idx = zt_idx - 3; else zt_idx = 1; endif zt = z_vis (zt_idx); text (real (zt), imag (zt), num, "parent", hg); endif endfor hold off; endfunction ##---------------------------------------------------- function __zgrid_delete__(hg) delete(hg); endfunction ##---------------------------------------------------- function __zgrid_delete_handles__(hg) delete(get(hg, "children")); endfunction ##---------------------------------------------------- function __zgrid_toggle__(hg) if (strcmp(get(hg, "visible"), "on")) set(hg, "visible", "off"); elseif (strcmp(get(hg, "visible"), "off")) set(hg, "visible", "on"); endif endfunction function z_vis = __zgrid_visible__ (z, cl) z_vis = z; z_vis = z_vis(real (z_vis) > cl(1)); z_vis = z_vis(real (z_vis) < cl(2)); z_vis = z_vis(imag (z_vis) > cl(3)); z_vis = z_vis(imag (z_vis) < cl(4)); endfunction %!demo %! clf; %! num = [1 0.25]; den = [1 -1.5 0]; %! sys = tf(num, den, 1); %! rlocus(sys,0.01,0,3.5); %! ylim([-1.1,1.1]); %! zgrid on; control-4.1.2/inst/PaxHeaders/strseq.m0000644000000000000000000000007415012430645014735 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/strseq.m0000644000175000017500000000256715012430645016136 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{strvec} =} strseq (@var{str}, @var{idx}) ## Return a cell vector of indexed strings by appending the indices @var{idx} ## to the string @var{str}. ## ## @example ## strseq ("x", 1:3) = @{"x1"; "x2"; "x3"@} ## strseq ("u", [1, 2, 5]) = @{"u1"; "u2"; "u5"@} ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.3 function strvec = strseq (str, idx) if (nargin != 2 || ! ischar (str) || ! isnumeric (idx)) print_usage (); endif strvec = arrayfun (@(x) sprintf ("%s%d", str, x), idx(:), "uniformoutput", false); endfunction control-4.1.2/inst/PaxHeaders/__tito_dim__.m0000644000000000000000000000007415012430645016020 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__tito_dim__.m0000644000175000017500000000307415012430645017213 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## Extract nmeas and ncon from plant P which has been partitioned by mktito. ## Author: Lukas Reichlin ## Created: January 2014 ## Version: 0.1 function [nmeas, ncon] = __tito_dim__ (P, name) [p, m] = size (P); outgroup = P.outgroup; ingroup = P.ingroup; if (! isfield (outgroup, "V")) error ("%s: missing outgroup 'V'", name); endif if (! isfield (ingroup, "U")) error ("%s: missing ingroup 'U'", name); endif nmeas = numel (outgroup.V); ncon = numel (ingroup.U); ## check whether indices of V and U are in ascending order ## and at the end of the outputs/inputs if (! isequal (outgroup.V(:), (p-nmeas+1:p)(:))) error ("%s: outgroup 'V' invalid", name); endif if (! isequal (ingroup.U(:), (m-ncon+1:m)(:))) error ("%s: ingroup 'U' invalid", name); endif endfunction control-4.1.2/inst/PaxHeaders/lqg.m0000644000000000000000000000007415012430645014177 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/lqg.m0000644000175000017500000001161615012430645015373 0ustar00lilgelilge00000000000000## Copyright (C) 2024 Fabio Di Iorio ## ## This file is part of the Control package for GNU Octave. ## ## Octave 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. ## ## Octave 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 Octave; see the file COPYING. If not, ## see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{reg} =} lqg (@var{sys}, @var{QXU}, @var{QWV}) ## @deftypefnx {Function File} {@var{reg} =} lqg (@var{sys}, @var{QXU}, @var{QWV}, @var{QI}) ## Linear-quadratic gaussian (LQG) design ## ## @strong{Inputs} ## @table @var ## @item sys ## Continuous or discrete-time @acronym{LTI} model (m inputs, n states, p outputs). ## @item QXU ## State and input weighting matrix (n+m-by-n+m). ## @item QWV ## Process and measurement noise covariance matrix (n+p-by-n+p). ## @item QI ## Optional output weighting matrix for LQG servo control with integral action (p-by-p). If @var{QI} is not specified, the LQG regulator is computed ## @end table ## ## @strong{Outputs} ## @table @var ## @item reg ## LQG regulator or controller as dynamic compensator. Connect with positive feedback. ## @end table ## ## @strong{Equations} ## @tex ## $$ \dot{x} = A\,x + B\,u,\quad x(0) = x_0 $$ ## $$ J(x_0) = E \left[ \lim_{T\to\infty} \, \frac{1}{T}\,\int_0^T [x^T \, u^T ] Q_{xu}\, [x^T \, u^T ]^T + x_i^TQ_i\,x_i \,\, dt \right] $$ ## @end tex ## @ifnottex ## @example ## @group ## . ## x = A x + B u, x(0) = x0 ## ## 1 T ## J(x0) = E@{ lim --- INT ([x', u'] Qxu [x u]' + xi' Qi xi) dt@} ## T->inf T 0 ## ## @end group ## @end example ## @end ifnottex ## ## @seealso{lqr, kalman, lqi} ## @end deftypefn ## Author: Fabio Di Iorio ## Created: July 2024 ## Version: 0.1 function [reg] = lqg (sys, QXU, QWV, QI = []) if (nargin < 3 || nargin > 4) print_usage (); endif if (isa (sys, "lti")) [a, b, c, d, e, Ts] = dssdata (sys, []); else print_usage (); endif if (~issquare (QXU) || ~issquare (QWV) || (~isempty(QI) && ~issquare(QI))) print_usage (); endif [n, m] = size(b); [p, ~] = size(c); % LQR data Q = QXU(1:n, 1:n); R = QXU(n+1:end, n+1:end); S = QXU(1:n, n+1:end); % observer data W = QWV(1:n, 1:n); V = QWV(n+1:end, n+1:end); N = QWV(1:n, n+1:end); if (isempty(QI)) K = lqr(sys, Q, R, S); else K = lqi(sys, blkdiag(Q, QI), R, vertcat(S,zeros(p,m))); endif % add noise to system as additional inputs, to use with "kalman" function Bn = [b eye(n)]; sys_noisy = ss(a, Bn, c, d, Ts); [est, L, ~] = kalman(sys_noisy, W, V, N, 1:p, 1:m); % regulator case if isempty(QI) reg = ss(a-b*K-L*c-L*d*K, L, -K, 0,Ts); % set variables names [inn, stn, outn, ing, outg] = get (sys, "inname", "stname", "outname", "ingroup", "outgroup"); stname = __labels__ (stn, "xhat"); outname = vertcat (__labels__ (outn(1:m), "u")); inname = vertcat (__labels__ (outn(1:p), "y")); reg = set (reg, "inname", inname, "stname", stname, "outname", outname); else % servo case if isct(sys) reg = ss([a-b*K(:,1:(end-p))-L*c+L*d*K(:,1:(end-p)) -b*K(:,(n+1):end)+L*d*K(:,(n+1):end); zeros(p,n) zeros(p,p)], [zeros(n,p) L; ones(p,1) -1.*ones(p,1)], -K, 0,Ts); else reg = ss([a-b*K(:,1:(end-p))-L*c+L*d*K(:,1:(end-p)) -b*K(:,(n+1):end)+L*d*K(:,(n+1):end); zeros(p,n) eye(p,p)], [zeros(n,p) L; Ts.*ones(p,1) -Ts.*ones(p,1)], -K, 0,Ts); endif % set variables names [inn, stn, outn, ing, outg] = get (sys, "inname", "stname", "outname", "ingroup", "outgroup"); stname = vertcat (__labels__ (stn(1:n), "xhat"), __labels__ (outn(1:p), "xi")); outname = vertcat (__labels__ (outn(1:m), "u")); inname = vertcat (__labels__ (outn(1:p), "r"),__labels__ (outn(1:p), "y")); reg = set (reg, "inname", inname, "stname", stname, "outname", outname); endif endfunction %!test %! G = zpk([], [-10 -1 -100], 2000); %! sys = ss(G); %! [A B C D] = ssdata(sys); %! Q = eye(3); %! QI = 100; %! QXU = blkdiag (Q, 1); %! QWV = eye(4); %! reg = lqg(sys, QXU, QWV); %! assert(real(eig(feedback(reg, sys, 1)))<0); %! reg=lqg(sys,QXU,QWV,QI); %! assert(real(eig(feedback(reg, sys, 2, 1, 1)))<0); %!test %! Ts = 0.1; %! Gz = zpk([], [-0.1 0.05 0.004], 3, Ts); %! sysz = ss(Gz); %! Q = eye(3); %! QI = 100; %! QXU = blkdiag (Q, 1); %! QWV = eye(4); %! regz = lqg(sysz, QXU, QWV); %! assert(abs(eig(feedback(regz, sysz, 1)))<1); %! regz=lqg(sysz, QXU, QWV, QI); %! assert(abs(eig(feedback(regz, sysz, 2, 1, 1)))<1); control-4.1.2/inst/PaxHeaders/__tf_dim__.m0000644000000000000000000000007415012430645015452 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__tf_dim__.m0000644000175000017500000000235115012430645016642 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Number of outputs and inputs of transfer function numerator and ## denominator. For internal use only. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function [nrows, ncols] = __tf_dim__ (num, den) [nrows, ncols] = size (num); [drows, dcols] = size (den); if (nrows != drows || ncols != dcols) error ("tf: arguments 'num' (%dx%d) and 'den' (%dx%d) must have equal dimensions", nrows, ncols, drows, dcols); endif endfunction control-4.1.2/inst/PaxHeaders/bstmodred.m0000644000000000000000000000007415012430645015377 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/bstmodred.m0000644000175000017500000003233315012430645016572 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{Gr}, @var{info}] =} bstmodred (@var{G}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} bstmodred (@var{G}, @var{nr}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} bstmodred (@var{G}, @var{opt}, @dots{}) ## @deftypefnx{Function File} {[@var{Gr}, @var{info}] =} bstmodred (@var{G}, @var{nr}, @var{opt}, @dots{}) ## ## Model order reduction by Balanced Stochastic Truncation (BST) method. ## The aim of model reduction is to find an @acronym{LTI} system @var{Gr} of order ## @var{nr} (nr < n) such that the input-output behaviour of @var{Gr} ## approximates the one from original system @var{G}. ## ## BST is a relative error method which tries to minimize ## @iftex ## @tex ## $$ || G^{-1} (G-G_r) ||_{\\infty} = \\min $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## -1 ## ||G (G-Gr)|| = min ## inf ## @end example ## @end ifnottex ## ## ## ## @strong{Inputs} ## @table @var ## @item G ## @acronym{LTI} model to be reduced. ## @item nr ## The desired order of the resulting reduced order system @var{Gr}. ## If not specified, @var{nr} is chosen automatically according ## to the description of key @var{'order'}. ## @item @dots{} ## Optional pairs of keys and values. @code{"key1", value1, "key2", value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item Gr ## Reduced order state-space model. ## @item info ## Struct containing additional information. ## @table @var ## @item info.n ## The order of the original system @var{G}. ## @item info.ns ## The order of the @var{alpha}-stable subsystem of the original system @var{G}. ## @item info.hsv ## The Hankel singular values of the phase system corresponding ## to the @var{alpha}-stable part of the original system @var{G}. ## The @var{ns} Hankel singular values are ordered decreasingly. ## @item info.nu ## The order of the @var{alpha}-unstable subsystem of both the original ## system @var{G} and the reduced-order system @var{Gr}. ## @item info.nr ## The order of the obtained reduced order system @var{Gr}. ## @end table ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'order', 'nr' ## The desired order of the resulting reduced order system @var{Gr}. ## If not specified, @var{nr} is the sum of NU and the number of ## Hankel singular values greater than @code{MAX(TOL1,NS*EPS)}; ## @var{nr} can be further reduced to ensure that ## @code{HSV(NR-NU) > HSV(NR+1-NU)}. ## ## @item 'method' ## Approximation method for the H-infinity norm. ## Valid values corresponding to this key are: ## @table @var ## @item 'sr-bta', 'b' ## Use the square-root Balance & Truncate method. ## @item 'bfsr-bta', 'f' ## Use the balancing-free square-root Balance & Truncate method. Default method. ## @item 'sr-spa', 's' ## Use the square-root Singular Perturbation Approximation method. ## @item 'bfsr-spa', 'p' ## Use the balancing-free square-root Singular Perturbation Approximation method. ## @end table ## ## @item 'alpha' ## Specifies the ALPHA-stability boundary for the eigenvalues ## of the state dynamics matrix @var{G.A}. For a continuous-time ## system, ALPHA <= 0 is the boundary value for ## the real parts of eigenvalues, while for a discrete-time ## system, 0 <= ALPHA <= 1 represents the ## boundary value for the moduli of eigenvalues. ## The ALPHA-stability domain does not include the boundary. ## Default value is 0 for continuous-time systems and ## 1 for discrete-time systems. ## ## @item 'beta' ## Use @code{[G, beta*I]} as new system @var{G} to combine ## absolute and relative error methods. ## BETA > 0 specifies the absolute/relative error weighting ## parameter. A large positive value of BETA favours the ## minimization of the absolute approximation error, while a ## small value of BETA is appropriate for the minimization ## of the relative error. ## BETA = 0 means a pure relative error method and can be ## used only if rank(G.D) = rows(G.D) which means that ## the feedthrough matrice must not be rank-deficient. ## Default value is 0. ## ## @item 'tol1' ## If @var{'order'} is not specified, @var{tol1} contains the tolerance for ## determining the order of reduced system. ## For model reduction, the recommended value of @var{tol1} lies ## in the interval [0.00001, 0.001]. @var{tol1} < 1. ## If @var{tol1} <= 0 on entry, the used default value is ## @var{tol1} = NS*EPS, where NS is the number of ## ALPHA-stable eigenvalues of A and EPS is the machine ## precision. ## If @var{'order'} is specified, the value of @var{tol1} is ignored. ## ## @item 'tol2' ## The tolerance for determining the order of a minimal ## realization of the phase system (see METHOD) corresponding ## to the ALPHA-stable part of the given system. ## The recommended value is TOL2 = NS*EPS. TOL2 <= TOL1 < 1. ## This value is used by default if @var{'tol2'} is not specified ## or if TOL2 <= 0 on entry. ## ## @item 'equil', 'scale' ## Boolean indicating whether equilibration (scaling) should be ## performed on system @var{G} prior to order reduction. ## Default value is true if @code{G.scaled == false} and ## false if @code{G.scaled == true}. ## Note that for @acronym{MIMO} models, proper scaling of both inputs and outputs ## is of utmost importance. The input and output scaling can @strong{not} ## be done by the equilibration option or the @command{prescale} function ## because these functions perform state transformations only. ## Furthermore, signals should not be scaled simply to a certain range. ## For all inputs (or outputs), a certain change should be of the same ## importance for the model. ## @end table ## ## ## BST is often suitable to perform model reduction in order to obtain ## low order design models for controller synthesis. ## ## Approximation Properties: ## @itemize @bullet ## @item ## Guaranteed stability of reduced models ## @item ## Approximates simultaneously gain and phase ## @item ## Preserves non-minimum phase zeros ## @item ## Guaranteed a priori error bound ## @iftex ## @tex ## $$ || G^{-1} (G-G_r) ||_{\\infty} \\leq 2 \\sum_{j=r+1}^{n} {1+\\sigma_j \\over 1-\\sigma_j} - 1 $$ ## @end tex ## @end iftex ## @end itemize ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB09HD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2011 ## Version: 0.1 function [Gr, info] = bstmodred (G, varargin) if (nargin == 0) print_usage (); endif if (! isa (G, "lti")) error ("bstmodred: first argument must be an LTI system"); endif if (nargin > 1) # bstmodred (G, ...) if (is_real_scalar (varargin{1})) # bstmodred (G, nr) varargin = horzcat (varargin(2:end), {"order"}, varargin(1)); endif if (isstruct (varargin{1})) # bstmodred (G, opt, ...), bstmodred (G, nr, opt, ...) varargin = horzcat (__opt2cell__ (varargin{1}), varargin(2:end)); endif ## order placed at the end such that nr from bstmodred (G, nr, ...) ## and bstmodred (G, nr, opt, ...) overrides possible nr's from ## key/value-pairs and inside opt struct (later keys override former keys, ## nr > key/value > opt) endif nkv = numel (varargin); # number of keys and values if (rem (nkv, 2)) error ("bstmodred: keys and values must come in pairs"); endif [a, b, c, d, tsam, scaled] = ssdata (G); dt = isdt (G); ## default arguments alpha = __modred_default_alpha__ (dt); beta = 0; tol1 = 0; tol2 = 0; ordsel = 1; nr = 0; job = 1; ## handle keys and values for k = 1 : 2 : nkv key = lower (varargin{k}); val = varargin{k+1}; switch (key) case {"order", "nr"} [nr, ordsel] = __modred_check_order__ (val, rows (a)); case "tol1" tol1 = __modred_check_tol__ (val, "tol1"); case "tol2" tol2 = __modred_check_tol__ (val, "tol2"); case "alpha" alpha = __modred_check_alpha__ (val, dt); case "beta" if (! issample (val, 0)) error ("bstmodred: argument %s must be BETA >= 0", varargin{k}); endif beta = val; case "method" # approximation method switch (tolower (val)) case {"sr-bta", "b"} # 'B': use the square-root Balance & Truncate method job = 0; case {"bfsr-bta", "f"} # 'F': use the balancing-free square-root Balance & Truncate method job = 1; case {"sr-spa", "s"} # 'S': use the square-root Singular Perturbation Approximation method job = 2; case {"bfsr-spa", "p"} # 'P': use the balancing-free square-root Singular Perturbation Approximation method job = 3; otherwise error ("bstmodred: '%s' is an invalid approximation method", val); endswitch case {"equil", "equilibrate", "equilibration", "scale", "scaling"} scaled = __modred_check_equil__ (val); otherwise warning ("bstmodred: invalid property name '%s' ignored\n", key); endswitch endfor ## perform model order reduction [ar, br, cr, dr, nr, hsv, ns] = __sl_ab09hd__ (a, b, c, d, dt, scaled, job, nr, ordsel, alpha, beta, ... tol1, tol2); ## assemble reduced order model Gr = ss (ar, br, cr, dr, tsam); ## assemble info struct n = rows (a); nu = n - ns; info = struct ("n", n, "ns", ns, "hsv", hsv, "nu", nu, "nr", nr); endfunction %!shared Mo, Me, Info, HSVe %! A = [ -0.04165 0.0000 4.9200 -4.9200 0.0000 0.0000 0.0000 %! -5.2100 -12.500 0.0000 0.0000 0.0000 0.0000 0.0000 %! 0.0000 3.3300 -3.3300 0.0000 0.0000 0.0000 0.0000 %! 0.5450 0.0000 0.0000 0.0000 -0.5450 0.0000 0.0000 %! 0.0000 0.0000 0.0000 4.9200 -0.04165 0.0000 4.9200 %! 0.0000 0.0000 0.0000 0.0000 -5.2100 -12.500 0.0000 %! 0.0000 0.0000 0.0000 0.0000 0.0000 3.3300 -3.3300 ]; %! %! B = [ 0.0000 0.0000 %! 12.500 0.0000 %! 0.0000 0.0000 %! 0.0000 0.0000 %! 0.0000 0.0000 %! 0.0000 12.500 %! 0.0000 0.0000 ]; %! %! C = [ 1.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 0.0000 1.0000 0.0000 0.0000 ]; %! %! D = [ 0.0000 0.0000 %! 0.0000 0.0000 %! 0.0000 0.0000 ]; %! %! sys = ss (A, B, C, D, "scaled", true); %! %! [sys_red, Info] = bstmodred (sys, "beta", 1.0, "tol1", 0.1, "tol2", 0.0); %! %! # Expected results %! Ae = [ 1.2729 0.0000 6.5947 0.0000 -3.4229 %! 0.0000 0.8169 0.0000 2.4821 0.0000 %! -2.9889 0.0000 -2.9028 0.0000 -0.3692 %! 0.0000 -3.3921 0.0000 -3.1126 0.0000 %! -1.4767 0.0000 -2.0339 0.0000 -0.6107 ]; %! %! Be = [ 0.1331 -0.1331 %! -0.0862 -0.0862 %! -2.6777 2.6777 %! -3.5767 -3.5767 %! -2.3033 2.3033 ]; %! %! Ce = [ -0.6907 -0.6882 0.0779 0.0958 -0.0038 %! 0.0676 0.0000 0.6532 0.0000 -0.7522 %! 0.6907 -0.6882 -0.0779 0.0958 0.0038 ]; %! %! De = [ 0.0000 0.0000 %! 0.0000 0.0000 %! 0.0000 0.0000 ]; %! %! HSVe = [ 0.8803 0.8506 0.8038 0.4494 0.3973 0.0214 0.0209 ].'; %! %! # Since bstmodred reduces the model while approximaton the input/output %! # behavior, only input/output behavior is tested by means of the first %! # n markov parameters. The state space representation is not unique. %! # By multiplying the matrices for the Markov parameters, numeric errors %! # would propagate, therefor the accuracy of the results are limited to %! # the accuracy of the given expected results %! %! [Ao, Bo, Co, Do] = ssdata (sys_red); %! Ao = round (Ao*1e4)/1e4; %! Bo = round (Bo*1e4)/1e4; %! Co = round (Co*1e4)/1e4; %! Do = round (Do*1e4)/1e4; %! %! n = size(Ao,1); %! m = size(Bo,2); %! p = size(Co,1); %! Mo = zeros (p,(n+1)*m); %! Me = zeros (p,(n+1)*m); %! Mo(:,1:m) = Do; %! Me(:,1:m) = De; %! %! Aoi = eye (n,n); %! Aei = eye (n,n); %! for i = 1:n %! Mo(:,(i-1)*m+1:i*m) = Co*Aoi*Bo; %! Me(:,(i-1)*m+1:i*m) = Ce*Aei*Be; %! Aoi = Aoi*Ao; %! Aei = Aei*Ae; %! endfor %! %!assert (Mo, Me, 1e-4) %!assert (Info.hsv, HSVe, 1e-4) control-4.1.2/inst/PaxHeaders/augw.m0000644000000000000000000000007415012430645014357 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/augw.m0000644000175000017500000001235115012430645015550 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{P} =} augw (@var{G}, @var{W1}, @var{W2}, @var{W3}) ## Extend plant for stacked S/KS/T problem. Subsequently, the robust control problem ## can be solved by h2syn or hinfsyn. ## ## @strong{Inputs} ## @table @var ## @item G ## @acronym{LTI} model of plant. ## @item W1 ## @acronym{LTI} model of performance weight. Bounds the largest singular values of sensitivity @var{S}. ## Model must be empty @code{[]}, SISO or of appropriate size. ## @item W2 ## @acronym{LTI} model to penalize large control inputs. Bounds the largest singular values of @var{KS}. ## Model must be empty @code{[]}, SISO or of appropriate size. ## @item W3 ## @acronym{LTI} model of robustness and noise sensitivity weight. Bounds the largest singular values of ## complementary sensitivity @var{T}. Model must be empty @code{[]}, SISO or of appropriate size. ## @end table ## ## All inputs must be proper/realizable. ## Scalars, vectors and matrices are possible instead of @acronym{LTI} models. ## ## @strong{Outputs} ## @table @var ## @item P ## State-space model of augmented plant. ## @end table ## ## @strong{Block Diagram} ## @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 ## @end group ## @end example ## @example ## @group ## +------+ z1 ## +---------------------------------------->| W1 |-----> ## | +------+ ## | +------+ z2 ## | +---------------------->| W2 |-----> ## | | +------+ ## r + e | +--------+ u | +--------+ y +------+ z3 ## ----->(+)---+-->| K(s) |----+-->| G(s) |----+---->| W3 |-----> ## ^ - +--------+ +--------+ | +------+ ## | | ## +----------------------------------------+ ## @end group ## @end example ## @example ## @group ## +--------+ ## | |-----> z1 (p1x1) z1 = W1 e ## r (px1) ----->| P(s) |-----> z2 (p2x1) z2 = W2 u ## | |-----> z3 (p3x1) z3 = W3 y ## u (mx1) ----->| |-----> e (px1) e = r - y ## +--------+ ## @end group ## @end example ## @example ## @group ## +--------+ ## r ----->| |-----> z ## | P(s) | ## u +---->| |-----+ e ## | +--------+ | ## | | ## | +--------+ | ## +-----| K(s) |<----+ ## +--------+ ## @end group ## @end example ## ## @strong{References}@* ## [1] Skogestad, S. and Postlethwaite I. (2005) ## @cite{Multivariable Feedback Control: Analysis and Design: ## Second Edition}. Wiley. ## ## @seealso{h2syn, hinfsyn, mixsyn} ## @end deftypefn ## Author: Lukas Reichlin ## Created: December 2009 ## Version: 0.4 function P = augw (G, W1 = [], W2 = [], W3 = []) if (nargin == 0 || nargin > 4) print_usage (); endif G = ss (G); [p, m] = size (G); [W1, p1, m1] = __adjust_weighting__ (W1, p); [W2, p2, m2] = __adjust_weighting__ (W2, m); [W3, p3, m3] = __adjust_weighting__ (W3, p); ## 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 = blkdiag (W1, W2, W3, eye (p, p)) * [Pr, Pu]; P = mktito (P, p, m); endfunction function [W, p, m] = __adjust_weighting__ (W, s) W = ss (W); [p, m] = size (W); if (m == 0 || m == s) # model is empty or has s inputs return; elseif (m == 1) # model is SISO or SIMO tmp = cell (s, 1); tmp(1:s) = W; W = blkdiag (tmp{:}); # stack single-input model s times [p, m] = size (W); # weighting function now of correct size else # model is MIMO or MISO error ("augw: %s must have 1 or %d inputs", inputname (1), s); endif endfunction control-4.1.2/inst/PaxHeaders/btaconred.m0000644000000000000000000000007415012430645015355 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/btaconred.m0000644000175000017500000002277515012430645016561 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{Kr}, @var{info}] =} btaconred (@var{G}, @var{K}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} btaconred (@var{G}, @var{K}, @var{ncr}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} btaconred (@var{G}, @var{K}, @var{opt}, @dots{}) ## @deftypefnx{Function File} {[@var{Kr}, @var{info}] =} btaconred (@var{G}, @var{K}, @var{ncr}, @var{opt}, @dots{}) ## ## Controller reduction by frequency-weighted Balanced Truncation Approximation (BTA). ## Given a plant @var{G} and a stabilizing controller @var{K}, determine a reduced ## order controller @var{Kr} such that the closed-loop system is stable and closed-loop ## performance is retained. ## ## The algorithm tries to minimize the frequency-weighted error ## @iftex ## @tex ## $$ || V \\ (K - K_r) \\ W ||_{\\infty} = \\min $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## ||V (K-Kr) W|| = min ## inf ## @end example ## @end ifnottex ## where @var{V} and @var{W} denote output and input weightings. ## ## ## @strong{Inputs} ## @table @var ## @item G ## @acronym{LTI} model of the plant. ## It has m inputs, p outputs and n states. ## @item K ## @acronym{LTI} model of the controller. ## It has p inputs, m outputs and nc states. ## @item ncr ## The desired order of the resulting reduced order controller @var{Kr}. ## If not specified, @var{ncr} is chosen automatically according ## to the description of key @var{'order'}. ## @item @dots{} ## Optional pairs of keys and values. @code{"key1", value1, "key2", value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item Kr ## State-space model of reduced order controller. ## @item info ## Struct containing additional information. ## @table @var ## @item info.ncr ## The order of the obtained reduced order controller @var{Kr}. ## @item info.ncs ## The order of the alpha-stable part of original controller @var{K}. ## @item info.hsvc ## The Hankel singular values of the alpha-stable part of @var{K}. ## The @var{ncs} Hankel singular values are ordered decreasingly. ## @end table ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'order', 'ncr' ## The desired order of the resulting reduced order controller @var{Kr}. ## If not specified, @var{ncr} is chosen automatically such that states with ## Hankel singular values @var{info.hsvc} > @var{tol1} are retained. ## ## @item 'method' ## Order reduction approach to be used as follows: ## @table @var ## @item 'sr', 'b' ## Use the square-root Balance & Truncate method. ## @item 'bfsr', 'f' ## Use the balancing-free square-root Balance & Truncate method. Default method. ## @end table ## ## @item 'weight' ## Specifies the type of frequency-weighting as follows: ## @table @var ## @item 'none' ## No weightings are used (V = I, W = I). ## ## @item 'left', 'output' ## Use stability enforcing left (output) weighting ## @iftex ## @tex ## $$ V = (I - G K)^{-1} G, \\qquad W = I $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## -1 ## V = (I-G*K) *G , W = I ## @end example ## @end ifnottex ## ## @item 'right', 'input' ## Use stability enforcing right (input) weighting ## @iftex ## @tex ## $$ V = I, \\qquad W = (I - G K)^{-1} G $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## -1 ## V = I , W = (I-G*K) *G ## @end example ## @end ifnottex ## ## @item 'both', 'performance' ## Use stability and performance enforcing weightings ## @iftex ## @tex ## $$ V = (I - G K)^{-1} G, \\qquad W = (I - G K)^{-1} $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## -1 -1 ## V = (I-G*K) *G , W = (I-G*K) ## @end example ## @end ifnottex ## Default value. ## @end table ## ## @item 'feedback' ## Specifies whether @var{K} is a positive or negative feedback controller: ## @table @var ## @item '+' ## Use positive feedback controller. Default value. ## @item '-' ## Use negative feedback controller. ## @end table ## ## @item 'alpha' ## Specifies the ALPHA-stability boundary for the eigenvalues ## of the state dynamics matrix @var{K.A}. For a continuous-time ## controller, ALPHA <= 0 is the boundary value for ## the real parts of eigenvalues, while for a discrete-time ## controller, 0 <= ALPHA <= 1 represents the ## boundary value for the moduli of eigenvalues. ## The ALPHA-stability domain does not include the boundary. ## Default value is 0 for continuous-time controllers and ## 1 for discrete-time controllers. ## ## @item 'tol1' ## If @var{'order'} is not specified, @var{tol1} contains the tolerance for ## determining the order of the reduced controller. ## For model reduction, the recommended value of @var{tol1} is ## c*info.hsvc(1), where c lies in the interval [0.00001, 0.001]. ## Default value is info.ncs*eps*info.hsvc(1). ## If @var{'order'} is specified, the value of @var{tol1} is ignored. ## ## @item 'tol2' ## The tolerance for determining the order of a minimal ## realization of the ALPHA-stable part of the given ## controller. TOL2 <= TOL1. ## If not specified, ncs*eps*info.hsvc(1) is chosen. ## ## @item 'gram-ctrb' ## Specifies the choice of frequency-weighted controllability ## Grammian as follows: ## @table @var ## @item 'standard' ## Choice corresponding to standard Enns' method [1]. Default method. ## @item 'enhanced' ## Choice corresponding to the stability enhanced ## modified Enns' method of [2]. ## @end table ## ## @item 'gram-obsv' ## Specifies the choice of frequency-weighted observability ## Grammian as follows: ## @table @var ## @item 'standard' ## Choice corresponding to standard Enns' method [1]. Default method. ## @item 'enhanced' ## Choice corresponding to the stability enhanced ## modified Enns' method of [2]. ## @end table ## ## @item 'equil', 'scale' ## Boolean indicating whether equilibration (scaling) should be ## performed on @var{G} and @var{K} prior to order reduction. ## Default value is false if both @code{G.scaled == true, K.scaled == true} ## and true otherwise. ## Note that for @acronym{MIMO} models, proper scaling of both inputs and outputs ## is of utmost importance. The input and output scaling can @strong{not} ## be done by the equilibration option or the @command{prescale} function ## because these functions perform state transformations only. ## Furthermore, signals should not be scaled simply to a certain range. ## For all inputs (or outputs), a certain change should be of the same ## importance for the model. ## @end table ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB16AD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: December 2011 ## Version: 0.1 function [Kr, info] = btaconred (varargin) [Kr, info] = __conred_sb16ad__ ("bta", varargin{:}); endfunction %!shared Mo, Me, Info, HSVCe %! A = [ -1. 0. 4. %! 0. 2. 0. %! 0. 0. -3. ]; %! %! B = [ 1. %! 1. %! 1. ]; %! %! C = [ 1. 1. 1. ]; %! %! D = [ 0. ]; %! %! G = ss (A, B, C, D, "scaled", true); %! %! AC = [ -26.4000, 6.4023, 4.3868; %! 32.0000, 0, 0; %! 0, 8.0000, 0 ]; %! %! BC = [ -16 %! 0 %! 0 ]; %! %! CC = [ 9.2994 1.1624 0.1090 ]; %! %! DC = [ 0 ]; %! %! K = ss (AC, BC, CC, DC, "scaled", true); %! %! [Kr, Info] = btaconred (G, K, 2, "weight", "input", "feedback", "+"); %! %! Ae = [ 9.1900 0.0000 %! 0.0000 -34.5297 ]; %! %! Be = [ -11.9593 %! 86.3137 ]; %! %! Ce = [ 2.8955 -1.3566 ]; %! %! De = [ 0.0000 ]; %! %! # Since btaconred approximates an output controller, %! # only its input/output behavior is important and is tested %! # using n first Markov parameters. %! # The state space representaton might have different signs %! # of the states. %! # By multiplying the matrices for the Markov parameters, numeric errors %! # would propagate, therefor the accuracy of the results are limited to %! # the accuracy of the given expected results %! %! [Ao,Bo,Co,Do] = ssdata (Kr); %! Ao = round (Ao*1e4)/1e4; %! Bo = round (Bo*1e4)/1e4; %! Co = round (Co*1e4)/1e4; %! Do = round (Do*1e4)/1e4; %! %! n = size(Ao,1); %! m = size(Bo,2); %! p = size(Co,1); %! Mo = zeros (p,(n+1)*m); %! Me = zeros (p,(n+1)*m); %! Mo(:,1:m) = Do; %! Me(:,1:m) = De; %! %! Aoi = eye (n,n); %! Aei = eye (n,n); %! for i = 1:n %! Mo(:,(i-1)*m+1:i*m) = Co*Aoi*Bo; %! Me(:,(i-1)*m+1:i*m) = Ce*Aei*Be; %! Aoi = Aoi*Ao; %! Aei = Aei*Ae; %! endfor %! %! HSVCe = [ 3.8253 0.2005 ].'; %! %!assert (Mo, Me, 1e-4); %!assert (Info.hsvc, HSVCe, 1e-4); control-4.1.2/inst/PaxHeaders/__slicot_identification__.m0000644000000000000000000000007415012430645020556 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__slicot_identification__.m0000644000175000017500000001677115012430645021761 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{sys}, @var{x0}], @var{info} =} __slicot_identification__ (@var{method}, @var{dat}, @dots{}) ## Backend for moesp, moen4 and n4sid. ## @end deftypefn ## Author: Lukas Reichlin ## Created: May 2012 ## Version: 0.1 function [sys, x0, info] = __slicot_identification__ (method, nout, dat, varargin) ## determine identification method switch (method) case "moesp" meth = 0; case "n4sid" meth = 1; case "moen4" meth = 2; otherwise error ("ident: invalid method"); # should never happen endswitch if (! isa (dat, "iddata") || ! dat.timedomain) error ("%s: first argument must be a time-domain 'iddata' dataset", method); endif if (nargin > 3) # ident (dat, ...) if (is_real_scalar (varargin{1})) # ident (dat, n, ...) varargin = horzcat (varargin(2:end), {"order"}, varargin(1)); endif if (isstruct (varargin{1})) # ident (dat, opt, ...), ident (dat, n, opt, ...) varargin = horzcat (__opt2cell__ (varargin{1}), varargin(2:end)); endif endif nkv = numel (varargin); # number of keys and values if (rem (nkv, 2)) error ("%s: keys and values must come in pairs", method); endif [ns, p, m, e] = size (dat); # dataset dimensions tsam = dat.tsam; ## multi-experiment data requires equal sampling times if (e > 1 && ! isequal (tsam{:})) error ("%s: require equally sampled experiments", method); else tsam = tsam{1}; endif ## default arguments alg = 0; conct = 1; # no connection between experiments ctrl = 1; # don't confirm order n rcond = 0.0; tol = 0.0; # -1.0; s = []; n = []; conf = []; noise = "n"; ## handle keys and values for k = 1 : 2 : nkv key = lower (varargin{k}); val = varargin{k+1}; switch (key) case {"n", "order"} if (! issample (val, 0) || val != round (val)) error ("%s: 'n' must be a positive integer", method); endif n = val; case "s" if (! issample (val, 0) || val != round (val)) error ("%s: 's' must be a positive integer", method); endif s = val; case {"alg", "algorithm"} if (strncmpi (val, "c", 1)) alg = 0; # Cholesky algorithm applied to correlation matrix elseif (strncmpi (val, "f", 1)) alg = 1; # fast QR algorithm elseif (strncmpi (val, "q", 1)) alg = 2; # QR algorithm applied to block Hankel matrices else error ("%s: invalid algorithm", method); endif case "tol" if (! is_real_scalar (val)) error ("%s: tolerance 'tol' must be a real scalar", method); endif tol = val; case "rcond" if (! is_real_scalar (val)) error ("%s: 'rcond' must be a real scalar", method); endif rcond = val; case "confirm" conf = logical (val); case {"noiseinput", "noiseinputs", "noise", "input", "inputs"} noise = val; otherwise warning ("%s: invalid property name '%s' ignored\n", method, key); endswitch endfor ## handle s/nobr and n nsmp = sum (ns); # total number of samples nobr = fix ((nsmp+1)/(2*(m+p+1))); if (e > 1) nobr = min (nobr, fix (min (ns) / 2)); endif if (nobr < 1) error ("%s: for the given system dimensions (%dx%d), the iddata dataset does not contain enough samples per experiment", ... method, p, m); endif if (isempty (s) && isempty (n)) ctrl = 0; # confirm system order estimate n = 0; elseif (isempty (s)) s = min (2*n, n+10); # upper bound for n nobr = min (nobr, s); elseif (isempty (n)) nobr = __check_s__ (s, nobr, method); ctrl = 0; # confirm system order estimate n = 0; else # s & n non-empty nobr = __check_s__ (s, nobr, method); if (n >= nobr) error ("%s: n=%d, but require n < %d (s)", method, n, nobr); endif endif if (! isempty (conf)) ctrl = ! conf; endif if (nout == 0) ## compute singular values [sv, nrec] = __sl_ib01ad__ (dat.y, dat.u, nobr, n, meth, alg, conct, ctrl, rcond, tol); ## there is no 'logbar' function svl = log10 (sv); base = floor (min (svl)); clf bar (svl, "basevalue", base) xlim ([0, length(sv)+1]) yl = ylim; ylim ([base, yl(2)]) title ("Singular Values") ylabel ("Logarithm of Singular Values") xlabel (sprintf ("Estimated System Order with current Tolerance: %d", nrec)) grid on else ## perform system identification [a, b, c, d, q, ry, s, k, x0] = __sl_ident__ (dat.y, dat.u, nobr, n, meth, alg, conct, ctrl, rcond, tol); ## compute noise variance matrix factor L ## L L' = Ry, e = L v ## v becomes white noise with identity covariance matrix l = chol (ry, "lower"); ## assemble model [inname, outname] = get (dat, "inname", "outname"); if (strncmpi (noise, "e", 1)) # add error inputs e, not normalized sys = ss (a, [b, k], c, [d, eye(p)], tsam); in_u = __labels__ (inname, "u"); in_e = __labels__ (outname, "y"); in_e = cellfun (@(x) ["e@", x], in_e, "uniformoutput", false); inname = [in_u; in_e]; elseif (strncmpi (noise, "v", 1)) # add error inputs v, normalized sys = ss (a, [b, k*l], c, [d, l], tsam); in_u = __labels__ (inname, "u"); in_v = __labels__ (outname, "y"); in_v = cellfun (@(x) ["v@", x], in_v, "uniformoutput", false); inname = [in_u; in_v]; elseif (strncmpi (noise, "k", 1)) # Kalman predictor sys = ss ([a-k*c], [b-k*d, k], c, [d, zeros(p)], tsam); in_u = __labels__ (inname, "u"); in_y = __labels__ (outname, "y"); inname = [in_u; in_y]; else # no error inputs, default sys = ss (a, b, c, d, tsam); endif sys = set (sys, "inname", inname, "outname", outname); ## return x0 as vector for single-experiment data ## instead of a cell containing one vector if (numel (x0) == 1) x0 = x0{1}; endif ## assemble info struct ## Kalman gain matrix K ## state covariance matrix Q ## output covariance matrix Ry ## state-output cross-covariance matrix S ## noise variance matrix factor L info = struct ("K", k, "Q", q, "Ry", ry, "S", s, "L", l); endif endfunction function nobr = __check_s__ (s, nobr, method) if (s <= nobr) nobr = s; else error ("%s: require upper bound s <= %d, but the requested s is %d", method, nobr, s); endif endfunction control-4.1.2/inst/PaxHeaders/@lti0000644000000000000000000000007415012430645014051 xustar0030 atime=1747595720.873132883 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/0000755000175000017500000000000015012430645015315 5ustar00lilgelilge00000000000000control-4.1.2/inst/@lti/PaxHeaders/norm.m0000644000000000000000000000007415012430645015257 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/norm.m0000644000175000017500000000734115012430645016453 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- 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 H-2 or L-inf norm of @acronym{LTI} model. ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB13BD and AB13DD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 0.5 function [gain, varargout] = norm (sys, ntype = "2", tol = 0.01) if (nargin > 3) # norm () is caught by built-in function print_usage (); endif if (is_real_scalar (ntype) && ! isinf (ntype)) if (ntype == 2) ntype = "2"; else error ("lti: norm: invalid norm type"); endif elseif (ischar (ntype)) ntype = lower (ntype); elseif ((numel (ntype) == 1) && isnumeric (ntype) && isinf (ntype)) ntype = "inf"; else error ("lti: norm: invalid norm type"); endif switch (ntype) case "2" gain = h2norm (sys); case "inf" [gain, varargout{1}] = linfnorm (sys, tol); otherwise error ("lti: norm: invalid norm type"); endswitch endfunction function gain = h2norm (sys) if (isstable (sys)) [a, b, c, d] = ssdata (sys); discrete = ! isct (sys); if (! discrete && any (d(:))) # continuous and non-zero feedthrough gain = inf; else gain = __sl_ab13bd__ (a, b, c, d, discrete); endif else gain = inf; endif endfunction function [gain, wpeak] = linfnorm (sys, tol = 0.01) [a, b, c, d, e, tsam, scaled] = dssdata (sys, []); discrete = ! isct (sys); tol = max (tol, 100*eps); if (isempty (e)) [fpeak, gpeak] = __sl_ab13dd__ (a, a, b, c, d, discrete, false, tol, scaled); # TODO: avoid dummy argument else if (rcond (e) < eps) gain = inf; wpeak = inf; return; else [fpeak, gpeak] = __sl_ab13dd__ (a, e, b, c, d, discrete, true, tol, scaled); endif endif if (fpeak(2) > 0) if (discrete) wpeak = fpeak(1) / abs (tsam); # tsam could be -1 else wpeak = fpeak(1); endif else wpeak = inf; endif if (gpeak(2) > 0) gain = gpeak(1); else gain = inf; endif endfunction ## 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); control-4.1.2/inst/@lti/PaxHeaders/__sys_keys__.m0000644000000000000000000000007415012430645016751 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/__sys_keys__.m0000644000175000017500000000217015012430645020140 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Stub function whose sole purpose is that function __lti_keys__ ## terminates correctly for pure LTI objects. This is needed in ## LTI subclasses for calls like @code{sys.lti.tsam}. For internal use only. ## Author: Lukas Reichlin ## Created: October 2015 ## Version: 0.1 function [keys, vals] = __sys_keys__ (sys) keys = vals = cell (0, 1); endfunction control-4.1.2/inst/@lti/PaxHeaders/isstable.m0000644000000000000000000000007415012430645016112 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/isstable.m0000644000175000017500000000331715012430645017305 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{bool} =} isstable (@var{sys}) ## @deftypefnx {Function File} {@var{bool} =} isstable (@var{sys}, @var{tol}) ## Determine whether @acronym{LTI} system is stable. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. ## @item tol ## Optional tolerance for stability. ## @var{tol} must be a real-valued, non-negative scalar. ## Default value is 0. ## @end table ## ## @strong{Outputs} ## @table @var ## @item bool ## True if the system is stable and false otherwise. ## @end table ## ## @example ## @group ## real (p) < -tol*(1 + abs (p)) continuous-time ## abs (p) < 1 - tol discrete-time ## @end group ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.2 function bool = isstable (sys, tol = 0) if (nargin > 2) print_usage (); endif pol = pole (sys); ct = isct (sys); bool = __is_stable__ (pol, ct, tol); endfunction control-4.1.2/inst/@lti/PaxHeaders/isct.m0000644000000000000000000000007415012430645015246 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/isct.m0000644000175000017500000000256615012430645016446 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{bool} =} isct (@var{sys}) ## Determine whether @acronym{LTI} model is a continuous-time system. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. ## @end table ## ## @strong{Outputs} ## @table @var ## @item bool = 0 ## @var{sys} is a discrete-time system. ## @item bool = 1 ## @var{sys} is a continuous-time system or a static gain. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function bool = isct (ltisys) if (nargin != 1) print_usage (); endif bool = (ltisys.tsam == 0); endfunction control-4.1.2/inst/@lti/PaxHeaders/get.m0000644000000000000000000000007415012430645015063 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/get.m0000644000175000017500000000433615012430645016260 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} get (@var{sys}) ## @deftypefnx {Function File} {@var{value} =} get (@var{sys}, @var{"key"}) ## @deftypefnx {Function File} {[@var{val1}, @var{val2}, @dots{}] =} get (@var{sys}, @var{"key1"}, @var{"key2"}, @dots{}) ## Access key values of @acronym{LTI} objects. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function varargout = get (sys, varargin) if (nargin == 1) [keys, vals] = __lti_keys__ (sys); nrows = numel (keys); str = strjust (strvcat (keys), "right"); str = horzcat (repmat (" ", nrows, 1), str, repmat (": ", nrows, 1), strvcat (vals)); disp (str); else if (! isa (sys, "lti")) print_usage (); endif keys = __lti_keys__ (sys, true); for k = 1 : (nargin-1) key = __match_key__ (varargin{k}, keys, [class(sys), ": get"]); switch (key) case {"inname", "inputname"} val = sys.inname; case {"outname", "outputname"} val = sys.outname; case {"ingroup", "inputgroup"} val = sys.ingroup; case {"outgroup", "outputgroup"} val = sys.outgroup; case "tsam" val = sys.tsam; case "name" val = sys.name; case "notes" val = sys.notes; case "userdata" val = sys.userdata; otherwise val = __get__ (sys, key); endswitch varargout{k} = val; endfor endif endfunction control-4.1.2/inst/@lti/PaxHeaders/set.m0000644000000000000000000000007415012430645015077 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/set.m0000644000175000017500000001242615012430645016273 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} set (@var{sys}) ## @deftypefnx {Function File} {} set (@var{sys}, @var{"key"}, @var{value}, @dots{}) ## @deftypefnx {Function File} {@var{retsys} =} set (@var{sys}, @var{"key"}, @var{value}, @dots{}) ## Set or modify properties of @acronym{LTI} objects. ## If no return argument @var{retsys} is specified, the modified @acronym{LTI} object is stored ## in input argument @var{sys}. @command{set} can handle multiple properties in one call: ## @code{set (sys, 'key1', val1, 'key2', val2, 'key3', val3)}. ## @code{set (sys)} prints a list of the object's key names. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.7 function retsys = set (sys, varargin) if (nargin == 1) # set (sys), sys = set (sys) [keys, vals] = __lti_keys__ (sys); nrows = numel (keys); str = strjust (strvcat (keys), "right"); str = horzcat (repmat (" ", nrows, 1), str, repmat (": ", nrows, 1), strvcat (vals)); disp (str); if (nargout != 0) # function sys = set (sys, varargin) retsys = sys; # would lead to unwanted output when using endif # set (sys) else # set (sys, "key1", val1, ...), sys = set (sys, "key1", val1, ...) if (! isa (sys, "lti")); print_usage (); endif if (rem (nargin-1, 2)) error ("lti: set: keys and values must come in pairs"); endif [p, m] = size (sys); keys = __lti_keys__ (sys, true); for k = 1 : 2 : (nargin-1) key = __match_key__ (varargin{k}, keys, [class(sys), ": set"]); val = varargin{k+1}; switch (key) case {"inname", "inputname"} sys.inname = __adjust_labels__ (val, m); case {"outname", "outputname"} sys.outname = __adjust_labels__ (val, p); case "tsam" if (issample (val, -1) && isdt (sys)) sys.tsam = val; elseif (is_real_scalar (val) && val == 0 && isct (sys)) sys.tsam = 0; elseif (is_real_matrix (val) && isempty (val) && isdt (sys)) sys.tsam = -1; else error ("lti: set: invalid sampling time"); endif case {"ingroup", "inputgroup"} if (isstruct (val) && all (size (val) == 1) ... && all (structfun (@(x) is_group_idx (x, m), val))) empty = structfun (@isempty, val); fields = fieldnames (val); sys.ingroup = rmfield (val, fields(empty)); else error ("lti: set: key 'ingroup' requires a scalar struct containing valid input indices in the range [1, %d]", m); endif case {"outgroup", "outputgroup"} if (isstruct (val) && all (size (val) == 1) ... && all (structfun (@(x) is_group_idx (x, p), val))) empty = structfun (@isempty, val); fields = fieldnames (val); sys.outgroup = rmfield (val, fields(empty)); else error ("lti: set: key 'outgroup' requires a scalar struct containing valid output indices in the range [1, %d]", p); endif case "name" if (ischar (val) && ndims (val) == 2 && (rows (val) == 1 || isempty (val))) sys.name = val; else error ("lti: set: key 'name' requires a string"); endif case "notes" if (iscellstr (val)) sys.notes = val; elseif (ischar (val)) sys.notes = {val}; else error ("lti: set: key 'notes' requires string or cell of strings"); endif case "userdata" sys.userdata = val; case "lti" if (isa (val, "lti")) lti_keys = __lti_keys__ (val, false, false); n = numel (lti_keys); lti_vals = cell (n, 1); [lti_vals{1:n}] = get (val, lti_keys{:}); for k = 1:n try sys = set (sys, lti_keys{k}, lti_vals{k}); end_try_catch endfor else error ("lti: set: key 'lti' requires an LTI model"); endif otherwise sys = __set__ (sys, key, val); endswitch endfor if (nargout == 0) # set (sys, "key1", val1, ...) assignin ("caller", inputname (1), sys); else # sys = set (sys, "key1", val1, ...) retsys = sys; endif endif endfunction function bool = is_group_idx (idx, n) bool = (isempty (idx) || (is_real_vector (idx) && all (idx > 0) && all (idx <= n) && all (abs (fix (idx)) == idx))); endfunction control-4.1.2/inst/@lti/PaxHeaders/inv.m0000644000000000000000000000007415012430645015100 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/inv.m0000644000175000017500000000470515012430645016275 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{SYSI} = } inv (@var{SYS}) ## Inversion of @acronym{LTI} objects. ## ## @strong{Inputs} ## @table @var ## @item SYS ## System to be inverted. ## @end table ## ## @strong{Outputs} ## @table @var ## @item SYSI ## Inverteted system of @var{SYS}. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function retsys = inv (sys) if (nargin != 1) # prevent sys = inv (sys1, sys2, sys3, ...) error ("lti: inv: this is an unary operator"); endif [p, m] = size (sys); if (p != m) error ("lti: inv: system must be square"); endif retsys = __sys_inverse__ (sys); ## handle i/o names retsys.inname = sys.outname; retsys.outname = sys.inname; retsys.ingroup = sys.outgroup; retsys.outgroup = sys.ingroup; endfunction ## inverse of state-space models ## test from SLICOT AB07ND ## result differs intentionally from slicot ## to prevent states x_inv = -x %!shared M, Me %! A = [ 1.0 2.0 0.0 %! 4.0 -1.0 0.0 %! 0.0 0.0 1.0 ]; %! %! B = [ 1.0 0.0 %! 0.0 1.0 %! 1.0 0.0 ]; %! %! C = [ 0.0 1.0 -1.0 %! 0.0 0.0 1.0 ]; %! %! D = [ 4.0 0.0 %! 0.0 1.0 ]; %! %! sys = ss (A, B, C, D); %! sysinv = inv (sys); %! [Ai, Bi, Ci, Di] = ssdata (sysinv); %! M = [Ai, Bi; Ci, Di]; %! %! Ae = [ 1.0000 1.7500 0.2500 %! 4.0000 -1.0000 -1.0000 %! 0.0000 -0.2500 1.2500 ]; %! %! Be = [-0.2500 0.0000 %! 0.0000 -1.0000 %! -0.2500 0.0000 ]; %! %! Ce = [ 0.0000 0.2500 -0.2500 %! 0.0000 0.0000 1.0000 ]; %! %! De = [ 0.2500 0.0000 %! 0.0000 1.0000 ]; %! %! Me = [Ae, -Be; -Ce, De]; %! %!assert (M, Me, 1e-4); control-4.1.2/inst/@lti/PaxHeaders/times.m0000644000000000000000000000007415012430645015425 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/times.m0000644000175000017500000000360515012430645016620 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} times ## Hadamard/Schur product of transfer function matrices. ## Also known as element-wise multiplication. ## Used by Octave for "sys1 .* sys2". ## ## @strong{Example} ## @example ## @group ## # Compute Relative-Gain Array ## G = tf (Boeing707) ## RGA = G .* inv (G).' ## # Gain at 0 rad/s ## RGA(0) ## @end group ## @end example ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: April 2014 ## Version: 0.2 function sys = times (sys1, sys2) if (nargin != 2) # prevent sys = times (sys1, sys2, sys3, ...) error ("lti: times: this is a binary operator"); endif [p1, m1] = size (sys1); [p2, m2] = size (sys2); if (p1 != p2 || m1 != m2) if (p1 == 1 && m1 == 1 && p2*m2 > 1) # sys1 SISO, sys2 non-empty sys1 = repmat (sys1, p2, m2); elseif (p2 == 1 && m2 == 1 && p1*m1 > 1) # sys2 SISO, sys1 non-empty sys2 = repmat (sys2, p1, m1); else error ("lti: times: system dimensions incompatible: (%dx%d) .* (%dx%d)", ... p1, m1, p2, m2); endif endif sys = __times__ (sys1, sys2); endfunction control-4.1.2/inst/@lti/PaxHeaders/subsref.m0000644000000000000000000000007415012430645015755 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/subsref.m0000644000175000017500000000472315012430645017152 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} subsref ## Subscripted reference for @acronym{LTI} objects. ## Used by Octave for "sys = sys(2:4, :)" or "val = sys.prop". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.5 function a = subsref (a, s) if (numel (s) == 0) return; endif switch (s(1).type) case "()" idx = s(1).subs; switch (numel (idx)) case 2 a = __sys_prune__ (a, idx{1}, idx{2}); case 1 a = freqresp (a, idx{1}); case 0 ## NOTE: for example, Octave returns a = a() for a = rand (2, 2) ## so we do the same for LTI models. ## a = a; # superfluous ## error (["lti: subsref: invalid subscripted reference of type '()'. ", ... ## "need one or two arguments inside the brackets."]); otherwise ## bug #45314 error (["lti: subsref: arrays of linear models are not supported (yet). ", ... "as a workaround, try to use cells of LTI models instead."]); endswitch case "." fld = s(1).subs; a = get (a, fld); ## warning ("lti: subsref: do not use subsref for development"); otherwise error ("lti: subsref: invalid subscript type '%s'", s(1).type); endswitch a = subsref (a, s(2:end)); endfunction ## lti: subsref %!shared a %! s = tf ("s"); %! G = (s+2)*s*5/(s+1)/(s^2+s+1); %! a = G(1,1).num{1,1}(2:3); %!assert (a, [5 10], 1e-4); %!shared a, b %! G = tf ({[1 1],[2];[1 1 1],[1 2]},{[1 1 1],[1 2 1];[1 2 1],[1 0]}); %! a = G(1,2).num{1,1}; %! b = G(2,2).den{1,1}; %!assert (a, [0 0 2], 1e-4); %!assert (b, [1 0], 1e-4); control-4.1.2/inst/@lti/PaxHeaders/d2c.m0000644000000000000000000000007415012430645014754 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/d2c.m0000644000175000017500000000675415012430645016157 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} d2c (@var{sys}) ## @deftypefnx {Function File} {@var{sys} =} d2c (@var{sys}, @var{method}) ## @deftypefnx {Function File} {@var{sys} =} d2c (@var{sys}, @var{'prewarp'}, @var{w0}) ## Convert the discrete @acronym{LTI} model into its continuous-time equivalent. ## ## @strong{Inputs} ## @table @var ## @item sys ## Discrete-time @acronym{LTI} model. ## @item method ## Optional conversion method. If not specified, default method @var{"zoh"} ## is taken. ## @table @var ## @item 'zoh' ## Zero-order hold or matrix logarithm. ## @item 'tustin', 'bilin' ## Bilinear transformation or Tustin approximation. ## @item 'prewarp' ## Bilinear transformation with pre-warping at frequency @var{w0}. ## @item 'matched' ## Matched pole/zero method. ## @end table ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Continuous-time @acronym{LTI} model. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2011 ## Version: 0.2 function sys = d2c (sys, method = "std", w0 = 0) if (nargin == 0 || nargin > 3) print_usage (); endif if (! isa (sys, "lti")) error ("d2c: first argument is not an LTI model"); endif if (isct (sys)) error ("d2c: system is already continuous-time"); endif if (! ischar (method)) error ("d2c: second argument is not a string"); endif if (! issample (w0, 0)) error ("d2c: third argument is not a valid pre-warping frequency"); endif sys = __d2c__ (sys, sys.tsam, lower (method), w0); sys.tsam = 0; endfunction ## bilinear transformation ## both directions %!shared Mo, Me %! A = [ 1.0 0.5 %! 0.5 1.0 ]; %! %! B = [ 0.0 -1.0 %! 1.0 0.0 ]; %! %! C = [ -1.0 0.0 %! 0.0 1.0 ]; %! %! D = [ 1.0 0.0 %! 0.0 -1.0 ]; %! %! [Ao, Bo, Co, Do] = ssdata (d2c (c2d (ss (A, B, C, D), 2, "tustin"), "tustin")); %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [A, B; C, D]; %! %!assert (Mo, Me, 1e-4); ## zero-order hold ## both directions %!shared Mo, Me %! A = [ 1.0 0.5 %! 0.5 1.0 ]; %! %! B = [ 0.0 -1.0 %! 1.0 0.0 ]; %! %! C = [ -1.0 0.0 %! 0.0 1.0 ]; %! %! D = [ 1.0 0.0 %! 0.0 -1.0 ]; %! %! [Ao, Bo, Co, Do] = ssdata (d2c (c2d (ss (A, B, C, D), 2, "zoh"), "zoh")); %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [A, B; C, D]; %! %!assert (Mo, Me, 1e-4); ## bilinear transformation with pre-warping ## both directions %!shared Mo, Me %! A = [ 1.0 0.5 %! 0.5 1.0 ]; %! %! B = [ 0.0 -1.0 %! 1.0 0.0 ]; %! %! C = [ -1.0 0.0 %! 0.0 1.0 ]; %! %! D = [ 1.0 0.0 %! 0.0 -1.0 ]; %! %! [Ao, Bo, Co, Do] = ssdata (d2c (c2d (ss (A, B, C, D), 2, "prewarp", 1000), "prewarp", 1000)); %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [A, B; C, D]; %! %!assert (Mo, Me, 1e-4); control-4.1.2/inst/@lti/PaxHeaders/transpose.m0000644000000000000000000000007415012430645016322 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/transpose.m0000644000175000017500000000272215012430645017514 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} transpose ## Transpose of @acronym{LTI} objects. Used by Octave for "sys.'". ## Useful for dual problems, i.e. controllability and observability ## or designing estimator gains with @command{lqr} and @command{place}. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: February 2010 ## Version: 0.2 function sys = transpose (sys) if (nargin != 1) # prevent sys = transpose (sys1, sys2, sys3, ...) error ("lti: transpose: this is an unary operator"); endif [p, m] = size (sys); sys = __transpose__ (sys); sys.inname = repmat ({""}, p, 1); sys.outname = repmat ({""}, m, 1); sys.ingroup = struct (); sys.outgroup = struct (); endfunction control-4.1.2/inst/@lti/PaxHeaders/vertcat.m0000644000000000000000000000007415012430645015754 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/vertcat.m0000644000175000017500000000272715012430645017153 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} vertcat ## Vertical concatenation of @acronym{LTI} objects. If necessary, object conversion ## is done by sys_group. Used by Octave for "[sys1; sys2]". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function sys = vertcat (sys, varargin) for k = 1 : (nargin-1) sys1 = sys; sys2 = varargin{k}; [p1, m1] = size (sys1); [p2, m2] = size (sys2); if (m1 != m2) error ("lti: vertcat: number of system inputs incompatible: [(%dx%d); (%dx%d)]", p1, m1, p2, m2); endif sys = __sys_group__ (sys1, sys2); in_scl = [eye(m1); eye(m2)]; sys = sys * in_scl; endfor endfunction control-4.1.2/inst/@lti/PaxHeaders/minreal.m0000644000000000000000000000007415012430645015733 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/minreal.m0000644000175000017500000001123415012430645017123 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} minreal (@var{sys}) ## @deftypefnx {Function File} {@var{sys} =} minreal (@var{sys}, @var{tol}) ## Minimal realization or zero-pole cancellation of @acronym{LTI} models. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function sys = minreal (sys, tol = "def") if (nargin > 2) # nargin == 0 not possible because minreal is inside @lti print_usage (); endif if (! is_real_scalar (tol) && tol != "def") error ("minreal: second argument must be a real-valued scalar"); endif sys = __minreal__ (sys, tol); endfunction ## ss: minreal (SLICOT TB01PD) %!shared C, D %! %! A = ss (-2, 3, 4, 5); %! B = A / A; %! C = minreal (B, 1e-15); %! D = ss (1); %! %!assert (C.a, D.a); %!assert (C.b, D.b); %!assert (C.c, D.c); %!assert (C.d, D.d); %!shared M, Me %! A = [ 1.0 2.0 0.0 %! 4.0 -1.0 0.0 %! 0.0 0.0 1.0 ]; %! %! B = [ 1.0 %! 0.0 %! 1.0 ]; %! %! C = [ 0.0 1.0 -1.0 %! 0.0 0.0 1.0 ]; %! %! D = zeros (2, 1); %! %! [Ar, Br, Cr] = __sl_tb01pd__ (A, B, C, 0.0, true); %! M = [Ar, Br; Cr, D]; %! %! Ae = [ 1.0000 -1.4142 1.4142 %! -2.8284 0.0000 1.0000 %! 2.8284 1.0000 0.0000 ]; %! %! Be = [-1.0000 %! 0.7071 %! 0.7071 ]; %! %! Ce = [ 0.0000 0.0000 -1.4142 %! 0.0000 0.7071 0.7071 ]; %! %! De = zeros (2, 1); %! %! Me = [Ae, Be; Ce, De]; %! %!assert (M, Me, 1e-4); ## dss: minreal (SLICOT TG01JD) ## FIXME: Test fails with larger ldwork in sltg01jd.cc %!shared Ar, Br, Cr, Dr, Er, Ae, Be, Ce, De, Ee, num, den, num2, den2, num3, num3a, den3, den3a %! A = [ -2 -3 0 0 0 0 0 0 0 %! 1 0 0 0 0 0 0 0 0 %! 0 0 -2 -3 0 0 0 0 0 %! 0 0 1 0 0 0 0 0 0 %! 0 0 0 0 1 0 0 0 0 %! 0 0 0 0 0 1 0 0 0 %! 0 0 0 0 0 0 1 0 0 %! 0 0 0 0 0 0 0 1 0 %! 0 0 0 0 0 0 0 0 1 ]; %! %! E = [ 1 0 0 0 0 0 0 0 0 %! 0 1 0 0 0 0 0 0 0 %! 0 0 1 0 0 0 0 0 0 %! 0 0 0 1 0 0 0 0 0 %! 0 0 0 0 0 0 0 0 0 %! 0 0 0 0 1 0 0 0 0 %! 0 0 0 0 0 0 0 0 0 %! 0 0 0 0 0 0 1 0 0 %! 0 0 0 0 0 0 0 1 0 ]; %! %! B = [ 1 0 %! 0 0 %! 0 1 %! 0 0 %! -1 0 %! 0 0 %! 0 -1 %! 0 0 %! 0 0 ]; %! %! C = [ 1 0 1 -3 0 1 0 2 0 %! 0 1 1 3 0 1 0 0 1 ]; %! %! D = zeros (2, 2); %! %! sys = dss (A, B, C, D, E, "scaled", true); %! sysmin = minreal (sys, 0.0); %! [Ar, Br, Cr, Dr, Er] = dssdata (sysmin); %! [num,den]=tfdata(sys); %! sysmin = minreal (sys, 1e-6); %! [num2,den2]=tfdata(sysmin); %! sys3 = dss (Ar, Br, Cr, Dr, Er, "scaled", true); %! [num3,den3]=tfdata(sys3); %! sysmin3 = minreal (sys3, 1e-6); %! [num3a,den3a]=tfdata(sysmin3); %! %!assert (num, num2 , 1e-4); %!assert (den, den2 , 1e-4); %!assert (num3, num3a , 1e-4); %!assert (den3, den3a , 1e-4); %!assert (num, num3a, 1e-4); %!assert (den, den3a, 1e-4); ## tf: minreal %!shared a, b, c, d %! s = tf ("s"); %! G1 = (s+1)*s*5/(s+1)/(s^2+s+1); %! G2 = tf ([1, 1, 1], [2, 2, 2]); %! G1min = minreal (G1); %! G2min = minreal (G2); %! a = G1min.num{1, 1}; %! b = G1min.den{1, 1}; %! c = G2min.num{1, 1}; %! d = G2min.den{1, 1}; %!assert (a, [0, 5, 0], 1e-4); %!assert (b, [1, 1, 1], 1e-4); %!assert (c, 0.5, 1e-4); %!assert (d, 1, 1e-4); control-4.1.2/inst/@lti/PaxHeaders/mrdivide.m0000644000000000000000000000007415012430645016107 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/mrdivide.m0000644000175000017500000000301715012430645017277 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} mrdivide ## Matrix right division of @acronym{LTI} objects. If necessary, object conversion ## is done by sys_group in mtimes. Used by Octave for "sys1 / sys2". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.2 function sys = mrdivide (sys1, sys2) if (nargin != 2) # prevent sys = mrdivide (sys1, sys2, sys3, ...) error ("lti: mrdivide: this is a binary operator"); endif sys2 = inv (sys2); # let octave decide which inv() it uses ## [p1, m1] = size (sys1); ## [p2, m2] = size (sys2); ## ## if (m1 != p2) ## error ("lti: mrdivide: system dimensions incompatible: (%dx%d) / (%dx%d)", ## p1, m1, p2, m2); ## endif sys = sys1 * sys2; endfunction control-4.1.2/inst/@lti/PaxHeaders/blkdiag.m0000644000000000000000000000007415012430645015701 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/blkdiag.m0000644000175000017500000000222315012430645017067 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} blkdiag (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}) ## Block-diagonal concatenation of @acronym{LTI} models. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function sys = blkdiag (varargin) sys = varargin{1}; for k = 2 : nargin sys = __sys_group__ (sys, varargin{k}); endfor endfunction control-4.1.2/inst/@lti/PaxHeaders/uplus.m0000644000000000000000000000007415012430645015454 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/uplus.m0000644000175000017500000000217215012430645016645 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} uplus ## Unary plus of @acronym{LTI} object. Used by Octave for "+sys". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: June 2012 ## Version: 0.1 function sys = uplus (sys) if (nargin != 1) # prevent sys = uplus (sys1, sys2, sys3, ...) error ("lti: uplus: this is an unary operator"); endif endfunction control-4.1.2/inst/@lti/PaxHeaders/__lti_data__.m0000644000000000000000000000007415012430645016661 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/__lti_data__.m0000644000175000017500000000202515012430645020047 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Used by display routines instead of multiple get calls. ## Author: Lukas Reichlin ## Created: September 2010 ## Version: 0.1 function [inname, outname, tsam] = __lti_data__ (sys) inname = sys.inname; outname = sys.outname; tsam = sys.tsam; endfunction control-4.1.2/inst/@lti/PaxHeaders/mconnect.m0000644000000000000000000000007415012430645016112 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/mconnect.m0000644000175000017500000000503215012430645017301 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} mconnect (@var{sys}, @var{m}) ## @deftypefnx {Function File} {@var{sys} =} mconnect (@var{sys}, @var{m}, @var{inputs}, @var{outputs}) ## Arbitrary interconnections between the inputs and outputs of an @acronym{LTI} model. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. ## @item m ## Connection matrix. Each row belongs to an input and each column represents an output. ## @item inputs ## Vector of indices of those inputs which are retained. If not specified, all inputs are kept. ## @item outputs ## Vector of indices of those outputs which are retained. If not specified, all outputs are kept. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Interconnected system. ## @end table ## ## @strong{Example} ## @example ## @group ## Solve the system equations of ## y(t) = G e(t) ## e(t) = u(t) + M y(t) ## in order to build ## y(t) = H u(t) ## The matrix M for a (p-by-m) system G ## has m rows and p columns (m-by-p). ## ## Example for a 3x2 system: ## u1 = -1*y1 + 5*y2 + 0*y3 ## u2 = pi*y1 + 0*y2 - 7*y3 ## ## | -1 5 0 | ## M = | pi 0 7 | ## @end group ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.2 function sys = mconnect (sys, M, in_idx, out_idx = ":") if (nargin < 2 || nargin > 4) print_usage (); endif [p, m] = size (sys); [mrows, mcols] = size (M); if (p != mcols || m != mrows) error ("mconnect: second argument must be a (%dx%d) matrix", m, p); endif if (! is_real_matrix (M)) error ("mconnect: second argument must be a matrix with real-valued coefficients"); endif sys = __sys_connect__ (sys, M); if (nargin > 2) sys = __sys_prune__ (sys, out_idx, in_idx); endif endfunction control-4.1.2/inst/@lti/PaxHeaders/subsasgn.m0000644000000000000000000000007415012430645016131 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/subsasgn.m0000644000175000017500000000407215012430645017323 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} subsasgn ## Subscripted assignment for @acronym{LTI} objects. ## Used by Octave for "sys.property = value". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function sys = subsasgn (sys, idx, val) ## TODO: enable *more* stuff like sys.a(2, 1:3) = [4, 5, 6] ## warning ("lti: subsasgn: do not use subsasgn for development"); switch (idx(1).type) case "." if (length (idx) == 1) sys = set (sys, idx.subs, val); else key = idx(1).subs; sys = set (sys, key, subsasgn (get (sys, key), idx(2:end), val)); endif case "()" if (numel (idx(1).subs) > 2) # sys(:, :, ...) = ltisys ## bug #45314 error (["lti: subsasgn: arrays of linear models are not supported (yet). ", ... "as a workaround, try to use cells of LTI models instead."]); else # sys(out_idx, in_idx).a = mat error (["lti: subsasgn: invalid subscripted assignment type '()'. ", ... "you must select an LTI key first, i.e. sys.keyname(...) = ..."]); endif otherwise error ("lti: subsasgn: invalid subscripted assignment type '%s'", idx(1).type); endswitch endfunction control-4.1.2/inst/@lti/PaxHeaders/d2d.m0000644000000000000000000000007415012430645014755 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/d2d.m0000644000175000017500000000460215012430645016146 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} d2d (@var{sys}, @var{tsam}) ## @deftypefnx {Function File} {@var{sys} =} d2d (@var{sys}, @var{tsam}, @var{method}) ## @deftypefnx {Function File} {@var{sys} =} d2d (@var{sys}, @var{tsam}, @var{'prewarp'}, @var{w0}) ## Resample discrete-time @acronym{LTI} model to sampling time @var{tsam}. ## ## @strong{Inputs} ## @table @var ## @item sys ## Discrete-time @acronym{LTI} model. ## @item tsam ## Desired sampling time in seconds. ## @item method ## Optional conversion method. If not specified, default method @var{"zoh"} ## is taken. ## @table @var ## @item 'zoh' ## Zero-order hold or matrix logarithm. ## @item 'tustin', 'bilin' ## Bilinear transformation or Tustin approximation. ## @item 'prewarp' ## Bilinear transformation with pre-warping at frequency @var{w0}. ## @item 'matched' ## Matched pole/zero method. ## @end table ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Resampled discrete-time @acronym{LTI} model with sampling time @var{tsam}. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2013 ## Version: 0.1 function sys = d2d (sys, tsam, method = "std", w0 = 0) if (nargin < 2) print_usage (); endif tmp = d2c (sys, method, w0); sys = c2d (tmp, tsam, method, w0); endfunction %!shared num, den, z, p, k %! H1 = zpk (0.7, 0.5, 1, 0.1); %! H2 = d2d (H1, 0.05); %! H3 = d2d (H2, 0.1); %! [num, den] = tfdata (H2, "vector"); %! [z, p, k] = zpkdata (H3, "vector"); %!assert (num, [1.00000 -0.82426], 1e-4); %!assert (den, [1.00000 -0.70711], 1e-4); %!assert (z, 0.7, 1e-4); %!assert (p, 0.5, 1e-4); %!assert (k, 1.0, 1e-4); control-4.1.2/inst/@lti/PaxHeaders/sminreal.m0000644000000000000000000000007415012430645016116 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/sminreal.m0000644000175000017500000000740515012430645017313 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} sminreal (@var{sys}) ## @deftypefnx {Function File} {@var{sys} =} sminreal (@var{sys}, @var{tol}) ## Perform state-space model reduction based on structure. ## Remove states which have no influence on the input-output behaviour. ## The physical meaning of the states is retained. ## ## @strong{Inputs} ## @table @var ## @item sys ## State-space model. ## @item tol ## Optional tolerance for controllability and observability. ## Entries of the state-space matrices whose moduli are less or equal to @var{tol} ## are assumed to be zero. Default value is 0. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Reduced state-space model. ## @end table ## ## @seealso{minreal} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function sys = sminreal (sys, tol = 0) if (nargin > 2) # sminreal () not possible (inside @lti) print_usage (); endif if (! isa (sys, "ss")) warning ("sminreal: system not in state-space form\n"); sys = ss (sys); # needed by __sys_prune__ endif if (! (is_real_scalar (tol) && tol >= 0)) error ("sminreal: second argument is not a valid tolerance"); endif [a, b, c, d, e] = dssdata (sys, []); a = abs (a) > tol; b = abs (b) > tol; c = abs (c) > tol; if (! isempty (e)) e = abs (e) > tol; a = a | e; endif co_idx = __controllable_states__ (a, b); ob_idx = __controllable_states__ (a.', c.'); st_idx = intersect (co_idx, ob_idx); sys = __sys_prune__ (sys, ":", ":", st_idx); endfunction function c_idx = __controllable_states__ (a, b) n = rows (a); # number of states a = a & ! eye (n); # set diagonal entries to zero c_vec = any (b, 2); # states directly controllable c_idx = find (c_vec); # indices of directly controllable states c_idx_new = 0; # any vector of length > 0 possible while (all (length (c_idx) != [0, n]) && length(c_idx_new) != 0) u_idx = find (! c_vec); # indices of uncontrollable states #{ ## debug code a(u_idx, :) repmat (c_vec.', length (u_idx), 1) a(u_idx, :) & repmat (c_vec.', length (u_idx), 1) any (a(u_idx, :) & repmat (c_vec.', length (u_idx), 1), 2) find (any (a(u_idx, :) & repmat (c_vec.', length (u_idx), 1), 2)) #} c_idx_new = u_idx (find (any (a(u_idx, :) & repmat (c_vec.', length (u_idx), 1), 2))); c_idx = union (c_idx, c_idx_new); c_vec(c_idx_new) = 1; endwhile endfunction ## ss: sminreal %!shared B, C %! %! A = ss (-2, 3, 4, 5); %! B = A / A; %! C = sminreal (B); # no states should be removed %! %!assert (C.a, B.a); %!assert (C.b, B.b); %!assert (C.c, B.c); %!assert (C.d, B.d); %!shared A, B, D, E %! %! A = ss (-1, 1, 1, 0); %! B = ss (-2, 3, 4, 5); %! C = [A, B]; %! D = sminreal (C(:, 1)); %! E = sminreal (C(:, 2)); %! %!assert (D.a, A.a); %!assert (D.b, A.b); %!assert (D.c, A.c); %!assert (D.d, A.d); %!assert (E.a, B.a); %!assert (E.b, B.b); %!assert (E.c, B.c); %!assert (E.d, B.d); control-4.1.2/inst/@lti/PaxHeaders/xperm.m0000644000000000000000000000007415012430645015437 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/xperm.m0000644000175000017500000000370515012430645016633 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{retsys} =} xperm (@var{sys}, @var{idx}) ## Reorder states in state-space models. ## ## @strong{Inputs} ## @table @var ## @item sys ## State-space model. ## @item idx ## Vector containing the state indices in the desired order. ## Alternatively, a cell vector containing the state names ## is possible as well. See @code{sys.stname}. State names ## only work if they were assigned explicitly before, i.e. ## @code{sys.stname} contains no empty strings. ## Note that if certain state indices of @var{sys} are ## missing or appear multiple times in @var{idx}, these ## states will be pruned or duplicated accordingly in the ## resulting state-space model @var{retsys}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item retsys ## Resulting state-space model with states reordered according to @var{idx}. ## @end table ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 0.2 function sys = xperm (sys, st_idx) if (nargin != 2) print_usage (); endif if (! isa (sys, "ss")) warning ("xperm: system not in state-space form\n"); sys = ss (sys); endif sys = __sys_prune__ (sys, ":", ":", st_idx); endfunction control-4.1.2/inst/@lti/PaxHeaders/__lti_group__.m0000644000000000000000000000007415012430645017104 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/__lti_group__.m0000644000175000017500000000570215012430645020277 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Block diagonal concatenation of two LTI models. ## This file is part of the Model Abstraction Layer. ## For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function retlti = __lti_group__ (lti1, lti2, dim = "blkdiag") retlti = lti (:, :, :); if (any (strcmpi (dim, {"blkdiag", "horzcat"}))) # blkdiag, horzcat retlti.inname = [lti1.inname; lti2.inname]; if (numfields (lti1.ingroup) || numfields (lti2.ingroup)) m1 = numel (lti1.inname); lti2_ingroup = structfun (@(x) x + m1, lti2.ingroup, "uniformoutput", false); retlti.ingroup = __merge_struct__ (lti1.ingroup, lti2_ingroup); endif else # times, vertcat retlti.inname = repmat ({""}, numel (lti1.inname), 1); ## retlti.ingroup remains empty struct endif if (any (strcmpi (dim, {"blkdiag", "vertcat"}))) # blkdiag, vertcat retlti.outname = [lti1.outname; lti2.outname]; if (numfields (lti1.outgroup) || numfields (lti2.outgroup)) p1 = numel (lti1.outname); lti2_outgroup = structfun (@(x) x + p1, lti2.outgroup, "uniformoutput", false); retlti.outgroup = __merge_struct__ (lti1.outgroup, lti2_outgroup); endif else # times, horzcat retlti.outname = repmat ({""}, numel (lti1.outname), 1); ## retlti.outgroup remains empty struct endif if (lti1.tsam == lti2.tsam) retlti.tsam = lti1.tsam; elseif (lti1.tsam == -1 && lti2.tsam > 0) retlti.tsam = lti2.tsam; elseif (lti2.tsam == -1 && lti1.tsam > 0) retlti.tsam = lti1.tsam; else error ("lti_group: systems must have identical sampling times"); endif endfunction function ret = __merge_struct__ (a, b) ## FIXME: this is too complicated; ## isn't there a simple function for this task? a = orderfields (a); b = orderfields (b); fa = fieldnames (a); fb = fieldnames (b); [fi, ia, ib] = intersect (fa, fb); ca = struct2cell (a); cb = struct2cell (b); for k = numel (fi) : -1 : 1 ca{ia(k)} = vertcat (ca{ia(k)}(:), cb{ib(k)}(:)); fb(ib(k)) = []; cb(ib(k)) = []; endfor ret = cell2struct ([ca; cb], [fa; fb]); endfunction control-4.1.2/inst/@lti/PaxHeaders/frdata.m0000644000000000000000000000007415012430645015545 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/frdata.m0000644000175000017500000000426015012430645016736 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{H}, @var{w}, @var{tsam}] =} frdata (@var{sys}) ## @deftypefnx {Function File} {[@var{H}, @var{w}, @var{tsam}] =} frdata (@var{sys}, @var{"vector"}) ## Access frequency response data. ## Argument @var{sys} is not limited to frequency response data objects. ## If @var{sys} is not a frd object, it is converted automatically. ## ## @strong{Inputs} ## @table @var ## @item sys ## Any type of @acronym{LTI} model. ## @item "v", "vector" ## In case @var{sys} is a SISO model, this option returns the frequency response ## as a column vector (lw-by-1) instead of an array (p-by-m-by-lw). ## @end table ## ## @strong{Outputs} ## @table @var ## @item H ## Frequency response array (p-by-m-by-lw). H(i,j,k) contains the ## response from input j to output i at frequency k. In the SISO case, ## a vector (lw-by-1) is possible as well. ## @item w ## Frequency vector (lw-by-1) in radian per second [rad/s]. ## Frequencies are in ascending order. ## @item tsam ## Sampling time in seconds. If @var{sys} is a continuous-time model, ## a zero is returned. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.3 function [H, w, tsam] = frdata (sys, rtype = "array") if (! isa (sys, "frd")) sys = frd (sys); endif [H, w] = __sys_data__ (sys); tsam = sys.tsam; if (strncmpi (rtype, "v", 1) && issiso (sys)) H = reshape (H, [], 1); endif endfunction control-4.1.2/inst/@lti/PaxHeaders/freqresp.m0000644000000000000000000000007415012430645016133 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/freqresp.m0000644000175000017500000000334015012430645017322 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{H} =} freqresp (@var{sys}, @var{w}) ## Evaluate frequency response at given frequencies. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. ## @item w ## Vector of frequency values. ## @end table ## ## @strong{Outputs} ## @table @var ## @item H ## Array of frequency response. For a system with m inputs and p outputs, the array @var{H} ## has dimensions [p, m, length (w)]. ## The frequency response at the frequency w(k) is given by H(:,:,k). ## @end table ## ## @seealso{dcgain} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.2 function H = freqresp (sys, w) if (nargin != 2) # case freqresp () not possible print_usage (); endif if (! is_real_vector (w)) # catches freqresp (sys, sys) and freqresp (w, sys) as well error ("freqresp: second argument 'w' must be a real-valued vector of frequencies"); endif H = __freqresp__ (sys, w); endfunction control-4.1.2/inst/@lti/PaxHeaders/connect.m0000644000000000000000000000007415012430645015735 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/connect.m0000644000175000017500000001527415012430645017135 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} connect (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}, @var{inputs}, @var{outputs}) ## @deftypefnx {Function File} {@var{sys} =} connect (@var{sys}, @var{cm}, @var{inputs}, @var{outputs}) ## Name-based or index-based interconnections between the inputs and outputs of @acronym{LTI} models. ## ## @strong{Inputs} ## @table @var ## @item sys1, @dots{}, sysN ## @acronym{LTI} models to be connected. The properties 'inname' and 'outname' ## of each model should be set according to the desired input-output connections. ## @item inputs ## For name-based interconnections, string or cell of strings containing the names ## of the inputs to be kept. The names must be part of the properties 'ingroup' or ## 'inname'. For index-based interconnections, vector containing the indices of the ## inputs to be kept. ## @item outputs ## For name-based interconnections, string or cell of strings containing the names ## of the outputs to be kept. The names must be part of the properties 'outgroup' ## or 'outname'. For index-based interconnections, vector containing the indices of ## the outputs to be kept. ## @item cm ## Connection matrix (not name-based). Each row of the matrix represents a summing ## junction. The first column holds the indices of the inputs to be summed with ## outputs of the subsequent columns. The output indices can be negative, if the output ## is to be substracted, or zero. For example, the row ## @example ## [2 0 3 -4 0] ## @end example ## or ## @example ## [2 -4 3] ## @end example ## will sum input u(2) with outputs y(3) and y(4) as ## @example ## u(2) + y(3) - y(4). ## @end example ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Resulting interconnected system with outputs @var{outputs} and ## inputs @var{inputs}. ## @end table ## ## @seealso{sumblk} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function sys = connect (varargin) if (nargin < 2) print_usage (); endif if (is_real_matrix (varargin{2})) # connect (sys, cm, in_idx, out_idx) if (nargin != 4) print_usage (); endif sys = varargin{1}; cm = varargin{2}; in_idx = varargin{3}; out_idx = varargin{4}; [p, m] = size (sys); [cmrows, cmcols] = size (cm); ## if (! is_real_matrix (cm)) ## error ("connect: second argument must be a matrix with real-valued coefficients"); ## endif M = zeros (m, p); in = cm(:, 1); out = cm(:, 2:cmcols); ## check sizes and integer values if (! isequal (cm, floor (cm))) error ("connect: matrix 'cm' must contain integer values (index-based interconnection)"); endif if ((min (in) <= 0) || (max (in) > m)) error ("connect: 'cm' input index in out of range (index-based interconnection)"); endif if (max (abs (out(:))) > p) error ("connect: 'cm' output index out of range (index-based interconnection)"); endif if ((! is_real_vector (in_idx)) || (! isequal (in_idx, floor (in_idx)))) error ("connect: 'inputs' must be a vector of integer values (index-based interconnection)"); endif if ((max (in_idx) > m) || (min (in_idx) <= 0)) error ("connect: index in vector 'inputs' out of range (index-based interconnection)"); endif if ((! is_real_vector (out_idx)) || (! isequal (out_idx, floor (out_idx)))) error ("connect: 'outputs' must be a vector of integer values (index-based interconnection)"); endif if ((max (out_idx) > p) || (min (out_idx) <= 0)) error ("connect: index in vector 'outputs' out of range (index-based interconnection)"); endif for a = 1 : cmrows out_tmp = out(a, (out(a,:) != 0)); if (! isempty (out_tmp)) M(in(a,1), abs (out_tmp)) = sign (out_tmp); endif endfor sys = __sys_connect__ (sys, M); sys = __sys_prune__ (sys, out_idx, in_idx); else # connect (sys1, sys2, ..., sysN, in_idx, out_idx) lti_idx = cellfun (@isa, varargin, {"lti"}); sys = blkdiag (varargin{lti_idx}); io_idx = ! lti_idx; if (nnz (io_idx) == 2) in_idx = varargin(io_idx){1}; out_idx = varargin(io_idx){2}; else in_idx = ":"; out_idx = ":"; endif inname = sys.inname; if (any (cellfun (@isempty, inname))) error ("connect: all inputs must have names"); endif outname = sys.outname; if (any (cellfun (@isempty , outname))) error ("connect: all outputs must have names"); endif ioname = intersect (inname, outname); tmp = cellfun (@(x) find (strcmp (inname, x)(:)), ioname, "uniformoutput", false); inputs = vertcat (tmp{:}); # there could be more than one input with the same name [p, m] = size (sys); M = zeros (m, p); for k = 1 : length (inputs) outputs = strcmp (outname, inname(inputs(k))); M(inputs(k), :) = outputs; endfor sys = __sys_connect__ (sys, M); ## sys_prune will error out if names in out_idx and in_idx are not unique ## the dark side handles cases with common in_idx names - so do we inname_u = unique (inname); if (numel (inname_u) != numel (inname)) tmp = cellfun (@(u) strcmp (u, inname), inname_u, "uniformoutput", false); mat = double (horzcat (tmp{:})); scl = ss (mat, "inname", inname_u, "outname", inname); sys = sys * scl; if (is_real_vector (in_idx)) warning ("connect: use names instead of indices for argument 'inputs'\n"); endif endif sys = __sys_prune__ (sys, out_idx, in_idx); if (isa (sys, "ss")) sys = sminreal (sys); endif endif endfunction %!shared T, Texp %! P = Boeing707; %! I = ss (-eye (2)); %! I.inname = P.outname; %! I.outname = P.inname; %! T = connect (P, I, P.inname, P.outname); %! Texp = feedback (P); %!assert (T.a, Texp.a, 1e-4); %!assert (T.b, Texp.b, 1e-4); %!assert (T.c, Texp.c, 1e-4); %!assert (T.d, Texp.d, 1e-4); control-4.1.2/inst/@lti/PaxHeaders/size_equal.m0000644000000000000000000000007415012430645016445 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/size_equal.m0000644000175000017500000000244015012430645017634 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{bool} =} size_equal (@var{a}, @var{b}, @dots{}) ## Return true if @acronym{LTI} models (and matrices) @var{a}, @var{b}, @dots{} ## are of equal size and false otherwise. ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2012 ## Version: 0.1 function bool = size_equal (varargin) s = cellfun (@size, varargin, "uniformoutput", false); bool = (nargin == 1 || isequal (s{:})); # isequal errors out with only 1 argument, nargin==0 handled by built-in size_equal endfunction control-4.1.2/inst/@lti/PaxHeaders/mtimes.m0000644000000000000000000000007415012430645015602 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/mtimes.m0000644000175000017500000001127615012430645017000 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} mtimes ## Matrix multiplication of @acronym{LTI} objects. If necessary, object conversion ## is done by sys_group. Used by Octave for "sys1 * sys2". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.4 function sys = mtimes (sys2, sys1) if (nargin != 2) # prevent sys = mtimes (sys1, sys2, sys3, ...) error ("lti: mtimes: this is a binary operator"); endif [p1, m1] = size (sys1); [p2, m2] = size (sys2); if (m2 != p1) # innner dimensions don't match if (p1 == 1 && m1 == 1 && m2 > 1) # sys1 is SISO, m2 != 0 [sys1, p1, m1] = __siso_expansion__ (sys1, m2); elseif (p2 == 1 && m2 == 1 && p1 > 1) # sys2 is SISO, p1 != 0 [sys2, p2, m2] = __siso_expansion__ (sys2, p1); else error ("lti: mtimes: system dimensions incompatible: (%dx%d) * (%dx%d)", p2, m2, p1, m1); endif endif M22 = zeros (m2, p2); M21 = eye (m2, p1); M12 = zeros (m1, p2); M11 = zeros (m1, p1); M = [M22, M21; M12, M11]; out_idx = 1 : p2; in_idx = m2 + (1 : m1); sys = __sys_group__ (sys2, sys1); sys = __sys_connect__ (sys, M); sys = __sys_prune__ (sys, out_idx, in_idx); endfunction ## concatenate lti or matrix sys s times block-diagonally ## despite its name, it also works for MIMO systems. function [sys, p, m] = __siso_expansion__ (sys, s) tmp = cell (s, 1); tmp(1:s) = sys; sys = blkdiag (tmp{:}); [p, m] = size (sys); endfunction ## Alternative code: consistency vs. compatibility #{ M11 = zeros (m1, p1); M12 = zeros (m1, p2); M21 = eye (m2, p1); M22 = zeros (m2, p2); M = [M11, M12; M21, M22]; out_idx = p1 + (1 : p2); in_idx = 1 : m1; sys = __sys_group__ (sys1, sys2); #} ## Don't forget to adapt @tf/__sys_connect__.m draft code ## mtimes %!shared sysmat, sysmat_exp %! sys1 = ss ([0, 1; -3, -2], [0; 1], [-5, 1], [2]); %! sys2 = ss ([-10], [1], [-40], [5]); %! sys3 = sys2 * sys1; %! [A, B, C, D] = ssdata (sys3); %! sysmat = [A, B; C, D]; %! A_exp = [ -10 -5 1 %! 0 0 1 %! 0 -3 -2 ]; %! B_exp = [ 2 %! 0 %! 1 ]; %! C_exp = [ -40 -25 5 ]; %! D_exp = [ 10 ]; %! sysmat_exp = [A_exp, B_exp; C_exp, D_exp]; %!assert (sysmat, sysmat_exp) ## Cascade inter-connection of two systems in state-space form ## Test from SLICOT AB05MD ## TODO: order of united state vector: consistency vs. compatibility? #%!shared M, Me #%! A1 = [ 1.0 0.0 -1.0 #%! 0.0 -1.0 1.0 #%! 1.0 1.0 2.0 ]; #%! #%! B1 = [ 1.0 1.0 0.0 #%! 2.0 0.0 1.0 ].'; #%! #%! C1 = [ 3.0 -2.0 1.0 #%! 0.0 1.0 0.0 ]; #%! #%! D1 = [ 1.0 0.0 #%! 0.0 1.0 ]; #%! #%! A2 = [-3.0 0.0 0.0 #%! 1.0 0.0 1.0 #%! 0.0 -1.0 2.0 ]; #%! #%! B2 = [ 0.0 -1.0 0.0 #%! 1.0 0.0 2.0 ].'; #%! #%! C2 = [ 1.0 1.0 0.0 #%! 1.0 1.0 -1.0 ]; #%! #%! D2 = [ 1.0 1.0 #%! 0.0 1.0 ]; #%! #%! sys1 = ss (A1, B1, C1, D1); #%! sys2 = ss (A2, B2, C2, D2); #%! sys = sys2 * sys1; #%! [A, B, C, D] = ssdata (sys); #%! M = [A, B; C, D]; #%! #%! Ae = [ 1.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 #%! 0.0000 -1.0000 1.0000 0.0000 0.0000 0.0000 #%! 1.0000 1.0000 2.0000 0.0000 0.0000 0.0000 #%! 0.0000 1.0000 0.0000 -3.0000 0.0000 0.0000 #%! -3.0000 2.0000 -1.0000 1.0000 0.0000 1.0000 #%! 0.0000 2.0000 0.0000 0.0000 -1.0000 2.0000 ]; #%! #%! Be = [ 1.0000 2.0000 #%! 1.0000 0.0000 #%! 0.0000 1.0000 #%! 0.0000 1.0000 #%! -1.0000 0.0000 #%! 0.0000 2.0000 ]; #%! #%! Ce = [ 3.0000 -1.0000 1.0000 1.0000 1.0000 0.0000 #%! 0.0000 1.0000 0.0000 1.0000 1.0000 -1.0000 ]; #%! #%! De = [ 1.0000 1.0000 #%! 0.0000 1.0000 ]; #%! #%! Me = [Ae, Be; Ce, De]; #%! #%!assert (M, Me, 1e-4); control-4.1.2/inst/@lti/PaxHeaders/zero.m0000644000000000000000000000007415012430645015263 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/zero.m0000644000175000017500000003604715012430645016464 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 Lukas F. Reichlin ## Copyright (C) 2011 Ferdinand Svaricek, UniBw Munich. ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{z} =} zero (@var{sys}) ## @deftypefnx {Function File} {@var{z} =} zero (@var{sys}, @var{type}) ## @deftypefnx {Function File} {[@var{z}, @var{k}, @var{info}] =} zero (@var{sys}) ## Compute zeros and gain of @acronym{LTI} model. ## By default, @command{zero} computes the invariant zeros, ## also known as Smith zeros. Alternatively, when called with ## a second input argument, @command{zero} can also compute ## the system zeros, transmission zeros, input decoupling zeros ## and output decoupling zeros. See paper [1] for an explanation ## of the various zero flavors as well as for further details. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @item type ## String specifying the type of zeros: ## @table @var ## @item 'system', 's' ## Compute the system zeros. ## The system zeros include in all cases ## (square, non-square, degenerate or non-degenerate system) ## all transmission and decoupling zeros. ## @item 'invariant', 'inv' ## Compute invariant zeros. Default selection. ## @item 'transmission', 't' ## Compute transmission zeros. Transmission zeros ## are a subset of the invariant zeros. ## The transmission zeros are the zeros of the ## Smith-McMillan form of the transfer function matrix. ## @item 'input', 'inp', 'id' ## Compute input decoupling zeros. The input decoupling zeros are ## also known as the uncontrollable eigenvalues of the pair (A,B). ## @item 'output', 'o', 'od' ## Compute output decoupling zeros. The output decoupling zeros are ## also known as the unobservable eigenvalues of the pair (A,C). ## @end table ## @end table ## ## @strong{Outputs} ## @table @var ## @item z ## Depending on argument @var{type}, @var{z} contains the ## invariant (default), system, transmission, input decoupling ## or output decoupling zeros of @var{sys} as defined in [1]. ## @item k ## Gain of @acronym{SISO} system @var{sys}. For @acronym{MIMO} ## systems, an empty matrix @code{[]} is returned. ## @item info ## Struct containing additional information. For details, ## see the documentation of @acronym{SLICOT} routines ## @acronym{AB08ND} and @acronym{AG08BD}. ## @item info.rank ## The normal rank of the transfer function matrix (regular state-space models) ## or of the system pencil (descriptor state-space models). ## @item info.infz ## Contains information on the infinite elementary divisors as follows: ## the system has info.infz(i) infinite elementary divisors of degree i, ## where i=1,2,...,length(info.infz). ## @item info.kronr ## Right Kronecker (column) indices. ## @item info.kronl ## Left Kronecker (row) indices. ## @end table ## ## @strong{Examples} ## @example ## @group ## [z, k, info] = zero (sys) # invariant zeros ## z = zero (sys, 'system') # system zeros ## z = zero (sys, 'invariant') # invariant zeros ## z = zero (sys, 'transmission') # transmission zeros ## z = zero (sys, 'output') # output decoupling zeros ## z = zero (sys, 'input') # input decoupling zeros ## @end group ## @end example ## ## @strong{Algorithm}@* ## For (descriptor) state-space models, @command{zero} ## uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB08ND and AG08BD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## For @acronym{SISO} transfer functions, @command{zero} ## uses Octave's @command{roots}. ## @acronym{MIMO} transfer functions are converted to ## a @emph{minimal} state-space representation for the ## computation of the zeros. ## ## @strong{References}@* ## [1] MacFarlane, A. and Karcanias, N. ## @cite{Poles and zeros of linear multivariable systems: ## a survey of the algebraic, geometric and complex-variable ## theory}. Int. J. Control, vol. 24, pp. 33-74, 1976.@* ## [2] Rosenbrock, H.H. ## @cite{Correction to 'The zeros of a system'}. ## Int. J. Control, vol. 20, no. 3, pp. 525-527, 1974.@* ## [3] Svaricek, F. ## @cite{Computation of the structural invariants of linear ## multivariable systems with an extended version of the ## program ZEROS}. ## Systems & Control Letters, vol. 6, pp. 261-266, 1985.@* ## [4] Emami-Naeini, A. and Van Dooren, P. ## @cite{Computation of zeros of linear multivariable systems}. ## Automatica, vol. 26, pp. 415-430, 1982.@* ## ## @end deftypefn ## TODO: write a short summary about the characteristics of the ## various zero flavors and add it to the docstring. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function [zer, gain, info] = zero (sys, type = "invariant") if (nargin > 2) print_usage (); endif if (strncmpi (type, "invariant", 3)) # invariant zeros, default [zer, gain, info] = __zero__ (sys, nargout); elseif (strncmpi (type, "transmission", 1)) # transmission zeros [zer, gain, info] = zero (minreal (sys)); elseif (strncmpi (type, "input", 3) || strncmpi (type, "id", 2)) # input decoupling zeros [a, b, c, d, e, tsam] = dssdata (sys, []); tmp = dss (a, b, zeros (0, columns (a)), zeros (0, columns (b)), e, tsam); [zer, gain, info] = zero (tmp); elseif (strncmpi (type, "output", 1)) # output decoupling zeros [a, b, c, d, e, tsam] = dssdata (sys, []); tmp = dss (a, zeros (rows (a), 0), c, zeros (rows (c), 0), e, tsam); [zer, gain, info] = zero (tmp); elseif (strncmpi (type, "system", 1)) # system zeros [zer, gain, info] = __szero__ (sys); else error ("zero: type '%s' invalid", type); endif endfunction ## Function for computing the system zeros. ## Adapted from Ferdinand Svaricek's szero.m function [z, gain, info] = __szero__ (sys) ## TODO: support descriptor state-space models ## with singular 'E' matrices [a, b, c, d] = ssdata (sys); [pp, mm] = size (sys); nn = rows (a); ## Tolerance for intersection of zeros Zeps = 10 * sqrt ((nn+pp)*(nn+mm)) * eps * norm (a,'fro'); [z, gain, info] = zero (ss (a, b, c, d)); # zero (sys) lets descriptor test fail Rank = info.rank; ## System is not degenerated and square if (Rank == 0 || (Rank == min(pp,mm) && mm == pp)) return; endif ## System (A,B,C,D) is degenerated and/or non-square z = []; ## Computation of the greatest common divisor of all minors of the ## Rosenbrock system matrix that have the following form ## ## 1, 2, ..., n, n+i_1, n+i_2, ..., n+i_k ## P ## 1, 2, ..., n, n+j_1, n+j_2, ..., n+j_k ## ## with k = Rank. NKP = nchoosek (1:pp, Rank); [IP, JP] = size (NKP); NKM = nchoosek (1:mm, Rank); [IM, JM] = size (NKM); for i = 1:IP for j = 1:JP k = NKP(i,j); C1(j,:) = c(k,:); # Build C of dimension (Rank x n) endfor for ii = 1:IM for jj = 1:JM k = NKM(ii,jj); B1(:,jj) = b(:,k); # Build B of dimension (n x Rank) endfor [z1, ~, info1] = zero (ss (a, B1, C1, zeros (Rank, Rank))); rank1 = info1.rank; if (rank1 == Rank) if (isempty (z1)) z = z1; # Subsystem has no zeros -> system has no system zeros return; else if (isempty (z)) z = z1; # Zeros of the first subsystem else # Compute intersection of z and z1 with tolerance Zeps z2 = []; for ii=1:length(z) for jj=1:length(z1) if (abs (z(ii)-z1(jj)) < Zeps) z2(end+1) = z(ii); z1(jj) = []; break; endif endfor endfor z = z2; # System zeros are the common zeros of all subsystems endif endif endif endfor endfor endfunction ## Invariant zeros of state-space models ## ## Results from the "Dark Side" 7.5 and 7.8 ## ## -13.2759 ## 12.5774 ## -0.0155 ## ## Results from Scilab 5.2.0b1 (trzeros) ## ## - 13.275931 ## 12.577369 ## - 0.0155265 ## %!shared z, z_exp %! A = [ -0.7 -0.0458 -12.2 0 %! 0 -0.014 -0.2904 -0.562 %! 1 -0.0057 -1.4 0 %! 1 0 0 0 ]; %! %! B = [ -19.1 -3.1 %! -0.0119 -0.0096 %! -0.14 -0.72 %! 0 0 ]; %! %! C = [ 0 0 -1 1 %! 0 0 0.733 0 ]; %! %! D = [ 0 0 %! 0.0768 0.1134 ]; %! %! sys = ss (A, B, C, D, "scaled", true); %! z = sort (zero (sys)); %! %! z_exp = sort ([-13.2759; 12.5774; -0.0155]); %! %!assert (z, z_exp, 1e-4); ## Invariant zeros of regular state-space models %!shared z, z_exp, info, rank_exp, infz_exp, kronr_exp, kronl_exp %! A = [ 1.0 0.0 0.0 0.0 0.0 0.0 %! 0.0 1.0 0.0 0.0 0.0 0.0 %! 0.0 0.0 3.0 0.0 0.0 0.0 %! 0.0 0.0 0.0 -4.0 0.0 0.0 %! 0.0 0.0 0.0 0.0 -1.0 0.0 %! 0.0 0.0 0.0 0.0 0.0 3.0 ]; %! %! B = [ 0.0 -1.0 %! -1.0 0.0 %! 1.0 -1.0 %! 0.0 0.0 %! 0.0 1.0 %! -1.0 -1.0 ]; %! %! C = [ 1.0 0.0 0.0 1.0 0.0 0.0 %! 0.0 1.0 0.0 1.0 0.0 1.0 %! 0.0 0.0 1.0 0.0 0.0 1.0 ]; %! %! D = [ 0.0 0.0 %! 0.0 0.0 %! 0.0 0.0 ]; %! %! sys = ss (A, B, C, D, "scaled", true); %! [z, ~, info] = zero (sys); %! %! z_exp = [ 2.0000 %! -1.0000 ]; %! %! rank_exp = 2; %! infz_exp = 2; %! kronr_exp = zeros (1, 0); %! kronl_exp = 2; %! %!assert (z, z_exp, 1e-4); %!assert (info.rank, rank_exp); %!assert (info.infz, infz_exp); %!assert (info.kronr, kronr_exp); %!assert (info.kronl, kronl_exp); ## Invariant zeros of descriptor state-space models %!shared z, z_exp, info, rank_exp, infz_exp, kronr_exp, kronl_exp %! A = [ 1 0 0 0 0 0 0 0 0 %! 0 1 0 0 0 0 0 0 0 %! 0 0 1 0 0 0 0 0 0 %! 0 0 0 1 0 0 0 0 0 %! 0 0 0 0 1 0 0 0 0 %! 0 0 0 0 0 1 0 0 0 %! 0 0 0 0 0 0 1 0 0 %! 0 0 0 0 0 0 0 1 0 %! 0 0 0 0 0 0 0 0 1 ]; %! %! E = [ 0 0 0 0 0 0 0 0 0 %! 1 0 0 0 0 0 0 0 0 %! 0 1 0 0 0 0 0 0 0 %! 0 0 0 0 0 0 0 0 0 %! 0 0 0 1 0 0 0 0 0 %! 0 0 0 0 1 0 0 0 0 %! 0 0 0 0 0 0 0 0 0 %! 0 0 0 0 0 0 1 0 0 %! 0 0 0 0 0 0 0 1 0 ]; %! %! B = [ -1 0 0 %! 0 0 0 %! 0 0 0 %! 0 -1 0 %! 0 0 0 %! 0 0 0 %! 0 0 -1 %! 0 0 0 %! 0 0 0 ]; %! %! C = [ 0 1 1 0 3 4 0 0 2 %! 0 1 0 0 4 0 0 2 0 %! 0 0 1 0 -1 4 0 -2 2 ]; %! %! D = [ 1 2 -2 %! 0 -1 -2 %! 0 0 0 ]; %! %! sys = dss (A, B, C, D, E, "scaled", true); %! [z, ~, info] = zero (sys); %! %! z_exp = 1; %! %! rank_exp = 11; %! infz_exp = [0, 1]; %! kronr_exp = 2; %! kronl_exp = 1; %! %!assert (z, z_exp, 1e-4); %!assert (info.rank, rank_exp); %!assert (info.infz, infz_exp); %!assert (info.kronr, kronr_exp); %!assert (info.kronl, kronl_exp); ## Gain of descriptor state-space models %!shared p, pi, z, zi, k, ki, p_tf, pi_tf, z_tf, zi_tf, k_tf, ki_tf %! P = ss (-2, 3, 4, 5); %! Pi = inv (P); %! %! p = pole (P); %! [z, k] = zero (P); %! %! pi = pole (Pi); %! [zi, ki] = zero (Pi); %! %! P_tf = tf (P); %! Pi_tf = tf (Pi); %! %! p_tf = pole (P_tf); %! [z_tf, k_tf] = zero (P_tf); %! %! pi_tf = pole (Pi_tf); %! [zi_tf, ki_tf] = zero (Pi_tf); %! %!assert (p, zi, 1e-4); %!assert (z, pi, 1e-4); %!assert (k, inv (ki), 1e-4); %!assert (p_tf, zi_tf, 1e-4); %!assert (z_tf, pi_tf, 1e-4); %!assert (k_tf, inv (ki_tf), 1e-4); ## Example taken from Paper [1] ## Regular state-space system %!shared z_inv, z_tra, z_inp, z_out, z_sys, z_inv_e, z_tra_e, z_inp_e, z_out_e, z_sys_e %! A = diag ([1, 1, 3, -4, -1, 3]); %! %! B = [ 0, -1 %! -1, 0 %! 1, -1 %! 0, 0 %! 0, 1 %! -1, -1 ]; %! %! C = [ 1, 0, 0, 1, 0, 0 %! 0, 1, 0, 1, 0, 1 %! 0, 0, 1, 0, 0, 1 ]; %! %! D = zeros (3, 2); %! %! SYS = ss (A, B, C, D); %! %! z_inv = zero (SYS); %! z_tra = zero (SYS, "transmission"); %! z_inp = zero (SYS, "input decoupling"); %! z_out = zero (SYS, "output decoupling"); %! z_sys = zero (SYS, "system"); %! %! z_inv_e = [2; -1]; %! z_tra_e = [2]; %! z_inp_e = [-4]; %! z_out_e = [-1]; %! z_sys_e = [-4, -1, 2]; %! %!assert (z_inv, z_inv_e, 1e-4); %!assert (z_tra, z_tra_e, 1e-4); %!assert (z_inp, z_inp_e, 1e-4); %!assert (z_out, z_out_e, 1e-4); %!assert (z_sys, z_sys_e, 1e-4); ## Example taken from Paper [1] ## Well, this is not exactly a descriptor state-space model, ## but it is the best thing I have right now and it is better ## than no test at all. The routine for the system zeros works ## only for descriptor state-space models with regular 'E' matrices. %!shared z_inv, z_tra, z_inp, z_out, z_sys, z_inv_e, z_tra_e, z_inp_e, z_out_e, z_sys_e %! A = diag ([1, 1, 3, -4, -1, 3]); %! %! B = [ 0, -1 %! -1, 0 %! 1, -1 %! 0, 0 %! 0, 1 %! -1, -1 ]; %! %! C = [ 1, 0, 0, 1, 0, 0 %! 0, 1, 0, 1, 0, 1 %! 0, 0, 1, 0, 0, 1 ]; %! %! D = zeros (3, 2); %! %! E = eye (6); %! %! SYS = dss (A, B, C, D, E); %! %! z_inv = zero (SYS); %! z_tra = zero (SYS, "transmission"); %! z_inp = zero (SYS, "input decoupling"); %! z_out = zero (SYS, "output decoupling"); %! z_sys = zero (SYS, "system"); %! %! z_inv_e = [2; -1]; %! z_tra_e = [2]; %! z_inp_e = [-4]; %! z_out_e = [-1]; %! z_sys_e = [-4, -1, 2]; %! %!assert (z_inv, z_inv_e, 1e-4); %!assert (z_tra, z_tra_e, 1e-4); %!assert (z_inp, z_inp_e, 1e-4); %!assert (z_out, z_out_e, 1e-4); %!assert (z_sys, z_sys_e, 1e-4); control-4.1.2/inst/@lti/PaxHeaders/ctranspose.m0000644000000000000000000000007415012430645016465 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/ctranspose.m0000644000175000017500000000377415012430645017667 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{SYST} =} ctranspose (@var{SYS}) ## Conjugate transpose or pertransposition of @acronym{LTI} objects. ## Used by Octave for "sys'". ## For a transfer-function matrix G, G' denotes the conjugate ## of G given by G.'(-s) for a continuous-time system or G.'(1/z) ## for a discrete-time system. ## The frequency response of the pertransposition of G is the ## Hermitian (conjugate) transpose of G(jw), i.e. ## freqresp (G', w) = freqresp (G, w)'. ## @strong{WARNING:} Do @strong{NOT} use this for dual problems, ## use the transpose "sys.'" (note the dot) instead. ## ## @strong{Inputs} ## @table @var ## @item SYS ## System to be transposed. ## @end table ## ## @strong{Outputs} ## @table @var ## @item SYST ## Conjugate transposed of @var{SYS}. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: May 2012 ## Version: 0.2 function sys = ctranspose (sys) if (nargin != 1) # prevent sys = ctranspose (sys1, sys2, sys3, ...) error ("lti: ctranspose: this is an unary operator"); endif [p, m] = size (sys); ct = isct (sys); sys = __ctranspose__ (sys, ct); sys.inname = repmat ({""}, p, 1); sys.outname = repmat ({""}, m, 1); sys.ingroup = struct (); sys.outgroup = struct (); endfunction control-4.1.2/inst/@lti/PaxHeaders/zpkdata.m0000644000000000000000000000007415012430645015742 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/zpkdata.m0000644000175000017500000000506215012430645017134 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{z}, @var{p}, @var{k}, @var{tsam}] =} zpkdata (@var{sys}) ## @deftypefnx {Function File} {[@var{z}, @var{p}, @var{k}, @var{tsam}] =} zpkdata (@var{sys}, @var{"v"}) ## Access zero-pole-gain data. ## ## @strong{Inputs} ## @table @var ## @item sys ## Any type of @acronym{LTI} model. ## @item "v", "vector" ## For SISO models, return @var{z} and @var{p} directly as column vectors ## instead of cells containing a single column vector. ## @end table ## ## @strong{Outputs} ## @table @var ## @item z ## Cell of column vectors containing the zeros for each channel. ## z@{i,j@} contains the zeros from input j to output i. ## @item p ## Cell of column vectors containing the poles for each channel. ## p@{i,j@} contains the poles from input j to output i. ## @item k ## Matrix containing the gains for each channel. ## k(i,j) contains the gain from input j to output i. ## @item tsam ## Sampling time in seconds. If @var{sys} is a continuous-time model, ## a zero is returned. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2011 ## Version: 0.1 function [z, p, k, tsam] = zpkdata (sys, rtype = "cell") [num, den, tsam] = tfdata (sys); num = cellfun (@__remove_leading_zeros__, num, 'uniformoutput', false); den = cellfun (@__remove_leading_zeros__, den, 'uniformoutput', false); z = cellfun (@roots, num, "uniformoutput", false); p = cellfun (@roots, den, "uniformoutput", false); k = cellfun (@(n,d) n(1)/d(1), num, den); if (strncmpi (rtype, "v", 1) && issiso (sys)) z = z{1}; p = p{1}; endif endfunction %!test %! ze = {[1];[-2 ; 0]}; %! pe = {[-1 ; 0];[-4 ; -3 ; -1]}; %! ke = [ 5 ; 10 ]; %! sys = zpk (ze, pe, ke); %! [zo, po, ko] = zpkdata (sys); %! assert (zo, ze, 1e-4); %! assert (po, pe, 1e-4); %! assert (ko, ke, 1e-4); control-4.1.2/inst/@lti/PaxHeaders/repmat.m0000644000000000000000000000007415012430645015574 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/repmat.m0000644000175000017500000000407215012430645016766 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{rsys} =} repmat (@var{sys}, @var{m}, @var{n}) ## @deftypefnx {Function File} {@var{rsys} =} repmat (@var{sys}, [@var{m}, @var{n}]) ## @deftypefnx {Function File} {@var{rsys} =} repmat (@var{sys}, @var{m}) ## Form a block transfer matrix of @var{sys} with @var{m} copies vertically ## and @var{n} copies horizontally. If @var{n} is not specified, it is set to @var{m}. ## @code{repmat (sys, 2, 3)} is equivalent to @code{[sys, sys, sys; sys, sys, sys]}. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: May 2014 ## Version: 0.1 function sys = repmat (sys, x, y) switch (nargin) case 2 if (is_real_scalar (x)) # repmat (sys, m) y = x; elseif (is_real_vector (x) && length (x) == 2) # repmat (sys, [m, n]) y = x(2); x = x(1); else error ("lti: repmat: second argument invalid"); endif case 3 # repmat (sys, m, n) if (! is_real_scalar (x, y)) error ("lti: repmat: dimensions 'm' and 'n' must be real integers"); endif otherwise print_usage (); endswitch [p, m] = size (sys); out_idx = repmat (1:p, 1, x); in_idx = repmat (1:m, 1, y); sys = __sys_prune__ (sys, out_idx, in_idx); endfunction control-4.1.2/inst/@lti/PaxHeaders/c2d.m0000644000000000000000000000007415012430645014754 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/c2d.m0000644000175000017500000001733215012430645016151 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} c2d (@var{sys}, @var{tsam}) ## @deftypefnx {Function File} {@var{sys} =} c2d (@var{sys}, @var{tsam}, @var{method}) ## @deftypefnx {Function File} {@var{sys} =} c2d (@var{sys}, @var{tsam}, @var{'prewarp'}, @var{w0}) ## Convert the continuous @acronym{LTI} model into its discrete-time equivalent. ## ## @strong{Inputs} ## @table @var ## @item sys ## Continuous-time @acronym{LTI} model. ## @item tsam ## Sampling time in seconds. ## @item method ## Optional conversion method. If not specified, default method @var{"zoh"} ## is taken. ## @table @var ## @item 'impulse' ## Impulse Invarient transformation. ## @item 'zoh' ## Zero-order hold or matrix exponential. ## @item 'foh' ## First-order hold, linear approximation of the input signals between ## two sample times ## @item 'tustin', 'bilin' ## Bilinear transformation or Tustin approximation. ## @item 'prewarp' ## Bilinear transformation with pre-warping at frequency @var{w0}. ## @item 'matched' ## Matched pole/zero method. ## @end table ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Discrete-time @acronym{LTI} model. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function sys = c2d (sys, tsam, method = "std", w0 = 0) if (nargin < 2 || nargin > 4) print_usage (); endif if (! isa (sys, "lti")) error ("c2d: first argument is not an LTI model"); endif if (isdt (sys)) error ("c2d: system is already discrete-time"); endif if (! issample (tsam)) error ("c2d: second argument is not a valid sample time"); endif if (! ischar (method)) error ("c2d: third argument is not a string"); endif if (! issample (w0, 0)) error ("c2d: fourth argument is not a valid pre-warping frequency"); endif sys = __c2d__ (sys, tsam, lower (method), w0); sys.tsam = tsam; endfunction ## bilinear transformation ## using oct-file directly %!shared Mo, Me %! A = [ 1.0 0.5 %! 0.5 1.0 ].'; %! %! B = [ 0.0 -1.0 %! 1.0 0.0 ].'; %! %! C = [ -1.0 0.0 %! 0.0 1.0 ].'; %! %! D = [ 1.0 0.0 %! 0.0 -1.0 ].'; %! %! [Ao, Bo, Co, Do] = __sl_ab04md__ (A, B, C, D, 1.0, 1.0, false); %! %! Ae = [ -1.0000 -4.0000 %! -4.0000 -1.0000 ]; %! %! Be = [ 2.8284 0.0000 %! 0.0000 -2.8284 ]; %! %! Ce = [ 0.0000 2.8284 %! -2.8284 0.0000 ]; %! %! De = [ -1.0000 0.0000 %! 0.0000 -3.0000 ]; %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [Ae, Be; Ce, De]; %! %!assert (Mo, Me, 1e-4); ## bilinear transformation ## user function %!shared Mo, Me %! A = [ 1.0 0.5 %! 0.5 1.0 ].'; %! %! B = [ 0.0 -1.0 %! 1.0 0.0 ].'; %! %! C = [ -1.0 0.0 %! 0.0 1.0 ].'; %! %! D = [ 1.0 0.0 %! 0.0 -1.0 ].'; %! %! [Ao, Bo, Co, Do] = ssdata (c2d (ss (A, B, C, D), 2, "tustin")); %! %! Ae = [ -1.0000 -4.0000 %! -4.0000 -1.0000 ]; %! %! Be = [ 2.8284 0.0000 %! 0.0000 -2.8284 ]; %! %! Ce = [ 0.0000 2.8284 %! -2.8284 0.0000 ]; %! %! De = [ -1.0000 0.0000 %! 0.0000 -3.0000 ]; %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [Ae, Be; Ce, De]; %! %!assert (Mo, Me, 1e-4); ## impulse invariant %!shared Mo, Me %! A = [ 1.0 0.5 %! 0.5 1.0 ]; %! %! B = [ 0.0 -1.0 %! 1.0 0.0 ]; %! %! C = [ -1.0 0.0 %! 0.0 1.0 ]; %! %! D = [ 0.0 0.0 %! 0.0 0.0 ]; %! %! [Ao, Bo, Co, Do] = ssdata (c2d (ss(A,B,C,D), 2, "imp")); %! %! Ae = [ 11.4019 8.6836 %! 8.6836 11.4019 ]; %! %! Be = [ 17.3673 -22.8038 %! 22.8038 -17.3673 ]; %! %! Ce = [ -1.0000 0.0000 %! 0.0000 1.0000 ]; %! %! De = [ 0.0000 2.0000 %! 2.0000 0.0000 ]; %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [Ae, Be; Ce, De]; %! %!assert (Mo, Me, 1e-4); ## impulse invariant for transfer function %!shared Mo, Me %! G = tf ({[1 0],1;[1],1},{[1 1 1],[1 1];[1 0],[1 2 1]}); %! %! [nuo, dno] = tfdata (c2d (G, 2, "imp")); %! %! nue = {[2 -0.3011 0], [2 0]; [2 0], [0 0.5413 0]}; %! dne = {[1 0.1181 0.1353], [1 -0.1353]; [1 -1], [1 -0.2707 0.01832]}; %! %! Mo = [ nuo{1,1} nuo{1,2} nuo{2,1} nuo{2,2} dno{1,1} dno{1,2} dno{2,1} dno{2,2} ]; %! Me = [ nue{1,1} nue{1,2} nue{2,1} nue{2,2} dne{1,1} dne{1,2} dne{2,1} dne{2,2} ]; %! %!assert (Mo, Me, 1e-4); ## bilinear transformation ## both directions %!shared Mo, Me %! A = [ 1.0 0.5 %! 0.5 1.0 ]; %! %! B = [ 0.0 -1.0 %! 1.0 0.0 ]; %! %! C = [ -1.0 0.0 %! 0.0 1.0 ]; %! %! D = [ 1.0 0.0 %! 0.0 -1.0 ]; %! %! [Ao, Bo, Co, Do] = ssdata (d2c (c2d (ss (A, B, C, D), 2, "tustin"), "tustin")); %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [A, B; C, D]; %! %!assert (Mo, Me, 1e-4); ## zero-order hold ## both directions %!shared Mo, Me %! A = [ 1.0 0.5 %! 0.5 1.0 ]; %! %! B = [ 0.0 -1.0 %! 1.0 0.0 ]; %! %! C = [ -1.0 0.0 %! 0.0 1.0 ]; %! %! D = [ 1.0 0.0 %! 0.0 -1.0 ]; %! %! [Ao, Bo, Co, Do] = ssdata (d2c (c2d (ss (A, B, C, D), 2, "zoh"), "zoh")); %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [A, B; C, D]; %! %!assert (Mo, Me, 1e-4); ## first-order hold ## user function %!shared Mo, Me %! A = [ 1.0 0.5 %! 0.5 1.0 ]; %! %! B = [ 0.0 -1.0 %! 1.0 0.0 ]; %! %! C = [ -1.0 0.0 %! 0.0 1.0 ]; %! %! D = [ 1.0 0.0 %! 0.0 -1.0 ]; %! %! [Ao, Bo, Co, Do] = ssdata (c2d (ss (A, B, C, D), 2, "foh")); %! %! Ae = [ 11.4019 8.6836 %! 8.6836 11.4019 ]; %! %! Be = [ 37.5206 -43.4256 %! 43.4256 -37.5206 ]; %! %! Ce = [ -1.0000 0.0000 %! 0.0000 1.0000 ]; %! %! De = [ -0.0690 2.5056 %! 2.5056 -2.0690 ]; %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [Ae, Be; Ce, De]; %! %!assert (Mo, Me, 1e-4); ## bilinear transformation with pre-warping ## both directions %!shared Mo, Me %! A = [ 1.0 0.5 %! 0.5 1.0 ]; %! %! B = [ 0.0 -1.0 %! 1.0 0.0 ]; %! %! C = [ -1.0 0.0 %! 0.0 1.0 ]; %! %! D = [ 1.0 0.0 %! 0.0 -1.0 ]; %! %! [Ao, Bo, Co, Do] = ssdata (d2c (c2d (ss (A, B, C, D), 2, "prewarp", 1000), "prewarp", 1000)); %! %! Mo = [Ao, Bo; Co, Do]; %! Me = [A, B; C, D]; %! %!assert (Mo, Me, 1e-4); ## matrix exponential %!shared Aex, Aexint, Aex_exp, Aexint_exp %! A = [ 5.0 4.0 3.0 2.0 1.0 %! 1.0 6.0 0.0 4.0 3.0 %! 2.0 0.0 7.0 6.0 5.0 %! 1.0 3.0 1.0 8.0 7.0 %! 2.0 5.0 7.0 1.0 9.0 ]; %! %! Aex_exp = [ 1.8391 0.9476 0.7920 0.8216 0.7811 %! 0.3359 2.2262 0.4013 1.0078 1.0957 %! 0.6335 0.6776 2.6933 1.6155 1.8502 %! 0.4804 1.1561 0.9110 2.7461 2.0854 %! 0.7105 1.4244 1.8835 1.0966 3.4134 ]; %! %! Aexint_exp = [ 0.1347 0.0352 0.0284 0.0272 0.0231 %! 0.0114 0.1477 0.0104 0.0369 0.0368 %! 0.0218 0.0178 0.1624 0.0580 0.0619 %! 0.0152 0.0385 0.0267 0.1660 0.0732 %! 0.0240 0.0503 0.0679 0.0317 0.1863 ]; %! %! [Aex, Aexint] = __sl_mb05nd__ (A, 0.1, 0.0001); %! %!assert (Aex, Aex_exp, 1e-4); %!assert (Aexint, Aexint_exp, 1e-4); control-4.1.2/inst/@lti/PaxHeaders/issiso.m0000644000000000000000000000007415012430645015615 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/issiso.m0000644000175000017500000000216215012430645017005 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{bool} =} issiso (@var{sys}) ## Determine whether @acronym{LTI} model is single-input/single-output (SISO). ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function bool = issiso (sys) if (nargin != 1) print_usage (); endif bool = all (size (sys) == 1); endfunction control-4.1.2/inst/@lti/PaxHeaders/dcgain.m0000644000000000000000000000007415012430645015531 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/dcgain.m0000644000175000017500000000435615012430645016730 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{k} =} dcgain (@var{sys}) ## Compute the DC gain of @acronym{LTI} system. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system created by tf(), ss(), dss(), etc. ## @end table ## ## @strong{Outputs} ## @table @var ## @item k ## DC gain matrix. For a system with m inputs and p outputs, the array @var{k} ## has dimensions [p, m]. ## @end table ## ## Transfer function for a continuous state space system (A,B,C,D) ## G(s) = C * inv(s*I - A) * B + D ## ## DC Gain: evaluate G(s) as s -> 0: ## k = C * inv(-A) * B + D ## ## Transfer function for a discrete state space system (A,B,C,D,T) ## G(z) = C * inv(z*I - A) * B + D ## ## DC Gain: evaluate G(z) as z -> 1: ## k = C * inv(I-A) * B + D ## ## @strong{Example} ## @example ## G = Transfer function 'G' from input 'u1' to output ... ## ## 1 ## y1: --------------------- ## s^3 + 2 s^2 + 3 s + 4 ## ## ## octave:1> K = dcgain(G) ## ## K = 0.25000 ## @end example ## ## @seealso{freqresp,tf,ss,dss} ## @end deftypefn ## Author: Lukas Reichlin ## Author: Geraint Paul Bevan ## Created: October 2009 ## Version: 0.1 function gain = dcgain (sys) if (nargin != 1) # sys is always an LTI model print_usage (); endif gain = __freqresp__ (sys, 0); endfunction %!assert( dcgain( tf(1,[1,1]) ) , 1 ) %!assert( dcgain( tf(2,[1,1]) ) , 2 ) %!assert( dcgain( ss([0,1;-2,-3],[0;1],[1,0],0) ) , 0.5 ) control-4.1.2/inst/@lti/PaxHeaders/lti.m0000644000000000000000000000007415012430645015074 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/lti.m0000644000175000017500000000274415012430645016272 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Constructor for LTI objects. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function ltisys = lti (p = 0, m = 0, tsam = -1) if (nargin != 3 || ! is_real_scalar (p, m, tsam)) error ("lti: constructor for 'lti' class, intended for internal use only"); endif inname = repmat ({""}, m, 1); outname = repmat ({""}, p, 1); ltisys = struct ("tsam", tsam, "inname", {inname}, "outname", {outname}, "ingroup", struct (), "outgroup", struct (), "name", "", "notes", {{}}, "userdata", []); ltisys = class (ltisys, "lti"); endfunction control-4.1.2/inst/@lti/PaxHeaders/size.m0000644000000000000000000000007415012430645015256 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/size.m0000644000175000017500000000474515012430645016457 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{nvec} =} size (@var{sys}) ## @deftypefnx {Function File} {@var{n} =} size (@var{sys}, @var{dim}) ## @deftypefnx {Function File} {[@var{p}, @var{m}] =} size (@var{sys}) ## @acronym{LTI} model size, i.e. number of outputs and inputs. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. ## @item dim ## If given a second argument, @command{size} will return the size of the ## corresponding dimension. ## @end table ## ## @strong{Outputs} ## @table @var ## @item nvec ## Row vector. The first element is the number of outputs (rows) and the second ## element the number of inputs (columns). ## @item n ## Scalar value. The size of the dimension @var{dim}. ## @item p ## Number of outputs. ## @item m ## Number of inputs. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function [n, varargout] = size (sys, dim = 0) if (nargin > 2) print_usage (); endif p = numel (sys.outname); # WARNING: system matrices may change without m = numel (sys.inname); # being noticed by the i/o names! switch (dim) case 0 switch (nargout) case 0 if (p == 1) stry = ""; else stry = "s"; endif if (m == 1) stru = ""; else stru = "s"; endif disp (sprintf ("LTI model with %d output%s and %d input%s.", p, stry, m, stru)); case 1 n = [p, m]; case 2 n = p; varargout{1} = m; otherwise print_usage (); endswitch case 1 n = p; case 2 n = m; otherwise print_usage (); endswitch endfunction control-4.1.2/inst/@lti/PaxHeaders/dssdata.m0000644000000000000000000000007415012430645015727 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/dssdata.m0000644000175000017500000000473515012430645017127 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{a}, @var{b}, @var{c}, @var{d}, @var{e}, @var{tsam}] =} dssdata (@var{sys}) ## @deftypefnx {Function File} {[@var{a}, @var{b}, @var{c}, @var{d}, @var{e}, @var{tsam}] =} dssdata (@var{sys}, @var{[]}) ## Access descriptor state-space model data. ## Argument @var{sys} is not limited to descriptor state-space models. ## If @var{sys} is not a descriptor state-space model, it is converted automatically. ## ## @strong{Inputs} ## @table @var ## @item sys ## Any type of @acronym{LTI} model. ## @item [] ## In case @var{sys} is not a dss model (descriptor matrix @var{e} empty), ## @code{dssdata (sys, [])} returns the empty element @code{e = []} whereas ## @code{dssdata (sys)} returns the identity matrix @code{e = eye (size (a))}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item a ## State matrix (n-by-n). ## @item b ## Input matrix (n-by-m). ## @item c ## Measurement matrix (p-by-n). ## @item d ## Feedthrough matrix (p-by-m). ## @item e ## Descriptor matrix (n-by-n). ## @item tsam ## Sampling time in seconds. If @var{sys} is a continuous-time model, ## a zero is returned. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2010 ## Version: 0.2 function [a, b, c, d, e, tsam, scaled] = dssdata (sys, flg = 0) ## NOTE: In case sys is not a dss model (matrice e empty), ## dssdata (sys, []) returns e = [] whereas ## dssdata (sys) returns e = eye (size (a)) if (nargin > 2) print_usage (); endif if (! isa (sys, "ss")) sys = ss (sys); endif [a, b, c, d, e, ~, scaled] = __sys_data__ (sys); if (isempty (e) && ! isempty (flg)) e = eye (size (a)); # return eye for ss models endif tsam = sys.tsam; endfunction control-4.1.2/inst/@lti/PaxHeaders/__numeric_to_lti__.m0000644000000000000000000000007415012430645020114 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/__numeric_to_lti__.m0000644000175000017500000000331315012430645021303 0ustar00lilgelilge00000000000000## Copyright (C) 2023 Torsten Lilge ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Chcking two systems that have to be connected if they ## possibly are only numerical values and have to be turned ## into proper lti systems. ## For internal use only. ## Author: Torsten Lilge ## Created: July 2023 ## Version: 0.1 function [sys1, sys2] = __numeric_to_lti__ (sys1, sys2) sys = {sys1, sys2}; for i = 1:2 if (! isa (sys{i}, "lti")) if (! isa (sys{i}, "numeric")) error ("lti: mtimes/mplus: one system is neither an lti system nor a numeric value"); else sys{i} = tf (sys{i}); endif endif endfor sys1 = sys{1}; sys2 = sys{2}; % If one of the two systems is only a static gain, just take the % sampling time of the other system if (isstaticgain(sys1) && (get(sys1,'tsam') == 0) && (get(sys2,'tsam') > 0)) sys1 = c2d (sys1, get(sys2,'tsam')); elseif (isstaticgain(sys2) && (get(sys2,'tsam') == 0) && (get(sys1,'tsam') > 0)) sys2 = c2d (sys2, get(sys1,'tsam')); endif endfunction control-4.1.2/inst/@lti/PaxHeaders/__lti_prune__.m0000644000000000000000000000007415012430645017101 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/__lti_prune__.m0000644000175000017500000000524515012430645020276 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Submodel extraction and reordering for LTI objects. ## This file is part of the Model Abstraction Layer. ## For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function [lti, out_idx, in_idx] = __lti_prune__ (lti, out_idx, in_idx) if (ischar (out_idx) && ! strcmp (out_idx, ":")) # sys("grp", :) out_idx = {out_idx}; endif if (ischar (in_idx) && ! strcmp (in_idx, ":")) # sys(:, "grp") in_idx = {in_idx}; endif if (iscell (out_idx)) # sys({"grp1", "grp2"}, :) tmp = cellfun (@(x) __str2idx__ (lti.outgroup, lti.outname, x, "out"), out_idx, "uniformoutput", false); out_idx = vertcat (tmp{:}); endif if (iscell (in_idx)) # sys(:, {"grp1", "grp2"}) tmp = cellfun (@(x) __str2idx__ (lti.ingroup, lti.inname, x, "in"), in_idx, "uniformoutput", false); in_idx = vertcat (tmp{:}); endif if (numfields (lti.outgroup)) p = numel (lti.outname); # get size before pruning outnames! [lti.outgroup, empty] = structfun (@(x) __group_prune__ (x, out_idx, p), lti.outgroup, "uniformoutput", false); empty = cell2mat (struct2cell (empty)); fields = fieldnames (lti.outgroup); lti.outgroup = rmfield (lti.outgroup, fields(empty)); endif if (numfields (lti.ingroup)) m = numel (lti.inname); [lti.ingroup, empty] = structfun (@(x) __group_prune__ (x, in_idx, m), lti.ingroup, "uniformoutput", false); empty = cell2mat (struct2cell (empty)); fields = fieldnames (lti.ingroup); lti.ingroup = rmfield (lti.ingroup, fields(empty)); endif lti.outname = lti.outname(out_idx); lti.inname = lti.inname(in_idx); endfunction function [group, empty] = __group_prune__ (group, idx, n) lg = length (group); group = sparse (group, 1:lg, 1, n, lg); group = group(idx, :); [group, ~] = find (group); empty = isempty (group); endfunction control-4.1.2/inst/@lti/PaxHeaders/mpower.m0000644000000000000000000000007415012430645015615 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/mpower.m0000644000175000017500000000422715012430645017011 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{SYSP} = } inv (@var{SYS}, @var{E}) ## Matrix power of @acronym{LTI} objects. The exponent must be an integer. ## Used by Octave for "sys^int". ## ## @strong{Inputs} ## @table @var ## @item SYS ## System for which the power by exponent @var{E} has to be calculated. ## @item E ## Exponent (integer). ## @end table ## ## @strong{Outputs} ## @table @var ## @item SYSP ## Resulting power of @var{SYS} by @var{E}. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.2 function retsys = mpower (sys, e) if (nargin != 2) # prevent sys = mpower (a, b, c, ...) error ("lti: mpower: this is a binary operator"); endif if (! is_real_scalar (e) || e != round (e)) error ("lti: mpower: exponent must be an integer"); endif [p, m] = size (sys); if (p != m) error ("lti: mpower: system must be square"); endif mimo_tf = (p*m > 1) && isa (sys, "tf"); if (mimo_tf) sys = ss (sys); endif ex = round (abs (e)); # make sure ex is a positive integer switch (sign (e)) case -1 # lti^-ex sys = inv (sys); retsys = sys; case 0 # lti^0 retsys = eye (p); return; case 1 # lti^ex retsys = sys; endswitch for k = 2 : ex retsys = retsys * sys; endfor if (mimo_tf) retsys = tf (retsys); endif endfunction control-4.1.2/inst/@lti/PaxHeaders/feedback.m0000644000000000000000000000007415012430645016030 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/feedback.m0000644000175000017500000002027315012430645017223 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} feedback (@var{sys1}) ## @deftypefnx {Function File} {@var{sys} =} feedback (@var{sys1}, @var{"+"}) ## @deftypefnx {Function File} {@var{sys} =} feedback (@var{sys1}, @var{sys2}) ## @deftypefnx {Function File} {@var{sys} =} feedback (@var{sys1}, @var{sys2}, @var{"+"}) ## @deftypefnx {Function File} {@var{sys} =} feedback (@var{sys1}, @var{sys2}, @var{feedin}, @var{feedout}) ## @deftypefnx {Function File} {@var{sys} =} feedback (@var{sys1}, @var{sys2}, @var{feedin}, @var{feedout}, @var{"+"}) ## Feedback connection of two @acronym{LTI} models. ## ## @strong{Inputs} ## @table @var ## @item sys1 ## @acronym{LTI} model of forward transmission. @code{[p1, m1] = size (sys1)}. ## @item sys2 ## @acronym{LTI} model of backward transmission. ## If not specified, an identity matrix of appropriate size is taken. ## @item feedin ## Vector containing indices of inputs to @var{sys1} which are involved in the feedback loop. ## The number of @var{feedin} indices and outputs of @var{sys2} must be equal. ## If not specified, @code{1:m1} is taken. ## @item feedout ## Vector containing indices of outputs from @var{sys1} which are to be connected to @var{sys2}. ## The number of @var{feedout} indices and inputs of @var{sys2} must be equal. ## If not specified, @code{1:p1} is taken. ## @item "+" ## Positive feedback sign. If not specified, @var{"-"} for a negative feedback interconnection ## is assumed. @var{+1} and @var{-1} are possible as well, but only from the third argument ## onward due to ambiguity. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Resulting @acronym{LTI} model. ## @end table ## ## @strong{Block Diagram} ## @example ## @group ## u + +--------+ y ## ------>(+)----->| sys1 |-------+-------> ## ^ - +--------+ | ## | | ## | +--------+ | ## +-------| sys2 |<------+ ## +--------+ ## @end group ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.7 function sys = feedback (sys1, sys2, feedin, feedout, fbsign = -1) [p1, m1] = size (sys1); switch (nargin) case 1 # sys = feedback (sys) if (p1 != m1) error ("feedback: argument must be a square system"); endif sys2 = eye (p1); feedin = 1 : m1; feedout = 1 : p1; case 2 if (ischar (sys2)) # sys = feedback (sys, "+") if (p1 != m1) error ("feedback: first argument must be a square system"); endif fbsign = __check_fbsign__ (sys2); sys2 = eye (p1); endif # sys = feedback (sys1, sys2) feedin = 1 : m1; feedout = 1 : p1; case 3 # sys = feedback (sys1, sys2, "+") fbsign = __check_fbsign__ (feedin); feedin = 1 : m1; feedout = 1 : p1; case 4 # sys = feedback (sys1, sys2, feedin, feedout) ## nothing needs to be done here ## case 4 required to prevent "otherwise" case 5 # sys = feedback (sys1, sys2, feedin, feedout, "+") fbsign = __check_fbsign__ (fbsign); otherwise print_usage (); endswitch if (ischar (feedin)) feedin = {feedin}; endif if (ischar (feedout)) feedout = {feedout}; endif if (iscell (feedin)) tmp = cellfun (@(x) __str2idx__ (sys1.ingroup, sys1.inname, x, "in"), feedin, "uniformoutput", false); feedin = vertcat (tmp{:}); endif if (iscell (feedout)) tmp = cellfun (@(x) __str2idx__ (sys1.outgroup, sys1.outname, x, "out"), feedout, "uniformoutput", false); feedout = vertcat (tmp{:}); endif if (! is_real_vector (feedin) || ! isequal (feedin, abs (fix (feedin)))) error ("feedback: require 'feedin' to be a vector of integers"); endif if (! is_real_vector (feedout) || ! isequal (feedout, abs (fix (feedout)))) error ("feedback: require 'feedout' to be a vector of integers"); endif [p2, m2] = size (sys2); l_feedin = length (feedin); l_feedout = length (feedout); if (l_feedin != p2) error ("feedback: feedin indices: %d, outputs sys2: %d", l_feedin, p2); endif if (l_feedout != m2) error ("feedback: feedout indices: %d, inputs sys2: %d", l_feedout, m2); endif if (any (feedin > m1 | feedin < 1)) error ("feedback: range of feedin indices exceeds dimensions of sys1"); endif if (any (feedout > p1 | feedout < 1)) error ("feedback: range of feedout indices exceeds dimensions of sys1"); endif M11 = zeros (m1, p1); M22 = zeros (m2, p2); M12 = full (sparse (feedin, 1:l_feedin, fbsign, m1, p2)); M21 = full (sparse (1:l_feedout, feedout, 1, m2, p1)); ## NOTE: for-loops do NOT the same as ## M12(feedin, 1:l_feedin) = fbsign; ## M21(1:l_feedout, feedout) = 1; ## ## M12 = zeros (m1, p2); ## M21 = zeros (m2, p1); ## ## for k = 1 : l_feedin ## M12(feedin(k), k) = fbsign; ## endfor ## ## for k = 1 : l_feedout ## M21(k, feedout(k)) = 1; ## endfor M = [M11, M12; M21, M22]; in_idx = 1 : m1; out_idx = 1 : p1; sys = __sys_group__ (sys1, sys2); sys = __sys_connect__ (sys, M); sys = __sys_prune__ (sys, out_idx, in_idx); endfunction function fbsign = __check_fbsign__ (fbsign) if (is_real_scalar (fbsign)) fbsign = sign (fbsign); elseif (ischar (fbsign)) if (strcmp (fbsign, "+")) fbsign = +1; elseif (strcmp (fbsign, "-")) fbsign = -1; else error ("feedback: invalid feedback sign string"); endif else error ("feedback: invalid feedback sign type"); endif endfunction ## Feedback inter-connection of two systems in state-space form ## Test from SLICOT AB05ND %!shared M, Me %! A1 = [ 1.0 0.0 -1.0 %! 0.0 -1.0 1.0 %! 1.0 1.0 2.0 ]; %! %! B1 = [ 1.0 1.0 0.0 %! 2.0 0.0 1.0 ].'; %! %! C1 = [ 3.0 -2.0 1.0 %! 0.0 1.0 0.0 ]; %! %! D1 = [ 1.0 0.0 %! 0.0 1.0 ]; %! %! A2 = [-3.0 0.0 0.0 %! 1.0 0.0 1.0 %! 0.0 -1.0 2.0 ]; %! %! B2 = [ 0.0 -1.0 0.0 %! 1.0 0.0 2.0 ].'; %! %! C2 = [ 1.0 1.0 0.0 %! 1.0 1.0 -1.0 ]; %! %! D2 = [ 1.0 1.0 %! 0.0 1.0 ]; %! %! sys1 = ss (A1, B1, C1, D1); %! sys2 = ss (A2, B2, C2, D2); %! sys = feedback (sys1, sys2); %! [A, B, C, D] = ssdata (sys); %! M = [A, B; C, D]; %! %! Ae = [-0.5000 -0.2500 -1.5000 -1.2500 -1.2500 0.7500 %! -1.5000 -0.2500 0.5000 -0.2500 -0.2500 -0.2500 %! 1.0000 0.5000 2.0000 -0.5000 -0.5000 0.5000 %! 0.0000 0.5000 0.0000 -3.5000 -0.5000 0.5000 %! -1.5000 1.2500 -0.5000 1.2500 0.2500 1.2500 %! 0.0000 1.0000 0.0000 -1.0000 -2.0000 3.0000 ]; %! %! Be = [ 0.5000 0.7500 %! 0.5000 -0.2500 %! 0.0000 0.5000 %! 0.0000 0.5000 %! -0.5000 0.2500 %! 0.0000 1.0000 ]; %! %! Ce = [ 1.5000 -1.2500 0.5000 -0.2500 -0.2500 -0.2500 %! 0.0000 0.5000 0.0000 -0.5000 -0.5000 0.5000 ]; %! %! De = [ 0.5000 -0.2500 %! 0.0000 0.5000 ]; %! %! Me = [Ae, Be; Ce, De]; %! %!assert (M, Me, 1e-4); ## sensitivity function %!shared S1, S2 %! P = ss (-2, 3, 4, 5); # meaningless numbers %! C = ss (-1, 1, 1, 0); # ditto %! L = P * C; %! I = eye (size (L)); %! S1 = feedback (I, L); %! S2 = inv (I + L); %!assert (S1.a, S2.a, 1e-4); %!assert (S1.b, S2.b, 1e-4); %!assert (S1.c, S2.c, 1e-4); %!assert (S1.d, S2.d, 1e-4); control-4.1.2/inst/@lti/PaxHeaders/eig.m0000644000000000000000000000007415012430645015050 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/eig.m0000644000175000017500000000201715012430645016237 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{p} =} eig (@var{sys}) ## Compute poles of @acronym{LTI} system. ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.1 function pol = eig (varargin) pol = pole (varargin{:}); endfunction control-4.1.2/inst/@lti/PaxHeaders/filtdata.m0000644000000000000000000000007415012430645016074 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/filtdata.m0000644000175000017500000000621315012430645017265 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{num}, @var{den}, @var{tsam}] =} filtdata (@var{sys}) ## @deftypefnx {Function File} {[@var{num}, @var{den}, @var{tsam}] =} filtdata (@var{sys}, @var{"vector"}) ## Access discrete-time transfer function data in DSP format. ## Argument @var{sys} is not limited to transfer function models. ## If @var{sys} is not a transfer function, it is converted automatically. ## ## @strong{Inputs} ## @table @var ## @item sys ## Any type of discrete-time @acronym{LTI} model. ## @item "v", "vector" ## For SISO models, return @var{num} and @var{den} directly as column vectors ## instead of cells containing a single column vector. ## @end table ## ## @strong{Outputs} ## @table @var ## @item num ## Cell of numerator(s). Each numerator is a row vector ## containing the coefficients of the polynomial in ascending powers of z^-1. ## num@{i,j@} contains the numerator polynomial from input j to output i. ## In the SISO case, a single vector is possible as well. ## @item den ## Cell of denominator(s). Each denominator is a row vector ## containing the coefficients of the polynomial in ascending powers of z^-1. ## den@{i,j@} contains the denominator polynomial from input j to output i. ## In the SISO case, a single vector is possible as well. ## @item tsam ## Sampling time in seconds. If @var{tsam} is not specified, -1 is returned. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: April 2012 ## Version: 0.1 function [num, den, tsam] = filtdata (sys, rtype = "cell") if (nargin > 2) print_usage (); endif if (! isdt (sys)) error ("lti: filtdata: require discrete-time system"); endif [num, den, tsam] = tfdata (sys); ## make numerator and denominator polynomials equally long ## by adding leading zeros lnum = cellfun (@length, num, "uniformoutput", false); lden = cellfun (@length, den, "uniformoutput", false); lmax = cellfun (@max, lnum, lden, "uniformoutput", false); num = cellfun (@prepad, num, lmax, "uniformoutput", false); den = cellfun (@prepad, den, lmax, "uniformoutput", false); ## remove trailing zeros ## such that polynomials are as short as possible num = cellfun (@__remove_trailing_zeros__, num, "uniformoutput", false); den = cellfun (@__remove_trailing_zeros__, den, "uniformoutput", false); if (strncmpi (rtype, "v", 1) && issiso (sys)) num = num{1}; den = den{1}; endif endfunction control-4.1.2/inst/@lti/PaxHeaders/__lti_keys__.m0000644000000000000000000000007415012430645016723 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/__lti_keys__.m0000644000175000017500000000367715012430645020127 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{keys}, @var{vals}] =} __lti_keys__ (@var{sys}) ## Return the list of keys as well as the assignable values for an LTI object sys. ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.3 function [keys, vals] = __lti_keys__ (sys, aliases = false, subclasses = true) ## cell vector of lti-specific keys keys = {"tsam"; "inname"; "outname"; "ingroup"; "outgroup"; "name"; "notes"; "userdata"}; ## cell vector of lti-specific assignable values vals = {"scalar (sample time in seconds)"; "m-by-1 cell vector of strings"; "p-by-1 cell vector of strings"; "struct with indices as fields"; "struct with indices as fields"; "string"; "string or cell of strings"; "any data type"}; if (aliases) ka = {"inputname"; "outputname"; "inputgroup"; "outputgroup"; "lti"}; keys = [keys; ka]; endif if (subclasses) [syskeys, sysvals] = __sys_keys__ (sys, aliases); keys = [syskeys; keys]; vals = [sysvals; vals]; endif endfunction control-4.1.2/inst/@lti/PaxHeaders/lft.m0000644000000000000000000000007415012430645015071 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/lft.m0000644000175000017500000001132115012430645016256 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} lft (@var{sys1}, @var{sys2}) ## @deftypefnx {Function File} {@var{sys} =} lft (@var{sys1}, @var{sys2}, @var{nu}, @var{ny}) ## Linear fractional tranformation, also known as Redheffer star product. ## ## @strong{Inputs} ## @table @var ## @item sys1 ## Upper @acronym{LTI} model. ## @item sys2 ## Lower @acronym{LTI} model. ## @item nu ## The last nu inputs of @var{sys1} are connected with the first nu outputs of @var{sys2}. ## If not specified, @code{min (m1, p2)} is taken. ## @item ny ## The last ny outputs of @var{sys1} are connected with the first ny inputs of @var{sys2}. ## If not specified, @code{min (p1, m2)} is taken. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Resulting @acronym{LTI} model. ## @end table ## ## @strong{Block Diagram} ## @example ## @group ## .............sys.............. ## : +--------+ : ## w1 ------------>| |------------> z1 ## : | sys1 | : ## : u +---->| |-----+ y : ## : | +--------+ | : Lower LFT ## : | | : ## : | +--------+ | : lft (sys1, sys2) ## : +-----| sys2 |<----+ : ## : +--------+ : ## :............................: ## @end group ## @end example ## @example ## @group ## .............sys.............. ## : +--------+ : ## : u +---->| sys1 |-----+ y : ## : | +--------+ | : Upper LFT ## : | | : ## : | +--------+ | : lft (sys1, sys2) ## : +-----| |<----+ : ## : | sys2 | : ## z2 <------------| |<------------ w2 ## : +--------+ : ## :............................: ## @end group ## @end example ## @example ## @group ## .............sys.............. ## : +--------+ : ## w1 ------------>| |------------> z1 ## : | sys1 | : ## : u +---->| |-----+ y : ## : | +--------+ | : ## : | | : lft (sys1, sys2, nu, ny) ## : | +--------+ | : ## : +-----| |<----+ : ## : | sys2 | : ## z2 <------------| |<------------ w2 ## : +--------+ : ## :............................: ## @end group ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.2 function sys = lft (sys1, sys2, nu, ny) if (nargin != 2 && nargin != 4) print_usage (); endif ## object conversion done by sys_group if necessary [p1, m1] = size (sys1); [p2, m2] = size (sys2); nu_max = min (m1, p2); ny_max = min (m2, p1); if (nargin == 2) # sys = lft (sys1, sys2) nu = nu_max; ny = ny_max; else # sys = lft (sys1, sys2, nu, ny) if (! is_real_scalar (nu) || nu < 0) error ("lft: argument 'nu' must be a positive integer"); endif if (! is_real_scalar (ny) || ny < 0) error ("lft: argument 'ny' must be a positive integer"); endif if (nu > nu_max) error ("lft: argument 'nu' (%d) must be at most %d", nu, nu_max); endif if (ny > ny_max) error ("lft: argument 'ny' (%d) must be at most %d", ny, ny_max); endif endif M11 = zeros (m1, p1); M12 = [zeros(m1-nu, p2); eye(nu), zeros(nu, p2-nu)]; M21 = [zeros(ny, p1-ny), eye(ny); zeros(m2-ny, p1)]; M22 = zeros (m2, p2); M = [M11, M12; M21, M22]; in_idx = [1 : (m1-nu), m1 + (ny+1 : m2)]; out_idx = [1 : (p1-ny), p1 + (nu+1 : p2)]; sys = __sys_group__ (sys1, sys2); sys = __sys_connect__ (sys, M); sys = __sys_prune__ (sys, out_idx, in_idx); [p, m] = size (sys); if (m == 0) warning ("lft: resulting system has no inputs\n"); endif if (p == 0) warning ("lft: resulting system has no outputs\n"); endif endfunction control-4.1.2/inst/@lti/PaxHeaders/isdt.m0000644000000000000000000000007415012430645015247 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/isdt.m0000644000175000017500000000277215012430645016446 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{bool} =} isdt (@var{sys}) ## Determine whether @acronym{LTI} model is a discrete-time system. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. ## @end table ## ## @strong{Outputs} ## @table @var ## @item bool = 0 ## @var{sys} is a continuous-time system. ## @item bool = 1 ## @var{sys} is a discrete-time system or a static gain. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function bool = isdt (ltisys) if (nargin != 1) print_usage (); endif # Treat static gains (tsam = -2) as ct systems since there is # no more information on its sampling time bool = ((ltisys.tsam != 0) && (ltisys.tsam != -2)); endfunction control-4.1.2/inst/@lti/PaxHeaders/uminus.m0000644000000000000000000000007415012430645015624 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/uminus.m0000644000175000017500000000231415012430645017013 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} uminus ## Unary minus of @acronym{LTI} object. Used by Octave for "-sys". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function sys = uminus (sys) if (nargin != 1) # prevent sys = uminus (sys1, sys2, sys3, ...) error ("lti: uminus: this is an unary operator"); endif [p, m] = size (sys); out_scl = - eye (p); sys = out_scl * sys; endfunction control-4.1.2/inst/@lti/PaxHeaders/end.m0000644000000000000000000000007415012430645015052 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/end.m0000644000175000017500000000243115012430645016241 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} end ## End indexing for @acronym{LTI} objects. ## Used by Octave for "sys(1:end, end-1)". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: December 2013 ## Version: 0.1 function ret = end (sys, k, n) if (n != 2) error ("lti: end: require 2 indices in the expression"); endif [p, m] = size (sys); switch (k) case 1 ret = p; case 2 ret = m; otherwise error ("lti: end: invalid expression index k = %d", k); endswitch endfunction control-4.1.2/inst/@lti/PaxHeaders/display.m0000644000000000000000000000007415012430645015751 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/display.m0000644000175000017500000000312615012430645017142 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Display routine for LTI objects. Called by its child classes. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.3 function display (sys) if (numfields (sys.ingroup) > 0) __disp_group__ (sys.ingroup, "Input"); endif if (numfields (sys.outgroup) > 0) __disp_group__ (sys.outgroup, "Output"); endif if (! isempty (sys.name)) disp (["Name: ", sys.name]); endif if (sys.tsam > 0) disp (sprintf ("Sampling time: %g s", sys.tsam)); elseif (sys.tsam == -1) disp ("Sampling time: unspecified"); endif endfunction function __disp_group__ (group, io) name = fieldnames (group); idx = struct2cell (group); cellfun (@(name, idx) printf ("%s group '%s' = %s\n", io, name, mat2str (idx(:).')), ... name, idx, "uniformoutput", false); endfunction control-4.1.2/inst/@lti/PaxHeaders/minus.m0000644000000000000000000000007415012430645015437 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/minus.m0000644000175000017500000000303215012430645016624 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} minus ## Binary subtraction of @acronym{LTI} objects. If necessary, object conversion ## is done by sys_group. Used by Octave for "sys1 - sys2". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function sys = minus (sys1, sys2) if (nargin != 2) # prevent sys = minus (sys1, sys2, sys3, ...) error ("lti: minus: this is a binary operator"); endif [p1, m1] = size (sys1); [p2, m2] = size (sys2); if (p1 != p2 || m1 != m2) error ("lti: minus: system dimensions incompatible: (%dx%d) - (%dx%d)", p1, m1, p2, m2); endif sys = __sys_group__ (sys1, sys2); in_scl = [eye(m1); eye(m2)]; out_scl = [eye(p1), -eye(p2)]; sys = out_scl * sys * in_scl; endfunction control-4.1.2/inst/@lti/PaxHeaders/series.m0000644000000000000000000000007415012430645015576 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/series.m0000644000175000017500000000672115012430645016773 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} series (@var{sys1}, @var{sys2}) ## @deftypefnx {Function File} {@var{sys} =} series (@var{sys1}, @var{sys2}, @var{outputs1}, @var{inputs2}) ## Series connection of two @acronym{LTI} models. ## ## @strong{Block Diagram} ## @example ## @group ## ..................................... ## u : +--------+ y1 u2 +--------+ : y ## ------>| sys1 |---------->| sys2 |-------> ## : +--------+ +--------+ : ## :................sys................. ## ## sys = series (sys1, sys2) ## @end group ## @end example ## @example ## @group ## ..................................... ## : v2 +--------+ : ## : ---------->| | : y ## : +--------+ y1 u2 | sys2 |-------> ## u : | |---------->| | : ## ------>| sys1 | z1 +--------+ : ## : | |----------> : ## : +--------+ : ## :................sys................. ## ## outputs1 = [1] ## inputs2 = [2] ## sys = series (sys1, sys2, outputs1, inputs2) ## @end group ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.3 function sys = series (sys1, sys2, out1, in2) if (nargin == 2) sys = sys2 * sys1; elseif (nargin == 4) [p1, m1] = size (sys1); [p2, m2] = size (sys2); if (! is_real_vector (out1)) error ("series: argument 3 (outputs1) invalid"); endif if (! is_real_vector (in2)) error ("series: argument 4 (inputs2) invalid"); endif l_out1 = length (out1); l_in2 = length (in2); if (l_out1 > p1) error ("series: 'outputs1' has too many indices for 'sys1'"); endif if (l_in2 > m2) error ("series: 'inputs2' has too many indices for 'sys2'"); endif if (l_out1 != l_in2) error ("series: number of 'outputs1' and 'inputs2' indices must be equal"); endif if (any (out1 > p1 | out1 < 1)) error ("series: range of 'outputs1' indices exceeds dimensions of 'sys1'"); endif if (any (in2 > m2 | in2 < 1)) error ("series: range of 'inputs2' indices exceeds dimensions of 'sys2'"); endif out_scl = full (sparse (1:l_out1, out1, 1, l_out1, p1)); in_scl = full (sparse (in2, 1:l_in2, 1, m2, l_in2)); ## NOTE: for-loop does NOT the same as ## out_scl(1:l_out1, out1) = 1; ## in_scl(in2, 1:l_out1) = 1; ## ## out_scl = zeros (l_out1, p1); ## in_scl = zeros (m2, l_in2); ## ## for k = 1 : l_out1 ## out_scl(k, out1(k)) = 1; ## in_scl(in2(k), k) = 1; ## endfor scl = in_scl * out_scl; sys = sys2 * scl * sys1; else print_usage (); endif endfunction control-4.1.2/inst/@lti/PaxHeaders/tfdata.m0000644000000000000000000000007415012430645015547 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/tfdata.m0000644000175000017500000000554315012430645016745 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{num}, @var{den}, @var{tsam}] =} tfdata (@var{sys}) ## @deftypefnx {Function File} {[@var{num}, @var{den}, @var{tsam}] =} tfdata (@var{sys}, @var{"vector"}) ## @deftypefnx {Function File} {[@var{num}, @var{den}, @var{tsam}] =} tfdata (@var{sys}, @var{"tfpoly"}) ## Access transfer function data. ## Argument @var{sys} is not limited to transfer function models. ## If @var{sys} is not a transfer function, it is converted automatically. ## ## @strong{Inputs} ## @table @var ## @item sys ## Any type of @acronym{LTI} model. ## @item "v", "vector" ## For SISO models, return @var{num} and @var{den} directly as column vectors ## instead of cells containing a single column vector. ## @end table ## ## @strong{Outputs} ## @table @var ## @item num ## Cell of numerator(s). Each numerator is a row vector ## containing the coefficients of the polynomial in descending powers of ## the transfer function variable. ## num@{i,j@} contains the numerator polynomial from input j to output i. ## In the SISO case, a single vector is possible as well. ## @item den ## Cell of denominator(s). Each denominator is a row vector ## containing the coefficients of the polynomial in descending powers of ## the transfer function variable. ## den@{i,j@} contains the denominator polynomial from input j to output i. ## In the SISO case, a single vector is possible as well. ## @item tsam ## Sampling time in seconds. If @var{sys} is a continuous-time model, ## a zero is returned. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.5 function [num, den, tsam] = tfdata (sys, rtype = "cell") if (! isa (sys, "tf")) sys = tf (sys); endif [num, den] = __sys_data__ (sys); tsam = sys.tsam; if (! strncmpi (rtype, "t", 1)) # != tfpoly [num, den] = __make_tf_polys_equally_long__ (tf (num,den)); num = cellfun (@get, num, "uniformoutput", false); den = cellfun (@get, den, "uniformoutput", false); endif if (strncmpi (rtype, "v", 1) && issiso (sys)) # == vector num = num{1}; den = den{1}; endif endfunction control-4.1.2/inst/@lti/PaxHeaders/parallel.m0000644000000000000000000000007415012430645016100 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/parallel.m0000644000175000017500000000321215012430645017265 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{sys} =} parallel (@var{sys1}, @var{sys2}) ## Parallel connection of two @acronym{LTI} systems. ## ## @strong{Block Diagram} ## @example ## @group ## .......................... ## : +--------+ : ## : +-->| sys1 |---+ : ## u : | +--------+ | + : y ## -------+ O---------> ## : | +--------+ | + : ## : +-->| sys2 |---+ : ## : +--------+ : ## :.........sys............: ## ## sys = parallel (sys1, sys2) ## @end group ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function sys = parallel (sys1, sys2) if (nargin == 2) sys = sys1 + sys2; ## elseif (nargin == 6) ## TODO: implement "complicated" case sys = parallel (sys1, sys2, in1, in2, out1, out2) else print_usage (); endif endfunction control-4.1.2/inst/@lti/PaxHeaders/mldivide.m0000644000000000000000000000007415012430645016101 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/mldivide.m0000644000175000017500000000302015012430645017263 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} mldivide ## Matrix left division of @acronym{LTI} objects. If necessary, object conversion ## is done by sys_group in mtimes. Used by Octave for "sys1 \\ sys2". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.2 function sys = mldivide (sys1, sys2) if (nargin != 2) # prevent sys = mldivide (sys1, sys2, sys3, ...) error ("lti: mldivide: this is a binary operator"); endif sys1 = inv (sys1); # let octave decide which inv() it uses ## [p1, m1] = size (sys1); ## [p2, m2] = size (sys2); ## ## if (m1 != p2) ## error ("lti: mldivide: system dimensions incompatible: (%dx%d) \\ (%dx%d)", ## p1, m1, p2, m2); ## endif sys = sys1 * sys2; endfunction control-4.1.2/inst/@lti/PaxHeaders/plus.m0000644000000000000000000000007415012430645015267 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/plus.m0000644000175000017500000000607415012430645016465 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} plus ## Binary addition of @acronym{LTI} objects. If necessary, object conversion ## is done by sys_group. Used by Octave for "sys1 + sys2". ## Operation is also known as "parallel connection". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function sys = plus (sys1, sys2) if (nargin != 2) # prevent sys = plus (sys1, sys2, sys3, ...) error ("lti: plus: this is a binary operator"); endif [p1, m1] = size (sys1); [p2, m2] = size (sys2); if (p1 != p2 || m1 != m2) error ("lti: plus: system dimensions incompatible: (%dx%d) + (%dx%d)", p1, m1, p2, m2); endif sys = __sys_group__ (sys1, sys2); in_scl = [eye(m1); eye(m2)]; out_scl = [eye(p1), eye(p2)]; sys = out_scl * sys * in_scl; endfunction ## Parallel inter-connection of two systems in state-space form ## Test from SLICOT AB05PD %!shared M, Me %! A1 = [ 1.0 0.0 -1.0 %! 0.0 -1.0 1.0 %! 1.0 1.0 2.0 ]; %! %! B1 = [ 1.0 1.0 0.0 %! 2.0 0.0 1.0 ].'; %! %! C1 = [ 3.0 -2.0 1.0 %! 0.0 1.0 0.0 ]; %! %! D1 = [ 1.0 0.0 %! 0.0 1.0 ]; %! %! A2 = [-3.0 0.0 0.0 %! 1.0 0.0 1.0 %! 0.0 -1.0 2.0 ]; %! %! B2 = [ 0.0 -1.0 0.0 %! 1.0 0.0 2.0 ].'; %! %! C2 = [ 1.0 1.0 0.0 %! 1.0 1.0 -1.0 ]; %! %! D2 = [ 1.0 1.0 %! 0.0 1.0 ]; %! %! sys1 = ss (A1, B1, C1, D1); %! sys2 = ss (A2, B2, C2, D2); %! sys = sys1 + sys2; %! [A, B, C, D] = ssdata (sys); %! M = [A, B; C, D]; %! %! Ae = [ 1.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 %! 0.0000 -1.0000 1.0000 0.0000 0.0000 0.0000 %! 1.0000 1.0000 2.0000 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 -3.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 %! 0.0000 0.0000 0.0000 0.0000 -1.0000 2.0000 ]; %! %! Be = [ 1.0000 2.0000 %! 1.0000 0.0000 %! 0.0000 1.0000 %! 0.0000 1.0000 %! -1.0000 0.0000 %! 0.0000 2.0000 ]; %! %! Ce = [ 3.0000 -2.0000 1.0000 1.0000 1.0000 0.0000 %! 0.0000 1.0000 0.0000 1.0000 1.0000 -1.0000 ]; %! %! De = [ 2.0000 1.0000 %! 0.0000 2.0000 ]; %! %! Me = [Ae, Be; Ce, De]; %! %!assert (M, Me, 1e-4); control-4.1.2/inst/@lti/PaxHeaders/pole.m0000644000000000000000000000007415012430645015243 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/pole.m0000644000175000017500000001011415012430645016427 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{p} =} pole (@var{sys}) ## Compute poles of @acronym{LTI} system. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @end table ## ## @strong{Outputs} ## @table @var ## @item p ## Poles of @var{sys}. ## @end table ## ## @strong{Algorithm}@* ## For (descriptor) state-space models and system/state matrices, @command{pole} ## relies on Octave's @command{eig}. ## For @acronym{SISO} transfer functions, @command{pole} ## uses Octave's @command{roots}. ## @acronym{MIMO} transfer functions are converted to ## a @emph{minimal} state-space representation for the ## computation of the poles. ## ## @end deftypefn ## Author: Lukas Reichlin ## Contributor: Mark Bronsfeld ## Created: October 2009 ## Version: 0.2 function pol = pole (sys) if(nargin == 1) # pole(sys) if(!(isa(sys, "lti")) && issquare(sys)) pol = eig(sys); elseif(isa(sys, "lti")) pol = __pole__(sys); else error("pole: argument must be an LTI system"); endif else print_usage(); endif endfunction %!shared pol_exp, pol_obs %! A = [-1, 0, 0; %! 0, -2, 0; %! 0, 0, -3]; %! pol_exp = [-3; %! -2; %! -1]; %! pol_obs = pole (ss (A, ones (3, 1))); %! %!assert(pol_obs, pol_exp, 0); ## Poles of descriptor state-space model %!shared pol, pol_exp, infp, kronr, kronl, infp_exp, kronr_exp, kronl_exp %! A = [ 1 0 0 0 0 0 0 0 0 %! 0 1 0 0 0 0 0 0 0 %! 0 0 1 0 0 0 0 0 0 %! 0 0 0 1 0 0 0 0 0 %! 0 0 0 0 1 0 0 0 0 %! 0 0 0 0 0 1 0 0 0 %! 0 0 0 0 0 0 1 0 0 %! 0 0 0 0 0 0 0 1 0 %! 0 0 0 0 0 0 0 0 1 ]; %! %! E = [ 0 0 0 0 0 0 0 0 0 %! 1 0 0 0 0 0 0 0 0 %! 0 1 0 0 0 0 0 0 0 %! 0 0 0 0 0 0 0 0 0 %! 0 0 0 1 0 0 0 0 0 %! 0 0 0 0 1 0 0 0 0 %! 0 0 0 0 0 0 0 0 0 %! 0 0 0 0 0 0 1 0 0 %! 0 0 0 0 0 0 0 1 0 ]; %! %! B = [ -1 0 0 %! 0 0 0 %! 0 0 0 %! 0 -1 0 %! 0 0 0 %! 0 0 0 %! 0 0 -1 %! 0 0 0 %! 0 0 0 ]; %! %! C = [ 0 1 1 0 3 4 0 0 2 %! 0 1 0 0 4 0 0 2 0 %! 0 0 1 0 -1 4 0 -2 2 ]; %! %! D = [ 1 2 -2 %! 0 -1 -2 %! 0 0 0 ]; %! %! sys = dss (A, B, C, D, E, "scaled", true); %! [pol, ~, infp, kronr, kronl] = __sl_ag08bd__ (A, E, [], [], [], true); %! %! pol_exp = zeros (0,1); %! %! infp_exp = [0, 3]; %! kronr_exp = zeros (1,0); %! kronl_exp = zeros (1,0); %! %!assert (pol, pol_exp, 1e-4); %!assert (infp, infp_exp); %!assert (kronr, kronr_exp); %!assert (kronl, kronl_exp); control-4.1.2/inst/@lti/PaxHeaders/isminimumphase.m0000644000000000000000000000007415012430645017334 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/isminimumphase.m0000644000175000017500000000666715012430645020542 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{bool} =} isminimumphase (@var{sys}) ## @deftypefnx {Function File} {@var{bool} =} isminimumphase (@var{sys}, @var{tol}) ## Determine whether @acronym{LTI} system has asymptotically stable zero dynamics. ## According to the definition of Byrnes/Isidori [1], the zeros ## of a minimum-phase system must be strictly ## inside the left complex half-plane (continuous-time case) ## or inside the unit circle (discrete-time case). ## Note that the poles are not tested. ## ## M. Zeitz [2] discusses the inconsistent definitions of the minimum-phase property ## in a German paper. The abstract in English states the following [2]: ## ## Originally, the minimum phase property has been defined by H. W. Bode [3] ## in order to characterize the unique relationship between gain and phase of ## the frequency response. ## With regard to the design of digital filters, another definition of minimum ## phase is used and a filter is said to be minimum phase if both the filter ## and its inverse are asymptotically stable. ## Finally, systems with asymptotically stable zero dynamics are named as ## minimum phase by C. I. Byrnes and A. Isidori [1]. ## Due to the inconsistent definitions, avoiding the minimum phase property ## for control purposes is advocated and the well-established criteria of ## Hurwitz or Ljapunow to describe the stability of filters and zero dynamics ## are recommended. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. ## @item tol ## Optional tolerance. ## @var{tol} must be a real-valued, non-negative scalar. ## Default value is 0. ## @end table ## ## @strong{Outputs} ## @table @var ## @item bool ## True if the system is minimum-phase and false otherwise. ## @end table ## ## @example ## @group ## real (z) < -tol*(1 + abs (z)) continuous-time ## abs (z) < 1 - tol discrete-time ## @end group ## @end example ## ## @strong{References}@* ## [1] Byrnes, C.I. and Isidori, A. ## @cite{A Frequency Domain Philosophy for Nonlinear Systems}. ## IEEE Conf. Dec. Contr. 23, pp. 1569–1573, 1984. ## ## [2] Zeitz, M. ## @cite{Minimum phase – no relevant property of automatic control!}. ## at – Automatisierungstechnik. Volume 62, Issue 1, pp. 3–10, 2014. ## ## [3] Bode, H.W. ## @cite{Network Analysis and Feedback Amplifier Design}. ## D. Van Nostrand Company, pp. 312-318, 1945. ## pp. 341-351, 1992. ## @end deftypefn ## Author: Lukas Reichlin ## Created: January 2011 ## Version: 0.3 function bool = isminimumphase (sys, tol = 0) if (nargin > 2) print_usage (); endif z = zero (sys); ct = isct (sys); bool = __is_stable__ (z, ct, tol); endfunction %!assert (isminimumphase (tf (1, [1, 0])), true); control-4.1.2/inst/@lti/PaxHeaders/ssdata.m0000644000000000000000000000007415012430645015563 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/ssdata.m0000644000175000017500000000453415012430645016760 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{a}, @var{b}, @var{c}, @var{d}, @var{tsam}] =} ssdata (@var{sys}) ## Access state-space model data. ## Argument @var{sys} is not limited to state-space models. ## If @var{sys} is not a state-space model, it is converted automatically. ## ## @strong{Inputs} ## @table @var ## @item sys ## Any type of @acronym{LTI} model. ## @end table ## ## @strong{Outputs} ## @table @var ## @item a ## State matrix (n-by-n). ## @item b ## Input matrix (n-by-m). ## @item c ## Measurement matrix (p-by-n). ## @item d ## Feedthrough matrix (p-by-m). ## @item tsam ## Sampling time in seconds. If @var{sys} is a continuous-time model, ## a zero is returned. ## @end table ## ## @strong{Note on compatibility} ## ## If @var{sys} is given by an input-output description, like, e.g., ## a transfer function, the resulting state-space model has a ## different form than the one provided by Matlab, ## see @code{ss} for details. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.4 function [a, b, c, d, tsam, scaled] = ssdata (sys) if (! isa (sys, "ss")) sys = ss (sys); endif [a, b, c, d, e, ~, scaled] = __sys_data__ (sys); [a, b, c, d, e] = __dss2ss__ (a, b, c, d, e); tsam = sys.tsam; endfunction %!test %! systf = tf ({[1 2 3],[1 1 1]},{[1 2 1],[1 3 3 1]}); %! [A,B,C,D,tsam] = ssdata (systf); %! s = -6:1.2:6; %! Gss = zeros(length(s),2); %! Gtf = zeros(length(s),2); %! for j = 1:length(s) %! Gss(j,:) = C*inv(eye(3,3)*i*s(j)-A)*B + D; %! Gtf(j,:) = systf (s(j)); %! endfor %! assert (Gss, Gtf, 1e-6); %! assert (tsam, 0, 1e-6); control-4.1.2/inst/@lti/PaxHeaders/prescale.m0000644000000000000000000000007415012430645016102 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/prescale.m0000644000175000017500000002553315012430645017301 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{scaledsys}, @var{info}] =} prescale (@var{sys}) ## Scale state-space model. The scaled model @var{scaledsys} is equivalent to ## @var{sys}, but the state vector is scaled by diagonal transformation matrices ## in order to increase the accuracy of subsequent numerical computations. ## Frequency response commands perform automatic scaling unless model property ## @var{scaled} is set to @var{true}. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @end table ## ## @strong{Outputs} ## @table @var ## @item scaledsys ## Scaled state-space model. ## @item info ## Structure containing additional information. ## @item info.SL ## Left scaling factors. @code{Tl = diag (info.SL)}. ## @item info.SR ## Right scaling factors. @code{Tr = diag (info.SR)}. ## @end table ## ## @strong{Equations} ## @tex ## $$ E_s = T_l\,E\,T_r \\ ## A_s = T_l\,A\,T_r \\ ## B_s = T_l\,B \\ ## C_s = C\,T_r \\ ## D_s = D $$ ## @end tex ## @ifnottex ## @example ## @group ## Es = Tl * E * Tr ## As = Tl * A * Tr ## Bs = Tl * B ## Cs = C * Tr ## Ds = D ## @end group ## @end example ## @end ifnottex ## ## For proper state-space models, @var{Tl} and @var{Tr} are inverse of each other. ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT TB01ID and TG01AD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @end deftypefn ## Author: Lukas Reichlin ## Created: June 2011 ## Version: 0.2 function [retsys, varargout] = prescale (sys) if (nargin != 1) print_usage (); endif if (! isa (sys, "ss")) warning ("prescale: system not in state-space form\n"); sys = ss (sys); endif [retsys, lscale, rscale] = __prescale__ (sys); if (nargout > 1) varargout{1} = struct ("SL", lscale, "SR", rscale); endif endfunction ## Scaling of state-space models, direct access to TB01ID %!shared Ao, Bo, Co, SCALEo, MAXREDo, Ae, Be, Ce, SCALEe, MAXREDe %! A = [ 0.0 1.0000e+000 0.0 0.0 0.0 %! -1.5800e+006 -1.2570e+003 0.0 0.0 0.0 %! 3.5410e+014 0.0 -1.4340e+003 0.0 -5.3300e+011 %! 0.0 0.0 0.0 0.0 1.0000e+000 %! 0.0 0.0 0.0 -1.8630e+004 -1.4820e+000 ]; %! %! B = [ 0.0 0.0 %! 1.1030e+002 0.0 %! 0.0 0.0 %! 0.0 0.0 %! 0.0 8.3330e-003 ]; %! %! C = [ 1.0000e+000 0.0 0.0 0.0 0.0 %! 0.0 0.0 1.0000e+000 0.0 0.0 %! 0.0 0.0 0.0 1.0000e+000 0.0 %! 6.6640e-001 0.0 -6.2000e-013 0.0 0.0 %! 0.0 0.0 -1.0000e-003 1.8960e+006 1.5080e+002 ]; %! %! MAXRED = 0.0; %! %! [Ao, Bo, Co, MAXREDo, SCALEo] = __sl_tb01id__ (A, B, C, MAXRED); %! %! Ae = [ 0.0000000D+00 0.1000000D+05 0.0000000D+00 0.0000000D+00 0.0000000D+00 %! -0.1580000D+03 -0.1257000D+04 0.0000000D+00 0.0000000D+00 0.0000000D+00 %! 0.3541000D+05 0.0000000D+00 -0.1434000D+04 0.0000000D+00 -0.5330000D+03 %! 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D+03 %! 0.0000000D+00 0.0000000D+00 0.0000000D+00 -0.1863000D+03 -0.1482000D+01 ]; %! %! Be = [ 0.0000000D+00 0.0000000D+00 %! 0.1103000D+04 0.0000000D+00 %! 0.0000000D+00 0.0000000D+00 %! 0.0000000D+00 0.0000000D+00 %! 0.0000000D+00 0.8333000D+02 ]; %! %! Ce = [ 0.1000000D-04 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 %! 0.0000000D+00 0.0000000D+00 0.1000000D+06 0.0000000D+00 0.0000000D+00 %! 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D-05 0.0000000D+00 %! 0.6664000D-05 0.0000000D+00 -0.6200000D-07 0.0000000D+00 0.0000000D+00 %! 0.0000000D+00 0.0000000D+00 -0.1000000D+03 0.1896000D+01 0.1508000D-01 ]; %! %! SCALEe = [0.1000000D-04 0.1000000D+00 0.1000000D+06 0.1000000D-05 0.1000000D-03 ]; %! %! MAXREDe = 0.3488E+10; %! %!assert (Ao, Ae, 1e-4); %!assert (Bo, Be, 1e-4); %!assert (Co, Ce, 1e-4); %!assert (MAXREDo, MAXREDe, 1e6); %!assert (SCALEo, SCALEe.', 1e-4); ## Scaling of descriptor state-space models, direct access to TG01AD %!shared Ao, Eo, Bo, Co, LSCALEo, RSCALEo, Ae, Ee, Be, Ce, LSCALEe, RSCALEe %! A = [ -1 0 0 0.003 %! 0 0 0.1000 0.02 %! 100 10 0 0.4 %! 0 0 0 0.0]; %! %! E = [ 1 0.2 0 0.0 %! 0 1 0 0.01 %! 300 90 6 0.3 %! 0 0 20 0.0]; %! %! B = [ 10 0 %! 0 0 %! 0 1000 %! 10000 10000]; %! %! C = [ -0.1 0.0 0.001 0.0 %! 0.0 0.01 -0.001 0.0001]; %! %! TRESH = 0.0; %! %! [Ao, Eo, Bo, Co, LSCALEo, RSCALEo] = __sl_tg01ad__ (A, E, B, C, TRESH); %! %! Ae = [ -1.0000 0.0000 0.0000 0.3000 %! 0.0000 0.0000 1.0000 2.0000 %! 1.0000 0.1000 0.0000 0.4000 %! 0.0000 0.0000 0.0000 0.0000]; %! %! Ee = [ 1.0000 0.2000 0.0000 0.0000 %! 0.0000 1.0000 0.0000 1.0000 %! 3.0000 0.9000 0.6000 0.3000 %! 0.0000 0.0000 0.2000 0.0000 ]; %! %! Be = [100.0000 0.0000 %! 0.0000 0.0000 %! 0.0000 100.0000 %! 100.0000 100.0000 ]; %! %! Ce = [ -0.0100 0.0000 0.0010 0.0000 %! 0.0000 0.0010 -0.0010 0.0010]; %! %! LSCALEe = [ 10.0000 10.0000 0.1000 0.0100 ]; %! %! RSCALEe = [ 0.1000 0.1000 1.0000 10.0000 ]; %! %!assert (Ao, Ae, 1e-4); %!assert (Eo, Ee, 1e-4); %!assert (Bo, Be, 1e-4); %!assert (Co, Ce, 1e-4); %!assert (LSCALEo, LSCALEe.', 1e-4); %!assert (RSCALEo, RSCALEe.', 1e-4); ## Scaling of state-space models, user function %!shared Ao, Bo, Co, INFOo, Ae, Be, Ce, SCALEe %! A = [ 0.0 1.0000e+000 0.0 0.0 0.0 %! -1.5800e+006 -1.2570e+003 0.0 0.0 0.0 %! 3.5410e+014 0.0 -1.4340e+003 0.0 -5.3300e+011 %! 0.0 0.0 0.0 0.0 1.0000e+000 %! 0.0 0.0 0.0 -1.8630e+004 -1.4820e+000 ]; %! %! B = [ 0.0 0.0 %! 1.1030e+002 0.0 %! 0.0 0.0 %! 0.0 0.0 %! 0.0 8.3330e-003 ]; %! %! C = [ 1.0000e+000 0.0 0.0 0.0 0.0 %! 0.0 0.0 1.0000e+000 0.0 0.0 %! 0.0 0.0 0.0 1.0000e+000 0.0 %! 6.6640e-001 0.0 -6.2000e-013 0.0 0.0 %! 0.0 0.0 -1.0000e-003 1.8960e+006 1.5080e+002 ]; %! %! SYS = ss (A, B, C); %! %! [SYSo, INFOo] = prescale (SYS); %! %! [Ao, Bo, Co] = ssdata (SYSo); %! %! Ae = [ 0.0000000D+00 0.1000000D+05 0.0000000D+00 0.0000000D+00 0.0000000D+00 %! -0.1580000D+03 -0.1257000D+04 0.0000000D+00 0.0000000D+00 0.0000000D+00 %! 0.3541000D+05 0.0000000D+00 -0.1434000D+04 0.0000000D+00 -0.5330000D+03 %! 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D+03 %! 0.0000000D+00 0.0000000D+00 0.0000000D+00 -0.1863000D+03 -0.1482000D+01 ]; %! %! Be = [ 0.0000000D+00 0.0000000D+00 %! 0.1103000D+04 0.0000000D+00 %! 0.0000000D+00 0.0000000D+00 %! 0.0000000D+00 0.0000000D+00 %! 0.0000000D+00 0.8333000D+02 ]; %! %! Ce = [ 0.1000000D-04 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.0000000D+00 %! 0.0000000D+00 0.0000000D+00 0.1000000D+06 0.0000000D+00 0.0000000D+00 %! 0.0000000D+00 0.0000000D+00 0.0000000D+00 0.1000000D-05 0.0000000D+00 %! 0.6664000D-05 0.0000000D+00 -0.6200000D-07 0.0000000D+00 0.0000000D+00 %! 0.0000000D+00 0.0000000D+00 -0.1000000D+03 0.1896000D+01 0.1508000D-01 ]; %! %! SCALEe = [0.1000000D-04 0.1000000D+00 0.1000000D+06 0.1000000D-05 0.1000000D-03 ]; %! %!assert (Ao, Ae, 1e-4); %!assert (Bo, Be, 1e-4); %!assert (Co, Ce, 1e-4); %!assert (INFOo.SL.^-1, SCALEe.', 1e-4); %!assert (INFOo.SR, SCALEe.', 1e-4); ## Scaling of descriptor state-space models, user function %!shared Ao, Eo, Bo, Co, INFOo, Ae, Ee, Be, Ce, LSCALEe, RSCALEe %! A = [ -1 0 0 0.003 %! 0 0 0.1000 0.02 %! 100 10 0 0.4 %! 0 0 0 0.0]; %! %! E = [ 1 0.2 0 0.0 %! 0 1 0 0.01 %! 300 90 6 0.3 %! 0 0 20 0.0]; %! %! B = [ 10 0 %! 0 0 %! 0 1000 %! 10000 10000]; %! %! C = [ -0.1 0.0 0.001 0.0 %! 0.0 0.01 -0.001 0.0001]; %! %! SYS = dss (A, B, C, [], E); %! %! [SYSo, INFOo] = prescale (SYS); %! %! [Ao, Bo, Co, ~, Eo] = dssdata (SYSo); %! %! Ae = [ -1.0000 0.0000 0.0000 0.3000 %! 0.0000 0.0000 1.0000 2.0000 %! 1.0000 0.1000 0.0000 0.4000 %! 0.0000 0.0000 0.0000 0.0000]; %! %! Ee = [ 1.0000 0.2000 0.0000 0.0000 %! 0.0000 1.0000 0.0000 1.0000 %! 3.0000 0.9000 0.6000 0.3000 %! 0.0000 0.0000 0.2000 0.0000 ]; %! %! Be = [100.0000 0.0000 %! 0.0000 0.0000 %! 0.0000 100.0000 %! 100.0000 100.0000 ]; %! %! Ce = [ -0.0100 0.0000 0.0010 0.0000 %! 0.0000 0.0010 -0.0010 0.0010]; %! %! LSCALEe = [ 10.0000 10.0000 0.1000 0.0100 ]; %! %! RSCALEe = [ 0.1000 0.1000 1.0000 10.0000 ]; %! %!assert (Ao, Ae, 1e-4); %!assert (Eo, Ee, 1e-4); %!assert (Bo, Be, 1e-4); %!assert (Co, Ce, 1e-4); %!assert (INFOo.SL, LSCALEe.', 1e-4); %!assert (INFOo.SR, RSCALEe.', 1e-4);control-4.1.2/inst/@lti/PaxHeaders/horzcat.m0000644000000000000000000000007415012430645015756 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@lti/horzcat.m0000644000175000017500000000613615012430645017153 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} horzcat ## Horizontal concatenation of @acronym{LTI} objects. If necessary, object conversion ## is done by sys_group. Used by Octave for "[sys1, sys2]". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function sys = horzcat (sys, varargin) for k = 1 : (nargin-1) sys1 = sys; sys2 = varargin{k}; [p1, m1] = size (sys1); [p2, m2] = size (sys2); if (p1 != p2) error ("lti: horzcat: number of system outputs incompatible: [(%dx%d), (%dx%d)]", p1, m1, p2, m2); endif sys = __sys_group__ (sys1, sys2); out_scl = [eye(p1), eye(p2)]; sys = out_scl * sys; endfor endfunction ## Rowwise concatenation of two systems in state-space form ## Test from SLICOT AB05OD %!shared M, Me %! A1 = [ 1.0 0.0 -1.0 %! 0.0 -1.0 1.0 %! 1.0 1.0 2.0 ]; %! %! B1 = [ 1.0 1.0 0.0 %! 2.0 0.0 1.0 ].'; %! %! C1 = [ 3.0 -2.0 1.0 %! 0.0 1.0 0.0 ]; %! %! D1 = [ 1.0 0.0 %! 0.0 1.0 ]; %! %! A2 = [-3.0 0.0 0.0 %! 1.0 0.0 1.0 %! 0.0 -1.0 2.0 ]; %! %! B2 = [ 0.0 -1.0 0.0 %! 1.0 0.0 2.0 ].'; %! %! C2 = [ 1.0 1.0 0.0 %! 1.0 1.0 -1.0 ]; %! %! D2 = [ 1.0 1.0 %! 0.0 1.0 ]; %! %! sys1 = ss (A1, B1, C1, D1); %! sys2 = ss (A2, B2, C2, D2); %! sys = [sys1, sys2]; %! [A, B, C, D] = ssdata (sys); %! M = [A, B; C, D]; %! %! Ae = [ 1.0000 0.0000 -1.0000 0.0000 0.0000 0.0000 %! 0.0000 -1.0000 1.0000 0.0000 0.0000 0.0000 %! 1.0000 1.0000 2.0000 0.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 -3.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 1.0000 0.0000 1.0000 %! 0.0000 0.0000 0.0000 0.0000 -1.0000 2.0000 ]; %! %! Be = [ 1.0000 2.0000 0.0000 0.0000 %! 1.0000 0.0000 0.0000 0.0000 %! 0.0000 1.0000 0.0000 0.0000 %! 0.0000 0.0000 0.0000 1.0000 %! 0.0000 0.0000 -1.0000 0.0000 %! 0.0000 0.0000 0.0000 2.0000 ]; %! %! Ce = [ 3.0000 -2.0000 1.0000 1.0000 1.0000 0.0000 %! 0.0000 1.0000 0.0000 1.0000 1.0000 -1.0000 ]; %! %! De = [ 1.0000 0.0000 1.0000 1.0000 %! 0.0000 1.0000 0.0000 1.0000 ]; %! %! Me = [Ae, Be; Ce, De]; %! %!assert (M, Me, 1e-4); control-4.1.2/inst/PaxHeaders/__conred_check_feedback_sign__.m0000644000000000000000000000007415012430645021443 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__conred_check_feedback_sign__.m0000644000175000017500000000231715012430645022635 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## check the feedback sign. ## Author: Lukas Reichlin ## Created: December 2011 ## Version: 0.1 function negfb = __conred_check_feedback_sign__ (fbsign, key = "feedback") if (! ischar (fbsign)) error ("conred: key '%s' requires string value", key); endif switch (fbsign) case "+" negfb = false; case "-" negfb = true; otherwise error ("conred: key '%s' has an invalid value", key); endswitch endfunction control-4.1.2/inst/PaxHeaders/__modred_check_weight__.m0000644000000000000000000000007415012430645020166 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__modred_check_weight__.m0000644000175000017500000000265215012430645021362 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## check weightings for model reduction commands ## Author: Lukas Reichlin ## Created: November 2011 ## Version: 0.1 function [a, b, c, d, job] = __modred_check_weight__ (sys, dt, p = [], m = []) sys = ss (sys); # could be non-lti, therefore ssdata would fail if (dt != isdt (sys)) error ("modred: ct/dt"); # TODO: error message endif [pw, mw] = size (sys); if (! isempty (p) && mw != p) error ("modred: left weight requires %d inputs", p); endif if (! isempty (m) && pw != m) error ("modred: right weight requires %d outputs", m); endif [a, b, c, d] = ssdata (sys); job = 1; ## TODO: check system size endfunction control-4.1.2/inst/PaxHeaders/__modred_check_gram__.m0000644000000000000000000000007415012430645017625 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__modred_check_gram__.m0000644000175000017500000000235515012430645021021 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## check choice of frequency-weighted grammians. ## Author: Lukas Reichlin ## Created: December 2011 ## Version: 0.1 function job = __modred_check_gram__ (choice, key) if (! ischar (choice)) error ("modred: key '%s' requires string value", key); endif switch (tolower (choice (1))) case "s" # standard job = 0; case "e" # enhanced job = 1; otherwise error ("modred: key '%s' has an invalid value", key); endswitch endfunction control-4.1.2/inst/PaxHeaders/@ss0000644000000000000000000000007415012430645013706 xustar0030 atime=1747595720.873132883 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/0000755000175000017500000000000015012430645015152 5ustar00lilgelilge00000000000000control-4.1.2/inst/@ss/PaxHeaders/__sys_keys__.m0000644000000000000000000000007415012430645016606 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__sys_keys__.m0000644000175000017500000000334615012430645020003 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{keys}, @var{vals}] =} __sys_keys__ (@var{sys}) ## @deftypefnx {Function File} {[@var{keys}, @var{vals}] =} __sys_keys__ (@var{sys}, @var{aliases}) ## Return the list of keys as well as the assignable values for a ss object sys. ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.3 function [keys, vals] = __sys_keys__ (sys, aliases = false) ## cell vector of ss-specific keys keys = {"a"; "b"; "c"; "d"; "e"; "stname"; "scaled"}; ## cell vector of ss-specific assignable values vals = {"n-by-n matrix (n = number of states)"; "n-by-m matrix (m = number of inputs)"; "p-by-n matrix (p = number of outputs)"; "p-by-m matrix"; "n-by-n matrix"; "n-by-1 cell vector of strings"; "scalar logical value"}; if (aliases) ka = {"statename"}; keys = [keys; ka]; endif endfunction control-4.1.2/inst/@ss/PaxHeaders/__set__.m0000644000000000000000000000007415012430645015530 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__set__.m0000644000175000017500000000353715012430645016727 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Set or modify keys of SS objects. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function sys = __set__ (sys, key, val) switch (key) # {, } case "a" __ss_dim__ (val, sys.b, sys.c, sys.d); sys.a = val; case "b" __ss_dim__ (sys.a, val, sys.c, sys.d); sys.b = val; case "c" __ss_dim__ (sys.a, sys.b, val, sys.d); sys.c = val; case "d" __ss_dim__ (sys.a, sys.b, sys.c, val); sys.d = val; case "e" if (isempty (val)) sys.e = []; # avoid [](nx0) or [](0xn) else __ss_dim__ (sys.a, sys.b, sys.c, sys.d, val); sys.e = val; endif case {"stname", "statename"} n = rows (sys.a); sys.stname = __adjust_labels__ (val, n); case "scaled" if (islogical (val) && isscalar (val) || is_real_scalar (val)) sys.scaled = logical (val); else error ("ss: set: key 'scaled' must be a scalar logical"); endif otherwise error ("ss: set: invalid key name '%s'", key); endswitch endfunction control-4.1.2/inst/@ss/PaxHeaders/__c2d__.m0000644000000000000000000000007415012430645015405 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__c2d__.m0000644000175000017500000000724315012430645016602 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 Lukas F. Reichlin ## Copyright (C) Torsten Lilge ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Convert the continuous SS model into its discrete-time equivalent. ## Author: Lukas Reichlin ## Created: October 2009 function sys = __c2d__ (sys, tsam, method = "zoh", w0 = 0) switch (method(1)) case {"z", "s"} # {"zoh", "std"} [sys.a, sys.b, sys.c, sys.d, sys.e] = __dss2ss__ (sys.a, sys.b, sys.c, sys.d, sys.e); [sys.a, tmp] = __sl_mb05nd__ (sys.a, tsam, eps); sys.b = tmp * sys.b; # G case {"f"} # {"foh"} # http://people.duke.edu/~hpgavin/cee541/LTI.pdf page 33 [sys.a, sys.b, sys.c, sys.d, sys.e] = __dss2ss__ (sys.a, sys.b, sys.c, sys.d, sys.e); n = size (sys.a,1); m = size (sys.b,2); M = [ sys.a sys.b zeros(n,m);... zeros(m,n) zeros(m,m) eye(m,m);... zeros(m,n) zeros(m,m) zeros(m,m) ]; expM = __sl_mb05nd__ (M, tsam, eps); sys.a = expM(1:n,1:n); Bd = expM(1:n,n+1:n+m); Bdd = expM(1:n,n+m+1:end); Bd0 = Bd - Bdd/tsam; # input matrix for u(k) Bd1 = Bdd/tsam; # input matrix for u(k+1) sys.b = Bd0 + sys.a*Bd1; # input matrix for ss with new state z(k) = x(k) - Bd1*u(k) sys.d = sys.d + sys.c*Bd1; # throughput for ss with new state z sys = ss (sys.a, sys.b, sys.c, sys.d, tsam, 'userdata', Bd1); # store Bd1 in userdata case {"t", "b", "p"} # {"tustin", "bilin", "prewarp"} if (method(1) == "p") # prewarping beta = w0 / tan (w0*tsam/2); else beta = 2/tsam; endif if (isempty (sys.e)) [sys.a, sys.b, sys.c, sys.d] = __sl_ab04md__ (sys.a, sys.b, sys.c, sys.d, 1, beta, false); else [sys.a, sys.b, sys.c, sys.d, sys.e] = __dss_bilin__ (sys.a, sys.b, sys.c, sys.d, sys.e, beta, false); endif case "i" # "impulse" if (any (sys.d(:))) error ("c2d: impuls invariant discrete-time models only supported for systems without direct feedthrough\n"); endif ## cont-time: u(t) = delta(t) ## x(0) = Phi(0)*B = B (Phi(0) = 0) ## x(t) = Phi(t)*B ## y(0) = C*B ## y(t) = C*x(t) ## disc-time x(k+1) = Ad*x(k) + Bd*u(k) ## y(k) = Cd*x(k) + Dd*u(k) ## => Ad = Phi(T), Bd = Phi(T)*B*T, Cd = C, Dd = C*B*T [sys.a, sys.b, sys.c, sys.d, sys.e] = __dss2ss__ (sys.a, sys.b, sys.c, sys.d, sys.e); [sys.a, tmp] = __sl_mb05nd__ (sys.a, tsam, eps); sys.d = sys.c * sys.b * tsam; sys.b = sys.a * sys.b * tsam; case "m" # "matched" tmp = ss (c2d (zpk (sys), tsam, method)); sys.e = tmp.e; sys.a = tmp.a; sys.b = tmp.b; sys.c = tmp.c; sys.d = tmp.d; otherwise error ("ss: c2d: '%s' is an invalid or missing method", method); endswitch endfunction control-4.1.2/inst/@ss/PaxHeaders/ss.m0000644000000000000000000000007415012430645014566 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/ss.m0000644000175000017500000002130115012430645015752 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} ss (@var{sys}) ## @deftypefnx {Function File} {@var{sys} =} ss (@var{d}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} ss (@var{a}, @var{b}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} ss (@var{a}, @var{b}, @var{c}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} ss (@var{a}, @var{b}, @var{c}, @var{d}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} ss (@var{a}, @var{b}, @var{c}, @var{d}, @var{tsam}, @dots{}) ## Create or convert to state-space model. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model to be converted to state-space. ## @item a ## State matrix (n-by-n). ## @item b ## Input matrix (n-by-m). ## @item c ## Output matrix (p-by-n). ## If @var{c} is empty @code{[]} or not specified, an identity matrix is assumed. ## @item d ## Feedthrough matrix (p-by-m). ## If @var{d} is empty @code{[]} or not specified, a zero matrix is assumed. ## @item tsam ## Sampling time in seconds. If @var{tsam} is not specified, a continuous-time model is assumed. ## @item @dots{} ## Optional pairs of properties and values. ## Type @command{set (ss)} for more information. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## State-space model. ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'a', 'b', 'c', 'd', 'e' ## State-space matrices. See 'Inputs' for details. ## ## @item 'stname' ## The name of the states in @var{sys}. ## Cell vector containing strings for each state. ## Default names are @code{@{'x1', 'x2', ...@}} ## ## @item 'scaled' ## Logical. If set to true, no automatic scaling is used, ## e.g. for frequency response plots. ## ## @item 'tsam' ## Sampling time. See 'Inputs' for details. ## ## @item 'inname' ## The name of the input channels in @var{sys}. ## Cell vector of length m containing strings. ## Default names are @code{@{'u1', 'u2', ...@}} ## ## @item 'outname' ## The name of the output channels in @var{sys}. ## Cell vector of length p containing strings. ## Default names are @code{@{'y1', 'y2', ...@}} ## ## @item 'ingroup' ## Struct with input group names as field names and ## vectors of input indices as field values. ## Default is an empty struct. ## ## @item 'outgroup' ## Struct with output group names as field names and ## vectors of output indices as field values. ## Default is an empty struct. ## ## @item 'name' ## String containing the name of the model. ## ## @item 'notes' ## String or cell of string containing comments. ## ## @item 'userdata' ## Any data type. ## @end table ## ## @strong{Equations} ## @tex ## $$\dot{x} = A\,x + B\,u$$ ## $$y = C\,x + D\,u$$ ## @end tex ## @ifnottex ## @example ## . ## x = A x + B u ## y = C x + D u ## @end example ## @end ifnottex ## ## @strong{Example} ## @example ## @group ## octave:1> a = [1 2 3; 4 5 6; 7 8 9]; ## octave:2> b = [10; 11; 12]; ## octave:3> stname = @{'V', 'A', 'kJ'@}; ## octave:4> sys = ss (a, b, 'stname', stname) ## ## sys.a = ## V A kJ ## V 1 2 3 ## A 4 5 6 ## kJ 7 8 9 ## ## sys.b = ## u1 ## V 10 ## A 11 ## kJ 12 ## ## sys.c = ## V A kJ ## y1 1 0 0 ## y2 0 1 0 ## y3 0 0 1 ## ## sys.d = ## u1 ## y1 0 ## y2 0 ## y3 0 ## ## Continuous-time model. ## octave:5> ## @end group ## @end example ## ## @strong{Note on compatibility} ## ## If the state-space model @var{sys} is converted from a transfer ## function, the resulting state-space model can be transformed into ## the form computed by Matlab (a controllable canonical form with ## flipped state variables order) by using the following ## similarity transformation: ## ## @example ## @group ## n = size (sys.a, 1) ## QSi = inv (ctrb (sys)) ## T(n,:) = QSi(n,:) ## for i=n-1:-1:1, T(i,:) = T(i+1,:)*sys.a, endfor ## sys_ml = ss2ss (sys, T) ## @end group ## @end example ## ## @seealso{tf, dss} ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.4 function sys = ss (varargin) ## model precedence: frd > ss > zpk > tf > double ## inferiorto ("frd"); superiorto ("zpk", "tf", "double"); if (nargin == 1) # shortcut for lti objects if (isa (varargin{1}, "ss")) # already in ss form sys = ss (sssys) sys = varargin{1}; return; elseif (isa (varargin{1}, "lti")) # another lti object sys = ss (sys) [sys, lti] = __sys2ss__ (varargin{1}); sys.lti = lti; # preserve lti properties return; endif elseif (nargin == 2) # shortcut for lti objects plus if (ischar (varargin{2}) && isa (varargin{1}, "lti")) candidates = {"minimal", "explicit"}; key = __match_key__ (varargin{2}, candidates, "ss"); switch (key) case "minimal" # ss (sys, 'minimal') sys = minreal (ss (varargin{1})); return; case "explicit" # ss (sys, 'explicit') sys = dss2ss (ss (varargin{1})); return; otherwise # this would be a silly bug endswitch endif endif a = []; b = []; c = []; d = []; # default state-space matrices tsam = 0; # default sampling time [mat_idx, opt_idx, obj_flg] = __lti_input_idx__ (varargin); switch (numel (mat_idx)) case 1 d = varargin{mat_idx}; case 2 [a, b] = varargin{mat_idx}; case 3 [a, b, c] = varargin{mat_idx}; case 4 [a, b, c, d] = varargin{mat_idx}; case 5 [a, b, c, d, tsam] = varargin{mat_idx}; if (isempty (tsam) && is_real_matrix (tsam)) tsam = -1; elseif (! issample (tsam, -10)) error ("ss: invalid sampling time"); endif case 0 ## nothing to do here, just prevent case 'otherwise' otherwise print_usage (); endswitch varargin = varargin(opt_idx); if (obj_flg) varargin = horzcat ({"lti"}, varargin); endif [a, b, c, d, tsam] = __adjust_ss_data__ (a, b, c, d, tsam); [p, m, n] = __ss_dim__ (a, b, c, d); # determine number of outputs, inputs and states stname = repmat ({""}, n, 1); # cell with empty state names ssdata = struct ("a", a, "b", b, "c", c, "d", d, "e", [], "stname", {stname}, "scaled", false); # struct for ss-specific data ltisys = lti (p, m, tsam); # parent class for general lti data sys = class (ssdata, "ss", ltisys); # create ss object if (numel (varargin) > 0) # if there are any properties and values, ... sys = set (sys, varargin{:}); # use the general set function endif endfunction ## TODO: create a separate function @lti/dss2ss.m function G = dss2ss (G) [G.a, G.b, G.c, G.d, G.e] = __dss2ss__ (G.a, G.b, G.c, G.d, G.e); endfunction %!test %! # Test the example for the SLICOT function TD04AD %! den1x = [1.0 6.0 11.0 6.0]; %! den2x = [1.0 6.0 11.0 6.0]; %! num11 = [1.0 6.0 12.0 7.0]; %! num12 = [0.0 1.0 4.0 3.0]; %! num21 = [0.0 0.0 1.0 1.0]; %! num22 = [1.0 8.0 20.0 15.0]; %! G = tf ( {num11, num12 ; num21, num22} , {den1x, den1x ; den2x, den2x} ); %! [A,B,C,D] = ssdata (ss (G)); %! %! Ae = [ 0.499999999999998 -0.802831617715081 0.938714854383612 ; %! 4.404724821517878 -2.338041431261778 2.507602188919887 ; %! -5.554133527986547 1.687202056051516 -4.161958568738229 ]; %! Be = [-0.200000000000000 -1.250000000000000 ; %! 0 -0.609718066426859 ; %! 0.000000000000000 2.221653411194620 ]; %! Ce = [ 0 -0.867926073205492 0.211918650529080 ; %! 0 0 0.900230427447532 ]; %! De = [ 1 0 ; %! 0 1 ]; %! %! # State space representations have different structures, therefore %! # compare the Markov parameters instead %! M = zeros (2,20); %! Me = zeros (2,20); %! for i = 0:9, M(:,2*i+1:2*i+2) = C*A^i*B; Me(:,2*i+1:2*i+2) = Ce*Ae^i*Be; end; %! %! assert (M, Me, 1e-6); control-4.1.2/inst/@ss/PaxHeaders/__d2c__.m0000644000000000000000000000007415012430645015405 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__d2c__.m0000644000175000017500000000426015012430645016576 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Convert the discrete SS model into its continuous-time equivalent. ## Author: Lukas Reichlin ## Created: September 2011 ## Version: 0.3 function sys = __d2c__ (sys, tsam, method = "zoh", w0 = 0) switch (method(1)) case {"z", "s"} # {"zoh", "std"} [sys.a, sys.b, sys.c, sys.d, sys.e] = __dss2ss__ (sys.a, sys.b, sys.c, sys.d, sys.e); [n, m] = size (sys.b); # n: states, m: inputs tmp = logm ([sys.a, sys.b; zeros(m,n), eye(m)]) / tsam; if (norm (imag (tmp), inf) > sqrt (eps)) warning ("ss: d2c: possibly inaccurate results\n"); endif sys.a = real (tmp(1:n, 1:n)); sys.b = real (tmp(1:n, n+1:n+m)); case {"t", "b", "p"} # {"tustin", "bilin", "prewarp"} if (method(1) == "p") # prewarping beta = w0 / tan (w0*tsam/2); else beta = 2/tsam; endif if (isempty (sys.e)) [sys.a, sys.b, sys.c, sys.d] = __sl_ab04md__ (sys.a, sys.b, sys.c, sys.d, 1, beta, true); else [sys.a, sys.b, sys.c, sys.d, sys.e] = __dss_bilin__ (sys.a, sys.b, sys.c, sys.d, sys.e, beta, true); endif case "m" # "matched" tmp = ss (d2c (zpk (sys), method)); sys.e = tmp.e; sys.a = tmp.a; sys.b = tmp.b; sys.c = tmp.c; sys.d = tmp.d; otherwise error ("ss: d2c: '%s' is an invalid or missing method", method); endswitch endfunction control-4.1.2/inst/@ss/PaxHeaders/__sys2tf__.m0000644000000000000000000000007415012430645016167 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__sys2tf__.m0000644000175000017500000000505115012430645017357 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## SS to TF conversion. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.7 function [retsys, retlti] = __sys2tf__ (sys) sg_flag = false; # static gain flag try [a, b, c, d, tsam, scaled] = ssdata (sys); # system could be a descriptor model if (isstaticgain (sys)) # static gain sg_flag = true; else [num, den] = __sl_tb04bd__ (a, b, c, d, scaled); endif catch if (strcmp (lasterror.identifier, "dss:improper")) ## sys is non-realizable, therefore ssdata failed. if (issiso (sys)) [num, den] = __siso_ss2tf__ (sys); else [p, m] = size (sys); num = cell (p, m); den = cell (p, m); for i = 1 : p for j = 1 : m idx = substruct ("()", {i, j}); tmp = subsref (sys, idx); # extract siso model tmp = sminreal (tmp); # sminreal is more suitable than minreal here [n, d] = __siso_ss2tf__ (tmp); num(i, j) = n; den(i, j) = d; endfor endfor endif tsam = get (sys, "tsam"); else ## something else happened rethrow (lasterror); endif end_try_catch if (sg_flag) retsys = tf (d); else retsys = tf (num, den, tsam); # tsam needed to set appropriate tfvar endif retlti = sys.lti; # preserve lti properties endfunction function [num, den] = __siso_ss2tf__ (sys) if (isempty (sys.a)) # static gain num = sys.d; den = 1; else # default case [zer, gain] = zero (sys); pol = pole (sys); num = gain * real (poly (zer)); den = real (poly (pol)); endif endfunction control-4.1.2/inst/@ss/PaxHeaders/isstaticgain.m0000644000000000000000000000007415012430645016623 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/isstaticgain.m0000644000175000017500000000253015012430645020012 0ustar00lilgelilge00000000000000## Copyright (C) 2022 Torsten Lilge ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{bool} =} isstaticgain (@var{sys}) ## Determine whether @acronym{LTI} model is a static gain. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. ## @end table ## ## @strong{Outputs} ## @table @var ## @item bool = 0 ## @var{sys} is a dynamical system ## @item bool = 1 ## @var{sys} is a static gain ## @end table ## @end deftypefn ## Author: Torsten Lilge ## Created: October 2022 ## Version: 0.1 function static_gain = isstaticgain (ltisys) if (nargin == 0) print_usage (); endif static_gain = isempty (ltisys.a); endfunction control-4.1.2/inst/@ss/PaxHeaders/__pole__.m0000644000000000000000000000007415012430645015674 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__pole__.m0000644000175000017500000000236515012430645017071 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Poles of SS object. ## Special thanks to Peter Benner for his advice. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function pol = __pole__ (sys) if (isempty (sys.e)) pol = eig (sys.a); else ## pol = eig (sys.a, sys.e); ## tol = norm ([sys.a, sys.e], 2); ## idx = find (abs (pol) < tol/eps); ## pol = pol(idx); ## do not scale, matrices B, C & D missing pol = __sl_ag08bd__ (sys.a, sys.e, [], [], [], true); endif endfunction control-4.1.2/inst/@ss/PaxHeaders/__sys2frd__.m0000644000000000000000000000007415012430645016331 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__sys2frd__.m0000644000175000017500000000220215012430645017514 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## SS to FRD conversion. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.1 function [retsys, retlti] = __sys2frd__ (sys, w = []) if (isempty (w)) # case sys = frd (sys) w = __frequency_vector__ (sys); endif H = freqresp (sys, w); retsys = frd (H, w); # tsam is set below retlti = sys.lti; # preserve lti properties endfunction control-4.1.2/inst/@ss/PaxHeaders/__sys_connect__.m0000644000000000000000000000007415012430645017264 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__sys_connect__.m0000644000175000017500000000731615012430645020462 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{retsys} =} __sys_connect__ (@var{sys}, @var{M}) ## This function is part of the Model Abstraction Layer. No argument checking. ## For internal use only. ## @example ## @group ## Problem: Solve the system equations of ## . ## E x(t) = A x(t) + B e(t) ## ## y(t) = C x(t) + D e(t) ## ## e(t) = u(t) + M y(t) ## ## in order to build ## . ## K x(t) = F x(t) + G u(t) ## ## y(t) = H x(t) + J u(t) ## ## Solution: Laplace Transformation ## E s X(s) = A X(s) + B U(s) + B M Y(s) [1] ## ## Y(s) = C X(s) + D U(s) + D M Y(s) [2] ## ## solve [2] for Y(s) ## Y(s) = [I - D M]^(-1) C X(s) + [I - D M]^(-1) D U(s) ## ## substitute Z = [I - D M]^(-1) ## Y(s) = Z C X(s) + Z D U(s) [3] ## ## insert [3] in [1], solve for X(s) ## X(s) = [s E - (A + B M Z C)]^(-1) (B + B M Z D) U(s) [4] ## ## inserting [4] in [3] finally yields ## Y(s) = Z C [s E - (A + B M Z C)]^(-1) (B + B M Z D) U(s) + Z D U(s) ## \ / | \_____ _____/ \_____ _____/ \ / ## H K F G J ## @end group ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.3 function sys = __sys_connect__ (sys, m) ## FIXME: error for nonsensical stuff like feedback (ss (1), ss (-1)) ## how to detect this? all-zero descriptor matrix? ! any (sys.e(:)) ## TODO: investigate whether all-zero sys.e make sense, ## before disabling them in a rash decision. a = sys.a; b = sys.b; c = sys.c; d = sys.d; z = eye (rows (d)) - d*m; if (rcond (z) >= eps) # check for singularity sys.a = a + b*m/z*c; # F sys.b = b + b*m/z*d; # G sys.c = z\c; # H sys.d = z\d; # J ## sys.e remains constant: [] for ss models, e for dss models else ## construct descriptor model ## try to introduce the least states [pp, mm] = size (d); n = rows (a); if (isempty (sys.e)) sys.e = eye (n); endif if (mm <= pp) ## Introduce state variable e = u + My ## . ## E x = A x + B e + 0 u ## . ## 0 e = MC x + (MD-I) e + I u ## ## y = C x + D e + 0 u ## sys.a = [a, b; m*c, m*d-eye(mm)]; sys.b = [zeros(n,mm); eye(mm)]; sys.c = [c, d]; sys.d = zeros (pp,mm); sys.e = blkdiag (sys.e, zeros (mm)); sys.stname = [sys.stname; repmat({""}, mm, 1)]; else ## Introduce state variable y ## . ## E x = A x + BM y + B u ## . ## 0 y = C x - Z y + D u ## ## y = 0 x + I y + 0 u ## sys.a = [a, b*m; c, -z]; sys.b = [b; d]; sys.c = [zeros(pp, n), eye(pp)]; sys.d = zeros (pp, mm); sys.e = blkdiag (sys.e, zeros (pp)); sys.stname = [sys.stname; repmat({""}, pp, 1)]; endif endif endfunction control-4.1.2/inst/@ss/PaxHeaders/__prescale__.m0000644000000000000000000000007415012430645016533 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__prescale__.m0000644000175000017500000000310015012430645017714 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Prescale state-space model. ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT TB01ID and TG01AD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## Author: Lukas Reichlin ## Created: June 2011 ## Version: 0.1 function [retsys, lscale, rscale] = __prescale__ (sys, optarg = 0.0) if (isempty (sys.e)) [a, b, c, ~, scale] = __sl_tb01id__ (sys.a, sys.b, sys.c, optarg); retsys = ss (a, b, c, sys.d); lscale = scale.^-1; rscale = scale; else [a, e, b, c, lscale, rscale] = __sl_tg01ad__ (sys.a, sys.e, sys.b, sys.c, optarg); retsys = dss (a, b, c, sys.d, e); endif retsys.scaled = true; retsys.lti = sys.lti; # retain i/o names and tsam endfunction control-4.1.2/inst/@ss/PaxHeaders/display.m0000644000000000000000000000007415012430645015606 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/display.m0000644000175000017500000000555715012430645017011 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {} display (@var{SYS}) ## Display routine for SS objects. ## ## @strong{Inputs} ## @table @var ## @item SYS ## System to be displayed. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function display (sys) sysname = inputname (1); [inname, outname, tsam] = __lti_data__ (sys.lti); stname = sys.stname; inname = __labels__ (inname, "u"); outname = __labels__ (outname, "y"); stname = __labels__ (stname, "x"); disp (""); if (! isempty (sys.e)) __disp_mat__ (sys.e, [sysname, ".e"], stname, stname); endif if (! isempty (sys.a)) __disp_mat__ (sys.a, [sysname, ".a"], stname, stname); __disp_mat__ (sys.b, [sysname, ".b"], stname, inname); __disp_mat__ (sys.c, [sysname, ".c"], outname, stname); endif __disp_mat__ (sys.d, [sysname, ".d"], outname, inname); display (sys.lti); # display sampling time if (isstaticgain (sys)) disp ("Static gain."); elseif (tsam == 0) disp ("Continuous-time model."); else disp ("Discrete-time model."); endif endfunction function __disp_mat__ (m, mname, rname, cname) MAX_LEN = 12; # max length of row name and column name [mrows, mcols] = size (m); row_name = strjust (strvcat (" ", rname), "left"); row_name = row_name(:, 1 : min (MAX_LEN, end)); row_name = horzcat (repmat (" ", mrows+1, 3), row_name); mat = cell (1, mcols); for k = 1 : mcols cname{k} = cname{k}(:, 1 : min (MAX_LEN, end)); acol = vertcat (cname(k), cellstr (deblank (num2str (m(:, k), 4)))); mat{k} = strjust (strvcat (acol{:}), "right"); endfor lcols = cellfun (@columns, mat); lcols_max = 2 + max (horzcat (lcols, 1)); for k = 1 : mcols mat{k} = horzcat (repmat (" ", mrows+1, lcols_max-lcols(k)), mat{k}); endfor tsize = terminal_size (); dispcols = max (1, floor ((tsize(2) - columns (row_name)) / lcols_max)); disprows = max (1, ceil (mcols / dispcols)); disp ([mname, " ="]); for k = 1 : disprows disp (horzcat (row_name, mat{1+(k-1)*dispcols : min (mcols, k*dispcols)})); disp (""); endfor endfunction control-4.1.2/inst/@ss/PaxHeaders/__ctranspose__.m0000644000000000000000000000007415012430645017116 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__ctranspose__.m0000644000175000017500000000273315012430645020312 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Conjugate transpose of SS models. ## Author: Lukas Reichlin ## Created: May 2012 ## Version: 0.1 function sys = __ctranspose__ (sys, ct) a = sys.a; b = sys.b; c = sys.c; d = sys.d; e = sys.e; if (ct) # continuous-time sys.a = -a.'; sys.b = -c.'; sys.c = b.'; sys.d = d.'; sys.e = e.'; sys.stname = repmat ({""}, rows (a), 1); else # discrete-time [n, m] = size (b); p = rows (c); if (isempty (e)) e = eye (n); endif sys.a = blkdiag (e.', eye (p)); sys.b = [zeros(n, p); -eye(p)]; sys.c = [b.', zeros(m, p)]; sys.d = d.'; sys.e = [a.', c.'; zeros(p, n+p)]; sys.stname = repmat ({""}, n+p, 1); endif endfunction control-4.1.2/inst/@ss/PaxHeaders/__minreal__.m0000644000000000000000000000007415012430645016364 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__minreal__.m0000644000175000017500000000354415012430645017561 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Minimal realization of SS models. The physical meaning of states is lost. ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT TB01PD and TG01JD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function retsys = __minreal__ (sys, tol) if (strcmpi (tol, "def")) tol = 0; elseif (tol > 1) error ("ss: minreal: require tol <= 1"); endif if (isempty (sys.e)) [a, b, c] = __sl_tb01pd__ (sys.a, sys.b, sys.c, tol, sys.scaled); if (rows (a) == rows (sys.a)) retsys = sys; else retsys = ss (a, b, c, sys.d); retsys.lti = sys.lti; # retain i/o names and tsam endif else [a, e, b, c] = __sl_tg01jd__ (sys.a, sys.e, sys.b, sys.c, tol, sys.scaled, 0, 0); if (rows (a) == rows (sys.a)) retsys = sys; else retsys = dss (a, b, c, sys.d, e); retsys.lti = sys.lti; # retain i/o names and tsam endif endif endfunction control-4.1.2/inst/@ss/PaxHeaders/ss2ss.m0000644000000000000000000000007415012430645015216 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/ss2ss.m0000644000175000017500000001053515012430645016411 0ustar00lilgelilge00000000000000## Copyright (C) 2017 Fabian Alexander Wilms ## ## This program is free software; you can redistribute it and/or modify it under ## the terms of the GNU General Public License as published by the Free Software ## Foundation; either version 3 of the License, or (at your option) any later ## version. ## ## This program is distributed in the hope that it will be useful, but WITHOUT ## ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ## FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more ## details. ## ## You should have received a copy of the GNU General Public License along with ## this program; if not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{SYS_T} =} ss2ss (@var{SYS}, @var{T}) ## @deftypefnx {Function File} {[@var{A_T} @var{B_T} @var{C_T} @var{D_T}] =} ss2ss (@var{A}, @var{B}, @var{C}, @var{D}, @var{T}) ## Applies the similarity transformation T to a state-space model ## ## Given the state space model ## @tex ## $$ \dot x = Ax + Bu $$ ## $$ y = Cx + Du $$ ## @end tex ## @ifnottex ## @example ## @group ## . ## x = Ax + Bu ## y = Cx + Du ## @end group ## @end example ## @end ifnottex ## ## and the transformation matrix T, which maps the state vector x to another ## coordinate system ## @tex ## $$ \bar{x} = Tx $$ ## @end tex ## @ifnottex ## @example ## @group ## _ ## x = Tx ## @end group ## @end example ## @end ifnottex ## ## the state-space model is transformed in a way that results in an equivalent ## state-space model which is based on the new state vector ## ## @tex ## $$ \dot{\bar{x}} = TAT^{-1}\bar{x} + TBu $$ ## $$ y = CT^{-1}\bar{x} + Du $$ ## @end tex ## @ifnottex ## @example ## @group ## . ## _ _ ## x = T A T^-1 x + T B u ## . _ ## y = C T^-1 x + D u ## @end group ## @end example ## @end ifnottex ## ## Please note: In the literature, T may be defined inversely: ## ## @tex ## $$ \bar{x} = T^{-1}x $$ ## @end tex ## @ifnottex ## @example ## @group ## _ -1 ## x = T x ## @end group ## @end example ## @end ifnottex ## References: ## ## Control System Design, page 484 by Goodwin, Graebe, Salgado, 2000 ## ## https://de.mathworks.com/help/control/ref/ss2ss.html ## ## Attention: T as defined by Matlab is the inverse of T as defined by ## Goodwin, Graebe, Salgado ## @end deftypefn ## Author: Fabian Alexander Wilms function [first_out, second_out, third_out, fourth_out] = ss2ss(first_in, second_in, third_in, fourth_in, fifth_in) if (nargin != 2 && nargin != 5) print_usage (); endif switch nargin case 2 [A,B,C,D] = ssdata(first_in); % Attention: T as defined by Matlab is the inverse of T as defined by % Goodwin, Graebe, Salgado T = inv(second_in); case 5; A = first_in; B = second_in; C = third_in; D = fourth_in; % see above T = inv(fifth_in); endswitch A_T = inv(T)*A*T; B_T = inv(T)*B; C_T = C*T; D_T = D; % make number of output variables depend on nargin switch nargin case 2 if nargout > 1 error('Too many output arguments') endif first_out = ss(A_T,B_T,C_T,D_T); case 5 if nargout > 4 error('Too many output arguments') endif first_out = A_T; second_out = B_T; third_out = C_T; fourth_out = D_T; endswitch endfunction %!test %! A = [1 2 3; 4 5 6; 7 8 9]; %! B = [1; 2; 3]; %! C = [-1 0 1]; %! D = 0; %! %! [T E] = eig(A); %! %! original_system = ss(A,B,C,D); %! transformed_system = ss2ss(original_system,T); %! assert(transformed_system.a, [0.5755 2.006 -0.8179; 6.684 13.62 -2.585; -4.476 -7.826 0.8073],e-14); %! assert(transformed_system.b, [-0.5789; -3.148; 1.631],e-14); %! assert(transformed_system.c, [0.8912 -0.2231 1.112],e-14); %! assert(transformed_system.d, 0); %! retransformed_system = ss2ss(transformed_system,inv(T)); %! assert(original_system.a,retransformed_system.a,e-14); %! assert(original_system.b,retransformed_system.b,e-14); %! assert(original_system.c,retransformed_system.c,e-14); %! assert(original_system.d,retransformed_system.d,e-14);control-4.1.2/inst/@ss/PaxHeaders/__sys_data__.m0000644000000000000000000000007415012430645016544 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__sys_data__.m0000644000175000017500000000207715012430645017741 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Used by ssdata instead of multiple get calls. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.3 function [a, b, c, d, e, stname, scaled] = __sys_data__ (sys) a = sys.a; b = sys.b; c = sys.c; d = sys.d; e = sys.e; stname = sys.stname; scaled = sys.scaled; endfunction control-4.1.2/inst/@ss/PaxHeaders/__transpose__.m0000644000000000000000000000007415012430645016753 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__transpose__.m0000644000175000017500000000213115012430645020137 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Transpose of SS models. ## Author: Lukas Reichlin ## Created: February 2010 ## Version: 0.2 function sys = __transpose__ (sys) a = sys.a; b = sys.b; c = sys.c; d = sys.d; e = sys.e; sys.stname = repmat ({""}, rows (a), 1); sys.a = a.'; sys.b = c.'; sys.c = b.'; sys.d = d.'; sys.e = e.'; endfunction control-4.1.2/inst/@ss/PaxHeaders/__sys_group__.m0000644000000000000000000000007415012430645016767 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__sys_group__.m0000644000175000017500000000400715012430645020157 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Block diagonal concatenation of two SS models. ## This file is part of the Model Abstraction Layer. ## For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function retsys = __sys_group__ (sys1, sys2) % If one system is just a numeric value, create a proper lti system [sys1, sys2] = __numeric_to_lti__ (sys1, sys2); if (! isa (sys1, "ss")) sys1 = ss (sys1); endif if (! isa (sys2, "ss")) sys2 = ss (sys2); endif retsys = ss (); retsys.lti = __lti_group__ (sys1.lti, sys2.lti); n1 = rows (sys1.a); n2 = rows (sys2.a); [p1, m1] = size (sys1.d); [p2, m2] = size (sys2.d); retsys.a = [sys1.a, zeros(n1,n2); zeros(n2,n1), sys2.a]; retsys.b = [sys1.b, zeros(n1,m2); zeros(n2,m1), sys2.b]; retsys.c = [sys1.c, zeros(p1,n2); zeros(p2,n1), sys2.c]; retsys.d = [sys1.d, zeros(p1,m2); zeros(p2,m1), sys2.d]; e1 = ! isempty (sys1.e); e2 = ! isempty (sys2.e); if (e1 || e2) if (e1 && e2) retsys.e = [sys1.e, zeros(n1,n2); zeros(n2,n1), sys2.e]; elseif (e1) retsys.e = [sys1.e, zeros(n1,n2); zeros(n2,n1), eye(n2)]; else retsys.e = [eye(n1), zeros(n1,n2); zeros(n2,n1), sys2.e]; endif endif retsys.stname = [sys1.stname; sys2.stname]; endfunction control-4.1.2/inst/@ss/PaxHeaders/__sys_prune__.m0000644000000000000000000000007415012430645016764 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__sys_prune__.m0000644000175000017500000000413115012430645020152 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Submodel extraction and reordering for SS objects. ## This file is part of the Model Abstraction Layer. ## For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.3 function sys = __sys_prune__ (sys, out_idx, in_idx, st_idx = ":") [sys.lti, out_idx, in_idx] = __lti_prune__ (sys.lti, out_idx, in_idx); if (ischar (st_idx) && ! strcmp (st_idx, ":")) st_idx = {st_idx}; endif if (iscell (st_idx)) st_idx = cellfun (@(x) __str2idx__ (sys.stname, x), st_idx); endif sys.a = sys.a(st_idx, st_idx); sys.b = sys.b(st_idx, in_idx); sys.c = sys.c(out_idx, st_idx); sys.d = sys.d(out_idx, in_idx); if (! isempty (sys.e)) sys.e = sys.e(st_idx, st_idx); endif sys.stname = sys.stname(st_idx); endfunction ## NOTE: This local '__str2idx__' function is different from ## the one defined in the file '__str2idx__.m'. Why? ## There are input and output groups, but no state groups. ## At least the 'dark side' does not have state groups. ## However, I do contemplate 'stgroup'. function idx = __str2idx__ (name, str) tmp = strcmp (name, str)(:); switch (nnz (tmp)) case 1 idx = find (tmp); case 0 error ("ss: state name '%s' not found", str); otherwise error ("ss: state name '%s' is ambiguous", str); endswitch endfunction control-4.1.2/inst/@ss/PaxHeaders/__zero__.m0000644000000000000000000000007415012430645015714 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__zero__.m0000644000175000017500000000332315012430645017104 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Invariant zeros of SS object. ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB08ND and AG08BD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function [zer, gain, info] = __zero__ (sys, argc) if (isempty (sys.e)) [zer, gain, rank, infz, kronr, kronl] = __sl_ab08nd__ (sys.a, sys.b, sys.c, sys.d, sys.scaled); else [zer, rank, infz, kronr, kronl] = __sl_ag08bd__ (sys.a, sys.e, sys.b, sys.c, sys.d, sys.scaled); if (argc > 1 && issiso (sys)) pol = pole (sys); gain = __sl_tg04bx__ (sys.a, sys.e, sys.b, sys.c, sys.d, ... real (pol), imag (pol), real (zer), imag (zer)); else gain = []; endif endif info = struct ("rank", rank, "infz", infz, "kronr", kronr, "kronl", kronl); endfunction control-4.1.2/inst/@ss/PaxHeaders/__sys_inverse__.m0000644000000000000000000000007415012430645017306 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__sys_inverse__.m0000644000175000017500000000312715012430645020500 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Inversion of SS models. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function sys = __sys_inverse__ (sys) a = sys.a; b = sys.b; c = sys.c; d = sys.d; e = sys.e; if (! isempty (e) || rcond (d) < eps) # dss or strictly proper ss n = rows (a); m = columns (b); # p = m (square system) if (isempty (e)) # avoid testing twice? e = eye (n); endif sys.a = [a, b; c, d]; sys.b = [zeros(n, m); -eye(m)]; sys.c = [zeros(m, n), eye(m)]; sys.d = zeros (m); sys.e = [e, zeros(n, m); zeros(m, n+m)]; sys.stname = [sys.stname; repmat({""}, m, 1)]; else # proper ss bid = b / d; sys.a = a - bid * c; sys.b = bid; sys.c = -d \ c; sys.d = inv (d); endif endfunction control-4.1.2/inst/@ss/PaxHeaders/__times__.m0000644000000000000000000000007415012430645016056 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__times__.m0000644000175000017500000000206215012430645017245 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Hadamard/Schur product of @acronym{SS} objects. ## Used by Octave for "sys1 .* sys2". ## Author: Lukas Reichlin ## Created: May 2014 ## Version: 0.1 function sys = __times__ (sys1, sys2) error ("ss: times: Hadamard/Schur product is only supported for transfer functions"); endfunction control-4.1.2/inst/@ss/PaxHeaders/__freqresp__.m0000644000000000000000000000007415012430645016564 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__freqresp__.m0000644000175000017500000000243415012430645017756 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Frequency response of SS models. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.6 function H = __freqresp__ (sys, w, cellflag = false) if (sys.scaled == false) sys = prescale (sys); endif [a, b, c, d, e, tsam] = dssdata (sys); if (isct (sys)) # continuous system s = i * w; else # discrete system s = exp (i * w * abs (tsam)); endif H = arrayfun (@(x) c/(x*e - a)*b + d, s, "uniformoutput", false); if (! cellflag) H = cat (3, H{:}); endif endfunction control-4.1.2/inst/@ss/PaxHeaders/__get__.m0000644000000000000000000000007415012430645015514 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@ss/__get__.m0000644000175000017500000000245115012430645016705 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Access key values of SS objects. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function val = __get__ (sys, key) switch (key) # {, } case "a" val = sys.a; case "b" val = sys.b; case "c" val = sys.c; case "d" val = sys.d; case "e" val = sys.e; case {"stname", "statename"} val = sys.stname; case "scaled" val = sys.scaled; otherwise error ("ss: get: invalid key name '%s'", key); endswitch endfunction control-4.1.2/inst/PaxHeaders/lyapchol.m0000644000000000000000000000007415012430645015227 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/lyapchol.m0000644000175000017500000001115515012430645016421 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{u} =} lyapchol (@var{a}, @var{b}) ## @deftypefnx{Function File} {@var{u} =} lyapchol (@var{a}, @var{b}, @var{e}) ## Compute Cholesky factor of continuous-time Lyapunov equations. ## ## @strong{Equations} ## @example ## @group ## A U' U + U' U A' + B B' = 0 (Lyapunov Equation) ## ## A U' U E' + E U' U A' + B B' = 0 (Generalized Lyapunov Equation) ## @end group ## @end example ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB03OD and SG03BD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @seealso{lyap, dlyap, dlyapchol} ## @end deftypefn ## Author: Lukas Reichlin ## Created: January 2010 ## Version: 0.2.1 function [u, scale] = lyapchol (a, b, e) switch (nargin) case 2 if (! is_real_square_matrix (a)) ## error ("lyapchol: a must be real and square"); error ("lyapchol: %s must be real and square", ... inputname (1)); endif if (! is_real_matrix (b)) ## error ("lyapchol: b must be real") error ("lyapchol: %s must be real", ... inputname (2)) endif if (rows (a) != rows (b)) ## error ("lyapchol: a and b must have the same number of rows"); error ("lyapchol: %s and %s must have the same number of rows", ... inputname (1), inputname (2)); endif [u, scale] = __sl_sb03od__ (a.', b.', false); ## NOTE: TRANS = 'T' not suitable because we need U' U, not U U' case 3 if (! is_real_square_matrix (a, e)) ## error ("lyapchol: a, e must be real and square"); error ("lyapchol: %s, %s must be real and square", ... inputname (1), inputname (3)); endif if (! is_real_matrix (b)) ## error ("lyapchol: b must be real"); error ("lyapchol: %s must be real", ... inputname (2)); endif if (rows (b) != rows (a) || rows (e) != rows (a)) ## error ("lyapchol: a, b, e must have the same number of rows"); error ("lyapchol: %s, %s, %s must have the same number of rows", ... inputname (1), inputname (2), inputname (3)); endif [u, scale] = __sl_sg03bd__ (a.', e.', b.', false); ## NOTE: TRANS = 'T' not suitable because we need U' U, not U U' otherwise print_usage (); endswitch if (scale < 1) warning ("lyapchol: solution scaled by %g to prevent overflow\n", scale); endif endfunction %!shared U, U_exp, X, X_exp %! %! A = [ -1.0 37.0 -12.0 -12.0 %! -1.0 -10.0 0.0 4.0 %! 2.0 -4.0 7.0 -6.0 %! 2.0 2.0 7.0 -9.0 ].'; %! %! B = [ 1.0 2.5 1.0 3.5 %! 0.0 1.0 0.0 1.0 %! -1.0 -2.5 -1.0 -1.5 %! 1.0 2.5 4.0 -5.5 %! -1.0 -2.5 -4.0 3.5 ].'; %! %! U = lyapchol (A, B); %! %! X = U.' * U; # use lyap at home! %! %! U_exp = [ 1.0000 0.0000 0.0000 0.0000 %! 3.0000 1.0000 0.0000 0.0000 %! 2.0000 -1.0000 1.0000 0.0000 %! -1.0000 1.0000 -2.0000 1.0000 ].'; %! %! X_exp = [ 1.0000 3.0000 2.0000 -1.0000 %! 3.0000 10.0000 5.0000 -2.0000 %! 2.0000 5.0000 6.0000 -5.0000 %! -1.0000 -2.0000 -5.0000 7.0000 ]; %! %!assert (U, U_exp, 1e-4); %!assert (X, X_exp, 1e-4); %!shared U, U_exp, X, X_exp %! %! A = [ -1.0 3.0 -4.0 %! 0.0 5.0 -2.0 %! -4.0 4.0 1.0 ].'; %! %! E = [ 2.0 1.0 3.0 %! 2.0 0.0 1.0 %! 4.0 5.0 1.0 ].'; %! %! B = [ 2.0 -1.0 7.0 ].'; %! %! U = lyapchol (A, B, E); %! %! U_exp = [ 1.6003 -0.4418 -0.1523 %! 0.0000 0.6795 -0.2499 %! 0.0000 0.0000 0.2041 ]; %! %!assert (U, U_exp, 1e-4); control-4.1.2/inst/PaxHeaders/Boeing707.m0000644000000000000000000000007415012430645015055 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/Boeing707.m0000644000175000017500000000443115012430645016246 0ustar00lilgelilge00000000000000## Copyright (C) 1997, 2000, 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} Boeing707 () ## Creates a linearized state-space model of a Boeing 707-321 aircraft ## at ## @tex ## \(v=80\,\frac{m}{s} (M = 0.26,\, G_{a0} = -3^{\circ},\, {\alpha}_0 = 4^{\circ},\, {\kappa}= 50^{\\circ}\)). ## @end tex ## @ifnottex ## @var{v}=80 m/s (@var{M} = 0.26, @var{Ga0} = -3 deg, @var{alpha0} = 4 deg, @var{kappa} = 50 deg). ## @end ifnottex ## ## System inputs: ## @enumerate ## @item Thrust ## @item Elevator angle ## @end enumerate ## System outputs: ## @enumerate ## @item Airspeed ## @item Pitch angle ## @end enumerate ## ## @strong{Reference}: R. Brockhaus: @cite{Flugregelung} (Flight ## Control), Springer, 1994. ## @end deftypefn ## Author: Kai P. Mueller ## Created: September 28, 1997 function outsys = Boeing707 () if (nargin != 0) print_usage (); endif a = [-0.46E-01, 0.10681415316, 0.0, -0.17121680433; -0.1675901504661613, -0.515, 1.0, 0.6420630320636088E-02; 0.1543104215347786, -0.547945, -0.906, -0.1521689385990753E-02; 0.0, 0.0, 1.0, 0.0]; b = [0.1602300107479095, 0.2111848453E-02; 0.8196877780963616E-02, -0.3025E-01; 0.9173594317692437E-01, -0.75283075; 0.0, 0.0]; c = [1.0, 0.0, 0.0, 0.0; 0.0, 0.0, 0.0, 1.0]; d = zeros (2, 2); inam = {"thrust"; "rudder"}; onam = {"speed"; "pitch"}; ## snam = {"x1"; "x2"; "x3"; "x4"}; outsys = ss (a, b, c, d, "inname", inam, "outname", onam); endfunction control-4.1.2/inst/PaxHeaders/margin.m0000644000000000000000000000007415012430645014671 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/margin.m0000644000175000017500000003141215012430645016061 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{gamma}, @var{phi}, @var{w_gamma}, @var{w_phi}] =} margin (@var{sys}) ## @deftypefnx{Function File} {[@var{gamma}, @var{phi}, @var{w_gamma}, @var{w_phi}] =} margin (@var{sys}, @var{tol}) ## Gain and phase margin of a system. ## If no output arguments are given, both gain and phase margin are plotted on a bode diagram. ## Otherwise, the margins and their corresponding frequencies are computed and returned. ## A more robust criterion to assess the stability of a feedback system is the sensitivity Ms ## computed by function @command{sensitivity}. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. Must be a single-input and single-output (SISO) system. ## @item tol ## Imaginary parts below @var{tol} are assumed to be zero. ## If not specified, default value @code{sqrt (eps)} is taken. ## @end table ## ## @strong{Outputs} ## @table @var ## @item gamma ## Gain margin (as gain, not dBs). ## @item phi ## Phase margin (in degrees). ## @item w_gamma ## Frequency for the gain margin (in rad/s). ## @item w_phi ## Frequency for the phase margin (in rad/s). ## @end table ## ## @strong{Algorithm}@* ## Uses function @command{roots} to calculate the frequencies ## @var{w_gamma}, @var{w_phi} from special polynomials created ## from the transfer function of @var{sys} as listed below ## in section @guillemetleft{}Equations@guillemetright{}. ## ## @strong{Equations} ## @example ## @group ## CONTINUOUS-TIME SYSTEMS ## Gain Margin ## _ _ ## L(jw) = L(jw) BTW: L(jw) = L(-jw) = conj (L(jw)) ## ## num(jw) num(-jw) ## ------- = -------- ## den(jw) den(-jw) ## ## num(jw) den(-jw) = num(-jw) den(jw) ## ## imag (num(jw) den(-jw)) = 0 ## imag (num(-jw) den(jw)) = 0 ## @end group ## @end example ## @example ## @group ## Phase Margin ## |num(jw)| ## |L(jw)| = |-------| = 1 ## |den(jw)| ## _ 2 2 ## z z = Re z + Im z ## ## num(jw) num(-jw) ## ------- * -------- = 1 ## den(jw) den(-jw) ## ## num(jw) num(-jw) - den(jw) den(-jw) = 0 ## ## real (num(jw) num(-jw) - den(jw) den(-jw)) = 0 ## @end group ## @end example ## @example ## @group ## DISCRETE-TIME SYSTEMS ## Gain Margin ## jwT log z ## L(z) = L(1/z) BTW: z = e --> w = ----- ## j T ## num(z) num(1/z) ## ------ = -------- ## den(z) den(1/z) ## ## num(z) den(1/z) - num(1/z) den(z) = 0 ## @end group ## @end example ## @example ## @group ## Phase Margin ## |num(z)| ## |L(z)| = |------| = 1 ## |den(z)| ## @end group ## @end example ## @example ## @group ## L(z) L(1/z) = 1 ## ## num(z) num(1/z) ## ------ * -------- = 1 ## den(z) den(1/z) ## ## num(z) num(1/z) - den(z) den(1/z) = 0 ## @end group ## @end example ## @example ## @group ## PS: How to get L(1/z) ## 4 3 2 ## p(z) = a z + b z + c z + d z + e ## ## -4 -3 -2 -1 ## p(1/z) = a z + b z + c z + d z + e ## ## -4 2 3 4 ## = z ( a + b z + c z + d z + e z ) ## ## 4 3 2 4 ## = ( e z + d z + c z + b z + a ) / ( z ) ## @end group ## @end example ## ## @seealso{sensitivity, roots} ## @end deftypefn ## Author: Lukas Reichlin ## Created: July 2009 ## Version: 0.9.2 function [gamma_r, phi_r, w_gamma_r, w_phi_r] = margin (sys, tol = sqrt (eps)) ## TODO: multiplot feature: margin (sys1, "b", sys2, "r", ...) ## check whether arguments are OK if (nargin < 1 || nargin > 2) print_usage (); endif if (! isa (sys, "lti")) error ("margin: argument sys must be an LTI system"); endif if (! issiso (sys)) error ("margin: argument sys must be a SISO system"); endif ## get transfer function [num, den, tsam] = tfdata (sys, "vector"); continuous = isct (sys); tsam = abs (tsam); # use 1 second as default if tsam == -1 if (continuous) # CONTINUOUS-TIME SYSTEM ## create polynomials s -> jw l_num = length (num); l_den = length (den); num_jw = num .* i.^(l_num-1 : -1 : 0); den_jw = den .* i.^(l_den-1 : -1 : 0); ## GAIN MARGIN ## create gm polynomial gm_poly = imag (conv (num_jw, conj (den_jw))); ## find frequencies w w = roots (gm_poly); ## filter results [gamma, w_gamma] = gm_filter (w, num, den, tsam, tol, continuous); ## PHASE MARGIN ## create pm polynomials poly_1 = conv (num_jw, conj (num_jw)); poly_2 = conv (den_jw, conj (den_jw)); ## make polynomials equally long for subtraction [poly_1, poly_2] = poly_equalizer (poly_1, poly_2); ## subtract polynomials pm_poly = real (poly_1 - poly_2); ## find frequencies w w = roots (pm_poly); ## filter results [phi, w_phi] = pm_filter (w, num, den, tsam, tol, continuous); else # DISCRETE-TIME SYSTEM ## create polynomials z -> 1/z l_num = length (num); l_den = length (den); num_rev = fliplr (num); den_rev = fliplr (den); num_div = zeros (1, l_num); den_div = zeros (1, l_den); num_div(1) = 1; den_div(1) = 1; num_inv = conv (num_rev, den_div); den_inv = conv (den_rev, num_div); ## GAIN MARGIN ## create gm polynomial poly_1 = conv (num, den_inv); poly_2 = conv (num_inv, den); ## make polynomials equally long for subtraction [poly_1, poly_2] = poly_equalizer (poly_1, poly_2); ## subtract polynomials gm_poly = poly_1 - poly_2; ## find frequencies z z = roots (gm_poly); ## filter results idx = find (abs (abs (z) - 1) < tol); # find z with magnitude 1 if (length (idx) > 0) # if z with magnitude 1 exist z_gm = z(idx); w = log (z_gm) / (i*tsam); # get frequencies w from z [gamma, w_gamma] = gm_filter (w, num, den, tsam, tol, continuous); else # there are no z with magnitude 1 gamma = Inf; w_gamma = NaN; endif ## PHASE MARGIN ## create pm polynomials poly_1 = conv (num, num_inv); poly_2 = conv (den, den_inv); ## make polynomials equally long for subtraction [poly_1, poly_2] = poly_equalizer (poly_1, poly_2); ## subtract polynomials pm_poly = poly_1 - poly_2; ## find frequencies z z = roots (pm_poly); ## filter results idx = find (abs (abs (z) - 1) < tol); # find z with magnitude 1 if (length (idx) > 0) # if z with magnitude 1 exist z_gm = z(idx); w = log (z_gm) / (i*tsam); # get frequencies w from z [phi, w_phi] = pm_filter (w, num, den, tsam, tol, continuous); else # there are no z with magnitude 1 phi = 180; w_phi = NaN; endif endif if (nargout == 0) # show bode diagram [H, w] = __frequency_response__ ("margin", {sys}); H = H{1}; w = w{1}; H = reshape (H, [], 1); mag_db = 20 * log10 (abs (H)); pha = unwrap (arg (H)) * 180 / pi; gamma_db = 20 * log10 (gamma); wv = [min(w), max(w)]; ax_vec_mag = __axis_limits__ ([w(:), mag_db(:)]); ax_vec_mag(1:2) = wv; ax_vec_pha = __axis_limits__ ([w(:), pha(:)]); ax_vec_pha(1:2) = wv; wgm = [w_gamma, w_gamma]; mgmh = [-gamma_db, ax_vec_mag(3)]; mgm = [0, -gamma_db]; pgm = [ax_vec_pha(4), -180]; wpm = [w_phi, w_phi]; mpm = [0, ax_vec_mag(3)]; ppmh = [ax_vec_pha(4), phi - 180]; ppm = [phi - 180, -180]; title_str = sprintf ("GM = %g dB (at %g rad/s), PM = %g deg (at %g rad/s)", gamma_db, w_gamma, phi, w_phi); if (continuous) xl_str = "Frequency [rad/s]"; else xl_str = sprintf ("Frequency [rad/s] w_N = %g", pi/tsam); endif subplot (2, 1, 1) semilogx (w, mag_db, "b", wv, [0, 0], "-.k", wgm, mgmh, "-.k", wgm, mgm, "r", wpm, mpm, "-.k") axis (ax_vec_mag) grid ("on") title (title_str) ylabel ("Magnitude [dB]") subplot (2, 1, 2) semilogx (w, pha, "b", wv, [-180, -180], "-.k", wgm, pgm, "-.k", wpm, ppmh, "-.k", wpm, ppm, "r") axis (ax_vec_pha) grid ("on") xlabel (xl_str) ylabel ("Phase [deg]") else # return values gamma_r = gamma; phi_r = phi; w_gamma_r = w_gamma; w_phi_r = w_phi; endif endfunction function [poly_eq_1, poly_eq_2] = poly_equalizer (poly_1, poly_2) l_p1 = length (poly_1); l_p2 = length (poly_2); l_max = max (l_p1, l_p2); lead_zer_1 = zeros (1, l_max - l_p1); lead_zer_2 = zeros (1, l_max - l_p2); poly_eq_1 = horzcat (lead_zer_1, poly_1); poly_eq_2 = horzcat (lead_zer_2, poly_2); endfunction function [gamma, w_gamma] = gm_filter (w, num, den, tsam, tol, continuous) idx = find ((abs (imag (w)) < tol) & (real (w) > 0)); # find frequencies in R+ if (length (idx) > 0) # if frequencies in R+ exist w_gm = real (w(idx)); if (continuous) s = i * w_gm; else s = exp (i * w_gm * tsam); endif f_resp = polyval (num, s) ./ polyval (den, s); gm = (abs (f_resp)).^-1; ## find crossings between 0 and -1 idx = find ((real (f_resp) < 0) & (real (f_resp) >= -1)); if (length (idx) > 0) # if crossings between 0 and -1 exist gm = gm(idx); w_gm = w_gm(idx); [gamma, idx] = min (gm); w_gamma = w_gm(idx); else # there are no crossings between 0 and -1 idx = find (real (f_resp) < -1); # find crossings between -1 and -Inf if (length (idx) > 0) # if crossings between -1 and -Inf exist gm = gm(idx); w_gm = w_gm(idx); [gamma, idx] = max (gm); w_gamma = w_gm(idx); else gamma = Inf; w_gamma = NaN; endif endif else # there are no frequencies in R+ gamma = Inf; w_gamma = NaN; endif endfunction function [phi, w_phi] = pm_filter (w, num, den, tsam, tol, continuous) idx = find ((abs (imag (w)) < tol) & (real (w) > 0)); # find frequencies in R+ if (length (idx) > 0) # if frequencies in R+ exist w_pm = real (w(idx)); if (continuous) s = i * w_pm; else s = exp (i * w_pm * tsam); endif f_resp = polyval (num, s) ./ polyval (den, s); pha = arg (f_resp) ./ pi .* 180; [pha, idx] = min (pha); w_phi = w_pm(idx); [mag_all, pha_all, w_all] = bode (tf(num,den,tsam)); # get complete response # get real phase and fix the phase computed above (only between -180 and +180) pha_real = interp1(w_all,pha_all,w_phi); while (pha_real < pha - 179) pha = pha - 360; # fix the phase endwhile phi = pha + 180; else # there are no frequencies in R+ phi = 180; w_phi = NaN; endif endfunction %!shared margin_c, margin_c_exp, margin_d, margin_d_exp %! sysc = tf ([24], [1, 6, 11, 6]); %! [gamma_c, phi_c, w_gamma_c, w_phi_c] = margin (sysc); %! sysd = c2d (sysc, 0.3); %! [gamma_d, phi_d, w_gamma_d, w_phi_d] = margin (sysd); %! %! margin_c = [gamma_c, phi_c, w_gamma_c, w_phi_c]; %! margin_d = [gamma_d, phi_d, w_gamma_d, w_phi_d]; %! %! ## results from this implementation and the "dark side" diverge %! ## from the third digit after the decimal point on %! %! gamma_c_exp = 2.50; %! phi_c_exp = 35.43; %! w_gamma_c_exp = 3.32; %! w_phi_c_exp = 2.06; %! %! gamma_d_exp = 1.41; %! phi_d_exp = 18.60; %! w_gamma_d_exp = 2.48; %! w_phi_d_exp = 2.04; %! %! margin_c_exp = [gamma_c_exp, phi_c_exp, w_gamma_c_exp, w_phi_c_exp]; %! margin_d_exp = [gamma_d_exp, phi_d_exp, w_gamma_d_exp, w_phi_d_exp]; %! %!assert (margin_c, margin_c_exp, 1e-2); %!assert (margin_d, margin_d_exp, 1e-2); control-4.1.2/inst/PaxHeaders/__iddata_dim__.m0000644000000000000000000000007415012430645016267 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__iddata_dim__.m0000644000175000017500000000437715012430645017471 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## Author: Lukas Reichlin ## Created: October 2011 ## Version: 0.1 function [p, m, e] = __iddata_dim__ (y, u) e = numel (y); # number of experiments if (isempty (u)) # time series data, outputs only [p, m] = cellfun (@__experiment_dim__, y, "uniformoutput", false); elseif (e == numel (u)) # outputs and inputs present [p, m] = cellfun (@__experiment_dim__, y, u, "uniformoutput", false); else error ("iddata: require input and output data with matching number of experiments"); endif if (e > 1 && ! isequal (p{:})) error ("iddata: require identical number of output channels for all experiments"); endif if (e > 1 && ! isequal (m{:})) error ("iddata: require identical number of input channels for all experiments"); endif p = p{1}; m = m{1}; endfunction function [p, m] = __experiment_dim__ (y, u = []) if (! is_matrix (y, u)) error ("iddata: inputs and outputs must be real or complex matrices"); endif [ly, p] = size (y); [lu, m] = size (u); if (! isempty (u) && ly != lu) error ("iddata: matrices 'y' (%dx%d) and 'u' (%dx%d) must have the same number of samples (rows)", ... ly, p, lu, m); endif if (ly < p) warning ("iddata:transpose", "iddata: more outputs than samples - matrice 'y' should probably be transposed\n"); endif if (lu < m) warning ("iddata:transpose", "iddata: more inputs than samples - matrice 'u' should probably be transposed\n"); endif endfunction control-4.1.2/inst/PaxHeaders/test_control.m0000644000000000000000000000007415012430645016133 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/test_control.m0000644000175000017500000000440015012430645017320 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Script File} {} test_control ## Execute all available tests at once. ## ## The Octave control package uses the ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT library}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## @acronym{SLICOT} needs @acronym{BLAS} and @acronym{LAPACK} libraries which are also prerequisites ## for Octave itself. ## In case of failing tests, it is highly recommended to use ## @uref{http://www.netlib.org/blas/, Netlib's reference @acronym{BLAS}} and ## @uref{http://www.netlib.org/lapack/, @acronym{LAPACK}} ## for building Octave. Using @acronym{ATLAS} may lead to sign changes ## in some entries of the state-space matrices. ## In general, these sign changes are not 'wrong' and can be regarded as ## the result of state transformations. Such state transformations ## (but not input/output transformations) have no influence on the ## input-output behaviour of the system. For better numerics, ## the control package uses such transformations by default when ## calculating the frequency responses and a few other things. ## However, arguments like the Hankel singular Values (@acronym{HSV}) must not change. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: May 2010 ## Version: 0.6 ## ## Modified 01.01.2024 by Torsten Lilge ## Use pkg test control instead of calling all tests separatly pkg test control control-4.1.2/inst/PaxHeaders/Anderson.m0000644000000000000000000000007415012430645015165 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/Anderson.m0000644000175000017500000000544115012430645016360 0ustar00lilgelilge00000000000000%% -*- texinfo -*- %% @deftypefn {Example Script} {} Anderson %% %% Frequency-weighted coprime factorization controller reduction [1]. %% %% @*@strong{References}@* %% [1] Anderson, B.D.O.: %% @cite{Controller Reduction: Concepts and Approaches}, %% IEEE Transactions of Automatic Control, Vol. 34, No. 8, August 1989. %% @end deftypefn % =============================================================================== % Coprime Factorization Controller Reduction Lukas Reichlin December 2011 % =============================================================================== % Reference: Anderson, B.D.O.: Controller Reduction: Concepts and Approaches % IEEE Transactions of Automatic Control, Vol. 34, No. 8, August 1989 % =============================================================================== % Tabula Rasa clear all, close all, clc % Plant A = [ -0.161 -6.004 -0.58215 -9.9835 -0.40727 -3.982 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 1.0 0.0 ]; B = [ 1.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 ]; C = [ 0.0 0.0 6.4432e-3 2.3196e-3 7.1252e-2 1.0002 0.10455 0.99551 ]; G = ss (A, B, C); % LQG Design H = [ 0.0 0.0 0.0 0.0 0.55 11.0 1.32 18.0 ]; q1 = 1e-6; q2 = 100; % [100, 1000, 2000] Q = q1 * H.' * H; R = 1; W = q2 * B * B.'; V = 1; F = lqr (G, Q, R) L = lqe (G, W, V) % Coprime Factorization using Balanced Truncation Approximation Kr = arrayfun (@(k) cfconred (G, F, L, k), 8:-1:2, 'uniformoutput', false); % 'method', 'bfsr-bta' T = cellfun (@(Kr) feedback (G*Kr), Kr, 'uniformoutput', false); figure (1) step (T{:}, 200) % Coprime Factorization using Singular Perturbation Approximation Kr = arrayfun (@(k) cfconred (G, F, L, k, 'method', 'bfsr-spa'), 8:-1:2, 'uniformoutput', false); T = cellfun (@(Kr) feedback (G*Kr), Kr, 'uniformoutput', false); figure (2) step (T{:}, 200) % Frequency-Weighted Coprime Factorization using BTA Kr = arrayfun (@(k) fwcfconred (G, F, L, k), 8:-1:2, 'uniformoutput', false); T = cellfun (@(Kr) feedback (G*Kr), Kr, 'uniformoutput', false); figure (3) step (T{:}, 300) control-4.1.2/inst/PaxHeaders/tfpolyzeros.m0000644000000000000000000000007415012430645016014 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/tfpolyzeros.m0000644000175000017500000000200115012430645017174 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Return (pxm) cell of tfpoly([0]). For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function ret = tfpolyzeros (p, m) ret = cell (p, m); zero = tfpoly ([0]); ret(:) = {zero}; endfunction control-4.1.2/inst/PaxHeaders/pidstd.m0000644000000000000000000000007415012430645014703 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/pidstd.m0000644000175000017500000000470715012430645016102 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{C} =} pidstd (@var{Kp}) ## @deftypefnx{Function File} {@var{C} =} pidstd (@var{Kp}, @var{Ti}) ## @deftypefnx{Function File} {@var{C} =} pidstd (@var{Kp}, @var{Ti}, @var{Td}) ## @deftypefnx{Function File} {@var{C} =} pidstd (@var{Kp}, @var{Ti}, @var{Td}, @var{N}) ## Return the transfer function @var{C} of the @acronym{PID} controller ## in standard form with first-order roll-off. ## ## @example ## @group ## 1 Td s ## C(s) = Kp (1 + ---- + ----------) ## Ti s Td/N s + 1 ## @end group ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2015 ## Version: 0.1 ## TODO: discrete-time case, dozens of options, ... ## NOTE: I don't see any need to implement 'pid' and 'pidstd' ## as LTI classes like the 'dark side' does. ## Returning a transfer function seems to be sufficient. ## These functions' sole purpose is to help novice users ## running their scripts with as little changes as possible. function C = pidstd (Kp = 1, Ti = inf, Td = 0, N = inf) if (! is_real_scalar (Kp, Ti, Td, N) || nargin > 4) print_usage (); endif if (Kp == 0) # pidstd (0) C = tf (0); elseif (Ti == inf && N == inf) # pidstd (Kp, inf, Td) C = tf (Kp*[Td, 1], [1]); elseif (Ti == inf) # pidstd (Kp, inf, Td, N) C = tf (Kp*[N*Td+Td, N], [Td, N]); elseif (N == inf) # pidstd (Kp, Ti, Td), pidstd (Kp, Ti) C = tf (Kp*[Td*Ti, Ti, 1], [Ti, 0]); else # pidstd (Kp, Ti, Td, N) C = tf (Kp*[N*Td*Ti+Td*Ti, N*Ti+Td, N], [Td*Ti, N*Ti, 0]); endif endfunction control-4.1.2/inst/PaxHeaders/rlocus.m0000644000000000000000000000007415012430645014723 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/rlocus.m0000644000175000017500000002563715012430645016127 0ustar00lilgelilge00000000000000## 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} {} rlocus (@var{sys}) ## @deftypefnx {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. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. Must be a single-input and single-output (SISO) system. ## @item increment ## The increment used in computing gain values. ## @item min_k ## Minimum value of @var{k}. ## @item max_k ## Maximum value of @var{k}. ## @end table ## ## @strong{Outputs} ## @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 ## ## @strong{Block Diagram} ## @example ## @group ## u + +---+ +------+ y ## ------>(+)----->| k |----->| SISO |-------+-------> ## ^ - +---+ +------+ | ## | | ## +---------------------------------+ ## @end group ## @end example ## @seealso{rlocusx} ## @end deftypefn ## Author: David Clem ## Author: R. Bruce Tenison ## Updated by Kristi McGowan July 1996 for intelligent gain selection ## Updated by John Ingram July 1996 for systems ## Adapted-By: Lukas Reichlin ## Date: December 2009 ## Version: 0.6 function [rldata_r, k_break, rlpol, gvec, real_ax_pts] = rlocus (sys, increment, min_k, max_k) ## TODO: improve compatibility to the "dark side" ## TODO: untangle spaghetti code ## TODO: multiplot feature: rlocus (sys1, "b", sys2, "r", ...) if (nargin < 1 || nargin > 4) print_usage (); endif if (! isa (sys, "lti") || ! issiso (sys)) error ("rlocus: first argument must be a SISO LTI model"); endif ## Convert the input to a transfer function if necessary [num_full, den] = tfdata (sys, "vector"); # extract numerator/denominator polynomials num = __remove_leading_zeros__ (num_full); den = __remove_leading_zeros__ (den); lnum = length (num); lden = length (den); ## equalize length of num, den polynomials ## TODO: handle case lnum > lden (non-proper models) if (lden < 2) error ("rlocus: 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 = polyder (num); dden = polyder (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)); real_ax_pts(polyval (num, real_ax_pts) == 0) = []; # avoid division by zero and therefore infinite k_break 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 ("rlocus: increment must be positive"); else ngain = fix ((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, reshape(k_break, 1, [])]); endif ## Find the open loop zeros and the initial poles rlzer = roots (num); ## update num to be the same length as den num = num_full; ## compute preliminary pole sets nroots = lden - 1; for ii = 1:ngain gain = gvec(ii); rlpol(1:nroots,ii) = vec(sort_complex_roots (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_complex_roots (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 = __axis_limits__ (axdata); rldata = [real(rlpolv), imag(rlpolv) ]; %inname = get (sys, "inname"); %outname = get (sys, "outname"); % Marker size depending on engine ms = 10; if (strcmp(graphics_toolkit(),'gnuplot')) ms = 6; endif ## 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} = "x;open loop poles;"; if (! isempty (rlzer)) args{1,++kk} = real (rlzer); args{2,kk} = imag (rlzer); args{3,kk} = "o;zeros;"; endif hplt = plot (args{:}); if (! isempty (rlzer)) set (hplt(kk--), {"linewidth", "markersize", "color"}, {2, ms, [0, 0.75, 0]}); endif set (hplt(kk--), {"linewidth", "markersize", "color"}, {2, ms, [0.75, 0, 0]}); for ii = 1:rows(rlpol) set (hplt(kk--), "linewidth", 2); endfor legend ("boxon"); grid ("on"); axis (axlim); name = inputname (1); if (! isempty (name)) name = [name, ' ']; endif title_string = sprintf ('Root loucs %s(K = %.3f .. %.3f)', name, gvec(1), gvec(end)); title (title_string); xlabel ("Real Axis"); 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 rlpol 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 [b, a] = swap (a, b) endfunction function c = sort_complex_roots (c) ## This function sorts complex numbers such that ## 1) All the pure reals come first and are sorted. ## 2) All complex numbers are sorted by the regular sort. c = vec (c); idx = (imag (c) == 0); cre = sort (c(idx)); cim = sort (c(! idx)); c = vertcat (cre, cim); endfunction %!demo %! s = tf('s'); %! g = (s^2+2*s+2)/(s*(s^4+9*s^3+33*s^2+51*s+26)); %! rlocus(g); %!test %! num = [0 0 1]; %! den = [1 2 0]; %! G = tf(num,den); %! [rldata,ko,~,gvec] = rlocus(G); %! idx = floor(length(gvec)/2); %! go = gvec(idx); %! rlo = rldata(1,idx); %! ke = 1; %! rle = roots (den + go*num); %! assert (ko, ke, 1e-4); %! assert (rlo, rle(2), 1e-4); control-4.1.2/inst/PaxHeaders/__modred_check_alpha_gram__.m0000644000000000000000000000007415012430645020772 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__modred_check_alpha_gram__.m0000644000175000017500000000221215012430645022156 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## check alpha for combination methods of grammians ## Author: Lukas Reichlin ## Created: December 2011 ## Version: 0.1 function alpha = __modred_check_alpha_gram__ (alpha, key) if (! is_real_scalar (alpha)) error ("modred: argument '%s' must be a real scalar", key); endif if (abs (alpha) > 1) error ("modred: require -1 <= %s <= 1", key); endif endfunction control-4.1.2/inst/PaxHeaders/__frequency_response__.m0000644000000000000000000000007415012430645020127 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__frequency_response__.m0000644000175000017500000001104415012430645021316 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Return frequency response H and frequency vector w. ## If w is empty, it will be calculated by __frequency_vector__. ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 0.7 function [H, w, sty, idx, H_auto, w_auto] = __frequency_response__ (caller, args, nout = 0) ## CALLER | MIMO | RANGE | CELL | ## ---------------+-------+-------+-------+ ## bode | false | std | false | ## bodemag | false | std | false | ## margin | false | std | false | ## nichols | false | ext | false | ## nyquist | false | ext | false | ## sensitivity | false | ext | false | ## sigma | true | std | true | mimoflag = false; cellflag = false; wbounds = "std"; if (strcmp (caller, {"sigma"})) mimoflag = true; cellflag = true; endif if (any (strcmp (caller, {"nyquist", "nichols", "sensitivity"}))) wbounds = "ext"; endif sys_idx = cellfun (@isa, args, {"lti"}); # look for LTI models frd_idx = cellfun (@isa, args, {"frd"}); # look for FRD models w_idx = cellfun (@is_real_vector, args); # look for frequency vectors r_idx = cellfun (@iscell, args); # look for frequency ranges {wmin, wmax} s_idx = cellfun (@ischar, args); # look for strings (style arguments) inv_idx = ! (sys_idx | w_idx | r_idx | s_idx); # look for invalid arguments if (any (inv_idx)) warning ("%s: argument(s) number %s are invalid and are being ignored\n", ... caller, mat2str (find (inv_idx)(:).')); endif if (nnz (sys_idx) == 0) error ("%s: require at least one LTI model", caller); endif if (nout > 0 && (nnz (sys_idx) > 1 || any (s_idx))) print_usage (caller); endif if (! mimoflag && ! all (cellfun (@issiso, args(sys_idx)))) error ("%s: require SISO systems", caller); endif if (any (find (s_idx) < find (sys_idx)(1))) warning ("%s: strings in front of first LTI model are being ignored\n", caller); endif ## determine frequency vectors w_auto = __frequency_vector__ (args(sys_idx), wbounds); if (any (r_idx)) # if there are frequency ranges if (nnz (r_idx) > 1) warning ("%s: several frequency ranges specified, taking the last one\n", caller); endif r = args(r_idx){end}; if (numel (r) == 2 && issample (r{1}) && issample (r{2}) && r{1} < r{2}) w = __frequency_vector__ (args(sys_idx), wbounds, r{1}, r{2}); else error ("%s: the cell defining the desired frequency range is invalid", caller); endif elseif (any (w_idx)) # are there any frequency vectors? if (nnz (r_idx) > 1) warning ("%s: several frequency vectors specified, taking the last one\n", caller); endif w = args(w_idx){end}; w = repmat ({w}, 1, nnz (sys_idx)); else # there are neither frequency ranges nor vectors w = w_auto; endif ## temporarily save frequency vectors of FRD models w_frd = cellfun (@(x) get (x, "w"), args(frd_idx), "uniformoutput", false); w(frd_idx) = {[]}; # freqresp returns all frequencies of FRD models for w=[] ## compute frequency response H for all LTI models H = cellfun (@__freqresp__, args(sys_idx), w, {cellflag}, "uniformoutput", false); H_auto = cellfun (@__freqresp__, args(sys_idx), w_auto, {cellflag}, "uniformoutput", false); ## restore frequency vectors of FRD models in w w(frd_idx) = w_frd; ## extract plotting styles tmp = cumsum (sys_idx); tmp(sys_idx | ! s_idx) = 0; n = nnz (sys_idx); sty = arrayfun (@(x) args(tmp == x), 1:n, "uniformoutput", false); ## get the systems among the input args for later building the legend idx = find (sys_idx); endfunction control-4.1.2/inst/PaxHeaders/bode.m0000644000000000000000000000007415012430645014325 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/bode.m0000644000175000017500000001362715012430645015525 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} bode (@var{sys}) ## @deftypefnx {Function File} {} bode (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}) ## @deftypefnx {Function File} {} bode (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}, @var{w}) ## @deftypefnx {Function File} {} bode (@var{sys1}, @var{'style1'}, @dots{}, @var{sysN}, @var{'styleN'}) ## @deftypefnx {Function File} {[@var{mag}, @var{pha}, @var{w}] =} bode (@var{sys}) ## @deftypefnx {Function File} {[@var{mag}, @var{pha}, @var{w}] =} bode (@var{sys}, @var{w}) ## Bode diagram of frequency response. If no output arguments are given, ## the response is printed on the screen. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. Must be a single-input and single-output (SISO) system. ## @item w ## Optional vector of frequency values. If @var{w} is not specified, ## it is calculated by the zeros and poles of the system. ## Alternatively, the cell @code{@{wmin, wmax@}} specifies a frequency range, ## where @var{wmin} and @var{wmax} denote minimum and maximum frequencies ## in rad/s. ## @item 'style' ## Line style and color, e.g. 'r' for a solid red line or '-.k' for a dash-dotted ## black line. See @command{help plot} for details. ## @end table ## ## @strong{Outputs} ## @table @var ## @item mag ## Vector of magnitude. Has length of frequency vector @var{w}. ## @item pha ## Vector of phase. Has length of frequency vector @var{w}. ## @item w ## Vector of frequency values used. ## @end table ## ## @seealso{nichols, nyquist, sigma} ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 1.0 function [mag_r, pha_r, w_r] = bode (varargin) if (nargin == 0) print_usage (); endif [H, w, sty, sys_idx, H_auto, w_auto] = __frequency_response__ ("bode", varargin, nargout); H = cellfun (@reshape, H, {[]}, {1}, "uniformoutput", false); H_auto = cellfun (@reshape, H_auto, {[]}, {1}, "uniformoutput", false); mag = cellfun (@abs, H, "uniformoutput", false); pha = cellfun (@(H) unwrap (arg (H)) * 180 / pi, H, "uniformoutput", false); pha_auto = cellfun (@(H_auto) unwrap (arg (H_auto)) * 180 / pi, H_auto, "uniformoutput", false); numsys = length (sys_idx); ## check for poles and zeroes at the origin for each of the numsys systems ## and compare this asymptotic value to initial phase for the full auto ## w-range, which is supposed to start at sufficiently small values fo w initial_phase = cellfun(@(x) x(1), pha_auto); for h = 1:numsys sys1 = varargin{sys_idx(h)}; [num,den] = tfdata (sys1,'v'); n_poles_at_origin = sum (roots (den) == 0); n_zeros_at_origin = sum (roots (num) == 0); asymptotic_low_freq_phase = (n_zeros_at_origin - n_poles_at_origin)*90; pha_auto(h)={cell2mat(pha_auto(h)) + round((asymptotic_low_freq_phase - initial_phase(h))/360)*360}; endfor ## check if possibly given w-range is at higher frequencies and provide ## missing "history" for the the phase initial_phase = cellfun(@(x) x(1), pha); for h = 1:numsys if (length (w{h}) != length (w_auto{h})) || any (w{h} - w_auto{h}) ## the w-range to use is not the auto (full) range, thus, make sure ## the inforamtion on the phase form beginning at small frequencies ## is used to determine the correct pahse at the beginning of the desired ## w range if w{h}(1) > w_auto{h}(1) ## w range starts at higher frequencies; get the nearest w in the auto ## range and add +/-360 degrees minimizing the differenze betwenn the ## phases pha_idx = length (find (w_auto{h} < w{h}(1))); pha_cmp = pha_auto{h}(pha_idx); pha(h)={cell2mat(pha(h)) + round((pha_cmp - initial_phase(h))/360)*360}; endif else ## w range is identical to auto range, just use the phase for the ## auto range pha(h) = {pha_auto(h)}; endif endfor if (! nargout) ## get system names and create the legend leg = cell (1, numsys); for k = 1:numsys leg{k} = inputname (sys_idx(k)); if (isempty (leg{k})) leg{k} = sprintf("Sys %d", k); endif endfor ## plot mag_db = cellfun (@mag2db, mag, "uniformoutput", false); mag_args = horzcat (cellfun (@horzcat, w, mag_db, sty, "uniformoutput", false){:}); pha_args = horzcat (cellfun (@horzcat, w, pha, sty, "uniformoutput", false){:}); subplot (2, 1, 1) semilogx (mag_args{:}) axis ("tight") ylim (__axis_margin__ (ylim)) grid ("on") title ("Bode Diagram") ylabel ("Magnitude [dB]") legend (leg) subplot (2, 1, 2) semilogx (pha_args{:}) axis ("tight") ylim (__axis_margin__ (ylim)) grid ("on") xlabel ("Frequency [rad/s]") ylabel ("Phase [deg]") legend (leg) else ## no plotting, assign values to the output parameters mag_r = mag{1}; pha_r = pha{1}; if (iscell (pha_r)) # fix possible cell in cell pha_r = pha_r{1}; endif w_r = w{1}; endif endfunction %!demo %! s = tf('s'); %! g = 1/(2*s^2+3*s+4); %! bode(g); %!test %! s = tf('s'); %! K = 1; %! T = 2; %! g = K/(1+T*s); %! [mag phas w] = bode(g); %! mag_dB = 20*log10(mag); %! index = find(mag_dB < -3,1); %! w_cutoff = w(index); %! assert (1/T, w_cutoff, eps); control-4.1.2/inst/PaxHeaders/__adjust_tf_data__.m0000644000000000000000000000007415012430645017164 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__adjust_tf_data__.m0000644000175000017500000000645615012430645020366 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Common code for adjusting TF model data. ## Used by tf and __set__. ## Author: Lukas Reichlin ## Created: October 2015 ## Version: 0.1 function [num, den, tsam, tfvar] = __adjust_tf_data__ (num, den, tsam = -1) static_gain = false; if (isempty (den)) # tf (num, []), where [] could be {} as well if (isempty (num)) # tf ([], []) num = den = {}; static_gain = true; elseif (is_real_matrix (num)) # static gain tf (matrix), tf (matrix, []) num = num2cell (num); den = num2cell (ones (size (num))); static_gain = true; endif endif if (! iscell (num)) num = {num}; endif if (! iscell (den)) den = {den}; endif ## Now check for static gain if all tfs have size num and size den of one num_scalar = cellfun (@(p) (find (p != 0, 1) == length (p)) || (length (find (p != 0, 1)) == 0), num); den_scalar = cellfun (@(p) (find (p != 0, 1) == length (p)) || (length (find (p != 0, 1)) == 0), den); if (all (num_scalar) && all (den_scalar)) ## All tf components are of the form b0/a0 (static gain) static_gain = true; endif ## NOTE: the 'tfpoly' constructor checks its vector as well, ## but its error message would make little sense for users ## and would make it hard for them to identify the invalid argument. ## NOTE: this code is nicer, but there would be conflicts in @tf/__set__.m ## e.g. sys = tf ([5, 22], [1, 2]), sys.num = 5 ## ## if (! is_real_vector (num{:}, 1)) # dummy argument 1 needed if num is empty cell ## error ("tf: first argument 'num' requires a real-valued, non-empty vector or a cell of such vectors"); ## endif ## if (! is_real_vector (den{:}, 1)) ## error ("tf: second argument 'den' requires a real-valued, non-empty vector or a cell of such vectors"); ## endif ## ## num = cellfun (@tfpoly, num, "uniformoutput", false); ## den = cellfun (@tfpoly, den, "uniformoutput", false); try num = cellfun (@tfpoly, num, "uniformoutput", false); catch error ("tf: numerator 'num' must be a real-valued, non-empty vector or a cell of such vectors"); end_try_catch try den = cellfun (@tfpoly, den, "uniformoutput", false); catch error ("tf: denominator 'den' must be a real-valued, non-empty vector or a cell of such vectors"); end_try_catch if (any (cellfun (@is_zero, den)(:))) error ("tf: denominator(s) cannot be zero"); endif if (static_gain) tfvar = "x"; elseif (tsam == 0) tfvar = "s"; else tfvar = "z"; endif endfunction control-4.1.2/inst/PaxHeaders/doc_control.m0000644000000000000000000000007415012430645015721 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/doc_control.m0000644000175000017500000000473715012430645017123 0ustar00lilgelilge00000000000000## Copyright (C) 2023-2024 Torsten Lilge ## ## This file is part of the Control package for GNU Octave ## ## This 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 software 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 the Control package. If not, see . ## -*- texinfo -*- ## @deftypefn {} doc_control @var{fcn1} @var{fcn2} ... ## @deftypefnx {} {@var{st} =} doc_control (@var{fcn1}, @var{fcn2}, ...) ## ## Open online documentation of the Control package in the system's ## standard browser. ## ## @strong{Inputs} ## @table @var ## @item fcn1, fcn2, ... ## Function names for which the documentation should be displayed. ## If no function name is given, the index of the documentation is shown. ## If one of the function names is 'license', copyright and license ## information are displayed. ## @end table ## ## @strong{Outputs} ## @table @var ## @item st ## The return value @var{st} has one of the values: ## @itemize @bullet ## @item ## @samp{0} Found and opened system browser successfully. ## @item ## @samp{1} System browser not found. ## @item ## @samp{2} System browser found, but an error occurred. ## @end itemize ## @end table ## ## @end deftypefn ## Author: Torsten Lilge ## Created: December 2023 ## Version: 0.1 function st = doc_control (varargin) base = 'https://gnu-octave.github.io/pkg-control/'; license = 'https://github.com/gnu-octave/pkg-control/blob/main/COPYING'; status = 0; if nargin == 0 status = web (base); else for i = 1:nargin if ischar (varargin{i}) fcn = strtrim (varargin{i}); if (strcmp (fcn, 'license')) url = license; else url = [base, strrep(fcn, '/', '_'), '.html']; endif sti = web (url); if sti > 1 status = sti; break; elseif status == 0 status = sti; endif else error ("argument %d is not a string\n", i); endif endfor endif if nargout > 0 st = status; endif endfunction control-4.1.2/inst/PaxHeaders/dare.m0000644000000000000000000000007415012430645014327 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/dare.m0000644000175000017500000001416415012430645015524 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{x}, @var{l}, @var{g}] =} dare (@var{a}, @var{b}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{x}, @var{l}, @var{g}] =} dare (@var{a}, @var{b}, @var{q}, @var{r}, @var{s}) ## @deftypefnx {Function File} {[@var{x}, @var{l}, @var{g}] =} dare (@var{a}, @var{b}, @var{q}, @var{r}, @var{[]}, @var{e}) ## @deftypefnx {Function File} {[@var{x}, @var{l}, @var{g}] =} dare (@var{a}, @var{b}, @var{q}, @var{r}, @var{s}, @var{e}) ## Solve discrete-time algebraic Riccati equation (ARE). ## ## @strong{Inputs} ## @table @var ## @item a ## Real matrix (n-by-n). ## @item b ## Real matrix (n-by-m). ## @item q ## Real matrix (n-by-n). ## @item r ## Real matrix (m-by-m). ## @item s ## Optional real matrix (n-by-m). If @var{s} is not specified, a zero matrix is assumed. ## @item e ## Optional descriptor matrix (n-by-n). If @var{e} is not specified, an identity matrix is assumed. ## @end table ## ## @strong{Outputs} ## @table @var ## @item x ## Unique stabilizing solution of the discrete-time Riccati equation (n-by-n). ## @item l ## Closed-loop poles (n-by-1). ## @item g ## Corresponding gain matrix (m-by-n). ## @end table ## ## @strong{Equations} ## @example ## @group ## -1 ## A'XA - X - A'XB (B'XB + R) B'XA + Q = 0 ## ## -1 ## A'XA - X - (A'XB + S) (B'XB + R) (B'XA + S') + Q = 0 ## ## -1 ## G = (B'XB + R) B'XA ## ## -1 ## G = (B'XB + R) (B'XA + S') ## ## L = eig (A - B*G) ## @end group ## @end example ## @example ## @group ## -1 ## A'XA - E'XE - A'XB (B'XB + R) B'XA + Q = 0 ## ## -1 ## A'XA - E'XE - (A'XB + S) (B'XB + R) (B'XA + S') + Q = 0 ## ## -1 ## G = (B'XB + R) B'XA ## ## -1 ## G = (B'XB + R) (B'XA + S') ## ## L = eig (A - B*G, E) ## @end group ## @end example ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB02OD and SG02AD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @seealso{care, lqr, dlqr, kalman} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.5.1 function [x, l, g] = dare (a, b, q, r, s = [], e = []) ## TODO: extract feedback matrix g from SB02OD (and SG02AD) if (nargin < 4 || nargin > 6) print_usage (); endif if (! is_real_square_matrix (a, q, r)) ## error ("dare: a, q, r must be real and square"); error ("dare: %s, %s, %s must be real and square", ... inputname (1), inputname (3), inputname (4)); endif if (! is_real_matrix (b) || rows (a) != rows (b)) ## error ("dare: a and b must have the same number of rows"); error ("dare: %s and %s must have the same number of rows", ... inputname (1), inputname (2)); endif if (columns (r) != columns (b)) ## error ("dare: b and r must have the same number of columns"); error ("dare: %s and %s must have the same number of columns", ... inputname (2), inputname (4)); endif if (! is_real_matrix (s) && ! size_equal (s, b)) ## error ("dare: s(%dx%d) must be real and identically dimensioned with b(%dx%d)", ## rows (s), columns (s), rows (b), columns (b)); error ("dare: %s(%dx%d) must be real and identically dimensioned with %s(%dx%d)", ... inputname (5), rows (s), columns (s), inputname (2), rows (b), columns (b)); endif if (! isempty (e) && (! is_real_square_matrix (e) || ! size_equal (e, a))) ## error ("dare: a and e must have the same number of rows"); error ("dare: %s and %s must have the same number of rows", ... inputname (1), inputname (6)); endif ## check stabilizability if (! isstabilizable (a, b, e, [], 1)) ## error ("dare: (a, b) not stabilizable"); error ("dare: (%s, %s) not stabilizable", ... inputname (1), inputname (2)); endif ## check positive semi-definiteness if (isempty (s)) t = zeros (size (b)); else t = s; endif m = [q, t; t.', r]; if (isdefinite (m) < 0) ## error ("dare: require [q, s; s.', r] >= 0"); error ("dare: require [%s, %s; %s.', %s] >= 0", ... inputname (3), inputname (5), inputname (5), inputname (4)); endif ## solve the riccati equation if (isempty (e)) if (isempty (s)) [x, l] = __sl_sb02od__ (a, b, q, r, b, true, false); g = (r + b.'*x*b) \ (b.'*x*a); # gain matrix else [x, l] = __sl_sb02od__ (a, b, q, r, s, true, true); g = (r + b.'*x*b) \ (b.'*x*a + s.'); # gain matrix endif else if (isempty (s)) [x, l] = __sl_sg02ad__ (a, e, b, q, r, b, true, false); g = (r + b.'*x*b) \ (b.'*x*a); # gain matrix else [x, l] = __sl_sg02ad__ (a, e, b, q, r, s, true, true); g = (r + b.'*x*b) \ (b.'*x*a + s.'); # gain matrix endif endif endfunction %!shared x, l, g, xe, le, ge %! a = [ 0.4 1.7 %! 0.9 3.8]; %! %! b = [ 0.8 %! 2.1]; %! %! c = [ 1 -1]; %! %! r = 3; %! %! [x, l, g] = dare (a, b, c.'*c, r); %! %! xe = [ 1.5354 1.2623 %! 1.2623 10.5596]; %! %! le = [-0.0022 %! 0.2454]; %! %! ge = [ 0.4092 1.7283]; %! %!assert (x, xe, 1e-4); %!assert (sort (l), sort (le), 1e-4); %!assert (g, ge, 1e-4); ## TODO: add more tests (nonempty s and/or e) control-4.1.2/inst/PaxHeaders/__is_stable__.m0000644000000000000000000000007415012430645016155 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__is_stable__.m0000644000175000017500000000235115012430645017345 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Determine whether all poles in a vector are stable. ## Author: Lukas Reichlin ## Created: December 2010 ## Version: 0.2 function bool = __is_stable__ (pol, ct = true, tol = 0) if (! is_real_scalar (tol) || tol < 0) error ("isstable: tolerance must be a real-valued, non-negative scalar"); endif if (ct) # continuous-time bool = all (real (pol) < -tol*(1 + abs (pol))); else # discrete-time bool = all (abs (pol) < 1 - tol); endif endfunction control-4.1.2/inst/PaxHeaders/__axis_limits__.m0000644000000000000000000000007415012430645016535 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__axis_limits__.m0000644000175000017500000000426715012430645017735 0ustar00lilgelilge00000000000000## Copyright (C) 1998, 2000, 2004, 2005, 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} {} __axis_limits__ (@var{axdata}) ## Determine axis limits for 2-D data (column vectors); leaves a 10% ## margin around the plots. ## Inserts margins of +/- 0.1 if data is one-dimensional ## (or a single point). ## ## @strong{Input} ## @table @var ## @item axdata ## @var{n} by 2 matrix of data [@var{x}, @var{y}]. ## @end table ## ## @strong{Output} ## @table @var ## @item axvec ## Vector of axis limits appropriate for call to @command{axis} function. ## @end table ## @end deftypefn function axvec = __axis_limits__ (axdata) if (nargin < 1 || isempty (axdata)) axdata = 0; endif ## compute axis limits minv = min (axdata); maxv = max (axdata); delv = (maxv-minv)/2; # breadth of the plot midv = (minv + maxv)/2; # midpoint of the plot axmid = [midv(1), midv(1), midv(2), midv(2)]; axdel = [-0.1, 0.1, -0.1, 0.1]; # default plot width (if less than 2-d data) if (max (delv) == 0) if (midv(1) != 0) axdel(1:2) = [-0.1*midv(1), 0.1*midv(1)]; endif if (midv(2) != 0) axdel(3:4) = [-0.1*midv(2), 0.1*midv(2)]; endif else ## they're at least one-dimensional tolv = max(1e-8, 1e-8*abs(midv)); if (abs (delv(1)) >= tolv(1)) axdel(1:2) = 1.1*[-delv(1),delv(1)]; endif if (abs (delv(2)) >= tolv(2)) axdel(3:4) = 1.1*[-delv(2),delv(2)]; endif endif axvec = axmid + axdel; endfunction control-4.1.2/inst/PaxHeaders/covar.m0000644000000000000000000000007415012430645014526 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/covar.m0000644000175000017500000000434515012430645015723 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{p}, @var{q}] =} covar (@var{sys}, @var{w}) ## Return the steady-state covariance. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @item w ## Intensity of Gaussian white noise inputs which drive @var{sys}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item p ## Output covariance. ## @item q ## State covariance. ## @end table ## ## @seealso{lyap, dlyap} ## @end deftypefn ## Author: Lukas Reichlin ## 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 an LTI model"); endif if (! isstable (sys)) error ("covar: system must be stable"); endif [a, b, c, d] = ssdata (sys); if (isct (sys)) if (any (d(:))) 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); control-4.1.2/inst/PaxHeaders/mag2db.m0000644000000000000000000000007415012430645014550 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/mag2db.m0000644000175000017500000000264515012430645015746 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{db} =} mag2db (@var{mag}) ## Convert Magnitude to Decibels (dB). ## ## @strong{Inputs} ## @table @var ## @item mag ## Magnitude value(s). Both real-valued scalars and matrices are accepted. ## @end table ## ## @strong{Outputs} ## @table @var ## @item db ## Decibel (dB) value(s). ## @end table ## ## @seealso{db2mag} ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2012 ## Version: 0.1 function db = mag2db (mag) if (nargin != 1 || ! is_real_matrix (mag)) print_usage (); endif db = 20 .* log10 (mag); db(mag < 0) = NaN; endfunction %!assert (mag2db (100), 40); %!assert (mag2db (0.1), -20); control-4.1.2/inst/PaxHeaders/pid.m0000644000000000000000000000007415012430645014170 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/pid.m0000644000175000017500000000412215012430645015356 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{C} =} pid (@var{Kp}) ## @deftypefnx{Function File} {@var{C} =} pid (@var{Kp}, @var{Ki}) ## @deftypefnx{Function File} {@var{C} =} pid (@var{Kp}, @var{Ki}, @var{Kd}) ## @deftypefnx{Function File} {@var{C} =} pid (@var{Kp}, @var{Ki}, @var{Kd}, @var{Tf}) ## @deftypefnx{Function File} {@var{C} =} pid (@var{Kp}, @var{Ki}, @var{Kd}, @var{Tf}, @var{Ts}) ## Return the transfer function @var{C} of the @acronym{PID} controller ## in parallel form with first-order roll-off. ## With a valid @var{Ts} a discrete-time system is created. ## ## @example ## @group ## Ki Kd s ## C(s) = Kp + ---- + -------- ## s Tf s + 1 ## @end group ## @end example ## @end deftypefn ## Author: Lukas Reichlin ## Created: June 2015 ## Version: 0.1 ## TODO: dozens of options, ... ## If you wish to kill time with this repetitive task, ## I'm happy to add your work :-) function C = pid (Kp = 1, Ki = 0, Kd = 0, Tf = 0, Ts = 0) if (! is_real_scalar (Kp, Ki, Kd, Tf, Ts) || nargin > 5 ) print_usage (); endif if (Kd == 0) # catch cases like pid (2, 0, 0, 3) Tf = 0; endif if (Ki == 0) # minimal realization if num(3) == 0 and den(3) == 0 C = tf ([Kp*Tf+Kd, Kp], [Tf, 1], Ts); else C = tf ([Kp*Tf+Kd, Kp+Ki*Tf, Ki], [Tf, 1, 0], Ts); endif endfunction control-4.1.2/inst/PaxHeaders/MDSSystem.m0000644000000000000000000000007415012430645015244 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/MDSSystem.m0000644000175000017500000001312715012430645016437 0ustar00lilgelilge00000000000000## -*- texinfo -*- ## @deftypefn {Function File} {} MDSSystem () ## ## Run the example for robust control of a ## mass-damper-spring system. ## ## @end deftypefn ## ## Run @code{edit MDSSystem} to open the example file. % =============================================================================== % Robust Control of a Mass-Damper-Spring System Lukas Reichlin August 2011 % =============================================================================== % Reference: Gu, D.W., Petkov, P.Hr. and Konstantinov, M.M. % Robust Control Design with Matlab, Springer 2005 % =============================================================================== % Tabula Rasa clear all, close all, clc % =============================================================================== % System Model % =============================================================================== % +---------------+ % | d_m 0 0 | % +-----| 0 d_c 0 |<----+ % u_m | | 0 0 d_k | | y_m % u_c | +---------------+ | y_c % u_k | | y_k % | +---------------+ | % +---->| |-----+ % | G_nom | % u ----->| |-----> y % +---------------+ % Nominal Values m_nom = 3; % mass c_nom = 1; % damping coefficient k_nom = 2; % spring stiffness % Perturbations p_m = 0.4; % 40% uncertainty in the mass p_c = 0.2; % 20% uncertainty in the damping coefficient p_k = 0.3; % 30% uncertainty in the spring stiffness % State-Space Representation A = [ 0, 1 -k_nom/m_nom, -c_nom/m_nom ]; B1 = [ 0, 0, 0 -p_m, -p_c/m_nom, -p_k/m_nom ]; B2 = [ 0 1/m_nom ]; C1 = [ -k_nom/m_nom, -c_nom/m_nom 0, c_nom k_nom, 0 ]; C2 = [ 1, 0 ]; D11 = [ -p_m, -p_c/m_nom, -p_k/m_nom 0, 0, 0 0, 0, 0 ]; D12 = [ 1/m_nom 0 0 ]; D21 = [ 0, 0, 0 ]; D22 = [ 0 ]; inname = {'u_m', 'u_c', 'u_k', 'u'}; % input names outname = {'y_m', 'y_c', 'y_k', 'y'}; % output names G_nom = ss (A, [B1, B2], [C1; C2], [D11, D12; D21, D22], ... 'inputname', inname, 'outputname', outname); G = G_nom('y', 'u'); % extract output y and input u % =============================================================================== % Frequency Analysis of Uncertain System % =============================================================================== % Uncertainties: -1 <= delta_m, delta_c, delta_k <= 1 [delta_m, delta_c, delta_k] = ndgrid ([-1, 0, 1], [-1, 0, 1], [-1, 0, 1]); % Bode Plots of Perturbed Plants w = logspace (-1, 1, 100); % frequency vector Delta = arrayfun (@(m, c, k) diag ([m, c, k]), delta_m(:), delta_c(:), delta_k(:), 'uniformoutput', false); G_per = cellfun (@lft, Delta, {G_nom}, 'uniformoutput', false); figure (1) bode (G_per{:}, w) legend off % =============================================================================== % Mixed Sensitivity H-infinity Controller Design (S over KS Method) % =============================================================================== % +-------+ % +--------------------->| W_p |----------> e_p % | +-------+ % | +-------+ % | +---->| W_u |----------> e_u % | | +-------+ % | | +---------+ % | | ->| |-> % r + e | +-------+ u | | G_nom | % ----->(+)---+-->| K |----+--->| |----+----> y % ^ - +-------+ +---------+ | % | | % +-----------------------------------------+ % Weighting Functions s = tf ('s'); % transfer function variable W_p = 0.95 * (s^2 + 1.8*s + 10) / (s^2 + 8.0*s + 0.01); % performance weighting W_u = 10^-2; % control weighting % Synthesis K_mix = mixsyn (G, W_p, W_u); % mixed-sensitivity H-infinity synthesis % Interconnections L_mix = G * K_mix; % open loop T_mix = feedback (L_mix); % closed loop % =============================================================================== % H-infinity Loop-Shaping Design (Normalized Coprime Factor Perturbations) % =============================================================================== % Settings W1 = 8 * (2*s + 1) / (0.9*s); % precompensator W2 = 1; % postcompensator factor = 1.1; % suboptimal controller % Synthesis K_ncf = ncfsyn (G, W1, W2, factor); % positive feedback controller % Interconnections K_ncf = -K_ncf; % negative feedback controller L_ncf = G * K_ncf; % open loop T_ncf = feedback (L_ncf); % closed loop % =============================================================================== % Plot Results % =============================================================================== % Bode Plot figure (2) bode (K_mix, K_ncf) % Step Response figure (3) step (T_mix, T_ncf, 10) % step response for 10 seconds % =============================================================================== control-4.1.2/inst/PaxHeaders/mktito.m0000644000000000000000000000007415012430645014723 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/mktito.m0000644000175000017500000000677615012430645016132 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{P} =} mktito (@var{P}, @var{nmeas}, @var{ncon}) ## Partition @acronym{LTI} plant @var{P} for robust controller synthesis. ## If a plant is partitioned this way, one can omit the inputs @var{nmeas} ## and @var{ncon} when calling the functions @command{hinfsyn} and @command{h2syn}. ## ## @strong{Inputs} ## @table @var ## @item P ## Generalized plant. ## @item nmeas ## Number of measured outputs v. The last @var{nmeas} outputs of @var{P} are connected to the ## inputs of controller @var{K}. The remaining outputs z (indices 1 to p-nmeas) are used ## to calculate the H-2/H-infinity norm. ## @item ncon ## Number of controlled inputs u. The last @var{ncon} inputs of @var{P} are connected to the ## outputs of controller @var{K}. The remaining inputs w (indices 1 to m-ncon) are excited ## by a harmonic test signal. ## @end table ## ## @strong{Outputs} ## @table @var ## @item P ## Partitioned plant. The input/output groups and names are overwritten with designations ## according to [1]. ## @end table ## ## @strong{Block Diagram} ## @example ## @group ## ## min||N(K)|| N = lft (P, K) ## K norm ## ## +--------+ ## w = u1 ----->| |-----> z = y1 ## | P(s) | ## u = u2 +---->| |-----+ y = y2 ## | +--------+ | ## | | ## | +--------+ | ## +-----| K(s) |<----+ ## +--------+ ## ## +--------+ ## w = u1 ----->| N(s) |-----> z = y1 ## +--------+ ## @end group ## @end example ## ## @strong{Reference}@* ## [1] Skogestad, S. and Postlethwaite, I. (2005) ## @cite{Multivariable Feedback Control: Analysis and Design: ## Second Edition}. Wiley, Chichester, England. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2013 ## Version: 0.1 function P = mktito (P, nmeas, ncon) if (nargin != 3) print_usage (); endif if (! isa (P, "lti")) error ("mktito: first argument must be an LTI model"); endif [p, m] = size (P); if (! is_index (nmeas, p)) error ("mktito: second argument 'nmeas' invalid"); endif if (! is_index (ncon, m)) error ("mktito: third argument 'ncon' invalid"); endif outgroup = struct ("Y1", 1:p-nmeas, "Y2", p-nmeas+1:p); outname = vertcat (strseq ("y", 1:p)); ingroup = struct ("U1", 1:m-ncon, "U2", m-ncon+1:m); inname = vertcat (strseq ("u", 1:m)); P = set (P, "outgroup", outgroup, "ingroup", ingroup, ... "outname", outname, "inname", inname); endfunction function bool = is_index (idx, s) ## (idx < s) and not (idx <= s) because we need at least one Z or W bool = is_real_scalar (idx) && fix (idx) == idx && idx > 0 && idx < s; endfunction control-4.1.2/inst/PaxHeaders/issample.m0000644000000000000000000000007415012430645015231 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/issample.m0000644000175000017500000000630115012430645016420 0ustar00lilgelilge00000000000000## Copyright (C) 1996, 2000, 2002, 2003, 2004, 2005, 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. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{bool} =} issample (@var{ts}) ## @deftypefnx {Function File} {@var{bool} =} issample (@var{ts}, @var{flg}) ## Return true if @var{ts} is a valid sampling time. ## ## @strong{Inputs} ## @table @var ## @item ts ## Alleged sampling time to be tested. ## @item flg = 1 ## Accept real scalars @var{ts} > 0. Default Value. ## @item flg = 0 ## Accept real scalars @var{ts} >= 0. ## @item flg = -1 ## Accept real scalars @var{ts} > 0 and @var{ts} == -1. ## @item flg = -10 ## Accept real scalars @var{ts} >= 0 and @var{ts} == -1. ## @end table ## ## @strong{Outputs} ## @table @var ## @item bool ## True if conditions are met and false otherwise. ## @end table ## ## @end deftypefn ## Author: A. S. Hodel ## Created: July 1995 ## Adapted-By: Lukas Reichlin ## Date: September 2009 ## Version: 0.3 function bool = issample (tsam, flg = 1) if (nargin < 1 || nargin > 2) print_usage (); endif switch (flg) case 1 # discrete bool = is_real_scalar (tsam) && (tsam > 0); case 0 # continuous or discrete bool = is_real_scalar (tsam) && (tsam >= 0); case -1 # discrete, tsam unspecified bool = is_real_scalar (tsam) && (tsam > 0 || tsam == -1); case -10 # continuous or discrete, tsam unspecified bool = is_real_scalar (tsam) && (tsam >= 0 || tsam == -1); otherwise print_usage (); endswitch endfunction ## flg == 1 %!assert (issample (1)) %!assert (issample (pi)) %!assert (issample (0), false) %!assert (issample (-1), false) %!assert (issample (-1, 1), false) %!assert (issample ("a"), false) %!assert (issample (eye (2)), false) %!assert (issample (2+2i), false) ## flg == 0 %!assert (issample (1, 0)) %!assert (issample (0, 0)) %!assert (issample (-1, 0), false) %!assert (issample (pi, 0)) %!assert (issample ("b", 0), false) %!assert (issample (rand (3,2), 0), false) %!assert (issample (2+2i, 0), false) %!assert (issample (0+2i, 0), false) ## flg == -1 %!assert (issample (-1, -1)) %!assert (issample (0, -1), false) %!assert (issample (1, -1)) %!assert (issample (pi, -1)) %!assert (issample (-pi, -1), false) %!assert (issample ("b", -1), false) %!assert (issample (rand (3,2), -1), false) %!assert (issample (-2+2i, -1), false) ## errors %!error (issample (-1, "ab")) %!error (issample ()) %!error (issample (-1, -1, -1)) %!error (issample (1, pi)) %!error (issample (5, rand (2,3))) %!error (issample (0, 1+2i)) control-4.1.2/inst/PaxHeaders/sgrid.m0000644000000000000000000000007415012430645014524 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/sgrid.m0000644000175000017500000001743615012430645015726 0ustar00lilgelilge00000000000000## Copyright (C) 2019 Stefan Mátéfi-Tempfli ## ## This program is free software: you can redistribute it and/or modify it ## under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, but ## WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program. If not, see ## . ## -*- texinfo -*- ## @deftypefn {Function File} {} sgrid ## @deftypefnx {Function File} {} sgrid on ## @deftypefnx {Function File} {} sgrid off ## @deftypefnx {Function File} {} sgrid (@var{z}, @var{w}) ## @deftypefnx {Function File} {} sgrid (@var{hax}, @dots{}) ## Display an grid in the complex s-plane. ## ## Control the display of s-plane grid with : ## @itemize ## @item zeta lines corresponding to damping ratios and ## @item omega circles corresponding to undamped natural frequencies ## @end itemize ## ## The function state input may be either @qcode{"on"} or @qcode{"off"} ## for creating or removing the grid. If omitted, a new grid is created ## when it does not exist or the visibility of the current grid is toggled. ## ## The sgrid will automatically plot the grid lines at nice values or ## at constant values specified by two arguments : ## ## @example ## sgrid (@var{Z}, @var{W}) ## @end example ## ## @noindent ## where @var{Z} and @var{W} are : ## @itemize ## @item @var{Z} vector of constant zeta values to plot as lines ## @item @var{W} vector of constant omega values to plot as circles ## @end itemize ## ## Example of usage: ## @example ## sgrid on create the s-plane grid ## sgrid off remove the s-plane grid ## sgrid toggle the s-plane grid visibility ## sgrid ([0.3, 0.8, @dots{}], [10, 75, @dots{}]) create: ## @example ## @itemize ## @item zeta lines for 0.3, 0.8, @dots{} ## @item omega circles for 10, 75, @dots{} [rad/s] ## @end itemize ## @end example ## sgrid (@var{hax}, @qcode{"on"}) create the s-plane grid for the axis ## handle @var{hax} ## @end example ## ## @seealso{grid,zgrid} ## ## @end deftypefn ## Author: Stefan Mátéfi-Tempfli ## Created: 2019-01-24 function sgrid(varargin) [hax, varargin, nargs] = __plt_get_axis_arg__("sgrid", varargin{:}); if (nargs > 3) print_usage(); endif if (isempty(hax)) hax = gca(); endif hg = findobj(hax, "tag", "sgrid"); if (isempty(hg)) hg = hggroup(hax, "tag", "sgrid"); v_new = 1; else v_new = 0; endif v_z = []; v_w = []; if (nargs == 0) if (v_new) __sgrid_create__(hax, hg, v_z, v_w) else __sgrid_toggle__(hg) endif elseif (nargs == 1) arg1 = varargin{1}; if (! ischar(arg1)) error("sgrid: argument must be a string"); endif if (strcmpi(arg1, "off")) __sgrid_delete__(hg); elseif (strcmpi(arg1, "on")) if (v_new) __sgrid_create__(hax, hg, v_z, v_w) else v_user = get(hg, "userdata"); if (!isempty(v_user.z) | !isempty(v_user.w)) __sgrid_delete_handles__(hg); __sgrid_create__(hax, hg, v_z, v_w) elseif (strcmp(get(hg, "visible"), "off")) set(hg, "visible", "on"); endif endif else print_usage(); endif else v_z = varargin{1}; if (! isnumeric(v_z)) error ("sgrid: Z argument (1) must be numeric"); endif if (any(v_z < 0 | v_z > 1)) error("sgrid: Z argument (1) must have values betwenn 0 .. 1"); endif v_w = varargin{2}; if (! isnumeric(v_w)) error("sgrid: W argument (2) must be numeric"); endif if (any(v_w <= 0)) error("sgrid: W argument (1) must have positive values larger than 0"); endif if (v_new) __sgrid_create__(hax, hg,v_z, v_w) else v_user = get(hg, "userdata"); if (!isequal(v_z, v_user.z) || !isequal(v_w, v_user.w)) __sgrid_delete_handles__(hg); __sgrid_create__(hax, hg, v_z, v_w) elseif (strcmp(get(hg, "visible"), "off")) set(hg, "visible", "on"); endif endif endif endfunction ##---------------------------------------------------- function __sgrid_create__(hax, hg, v_z, v_w) hold on; box on; v_user.z = v_z; v_user.w = v_w; set(hg, "userdata", v_user); v_axis = axis(hax); if ((v_axis(2) < 0.15 * (v_axis(2) - v_axis(1)))) v_axis(2) = 0.15 * (v_axis(2) - v_axis(1)); axis(hax,v_axis); endif v_daxis = [v_axis(2) - v_axis(1), v_axis(4) - v_axis(3)]; v_1d5axis = 0.015 * v_daxis; v_taxis = [v_axis(1) + v_1d5axis(1); v_1d5axis(1); v_axis(3) + v_1d5axis(2); v_axis(4) - v_1d5axis(2)]; v_max = max (abs(v_axis)) * sqrt(2); v_rd = v_max/14; v_x = ceil(log10 (v_rd) - 1); v_p10 = 10^v_x; v_d = ceil(v_rd/v_p10) * v_p10; if (isempty(v_w)) v_w = v_d:v_d:v_max; endif v_w_x = v_taxis(2) * ones(size(v_w)); if ((0.1 < v_d) & (v_d < 1000)) if (v_d >= 1) v_w_str = cellstr(int2str(v_w(:))); else v_w_str = cellstr(num2str(v_w(:),"%2.2f")); endif else v_w_str = cellstr(num2str(v_w(:),"%1.2e")); endif for (i = 1:length(v_w)) v_sgrid.w(i) = plot(v_w(i)*cos(pi/2:0.01:3*pi/2), v_w(i)*sin(pi/2:0.01:3*pi/2), ":k", "linewidth", 0.6, "parent", hg); endfor idx = sum(v_w <= v_taxis(4)); for (i = 1:idx) text(v_w_x(i), v_w(i), v_w_str{i}, "parent", hg); endfor text(v_taxis(2), 0, "0 rad/s", "parent", hg); idx = sum(v_w <= -v_taxis(3)); for (i = 1:idx) text(v_w_x(i), -v_w(i), v_w_str{i}, "parent", hg); endfor if (isempty(v_z)) v_z = sin(linspace(pi/18, 8*pi/18, 10)); endif v_z_phi = [(pi/2 + asin(v_z(v_z != 0))), ... (-pi/2 -asin(v_z((v_z != 0)&(v_z != 1))))]; v_z_px = v_max * cos(v_z_phi); v_z_py = v_max * sin(v_z_phi); v_z_str = cellstr(num2str(abs(sin(v_z_phi(:) - pi/2)),"%1.2f")); for (i = 1:length(v_z_phi)) plot([0 v_z_px(i)], [0 v_z_py(i)], ":k", "linewidth", 0.6, "parent", hg); pry = v_taxis(1) * tan(v_z_phi(i)); if (pry > v_taxis(4)) v_z_lc = v_taxis(4) * [cot(v_z_phi(i)) 1]; v_z_lc(1) += -v_1d5axis(1); elseif (pry < v_taxis(3)) v_z_lc = v_taxis(3) * [cot(v_z_phi(i)) 1]; v_z_lc(1) += -v_1d5axis(1); else v_z_lc = v_taxis(1) * [1 tan(v_z_phi(i))]; endif text (v_z_lc(1), v_z_lc(2), v_z_str{i}, "parent", hg); endfor plot([0 0], [0 v_max], "-k", "linewidth", 0.3, "parent", hg); plot([0 0], [0 -v_max], "-k", "linewidth", 0.3, "parent", hg); hold off; endfunction ##---------------------------------------------------- function __sgrid_delete__(hg) delete(hg); endfunction ##---------------------------------------------------- function __sgrid_delete_handles__(hg) delete(get(hg, "children")); endfunction ##---------------------------------------------------- function __sgrid_toggle__(hg) if (strcmp(get(hg, "visible"), "on")) set(hg, "visible", "off"); elseif (strcmp(get(hg, "visible"), "off")) set(hg, "visible", "on"); endif endfunction %!demo %! clf; %! num = 1; den = [1 4 5 0]; %! sys = tf(num, den); %! rlocus(sys); %! sgrid on; %!demo %! clf; %! num = [1 3]; den = [1 5 20 16 0]; %! sys = tf(num, den); %! rlocus(sys); %! hfig = get(0, "currentfigure"); %! hax = get(hfig, "currentaxes"); %! sgrid(hax, "on"); %!demo %! clf; %! num = 1; den = [1 4 5 0]; %! sys = tf(num, den); %! rlocus(sys); %! sgrid([0.5 0.7 0.89], [1 1.66 2.23]); control-4.1.2/inst/PaxHeaders/__modred_check_equil__.m0000644000000000000000000000007415012430645020016 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__modred_check_equil__.m0000644000175000017500000000211415012430645021203 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## check equilibration for model reduction commands ## Author: Lukas Reichlin ## Created: November 2011 ## Version: 0.1 function scaled = __modred_check_equil__ (equil) if (isscalar (equil)) scaled = ! logical (equil); else error ("modred: property 'equil' must be a logical value"); endif endfunction control-4.1.2/inst/PaxHeaders/ctrb.m0000644000000000000000000000007415012430645014346 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/ctrb.m0000644000175000017500000000427115012430645015541 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 Lukas F. Reichlin ## Copyright (C) 2009 Luca Favatella ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{co} =} ctrb (@var{sys}) ## @deftypefnx {Function File} {@var{co} =} ctrb (@var{a}, @var{b}) ## Return controllability matrix. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @item a ## State matrix (n-by-n). ## @item b ## Input matrix (n-by-m). ## @end table ## ## @strong{Outputs} ## @table @var ## @item co ## Controllability matrix. ## @end table ## ## @strong{Equation} ## @iftex ## @tex ## $$ C_o = [ B \\ \\ AB \\ \\ A^2B \\ \\ldots \\ A^{n-1}B ] $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## 2 n-1 ## Co = [ B AB A B ... A B ] ## @end example ## @end ifnottex ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function co = ctrb (a, b) if (nargin == 1) # ctrb (sys) if (! isa (a, "lti")) error ("ctrb: argument must be an lti system"); endif [a, b] = ssdata (a); elseif (nargin == 2) # ctrb (a, b) if (! is_real_square_matrix (a) || ! is_real_matrix (b) || rows (a) != rows (b)) error ("ctrb: invalid arguments (a, b)"); endif else print_usage (); endif n = rows (a); # number of states k = 0:n-1; # exponents for a tmp = arrayfun (@(x) a^x*b, k, "uniformoutput", false); co = horzcat (tmp{:}); endfunction %!assert (ctrb ([1, 0; 0, -0.5], [8; 8]), [8, 8; 8, -4]); control-4.1.2/inst/PaxHeaders/damp.m0000644000000000000000000000007415012430645014335 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/damp.m0000644000175000017500000001561015012430645015527 0ustar00lilgelilge00000000000000## Copyright (C) 2017 Mark Bronsfeld ## ## This program is free software: you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} damp(@var{sys}) ## @deftypefnx {Function File} {[@var{Wn}, @var{zeta}] =} damp(@var{sys}) ## @deftypefnx {Function File} {[@var{Wn}, @var{zeta}, @var{P}] =} damp(@var{sys}) ## Calculate natural frequencies, damping ratios and poles. ## ## If no output is specified, display overview table containing poles, ## magnitude (if @var{sys} is a discrete-time model), damping ratios, natural ## frequencies and time constants. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @end table ## ## @strong{Outputs} ## @table @var ## @item Wn ## Natural frequencies of each pole of @var{sys} (in increasing order). ## The frequency unit is rad/s (radians per second). ## If @var{sys} is a discrete-time model with specified sample time, @var{Wn} ## contains the natural frequencies of the equivalent continuous-time poles ## (see Algorithms). If @var{sys} has an unspecified sample time ## (@var{tsam =} -1), @var{tsam =} 1 is used to calculate @var{Wn}. ## @item zeta ## Damping ratios of each pole of @var{sys} (in the same order as @var{Wn}). ## If @var{sys} is a discrete-time model with specified sample time, ## @var{zeta} contains the damping ratios of the equivalent continuous-time ## poles (see Algorithms). If @var{sys} has an unspecified sample time ## (@var{tsam =} -1), @var{tsam =} 1 is used to calculate @var{zeta}. ## @item P ## Poles of @var{sys} (in the same order as @var{Wn}). ## @end table ## ## @strong{Algorithm}@* ## @table @var ## @item Pole ## Poles s (or z for discrete-time models) are calculated via @command{pole} ## and resorted in order of increasing natural frequency. ## @item Equivalent continuous-time pole ## s = log (z) / sys.tsam (discrete-time models only) ## @item Magnitude ## mag = abs (z) (discrete-time models only) ## @item Natural Frequency ## Wn = abs (s) ## @item Damping ratio ## zeta = -cos (arg (s)) ## @item Time constant ## tau = 1 / (Wn * zeta) ## @end table ## ## @seealso{dsort, eig, esort, pole, pzmap, zero} ## @end deftypefn ## Author: Mark Bronsfeld ## Created: January 2017 ## Version: 0.1 function [Wn_out, zeta, P] = damp (sys) if (nargin == 1) # damp (sys) if (! (isa (sys, "lti") || issquare (sys))) error ("damp: argument must be an LTI system"); endif else print_usage (); endif P = pole (sys); # Poles ## Distinguish between system/state matrices, continuous- and ... ## discrete-time models if ((! (isa (sys, "lti")) && issquare (sys)) || (isct (sys))) s = P; elseif (isdt (sys)) if (sys.tsam == -1) # If sample time is unspecified... s = log (P); # ...assume 1 second: log (P) / 1 else s = log (P) ./ sys.tsam; endif mag = abs (P); # Magnitude endif Wn = abs (s); # Frequencies (rad / seconds) ## Sort all vectors in order of increasing natural frequency [Wn, ndx] = sort (Wn); P = P (ndx); s = s (ndx); zeta = -cos (arg (s)); # Damping tau = 1 ./ (Wn .* zeta); # Time constant (seconds) ## Suppress "ans" output if no output specified (only assign "Wn_out" ... ## if any output specified) if (nargout > 0) Wn_out = Wn; ## Display overview table when no output specified elseif (nargout == 0) ## Type conversion and formatting to exponential format P = num2str (P, '%1.2e'); zeta = num2str (zeta, '%1.2e'); Wn = num2str (Wn, '%1.2e'); tau = num2str (tau, '%1.2e'); ## Construct columns of overview table Pole = [['Pole'; ' '; ' ']; P]; Damping = [['Damping'; ' '; ' ']; zeta]; Frequency = [['Frequency'; '(rad/seconds)'; ' ']; Wn]; TimeConstant = [['Time Constant'; '(seconds)'; ' ']; tau]; ## Construct overview table - distinguish between system/state ... ## matrices, continuous- and discrete-time models if ((! (isa (sys, "lti")) && issquare (sys)) || (isct (sys))) ## Overview table overview_table = [repmat(' ',rows(Pole),3) Pole ... repmat(' ',rows(Pole),4) Damping ... repmat(' ',rows(Pole),4) Frequency ... repmat(' ',rows(Pole),4) TimeConstant]; elseif (isdt (sys)) mag = mag (ndx); # Sort vector in order of increasing natural frequency mag = num2str (mag, '%1.2e'); # Type conversion and formatting to ... # exponential format Magnitude = [['Magnitude'; ' '; ' ']; mag]; # Construct additional ... # column of overview table ## Overview table overview_table = [repmat(' ',rows(Pole),3) Pole ... repmat(' ',rows(Pole),4) Magnitude ... repmat(' ',rows(Pole),4) Damping .... repmat(' ',rows(Pole),4) Frequency .... repmat(' ',rows(Pole),4) TimeConstant]; endif disp (overview_table); # Display overview table endif endfunction ## Test system/state matrix %!test %! A = [-1, 0, 0; %! 0, -2, 0; %! 0, 0, -3 ]; %! %! Wn_exp = [1; %! 2; %! 3 ]; %! %! zeta_exp = [1; %! 1; %! 1 ]; %! %! P_exp = [-1; %! -2; %! -3 ]; %! %! [Wn_obs, zeta_obs, P_obs] = damp (ss (A, ones (3, 1))); %! %! assert (Wn_obs, Wn_exp, 0); %! assert (zeta_obs, zeta_exp, 0); %! assert (P_obs, P_exp, 0); ## Test continuous-time model %!test %! H = tf ([2, 5, 1], [1, 2, 3]); %! %! Wn_exp = [1.7321; %! 1.7321 ]; %! %! zeta_exp = [0.5774; %! 0.5774 ]; %! %! P_exp = [-1.0000 + 1.4142i; %! -1.0000 - 1.4142i ]; %! %! [Wn_obs, zeta_obs, P_obs] = damp (H); %! %! assert (Wn_obs, Wn_exp, 1e-4); %! assert (zeta_obs, zeta_exp, 1e-4); %! assert (P_obs, P_exp, 1e-4); ## Test discrete-time model %!test %! H = tf ([5, 3, 1], [1, 6, 4, 4], 0.01); %! %! Wn_exp = [193.4924; %! 193.4924; %! 356.5264 ]; %! %! zeta_exp = [ 0.0774; %! 0.0774; %! -0.4728 ]; %! %! P_exp = [-0.3020 + 0.8063i; %! -0.3020 - 0.8063i; %! -5.3961 + 0.0000i ]; %! %! [Wn_obs, zeta_obs, P_obs] = damp (H); %! %! assert (Wn_obs, Wn_exp, 1e-4); %! assert (zeta_obs, zeta_exp, 1e-4); %! assert (P_obs, P_exp, 1e-4); control-4.1.2/inst/PaxHeaders/moen4.m0000644000000000000000000000007415012430645014436 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/moen4.m0000644000175000017500000045143015012430645015634 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{sys}, @var{x0}, @var{info}] =} moen4 (@var{dat}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}, @var{info}] =} moen4 (@var{dat}, @var{n}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}, @var{info}] =} moen4 (@var{dat}, @var{opt}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}, @var{info}] =} moen4 (@var{dat}, @var{n}, @var{opt}, @dots{}) ## Estimate state-space model using combined subspace method: ## @acronym{MOESP} algorithm for finding the matrices A and C, ## and @acronym{N4SID} algorithm for finding the matrices B and D. ## If no output arguments are given, the singular values are ## plotted on the screen in order to estimate the system order. ## ## @strong{Inputs} ## @table @var ## @item dat ## iddata set containing the measurements, i.e. time-domain signals. ## @item n ## The desired order of the resulting state-space system @var{sys}. ## If not specified, @var{n} is chosen automatically according ## to the singular values and tolerances. ## @item @dots{} ## Optional pairs of keys and values. @code{'key1', value1, 'key2', value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## ## @strong{Outputs} ## @table @var ## @item sys ## Discrete-time state-space model. ## @item x0 ## Initial state vector. If @var{dat} is a multi-experiment dataset, ## @var{x0} becomes a cell vector containing an initial state vector ## for each experiment. ## @item info ## Struct containing additional information. ## @table @var ## @item info.K ## Kalman gain matrix. ## @item info.Q ## State covariance matrix. ## @item info.Ry ## Output covariance matrix. ## @item info.S ## State-output cross-covariance matrix. ## @item info.L ## Noise variance matrix factor. LL'=Ry. ## @end table ## @end table ## ## ## ## @strong{Option Keys and Values} ## @table @var ## @item 'n' ## The desired order of the resulting state-space system @var{sys}. ## @var{s} > @var{n} > 0. ## ## @item 's' ## The number of block rows @var{s} in the input and output ## block Hankel matrices to be processed. @var{s} > 0. ## In the MOESP theory, @var{s} should be larger than @var{n}, ## the estimated dimension of state vector. ## ## @item 'alg', 'algorithm' ## Specifies the algorithm for computing the triangular ## factor R, as follows: ## @table @var ## @item 'C' ## Cholesky algorithm applied to the correlation ## matrix of the input-output data. Default method. ## @item 'F' ## Fast QR algorithm. ## @item 'Q' ## QR algorithm applied to the concatenated block ## Hankel matrices. ## @end table ## ## @item 'tol' ## Absolute tolerance used for determining an estimate of ## the system order. If @var{tol} >= 0, the estimate is ## indicated by the index of the last singular value greater ## than or equal to @var{tol}. (Singular values less than @var{tol} ## are considered as zero.) When @var{tol} = 0, an internally ## computed default value, @var{tol} = @var{s}*@var{eps}*SV(1), is used, ## where SV(1) is the maximal singular value, and @var{eps} is ## the relative machine precision. ## When @var{tol} < 0, the estimate is indicated by the ## index of the singular value that has the largest ## logarithmic gap to its successor. Default value is 0. ## ## @item 'rcond' ## The tolerance to be used for estimating the rank of ## matrices. If the user sets @var{rcond} > 0, the given value ## of @var{rcond} is used as a lower bound for the reciprocal ## condition number; an m-by-n matrix whose estimated ## condition number is less than 1/@var{rcond} is considered to ## be of full rank. If the user sets @var{rcond} <= 0, then an ## implicitly computed, default tolerance, defined by ## @var{rcond} = m*n*@var{eps}, is used instead, where @var{eps} is the ## relative machine precision. Default value is 0. ## ## @item 'confirm' ## Specifies whether or not the user's confirmation of the ## system order estimate is desired, as follows: ## @table @var ## @item true ## User's confirmation. ## @item false ## No confirmation. Default value. ## @end table ## ## @item 'noiseinput' ## The desired type of noise input channels. ## @table @var ## @item 'n' ## No error inputs. Default value. ## @iftex ## @tex ## $$ x_{k+1} = A x_k + B u_k $$ ## $$ y_k = C x_k + D u_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## x[k+1] = A x[k] + B u[k] ## y[k] = C x[k] + D u[k] ## @end example ## @end ifnottex ## ## @item 'e' ## Return @var{sys} as a (p-by-m+p) state-space model with ## both measured input channels u and noise channels e ## with covariance matrix @var{Ry}. ## @iftex ## @tex ## $$ x_{k+1} = A x_k + B u_k + K e_k $$ ## $$ y_k = C x_k + D u_k + e_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## x[k+1] = A x[k] + B u[k] + K e[k] ## y[k] = C x[k] + D u[k] + e[k] ## @end example ## @end ifnottex ## ## @item 'v' ## Return @var{sys} as a (p-by-m+p) state-space model with ## both measured input channels u and white noise channels v ## with identity covariance matrix. ## @iftex ## @tex ## $$ x_{k+1} = A x_k + B u_k + K L v_k $$ ## $$ y_k = C x_k + D u_k + L v_k $$ ## $$ e = L v, \\ L L^T = R_y $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## x[k+1] = A x[k] + B u[k] + K L v[k] ## y[k] = C x[k] + D u[k] + L v[k] ## e = L v, L L' = Ry ## @end example ## @end ifnottex ## ## @item 'k' ## Return @var{sys} as a Kalman predictor for simulation. ## @iftex ## @tex ## $$ \\widehat{x}_{k+1} = A \\widehat{x}_k + B u_k + K (y_k - \\widehat{y}_k) $$ ## $$ \\widehat{y}_k = C \\widehat{x}_k + D u_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## ^ ^ ^ ## x[k+1] = A x[k] + B u[k] + K(y[k] - y[k]) ## ^ ^ ## y[k] = C x[k] + D u[k] ## @end example ## @end ifnottex ## ## @iftex ## @tex ## $$ \\widehat{x}_{k+1} = (A-KC) \\widehat{x}_k + (B-KD) u_k + K y_k $$ ## $$ \\widehat{y}_k = C \\widehat{x}_k + D u_k + 0 y_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## ^ ^ ## x[k+1] = (A-KC) x[k] + (B-KD) u[k] + K y[k] ## ^ ^ ## y[k] = C x[k] + D u[k] + 0 y[k] ## @end example ## @end ifnottex ## @end table ## @end table ## ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT IB01AD, IB01BD and IB01CD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: May 2012 ## Version: 0.1 function [sys, x0, info] = moen4 (varargin) if (nargin == 0) print_usage (); endif if (nargout == 0) __slicot_identification__ ("moen4", nargout, varargin{:}); else [sys, x0, info] = __slicot_identification__ ("moen4", nargout, varargin{:}); endif endfunction %!shared SYS, X0, INFO, Ae, Be, Ce, De, Ke, Qe, Rye, Se, X0e %! %! Y = [ 4.7661 5.5451 5.8503 5.3766 4.8833 5.4865 3.5378 5.3155 6.0530 4.3729 %! 4.7637 5.1886 5.9236 5.6818 4.8858 5.1495 3.5549 5.5329 6.0799 4.7417 %! 4.8394 4.8833 5.9212 5.8235 4.8931 4.8442 3.4938 5.4450 6.1287 5.0884 %! 5.0030 4.6000 5.9773 5.9529 4.7148 4.5414 3.4474 5.3961 6.0799 5.1861 %! 5.0176 4.2704 5.7405 6.0628 4.4511 4.2679 3.4401 5.2740 6.1678 5.0372 %! 5.0567 4.0384 5.3888 6.0897 4.2337 4.0604 3.4083 5.0274 6.1947 4.7856 %! 5.1544 3.8381 5.0005 6.0750 4.0433 3.9602 3.4108 4.7441 6.2362 4.5634 %! 5.3619 3.7112 4.8491 6.0262 3.8650 3.7893 3.4523 4.6684 6.0530 4.5341 %! 5.4254 3.5915 4.9444 5.9944 3.7576 3.6428 3.6818 4.6513 5.6525 4.7050 %! 5.5695 3.5353 5.1739 6.0775 3.6696 3.5256 4.0604 4.5146 5.2740 4.7417 %! 5.6818 3.4865 5.3693 5.8577 3.5939 3.4987 4.4413 4.2679 4.8589 4.6489 %! 5.7429 3.4767 5.4474 5.7014 3.5475 3.4547 4.8540 4.2606 4.5341 4.4315 %! 5.8039 3.4254 5.6037 5.7307 3.5060 3.4083 5.1544 4.2630 4.4560 4.2386 %! 5.9187 3.3815 5.7307 5.7844 3.4547 3.3790 5.4254 4.1898 4.6196 4.0652 %! 5.8210 3.3693 5.8503 5.8235 3.3986 3.3766 5.5964 4.2777 4.8662 3.9431 %! 5.4474 3.3644 5.9798 5.8943 3.3619 3.3619 5.5866 4.6000 5.1177 3.8113 %! 5.0616 3.3473 5.9920 5.7624 3.3400 3.3595 5.3546 4.9322 5.1666 3.6916 %! 4.6293 3.3815 6.0848 5.4157 3.3742 3.3693 5.0274 5.2838 5.0567 3.6525 %! 4.2679 3.4206 5.9407 4.9615 3.5207 3.3986 4.8638 5.5280 5.0030 3.8259 %! 4.0115 3.4132 5.8039 4.5952 3.7136 3.5793 4.7612 5.7405 5.0982 4.2240 %! 3.8503 3.4523 5.7917 4.3314 3.7576 3.9480 4.5707 5.8748 5.3253 4.4242 %! 3.7112 3.6355 5.6037 4.2972 3.7795 4.4120 4.3681 5.9554 5.5671 4.4291 %! 3.5695 4.0384 5.2643 4.5829 3.6965 4.5854 4.3974 5.9920 5.4670 4.3192 %! 3.5182 4.3754 4.9468 4.8613 3.7771 4.5146 4.5732 5.8455 5.2521 4.1385 %! 3.6525 4.7270 4.6196 5.1739 3.8870 4.3436 4.8418 5.5280 4.9468 3.9651 %! 3.8186 5.0567 4.5146 5.1666 3.9041 4.1556 5.2032 5.0616 4.8809 3.8870 %! 3.8626 5.2985 4.4340 4.9199 3.8503 3.9847 5.4523 4.7344 4.9810 3.8015 %! 4.0115 5.5329 4.2850 4.6074 3.9651 4.0433 5.6525 4.5341 5.2252 3.7014 %! 4.3534 5.4670 4.1214 4.3705 4.2826 4.3070 5.8552 4.5341 5.4596 3.6403 %! 4.7050 5.1959 3.9456 4.1825 4.5219 4.4218 5.9065 4.6977 5.7234 3.7673 %! 5.0836 4.8858 3.9847 4.0384 4.7148 4.3534 5.9529 4.7441 5.7917 4.1507 %! 5.3449 4.7637 4.2191 4.1458 4.9712 4.2240 5.8284 4.6196 5.9065 4.6489 %! 5.2740 4.8760 4.5463 4.4315 5.2203 4.0530 5.7917 4.6440 5.9920 4.9908 %! 5.1275 5.0420 4.8735 4.5561 5.5329 3.9407 5.7991 4.8320 5.8357 5.0884 %! 4.7612 5.2838 5.1544 4.4804 5.6525 3.8381 5.8137 5.1324 5.5280 5.0225 %! 4.4511 5.4914 5.3888 4.3754 5.7820 3.7307 5.8772 5.4108 5.1422 4.7832 %! 4.2215 5.5964 5.6135 4.3705 5.9554 3.6525 5.9554 5.6257 4.7759 4.6855 %! 4.0457 5.6721 5.8357 4.5585 6.0359 3.6110 5.7820 5.6037 4.4902 4.6660 %! 3.8748 5.7722 5.8845 4.8589 6.1190 3.5646 5.5182 5.3155 4.2362 4.7075 %! 3.7307 5.8308 5.9554 4.8955 6.1336 3.4963 5.1275 4.9615 4.0237 4.9126 %! 3.6623 5.9334 5.7624 4.7417 6.1532 3.4621 4.7637 4.6196 3.8870 5.1959 %! 3.5768 5.8992 5.4596 4.7441 6.1922 3.4547 4.4926 4.3583 3.7527 5.4157 %! 3.5427 5.9358 5.0616 4.8760 6.1434 3.4254 4.2337 4.1556 3.6818 5.6232 %! 3.4792 5.8943 4.7075 5.1055 6.1678 3.3790 4.0115 4.0335 3.8064 5.7405 %! 3.4547 5.9187 4.4584 5.2398 5.9920 3.4328 3.8552 3.8870 4.1458 5.8992 %! 3.3595 5.9944 4.2679 5.5182 5.6525 3.6232 3.6916 3.7722 4.6000 5.9285 %! 3.2985 5.9578 4.0530 5.6525 5.4596 3.9749 3.6355 3.6403 5.0030 6.0506 %! 3.2252 6.0311 3.9431 5.7234 5.4376 4.3803 3.8186 3.5329 5.3033 6.1532 %! 3.2008 6.0628 3.8259 5.8552 5.3400 4.7148 4.1556 3.4352 5.5524 5.9651 %! 3.2252 6.0408 3.9676 5.9627 5.0982 5.0738 4.5903 3.4279 5.6159 5.5866 %! 3.2276 6.0970 4.2801 5.9847 4.7856 5.3693 4.9883 3.4230 5.5231 5.3815 %! 3.2740 6.1239 4.4804 5.9847 4.4926 5.6037 5.0762 3.3986 5.6110 5.3717 %! 3.4572 6.1629 4.4926 6.0555 4.2362 5.7453 4.9077 3.6037 5.7136 5.4865 %! 3.8674 6.0408 4.3900 6.0628 4.0677 5.6525 4.6489 4.0237 5.8455 5.5671 %! 4.3217 5.8455 4.1971 6.0555 3.9334 5.4010 4.3778 4.4511 5.8992 5.8210 %! 4.4926 5.7722 4.1116 6.0701 3.8235 5.0152 4.2166 4.7930 5.9944 5.9138 %! 4.4315 5.7991 3.9822 5.7844 3.7307 4.7099 4.2875 4.9029 6.0921 5.9944 %! 4.2435 5.9236 3.8674 5.4401 3.6110 4.4169 4.5903 4.7808 6.0921 6.0115 %! 4.0506 5.9285 3.7673 5.0567 3.5646 4.2362 4.8467 4.5903 6.1434 5.9993 %! 3.8577 6.0018 3.8723 4.9419 3.5500 4.2362 5.1397 4.3363 6.1532 6.0188 %! 3.7307 6.0018 4.2362 5.0103 3.5573 4.2484 5.3888 4.1458 6.2337 5.8210 %! 3.7917 6.0604 4.6635 5.1348 3.5134 4.2215 5.6892 4.2166 6.1873 5.7282 %! 3.9212 5.8821 4.9712 5.3131 3.5158 4.2972 5.8845 4.4340 6.0140 5.7405 %! 3.9554 5.5109 5.0665 5.4792 3.6941 4.5903 6.0433 4.7148 5.8357 5.7649 %! 3.8479 5.3229 4.9029 5.6232 4.0726 4.8931 6.1703 5.0982 5.7746 5.8821 %! 3.7258 5.3717 4.6757 5.5622 4.4804 5.1348 6.2118 5.3595 5.6867 5.9260 %! 3.6110 5.4547 4.3925 5.3302 4.7050 5.4279 6.2508 5.5695 5.5378 5.7502 %! 3.7160 5.4376 4.0994 5.0103 4.6123 5.3790 6.2093 5.7722 5.3278 5.4157 %! 4.0921 5.1593 4.1141 4.6660 4.3851 5.3644 6.0140 5.9212 5.0543 4.9956 %! 4.4804 4.9029 4.3265 4.4145 4.2020 5.4523 5.7014 6.0555 4.7002 4.8613 %! 4.8149 4.5878 4.6440 4.2020 4.0262 5.5671 5.4694 5.9627 4.3949 4.9029 %! 5.0543 4.5024 4.9712 4.0482 3.9041 5.6721 5.4792 5.6428 4.1800 5.1031 %! 5.3033 4.5952 5.1593 4.0799 3.7746 5.7698 5.5573 5.4352 4.0433 5.3644 %! 5.4865 4.8247 5.3888 4.1898 3.6916 5.8308 5.7282 5.3888 3.8772 5.5964 %! 5.6721 5.0640 5.5768 4.1312 3.8455 5.9236 5.8821 5.5378 3.7527 5.7527 %! 5.7795 5.2716 5.6525 4.0042 4.2020 5.9651 5.9847 5.6818 3.7282 5.8455 %! 5.7991 5.4670 5.8039 3.9163 4.5854 6.0579 5.9016 5.7014 3.8699 5.9285 %! 5.6648 5.6159 5.9138 3.9602 4.9029 6.0506 5.5817 5.6159 4.2069 6.0066 %! 5.2911 5.5280 5.8870 4.1996 5.2569 6.0726 5.3717 5.6672 4.3558 5.8406 %! 4.8809 5.2545 5.7991 4.6245 5.5109 6.1116 5.4181 5.7405 4.4267 5.5182 %! 4.5585 4.8833 5.7307 4.8833 5.6403 6.0701 5.5109 5.8039 4.4535 5.1739 %! 4.1849 4.5170 5.7624 5.1373 5.8430 5.8967 5.6672 5.8821 4.5219 4.7392 %! 3.8894 4.1971 5.8137 5.3790 5.9749 5.7551 5.7917 5.9505 4.3925 4.4584 %! 3.7087 4.0018 5.8210 5.6232 5.9358 5.7185 5.6989 6.0726 4.1556 4.4267 %! 3.6232 3.8064 5.9285 5.7624 5.8210 5.8210 5.4840 6.1483 3.9651 4.6025 %! 3.5695 3.9041 6.0140 5.8333 5.5280 6.0018 5.1544 6.1165 3.8772 4.8223 %! 3.7185 3.9236 5.7649 5.6867 5.1715 6.0018 4.9810 6.1776 3.9700 5.1837 %! 4.0335 3.8699 5.4132 5.3668 4.8101 5.9016 5.0616 6.2020 4.2582 5.4303 %! 4.4120 3.8064 5.0982 5.2252 4.4535 5.5573 5.1959 6.2069 4.4218 5.6525 %! 4.6293 3.7209 4.6782 5.2398 4.3803 5.1739 5.3595 5.9920 4.3363 5.8210 %! 4.5585 3.8186 4.3729 5.3546 4.5659 4.8003 5.6159 5.5646 4.2997 5.7063 %! 4.3949 4.1409 4.3925 5.5085 4.8052 4.4315 5.7624 5.1788 4.3925 5.3693 %! 4.1800 4.5292 4.5903 5.5964 5.1251 4.1947 5.8577 4.9981 4.6757 5.0274 %! 4.1971 4.8052 4.9199 5.7527 5.3546 4.0066 5.9480 5.0518 4.7612 4.7050 %! 4.4315 5.0860 5.0176 5.8748 5.5891 3.8503 5.8357 5.2325 4.6587 4.4145 %! 4.7148 5.3400 4.8589 5.9065 5.7649 3.7478 5.7063 5.4840 4.4902 4.1458 %! 4.9615 5.5329 4.6757 5.8943 5.9236 3.6428 5.4987 5.6867 4.3070 3.9651 %! 5.3009 5.5768 4.6196 5.7429 5.9407 3.5915 5.1886 5.8992 4.1263 4.0335 %! 5.5671 5.6672 4.8345 5.4474 5.8577 3.5695 5.1177 5.8699 3.9724 4.3729 %! 5.6818 5.7917 5.0909 5.0250 5.6941 3.5280 5.1910 5.9773 4.0775 4.6831 ](:); %! %! %! %! U = [ 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 3.4100 6.4100 6.4100 3.4100 %! 3.4100 3.4100 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 3.4100 %! 6.4100 3.4100 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 3.4100 %! 6.4100 3.4100 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 3.4100 %! 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 3.4100 6.4100 3.4100 6.4100 %! 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 6.4100 3.4100 3.4100 6.4100 %! 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 6.4100 3.4100 3.4100 3.4100 %! 6.4100 3.4100 6.4100 3.4100 3.4100 3.4100 6.4100 3.4100 3.4100 3.4100 %! 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 6.4100 6.4100 3.4100 3.4100 %! 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 6.4100 3.4100 6.4100 3.4100 %! 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 6.4100 3.4100 6.4100 3.4100 %! 3.4100 3.4100 6.4100 6.4100 3.4100 3.4100 6.4100 6.4100 6.4100 3.4100 %! 3.4100 3.4100 6.4100 6.4100 3.4100 3.4100 3.4100 6.4100 6.4100 3.4100 %! 3.4100 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 3.4100 3.4100 %! 3.4100 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 3.4100 3.4100 %! 3.4100 3.4100 3.4100 3.4100 6.4100 3.4100 6.4100 6.4100 6.4100 6.4100 %! 3.4100 3.4100 6.4100 3.4100 3.4100 6.4100 3.4100 6.4100 6.4100 6.4100 %! 3.4100 3.4100 6.4100 3.4100 3.4100 6.4100 3.4100 6.4100 6.4100 3.4100 %! 3.4100 6.4100 3.4100 6.4100 3.4100 6.4100 3.4100 6.4100 6.4100 3.4100 %! 3.4100 6.4100 3.4100 6.4100 3.4100 3.4100 6.4100 6.4100 3.4100 3.4100 %! 3.4100 6.4100 3.4100 6.4100 6.4100 3.4100 6.4100 3.4100 3.4100 3.4100 %! 6.4100 6.4100 3.4100 6.4100 3.4100 3.4100 6.4100 3.4100 3.4100 3.4100 %! 3.4100 6.4100 6.4100 3.4100 3.4100 3.4100 6.4100 3.4100 6.4100 3.4100 %! 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 3.4100 6.4100 3.4100 %! 6.4100 6.4100 3.4100 3.4100 6.4100 6.4100 6.4100 3.4100 6.4100 3.4100 %! 6.4100 3.4100 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 6.4100 3.4100 %! 6.4100 3.4100 3.4100 3.4100 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 %! 6.4100 3.4100 6.4100 3.4100 6.4100 3.4100 6.4100 3.4100 6.4100 6.4100 %! 6.4100 6.4100 6.4100 6.4100 6.4100 3.4100 3.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 6.4100 6.4100 %! 3.4100 6.4100 6.4100 3.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 %! 3.4100 6.4100 6.4100 3.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 %! 3.4100 6.4100 6.4100 3.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 %! 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 3.4100 6.4100 %! 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 3.4100 3.4100 3.4100 3.4100 %! 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 %! 3.4100 6.4100 6.4100 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 %! 3.4100 6.4100 3.4100 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 3.4100 6.4100 3.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 6.4100 6.4100 3.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 3.4100 6.4100 6.4100 3.4100 6.4100 3.4100 %! 3.4100 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 3.4100 %! 3.4100 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 3.4100 6.4100 3.4100 3.4100 6.4100 6.4100 %! 6.4100 6.4100 3.4100 6.4100 3.4100 6.4100 3.4100 6.4100 6.4100 6.4100 %! 6.4100 3.4100 3.4100 6.4100 3.4100 3.4100 3.4100 6.4100 6.4100 6.4100 %! 6.4100 6.4100 3.4100 6.4100 3.4100 3.4100 3.4100 6.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 3.4100 3.4100 3.4100 6.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 6.4100 6.4100 3.4100 3.4100 6.4100 3.4100 6.4100 3.4100 %! 6.4100 6.4100 6.4100 6.4100 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 %! 3.4100 3.4100 6.4100 6.4100 3.4100 6.4100 6.4100 6.4100 3.4100 6.4100 %! 3.4100 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 6.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 6.4100 6.4100 6.4100 6.4100 6.4100 6.4100 %! 3.4100 6.4100 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 %! 3.4100 6.4100 3.4100 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 %! 6.4100 3.4100 3.4100 3.4100 3.4100 3.4100 6.4100 6.4100 3.4100 3.4100 %! 6.4100 3.4100 6.4100 3.4100 3.4100 6.4100 3.4100 6.4100 3.4100 3.4100 %! 6.4100 3.4100 6.4100 3.4100 3.4100 6.4100 3.4100 6.4100 3.4100 6.4100 %! 6.4100 3.4100 6.4100 3.4100 3.4100 6.4100 6.4100 3.4100 3.4100 6.4100 %! 6.4100 6.4100 6.4100 3.4100 3.4100 6.4100 6.4100 3.4100 3.4100 6.4100 %! 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 6.4100 3.4100 6.4100 %! 6.4100 6.4100 6.4100 3.4100 3.4100 6.4100 6.4100 6.4100 3.4100 6.4100 %! 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 %! 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 %! 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 6.4100 6.4100 %! 3.4100 6.4100 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 6.4100 %! 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 6.4100 6.4100 3.4100 3.4100 %! 3.4100 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 6.4100 3.4100 3.4100 %! 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 6.4100 6.4100 6.4100 3.4100 %! 3.4100 3.4100 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 %! 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 6.4100 6.4100 3.4100 3.4100 %! 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 3.4100 6.4100 %! 3.4100 3.4100 6.4100 6.4100 3.4100 6.4100 3.4100 6.4100 3.4100 6.4100 %! 3.4100 6.4100 6.4100 6.4100 3.4100 6.4100 3.4100 6.4100 3.4100 6.4100 %! 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 6.4100 %! 6.4100 3.4100 3.4100 3.4100 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 %! 6.4100 3.4100 3.4100 6.4100 3.4100 3.4100 6.4100 6.4100 3.4100 6.4100 %! 3.4100 3.4100 3.4100 6.4100 6.4100 3.4100 6.4100 3.4100 3.4100 6.4100 %! 3.4100 6.4100 3.4100 6.4100 6.4100 3.4100 6.4100 3.4100 3.4100 3.4100 %! 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 3.4100 6.4100 3.4100 %! 3.4100 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 6.4100 3.4100 %! 6.4100 6.4100 6.4100 6.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 %! 6.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 6.4100 3.4100 3.4100 %! 6.4100 6.4100 3.4100 6.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 %! 6.4100 6.4100 3.4100 6.4100 6.4100 3.4100 3.4100 6.4100 3.4100 3.4100 %! 6.4100 6.4100 6.4100 3.4100 6.4100 3.4100 3.4100 6.4100 3.4100 6.4100 %! 6.4100 6.4100 6.4100 3.4100 3.4100 3.4100 6.4100 6.4100 3.4100 6.4100 %! 6.4100 6.4100 6.4100 3.4100 6.4100 3.4100 6.4100 6.4100 6.4100 6.4100 %! 3.4100 6.4100 6.4100 6.4100 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 %! 3.4100 6.4100 6.4100 6.4100 3.4100 3.4100 6.4100 6.4100 6.4100 6.4100 %! 3.4100 6.4100 6.4100 3.4100 3.4100 3.4100 3.4100 6.4100 6.4100 6.4100 ](:); %! %! %! DAT = iddata (Y, U); %! %! [SYS, X0, INFO] = moen4 (DAT, "s", 15, "rcond", 0.0, "tol", -1.0, "confirm", false); %! %! Ae = [ 0.8924 0.3887 0.1285 0.1716 %! -0.0837 0.6186 -0.6273 -0.4582 %! 0.0052 0.1307 0.6685 -0.6755 %! 0.0055 0.0734 -0.2148 0.4788 ]; %! %! Ce = [ -0.4442 0.6663 0.3961 0.4102 ]; %! %! Be = [ -0.2142 %! -0.1968 %! 0.0525 %! 0.0361 ]; %! %! De = [ -0.0041 ]; %! %! Ke = [ -1.9513 %! -0.1867 %! 0.6348 %! -0.3486 ]; %! %! Qe = [ 0.0052 0.0005 -0.0017 0.0009 %! 0.0005 0.0000 -0.0002 0.0001 %! -0.0017 -0.0002 0.0006 -0.0003 %! 0.0009 0.0001 -0.0003 0.0002 ]; %! %! Rye = [ 0.0012 ]; %! %! Se = [ -0.0025 %! -0.0002 %! 0.0008 %! -0.0005 ]; %! %! X0e = [ -11.496422 %! -0.718576 %! -0.014211 %! 0.500073 ]; # X0e is not from SLICOT %! %! ## The SLICOT test for IB01CD uses COMUSE=C, not COMUSE=U. %! ## This means that they don't use the matrices B and D %! ## computed by IB01BD. They use only A and C from IB01BD, %! ## while B and D are from SLICOT routine IB01CD. %! ## Therefore they get slightly different matrices B and D %! ## and finally a different initial state vector X0. %! %!assert (SYS.A, Ae, 1e-4); %!assert (SYS.B, Be, 1e-4); %!assert (SYS.C, Ce, 1e-4); %!assert (SYS.D, De, 1e-4); %!assert (INFO.K, Ke, 1e-4); %!assert (INFO.Q, Qe, 1e-4); %!assert (INFO.Ry, Rye, 1e-4); %!assert (INFO.S, Se, 1e-4); %!assert (X0, X0e, 1e-4); ## [96-003] Data of a 120 MW power plant (Pont-sur-Sambre, France) %!shared SYS, Ae, Be, Ce, De %! U = [ -811 -592 421 -680 -681 %! -812 -619 477 -685 -651 %! -817 -565 538 -678 -677 %! -695 -725 536 -674 -702 %! -697 -571 531 -676 -685 %! -697 -618 533 -681 -721 %! -702 -579 549 -677 -699 %! -703 -487 575 -677 -694 %! -705 -449 561 -679 -678 %! -705 -431 563 -680 -692 %! -707 -502 561 -679 -686 %! -707 -583 530 -676 -751 %! -710 -458 540 -677 -700 %! -713 -469 543 -679 -731 %! -715 -506 549 -684 -635 %! -713 -590 532 -681 -715 %! -714 -582 528 -676 -696 %! -713 -575 538 -679 -690 %! -716 -382 557 -682 -701 %! -716 -476 558 -679 -690 %! -718 -425 565 -678 -686 %! -719 -409 562 -679 -615 %! -719 -508 523 -677 -737 %! -721 -569 523 -679 -722 %! -723 -434 542 -681 -735 %! -723 -395 544 -676 -704 %! -723 -428 542 -677 -729 %! -722 -402 537 -677 -706 %! -725 -380 534 -681 -696 %! -726 -324 549 -676 -701 %! -726 -211 578 -675 -614 %! -727 -113 569 -677 -738 %! -727 -208 554 -676 -737 %! -727 -320 523 -684 -697 %! -727 944 605 -680 -587 %! -729 396 654 -681 -708 %! -729 754 637 -682 -685 %! -727 419 522 -677 -715 %! -729 378 494 -668 -703 %! -728 363 493 -669 -682 %! -729 390 496 -665 -713 %! -729 106 483 -664 -711 %! -729 32 495 -661 -718 %! -729 517 585 -661 -641 %! -729 455 625 -659 -703 %! -730 521 649 -687 -669 %! -730 540 627 -689 -705 %! -731 514 605 -694 -682 %! -585 525 558 -685 -611 %! -586 534 520 -680 -668 %! -586 539 531 -681 -679 %! -585 519 507 -682 -663 %! -588 513 505 -667 -668 %! -587 509 539 -680 -616 %! -587 512 535 -668 -628 %! -588 514 557 -667 -648 %! -588 553 563 -676 -613 %! -589 519 559 -684 -638 %! -589 521 563 -682 -652 %! -588 518 547 -678 -597 %! -589 552 549 -688 -630 %! -589 520 535 -685 -623 %! -589 547 542 -678 -619 %! -589 549 531 -684 -524 %! -588 544 522 -1540 -580 %! -588 564 555 -1538 -584 %! -588 684 545 -1541 -564 %! -590 558 546 -1541 -609 %! -589 552 537 -1550 -601 %! -591 532 526 -1548 -580 %! -590 544 524 -1542 -565 %! -591 559 535 -1538 -604 %! -592 555 542 -1548 -629 %! -591 577 532 -1549 -587 %! -593 581 530 -1543 -585 %! -592 562 540 -1548 -583 %! -591 568 546 -1536 -587 %! -593 550 557 -1533 -569 %! -592 550 537 -1518 -527 %! -593 568 551 -1533 -582 %! -590 528 540 -1529 -492 %! -590 542 532 -1525 -585 %! -590 556 535 -1522 -606 %! -591 637 535 -1516 -571 %! -591 608 539 -1512 -582 %! -591 545 527 -1510 -577 %! -591 603 534 -1507 -548 %! -592 567 521 -1507 -539 %! -594 560 530 -1503 -583 %! -422 549 534 -1487 -542 %! 5 619 550 -1488 -609 %! 5 572 541 -1487 -545 %! 185 564 529 -1488 -528 %! 185 571 531 -1497 -512 %! 187 590 545 -1489 -472 %! 186 658 544 -1485 -501 %! 185 639 553 -1486 -512 %! 187 604 532 -1486 -490 %! 186 584 535 -1486 -505 %! 187 572 541 -1488 -479 %! 186 570 531 -1486 -477 %! 187 579 539 -1488 -482 %! 187 694 537 -1487 -512 %! 187 727 546 -1494 -474 %! 186 838 545 -1493 -470 %! 186 703 527 -1492 -510 %! 185 634 502 -1490 -486 %! 185 659 502 -1490 -446 %! 185 569 483 -1488 -472 %! 184 552 494 -1487 -468 %! 183 541 492 -1487 -411 %! 184 544 519 -1486 -471 %! 184 577 538 -1487 -420 %! 183 536 546 -1490 -455 %! 183 586 567 -1487 -421 %! 183 554 566 -1485 -449 %! 183 564 558 -1486 -455 %! 182 558 546 -1486 -426 %! 183 659 543 -1486 -398 %! 182 545 531 -1487 -425 %! 182 542 513 -1487 -297 %! 181 549 502 -1486 -407 %! 180 558 963 -1487 -391 %! 182 546 1105 -1487 -388 %! 179 540 1166 -1487 -387 %! 181 519 1221 -1487 -390 %! 179 510 1254 -1486 -382 %! 176 528 1289 -1487 -379 %! 178 510 1310 -1486 -389 %! 178 504 1313 -1484 -357 %! 178 507 1328 -1484 -383 %! 178 519 1333 -1489 -426 %! 183 509 1317 -1483 -377 %! 177 585 1331 -1483 -352 %! 176 765 1334 -1484 -375 %! 196 689 1328 -1484 -381 %! 178 570 1306 -1486 -398 %! 176 997 1338 -1483 -360 %! 176 839 1318 -1487 -366 %! 176 879 1324 -90 -394 %! 175 763 1302 -92 -436 %! 175 739 1307 -92 -430 %! 176 791 1336 -86 -446 %! 175 774 1301 -91 -405 %! 174 782 1304 -91 -414 %! 189 722 1335 -92 -360 %! 173 871 1341 -91 -417 %! 173 825 1337 -86 -383 %! 193 836 1332 -86 -449 %! 174 832 1325 -87 -432 %! 175 834 1326 -88 -383 %! 176 899 1332 -86 -341 %! 195 827 1296 -84 -371 %! 174 897 1311 -86 -366 %! 195 848 1320 -86 -416 %! 192 777 1286 -83 126 %! 171 788 1309 -84 153 %! 171 810 1307 -84 173 %! 174 758 1297 -85 182 %! 188 910 1329 -1036 236 %! 189 944 1344 -1669 245 %! 196 859 1330 -1668 249 %! 190 797 1320 -1669 231 %! 191 784 1341 -1665 248 %! 184 737 1335 -1656 240 %! 182 733 1342 -1655 245 %! 182 696 1350 -1653 253 %! 185 614 1341 -1658 236 %! 188 708 1370 -1654 238 %! 191 729 1366 -1655 237 %! 183 714 1380 -1651 262 %! 186 695 1378 -1651 257 %! 189 758 1387 -1649 276 %! 164 572 1364 -1649 257 %! 163 587 1343 -1650 246 %! 161 683 1353 -1658 261 %! 160 572 1359 -1654 261 %! 160 607 1355 -1651 267 %! 158 580 1349 -1655 273 %! 161 631 1362 -1652 272 %! 160 706 1382 -1657 298 %! 161 601 1356 -1654 277 %! 159 570 1354 -1653 274 %! 158 547 1347 -1657 261 %! 158 582 1332 -1657 257 %! 157 570 1340 -1657 267 %! 154 556 1343 -1657 268 %! 157 537 1345 -1657 -425 %! 158 555 1331 -1653 -581 %! 158 551 1315 -1654 -643 %! 159 590 1322 -1656 -687 %! 160 566 1315 -1657 -737 %! 160 553 1315 -1653 -767 %! 161 644 1327 -1396 -731 %! 159 640 1335 -577 -639 %! 161 726 1334 -577 -730 %! 175 729 1310 -573 -711 %! 175 854 1330 -576 -690 %! 161 729 1313 -573 -636 %! 176 706 1314 -583 -745 ]; %! %! %! Y = [ 117 129 -47 %! 113 141 -42 %! 83 150 -37 %! 144 174 -3 %! 156 196 19 %! 174 192 6 %! 171 193 3 %! 169 224 14 %! 155 211 14 %! 137 175 4 %! 130 165 13 %! 145 172 21 %! 128 173 30 %! 119 194 30 %! 127 188 11 %! 147 176 5 %! 162 183 19 %! 173 178 14 %! 131 161 4 %! 112 139 -11 %! 91 133 -10 %! 75 127 -7 %! 80 115 -10 %! 87 132 6 %! 51 151 6 %! 28 167 3 %! 22 167 -3 %! 9 171 4 %! 7 158 6 %! -11 155 5 %! -87 149 -8 %! -153 146 -12 %! -184 116 -20 %! -167 118 8 %! -563 78 -4 %! -694 -3 -155 %! -1000 -39 -168 %! -1101 -28 -135 %! -1080 55 6 %! -1075 162 89 %! -1035 254 117 %! -894 329 148 %! -747 409 218 %! -774 416 231 %! -781 361 189 %! -825 288 171 %! -897 220 166 %! -960 175 169 %! -994 157 196 %! -1009 202 237 %! -1003 267 258 %! -981 326 267 %! -947 361 276 %! -921 369 280 %! -894 369 292 %! -876 359 302 %! -869 356 318 %! -857 334 316 %! -857 336 320 %! -868 331 323 %! -873 316 324 %! -870 301 326 %! -867 294 323 %! -878 293 322 %! -877 300 309 %! -891 317 233 %! -919 308 160 %! -919 296 111 %! -898 304 94 %! -884 336 101 %! -876 344 92 %! -877 347 77 %! -859 354 79 %! -852 368 84 %! -852 362 79 %! -846 337 67 %! -846 322 71 %! -836 325 82 %! -831 330 81 %! -848 332 84 %! -834 334 89 %! -830 314 87 %! -838 322 93 %! -859 313 73 %! -864 317 59 %! -852 318 48 %! -850 313 59 %! -858 327 65 %! -849 332 82 %! -822 332 77 %! -721 377 121 %! -517 492 193 %! -306 596 226 %! -117 683 244 %! 22 716 212 %! 87 684 157 %! 151 642 129 %! 198 599 105 %! 233 549 93 %! 244 512 83 %! 255 487 70 %! 247 453 49 %! 225 437 32 %! 175 410 4 %! 105 386 -12 %! 86 379 -35 %! 101 382 -16 %! 111 412 3 %! 158 451 31 %! 217 486 37 %! 259 504 29 %! 301 503 24 %! 317 495 7 %! 354 472 -3 %! 361 441 -8 %! 368 413 -32 %! 362 381 -34 %! 354 370 -42 %! 310 360 -36 %! 318 369 -36 %! 313 372 -36 %! 298 377 -28 %! 311 341 -34 %! 339 292 -33 %! 362 223 -52 %! 380 161 -73 %! 397 113 -90 %! 402 64 -117 %! 398 30 -136 %! 396 12 -148 %! 390 -22 -189 %! 377 -47 -211 %! 366 -54 -227 %! 331 -52 -240 %! 227 -74 -289 %! 168 -117 -355 %! 149 -104 -357 %! 10 -101 -344 %! -77 -115 -374 %! -116 -88 -330 %! -106 -53 -223 %! -82 -4 -98 %! -99 5 -40 %! -89 22 3 %! -79 34 26 %! -74 34 42 %! -101 28 61 %! -102 28 73 %! -124 22 74 %! -125 19 90 %! -132 9 100 %! -167 8 102 %! -161 7 90 %! -185 19 105 %! -207 29 110 %! -295 24 159 %! -361 17 293 %! -411 12 436 %! -401 48 540 %! -441 86 601 %! -475 118 553 %! -448 146 472 %! -401 172 428 %! -366 197 400 %! -304 231 391 %! -252 253 387 %! -183 261 399 %! -123 255 405 %! -107 247 397 %! -76 228 392 %! -71 205 389 %! -66 192 381 %! -92 171 371 %! -40 178 356 %! -15 185 353 %! -27 170 359 %! 15 173 351 %! 23 175 356 %! 44 178 338 %! 47 171 323 %! 4 153 294 %! 23 141 295 %! 39 141 306 %! 52 139 313 %! 53 142 313 %! 69 142 312 %! 74 136 306 %! 196 164 277 %! 347 208 133 %! 461 230 -58 %! 526 204 -251 %! 581 161 -385 %! 588 119 -458 %! 549 63 -528 %! 497 5 -550 %! 420 -20 -498 %! 327 -49 -464 %! 198 -78 -438 %! 154 -80 -409 %! 130 -60 -377 ]; %! %! DAT = iddata (Y, U, 1228.8); %! %! [SYS, X0] = moen4 (DAT, "s", 10, "n", 8, "rcond", 0.0, "tol", -1.0); %! %! Ae = [ 0.9811 0.0574 0.3270 0.0003 0.0358 0.0403 -0.1366 0.0276 %! 0.1043 0.7634 -0.1308 0.2252 0.0203 -0.0117 -0.2328 -0.2516 %! -0.0612 0.1437 0.8378 -0.2400 0.0367 -0.3205 -0.0367 -0.0978 %! -0.0213 0.0149 0.0706 0.8902 0.2415 -0.1329 0.3080 -0.0143 %! -0.0076 0.0680 0.0557 -0.0469 0.7084 0.2852 0.2565 0.1508 %! -0.0016 0.0603 0.0071 -0.0448 -0.0870 0.8608 0.1495 -0.1148 %! 0.0046 0.0120 0.0040 -0.0272 0.0117 -0.0654 0.8348 -0.4557 %! -0.0058 0.0133 -0.0112 -0.0171 -0.0353 -0.0892 0.3328 0.7650 ]; %! %! Ce = [ -0.1635 0.6294 0.1157 -0.2129 0.0812 -0.0238 0.0745 0.2027 %! 0.1775 0.1736 -0.2839 -0.0750 -0.4986 -0.1254 0.3740 0.1598 %! 0.2012 -0.0045 -0.4447 -0.3289 0.4767 -0.3377 0.0200 -0.0978 ]; %! %! Be = [ -0.0436 0.1911 -0.1345 0.0409 0.2828 %! 0.5541 -0.4223 0.0001 -0.0151 -0.1778 %! -0.3644 0.2868 0.0754 -0.0457 -0.1691 %! -0.0372 0.1270 -0.0772 -0.0714 -0.0255 %! -0.1251 -0.0021 0.1094 0.0576 0.2121 %! -0.1372 0.1139 0.0030 0.0141 0.0493 %! -0.0187 0.0712 -0.0042 0.0075 -0.0221 %! -0.0834 0.0509 0.0322 -0.0089 0.0009 ]; %! %! De = [ 0.1581 -0.3111 -0.0350 0.0179 -0.1403 %! -0.0037 -0.0461 -0.1177 0.0092 -0.0242 %! 0.0476 -0.0237 -0.0159 0.0174 0.0464 ]; %! %! # Since moen4 identifies the input/output behavior only %! # input/output behavior is tested using n first Markov parameters. %! # The state space representaton might have different signs %! # of the states. %! # By multiplying the matrices for the Markov parameters, numeric errors %! # would propagate, therefor the accuracy of the results are limited to %! # the accuracy of the given expected results %! %! [Ao,Bo,Co,Do] = ssdata (SYS); %! Ao = round (Ao*1e4)/1e4; %! Bo = round (Bo*1e4)/1e4; %! Co = round (Co*1e4)/1e4; %! Do = round (Do*1e4)/1e4; %! %! n = size(Ao,1); %! m = size(Bo,2); %! p = size(Co,1); %! Mo = zeros (p,(n+1)*m); %! Me = zeros (p,(n+1)*m); %! Mo(:,1:m) = Do; %! Me(:,1:m) = De; %! %! Aoi = eye (n,n); %! Aei = eye (n,n); %! for i = 1:n %! Mo(:,i*m+1:(i+1)*m) = Co*Aoi*Bo; %! Me(:,i*m+1:(i+1)*m) = Ce*Aei*Be; %! Aoi = Aoi*Ao; %! Aei = Aei*Ae; %! endfor %! %! assert (Mo, Me, 1e-4); ## [96-007] Data of a CD-player arm %!shared SYS, Ae, Be, Ce, De %! UY = [ 0.0531 -0.0313 0.0495 0.0342 %! 0.0526 -0.0328 0.0525 0.0342 %! 0.0504 -0.0482 0.0485 0.0567 %! 0.0423 -0.1048 0.0285 0.1542 %! 0.0269 -0.1515 0.0555 0.1192 %! 0.0072 -0.1404 0.0635 0.2067 %! -0.0091 -0.0936 0.1885 -0.0558 %! -0.0272 -0.0770 0.1145 0.2292 %! -0.0602 -0.0720 0.0985 0.2767 %! -0.0962 -0.1012 0.2485 -0.0733 %! -0.1266 -0.2732 0.2705 0.3017 %! -0.1548 -0.4999 0.3675 0.2567 %! -0.1831 -0.6836 0.3665 0.3492 %! -0.2225 -0.8477 0.3145 0.7492 %! -0.2638 -0.9533 0.4615 0.4067 %! -0.2865 -0.9926 0.5025 0.4917 %! -0.2877 -0.9519 0.5355 0.5942 %! -0.2652 -0.8100 0.5835 0.2917 %! -0.2229 -0.6546 0.4355 0.4417 %! -0.1690 -0.4802 0.3175 0.2667 %! -0.1022 -0.3147 0.2265 0.1067 %! -0.0262 -0.2181 0.1655 0.1717 %! 0.0508 -0.1214 0.1295 0.0167 %! 0.1181 0.0027 -0.0375 0.0642 %! 0.1639 0.1290 -0.2015 0.0767 %! 0.1915 0.2491 -0.2445 -0.0933 %! 0.2141 0.3501 -0.2085 -0.1833 %! 0.2383 0.4384 -0.2055 -0.2083 %! 0.2591 0.5325 -0.2915 -0.1533 %! 0.2720 0.6505 -0.3725 -0.2108 %! 0.2855 0.7959 -0.3975 -0.4083 %! 0.3036 0.9837 -0.4585 -0.4258 %! 0.3180 1.2078 -0.5175 -0.4108 %! 0.3278 1.4001 -0.4415 -0.6958 %! 0.3333 1.5244 -0.4445 -0.7183 %! 0.3201 1.6123 -0.6065 -0.4658 %! 0.2920 1.6983 -0.5645 -0.8133 %! 0.2720 1.7388 -0.3875 -1.0058 %! 0.2556 1.6854 -0.3775 -0.6208 %! 0.2279 1.5986 -0.4115 -0.6783 %! 0.1954 1.4945 -0.4215 -0.7808 %! 0.1667 1.3238 -0.3475 -0.6483 %! 0.1384 1.0917 -0.2985 -0.5033 %! 0.1039 0.8539 -0.2995 -0.3083 %! 0.0697 0.6475 -0.1155 -0.4483 %! 0.0391 0.4233 -0.0315 -0.2033 %! 0.0027 0.2235 -0.0775 0.0317 %! -0.0330 0.0966 0.0155 -0.2458 %! -0.0606 -0.0817 0.1125 0.0542 %! -0.0827 -0.3000 0.2685 0.1242 %! -0.0939 -0.4675 0.2865 0.0642 %! -0.0950 -0.5866 0.1685 0.3717 %! -0.0840 -0.6702 0.2735 0.1017 %! -0.0611 -0.7676 0.2505 0.2867 %! -0.0432 -0.7891 0.1245 0.5342 %! -0.0289 -0.6736 0.1945 0.0842 %! -0.0126 -0.5516 0.1885 0.2392 %! 0.0003 -0.4055 0.1795 0.1967 %! 0.0159 -0.2097 0.1605 -0.1208 %! 0.0348 -0.0408 0.0925 0.0217 %! 0.0506 0.1208 0.1395 -0.1408 %! 0.0627 0.3078 0.0795 -0.2183 %! 0.0723 0.4773 0.0175 -0.3158 %! 0.0792 0.5095 0.0215 -0.3533 %! 0.0752 0.4314 0.0085 -0.1533 %! 0.0590 0.4053 0.0425 -0.2683 %! 0.0378 0.4174 0.0245 -0.2658 %! 0.0103 0.4410 0.0295 -0.1783 %! -0.0258 0.4940 0.0905 -0.2633 %! -0.0652 0.4837 0.1385 -0.2758 %! -0.1035 0.3611 0.1805 -0.2258 %! -0.1429 0.1376 0.2035 -0.0383 %! -0.1847 -0.2251 0.3095 0.0167 %! -0.2340 -0.7017 0.3245 0.3692 %! -0.3036 -1.1050 0.3355 0.7517 %! -0.3827 -1.3696 0.5995 0.4917 %! -0.4557 -1.6423 0.7655 0.7017 %! -0.5309 -1.9082 0.7975 1.1367 %! -0.6018 -2.0464 0.9805 0.8317 %! -0.6458 -2.0844 1.1445 0.7692 %! -0.6613 -2.0949 1.2125 0.9217 %! -0.6589 -2.0794 1.1595 0.9317 %! -0.6399 -1.9906 1.1525 0.7942 %! -0.6009 -1.8632 1.1895 0.6867 %! -0.5490 -1.7523 1.0765 0.7617 %! -0.4912 -1.6356 0.9615 0.6342 %! -0.4272 -1.5132 0.8845 0.5817 %! -0.3567 -1.3945 0.8295 0.5517 %! -0.2766 -1.3215 0.7085 0.4392 %! -0.1868 -1.3317 0.5175 0.4792 %! -0.0971 -1.3609 0.3765 0.5317 %! -0.0192 -1.3473 0.2125 0.6367 %! 0.0466 -1.2796 0.0715 0.5192 %! 0.1089 -1.2096 -0.0385 0.4117 %! 0.1644 -1.1582 -0.1425 0.5742 %! 0.2056 -1.0522 -0.2015 0.4542 %! 0.2331 -0.9216 -0.3305 0.3817 %! 0.2478 -0.8330 -0.4485 0.4142 %! 0.2518 -0.7613 -0.4545 0.3017 %! 0.2470 -0.7081 -0.4315 0.2892 %! 0.2276 -0.6960 -0.4605 0.3442 %! 0.1865 -0.7076 -0.5155 0.3692 %! 0.1253 -0.7396 -0.4485 0.3242 %! 0.0472 -0.8146 -0.3375 0.4292 %! -0.0473 -0.8961 -0.2235 0.4967 %! -0.1521 -0.9436 -0.0515 0.4692 %! -0.2577 -0.9516 0.1265 0.5667 %! -0.3484 -0.8765 0.3575 0.3617 %! -0.4103 -0.7632 0.4915 0.2542 %! -0.4523 -0.6816 0.4825 0.4667 %! -0.4835 -0.5694 0.5725 0.2892 %! -0.4953 -0.4093 0.6665 0.1417 %! -0.4786 -0.2418 0.7055 0.0917 %! -0.4345 -0.0829 0.6615 0.0192 %! -0.3719 0.0565 0.5455 0.0617 %! -0.2949 0.2073 0.4655 -0.0808 %! -0.2016 0.3566 0.3255 -0.1433 %! -0.0946 0.3950 0.1765 -0.1383 %! 0.0180 0.2803 0.0325 -0.1083 %! 0.1239 0.1148 -0.1245 0.0392 %! 0.2137 -0.0357 -0.2785 0.0642 %! 0.2851 -0.1776 -0.4545 0.1267 %! 0.3386 -0.2838 -0.5135 0.1392 %! 0.3724 -0.3703 -0.5395 0.1992 %! 0.3804 -0.4262 -0.5995 0.2692 %! 0.3606 -0.3882 -0.6205 0.1717 %! 0.3143 -0.2657 -0.6005 0.1667 %! 0.2456 -0.0453 -0.4925 0.0092 %! 0.1633 0.2726 -0.3835 -0.1683 %! 0.0757 0.6140 -0.2705 -0.3183 %! -0.0088 0.8954 -0.1175 -0.5333 %! -0.0827 1.0590 -0.0395 -0.5358 %! -0.1377 1.1857 0.0545 -0.7408 %! -0.1707 1.3715 0.0725 -0.7933 %! -0.1911 1.5865 0.0695 -0.7758 %! -0.2027 1.7486 0.1445 -0.9933 %! -0.2042 1.8322 0.1265 -0.8733 %! -0.1901 1.9362 0.2065 -1.0933 %! -0.1550 2.0756 0.2185 -1.2008 %! -0.1150 2.2175 0.0835 -0.9258 %! -0.0782 2.4161 0.1225 -1.3158 %! -0.0382 2.5968 0.0995 -1.3508 %! 0.0009 2.6974 0.0685 -1.2508 %! 0.0392 2.7343 0.0955 -1.4683 %! 0.0755 2.6634 0.0165 -1.2133 %! 0.1076 2.5477 0.0225 -1.2458 %! 0.1431 2.4412 -0.0305 -1.2558 %! 0.1844 2.3062 -0.1165 -1.0908 %! 0.2260 2.1947 -0.1755 -1.1083 %! 0.2587 2.1622 -0.2835 -0.9508 %! 0.2798 2.1829 -0.3055 -1.0508 %! 0.2967 2.2071 -0.3375 -1.1083 %! 0.3114 2.2195 -0.3515 -1.0408 %! 0.3235 2.2042 -0.3295 -1.1133 %! 0.3315 2.0932 -0.3775 -0.9583 %! 0.3365 1.8795 -0.3815 -0.9233 %! 0.3446 1.6517 -0.4025 -0.8583 %! 0.3561 1.4464 -0.4285 -0.7183 %! 0.3619 1.2298 -0.4995 -0.5708 %! 0.3524 1.0610 -0.6035 -0.3683 %! 0.3355 0.9913 -0.5375 -0.5383 %! 0.3266 0.9109 -0.4835 -0.5358 %! 0.3218 0.7731 -0.5415 -0.2683 %! 0.3110 0.6149 -0.5715 -0.2408 %! 0.2969 0.4368 -0.5525 -0.1883 %! 0.2860 0.2525 -0.4825 -0.1483 %! 0.2740 0.0546 -0.5115 0.0767 %! 0.2521 -0.1300 -0.5075 0.2217 %! 0.2261 -0.2571 -0.3805 0.1317 %! 0.2065 -0.3238 -0.3155 0.1867 %! 0.1931 -0.2987 -0.3305 0.1942 %! 0.1808 -0.2329 -0.3565 0.2092 %! 0.1728 -0.2060 -0.2655 0.1117 %! 0.1778 -0.1696 -0.1935 0.0042 %! 0.1933 -0.0814 -0.2805 0.1292 %! 0.2136 0.0401 -0.3195 0.0017 %! 0.2433 0.1480 -0.3015 -0.1308 %! 0.2830 0.1864 -0.3395 -0.1183 %! 0.3231 0.1801 -0.5095 -0.0508 %! 0.3548 0.1985 -0.6255 -0.0283 %! 0.3828 0.2212 -0.5505 -0.2358 %! 0.4071 0.2130 -0.6185 -0.0833 %! 0.4161 0.2078 -0.7505 -0.0233 %! 0.4070 0.1729 -0.7735 -0.1208 %! 0.3820 0.0580 -0.7255 0.0892 %! 0.3472 -0.1245 -0.6195 0.0492 %! 0.3091 -0.3883 -0.6545 0.2617 %! 0.2664 -0.6903 -0.6355 0.5492 %! 0.2262 -1.0013 -0.4655 0.4792 %! 0.1930 -1.3467 -0.4925 0.8692 %! 0.1636 -1.6417 -0.5175 0.9717 %! 0.1427 -1.8525 -0.4415 0.9067 %! 0.1266 -2.0179 -0.4015 1.2292 %! 0.1118 -2.1203 -0.3485 1.0842 %! 0.1018 -2.1909 -0.3845 1.0817 %! 0.0912 -2.2222 -0.3635 1.2492 %! 0.0774 -2.1564 -0.2115 0.9892 %! 0.0614 -2.0300 -0.1995 1.0467 %! 0.0438 -1.8759 -0.1595 0.9517 %! 0.0385 -1.7096 0.0155 0.5367 %! 0.0457 -1.5773 0.0455 0.6742 %! 0.0461 -1.4479 -0.0415 0.7242 %! 0.0371 -1.2867 -0.0325 0.3842 %! 0.0259 -1.1849 0.0445 0.4142 %! 0.0133 -1.1751 0.1485 0.4092 %! -0.0023 -1.1735 0.1255 0.3992 %! -0.0234 -1.1757 0.0705 0.5492 %! -0.0427 -1.2288 0.1825 0.3642 %! -0.0546 -1.3379 0.1545 0.5367 %! -0.0693 -1.4457 0.0385 0.8092 %! -0.0862 -1.4768 0.0965 0.6067 %! -0.0960 -1.4632 0.1635 0.6542 %! -0.1013 -1.4416 0.1445 0.7117 %! -0.1098 -1.3817 0.0555 0.6417 %! -0.1307 -1.2943 0.0305 0.7067 %! -0.1687 -1.1853 0.1585 0.6017 %! -0.2203 -1.0350 0.2505 0.5317 %! -0.2805 -0.8197 0.3175 0.4542 %! -0.3427 -0.5362 0.4545 0.3067 %! -0.3950 -0.2783 0.6245 0.1217 %! -0.4257 -0.1265 0.6745 -0.0083 %! -0.4347 -0.0352 0.6115 0.0642 %! -0.4273 0.0849 0.6455 -0.0608 %! -0.4080 0.2669 0.6375 -0.0983 %! -0.3808 0.4593 0.5595 -0.1183 %! -0.3378 0.6035 0.5465 -0.4158 %! -0.2776 0.6956 0.4895 -0.3233 %! -0.2139 0.7767 0.4145 -0.2483 %! -0.1485 0.8759 0.3105 -0.5033 %! -0.0798 0.9496 0.1465 -0.4033 %! -0.0138 0.9867 0.1065 -0.4133 %! 0.0481 1.0353 0.0825 -0.5458 %! 0.1014 1.0584 -0.0285 -0.3958 %! 0.1417 1.0195 -0.1245 -0.3508 %! 0.1810 0.9643 -0.1175 -0.5058 %! 0.2304 0.8987 -0.1325 -0.4633 %! 0.2784 0.8223 -0.3155 -0.1833 %! 0.3158 0.7741 -0.4165 -0.3058 %! 0.3477 0.7241 -0.4475 -0.3608 %! 0.3700 0.6195 -0.5515 -0.0458 %! 0.3809 0.5139 -0.5905 -0.1633 %! 0.3896 0.4472 -0.5885 -0.1983 %! 0.3935 0.3697 -0.5985 0.0417 %! 0.3879 0.3296 -0.6335 -0.0308 %! 0.3781 0.3844 -0.6795 -0.1183 %! 0.3661 0.4741 -0.6555 -0.0908 %! 0.3493 0.6039 -0.5805 -0.2358 %! 0.3240 0.7004 -0.5635 -0.2533 %! 0.2858 0.6189 -0.5785 -0.0933 %! 0.2432 0.4427 -0.4435 -0.2383 %! 0.2074 0.2354 -0.3355 -0.1458 %! 0.1672 0.0128 -0.4075 0.2967 %! 0.1183 -0.1060 -0.3275 0.0767 %! 0.0720 -0.1569 -0.2185 0.0792 %! 0.0281 -0.1837 -0.1755 0.2942 %! -0.0110 -0.1465 -0.0965 0.0092 %! -0.0430 -0.1124 -0.1035 0.1892 %! -0.0694 -0.0907 0.0345 0.1267 %! -0.0822 -0.0402 0.1395 -0.0883 %! -0.0840 0.0366 0.0545 0.1267 %! -0.0813 0.1044 0.1125 -0.0758 %! -0.0744 0.0936 0.1615 -0.0783 %! -0.0736 0.0579 0.1215 0.1442 %! -0.0809 0.0546 0.1445 -0.0458 %! -0.0869 0.0402 0.1665 -0.0033 %! -0.0882 0.0025 0.2585 0.0167 %! -0.0891 -0.0893 0.2335 0.0617 %! -0.0989 -0.2016 0.1095 0.2567 %! -0.1157 -0.2898 0.1755 0.1517 %! -0.1279 -0.4203 0.2505 0.2192 %! -0.1321 -0.5523 0.2425 0.2892 %! -0.1353 -0.6380 0.1515 0.3892 %! -0.1451 -0.7266 0.0955 0.5492 %! -0.1517 -0.8032 0.1775 0.3517 %! -0.1402 -0.8444 0.1445 0.4217 %! -0.1103 -0.8473 0.0825 0.4467 %! -0.0677 -0.8711 0.0725 0.3342 %! -0.0286 -0.9469 -0.0805 0.6842 %! 0.0023 -0.9579 -0.1245 0.4242 %! 0.0381 -0.9479 -0.1135 0.2117 %! 0.0664 -0.9993 -0.2065 0.7217 %! 0.0742 -1.0048 -0.1365 0.4642 %! 0.0735 -1.0174 -0.0945 0.2817 %! 0.0619 -1.1243 -0.1855 0.6692 %! 0.0339 -1.2704 -0.1235 0.5067 %! -0.0041 -1.4761 -0.0475 0.6292 %! -0.0512 -1.6788 0.0215 0.8992 %! -0.0973 -1.7716 0.1645 0.6467 %! -0.1341 -1.8061 0.1835 0.7942 %! -0.1695 -1.7935 0.1665 0.9717 %! -0.1988 -1.7171 0.2675 0.6517 %! -0.2107 -1.6368 0.3285 0.6417 %! -0.2119 -1.5489 0.3375 0.7267 %! -0.2123 -1.4181 0.3615 0.5617 %! -0.2172 -1.2714 0.3455 0.5342 %! -0.2319 -1.0671 0.3335 0.4817 %! -0.2558 -0.7123 0.3665 0.2467 %! -0.2838 -0.2669 0.4385 0.0517 %! -0.3123 0.1531 0.5195 -0.1483 %! -0.3390 0.5226 0.5215 -0.3008 %! -0.3576 0.8555 0.4985 -0.4808 %! -0.3583 1.1684 0.5345 -0.7233 %! -0.3436 1.4304 0.5085 -0.6883 %! -0.3233 1.6427 0.4625 -0.7483 %! -0.2932 1.8196 0.4685 -1.0258 %! -0.2534 1.8815 0.3835 -0.8933 %! -0.2164 1.8872 0.2795 -0.7883 %! -0.1816 1.9679 0.2695 -0.9983 %! -0.1423 2.0907 0.2485 -1.0408 %! -0.1081 2.2150 0.1715 -0.9933 %! -0.0923 2.2823 0.0785 -0.9883 %! -0.0926 2.2505 0.0865 -1.0533 %! -0.0974 2.2151 0.1815 -1.1133 %! -0.1033 2.1746 0.2105 -1.0133 %! -0.1130 2.0369 0.1895 -0.9683 %! -0.1261 1.8613 0.1905 -0.8858 %! -0.1377 1.7249 0.2185 -0.8358 %! -0.1403 1.5793 0.2285 -0.8208 %! -0.1310 1.4183 0.2345 -0.7683 %! -0.1180 1.2871 0.2165 -0.6133 %! -0.1102 1.1936 0.1955 -0.5383 %! -0.1015 1.1864 0.2075 -0.7283 %! -0.0886 1.2592 0.1275 -0.5833 %! -0.0749 1.3410 0.1485 -0.5658 %! -0.0470 1.4143 0.2895 -0.9458 %! -0.0031 1.4604 0.1465 -0.6733 %! 0.0402 1.5447 -0.0435 -0.6083 %! 0.0876 1.6959 -0.0645 -1.0383 %! 0.1412 1.7869 -0.1525 -0.8083 %! 0.1883 1.8245 -0.2255 -0.8208 %! 0.2252 1.8679 -0.3275 -0.9933 %! 0.2467 1.9045 -0.4395 -0.8208 %! 0.2469 1.9533 -0.4565 -0.9058 %! 0.2301 1.9731 -0.5135 -0.9308 %! 0.2034 1.9264 -0.4865 -0.9233 %! 0.1679 1.8261 -0.4125 -0.8458 %! 0.1191 1.7087 -0.3975 -0.7083 %! 0.0578 1.6395 -0.3765 -0.7758 %! -0.0120 1.5785 -0.3385 -0.6708 %! -0.0860 1.4653 -0.1925 -0.6008 %! -0.1515 1.3092 0.0135 -0.6958 %! -0.2008 1.0958 0.0985 -0.5583 %! -0.2418 0.8423 0.0795 -0.3258 %! -0.2793 0.5898 0.1115 -0.2908 %! -0.3053 0.3063 0.2445 -0.3208 %! -0.3232 -0.0402 0.2745 0.0467 %! -0.3460 -0.3642 0.2835 0.3317 %! -0.3602 -0.6486 0.4845 0.0767 %! -0.3510 -1.0138 0.5625 0.3067 %! -0.3365 -1.3782 0.4035 0.8092 %! -0.3285 -1.6311 0.3775 0.7192 %! -0.3177 -1.8760 0.4785 0.7742 %! -0.3025 -2.0846 0.5275 1.0067 %! -0.2861 -2.1696 0.4745 1.0042 %! -0.2632 -2.1988 0.4385 0.9742 %! -0.2280 -2.2098 0.4705 0.9567 %! -0.1835 -2.2121 0.3835 1.0492 %! -0.1343 -2.2346 0.2365 1.0167 %! -0.0799 -2.2940 0.2005 0.9267 %! -0.0296 -2.4018 0.1485 1.1567 %! 0.0054 -2.5377 0.0265 1.2892 %! 0.0379 -2.6953 -0.0205 1.1017 %! 0.0850 -2.8762 -0.0155 1.1667 %! 0.1365 -3.0209 -0.1045 1.4792 %! 0.1758 -3.0638 -0.2865 1.4992 %! 0.2069 -3.0199 -0.3975 1.3217 %! 0.2399 -2.9711 -0.3785 1.2517 %! 0.2687 -2.9543 -0.4125 1.3817 %! 0.2813 -2.9447 -0.4615 1.3142 %! 0.2737 -2.9591 -0.4575 1.2217 %! 0.2385 -3.0112 -0.4585 1.4592 %! 0.1778 -3.0317 -0.3535 1.3667 %! 0.1115 -2.9655 -0.1805 1.1367 %! 0.0469 -2.8414 -0.0535 1.2642 %! -0.0254 -2.7009 0.0305 1.2717 %! -0.1049 -2.5296 0.0665 1.1567 %! -0.1749 -2.2903 0.2005 0.8842 %! -0.2261 -2.0294 0.3485 0.7692 %! -0.2709 -1.8409 0.3965 0.9217 %! -0.3160 -1.7059 0.4925 0.6592 %! -0.3553 -1.5587 0.5645 0.5542 %! -0.3887 -1.4311 0.6065 0.6467 %! -0.4132 -1.3691 0.6915 0.4717 %! -0.4202 -1.3607 0.7465 0.4992 %! -0.4079 -1.3743 0.8165 0.5242 %! -0.3790 -1.3781 0.7885 0.4892 %! -0.3393 -1.3442 0.6355 0.5792 %! -0.2925 -1.2459 0.5555 0.4817 %! -0.2378 -1.1148 0.5695 0.3467 %! -0.1856 -0.9931 0.4825 0.4667 %! -0.1486 -0.8185 0.3805 0.3767 %! -0.1216 -0.5874 0.3885 0.0717 %! -0.1015 -0.3821 0.3235 0.1667 %! -0.0898 -0.1778 0.2855 0.0667 %! -0.0712 0.0346 0.3355 -0.2858 %! -0.0379 0.2085 0.3175 -0.2483 %! -0.0027 0.3772 0.2065 -0.2333 %! 0.0236 0.5655 0.0175 -0.3458 %! 0.0438 0.7329 -0.0445 -0.4733 %! 0.0635 0.8253 0.0225 -0.5433 %! 0.0801 0.8649 0.0045 -0.4633 %! 0.0903 0.9308 -0.0115 -0.6133 %! 0.0901 1.0208 -0.0875 -0.5258 %! 0.0744 1.1279 -0.1185 -0.4933 %! 0.0558 1.2299 -0.0115 -0.8233 %! 0.0408 1.2587 -0.0005 -0.6233 %! 0.0191 1.2574 0.0385 -0.5433 %! -0.0063 1.2484 0.0785 -0.7158 %! -0.0255 1.1921 0.0205 -0.5933 %! -0.0336 1.1108 0.0425 -0.6808 %! -0.0357 0.9984 0.0135 -0.4883 %! -0.0415 0.8908 0.0155 -0.3583 %! -0.0416 0.8448 0.0965 -0.6158 %! -0.0291 0.8026 0.0265 -0.4233 %! -0.0135 0.7560 -0.0525 -0.2958 %! 0.0064 0.7406 -0.0195 -0.4958 %! 0.0347 0.7367 -0.0165 -0.4208 %! 0.0633 0.7939 -0.0945 -0.3233 %! 0.0912 0.9579 -0.1195 -0.5658 %! 0.1225 1.1168 -0.1215 -0.6283 %! 0.1480 1.1866 -0.2055 -0.4508 %! 0.1662 1.2186 -0.1875 -0.7083 %! 0.1851 1.2276 -0.2065 -0.7058 %! 0.1996 1.2388 -0.2605 -0.4633 %! 0.2131 1.3063 -0.2195 -0.7858 %! 0.2323 1.3793 -0.3485 -0.6333 %! 0.2558 1.4242 -0.3975 -0.6083 %! 0.2937 1.4094 -0.3555 -0.9133 %! 0.3392 1.2810 -0.5475 -0.4583 %! 0.3757 1.1218 -0.6745 -0.4483 %! 0.4103 0.9746 -0.7225 -0.6508 %! 0.4441 0.8090 -0.8085 -0.2808 %! 0.4710 0.6612 -0.8195 -0.3258 %! 0.4931 0.5291 -0.8975 -0.3208 %! 0.5052 0.4500 -0.9735 -0.1608 %! 0.4969 0.4825 -1.0065 -0.2058 %! 0.4640 0.5571 -1.0395 -0.1783 %! 0.4134 0.6007 -0.9225 -0.3358 %! 0.3525 0.5695 -0.7705 -0.2733 %! 0.2808 0.4708 -0.6625 -0.1683 %! 0.2038 0.3850 -0.5825 -0.2383 %! 0.1330 0.3329 -0.4905 -0.1808 %! 0.0800 0.2964 -0.3315 -0.2783 %! 0.0499 0.2154 -0.2585 -0.2158 %! 0.0356 0.0501 -0.2945 0.0017 %! 0.0345 -0.1225 -0.2425 -0.1633 %! 0.0424 -0.2963 -0.2555 0.0417 %! 0.0454 -0.4329 -0.3185 0.2467 %! 0.0459 -0.4041 -0.2455 -0.0408 %! 0.0501 -0.2796 -0.1785 0.0867 %! 0.0562 -0.1394 -0.1245 0.0392 %! 0.0708 0.0026 -0.1095 -0.2233 %! 0.0921 0.1000 -0.2235 0.0242 %! 0.1173 0.2755 -0.1985 -0.2208 %! 0.1574 0.5562 -0.1505 -0.5558 %! 0.2034 0.7663 -0.3005 -0.3233 %! 0.2345 0.8696 -0.3995 -0.4508 %! 0.2466 0.8681 -0.4305 -0.5183 %! 0.2426 0.8135 -0.4365 -0.4033 %! 0.2294 0.8375 -0.3955 -0.5383 %! 0.2117 0.9195 -0.3865 -0.4633 %! 0.1889 1.0417 -0.3415 -0.5258 %! 0.1615 1.2338 -0.3415 -0.6758 %! 0.1260 1.4168 -0.4065 -0.6508 %! 0.0810 1.5369 -0.3505 -0.7708 %! 0.0342 1.5810 -0.1615 -0.8558 %! -0.0091 1.5314 -0.0225 -0.8083 %! -0.0503 1.4241 -0.0285 -0.7283 %! -0.0876 1.2739 0.0045 -0.7208 %! -0.1141 1.0825 0.0965 -0.7008 %! -0.1308 0.9130 0.1345 -0.5608 %! -0.1446 0.7945 0.1385 -0.5108 %! -0.1608 0.7183 0.1425 -0.4833 %! -0.1846 0.7185 0.1855 -0.4508 %! -0.2169 0.7908 0.2355 -0.5133 %! -0.2502 0.8577 0.2985 -0.5833 %! -0.2747 0.8571 0.4505 -0.6633 %! -0.2911 0.7965 0.5145 -0.5358 %! -0.3055 0.7070 0.5125 -0.5008 %! -0.3153 0.5460 0.5205 -0.5583 %! -0.3242 0.2987 0.4875 -0.2383 %! -0.3392 0.0706 0.5795 -0.1583 %! -0.3528 -0.0710 0.6875 -0.2433 %! -0.3649 -0.1759 0.6485 0.0217 %! -0.3827 -0.3188 0.6335 0.1142 %! -0.3987 -0.5033 0.7005 0.0142 %! -0.4061 -0.6932 0.7185 0.2192 %! -0.4107 -0.8736 0.7015 0.4317 %! -0.4089 -1.0089 0.7395 0.3192 %! -0.3942 -1.1045 0.7075 0.4167 %! -0.3738 -1.2074 0.5835 0.6192 %! -0.3490 -1.3199 0.5075 0.5067 %! -0.3125 -1.4543 0.4785 0.5492 %! -0.2685 -1.5904 0.4425 0.6667 %! -0.2324 -1.6779 0.2805 0.7667 %! -0.2177 -1.7222 0.1215 0.8817 %! -0.2177 -1.7124 0.2035 0.6517 %! -0.2191 -1.6440 0.2945 0.6017 %! -0.2262 -1.5442 0.2725 0.7342 %! -0.2446 -1.4283 0.2725 0.5967 %! -0.2675 -1.3620 0.3145 0.5392 %! -0.2852 -1.3847 0.3815 0.5242 %! -0.2915 -1.4221 0.3885 0.5442 %! -0.2859 -1.4241 0.3955 0.6142 %! -0.2662 -1.4117 0.4345 0.5817 %! -0.2261 -1.4121 0.3795 0.5092 %! -0.1681 -1.4674 0.1875 0.5967 %! -0.1067 -1.5856 0.0025 0.7967 %! -0.0484 -1.7123 0.0105 0.7017 %! 0.0055 -1.8149 -0.0275 0.7892 %! 0.0441 -1.8852 -0.1755 1.0267 %! 0.0662 -1.9856 -0.1775 0.8417 %! 0.0769 -2.2193 -0.1235 1.0092 %! 0.0690 -2.4788 -0.1095 1.2917 %! 0.0433 -2.5547 -0.1075 1.1892 %! 0.0121 -2.4502 -0.0515 1.1292 %! -0.0163 -2.3174 0.0695 1.0167 %! -0.0431 -2.2535 0.0355 1.0567 %! -0.0690 -2.2237 -0.0085 1.0267 %! -0.0830 -2.1826 0.0905 0.8217 %! -0.0802 -2.1610 0.1245 0.9717 %! -0.0644 -2.1314 0.0895 0.8942 %! -0.0389 -2.0083 -0.0235 0.7767 %! -0.0144 -1.7807 -0.0925 0.8117 %! 0.0039 -1.5045 -0.0555 0.5167 %! 0.0181 -1.2185 -0.0975 0.3967 %! 0.0257 -0.9135 -0.1055 0.2917 %! 0.0253 -0.5901 -0.0405 0.0192 %! 0.0119 -0.2804 -0.0405 -0.0208 %! -0.0223 0.0284 -0.0525 -0.1183 %! -0.0722 0.3668 0.0375 -0.3658 %! -0.1248 0.6931 0.2185 -0.5433 %! -0.1762 0.9826 0.3255 -0.5983 %! -0.2279 1.2387 0.3505 -0.7408 %! -0.2801 1.4081 0.3595 -0.7783 %! -0.3313 1.4824 0.4385 -0.7633 %! -0.3714 1.4586 0.5705 -0.8483 %! -0.3940 1.3294 0.5915 -0.6908 %! -0.4058 1.2356 0.5915 -0.5733 %! -0.4124 1.2560 0.5965 -0.6108 %! -0.4123 1.3012 0.5405 -0.5908 %! -0.3988 1.2608 0.5535 -0.6983 %! -0.3752 1.0714 0.5255 -0.4733 %! -0.3563 0.8491 0.5215 -0.2658 %! -0.3428 0.6776 0.5805 -0.4083 %! -0.3337 0.4690 0.4925 -0.1158 %! -0.3337 0.2571 0.5005 0.0117 %! -0.3316 0.0998 0.6345 -0.1208 %! -0.3140 -0.0275 0.7025 -0.0458 %! -0.2848 -0.1338 0.6455 0.0317 %! -0.2575 -0.2528 0.4625 0.1967 %! -0.2342 -0.3685 0.4365 0.0917 %! -0.2083 -0.4770 0.4665 0.0767 %! -0.1875 -0.6038 0.3695 0.3942 %! -0.1767 -0.6891 0.3645 0.2767 %! -0.1647 -0.7274 0.4225 0.1342 %! -0.1496 -0.7568 0.3685 0.2642 %! -0.1427 -0.8146 0.2315 0.3767 %! -0.1438 -0.9273 0.2285 0.3517 %! -0.1384 -1.0284 0.4105 0.2117 %! -0.1249 -1.1491 0.4185 0.4717 %! -0.1147 -1.3249 0.2665 0.6917 %! -0.0989 -1.4528 0.2795 0.4867 %! -0.0619 -1.5434 0.3525 0.5667 %! -0.0081 -1.6087 0.2615 0.7242 %! 0.0507 -1.6067 0.0855 0.6692 %! 0.1051 -1.5640 -0.0405 0.7317 %! 0.1482 -1.4225 -0.0795 0.6492 %! 0.1804 -1.1516 -0.1505 0.4267 %! 0.2027 -0.8082 -0.2635 0.3492 %! 0.2135 -0.4165 -0.2375 0.1192 %! 0.2148 -0.0383 -0.1745 -0.1108 %! 0.2076 0.3144 -0.3045 -0.1433 %! 0.2004 0.6244 -0.3415 -0.4108 %! 0.2110 0.7909 -0.2105 -0.6583 %! 0.2361 0.8213 -0.2295 -0.3833 %! 0.2602 0.7620 -0.3495 -0.3533 %! 0.2841 0.6144 -0.4395 -0.4783 %! 0.3056 0.4209 -0.4835 -0.1683 %! 0.3176 0.2084 -0.4535 -0.0783 %! 0.3250 -0.0407 -0.4695 -0.0783 %! 0.3287 -0.3328 -0.5005 0.1792 %! 0.3187 -0.6266 -0.5085 0.4117 %! 0.2961 -0.8894 -0.5195 0.4617 %! 0.2740 -1.0959 -0.4995 0.4492 %! 0.2542 -1.1684 -0.4795 0.6467 %! 0.2321 -1.0800 -0.3895 0.5542 %! 0.2110 -0.8808 -0.3495 0.3067 %! 0.1900 -0.6415 -0.3965 0.3167 %! 0.1682 -0.4753 -0.3005 0.0467 %! 0.1458 -0.4414 -0.2055 0.0917 %! 0.1163 -0.4386 -0.1425 0.2617 %! 0.0891 -0.3733 0.0045 -0.0933 %! 0.0760 -0.3217 0.0415 -0.0408 %! 0.0669 -0.3010 -0.0135 0.1467 %! 0.0560 -0.2167 -0.0305 -0.0708 %! 0.0476 -0.1060 -0.0405 -0.0458 %! 0.0458 -0.0230 0.0035 -0.1208 %! 0.0540 0.0155 -0.0085 -0.1733 %! 0.0668 -0.0147 -0.1005 0.0117 %! 0.0792 -0.0398 -0.1425 -0.0508 %! 0.0933 -0.0347 -0.1735 -0.0508 %! 0.1089 -0.0374 -0.2045 -0.0283 %! 0.1195 -0.0380 -0.2625 0.0292 %! 0.1195 -0.0179 -0.2725 0.0267 %! 0.1110 0.0673 -0.2335 -0.1483 %! 0.0916 0.2159 -0.2865 -0.0383 %! 0.0596 0.3960 -0.2405 -0.1733 %! 0.0267 0.6076 -0.1025 -0.4333 %! -0.0017 0.8519 -0.0395 -0.3883 %! -0.0248 1.1211 0.0015 -0.6533 %! -0.0414 1.3389 -0.0415 -0.6833 %! -0.0505 1.4805 -0.0145 -0.7208 %! -0.0418 1.5473 0.0785 -1.0008 %! -0.0182 1.5086 -0.0465 -0.7158 %! 0.0047 1.4786 -0.1455 -0.6858 %! 0.0286 1.4618 -0.1135 -0.8933 %! 0.0544 1.3645 -0.1525 -0.6733 %! 0.0735 1.2553 -0.1945 -0.6583 %! 0.0804 1.1186 -0.2285 -0.5433 %! 0.0768 0.9336 -0.1345 -0.4483 %! 0.0700 0.7648 -0.0355 -0.4333 %! 0.0642 0.5964 -0.0615 -0.2583 %! 0.0608 0.4208 -0.0495 -0.2258 %! 0.0602 0.2307 -0.0155 -0.0408 %! 0.0659 0.0514 0.0435 -0.0433 %! 0.0820 -0.0945 0.0105 -0.0583 %! 0.0956 -0.2256 -0.1235 0.2667 %! 0.0948 -0.2807 -0.1055 0.1717 %! 0.0868 -0.2945 -0.0515 0.0367 %! 0.0754 -0.3494 -0.0825 0.1942 %! 0.0574 -0.4033 -0.0815 0.1867 %! 0.0357 -0.4587 -0.0115 0.1717 %! 0.0156 -0.5346 0.0505 0.1867 %! -0.0023 -0.6237 0.0135 0.3017 %! -0.0165 -0.7228 0.0525 0.2717 %! -0.0230 -0.7928 0.1605 0.2417 %! -0.0284 -0.8219 0.1615 0.4642 %! -0.0327 -0.8036 0.1625 0.2917 %! -0.0210 -0.7466 0.1915 0.1567 %! 0.0111 -0.7242 0.2005 0.3042 %! 0.0592 -0.7573 0.1465 0.2667 %! 0.1231 -0.7844 -0.0095 0.2467 %! 0.1999 -0.7794 -0.1375 0.2692 %! 0.2804 -0.7513 -0.2825 0.3117 %! 0.3560 -0.6774 -0.4315 0.2467 %! 0.4198 -0.5854 -0.5625 0.2242 %! 0.4650 -0.5277 -0.6685 0.3242 %! 0.4975 -0.4888 -0.6675 0.1642 %! 0.5329 -0.4856 -0.6705 0.0967 %! 0.5714 -0.5286 -0.7535 0.2292 %! 0.5974 -0.5528 -0.8835 0.3717 %! 0.6036 -0.5237 -0.9285 0.3542 %! 0.6018 -0.4513 -0.8545 0.1417 %! 0.5995 -0.3414 -0.8395 0.2067 %! 0.5916 -0.2010 -0.8205 0.1942 %! 0.5754 -0.0626 -0.8065 0.0892 %! 0.5542 0.0470 -0.8155 0.0967 %! 0.5375 0.0963 -0.7775 -0.0808 %! 0.5306 0.0637 -0.8045 0.0367 %! 0.5296 0.0065 -0.7795 0.0492 %! 0.5319 -0.0821 -0.7785 -0.0208 %! 0.5239 -0.2330 -0.9285 0.2767 %! 0.4911 -0.3534 -0.9875 0.2492 %! 0.4368 -0.4041 -0.9135 0.2767 %! 0.3774 -0.4396 -0.6965 0.2317 %! 0.3299 -0.5189 -0.5085 0.1617 %! 0.2946 -0.5876 -0.5285 0.4617 %! 0.2732 -0.5118 -0.4495 0.1917 %! 0.2735 -0.3676 -0.4335 0.1092 %! 0.2897 -0.2488 -0.4875 0.2317 %! 0.3188 -0.1107 -0.4445 -0.0758 %! 0.3580 0.0310 -0.4655 0.0367 %! 0.3999 0.2099 -0.4825 -0.0933 %! 0.4416 0.4537 -0.6305 -0.2708 %! 0.4758 0.6744 -0.8075 -0.1533 %! 0.5033 0.8167 -0.7235 -0.5058 %! 0.5249 0.8812 -0.7385 -0.3783 %! 0.5302 0.9226 -0.8115 -0.2858 %! 0.5213 0.9572 -0.8195 -0.5783 %! 0.4967 0.9528 -0.8725 -0.2483 %! 0.4535 0.9563 -0.7685 -0.3808 %! 0.4022 0.9923 -0.6685 -0.5258 %! 0.3435 1.0462 -0.6205 -0.2433 %! 0.2816 1.1181 -0.4365 -0.5508 %! 0.2276 1.1811 -0.3685 -0.5858 %! 0.1752 1.2622 -0.3765 -0.4508 %! 0.1188 1.4145 -0.3025 -0.6808 %! 0.0624 1.5738 -0.1975 -0.7083 %! 0.0118 1.6516 -0.0645 -0.8358 %! -0.0333 1.6513 -0.0625 -0.8383 %! -0.0826 1.5769 -0.1065 -0.6158 %! -0.1318 1.4702 0.0125 -0.7833 %! -0.1670 1.4121 0.1115 -0.7908 %! -0.1917 1.3594 0.0985 -0.5433 %! -0.2125 1.2994 0.1295 -0.6108 %! -0.2249 1.2767 0.2415 -0.6833 %! -0.2319 1.2354 0.2795 -0.5283 %! -0.2430 1.1914 0.2665 -0.4958 %! -0.2598 1.1599 0.3615 -0.5608 %! -0.2818 1.0552 0.4915 -0.4008 %! -0.3076 0.8983 0.5765 -0.2833 %! -0.3210 0.7477 0.6535 -0.4083 %! -0.3101 0.6146 0.6765 -0.3383 %! -0.2900 0.5163 0.5625 0.0067 %! -0.2723 0.4557 0.4575 -0.0683 %! -0.2465 0.3869 0.4035 -0.2233 %! -0.2099 0.2499 0.3495 0.0092 %! -0.1739 0.1037 0.3055 0.0267 %! -0.1512 0.0119 0.1695 0.1517 %! -0.1484 -0.0519 0.0805 0.2842 %! -0.1510 -0.0699 0.2045 -0.0533 %! -0.1495 -0.0575 0.2485 0.0517 %! -0.1572 -0.0494 0.2205 0.2867 %! -0.1715 -0.0612 0.3355 -0.0658 %! -0.1810 -0.1391 0.3715 0.0442 %! -0.1916 -0.2317 0.3255 0.2367 %! -0.2045 -0.3066 0.3375 0.0842 %! -0.2152 -0.4015 0.3625 0.2167 %! -0.2228 -0.5104 0.4315 0.2292 %! -0.2264 -0.6669 0.3695 0.2817 %! -0.2322 -0.8304 0.2035 0.5217 %! -0.2424 -0.9202 0.2115 0.4992 %! -0.2438 -0.9549 0.3045 0.3742 %! -0.2288 -0.9232 0.2735 0.3792 %! -0.2076 -0.8649 0.1505 0.5142 %! -0.1881 -0.8226 0.1345 0.4142 %! -0.1670 -0.7409 0.1615 0.2617 %! -0.1451 -0.6425 0.1015 0.3617 %! -0.1230 -0.5638 0.1275 0.1917 %! -0.0984 -0.5363 0.2195 0.1492 %! -0.0803 -0.5953 0.1945 0.3917 %! -0.0729 -0.6555 0.1085 0.3267 %! -0.0632 -0.6865 0.1145 0.1717 %! -0.0489 -0.7249 0.1485 0.3442 %! -0.0439 -0.7028 0.0995 0.4717 %! -0.0451 -0.6042 0.0625 0.2117 %! -0.0406 -0.5269 0.0245 0.1367 %! -0.0383 -0.4894 -0.0435 0.3392 %! -0.0485 -0.4438 -0.0455 0.2067 %! -0.0679 -0.4331 -0.0395 0.2042 %! -0.0895 -0.4768 0.0445 0.2217 %! -0.1077 -0.4958 0.1265 0.0817 %! -0.1329 -0.4951 0.0275 0.3717 %! -0.1737 -0.5221 0.0445 0.3217 %! -0.2132 -0.5739 0.2165 0.0742 %! -0.2403 -0.6589 0.2895 0.3267 %! -0.2575 -0.7592 0.3165 0.3442 %! -0.2639 -0.8295 0.2885 0.3417 %! -0.2594 -0.8865 0.2775 0.3992 %! -0.2440 -0.9962 0.2605 0.3367 %! -0.2267 -1.1301 0.0985 0.6167 %! -0.2183 -1.1910 0.0655 0.6417 %! -0.2123 -1.1804 0.1735 0.4192 %! -0.2063 -1.1308 0.1145 0.5367 %! -0.2103 -1.0522 -0.0135 0.6292 %! -0.2177 -0.9723 0.0595 0.3867 %! -0.2085 -0.8974 0.2295 0.2317 %! -0.1816 -0.8520 0.1905 0.4017 %! -0.1471 -0.8541 0.0715 0.3917 %! -0.1048 -0.8622 0.0615 0.2592 %! -0.0576 -0.8463 0.0615 0.3767 %! -0.0136 -0.8192 -0.0185 0.3392 %! 0.0235 -0.7788 -0.1415 0.3292 %! 0.0551 -0.7021 -0.1095 0.2867 %! 0.0856 -0.6467 -0.0675 0.1667 %! 0.1120 -0.6449 -0.2705 0.3217 %! 0.1297 -0.6291 -0.4115 0.2392 %! 0.1433 -0.6098 -0.3755 0.1167 %! 0.1493 -0.5649 -0.4015 0.2967 %! 0.1413 -0.4200 -0.4795 0.1742 %! 0.1251 -0.2349 -0.5045 -0.0333 %! 0.1035 -0.0723 -0.4195 -0.0283 %! 0.0714 0.0871 -0.3485 -0.0533 %! 0.0300 0.2866 -0.3345 -0.1883 %! -0.0115 0.5233 -0.2235 -0.3508 %! -0.0474 0.7916 -0.0725 -0.4258 %! -0.0765 1.1562 -0.0105 -0.6133 %! -0.0981 1.5229 -0.0365 -0.7958 %! -0.1162 1.7436 -0.0585 -0.7983 %! -0.1316 1.8822 0.0025 -0.9008 %! -0.1349 1.9916 0.0605 -1.0358 %! -0.1202 2.0391 0.0065 -1.0233 %! -0.0932 2.0123 -0.0625 -0.9483 %! -0.0609 1.9210 -0.0805 -0.9583 %! -0.0293 1.8059 -0.1785 -0.8458 %! -0.0052 1.7253 -0.2625 -0.7733 %! 0.0091 1.7317 -0.2195 -0.8883 %! 0.0063 1.7910 -0.1925 -0.7333 %! -0.0175 1.8525 -0.1535 -0.7433 %! -0.0460 1.9114 -0.0405 -1.0208 %! -0.0656 1.9435 0.0365 -0.9383 %! -0.0793 1.9967 0.1075 -0.9433 %! -0.0890 2.0655 0.1275 -1.0708 %! -0.0971 2.0547 0.0985 -0.9808 %! -0.1056 1.9936 0.1425 -1.0508 %! -0.1133 1.9289 0.1445 -1.0233 %! -0.1202 1.8841 0.1445 -1.0283 %! -0.1278 1.8653 0.1605 -1.1133 %! -0.1456 1.8273 0.0905 -0.9433 %! -0.1796 1.7730 0.0805 -0.9833 %! -0.2191 1.6584 0.1575 -1.0358 %! -0.2544 1.4743 0.2565 -0.9083 %! -0.2854 1.3089 0.3565 -0.9083 %! -0.3208 1.1494 0.3295 -0.6758 %! -0.3642 0.9927 0.3655 -0.6683 %! -0.4052 0.8263 0.5005 -0.7658 %! -0.4443 0.5780 0.5355 -0.4133 %! -0.4891 0.3103 0.6355 -0.3558 %! -0.5373 0.1107 0.7275 -0.2808 %! -0.5849 0.0334 0.7645 -0.1008 %! -0.6212 0.1017 0.8415 -0.3308 %! -0.6375 0.2141 0.8055 -0.2608 %! -0.6349 0.3187 0.8195 -0.2683 %! -0.6100 0.4173 0.8785 -0.5558 %! -0.5747 0.4404 0.6735 -0.2058 %! -0.5453 0.3679 0.5525 -0.1733 %! -0.5116 0.2496 0.6265 -0.4183 %! -0.4674 0.1314 0.6485 -0.1408 %! -0.4214 0.0316 0.6365 -0.1358 %! -0.3811 -0.0349 0.5035 -0.0783 %! -0.3498 -0.0504 0.4445 0.0092 %! -0.3165 -0.0772 0.5055 -0.2258 %! -0.2736 -0.1911 0.4325 -0.0983 %! -0.2333 -0.3845 0.3495 0.0917 %! -0.2116 -0.6080 0.2855 0.1917 %! -0.2140 -0.7873 0.2095 0.3642 %! -0.2278 -0.9055 0.1795 0.2642 %! -0.2368 -1.0029 0.1665 0.3317 %! -0.2350 -1.0601 0.2255 0.3617 %! -0.2232 -1.0793 0.2145 0.2592 %! -0.2166 -1.0744 -0.0305 0.4942 %! -0.2288 -0.9663 -0.1795 0.4292 %! -0.2482 -0.7630 -0.0595 0.1117 %! -0.2598 -0.5967 0.1215 0.0967 %! -0.2618 -0.4925 0.2025 0.0492 %! -0.2590 -0.4010 0.1605 0.0367 %! -0.2550 -0.3328 0.1185 0.0867 %! -0.2431 -0.2946 0.1605 -0.0808 %! -0.2166 -0.2787 0.1645 -0.0383 %! -0.1817 -0.3122 0.1755 0.1067 %! -0.1408 -0.4076 0.2485 -0.0058 %! -0.0955 -0.5121 0.1335 0.1192 %! -0.0580 -0.5406 -0.0965 0.2292 %! -0.0371 -0.4996 -0.1945 0.1292 %! -0.0357 -0.4631 -0.1495 0.2142 %! -0.0497 -0.4436 -0.0065 0.0717 %! -0.0737 -0.4519 -0.0165 0.0992 %! -0.1119 -0.4687 -0.0865 0.2892 %! -0.1561 -0.4543 0.0375 -0.0208 %! -0.1950 -0.4876 0.1145 0.0817 %! -0.2343 -0.5827 0.1375 0.2967 %! -0.2695 -0.6924 0.2895 0.0017 %! -0.2983 -0.8815 0.3295 0.3067 %! -0.3325 -1.1117 0.3055 0.5492 %! -0.3656 -1.2956 0.3705 0.2967 %! -0.3906 -1.4858 0.4285 0.5417 %! -0.4198 -1.6773 0.4905 0.8242 %! -0.4544 -1.8112 0.5555 0.6917 %! -0.4817 -1.9092 0.5635 0.7317 %! -0.4984 -1.9624 0.5865 0.8517 %! -0.5052 -1.9578 0.6725 0.7392 %! -0.5043 -1.9750 0.6675 0.8467 %! -0.5005 -2.0244 0.6645 0.8942 %! -0.4895 -2.0492 0.7325 0.7292 %! -0.4713 -2.0865 0.6905 0.9517 %! -0.4485 -2.1329 0.7045 0.9417 %! -0.4108 -2.1318 0.7525 0.7467 %! -0.3562 -2.1064 0.6665 0.9792 %! -0.2897 -2.0510 0.5845 0.8717 %! -0.2097 -1.9414 0.4475 0.7142 %! -0.1240 -1.8255 0.2975 0.8092 %! -0.0458 -1.7261 0.1825 0.7217 %! 0.0176 -1.5932 0.0225 0.7017 %! 0.0662 -1.4228 -0.0535 0.5917 %! 0.1049 -1.3030 -0.0845 0.4792 %! 0.1335 -1.2418 -0.1745 0.5192 %! 0.1483 -1.1914 -0.2385 0.4542 %! 0.1466 -1.1992 -0.2885 0.5092 %! 0.1282 -1.2520 -0.2755 0.5542 %! 0.0992 -1.2430 -0.2205 0.5267 %! 0.0699 -1.1510 -0.1345 0.4517 %! 0.0478 -1.0541 -0.0455 0.3867 %! 0.0322 -0.9852 -0.0195 0.4267 %! 0.0207 -0.8964 0.0005 0.2817 %! 0.0094 -0.8166 -0.0155 0.3042 %! -0.0108 -0.7687 0.0055 0.3492 %! -0.0421 -0.6628 0.0855 0.1892 %! -0.0816 -0.5166 0.1335 0.2067 %! -0.1240 -0.4531 0.1985 0.1517 %! -0.1587 -0.4955 0.2175 0.1317 %! -0.1765 -0.5726 0.2375 0.2242 %! -0.1697 -0.6386 0.2575 0.1567 %! -0.1396 -0.6945 0.1815 0.2542 %! -0.0986 -0.7609 0.0965 0.3417 %! -0.0577 -0.8911 0.0185 0.4417 %! -0.0179 -1.0590 0.0145 0.4917 %! 0.0260 -1.1811 0.0785 0.4217 %! 0.0683 -1.2444 0.0305 0.6217 %! 0.0949 -1.1920 -0.0365 0.6392 %! 0.1073 -1.0508 -0.0215 0.4067 %! 0.1155 -0.9975 -0.0025 0.4092 %! 0.1214 -1.0199 0.0115 0.4092 %! 0.1192 -0.9884 0.0035 0.4167 %! 0.1011 -0.8955 -0.0175 0.4642 %! 0.0706 -0.7734 -0.0055 0.3317 %! 0.0435 -0.6574 0.0385 0.1417 %! 0.0254 -0.5681 0.0495 0.1792 %! 0.0072 -0.4466 0.0325 0.2567 %! -0.0080 -0.2535 0.0875 -0.0533 %! -0.0115 -0.0873 0.0575 -0.1208 %! -0.0112 -0.0130 -0.0395 0.0817 %! -0.0089 0.0369 0.0145 -0.1758 %! 0.0030 0.0533 0.0625 -0.1708 %! 0.0194 -0.0025 0.0185 0.0467 %! 0.0374 -0.0338 -0.0445 -0.0783 %! 0.0607 0.0134 -0.0985 -0.0633 %! 0.0869 0.0666 -0.1175 -0.0358 %! 0.1116 0.1083 -0.1945 -0.0683 %! 0.1329 0.1776 -0.2645 -0.0883 %! 0.1515 0.2269 -0.2495 -0.1808 %! 0.1643 0.2195 -0.3015 -0.0533 %! 0.1677 0.2351 -0.3745 -0.0333 %! 0.1713 0.2860 -0.3445 -0.2508 %! 0.1813 0.2769 -0.3195 -0.1283 %! 0.1898 0.1852 -0.3195 -0.0083 %! 0.1937 0.0800 -0.3415 -0.0683 %! 0.1960 0.0125 -0.3745 0.0767 %! 0.2058 -0.0679 -0.2675 -0.0358 %! 0.2313 -0.2067 -0.2205 -0.0433 %! 0.2604 -0.2975 -0.3315 0.2442 %! 0.2806 -0.2723 -0.3645 0.0692 %! 0.2919 -0.2029 -0.3955 0.0117 %! 0.2899 -0.0986 -0.4325 0.0517 %! 0.2731 0.0407 -0.3855 -0.1783 %! 0.2420 0.1252 -0.3585 -0.1008 %! 0.1990 0.1201 -0.2645 -0.1433 %! 0.1551 0.0612 -0.2165 -0.2383 %! 0.1148 -0.0002 -0.2735 -0.0133 %! 0.0804 -0.0214 -0.2015 -0.1033 %! 0.0626 -0.0484 -0.0865 -0.2383 %! 0.0590 -0.1404 -0.1335 0.0367 %! 0.0604 -0.2218 -0.2005 0.0567 %! 0.0731 -0.2085 -0.1645 -0.1383 %! 0.0997 -0.1695 -0.1575 -0.0058 %! 0.1295 -0.1504 -0.2145 0.0242 %! 0.1556 -0.1147 -0.2605 -0.0783 %! 0.1749 -0.1237 -0.2505 0.0192 %! 0.1857 -0.2165 -0.2005 -0.0008 %! 0.1859 -0.2956 -0.2755 0.1167 %! 0.1726 -0.2906 -0.3025 0.1892 %! 0.1556 -0.2457 -0.1625 -0.0583 %! 0.1417 -0.2264 -0.1545 0.0942 %! 0.1269 -0.2038 -0.1905 0.0842 %! 0.1129 -0.1753 -0.1785 -0.0658 %! 0.0992 -0.1663 -0.1525 0.1442 %! 0.0875 -0.1169 -0.0275 -0.1183 %! 0.0790 -0.0582 -0.0545 -0.0283 %! 0.0663 -0.0174 -0.0605 0.0767 %! 0.0562 0.0665 0.0935 -0.3133 %! 0.0531 0.1512 0.0685 -0.1408 %! 0.0461 0.2151 0.0115 -0.1208 %! 0.0374 0.2488 0.0475 -0.3083 %! 0.0370 0.2115 0.1245 -0.2358 %! 0.0492 0.1377 0.1595 -0.3158 %! 0.0650 0.0180 -0.0255 -0.0283 %! 0.0750 -0.1500 -0.0805 0.0317 %! 0.0891 -0.3396 0.0055 -0.0733 %! 0.1133 -0.5416 -0.0395 0.1742 %! 0.1401 -0.7139 -0.1485 0.2417 %! 0.1603 -0.9009 -0.2485 0.4742 %! 0.1780 -1.1065 -0.1815 0.4742 %! 0.2099 -1.2319 -0.1665 0.3667 %! 0.2553 -1.2788 -0.3375 0.6817 %! 0.3076 -1.2666 -0.3695 0.5117 %! 0.3685 -1.2250 -0.3785 0.4217 %! 0.4305 -1.1970 -0.5295 0.5917 %! 0.4856 -1.1524 -0.7095 0.4792 %! 0.5373 -1.1079 -0.7375 0.4042 %! 0.5897 -1.0977 -0.6755 0.3842 %! 0.6362 -1.0851 -0.8095 0.4792 %! 0.6699 -1.0496 -0.9775 0.4067 %! 0.6894 -0.9976 -1.0365 0.3367 %! 0.6901 -0.9060 -1.0275 0.4142 %! 0.6719 -0.7677 -0.9995 0.2142 %! 0.6371 -0.6139 -1.0315 0.2267 %! 0.5849 -0.4463 -0.9335 0.1717 %! 0.5219 -0.2783 -0.7995 0.0167 %! 0.4573 -0.1421 -0.7785 0.0567 %! 0.4020 -0.0451 -0.6615 -0.1833 %! 0.3559 0.0389 -0.5805 -0.0758 %! 0.3050 0.2057 -0.5415 0.0042 %! 0.2521 0.4271 -0.4775 -0.3708 %! 0.2065 0.5643 -0.4755 -0.3033 %! 0.1686 0.6331 -0.3475 -0.3783 %! 0.1358 0.6722 -0.2895 -0.3708 %! 0.1037 0.6797 -0.3195 -0.2408 %! 0.0778 0.6585 -0.2575 -0.4533 %! 0.0624 0.5950 -0.2515 -0.2558 %! 0.0517 0.5407 -0.2285 -0.1908 %! 0.0473 0.5332 -0.1815 -0.3383 %! 0.0465 0.6105 -0.1795 -0.2558 %! 0.0382 0.7590 -0.1585 -0.3383 %! 0.0154 0.8366 -0.1745 -0.3208 %! -0.0179 0.8604 -0.0875 -0.3733 %! -0.0470 0.8872 0.1005 -0.5033 %! -0.0626 0.8752 0.1875 -0.3783 %! -0.0602 0.8813 0.2065 -0.5008 %! -0.0402 0.8863 0.1245 -0.4583 %! -0.0124 0.8391 0.0235 -0.3433 %! 0.0192 0.7919 -0.0165 -0.4783 %! 0.0554 0.7361 -0.0555 -0.3733 %! 0.0929 0.6751 -0.0475 -0.3683 %! 0.1304 0.6184 -0.0965 -0.3933 %! 0.1639 0.5700 -0.2405 -0.2308 %! 0.1967 0.6093 -0.2875 -0.4483 %! 0.2338 0.7093 -0.3125 -0.4933 %! 0.2645 0.8005 -0.3845 -0.3158 %! 0.2869 0.8915 -0.3885 -0.5983 %! 0.3091 0.9385 -0.4365 -0.6158 %! 0.3251 0.9464 -0.5195 -0.4483 %! 0.3311 0.9586 -0.5255 -0.6083 %! 0.3313 0.9269 -0.5245 -0.5558 %! 0.3224 0.8837 -0.5195 -0.4508 %! 0.3000 0.9051 -0.5285 -0.4733 %! 0.2679 0.9557 -0.5235 -0.4883 %! 0.2360 1.0002 -0.4485 -0.6033 %! 0.2076 0.9830 -0.4105 -0.5083 %! 0.1760 0.8692 -0.4285 -0.3633 %! 0.1395 0.7508 -0.4055 -0.3758 %! 0.1052 0.6499 -0.3275 -0.3558 %! 0.0774 0.5699 -0.2655 -0.3033 %! 0.0517 0.6138 -0.2495 -0.3008 %! 0.0213 0.7287 -0.1975 -0.3383 %! -0.0184 0.7977 -0.1255 -0.3633 %! -0.0668 0.8589 -0.0445 -0.4283 %! -0.1192 0.9156 0.0605 -0.5133 %! -0.1747 0.9026 0.1815 -0.4483 %! -0.2323 0.8126 0.3325 -0.4383 %! -0.2839 0.6700 0.4405 -0.4483 %! -0.3233 0.5204 0.4685 -0.3258 %! -0.3485 0.4290 0.5085 -0.3033 %! -0.3550 0.4219 0.5735 -0.3533 %! -0.3426 0.4701 0.5585 -0.3108 %! -0.3172 0.5523 0.4785 -0.3108 %! -0.2791 0.6432 0.4565 -0.4733 %! -0.2315 0.6805 0.4115 -0.4533 %! -0.1894 0.6917 0.2995 -0.3708 %! -0.1591 0.7669 0.2685 -0.5033 %! -0.1352 0.8755 0.2685 -0.5383 %! -0.1136 0.9348 0.2695 -0.5183 %! -0.0901 0.9419 0.2325 -0.6033 %! -0.0643 0.9225 0.1315 -0.5033 %! -0.0407 0.8522 0.0945 -0.4833 %! -0.0225 0.7295 0.0265 -0.4108 %! -0.0137 0.6081 -0.0405 -0.3008 %! -0.0151 0.4741 -0.0395 -0.2883 %! -0.0274 0.3231 -0.0395 -0.1408 %! -0.0520 0.2134 -0.0215 -0.0958 %! -0.0864 0.1254 -0.0295 -0.0233 %! -0.1263 0.0256 0.0055 0.0442 %! -0.1653 -0.0778 0.0825 0.0617 %! -0.1988 -0.1712 0.1285 0.1667 %! -0.2238 -0.2647 0.1945 0.1292 %! -0.2412 -0.3741 0.1865 0.2617 %! -0.2549 -0.4006 0.1935 0.3267 %! -0.2573 -0.3240 0.2765 0.0892 %! -0.2433 -0.2505 0.2645 0.1417 %! -0.2231 -0.1534 0.2415 0.1142 %! -0.2069 -0.0410 0.2085 0.0342 %! -0.2000 0.0238 0.1645 0.0642 %! -0.2001 0.0544 0.1985 -0.0808 %! -0.2037 -0.0099 0.2065 0.0317 %! -0.2104 -0.1788 0.2635 0.1042 %! -0.2160 -0.3564 0.2935 0.1217 %! -0.2186 -0.5024 0.2335 0.2917 %! -0.2186 -0.5871 0.1745 0.3217 %! -0.2108 -0.5916 0.1735 0.2567 %! -0.1901 -0.5845 0.2265 0.1692 %! -0.1679 -0.6241 0.1165 0.4067 %! -0.1573 -0.6377 0.0325 0.3817 %! -0.1530 -0.6189 0.0765 0.1342 %! -0.1569 -0.6339 0.0265 0.4667 %! -0.1734 -0.6051 0.0855 0.3067 %! -0.1951 -0.5319 0.1385 0.1567 %! -0.2237 -0.4474 0.1275 0.3742 %! -0.2571 -0.3082 0.2075 0.0317 %! -0.2879 -0.2211 0.1775 0.0992 %! -0.3188 -0.1793 0.1985 0.1917 %! -0.3429 -0.0881 0.3475 -0.1158 %! -0.3541 -0.0297 0.3825 -0.0333 %! -0.3618 0.0134 0.3265 0.0117 %! -0.3716 0.0785 0.2805 -0.0033 %! -0.3719 0.0910 0.3965 -0.1883 %! -0.3546 0.0535 0.4395 -0.1708 %! -0.3345 0.0320 0.3055 0.1492 %! -0.3160 0.0821 0.3255 -0.1533 %! -0.2892 0.1773 0.3235 -0.2208 %! -0.2587 0.2922 0.2255 -0.0133 %! -0.2214 0.4446 0.2095 -0.3608 %! -0.1671 0.5549 0.2005 -0.4208 %! -0.1050 0.5845 0.1275 -0.2683 %! -0.0486 0.5966 -0.0525 -0.3083 %! 0.0032 0.5948 -0.1795 -0.4133 %! 0.0516 0.5806 -0.2155 -0.3683 %! 0.0863 0.5808 -0.2465 -0.2633 %! 0.1019 0.5570 -0.2995 -0.3258 %! 0.1007 0.4895 -0.3555 -0.2833 %! 0.0823 0.4475 -0.3445 -0.2083 %! 0.0486 0.4517 -0.3085 -0.1983 %! 0.0106 0.4461 -0.2495 -0.2433 %! -0.0204 0.3968 -0.1525 -0.2433 %! -0.0427 0.3374 -0.1145 -0.1308 %! -0.0570 0.3425 -0.1035 -0.2283 %! -0.0662 0.4094 -0.1785 -0.1583 %! -0.0749 0.4980 -0.1755 -0.1458 %! -0.0767 0.5981 -0.0495 -0.3908 %! -0.0689 0.6888 -0.0465 -0.2683 %! -0.0577 0.7881 -0.0605 -0.3833 %! -0.0469 0.8619 -0.1055 -0.4733 %! -0.0422 0.8321 -0.1485 -0.3083 %! -0.0387 0.7466 -0.0695 -0.5408 %! -0.0309 0.6634 -0.0885 -0.3933 %! -0.0268 0.5794 -0.0795 -0.2908 %! -0.0307 0.5002 -0.0445 -0.4458 %! -0.0508 0.4760 -0.1505 -0.1608 %! -0.0894 0.5679 -0.0875 -0.3133 %! -0.1283 0.7078 0.1175 -0.6508 %! -0.1663 0.7919 0.1845 -0.3833 %! -0.2133 0.8265 0.2345 -0.4483 %! -0.2599 0.8374 0.3125 -0.6758 %! -0.2969 0.8162 0.3435 -0.4808 %! -0.3210 0.7420 0.4165 -0.5058 %! -0.3215 0.5730 0.4795 -0.5808 %! -0.3013 0.2979 0.4085 -0.1883 %! -0.2680 0.0143 0.3635 -0.1408 %! -0.2172 -0.1931 0.2695 -0.1933 %! -0.1568 -0.3482 0.0795 0.1542 %! -0.0990 -0.5055 0.0565 0.0917 %! -0.0475 -0.7178 -0.0035 0.2642 %! -0.0025 -0.9341 -0.0295 0.3692 %! 0.0428 -1.0834 -0.0325 0.2067 %! 0.0814 -1.2097 -0.2115 0.6567 %! 0.1090 -1.3175 -0.1885 0.4517 %! 0.1336 -1.4127 -0.1795 0.3767 %! 0.1445 -1.5065 -0.3165 0.8592 %! 0.1424 -1.5894 -0.2155 0.4442 %! 0.1379 -1.7094 -0.2005 0.5842 %! 0.1194 -1.7628 -0.2475 0.9192 %! 0.0871 -1.6474 -0.1865 0.5092 %! 0.0541 -1.4894 -0.1495 0.4967 %! 0.0205 -1.3807 -0.0495 0.4817 %! -0.0189 -1.3325 -0.0365 0.4492 %! -0.0630 -1.3452 -0.0175 0.4417 %! -0.1055 -1.4067 0.0835 0.4317 %! -0.1473 -1.4711 0.1405 0.6042 %! -0.1886 -1.4663 0.2055 0.4892 %! -0.2252 -1.4405 0.2435 0.5292 %! -0.2545 -1.4530 0.3345 0.5367 %! -0.2726 -1.4790 0.3915 0.4667 %! -0.2804 -1.5291 0.3805 0.6292 %! -0.2800 -1.6064 0.4145 0.5967 %! -0.2711 -1.6577 0.4125 0.6642 %! -0.2543 -1.6503 0.4445 0.6142 %! -0.2332 -1.6413 0.3945 0.6267 %! -0.2186 -1.6598 0.2995 0.8167 %! -0.2105 -1.6905 0.3655 0.6167 %! -0.2016 -1.7773 0.3605 0.6767 %! -0.1990 -1.8767 0.3035 0.8442 %! -0.2109 -1.9359 0.2905 0.8542 %! -0.2309 -1.9978 0.3625 0.8267 %! -0.2464 -2.0725 0.4795 0.7117 %! -0.2598 -2.1566 0.3915 1.0417 %! -0.2729 -2.2060 0.4415 0.9092 %! -0.2729 -2.2146 0.5805 0.6867 %! -0.2651 -2.1907 0.4845 1.0592 %! -0.2563 -2.0544 0.4705 0.7217 %! -0.2420 -1.8793 0.4675 0.5817 %! -0.2313 -1.7438 0.4625 0.7617 %! -0.2284 -1.5795 0.5095 0.4092 %! -0.2306 -1.4005 0.4165 0.4717 %! -0.2380 -1.2226 0.4445 0.3817 %! -0.2426 -1.0615 0.5195 0.1817 %! -0.2387 -0.9443 0.4795 0.2317 %! -0.2262 -0.8374 0.4195 0.1167 %! -0.2090 -0.7585 0.3505 0.1867 %! -0.1902 -0.6965 0.3525 0.1167 %! -0.1702 -0.6160 0.2955 0.0917 %! -0.1530 -0.5535 0.2285 0.1892 %! -0.1379 -0.5331 0.2845 0.0267 %! -0.1232 -0.5745 0.2955 0.1692 %! -0.1141 -0.6693 0.2535 0.3117 %! -0.1051 -0.7692 0.2395 0.2017 %! -0.0888 -0.8714 0.2465 0.3167 %! -0.0706 -0.9784 0.2345 0.4467 %! -0.0576 -1.0470 0.1525 0.4467 %! -0.0533 -1.0386 0.0805 0.4942 %! -0.0564 -0.9563 0.0985 0.4417 %! -0.0595 -0.8278 0.1525 0.2792 %! -0.0590 -0.6936 0.1335 0.2642 %! -0.0571 -0.6112 0.1255 0.2042 %! -0.0560 -0.6221 0.1465 0.1867 %! -0.0570 -0.6806 0.1365 0.2192 %! -0.0627 -0.7056 0.1195 0.1917 %! -0.0791 -0.6703 0.1115 0.3067 %! -0.1047 -0.5488 0.2345 0.1217 %! -0.1276 -0.3868 0.3215 -0.0508 %! -0.1452 -0.2989 0.2885 0.0592 %! -0.1579 -0.3142 0.3435 -0.1133 %! -0.1698 -0.3930 0.3155 0.1142 %! -0.1872 -0.4033 0.3395 0.1592 %! -0.1990 -0.3194 0.4595 -0.2333 %! -0.2078 -0.2826 0.3695 0.1642 %! -0.2264 -0.2406 0.3875 0.1117 %! -0.2433 -0.1958 0.4715 -0.2008 %! -0.2512 -0.2855 0.4245 0.1467 %! -0.2515 -0.4154 0.4715 0.0942 %! -0.2396 -0.5006 0.4585 0.1692 %! -0.2129 -0.5207 0.4565 0.2067 %! -0.1705 -0.4377 0.3985 0.0617 %! -0.1208 -0.3532 0.2195 0.2492 %! -0.0686 -0.3256 0.2095 0.0667 %! -0.0112 -0.3184 0.1815 0.0317 %! 0.0433 -0.3352 0.0535 0.2317 %! 0.0918 -0.4017 -0.0255 0.0992 %! 0.1426 -0.5515 -0.0725 0.1567 %! 0.1971 -0.7994 -0.1095 0.3167 %! 0.2489 -1.0643 -0.2455 0.4467 %! 0.2920 -1.1858 -0.3815 0.4692 %! 0.3209 -1.1632 -0.4625 0.5017 %! 0.3329 -1.1275 -0.5055 0.5192 %! 0.3346 -1.1285 -0.4975 0.3542 %! 0.3295 -1.1701 -0.5175 0.5017 %! 0.3165 -1.1697 -0.4415 0.4092 %! 0.2959 -1.0758 -0.4215 0.3492 %! 0.2624 -0.9392 -0.4725 0.4917 %! 0.2233 -0.7484 -0.3445 0.0942 %! 0.1902 -0.5707 -0.2465 0.1017 %! 0.1574 -0.4626 -0.2065 0.2217 %! 0.1245 -0.3397 -0.1795 -0.0258 %! 0.0987 -0.1692 -0.2115 0.0592 %! 0.0892 0.0685 -0.1245 -0.2233 %! 0.1028 0.3453 -0.1275 -0.3658 %! 0.1273 0.5826 -0.2405 -0.2433 %! 0.1497 0.7764 -0.2575 -0.4733 %! 0.1646 0.9231 -0.3065 -0.4433 %! 0.1718 1.0326 -0.3265 -0.4683 %! 0.1809 1.1361 -0.2795 -0.6558 %! 0.1953 1.2657 -0.2505 -0.6283 %! 0.2050 1.4464 -0.2775 -0.6108 %! 0.2068 1.6188 -0.3545 -0.7183 %! 0.2126 1.7093 -0.3495 -0.9183 %! 0.2281 1.7044 -0.3355 -0.8058 %! 0.2457 1.6703 -0.3325 -0.7608 %! 0.2611 1.6585 -0.3575 -0.9008 %! 0.2661 1.6143 -0.4705 -0.6558 %! 0.2578 1.5015 -0.4585 -0.7583 %! 0.2451 1.2956 -0.4175 -0.8033 %! 0.2207 1.0253 -0.4485 -0.3858 %! 0.1768 0.8074 -0.3655 -0.4483 %! 0.1220 0.6616 -0.2795 -0.4508 %! 0.0620 0.5891 -0.2285 -0.3108 %! 0.0002 0.5812 -0.1485 -0.4083 %! -0.0594 0.5578 -0.0655 -0.3083 %! -0.1114 0.5396 0.0895 -0.3433 %! -0.1434 0.5741 0.2125 -0.4708 %! -0.1458 0.6506 0.2315 -0.4908 %! -0.1214 0.7486 0.1975 -0.5258 %! -0.0806 0.8194 0.1325 -0.4908 %! -0.0301 0.8304 0.0945 -0.5433 %! 0.0299 0.7454 0.0665 -0.5858 %! 0.0900 0.5891 -0.0315 -0.3883 %! 0.1351 0.4885 -0.1265 -0.2783 %! 0.1632 0.4505 -0.1695 -0.3683 %! 0.1762 0.3982 -0.2285 -0.2433 %! 0.1710 0.3510 -0.2465 -0.1358 %! 0.1548 0.3268 -0.1755 -0.2458 %! 0.1398 0.2582 -0.1175 -0.2033 %! 0.1272 0.1084 -0.1365 -0.0433 %! 0.1135 -0.0557 -0.1765 0.0192 %! 0.1006 -0.2035 -0.1505 0.0517 %! 0.0938 -0.3889 -0.0855 0.1217 %! 0.0944 -0.6404 -0.0965 0.2717 %! 0.1026 -0.9610 -0.1245 0.3942 %! 0.1201 -1.2709 -0.1525 0.5192 %! 0.1463 -1.4491 -0.2075 0.6042 %! 0.1781 -1.5392 -0.2885 0.5967 %! 0.2058 -1.5973 -0.4185 0.7367 %! 0.2213 -1.5830 -0.4225 0.7092 %! 0.2301 -1.5379 -0.3435 0.5192 %! 0.2335 -1.5207 -0.3875 0.6617 %! 0.2284 -1.5386 -0.3855 0.6292 %! 0.2245 -1.5724 -0.3055 0.4667 %! 0.2271 -1.5665 -0.2665 0.5442 %! 0.2266 -1.5256 -0.3165 0.5842 %! 0.2127 -1.4837 -0.3835 0.5992 %! 0.1882 -1.4411 -0.2855 0.4917 %! 0.1628 -1.3895 -0.1655 0.4392 %! 0.1359 -1.2722 -0.1825 0.5567 %! 0.1069 -1.0629 -0.1565 0.3892 %! 0.0833 -0.7969 -0.0815 0.2242 %! 0.0679 -0.5100 -0.0695 0.1892 %! 0.0615 -0.2389 -0.1075 -0.0033 %! 0.0664 0.0303 -0.1485 -0.0908 %! 0.0822 0.3079 -0.1295 -0.1783 %! 0.1140 0.5658 -0.1465 -0.4283 %! 0.1627 0.7941 -0.3005 -0.5208 %! 0.2134 0.9634 -0.4675 -0.4783 %! 0.2515 1.0687 -0.5295 -0.5583 %! 0.2738 1.1300 -0.5445 -0.6233 %! 0.2803 1.1322 -0.5615 -0.6283 %! 0.2668 1.0979 -0.5675 -0.5358 %! 0.2311 1.0801 -0.4795 -0.5458 %! 0.1799 1.0888 -0.3715 -0.6558 %! 0.1121 1.1266 -0.4035 -0.4358 %! 0.0311 1.2269 -0.3055 -0.5658 %! -0.0402 1.3304 -0.0415 -0.9458 %! -0.0970 1.3157 0.0015 -0.6333 %! -0.1536 1.2545 -0.0375 -0.5383 %! -0.2054 1.2245 0.0305 -0.7933 %! -0.2445 1.1415 0.1235 -0.5958 %! -0.2725 1.0068 0.2105 -0.5658 %! -0.2878 0.8388 0.2305 -0.5408 %! -0.2910 0.6395 0.2735 -0.3933 %! -0.2874 0.5035 0.3115 -0.3133 %! -0.2779 0.4273 0.2875 -0.2908 %! -0.2564 0.3242 0.2965 -0.3508 %! -0.2262 0.1788 0.3125 -0.1683 %! -0.1995 0.0612 0.3315 -0.0883 %! -0.1818 0.0445 0.2725 -0.1558 %! -0.1738 0.0600 0.1725 -0.0008 %! -0.1659 0.0355 0.2655 -0.2008 %! -0.1461 -0.0219 0.3315 -0.2508 %! -0.1285 -0.0978 0.1775 0.1717 %! -0.1227 -0.0947 0.1175 -0.0583 %! -0.1180 0.0203 0.1475 -0.2958 %! -0.1209 0.1808 0.0885 -0.0583 %! -0.1447 0.3916 0.0655 -0.2633 %! -0.1867 0.6153 0.1075 -0.3983 %! -0.2364 0.7858 0.2675 -0.4633 %! -0.2797 0.8695 0.3975 -0.6508 %! -0.3113 0.8415 0.3245 -0.4733 %! -0.3328 0.7698 0.3295 -0.4683 %! -0.3393 0.6590 0.4225 -0.5358 %! -0.3336 0.4096 0.3615 -0.2583 %! -0.3268 0.0623 0.2565 -0.0833 %! -0.3236 -0.2521 0.2545 0.0217 %! -0.3274 -0.4415 0.3015 0.1842 %! -0.3401 -0.4715 0.3165 0.1442 %! -0.3613 -0.3861 0.2875 0.1192 %! -0.3928 -0.2126 0.3465 0.1017 %! -0.4270 0.0263 0.5095 -0.1383 %! -0.4483 0.2006 0.5895 -0.2933 %! -0.4524 0.2266 0.5585 -0.1858 %! -0.4430 0.1870 0.5985 -0.2108 %! -0.4182 0.1108 0.6425 -0.2158 %! -0.3771 -0.0376 0.5545 -0.0483 %! -0.3187 -0.1650 0.4475 -0.0533 %! -0.2411 -0.2002 0.3935 -0.0583 %! -0.1509 -0.2036 0.2985 0.0642 %! -0.0553 -0.2188 0.1135 0.0367 %! 0.0448 -0.2304 -0.0875 -0.0033 %! 0.1459 -0.2073 -0.1945 0.0142 %! 0.2399 -0.1473 -0.2935 -0.0083 %! 0.3167 -0.0702 -0.4665 -0.0133 %! 0.3672 -0.0015 -0.6225 -0.0183 %! 0.3880 0.0378 -0.6905 -0.0008 %! 0.3879 0.0570 -0.6595 -0.1233 %! 0.3785 0.0166 -0.6325 -0.1958 %! 0.3514 -0.0870 -0.7245 0.1167 %! 0.2945 -0.1448 -0.7365 0.1692 %! 0.2217 -0.1525 -0.6035 -0.0558 %! 0.1512 -0.1462 -0.5155 0.0192 %! 0.0848 -0.0799 -0.4575 0.1092 %! 0.0256 0.0141 -0.3195 -0.0783 %! -0.0216 0.0462 -0.2265 -0.0958 %! -0.0663 0.0041 -0.2675 0.1267 %! -0.1129 -0.0417 -0.2395 0.0467 %! -0.1489 -0.0732 -0.0465 -0.1133 %! -0.1735 -0.1401 0.0665 0.1492 %! -0.1959 -0.2071 0.0965 0.1167 %! -0.2177 -0.2551 0.0575 0.0867 %! -0.2382 -0.3215 0.0755 0.3017 %! -0.2444 -0.3974 0.2365 0.0692 %! -0.2240 -0.5052 0.2665 0.1617 %! -0.1884 -0.5983 0.1795 0.4567 %! -0.1441 -0.5736 0.1695 0.2567 %! -0.0834 -0.5133 0.1105 0.2092 %! -0.0064 -0.5083 -0.0085 0.2642 %! 0.0780 -0.4662 -0.1285 0.2517 %! 0.1629 -0.3218 -0.1705 0.1792 %! 0.2469 -0.1316 -0.2225 -0.0458 %! 0.3188 0.0698 -0.4895 0.0292 %! 0.3657 0.2711 -0.6915 -0.0558 %! 0.3947 0.3881 -0.6545 -0.3083 %! 0.4166 0.3752 -0.6155 -0.2233 %! 0.4322 0.3157 -0.6895 -0.1933 %! 0.4374 0.2851 -0.8475 -0.1083 %! 0.4346 0.2856 -0.8755 -0.1283 %! 0.4354 0.2982 -0.8335 -0.3133 %! 0.4374 0.3127 -0.9455 -0.0808 %! 0.4289 0.3315 -0.9695 -0.0958 %! 0.4117 0.3484 -0.8695 -0.2483 %! 0.3875 0.3695 -0.8635 -0.1233 %! 0.3534 0.4046 -0.8965 -0.2008 %! 0.3109 0.4103 -0.8595 -0.2033 %! 0.2621 0.3735 -0.6865 -0.1533 %! 0.2091 0.3471 -0.5615 -0.1958 %! 0.1487 0.3500 -0.6085 -0.0883 %! 0.0755 0.4095 -0.5965 -0.0558 %! -0.0007 0.5566 -0.3735 -0.2433 %! -0.0624 0.7375 -0.1545 -0.3708 %! -0.1055 0.9106 -0.1155 -0.3558 %! -0.1340 1.0728 -0.0775 -0.4608 %! -0.1476 1.2037 -0.0005 -0.5433 %! -0.1445 1.3093 0.0225 -0.5708 %! -0.1205 1.4124 0.0125 -0.6983 %! -0.0755 1.5512 -0.0005 -0.7383 %! -0.0197 1.7541 -0.0045 -0.7633 %! 0.0390 1.9343 -0.0825 -0.9433 %! 0.0935 1.9883 -0.2615 -0.9758 %! 0.1276 1.9447 -0.3705 -0.8358 %! 0.1302 1.8773 -0.3225 -0.8033 %! 0.1103 1.7874 -0.2095 -0.9333 %! 0.0776 1.6447 -0.2025 -0.8183 %! 0.0259 1.5027 -0.2675 -0.5433 %! -0.0390 1.4181 -0.1615 -0.7108 %! -0.0957 1.2941 -0.0355 -0.7858 %! -0.1442 1.0659 -0.0665 -0.4158 %! -0.1955 0.8406 -0.0395 -0.3733 %! -0.2470 0.6814 0.0665 -0.4008 %! -0.2951 0.5478 0.1495 -0.2533 %! -0.3391 0.4030 0.1875 -0.2308 %! -0.3757 0.2509 0.2445 -0.1508 %! -0.3997 0.0973 0.4195 -0.1908 %! -0.4133 -0.1007 0.4435 0.0092 %! -0.4258 -0.3112 0.3315 0.2217 %! -0.4290 -0.4816 0.4055 0.0417 %! -0.4116 -0.6439 0.5125 0.1667 %! -0.3855 -0.7518 0.4715 0.3892 %! -0.3658 -0.8248 0.3845 0.3667 %! -0.3557 -0.9450 0.3525 0.4867 %! -0.3478 -1.0281 0.4715 0.4367 %! -0.3283 -1.0926 0.5655 0.3717 %! -0.2970 -1.2113 0.4865 0.5767 %! -0.2629 -1.3095 0.4455 0.5692 %! -0.2277 -1.4162 0.4285 0.5542 %! -0.1940 -1.5722 0.2955 0.7242 %! -0.1658 -1.7209 0.1985 0.7442 %! -0.1448 -1.8574 0.2275 0.7892 %! -0.1375 -1.9598 0.2405 0.9342 %! -0.1496 -1.9831 0.1605 0.9617 %! -0.1754 -1.9571 0.0975 0.8592 %! -0.2079 -1.9523 0.1425 0.9042 %! -0.2432 -1.9481 0.2485 0.9167 %! -0.2732 -1.8977 0.2955 0.8142 %! -0.2909 -1.8860 0.2895 0.8067 %! -0.2993 -1.9321 0.2625 0.8917 %! -0.3030 -1.9254 0.2225 0.9267 %! -0.2944 -1.8378 0.2495 0.7292 %! -0.2680 -1.7114 0.2665 0.6842 %! -0.2381 -1.6035 0.2105 0.8692 %! -0.2142 -1.5457 0.1815 0.7167 %! -0.1883 -1.5002 0.1355 0.6142 %! -0.1554 -1.4121 0.0995 0.6692 %! -0.1165 -1.2429 0.1295 0.4617 %! -0.0822 -1.0065 0.0435 0.5217 %! -0.0685 -0.7615 -0.0505 0.5117 %! -0.0718 -0.5596 -0.0245 0.1767 %! -0.0823 -0.4178 -0.0155 0.2067 %! -0.0983 -0.3206 0.0595 0.2192 %! -0.1120 -0.2728 0.1795 0.0367 %! -0.1158 -0.3035 0.2005 0.0992 %! -0.1137 -0.4179 0.1345 0.2017 %! -0.1111 -0.5628 0.0385 0.2992 %! -0.1055 -0.6991 0.0785 0.2917 %! -0.0926 -0.8462 0.1725 0.3192 %! -0.0805 -0.9604 0.1215 0.4942 %! -0.0829 -0.9911 0.0025 0.5617 %! -0.0989 -0.9748 0.0055 0.4517 %! -0.1198 -0.9313 0.0895 0.3517 %! -0.1470 -0.8188 0.0865 0.4717 %! -0.1825 -0.5767 0.1175 0.3517 %! -0.2078 -0.2504 0.2775 -0.1133 %! -0.2118 0.0583 0.2575 -0.1083 %! -0.2050 0.3599 0.1075 -0.1258 %! -0.1866 0.6426 0.1025 -0.5283 %! -0.1520 0.8930 0.1295 -0.5483 %! -0.1091 1.1596 0.1155 -0.6283 %! -0.0649 1.3843 -0.0185 -0.8033 %! -0.0246 1.5324 -0.1305 -0.8133 %! 0.0046 1.6659 -0.1205 -0.8933 %! 0.0178 1.7974 -0.1815 -0.8083 %! 0.0241 1.8634 -0.1665 -0.9808 %! 0.0406 1.7408 -0.1085 -1.0333 %! 0.0601 1.4745 -0.2045 -0.5733 %! 0.0706 1.2181 -0.2795 -0.5683 %! 0.0761 0.9181 -0.3655 -0.4383 %! 0.0813 0.5557 -0.3455 -0.1333 %! 0.0948 0.1924 -0.1705 -0.2608 %! 0.1104 -0.2105 -0.2785 0.2767 %! 0.1106 -0.5572 -0.3925 0.5542 %! 0.1075 -0.7736 -0.2685 0.2067 %! 0.1162 -0.9587 -0.2095 0.4942 %! 0.1310 -1.0968 -0.1835 0.5617 %! 0.1419 -1.1625 -0.2115 0.5117 %! 0.1387 -1.1825 -0.2185 0.6392 %! 0.1236 -1.1781 -0.1115 0.3592 %! 0.1019 -1.2740 -0.1395 0.5267 %! 0.0726 -1.4467 -0.0835 0.6167 %! 0.0408 -1.5448 0.1065 0.4117 %! 0.0016 -1.5764 0.0855 0.7292 %! -0.0515 -1.5247 0.0165 0.6792 %! -0.0978 -1.3839 0.1515 0.2642 %! -0.1198 -1.2895 0.3075 0.3542 %! -0.1232 -1.2714 0.3285 0.4542 %! -0.1137 -1.2652 0.2525 0.3392 %! -0.0937 -1.2585 0.1695 0.4317 %! -0.0676 -1.2220 0.1545 0.4642 %! -0.0336 -1.1269 0.1285 0.2617 %! 0.0051 -0.9943 0.0255 0.3567 %! 0.0358 -0.8408 -0.0185 0.3917 %! 0.0583 -0.6968 -0.0065 0.1442 %! 0.0780 -0.6212 -0.1115 0.1767 %! 0.0897 -0.6090 -0.2035 0.2367 %! 0.0864 -0.6100 -0.1845 0.2517 %! 0.0693 -0.5884 -0.0925 0.3142 %! 0.0521 -0.5452 0.0195 0.0817 %! 0.0422 -0.5450 -0.0485 0.2167 %! 0.0304 -0.5974 -0.0775 0.3592 %! 0.0179 -0.6380 0.0365 0.1317 %! 0.0090 -0.6589 0.0385 0.3142 %! 0.0029 -0.6802 0.0675 0.3042 %! 0.0083 -0.7241 0.1465 0.1517 %! 0.0292 -0.8090 0.1455 0.3517 %! 0.0665 -0.9103 0.1315 0.2267 %! 0.1175 -0.9751 -0.0355 0.3342 %! 0.1700 -0.9540 -0.1515 0.4492 %! 0.2239 -0.8772 -0.1285 0.1217 %! 0.2782 -0.7929 -0.2845 0.2592 %! 0.3202 -0.6856 -0.4145 0.2367 %! 0.3485 -0.5863 -0.4115 -0.0058 %! 0.3620 -0.5588 -0.4445 0.1667 %! 0.3588 -0.6270 -0.4405 0.1317 %! 0.3445 -0.7807 -0.4595 0.1717 %! 0.3223 -0.9466 -0.4315 0.3642 %! 0.2962 -1.0383 -0.3285 0.3042 %! 0.2693 -1.0274 -0.3485 0.3917 %! 0.2392 -0.9591 -0.3755 0.3742 %! 0.2038 -0.9085 -0.3265 0.3042 %! 0.1593 -0.8824 -0.2615 0.4042 %! 0.1061 -0.8394 -0.1675 0.3567 %! 0.0545 -0.7459 -0.0505 0.2442 %! 0.0122 -0.6037 0.0655 0.1592 %! -0.0254 -0.4611 0.0855 0.2192 %! -0.0626 -0.3247 0.0695 0.1617 %! -0.0875 -0.1777 0.1505 -0.1158 %! -0.0905 -0.0481 0.2245 -0.0983 %! -0.0766 0.0802 0.2345 -0.1633 %! -0.0549 0.2306 0.1405 -0.2558 %! -0.0366 0.3284 0.0435 -0.1458 %! -0.0207 0.3329 0.1075 -0.3483 %! 0.0026 0.3131 0.1475 -0.3983 %! 0.0262 0.3154 0.1045 -0.1858 %! 0.0400 0.3280 0.0795 -0.2658 %! 0.0476 0.3332 0.0685 -0.3658 %! 0.0513 0.3067 0.0155 -0.3033 %! 0.0436 0.2422 -0.0525 -0.2133 %! 0.0191 0.1745 -0.0125 -0.1783 %! -0.0154 0.1173 0.1125 -0.2333 %! -0.0520 0.0566 0.1405 -0.1883 %! -0.0912 -0.0241 0.1125 -0.1083 %! -0.1337 -0.1957 0.1615 -0.0583 %! -0.1775 -0.4680 0.2625 0.0967 %! -0.2182 -0.7258 0.3555 0.1792 %! -0.2523 -0.9660 0.3795 0.3267 %! -0.2796 -1.2414 0.4355 0.4692 %! -0.3002 -1.4781 0.5115 0.5442 %! -0.3161 -1.6356 0.4915 0.7167 %! -0.3243 -1.7215 0.5205 0.6517 %! -0.3173 -1.7280 0.6125 0.5417 %! -0.3033 -1.6605 0.5655 0.7367 %! -0.2915 -1.5221 0.5125 0.5692 %! -0.2740 -1.4133 0.5035 0.3317 %! -0.2508 -1.3893 0.4615 0.5317 %! -0.2274 -1.3097 0.5105 0.3317 %! -0.2072 -1.1267 0.4385 0.2692 %! -0.2012 -0.8891 0.3175 0.3692 %! -0.2073 -0.6029 0.3925 -0.0383 %! -0.2127 -0.3371 0.4275 -0.1183 %! -0.2136 -0.1458 0.4635 -0.1808 %! -0.2108 -0.0281 0.4615 -0.3008 %! -0.2106 0.0331 0.3555 -0.0583 %! -0.2045 0.0892 0.4145 -0.3483 %! -0.1740 0.1431 0.4105 -0.4808 %! -0.1301 0.2082 0.2505 -0.1883 %! -0.0931 0.3034 0.1765 -0.3183 %! -0.0690 0.3629 0.0665 -0.2933 %! -0.0537 0.4034 0.0305 -0.3458 %! -0.0359 0.4826 0.0655 -0.5758 %! -0.0191 0.5747 0.0015 -0.3583 %! -0.0119 0.6836 0.0125 -0.4958 %! -0.0100 0.8082 -0.0155 -0.6258 %! -0.0110 0.9267 -0.0725 -0.5783 %! -0.0131 1.0266 -0.0315 -0.7833 %! -0.0191 1.0669 -0.0235 -0.6333 %! -0.0329 1.0852 0.0475 -0.6808 %! -0.0476 1.1486 0.1005 -0.8408 %! -0.0613 1.2331 0.0555 -0.6658 %! -0.0695 1.2863 0.1305 -0.8658 %! -0.0629 1.2536 0.1935 -0.9183 %! -0.0502 1.1622 0.1295 -0.6433 %! -0.0420 1.0762 0.1075 -0.7283 %! -0.0378 0.9463 0.0865 -0.6458 %! -0.0383 0.7694 0.0815 -0.4908 %! -0.0424 0.6196 0.1055 -0.5508 %! -0.0527 0.4838 0.0825 -0.3458 %! -0.0750 0.3620 0.1135 -0.2508 %! -0.1029 0.3257 0.1775 -0.3258 %! -0.1237 0.3916 0.2245 -0.4083 %! -0.1362 0.4953 0.2215 -0.4708 %! -0.1525 0.5921 0.2075 -0.3783 %! -0.1774 0.6786 0.2845 -0.5608 %! -0.2054 0.7145 0.3265 -0.5958 %! -0.2364 0.6962 0.3055 -0.4108 %! -0.2619 0.6799 0.4275 -0.6658 %! -0.2722 0.6582 0.4825 -0.6183 %! -0.2772 0.6341 0.3975 -0.3433 %! -0.2753 0.6139 0.3925 -0.6433 %! -0.2569 0.5279 0.3515 -0.5758 %! -0.2352 0.3880 0.2905 -0.2933 %! -0.2256 0.2776 0.2425 -0.2983 %! -0.2253 0.2197 0.2435 -0.2883 %! -0.2240 0.1661 0.3435 -0.3258 %! -0.2194 0.0552 0.3135 -0.1083 %! -0.2107 -0.0586 0.2945 -0.0883 %! -0.1862 -0.1745 0.3505 -0.1983 %! -0.1449 -0.3729 0.2845 0.1492 %! -0.0923 -0.5517 0.2365 0.0692 %! -0.0331 -0.6555 0.0805 0.1867 %! 0.0188 -0.7057 -0.0615 0.4342 %! 0.0632 -0.6388 -0.0115 0.0117 %! 0.1011 -0.5252 -0.1195 0.1917 %! 0.1224 -0.4038 -0.1795 0.1617 %! 0.1294 -0.2700 -0.1185 -0.2408 %! 0.1151 -0.2191 -0.2065 0.1567 %! 0.0729 -0.1642 -0.1515 -0.0483 %! 0.0192 -0.0712 -0.0105 -0.3533 %! -0.0439 -0.0512 0.0485 0.0167 %! -0.1182 -0.0612 0.2055 -0.1708 %! -0.1887 -0.0999 0.2975 -0.2733 %! -0.2494 -0.1813 0.3405 -0.0633 %! -0.2982 -0.2755 0.4775 -0.1683 %! -0.3334 -0.4156 0.5205 -0.0333 %! -0.3602 -0.5483 0.5275 0.1142 %! -0.3767 -0.6765 0.6015 0.0492 %! -0.3788 -0.8510 0.6165 0.1667 %! -0.3733 -0.9980 0.5815 0.3117 %! -0.3666 -1.1136 0.5495 0.3617 %! -0.3586 -1.2004 0.5285 0.3817 %! -0.3497 -1.1950 0.5185 0.4042 %! -0.3411 -1.1416 0.4925 0.3942 %! -0.3308 -1.1319 0.4865 0.3667 %! -0.3151 -1.1897 0.5185 0.4042 %! -0.2909 -1.2479 0.5295 0.4217 %! -0.2559 -1.2221 0.4895 0.3667 %! -0.2137 -1.1087 0.4145 0.3742 %! -0.1715 -0.9637 0.3655 0.3142 %! -0.1311 -0.8325 0.3315 0.2117 %! -0.0919 -0.6882 0.2665 0.1967 %! -0.0507 -0.5098 0.2545 0.0167 %! -0.0053 -0.3457 0.2025 -0.0408 %! 0.0384 -0.2101 0.0915 -0.0308 %! 0.0784 -0.1111 0.0025 -0.1683 %! 0.1181 -0.0751 -0.0865 -0.1308 %! 0.1605 -0.0730 -0.1175 -0.2033 %! 0.2059 -0.1001 -0.2135 -0.2008 %! 0.2462 -0.2077 -0.3615 -0.0183 %! 0.2772 -0.4270 -0.4225 -0.0558 %! 0.3007 -0.7541 -0.4925 0.1717 %! 0.3146 -1.1303 -0.5105 0.3567 %! 0.3186 -1.4819 -0.5215 0.4617 %! 0.3091 -1.7927 -0.5565 0.7917 %! 0.2890 -2.0763 -0.4785 0.7642 %! 0.2692 -2.3198 -0.4585 0.8617 %! 0.2490 -2.4531 -0.4775 1.1192 %! 0.2292 -2.4601 -0.4055 0.9467 %! 0.2131 -2.4495 -0.3885 0.9992 %! 0.1952 -2.4696 -0.3775 1.0642 %! 0.1710 -2.4586 -0.3765 1.0317 %! 0.1456 -2.4272 -0.2785 0.9392 %! 0.1230 -2.4762 -0.1635 0.9317 %! 0.0921 -2.5929 -0.1965 1.2292 %! 0.0478 -2.6509 -0.1055 1.0467 %! -0.0025 -2.6497 0.0055 1.0742 %! -0.0578 -2.6410 0.0905 1.2692 %! -0.1096 -2.5957 0.2545 0.9617 %! -0.1513 -2.5087 0.2895 1.1817 %! -0.1795 -2.3898 0.4275 1.0492 %! -0.1794 -2.2767 0.5375 0.6942 %! -0.1570 -2.1483 0.3505 1.0492 %! -0.1248 -1.8914 0.3095 0.7342 %! -0.0796 -1.5767 0.2835 0.4517 %! -0.0317 -1.3301 0.1355 0.6567 %! 0.0092 -1.1046 0.0485 0.3492 %! 0.0457 -0.8055 -0.0545 0.2217 %! 0.0755 -0.4035 -0.0825 0.1117 %! 0.0943 0.0059 -0.1495 -0.0883 %! 0.1011 0.3715 -0.2115 -0.2533 %! 0.0943 0.7130 -0.1945 -0.4308 %! 0.0694 1.0155 -0.1785 -0.3908 %! 0.0356 1.3196 -0.0615 -0.7733 %! 0.0046 1.5734 -0.0275 -0.8458 %! -0.0314 1.7202 -0.0395 -0.6133 %! -0.0681 1.8521 0.1035 -1.0408 %! -0.0942 1.9659 0.1055 -0.9358 %! -0.1141 2.0471 0.0675 -0.8083 %! -0.1209 2.0915 0.1535 -1.1308 %! -0.1063 2.0434 0.1825 -1.0608 %! -0.0888 1.9430 0.0735 -0.8483 %! -0.0915 1.8424 -0.1075 -0.6683 %! -0.1083 1.8053 -0.0255 -0.9108 %! -0.1202 1.8339 0.1335 -0.9908 %! -0.1316 1.8332 0.1095 -0.6858 %! -0.1505 1.8459 0.1255 -0.9133 %! -0.1761 1.8897 0.1255 -0.8433 %! -0.2072 1.8891 0.1965 -0.7508 %! -0.2260 1.8554 0.3535 -1.1083 %! -0.2255 1.8173 0.3455 -0.8533 %! -0.2197 1.7742 0.3785 -0.7258 %! -0.2068 1.6928 0.4225 -0.9683 %! -0.1823 1.5929 0.2655 -0.7583 %! -0.1528 1.5525 0.1635 -0.6833 %! -0.1153 1.5768 0.1865 -0.8233 %! -0.0639 1.6492 0.1845 -0.8233 %! -0.0036 1.7389 0.0385 -0.7983 %! 0.0568 1.8252 -0.1795 -0.8408 %! 0.1135 1.9303 -0.3065 -0.9008 %! 0.1663 2.0578 -0.3395 -0.9508 %! 0.2171 2.2149 -0.3865 -1.1108 %! 0.2609 2.3688 -0.5255 -1.0583 %! 0.2903 2.4811 -0.5965 -1.0783 %! 0.3116 2.5456 -0.5985 -1.2933 %! 0.3302 2.5368 -0.6915 -1.2033 %! 0.3386 2.4999 -0.7635 -1.1133 %! 0.3349 2.4705 -0.7265 -1.1508 %! 0.3272 2.3935 -0.6665 -1.1583 %! 0.3200 2.2373 -0.7235 -1.0883 %! 0.3069 2.0341 -0.8575 -0.8508 %! 0.2852 1.8725 -0.7935 -0.9233 %! 0.2581 1.7540 -0.7195 -0.8208 %! 0.2203 1.6180 -0.7705 -0.5283 %! 0.1816 1.4957 -0.6725 -0.8258 %! 0.1549 1.3512 -0.5665 -0.7058 %! 0.1282 1.1388 -0.5585 -0.2658 %! 0.1008 0.9536 -0.4685 -0.5208 %! 0.0874 0.8015 -0.3885 -0.4808 %! 0.0840 0.6058 -0.3185 -0.1583 %! 0.0854 0.4115 -0.2425 -0.2633 %! 0.0948 0.2596 -0.2405 -0.1983 %! 0.1089 0.1118 -0.2375 -0.0158 %! 0.1282 -0.0454 -0.1845 -0.0983 %! 0.1559 -0.2334 -0.2045 -0.0283 %! 0.1806 -0.4327 -0.3215 0.2567 %! 0.1940 -0.5798 -0.3475 0.2092 %! 0.2039 -0.6991 -0.3195 0.1717 %! 0.2138 -0.7922 -0.3635 0.3517 %! 0.2221 -0.8503 -0.4145 0.3267 %! 0.2299 -0.9164 -0.4665 0.3792 %! 0.2400 -0.9682 -0.4465 0.3692 %! 0.2545 -1.0512 -0.4625 0.3767 %! 0.2670 -1.2018 -0.5555 0.6217 %! 0.2737 -1.3174 -0.5085 0.5317 %! 0.2764 -1.4090 -0.4815 0.6092 %! 0.2693 -1.5248 -0.5265 0.8217 %! 0.2531 -1.6471 -0.4865 0.6892 %! 0.2321 -1.8015 -0.4525 0.8867 %! 0.2056 -1.9496 -0.3925 1.0067 %! 0.1804 -2.0230 -0.3695 0.8967 %! 0.1599 -1.9852 -0.4155 1.0367 %! 0.1436 -1.8214 -0.3455 0.8392 %! 0.1329 -1.6423 -0.3275 0.7317 %! 0.1199 -1.5459 -0.3995 0.8667 %! 0.1026 -1.4838 -0.3475 0.6542 %! 0.0885 -1.4278 -0.2525 0.5967 %! 0.0761 -1.3787 -0.2145 0.6842 %! 0.0645 -1.2595 -0.1895 0.5417 %! 0.0588 -1.0485 -0.1635 0.3892 %! 0.0552 -0.8090 -0.1595 0.4317 %! 0.0479 -0.5480 -0.1485 0.2867 %! 0.0420 -0.3196 -0.1045 0.0467 %! 0.0378 -0.2052 -0.0815 0.0967 %! 0.0258 -0.1789 -0.0605 0.0942 %! 0.0006 -0.2476 -0.0715 0.1042 %! -0.0359 -0.4128 -0.0735 0.2417 %! -0.0730 -0.6137 0.0265 0.2317 %! -0.0993 -0.8314 0.0895 0.3617 %! -0.1153 -0.9895 0.0605 0.5417 %! -0.1249 -1.0287 -0.0115 0.6092 %! -0.1250 -1.0177 -0.0275 0.5817 %! -0.1093 -0.9871 0.0055 0.4892 %! -0.0832 -0.9130 -0.0565 0.6292 %! -0.0526 -0.8006 -0.0585 0.5317 %! -0.0077 -0.7273 0.0065 0.2742 %! 0.0553 -0.7710 -0.0665 0.4267 %! 0.1270 -0.9222 -0.1935 0.4617 %! 0.1985 -1.1668 -0.3345 0.6017 %! 0.2688 -1.4234 -0.3835 0.6767 %! 0.3422 -1.5956 -0.4405 0.5992 %! 0.4068 -1.7452 -0.6875 0.9367 %! 0.4443 -1.9072 -0.8405 0.9867 %! 0.4553 -2.0635 -0.8345 0.9092 %! 0.4476 -2.2464 -0.8135 1.0567 %! 0.4252 -2.4329 -0.7825 1.0967 %! 0.3876 -2.5541 -0.7555 1.2767 %! 0.3383 -2.5291 -0.6055 1.1367 %! 0.2853 -2.3477 -0.5295 1.0567 %! 0.2304 -2.0738 -0.5415 1.0692 %! 0.1821 -1.7182 -0.3605 0.5542 %! 0.1429 -1.3468 -0.2425 0.5842 %! 0.1032 -1.0234 -0.2025 0.4742 %! 0.0679 -0.7153 -0.1825 0.0467 %! 0.0414 -0.4370 -0.1845 0.1467 %! 0.0237 -0.2054 -0.0365 -0.1708 %! 0.0103 -0.0543 -0.0845 -0.1233 %! -0.0138 -0.0096 -0.1945 0.1042 %! -0.0442 0.0084 -0.0665 -0.3308 %! -0.0775 0.0274 -0.0545 -0.0058 %! -0.1239 0.0529 -0.0365 0.0892 %! -0.1740 0.1041 0.0725 -0.2208 %! -0.2155 0.1382 0.1855 0.0092 %! -0.2412 0.1550 0.3675 -0.2133 %! -0.2493 0.1734 0.3055 -0.1183 %! -0.2515 0.2194 0.2315 0.0167 %! -0.2507 0.3222 0.3455 -0.2983 %! -0.2498 0.4421 0.3345 -0.1158 %! -0.2534 0.5567 0.3655 -0.2708 %! -0.2559 0.6360 0.3995 -0.3958 %! -0.2582 0.6567 0.4175 -0.2383 %! -0.2604 0.6446 0.4565 -0.4358 %! -0.2618 0.5815 0.3395 -0.2633 %! -0.2665 0.5052 0.3425 -0.2233 %! -0.2708 0.5100 0.4235 -0.3608 %! -0.2728 0.6079 0.3875 -0.2883 %! -0.2742 0.7203 0.3615 -0.4683 %! -0.2795 0.7793 0.3085 -0.3733 %! -0.2924 0.8673 0.3805 -0.4158 %! -0.3020 0.9995 0.5025 -0.6983 %! -0.3037 1.0591 0.4755 -0.5208 %! -0.3040 1.0871 0.5245 -0.5933 %! -0.3049 1.1507 0.5525 -0.6233 %! -0.3058 1.2644 0.5195 -0.6358 %! -0.3004 1.4334 0.4955 -0.8358 %! -0.2875 1.5499 0.4055 -0.6808 %! -0.2652 1.5844 0.4605 -0.8508 %! -0.2284 1.5971 0.3825 -0.8783 %! -0.1892 1.6190 0.1465 -0.5958 %! -0.1537 1.6781 0.1075 -0.9083 %! -0.1213 1.6967 0.0525 -0.7883 %! -0.1047 1.6351 0.0045 -0.5783 %! -0.1042 1.5375 0.0525 -0.8158 %! -0.1170 1.3787 0.0375 -0.5208 %! -0.1449 1.2041 0.1245 -0.4508 %! -0.1783 1.0765 0.1865 -0.4958 %! -0.2074 0.9696 0.2285 -0.3758 %! -0.2269 0.8117 0.3565 -0.4383 %! -0.2434 0.5263 0.3285 -0.0883 %! -0.2634 0.1883 0.3275 0.0292 %! -0.2766 -0.1724 0.4035 -0.0358 %! -0.2855 -0.6067 0.3515 0.5092 %! -0.2971 -0.9636 0.3975 0.5592 %! -0.3002 -1.1742 0.4425 0.4867 %! -0.2883 -1.3005 0.3975 0.6967 %! -0.2630 -1.3348 0.3585 0.5892 %! -0.2244 -1.3593 0.2655 0.6317 %! -0.1732 -1.4072 0.2425 0.5767 %! -0.1119 -1.4491 0.2175 0.5367 %! -0.0519 -1.5377 0.1075 0.7042 %! -0.0045 -1.6482 0.0515 0.6342 %! 0.0222 -1.7353 -0.0215 0.8067 %! 0.0255 -1.7833 -0.0095 0.8492 %! 0.0200 -1.7957 0.0855 0.6017 %! 0.0138 -1.8427 0.0605 0.8717 %! 0.0079 -1.9256 0.0775 0.8342 %! 0.0100 -2.0111 0.0645 0.7467 %! 0.0160 -2.0729 -0.0805 1.0792 %! 0.0231 -2.0740 -0.0975 0.8967 %! 0.0388 -2.0445 -0.1065 0.8617 %! 0.0597 -1.9906 -0.1435 1.0067 %! 0.0807 -1.9170 -0.1825 0.8017 %! 0.0969 -1.8479 -0.3205 0.9292 %! 0.1029 -1.7495 -0.3275 0.8542 %! 0.1043 -1.6604 -0.2355 0.6392 %! 0.1001 -1.6211 -0.2395 0.8142 %! 0.0841 -1.5806 -0.2095 0.7817 %! 0.0630 -1.5319 -0.1415 0.6667 %! 0.0489 -1.5022 -0.0715 0.6367 %! 0.0469 -1.4700 -0.0835 0.6692 %! 0.0566 -1.3234 -0.1335 0.6092 %! 0.0811 -1.0251 -0.0935 0.2617 %! 0.1115 -0.7103 -0.2095 0.3017 %! 0.1288 -0.4227 -0.3555 0.2692 %! 0.1352 -0.1704 -0.2835 -0.2308 %! 0.1320 -0.0594 -0.2505 -0.0183 %! 0.1065 -0.0067 -0.2275 0.0967 %! 0.0680 0.1685 -0.1365 -0.3083 %! 0.0335 0.4148 -0.0715 -0.3258 %! 0.0049 0.5997 -0.0175 -0.3758 %! -0.0195 0.7006 -0.0445 -0.4033 %! -0.0351 0.7637 -0.0225 -0.4233 %! -0.0299 0.8425 0.0905 -0.6383 %! -0.0055 0.9276 0.0615 -0.5283 %! 0.0178 1.0462 -0.0975 -0.3783 %! 0.0368 1.2729 -0.1145 -0.6858 %! 0.0674 1.4969 -0.0265 -0.9283 %! 0.1083 1.6066 -0.1025 -0.7658 %! 0.1448 1.7228 -0.2695 -0.7558 %! 0.1778 1.9169 -0.3095 -1.0808 %! 0.2111 2.1262 -0.3605 -1.0633 %! 0.2372 2.3387 -0.4795 -1.0733 %! 0.2550 2.5757 -0.5415 -1.3358 %! 0.2666 2.7617 -0.4935 -1.4108 %! 0.2636 2.7910 -0.4535 -1.3158 %! 0.2380 2.7246 -0.5335 -1.2708 %! 0.1975 2.6043 -0.4965 -1.3383 %! 0.1524 2.3566 -0.3465 -1.1458 %! 0.1037 2.0830 -0.2385 -0.9383 %! 0.0570 1.8917 -0.1875 -1.0133 %! 0.0150 1.7363 -0.2315 -0.7908 %! -0.0242 1.6378 -0.1455 -0.8158 %! -0.0589 1.5875 -0.0665 -0.9083 %! -0.0979 1.5152 -0.1345 -0.6183 %! -0.1459 1.4203 -0.0325 -0.7233 %! -0.1901 1.3044 0.1315 -0.7433 %! -0.2209 1.1849 0.2195 -0.6183 %! -0.2339 1.0649 0.2275 -0.6983 %! -0.2355 0.9365 0.1425 -0.4533 %! -0.2337 0.8784 0.1855 -0.4658 %! -0.2214 0.8990 0.2485 -0.6558 %! -0.1964 0.9349 0.1745 -0.5258 %! -0.1659 0.9811 0.1785 -0.6333 %! -0.1372 0.9916 0.1725 -0.5783 %! -0.1158 0.9395 0.1425 -0.5083 %! -0.0970 0.8657 0.1345 -0.6183 %! -0.0792 0.8086 0.0965 -0.4358 %! -0.0657 0.8370 0.1385 -0.4958 %! -0.0552 0.9112 0.1155 -0.5783 %! -0.0518 0.9266 -0.0175 -0.4133 %! -0.0560 0.9192 -0.0425 -0.5208 %! -0.0578 0.8932 0.0005 -0.5783 %! -0.0564 0.8007 -0.0235 -0.4083 %! -0.0591 0.6940 -0.0925 -0.3358 %! -0.0655 0.6191 -0.1015 -0.3833 %! -0.0735 0.5441 -0.0995 -0.2783 %! -0.0841 0.4197 -0.1085 -0.1608 %! -0.0892 0.2639 -0.0675 -0.2483 %! -0.0801 0.1240 -0.0085 -0.2133 %! -0.0661 -0.0027 -0.0185 -0.0408 %! -0.0647 -0.0929 -0.1255 0.0367 %! -0.0828 -0.1350 -0.1705 0.0342 %! -0.1111 -0.1750 -0.0195 -0.0983 %! -0.1424 -0.2431 0.1145 -0.0458 %! -0.1823 -0.3343 0.1235 0.1642 %! -0.2282 -0.4034 0.1845 0.0017 %! -0.2684 -0.4463 0.2355 0.0017 %! -0.3042 -0.4858 0.2235 0.1692 %! -0.3374 -0.5038 0.2585 0.0742 %! -0.3619 -0.5260 0.3695 0.0692 %! -0.3751 -0.5692 0.4925 0.0867 %! -0.3804 -0.6271 0.4655 0.1342 %! -0.3838 -0.6946 0.3635 0.2492 %! -0.3849 -0.7012 0.4405 0.1317 %! -0.3802 -0.6456 0.5245 0.1767 %! -0.3685 -0.5710 0.5145 0.1717 %! -0.3432 -0.4960 0.4965 -0.0458 %! -0.3091 -0.5027 0.3875 0.1642 %! -0.2816 -0.5650 0.2855 0.2767 %! -0.2575 -0.6307 0.2745 0.0492 %! -0.2333 -0.7767 0.2115 0.3092 %! -0.2177 -0.9320 0.2115 0.4467 %! -0.2103 -0.9808 0.2295 0.3017 %! -0.2077 -0.9820 0.1235 0.4517 %! -0.2091 -0.9672 0.0925 0.4017 %! -0.2067 -0.9320 0.1505 0.2667 %! -0.1964 -0.9354 0.1875 0.3117 %! -0.1862 -1.0067 0.1385 0.4092 %! -0.1835 -1.1249 0.0845 0.4417 %! -0.1878 -1.2659 0.1145 0.4717 %! -0.1971 -1.4192 0.1755 0.5892 %! -0.2082 -1.5634 0.2345 0.5917 %! -0.2205 -1.6030 0.2205 0.7092 %! -0.2334 -1.4712 0.2515 0.5992 %! -0.2378 -1.2802 0.2915 0.3067 %! -0.2371 -1.1340 0.1805 0.4742 %! -0.2418 -1.0239 0.1895 0.3717 %! -0.2467 -0.9961 0.2855 0.1917 %! -0.2506 -1.0394 0.2625 0.4892 %! -0.2481 -1.0708 0.3205 0.2867 %! -0.2255 -1.1285 0.3115 0.2942 %! -0.1851 -1.2190 0.2515 0.5392 %! -0.1284 -1.2780 0.2205 0.3617 %! -0.0568 -1.3066 0.0485 0.4992 %! 0.0190 -1.3093 -0.0745 0.5842 %! 0.0980 -1.3169 -0.0975 0.3817 %! 0.1790 -1.3629 -0.1905 0.4917 %! 0.2470 -1.3928 -0.3335 0.5942 %! 0.2906 -1.3799 -0.4495 0.5667 %! 0.3119 -1.3872 -0.4345 0.4267 %! 0.3070 -1.4366 -0.4805 0.6267 %! 0.2694 -1.4497 -0.5195 0.7092 %! 0.2157 -1.4180 -0.3445 0.3267 %! 0.1572 -1.4131 -0.2795 0.5917 %! 0.0900 -1.4020 -0.2475 0.6467 %! 0.0252 -1.3726 -0.1455 0.2942 %! -0.0329 -1.3701 -0.1075 0.5992 %! -0.0863 -1.3388 0.0435 0.4792 %! -0.1235 -1.2708 0.1565 0.2142 %! -0.1478 -1.2320 0.1245 0.4817 %! -0.1728 -1.2034 0.1555 0.4392 %! -0.1952 -1.1628 0.2365 0.2667 %! -0.2103 -1.1065 0.2765 0.3317 %! -0.2217 -0.9840 0.3265 0.2767 %! -0.2321 -0.8129 0.3975 0.1317 %! -0.2489 -0.6673 0.3905 0.1867 %! -0.2823 -0.5045 0.3435 0.2217 %! -0.3208 -0.2971 0.4725 -0.1183 %! -0.3473 -0.1283 0.6145 -0.1808 %! -0.3655 0.0017 0.6595 -0.0633 %! -0.3824 0.1148 0.6585 -0.2158 %! -0.3984 0.1791 0.6025 -0.1708 %! -0.4094 0.2068 0.6665 -0.2083 %! -0.4057 0.1834 0.7515 -0.2908 %! -0.3881 0.1013 0.7285 -0.1283 %! -0.3652 0.0076 0.6865 -0.0358 %! -0.3341 -0.0852 0.6455 -0.0683 %! -0.2841 -0.1695 0.5685 -0.0783 %! -0.2157 -0.2379 0.4245 0.0317 %! -0.1411 -0.3204 0.2975 0.1167 %! -0.0709 -0.4622 0.1965 0.1842 %! -0.0090 -0.6683 0.0635 0.2967 %! 0.0471 -0.8651 -0.0275 0.2617 %! 0.0923 -0.9752 -0.1435 0.4992 %! 0.1202 -0.9762 -0.1835 0.5592 %! 0.1442 -0.9324 -0.0975 0.1967 %! 0.1675 -0.9128 -0.2015 0.4142 %! 0.1732 -0.8419 -0.3305 0.5317 %! 0.1625 -0.6695 -0.2815 0.1442 %! 0.1441 -0.4938 -0.2375 0.1892 ]; %! %! DAT = iddata (UY(:, 3:4), UY(:, 1:2)); %! %! [SYS, X0] = moen4 (DAT, "s", 15, "n", 8, "rcond", 0.0, "tol", -1.0); %! %! Ae = [ 0.9893 0.0081 -0.0844 0.0299 0.1262 0.0815 -0.0379 0.1779 %! 0.0076 0.9694 0.1352 0.1793 0.0965 -0.1041 -0.0373 -0.0045 %! 0.0018 -0.0115 0.9413 -0.3450 0.1674 0.0302 -0.1098 -0.0087 %! 0.0036 -0.0197 0.1766 0.6550 -0.1178 0.6168 0.0028 0.0085 %! -0.0010 -0.0032 -0.0507 0.0624 0.9293 -0.0034 0.0229 -0.4511 %! 0.0032 -0.0012 -0.0397 0.1255 0.1578 0.1833 0.7586 0.3125 %! 0.0029 -0.0048 0.0422 0.2343 0.0321 -0.6549 -0.0374 0.2232 %! -0.0036 0.0028 0.0080 -0.2437 0.1074 0.1599 -0.1012 0.2106 ]; %! %! Ce = [ -0.2226 0.2072 -0.3129 -0.3937 0.1722 0.3232 -0.2113 0.2928 %! -0.1680 -0.2205 0.0698 0.4049 0.3210 -0.1143 -0.2451 0.4844 ]; %! %! Be = [ 0.0857 0.0026 %! -0.6433 -0.0314 %! 0.2445 0.0044 %! 1.8942 0.0488 %! 0.0549 0.0151 %! -2.2093 -0.0622 %! -2.5072 -0.0925 %! 0.8189 0.0280 ]; %! %! De = [ -0.4997 0.0451 %! -1.0011 -0.5567 ]; %! %! # Since moen4 identifies the input/output behavior only %! # input/output behavior is tested using n first Markov parameters. %! # The state space representaton might have different signs %! # of the states. %! # By multiplying the matrices for the Markov parameters, numeric errors %! # would propagate, therefor the accuracy of the results are limited to %! # the accuracy of the given expected results %! [Ao,Bo,Co,Do] = ssdata (SYS); %! Ao = round (Ao*1e4)/1e4; %! Bo = round (Bo*1e4)/1e4; %! Co = round (Co*1e4)/1e4; %! Do = round (Do*1e4)/1e4; %! %! n = size(Ao,1); %! m = size(Bo,2); %! p = size(Co,1); %! Mo = zeros (p,(n+1)*m); %! Me = zeros (p,(n+1)*m); %! Mo(:,1:m) = Do; %! Me(:,1:m) = De; %! %! Aoi = eye (n,n); %! Aei = eye (n,n); %! for i = 1:n %! Mo(:,i*m+1:(i+1)*m) = Co*Aoi*Bo; %! Me(:,i*m+1:(i+1)*m) = Ce*Aei*Be; %! Aoi = Aoi*Ao; %! Aei = Aei*Ae; %! endfor %! %! assert (Mo, Me, 1e-3); control-4.1.2/inst/PaxHeaders/__match_key__.m0000644000000000000000000000007415012430645016154 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__match_key__.m0000644000175000017500000000373615012430645017354 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Check whether string @var{str} matches one of the candidates ## in cell @var{props} exactly and return the matching property/key ## name. If no exact match is found, check whether there is a ## candidate name in @var{props} which starts with @var{str} and ## return the partial match. In case of ambiguity or a mismatch, ## raise an error. ## Author: Lukas Reichlin ## Created: June 2015 ## Version: 0.1 function key = __match_key__ (str, props, caller = "match_key") if (! ischar (str)) error ("%s: key name must be a string", caller); endif ## exact matching - needed for e.g. iddata properties "u" and "userdata" idx = strcmpi (str, props); n = sum (idx); if (n == 1) # 1 exact match key = lower (str); return; elseif (n > 1) # props are not unique, this would be a bug in the control package error ("%s: key name '%s' is ambiguous", caller, str); endif ## partial matching - n was zero idx = strncmpi (str, props, length (str)); n = sum (idx); if (n == 1) key = lower (props{idx}); return; elseif (n > 1) error ("%s: key name '%s' is ambiguous", caller, str); endif error ("%s: key name '%s' is unknown", caller, str); endfunction control-4.1.2/inst/PaxHeaders/__modred_check_order__.m0000644000000000000000000000007415012430645020012 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__modred_check_order__.m0000644000175000017500000000233315012430645021202 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## check order for model reduction commands ## Author: Lukas Reichlin ## Created: November 2011 ## Version: 0.1 function [nr, ordsel] = __modred_check_order__ (nr, n) if (! issample (nr, 0) || nr != round (nr)) error ("modred: order of reduced model must be an integer >= 0"); endif if (nr > n) error ("modred: order of reduced model (%d) can't be larger than the original one (%d)", ... nr, n); endif ordsel = 0; endfunction control-4.1.2/inst/PaxHeaders/dss.m0000644000000000000000000000007415012430645014205 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/dss.m0000644000175000017500000001007515012430645015377 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} dss (@var{sys}) ## @deftypefnx {Function File} {@var{sys} =} dss (@var{d}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} dss (@var{a}, @var{b}, @var{c}, @var{d}, @var{e}, @dots{}) ## @deftypefnx {Function File} {@var{sys} =} dss (@var{a}, @var{b}, @var{c}, @var{d}, @var{e}, @var{tsam}, @dots{}) ## Create or convert to descriptor state-space model. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model to be converted to state-space. ## @item a ## State matrix (n-by-n). ## @item b ## Input matrix (n-by-m). ## @item c ## Output matrix (p-by-n). ## @item d ## Feedthrough matrix (p-by-m). ## @item e ## Descriptor matrix (n-by-n). ## @item tsam ## Sampling time in seconds. If @var{tsam} is not specified, ## a continuous-time model is assumed. ## @item @dots{} ## Optional pairs of properties and values. ## Type @command{set (dss)} for more information. ## @end table ## ## @strong{Outputs} ## @table @var ## @item sys ## Descriptor state-space model. ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'a', 'b', 'c', 'd', 'e' ## State-space matrices. See 'Inputs' for details. ## ## @item 'stname' ## The name of the states in @var{sys}. ## Cell vector containing strings for each state. ## Default names are @code{@{'x1', 'x2', ...@}} ## ## @item 'scaled' ## Logical. If set to true, no automatic scaling is used, ## e.g. for frequency response plots. ## ## @item 'tsam' ## Sampling time. See 'Inputs' for details. ## ## @item 'inname' ## The name of the input channels in @var{sys}. ## Cell vector of length m containing strings. ## Default names are @code{@{'u1', 'u2', ...@}} ## ## @item 'outname' ## The name of the output channels in @var{sys}. ## Cell vector of length p containing strings. ## Default names are @code{@{'y1', 'y2', ...@}} ## ## @item 'ingroup' ## Struct with input group names as field names and ## vectors of input indices as field values. ## Default is an empty struct. ## ## @item 'outgroup' ## Struct with output group names as field names and ## vectors of output indices as field values. ## Default is an empty struct. ## ## @item 'name' ## String containing the name of the model. ## ## @item 'notes' ## String or cell of string containing comments. ## ## @item 'userdata' ## Any data type. ## @end table ## ## @strong{Equations} ## @tex ## $$E\, \dot{x} = A\,x + B\,u$$ ## $$y = C\,x + D\,u$$ ## @end tex ## @ifnottex ## @example ## . ## E x = A x + B u ## y = C x + D u ## @end example ## @end ifnottex ## ## @seealso{ss, tf} ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2010 ## Version: 0.2 function sys = dss (varargin) mat_idx = __lti_input_idx__ (varargin); switch (numel (mat_idx)) case {0, 1} sys = ss (varargin{:}); [a, ~, ~, ~, e] = __sys_data__ (sys); if (isempty (e)); sys = __set__ (sys, "e", eye (size (a))); endif case {5, 6} sys = ss (varargin{[1:4, 6:end]}, "e", varargin{5}); otherwise print_usage (); endswitch endfunction ## NOTE: The author prefers "dss (e, a, b, c, d)" since we write ## . ## E x = A x + B u, y = C x + D u ## ## but this would break compatibility to a widespread ## commercial implementation of the octave language. ## There's no way to tell e and d apart if n = m = p.control-4.1.2/inst/PaxHeaders/h2syn.m0000644000000000000000000000007415012430645014457 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/h2syn.m0000644000175000017500000002055615012430645015656 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{K}, @var{N}, @var{gamma}, @var{info}] =} h2syn (@var{P}, @var{nmeas}, @var{ncon}) ## @deftypefnx{Function File} {[@var{K}, @var{N}, @var{gamma}, @var{info}] =} h2syn (@var{P}) ## H-2 control synthesis for @acronym{LTI} plant. ## ## @strong{Inputs} ## @table @var ## @item P ## Generalized plant. Must be a proper/realizable @acronym{LTI} model. ## If @var{P} is constructed with @command{mktito} or @command{augw}, ## arguments @var{nmeas} and @var{ncon} can be omitted. ## @item nmeas ## Number of measured outputs v. The last @var{nmeas} outputs of @var{P} are connected to the ## inputs of controller @var{K}. The remaining outputs z (indices 1 to p-nmeas) are used ## to calculate the H-2 norm. ## @item ncon ## Number of controlled inputs u. The last @var{ncon} inputs of @var{P} are connected to the ## outputs of controller @var{K}. The remaining inputs w (indices 1 to m-ncon) are excited ## by a harmonic test signal. ## @end table ## ## @strong{Outputs} ## @table @var ## @item K ## State-space model of the H-2 optimal controller. ## @item N ## State-space model of the lower LFT of @var{P} and @var{K}. ## @item info ## Structure containing additional information. ## @item info.gamma ## H-2 norm of @var{N}. ## @item info.rcond ## Vector @var{rcond} contains estimates of the reciprocal condition ## numbers of the matrices which are to be inverted and ## estimates of the reciprocal condition numbers of the ## Riccati equations which have to be solved during the ## computation of the controller @var{K}. For details, ## see the description of the corresponding SLICOT routine. ## @end table ## ## @strong{Block Diagram} ## @example ## @group ## ## gamma = min||N(K)|| N = lft (P, K) ## K 2 ## ## +--------+ ## w ----->| |-----> z ## | P(s) | ## u +---->| |-----+ v ## | +--------+ | ## | | ## | +--------+ | ## +-----| K(s) |<----+ ## +--------+ ## ## +--------+ ## w ----->| N(s) |-----> z ## +--------+ ## @end group ## @end example ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB10HD and SB10ED}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @seealso{augw, lqr, dlqr, kalman} ## @end deftypefn ## Author: Lukas Reichlin ## Created: December 2009 ## Version: 0.3 function [K, varargout] = h2syn (P, nmeas, ncon) ## check input arguments if (nargin != 1 && nargin != 3) print_usage (); endif if (! isa (P, "lti")) error ("h2syn: first argument must be an LTI system"); endif if (nargin == 1) [nmeas, ncon] = __tito_dim__ (P, "h2syn"); endif if (! is_real_scalar (nmeas)) error ("h2syn: second argument 'nmeas' invalid"); endif if (! is_real_scalar (ncon)) error ("h2syn: third argument 'ncon' 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 (isct (P) && any (d11(:))) warning ("h2syn: setting matrice D11 to zero\n"); d(1:p1, 1:m1) = 0; endif if (! isstabilizable (P(:, m1+1:m))) error ("h2syn: (A, B2) must be stabilizable"); endif if (! isdetectable (P(p1+1:p, :))) error ("h2syn: (C2, A) must be detectable"); endif ## H-2 synthesis if (isct (P)) # continuous plant [ak, bk, ck, dk, rcond] = __sl_sb10hd__ (a, b, c, d, ncon, nmeas); else # discrete plant [ak, bk, ck, dk, rcond] = __sl_sb10ed__ (a, b, c, d, ncon, nmeas); endif ## controller K = ss (ak, bk, ck, dk, tsam); if (nargout > 1) N = lft (P, K); varargout{1} = N; if (nargout > 2) gamma = norm (N, 2); varargout{2} = gamma; if (nargout > 3) varargout{3} = struct ("gamma", gamma, "rcond", rcond); endif 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); control-4.1.2/inst/PaxHeaders/__modred_check_tol__.m0000644000000000000000000000007415012430645017475 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__modred_check_tol__.m0000644000175000017500000000205015012430645020661 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## check tolerance for model reduction commands ## Author: Lukas Reichlin ## Created: November 2011 ## Version: 0.1 function tol = __modred_check_tol__ (tol, str = "") if (! is_real_scalar (tol)) error ("modred: argument %s must be a real scalar", str); endif endfunction control-4.1.2/inst/PaxHeaders/dsort.m0000644000000000000000000000007415012430645014547 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/dsort.m0000644000175000017500000000403615012430645015741 0ustar00lilgelilge00000000000000## Copyright (C) 2016 Mark Bronsfeld ## ## This program is free software: you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{s} =} dsort(@var{p}) ## @deftypefnx {Function File} {[@var{s}, @var{ndx}] =} dsort(@var{p}) ## Sort discrete-time poles by magnitude (in decreasing order). ## ## @strong{Inputs} ## @table @var ## @item p ## Input vector containing discrete-time poles. ## @end table ## ## @strong{Outputs} ## @table @var ## @item s ## Vector with sorted poles. ## @item ndx ## Vector containing the indices used in the sort. ## @end table ## ## @seealso{eig, esort, pole, pzmap, sort, zero} ## @end deftypefn ## Author: Mark Bronsfeld ## Created: December 2016 ## Version: 0.2 function [s, ndx] = dsort(p) if(nargin == 1) if(!isvector(p)) error("dsort: argument must be a vector"); endif else print_usage(); endif [s, ndx] = sort(p, 'descend'); endfunction %!shared s_exp, ndx_exp, s_obs, ndx_obs %! p = [-0.2410+0.5573i; %! -0.2410-0.5573i; %! 0.1503; %! -0.0972; %! -0.2590]; %! s_exp = [ -0.2410+0.5573i; %! -0.2410-0.5573i; %! -0.2590; %! 0.1503; %! -0.0972]; %! ndx_exp = [ 1; %! 2; %! 5; %! 3; %! 4]; %! [s_obs, ndx_obs] = dsort(p); %!assert(s_obs, s_exp, 0); %!assert(ndx_obs, ndx_exp, 0); control-4.1.2/inst/PaxHeaders/dlqe.m0000644000000000000000000000007415012430645014341 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/dlqe.m0000644000175000017500000000733215012430645015535 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 Lukas F. Reichlin ## Copyright (C) 2012 Megan Zagrobelny ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{m}, @var{p}, @var{z}, @var{e}] =} dlqe (@var{a}, @var{g}, @var{c}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{m}, @var{p}, @var{z}, @var{e}] =} dlqe (@var{a}, @var{g}, @var{c}, @var{q}, @var{r}, @var{s}) ## @deftypefnx {Function File} {[@var{m}, @var{p}, @var{z}, @var{e}] =} dlqe (@var{a}, @var{[]}, @var{c}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{m}, @var{p}, @var{z}, @var{e}] =} dlqe (@var{a}, @var{[]}, @var{c}, @var{q}, @var{r}, @var{s}) ## Kalman filter for discrete-time systems. ## ## @example ## @group ## x[k] = Ax[k] + Bu[k] + Gw[k] (State equation) ## y[k] = Cx[k] + Du[k] + v[k] (Measurement Equation) ## E(w) = 0, E(v) = 0, cov(w) = Q, cov(v) = R, cov(w,v) = S ## @end group ## @end example ## ## @strong{Inputs} ## @table @var ## @item a ## State transition matrix of discrete-time system (n-by-n). ## @item g ## Process noise matrix of discrete-time system (n-by-g). ## If @var{g} is empty @code{[]}, an identity matrix is assumed. ## @item c ## Measurement matrix of discrete-time system (p-by-n). ## @item q ## Process noise covariance matrix (g-by-g). ## @item r ## Measurement noise covariance matrix (p-by-p). ## @item s ## Optional cross term covariance matrix (g-by-p), s = cov(w,v). ## If @var{s} is empty @code{[]} or not specified, a zero matrix is assumed. ## @end table ## ## @strong{Outputs} ## @table @var ## @item m ## Kalman filter gain matrix (n-by-p). ## @item p ## Unique stabilizing solution of the discrete-time Riccati equation (n-by-n). ## Symmetric matrix. ## @item z ## Error covariance (n-by-n), cov(x(k|k)-x) ## @item e ## Closed-loop poles (n-by-1). ## @end table ## ## @strong{Equations} ## @example ## @group ## x[k|k] = x[k|k-1] + M(y[k] - Cx[k|k-1] - Du[k]) ## ## x[k+1|k] = Ax[k|k] + Bu[k] for S=0 ## ## x[k+1|k] = Ax[k|k] + Bu[k] + G*S*(C*P*C' + R)^-1*(y[k] - C*x[k|k-1]) for non-zero S ## ## ## E = eig(A - A*M*C) for S=0 ## ## E = eig(A - A*M*C - G*S*(C*P*C' + Rv)^-1*C) for non-zero S ## ## @end group ## @end example ## @seealso{dare, care, dlqr, lqr, lqe} ## @end deftypefn ## Author: Lukas Reichlin ## Created: April 2012 ## Version: 0.1 function [m, p, z, e] = dlqe (a, g, c, q, r, s = []) if (nargin < 5 || nargin > 6) print_usage (); endif if (isempty (g)) [p, e] = dare (a.', c.', q, r, s); # dlqe (a, [], c, q, r, s), g=I elseif (columns (g) != rows (q) || ! issquare (q)) error ("dlqe: matrices g(%dx%d) and q(%dx%d) have incompatible dimensions", ... rows (g), columns (g), rows (q), columns (q)); elseif (isempty (s)) [p, e] = dare (a.', c.', g*q*g.', r); elseif (columns (g) != rows (s)) error ("dlqe: matrices g(%dx%d) and s(%dx%d) have incompatible dimensions", ... rows (g), columns (g), rows (s), columns (s)); else [p, e] = dare (a.', c.', g*q*g.', r, g*s); endif m = p*c.' / (c*p*c.' + r); z = p - m*c*p; z = (z + z.') / 2; endfunction control-4.1.2/inst/PaxHeaders/ramp.m0000644000000000000000000000007415012430645014353 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/ramp.m0000644000175000017500000000712515012430645015547 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {} ramp (@var{sys}) ## @deftypefnx{Function File} {} ramp (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}) ## @deftypefnx{Function File} {} ramp (@var{sys1}, @var{'style1'}, @dots{}, @var{sysN}, @var{'styleN'}) ## @deftypefnx{Function File} {} ramp (@var{sys1}, @dots{}, @var{t}) ## @deftypefnx{Function File} {} ramp (@var{sys1}, @dots{}, @var{tfinal}) ## @deftypefnx{Function File} {} ramp (@var{sys1}, @dots{}, @var{tfinal}, @var{dt}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} ramp (@var{sys}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} ramp (@var{sys}, @var{t}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} ramp (@var{sys}, @var{tfinal}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} ramp (@var{sys}, @var{tfinal}, @var{dt}) ## Ramp response of @acronym{LTI} system. ## If no output arguments are given, the response is printed on the screen. ## @iftex ## @tex ## $$ r(t) = t \\, \\cdot \\, h(t) $$ ## @end tex ## @end iftex ## @ifnottex ## ## @example ## r(t) = t * h(t) ## @end example ## ## @end ifnottex ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @item t ## Time vector. Should be evenly spaced. If not specified, it is calculated by ## the poles of the system to reflect adequately the response transients. ## @item tfinal ## Optional simulation horizon. If not specified, it is calculated by ## the poles of the system to reflect adequately the response transients. ## @item dt ## Optional sampling time. Be sure to choose it small enough to capture transient ## phenomena. If not specified, it is calculated by the poles of the system. ## @item 'style' ## Line style and color, e.g. 'r' for a solid red line or '-.k' for a dash-dotted ## black line. See @command{help plot} for details. ## @end table ## ## @strong{Outputs} ## @table @var ## @item y ## Output response array. Has as many rows as time samples (length of t) ## and as many columns as outputs. ## @item t ## Time row vector. ## @item x ## State trajectories array. Has @code{length (t)} rows and as many columns as states. ## @end table ## ## @seealso{impulse, initial, lsim, step} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2012 ## Version: 1.0 function [y_r, t_r, x_r] = ramp (varargin) if (nargin == 0) print_usage (); endif names = cell (1,nargin); for i = 1:nargin names{i} = inputname (i); end [y, t, x] = __time_response__ ("ramp", varargin, names, nargout); if (nargout) y_r = y{1}; t_r = t{1}; x_r = x{1}; endif endfunction %!demo %! clf; %! s = tf('s'); %! g = 1/(2*s^2+3*s+4); %! ramp(g); %! title ("Ramp response of a PT2 transfer function"); %!demo %! clf; %! s = tf('s'); %! g = 1/(2*s^2+3*s+4); %! h = c2d(g,0.1); %! ramp(h); %! title ("Ramp response of a discretized PT2 transfer function"); control-4.1.2/inst/PaxHeaders/lqi.m0000644000000000000000000000007415012430645014201 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/lqi.m0000644000175000017500000000607315012430645015376 0ustar00lilgelilge00000000000000## Copyright (C) 2024 Fabio Di Iorio ## ## This file is part of the Control package for GNU Octave. ## ## Octave 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. ## ## Octave 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 Octave; see the file COPYING. If not, ## see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{g}, @var{x}, @var{l}] =} lqi (@var{sys}, @var{q}, @var{r}) ## @deftypefnx {Function File} {[@var{g}, @var{x}, @var{l}] =} lqr (@var{sys}, @var{q}, @var{r}, @var{s}) ## Linear-quadratic integral control. ## ## @strong{Inputs} ## @table @var ## @item sys ## Continuous or discrete-time @acronym{LTI} model (m inputs, n states, p outputs). ## @item q ## State weighting matrix (n+p-by-n+p). ## @item r ## Input weighting matrix (m-by-m). ## @item s ## Optional cross term matrix (n+p-by-m). If @var{s} is not specified, a zero matrix is assumed. ## @end table ## ## @strong{Outputs} ## @table @var ## @item g ## State feedback matrix (m-by-n). ## @item x ## Unique stabilizing solution of the continuous-time Riccati equation (n+p-by-n+p). ## @item l ## Closed-loop poles (n-by-1). ## @end table ## ## @strong{Equations} ## @tex ## $$ \dot{x} = A\,x + B\,u,\quad x(0) = x_0 $$ ## $$ J(x_0) = \int_0^\infty z^T Q\, z + u^T R\, u + 2\, z^T S\, u \,\, dt $$ ## $$ z = \left[ \matrix{ x \cr x_i} \right],\qquad x_i = \int_0^t r - y \,\, dt $$ ## $$ L = \sigma (A - B\, G) $$ ## @end tex ## @ifnottex ## @example ## @group ## . ## x = A x + B u, x(0) = x0 ## ## inf ## J(x0) = INT (z' Q z + u' R u + 2 z' S u) dt ## 0 ## ## z = [x; xi] # z is the augmented state and xi the integral of the error e = r - y ## L = eig (A - B*G) ## @end group ## @end example ## @end ifnottex ## ## @seealso{care, dare, dlqr} ## @end deftypefn ## Author: Fabio Di Iorio ## Created: June 2024 ## Version: 0.1 function [g, x, l] = lqi (sys, q, r, s = []) if (nargin < 3 || nargin > 4) print_usage (); endif if ~isa(sys, 'ss') print_usage (); endif [A B C D Ts] = ssdata(sys); [n, m] = size(B); [p, ~] = size(C); % create augmented plant with integrator states if Ts==0 % continuous time case Ag = [A zeros(n,p); -C zeros(p,p)]; Bg = [B; -D]; Cg = [C zeros(p, p)]; sysg = ss(Ag, Bg, Cg, D); else % discrete time case Ag = [A zeros(n,p); -Ts*C eye(p)]; Bg = [B; -D*Ts]; Cg = [C zeros(p, p)]; sysg = ss(Ag, Bg, Cg, D, Ts); endif [g, x, l] = lqr (sysg, q, r, s); endfunction %!test %! A = [1 -1; 0 -5]; %! B = [0;1]; %! C = [1 0]; %! D = 0; %! sys = ss(A,B,C,D); %! [g, x, l] = lqi(sys,eye(3),1); %! assert(l<0,'lqi error') control-4.1.2/inst/PaxHeaders/lqgreg.m0000644000000000000000000000007415012430645014675 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/lqgreg.m0000644000175000017500000000561015012430645016066 0ustar00lilgelilge00000000000000## Copyright (C) 2024 Fabio Di Iorio ## ## This file is part of the Control package for GNU Octave. ## ## Octave 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. ## ## Octave 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 Octave; see the file COPYING. If not, ## see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{reg} =} lqgreg (@var{kest}, @var{k}) ## Form LQG regulator ## ## @strong{Inputs} ## @table @var ## @item kest ## Kalman estimator ## @item k ## State-feedback gain ## @end table ## ## @strong{Outputs} ## @table @var ## @item reg ## LQG regulator as dynamic compensator. Connect with positive feedback. ## @end table ## ## @strong{Equations} ## @seealso{lqr, kalman, lqg} ## @end deftypefn ## Author: Fabio Di Iorio ## Created: July 2024 ## Version: 0.1 function [reg] = lqgreg (kest, k) %% TODO: implement variant with additional known inputs: %% reg = lqgreg (kest, k, controls) if (isa (kest, "lti")) [a, b, c, d, e, Ts] = dssdata (kest, []); else print_usage (); endif [m, ~] = size(k); L = kest.b(:, m+1:end); [~, p] = size(L); C = kest.c(1:p, :); B = kest.b(:, 1:m); D = kest.d(1:p, 1:m); reg = ss(a-B*k-L*C-L*D*k, L, -k, 0,Ts); % set variables names [inn, stn, outn, ing, outg] = get (kest, "inname", "stname", "outname", "ingroup", "outgroup"); stname = __labels__ (stn, "xhat"); outname = cell(m,1); for i=1:m outname{i,1} = strcat("u",num2str(i)); endfor inname = cell(p,1); for i=1:p inname{i,1} = strcat("y",num2str(i)); endfor reg = set (reg, "inname", inname, "stname", stname, "outname", outname); endfunction %!test %! G=zpk([], [-10 -1 -100], 2000); %! sys = ss(G); %! [n, m] = size(sys.b); %! [p, ~] = size(sys.c); %! Q = eye(3); %! R = 1; %! S = zeros(3, 1); %! W = eye(3); %! V = 1; %! N = zeros(3, 1); %! K = lqr(sys, Q, R, S); %! Bn = [sys.b eye(n)]; %! sys_noisy = ss(sys.a, Bn, sys.c, sys.d, sys.ts); %! [est, L1, ~] = kalman(sys_noisy, W, V, N, 1:p, 1:m); %! reg = lqgreg(est,K); %! assert(real(eig(feedback(reg, sys, 1))) < 0); %! Ts = 0.01; %! Gz=zpk([], [-0.1 0.05 0.004], 3, Ts); %! sysz = ss(Gz); %! kz = lqr(sysz, Q, R, S); %! Bn = [sysz.b eye(n)]; %! sys_noisyz = ss(sysz.a, Bn, sysz.c, sysz.d, sysz.ts); %! [estz, L1, ~] = kalman(sys_noisyz, W, V, N, 1:p, 1:m); %! regz = lqgreg(estz, kz); %! assert(abs(eig(feedback(regz, sysz, 1))) < 1); control-4.1.2/inst/PaxHeaders/pzmap.m0000644000000000000000000000007415012430645014543 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/pzmap.m0000644000175000017500000001553015012430645015736 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} pzmap (@var{sys}) ## @deftypefnx {Function File} {} pzmap (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}) ## @deftypefnx {Function File} {} pzmap (@var{sys1}, @var{'style1'}, @dots{}, @var{sysN}, @var{'styleN'}) ## @deftypefnx {Function File} {[@var{p}, @var{z}] =} pzmap (@var{sys}) ## Plot the poles and zeros of an LTI system in the complex plane. ## If no output arguments are given, the result is plotted on the screen. ## Otherwise, the poles and zeros are computed and returned. Note that ## only one system is processed when output arguments are given. ## ## @strong{Inputs} ## @table @var ## @item sys, sys1, ... ## @acronym{LTI} model(s). ## @item 'style' ## Color, e.g. 'r' for a red. See @command{help plot} for details. ## Marker or line styles are ignored as poles and zeros have the ## fixed marker types 'x' and 'o' repectively. ## @end table ## ## @strong{Outputs} ## @table @var ## @item p ## Poles of @var{sys}. ## @item z ## Invariant zeros of @var{sys}. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 0.2 function [pol_r, zer_r] = pzmap (varargin) if (nargin == 0) print_usage (); endif sys_idx = cellfun (@isa, varargin, {"lti"}); # look for LTI models sty_idx = cellfun (@ischar, varargin); # look for strings (plot styles) inv_idx = ! (sys_idx | sty_idx); # invalid arguments if (any (inv_idx)) warning ("pzmap: arguments number %s are invalid and are being ignored\n", ... mat2str (find (inv_idx)(:).')); endif if (nnz (sys_idx) == 0) error ("pzmap: require at least one LTI model"); endif if (nargout > 0 && (nnz (sys_idx) > 1 || any (sty_idx))) print_usage (); endif if (any (find (sty_idx) < find (sys_idx)(1))) warning ("pzmap: strings in front of first LTI model are being ignored\n"); endif pol = cellfun (@pole, varargin(sys_idx), "uniformoutput", false); zer = cellfun (@zero, varargin(sys_idx), "uniformoutput", false); if (! nargout) ms = 10; if (strcmp(graphics_toolkit(),'gnuplot')) ms = 6; endif pol_re = cellfun (@real, pol, "uniformoutput", false); pol_im = cellfun (@imag, pol, "uniformoutput", false); zer_re = cellfun (@real, zer, "uniformoutput", false); zer_im = cellfun (@imag, zer, "uniformoutput", false); ## extract plotting styles tmp = cumsum (sys_idx); tmp(sys_idx | ! sty_idx) = 0; n = nnz (sys_idx); sty = arrayfun (@(x) varargin(tmp == x), 1:n, "uniformoutput", false); colororder = get (gca, "colororder"); rc = rows (colororder); def_pol = arrayfun (@(k) {"x", "linewidth", 2, "markersize", ms, "color", colororder(1+rem (k-1, rc), :)}, 1:n, "uniformoutput", false); def_zer = arrayfun (@(k) {"o", "linewidth", 2, "markersize", ms, "color", colororder(1+rem (k-1, rc), :)}, 1:n, "uniformoutput", false); idx_no_sty = cellfun (@isempty, sty); sty_pol = sty_zer = sty; sty_pol(idx_no_sty) = def_pol(idx_no_sty); sty_zer(idx_no_sty) = def_zer(idx_no_sty); leg_args = cell (1, n); idx = find (sys_idx); dt = false; for k = 1 : n if (! idx_no_sty(k)) ## style given, only allow custom colors, no custom markers [opt,vopt] = __pltopt__ ('pzmap', sty{k}, false); if (! @isempty (opt.color)) sty_pol{1,k} = {"x", "linewidth", 2, "color", opt.color}; sty_zer{1,k} = {"o", "linewidth", 2, "color", opt.color}; else if (! vopt) warning ("pzmap: ignoring undefined color value in style \"%s\"\n", sty{k}{1,1}); endif sty_pol(k) = def_pol(k); sty_zer(k) = def_zer(k); endif endif dt = dt || (varargin{idx(k)}.tsam != 0); endfor pol_args = horzcat (cellfun (@horzcat, pol_re, pol_im, sty_pol, "uniformoutput", false){:}); zer_args = horzcat (cellfun (@horzcat, zer_re, zer_im, sty_zer, "uniformoutput", false){:}); hold on; ## If no zeroes then just plot the poles and vice versa h = []; leg_args = cell (); for k = 1:n name = inputname (idx(k)); if (isempty (name)) name = ["Sys ", num2str(k)]; # needed for pzmap (lticell{:}) endif if (isempty (zer_re{1,k})) hx = plot (pol_re{1,k}, pol_im{1,k}, sty_pol{1,k}{:}); leg_args = { leg_args{:}, ["poles ", name] }; elseif (isempty (pol_re{1,k})) hx = plot (zer_re{1,k}, zer_im{1,k}, sty_zer{1,k}{:}); leg_args = { leg_args{:}, ["zeros ", name] }; else hx = plot (pol_re{1,k}, pol_im{1,k}, sty_pol{1,k}{:}, ... zer_re{1,k}, zer_im{1,k}, sty_zer{1,k}{:}); leg_args = { leg_args{:}, ["poles ", name], ["zeros ", name] }; endif h = [ h; hx ]; endfor grid on box on title ("Pole-Zero Map") xlabel ("Real Axis") ylabel ("Imaginary Axis") xl = xlim(); yl = ylim(); dx = (xl(2)-xl(1))/10; xl(1) = xl(1) - dx; xl(2) = xl(2) + dx; dy = (yl(2)-yl(1))/10; yl(1) = yl(1) - dy; yl(2) = yl(2) + dy; a = gca (); % avoid flickering while drawing axis / stablity region set (a, 'xlimmode', 'manual'); set (a, 'ylimmode', 'manual'); plot ([0,0], [yl(1)-dy*100, yl(2)+dy*100], '-', 'color', [0.7 0.7 0.7]); plot ([xl(1)-dx*100, xl(2)+dx*100], [0,0], '-', 'color', [0.7 0.7 0.7]); if dt t = 0:0.05:6.3; plot(cos(t),sin(t),'-', 'color', [0.7 0.7 0.7]); endif set (a, 'xlimmode', 'auto'); set (a, 'ylimmode', 'auto'); xlim(xl); ylim(yl); hold off; legend (h, leg_args) else ## output arguments: only one system is allowed as input pol_r = pol{1}; zer_r = zer{1}; endif endfunction %!demo %! z = tf('z',1); %! G1z = (z+1)/(z-0.75)/(z^2-1*z+1); %! pzmap(G1z); %!demo %! s = tf('s'); %! G1 = 1/(2*s^2+3*s+4); %! G2 = (1-s)/(1+s)/(s^2+s+1); %! pzmap(G1,G2); %!test %! s = tf('s'); %! G = (s-1)/(s-2)/(s-3); %! [pol zer] = pzmap(G); %! assert(sort(pol), [2 3]', 2*eps); %! assert(zer, 1, eps); %!test %! s = tf('s'); %! g = 1/(2*s^2+3*s+4); %! pol = pzmap(g); %! assert(sort(pol), sort(roots([2 3 4]')), eps); control-4.1.2/inst/PaxHeaders/append.m0000644000000000000000000000007415012430645014663 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/append.m0000644000175000017500000000221415012430645016051 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{sys} =} append (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}) ## Group @acronym{LTI} models by appending their inputs and outputs. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function sys = append (varargin) if (nargin == 0) print_usage (); endif sys = blkdiag (varargin{:}); endfunction control-4.1.2/inst/PaxHeaders/isctrb.m0000644000000000000000000000007415012430645014702 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/isctrb.m0000644000175000017500000000746215012430645016102 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{bool}, @var{ncon}] =} isctrb (@var{sys}) ## @deftypefnx {Function File} {[@var{bool}, @var{ncon}] =} isctrb (@var{sys}, @var{tol}) ## @deftypefnx {Function File} {[@var{bool}, @var{ncon}] =} isctrb (@var{a}, @var{b}) ## @deftypefnx {Function File} {[@var{bool}, @var{ncon}] =} isctrb (@var{a}, @var{b}, @var{e}) ## @deftypefnx {Function File} {[@var{bool}, @var{ncon}] =} isctrb (@var{a}, @var{b}, @var{[]}, @var{tol}) ## @deftypefnx {Function File} {[@var{bool}, @var{ncon}] =} isctrb (@var{a}, @var{b}, @var{e}, @var{tol}) ## Logical check for system controllability. ## For numerical reasons, @code{isctrb (sys)} ## should be used instead of @code{rank (ctrb (sys))}. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. Descriptor state-space models are possible. ## If @var{sys} is not a state-space model, it is converted to ## a minimal state-space realization, so beware of pole-zero ## cancellations which may lead to wrong results! ## @item a ## State matrix (n-by-n). ## @item b ## Input matrix (n-by-m). ## @item e ## Descriptor matrix (n-by-n). ## If @var{e} is empty @code{[]} or not specified, an identity matrix is assumed. ## @item tol ## Optional roundoff parameter. Default value is 0. ## @end table ## ## @strong{Outputs} ## @table @var ## @item bool = 0 ## System is not controllable. ## @item bool = 1 ## System is controllable. ## @item ncon ## Number of controllable states. ## @end table ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB01OD and TG01HD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @seealso{isobsv} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.5 function [bool, ncont] = isctrb (a, b = [], e = [], tol = []) if (nargin < 1 || nargin > 4) print_usage (); elseif (isa (a, "lti")) # isctrb (sys), isctrb (sys, tol) if (nargin > 2) print_usage (); endif if (! isa (a, "ss")) warning ("isctrb: converting to minimal state-space realization\n"); endif tol = b; [a, b, c, d, e] = dssdata (a, []); elseif (nargin < 2) # isctrb (a, b), isctrb (a, b, tol) print_usage (); elseif (! is_real_square_matrix (a) || ! is_real_matrix (b) || rows (a) != rows (b)) error ("isctrb: a(%dx%d), b(%dx%d) not conformal", rows (a), columns (a), rows (b), columns (b)); elseif (! isempty (e) && (! is_real_square_matrix (e) || ! size_equal (e, a))) error ("isctrb: a(%dx%d), e(%dx%d) not conformal", rows (a), columns (a), rows (e), columns (e)); endif if (isempty (tol)) tol = 0; # default tolerance elseif (! is_real_scalar (tol)) error ("isctrb: tol must be a real scalar"); endif if (isempty (e)) [~, ~, ~, ncont] = __sl_ab01od__ (a, b, tol); else [~, ~, ~, ~, ~, ~, ncont] = __sl_tg01hd__ (a, e, b, zeros (1, columns (a)), tol); endif bool = (ncont == rows (a)); endfunction control-4.1.2/inst/PaxHeaders/__modred_ab09id__.m0000644000000000000000000000007415012430645016612 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__modred_ab09id__.m0000644000175000017500000001330015012430645017776 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{Gr}, @var{info}] =} __modred_ab09id__ (@var{method}, @dots{}) ## Backend for btamodred and spamodred. ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2011 ## Version: 0.1 function [Gr, info] = __modred_ab09id__ (method, varargin) if (nargin < 2) print_usage (); endif if (method != "bta" && method != "spa") error ("modred: invalid method"); endif G = varargin{1}; varargin = varargin(2:end); if (! isa (G, "lti")) error ("%smodred: first argument must be an LTI system", method); endif if (nargin > 2) # *modred (G, ...) if (is_real_scalar (varargin{1})) # *modred (G, nr) varargin = horzcat (varargin(2:end), {"order"}, varargin(1)); endif if (isstruct (varargin{1})) # *modred (G, opt, ...), *modred (G, nr, opt, ...) varargin = horzcat (__opt2cell__ (varargin{1}), varargin(2:end)); endif ## order placed at the end such that nr from *modred (G, nr, ...) ## and *modred (G, nr, opt, ...) overrides possible nr's from ## key/value-pairs and inside opt struct (later keys override former keys, ## nr > key/value > opt) endif nkv = numel (varargin); # number of keys and values if (rem (nkv, 2)) error ("%smodred: keys and values must come in pairs", method); endif [a, b, c, d, tsam, scaled] = ssdata (G); [p, m] = size (G); dt = isdt (G); ## default arguments alpha = __modred_default_alpha__ (dt); av = bv = cv = dv = []; jobv = 0; aw = bw = cw = dw = []; jobw = 0; alphac = alphao = 0.0; tol1 = 0.0; tol2 = 0.0; jobc = jobo = 0; bf = true; # balancing-free weight = 1; equil = 0; ordsel = 1; nr = 0; ## handle keys and values for k = 1 : 2 : nkv key = lower (varargin{k}); val = varargin{k+1}; switch (key) case {"left", "output", "v"} [av, bv, cv, dv, jobv] = __modred_check_weight__ (val, dt, p, []); case {"right", "input", "w"} [aw, bw, cw, dw, jobw] = __modred_check_weight__ (val, dt, [], m); case {"order", "n", "nr"} [nr, ordsel] = __modred_check_order__ (val, rows (a)); case "tol1" tol1 = __modred_check_tol__ (val, "tol1"); case "tol2" tol2 = __modred_check_tol__ (val, "tol2"); case "alpha" alpha = __modred_check_alpha__ (val, dt); case "method" switch (tolower (val)) case "sr" bf = false; case "bfsr" bf = true; otherwise error ("modred: '%s' is an invalid approach", val); endswitch case {"jobc", "gram-ctrb"} jobc = __modred_check_gram__ (val, "gram-ctrb"); case {"jobo", "gram-obsv"} jobo = __modred_check_gram__ (val, "gram-obsv"); case {"alphac", "alpha-ctrb"} alphac = __modred_check_alpha_gram__ (val, "alpha-ctrb"); case {"alphao", "alpha-obsv"} alphao = __modred_check_alpha_gram__ (val, "alpha-obsv"); case {"equil", "equilibrate", "equilibration", "scale", "scaling"} scaled = __modred_check_equil__ (val); otherwise warning ("%smodred: invalid property name '%s' ignored\n", method, key); endswitch endfor ## handle type of frequency weighting if (jobv && jobw) weight = 3; # 'B': both left and right weightings V and W are used elseif (jobv) weight = 1; # 'L': only left weighting V is used (W = I) elseif (jobw) weight = 2; # 'R': only right weighting W is used (V = I) else weight = 0; # 'N': no weightings are used (V = I, W = I) endif ## handle model reduction approach if (strcmpi (method, "bta") && ! bf) # 'B': use the square-root Balance & Truncate method job = 0; elseif (strcmpi (method, "bta") && bf) # 'F': use the balancing-free square-root Balance & Truncate method job = 1; elseif (strcmpi (method, "spa") && ! bf) # 'S': use the square-root Singular Perturbation Approximation method job = 2; elseif (strcmpi (method, "spa") && bf) # 'P': use the balancing-free square-root Singular Perturbation Approximation method job = 3; else error ("modred: invalid job option"); # this should never happen endif ## perform model order reduction [ar, br, cr, dr, nr, hsv, ns] = __sl_ab09id__ (a, b, c, d, dt, equil, nr, ordsel, alpha, job, ... av, bv, cv, dv, ... aw, bw, cw, dw, ... weight, jobc, jobo, alphac, alphao, ... tol1, tol2); ## assemble reduced order model Gr = ss (ar, br, cr, dr, tsam); ## assemble info struct info = struct ("nr", nr, "ns", ns, "hsv", hsv); endfunction control-4.1.2/inst/PaxHeaders/__frequency_vector__.m0000644000000000000000000000007415012430645017573 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__frequency_vector__.m0000644000175000017500000001332215012430645020763 0ustar00lilgelilge00000000000000## Copyright (C) 1996, 2000, 2004, 2005, 2006, 2007 ## Auburn University. All rights reserved. ## Copyright (C) 2009-2016 Lukas F. Reichlin ## ## 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{w} =} __frequency_vector__ (@var{sys}) ## Get default range of frequencies based on cutoff frequencies of system ## poles and zeros. ## Frequency range is the interval ## @iftex ## @tex ## $ [ 10^{w_{min}}, 10^{w_{max}} ] $ ## @end tex ## @end iftex ## @ifnottex ## [10^@var{wmin}, 10^@var{wmax}] ## @end ifnottex ## ## Used by @command{__frequency_response__} ## @end deftypefn ## Adapted-By: Lukas Reichlin ## Date: October 2009 ## Version: 0.4 function w = __frequency_vector__ (sys_cell, wbounds = "std", wmin, wmax) N = 1000; # intervals within the w range isc = iscell (sys_cell); if (! isc) # __sys2frd__ methods pass LTI models not in cells sys_cell = {sys_cell}; endif idx = cellfun (@(x) isa (x, "lti"), sys_cell); sys_cell = sys_cell(idx); len = numel (sys_cell); [dec_min, dec_max, zp] = cellfun (@__frequency_range__, sys_cell, {wbounds}, "uniformoutput", false); if (strcmpi (wbounds, "std")) # plots with explicit frequencies if (nargin == 4) # w = {wmin, wmax} dec_min = log10 (wmin); dec_max = log10 (wmax); else dec_min = min (cell2mat (dec_min)); dec_max = max (cell2mat (dec_max)); endif zp = horzcat (zp{:}); ## include zeros and poles for nice peaks in plots idx = find (zp > 10^dec_min & zp < 10^dec_max); zp = zp(idx); w = logspace (dec_min, dec_max, N); w = unique ([w, zp]); # unique also sorts frequency vector w = repmat ({w}, 1, len); # return cell of frequency vectors elseif (strcmpi (wbounds, "ext")) # plots with implicit frequencies if (nargin == 4) dec_min = repmat ({log10(wmin)}, 1, len); dec_max = repmat ({log10(wmax)}, 1, len); endif idx = cellfun (@(zp, dec_min, dec_max) find (zp > 10^dec_min & zp < 10^dec_max), ... zp, dec_min, dec_max, "uniformoutput", false); zp = cellfun (@(zp, idx) zp(idx), zp, idx, "uniformoutput", false); w = cellfun (@logspace, dec_min, dec_max, {N}, "uniformoutput", false); w = cellfun (@(w, zp) unique ([w, zp]), w, zp, "uniformoutput", false); ## unique also sorts frequency vector else error ("frequency_vector: invalid argument 'wbounds'"); endif if (! isc) # for __sys2frd__ methods w = w{1}; endif endfunction function [dec_min, dec_max, zp] = __frequency_range__ (sys, wbounds = "std") if (isa (sys, "frd")) w = get (sys, "w"); dec_min = log10 (w(1)); dec_max = log10 (w(end)); zp = []; return; endif zer = zero (sys); pol = pole (sys); tsam = abs (get (sys, "tsam")); # tsam could be -1 discrete = ! isct (sys); ## make sure zer, pol are row vectors pol = reshape (pol, 1, []); zer = reshape (zer, 1, []); ## check for natural frequencies away from omega = 0 if (discrete) ## The 2nd conditions prevents log(0) in the next log command iiz = find (abs(zer-1) > norm(zer)*eps && abs(zer) > norm(zer)*eps); iip = find (abs(pol-1) > norm(pol)*eps && abs(pol) > norm(pol)*eps); ## avoid dividing empty matrices, it would work but looks nasty if (! isempty (iiz)) czer = log (zer(iiz))/tsam; else czer = []; endif if (! isempty (iip)) cpol = log (pol(iip))/tsam; else cpol = []; endif else ## continuous pol_zeros = [zer pol]; iip = find (abs(pol) > norm(pol_zeros)*eps); iiz = find (abs(zer) > norm(pol_zeros)*eps); if (! isempty (zer)) czer = zer(iiz); else czer = []; endif if (! isempty (pol)) cpol = pol(iip); else cpol = []; endif endif if (isempty (iip) && isempty (iiz)) ## no poles/zeros away from omega = 0; pick defaults dec_min = 0; # -1 dec_max = 2; # 3 else dec_min = floor (log10 (min (abs ([cpol, czer])))); dec_max = ceil (log10 (max (abs ([cpol, czer])))); endif ## expand to show the entirety of the "interesting" portion of the plot switch (wbounds) case "std" # standard if (dec_min == dec_max) dec_min -= 2; dec_max += 2; else dec_min--; dec_max++; endif case "ext" # extended (for nyquist) if (any (abs (pol) < sqrt (eps))) # look for integrators dec_min -= 0.5; dec_max += 2; else dec_min -= 2; dec_max += 2; endif otherwise error ("frequency_range: second argument invalid"); endswitch ## run discrete frequency all the way to pi if (discrete) dec_max = log10 (pi/tsam); endif ## include zeros and poles for nice peaks in plots zp = [abs(zer), abs(pol)]; endfunction control-4.1.2/inst/PaxHeaders/arx.m0000644000000000000000000000007415012430645014206 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/arx.m0000644000175000017500000002575515012430645015413 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{sys}, @var{x0}] =} arx (@var{dat}, @var{n}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}] =} arx (@var{dat}, @var{n}, @var{opt}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}] =} arx (@var{dat}, @var{opt}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}] =} arx (@var{dat}, @var{'na'}, @var{na}, @var{'nb'}, @var{nb}) ## Estimate ARX model using QR factorization. ## @iftex ## @tex ## $$ A(q) \\, y(t) = B(q) \\, u(t) \\, + \\, e(t) $$ ## @end tex ## @end iftex ## @ifnottex ## ## @example ## A(q) y(t) = B(q) u(t) + e(t) ## @end example ## ## @end ifnottex ## ## @strong{Inputs} ## @table @var ## @item dat ## iddata identification dataset containing the measurements, i.e. time-domain signals. ## @item n ## The desired order of the resulting model @var{sys}. ## @item @dots{} ## Optional pairs of keys and values. @code{'key1', value1, 'key2', value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## ## @strong{Outputs} ## @table @var ## @item sys ## Discrete-time transfer function model. ## If the second output argument @var{x0} is returned, ## @var{sys} becomes a state-space model. ## @item x0 ## Initial state vector. If @var{dat} is a multi-experiment dataset, ## @var{x0} becomes a cell vector containing an initial state vector ## for each experiment. ## @end table ## ## ## @strong{Option Keys and Values} ## @table @var ## @item 'na' ## Order of the polynomial A(q) and number of poles. ## ## @item 'nb' ## Order of the polynomial B(q)+1 and number of zeros+1. ## @var{nb} <= @var{na}. ## ## @item 'nk' ## Input-output delay specified as number of sampling instants. ## Scalar positive integer. This corresponds to a call to function ## @command{nkshift}, followed by padding the B polynomial with ## @var{nk} leading zeros. ## @end table ## ## ## @strong{Algorithm}@* ## Uses the formulae given in [1] on pages 318-319, ## 'Solving for the LS Estimate by QR Factorization'. ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT IB01CD} ## for initial conditions, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @strong{References}@* ## [1] Ljung, L. (1999) ## @cite{System Identification: Theory for the User: Second Edition}. ## Prentice Hall, New Jersey, USA. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: April 2012 ## Version: 0.1 function [sys, varargout] = arx (dat, varargin) ## TODO: delays if (nargin < 2) print_usage (); endif if (! isa (dat, "iddata") || ! dat.timedomain) error ("arx: first argument must be a time-domain iddata dataset"); endif ## p: outputs, m: inputs, ex: experiments [~, p, m, ex] = size (dat); # dataset dimensions if (is_real_scalar (varargin{1})) # arx (dat, n, ...) varargin = horzcat (varargin(2:end), {"na"}, varargin(1), {"nb"}, varargin(1)); endif if (isstruct (varargin{1})) # arx (dat, opt, ...), arx (dat, n, opt, ...) varargin = horzcat (__opt2cell__ (varargin{1}), varargin(2:end)); endif nkv = numel (varargin); # number of keys and values if (rem (nkv, 2)) error ("arx: keys and values must come in pairs"); endif ## default arguments na = []; nb = []; nk = 0; ## handle keys and values for k = 1 : 2 : nkv key = lower (varargin{k}); val = varargin{k+1}; switch (key) case "na" na = __check_n__ (val, "na"); case "nb" nb = __check_n__ (val, "nb"); case "nk" nk = __check_n__ (val, "nk"); if (! issample (val, 0)) error ("arx: channel-wise 'nk' matrices not supported yet"); endif otherwise warning ("arx: invalid property name '%s' ignored\n", key); endswitch endfor if (any (nk(:) != 0)) dat = nkshift (dat, nk); endif ## extract data Y = dat.y; U = dat.u; tsam = dat.tsam; ## multi-experiment data requires equal sampling times if (ex > 1 && ! isequal (tsam{:})) error ("arx: require equally sampled experiments"); else tsam = tsam{1}; endif if (is_real_scalar (na, nb)) na = repmat (na, p, 1); # na(p-by-1) nb = repmat (nb, p, m); # nb(p-by-m) elseif (! (is_real_vector (na) && is_real_matrix (nb) ... && rows (na) == p && rows (nb) == p && columns (nb) == m)) error ("arx: require na(%dx1) instead of (%dx%d) and nb(%dx%d) instead of (%dx%d)", ... p, rows (na), columns (na), p, m, rows (nb), columns (nb)); endif max_nb = max (nb, [], 2); # one maximum for each row/output, max_nb(p-by-1) n = max (na, max_nb); # n(p-by-1) ## create empty cells for numerator and denominator polynomials num = cell (p, m+p); den = cell (p, m+p); ## MIMO (p-by-m) models are identified as p MISO (1-by-m) models ## For multi-experiment data, minimize the trace of the error for i = 1 : p # for every output Phi = cell (ex, 1); # one regression matrix per experiment for e = 1 : ex # for every experiment ## avoid warning: toeplitz: column wins anti-diagonal conflict ## therefore set first row element equal to y(1) PhiY = toeplitz (Y{e}(1:end-1, i), [Y{e}(1, i); zeros(na(i)-1, 1)]); ## create MISO Phi for every experiment PhiU = arrayfun (@(x) toeplitz (U{e}(1:end-1, x), [U{e}(1, x); zeros(nb(i,x)-1, 1)]), 1:m, "uniformoutput", false); Phi{e} = (horzcat (-PhiY, PhiU{:}))(n(i):end, :); endfor ## compute parameter vector Theta Theta = __theta__ (Phi, Y, i, n); ## extract polynomial matrices A and B from Theta ## A is a scalar polynomial for output i, i=1:p ## B is polynomial row vector (1-by-m) for output i A = [1; Theta(1:na(i))]; # a0 = 1, a1 = Theta(1), an = Theta(n) ThetaB = Theta(na(i)+1:end); # all polynomials from B are in one column vector B = mat2cell (ThetaB, nb(i,:)); # now separate the polynomials, one for each input B = reshape (B, 1, []); # make B a row cell (1-by-m) B = cellfun (@(B) [zeros(1+nk, 1); B], B, "uniformoutput", false); # b0 = 0 (leading zero required by filt) ## add error inputs Be = repmat ({0}, 1, p); # there are as many error inputs as system outputs (p) Be(i) = [zeros(1,nk), 1]; # inputs m+1:m+p are zero, except m+i which is one num(i, :) = [B, Be]; # numerator polynomials for output i, individual for each input den(i, :) = repmat ({A}, 1, m+p); # in a row (output i), all inputs have the same denominator polynomial endfor ## A(q) y(t) = B(q) u(t) + e(t) ## there is only one A per row ## B(z) and A(z) are a Matrix Fraction Description (MFD) ## y = A^-1(q) B(q) u(t) + A^-1(q) e(t) ## since A(q) is a diagonal polynomial matrix, its inverse is trivial: ## the corresponding transfer function has common row denominators. sys = filt (num, den, tsam); # filt creates a transfer function in z^-1 ## compute initial state vector x0 if requested ## this makes only sense for state-space models, therefore convert TF to SS if (nargout > 1) sys = prescale (ss (sys(:,1:m))); x0 = __sl_ib01cd__ (Y, U, sys.a, sys.b, sys.c, sys.d, 0.0); ## return x0 as vector for single-experiment data ## instead of a cell containing one vector if (numel (x0) == 1) x0 = x0{1}; endif varargout{1} = x0; endif endfunction function Theta = __theta__ (Phi, Y, i, n) if (numel (Phi) == 1) # single-experiment dataset ## use "square-root algorithm" A = horzcat (Phi{1}, Y{1}(n(i)+1:end, i)); # [Phi, Y] R0 = triu (qr (A, 0)); # 0 for economy-size R (without zero rows) R1 = R0(1:end-1, 1:end-1); # R1 is triangular - can we exploit this in R1\R2? R2 = R0(1:end-1, end); Theta = __ls_svd__ (R1, R2); # R1 \ R2 ## Theta = Phi \ Y(n+1:end, :); # naive formula ## Theta = __ls_svd__ (Phi{1}, Y{1}(n(i)+1:end, i)); else # multi-experiment dataset ## TODO: find more sophisticated formula than ## Theta = (Phi1' Phi1 + Phi2' Phi2 + ...) \ (Phi1' Y1 + Phi2' Y2 + ...) ## covariance matrix C = (Phi1' Phi + Phi2' Phi2 + ...) tmp = cellfun (@(Phi) Phi.' * Phi, Phi, "uniformoutput", false); ## rc = cellfun (@rcond, tmp); # also test C? QR or SVD? C = plus (tmp{:}); ## PhiTY = (Phi1' Y1 + Phi2' Y2 + ...) tmp = cellfun (@(Phi, Y) Phi.' * Y(n(i)+1:end, i), Phi, Y, "uniformoutput", false); PhiTY = plus (tmp{:}); ## pseudoinverse Theta = C \ Phi'Y Theta = __ls_svd__ (C, PhiTY); endif endfunction function x = __ls_svd__ (A, b) ## solve the problem Ax=b ## x = A\b would also work, ## but this way we have better control and warnings ## solve linear least squares problem by pseudoinverse ## the pseudoinverse is computed by singular value decomposition ## M = U S V* ---> M+ = V S+ U* ## Th = Ph \ Y = Ph+ Y ## Th = V S+ U* Y, S+ = 1 ./ diag (S) [U, S, V] = svd (A, 0); # 0 for "economy size" decomposition S = diag (S); # extract main diagonal r = sum (S > eps*S(1)); if (r < length (S)) warning ("arx: rank-deficient coefficient matrix\n"); warning ("sampling time too small\n"); warning ("persistence of excitation\n"); endif V = V(:, 1:r); S = S(1:r); U = U(:, 1:r); x = V * (S .\ (U' * b)); # U' is the conjugate transpose endfunction function val = __check_n__ (val, str = "n") if (! is_real_matrix (val) || fix (val) != val) error ("arx: argument '%s' must be a positive integer", str); endif endfunction control-4.1.2/inst/PaxHeaders/optiPID.m0000644000000000000000000000007415012430645014724 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/optiPID.m0000644000175000017500000001601115012430645016112 0ustar00lilgelilge00000000000000%% -*- texinfo -*- %% @deftypefn {Example Script} {} optiPID %% Numerical optimization of a PID controller using an objective function. %% %% The objective function is located in the file @command{optiPIDfun}. %% Type @code{which optiPID} to locate, @code{edit optiPID} to open %% and simply @code{optiPID} to run the example file. %% In this example called @code{optiPID}, loosely based on [1], it is assumed %% that the plant %% @tex %% $$ P(s) = \frac{1}{(s^{2} + s + 1)(s + 1)^{4}} $$ %% @end tex %% @ifnottex %% @example %% 1 %% P(s) = ----------------------- %% (s^2 + s + 1) (s + 1)^4 %% @end example %% @end ifnottex %% is controlled by a PID controller with second-order roll-off %% @tex %% $$ C(s) = K_P (1 + \frac{1}{T_Is} + T_D s) \frac{1}{(\tau s + 1)^{2}} $$ %% @end tex %% @ifnottex %% @example %% 1 1 %% C(s) = Kp (1 + ---- + Td s) ------------- %% Ti s (tau s + 1)^2 %% @end example %% @end ifnottex %% in the usual negative feedback structure %% @tex %% $$ T(s) = \frac{L(s)}{1 + L(s)} = \frac{P(s) C(s)}{1 + P(s)C(s)} $$ %% @end tex %% @ifnottex %% @example %% L(s) P(s) C(s) %% T(s) = -------- = ------------- %% 1 + L(s) 1 + P(s) C(s) %% @end example %% @end ifnottex %% The plant P(s) is of higher order but benign. The initial values for the %% controller parameters %% @tex %% \(K_P,T_I\mbox{ and } T_D\) %% @end tex %% @ifnottex %% Kp, Ti and Td %% @end ifnottex %% are obtained by applying the %% Astroem and Haegglund rules [2]. These values are to be improved using a %% numerical optimization as shown below. %% As with all numerical methods, this approach can never guarantee that a %% proposed solution is a global minimum. Therefore, good initial guesses for %% the parameters to be optimized are very important. %% The Octave function @code{fminsearch} minimizes the objective function @var{J}, %% which is chosen to be %% @tex %% $$ J(K_P, T_I, T_D) = \mu_1 \int_0^{\infty} \! t |e(t)| dt + \mu_2 (|| y(t) ||_{\infty} - 1) + \mu_3 ||S(jw)||_{\infty} $$ %% @end tex %% @ifnottex %% @example %% inf %% J(Kp, Ti, Td) = mu1 INT t |e(t)| dt + mu2 (||y(t)|| - 1) + mu3 ||S(jw)|| %% 0 inf inf %% @end example %% @end ifnottex %% This particular objective function penalizes the integral of time-weighted absolute error %% @tex %% $$ ITAE = \int_0^{\infty} \! t |e(t)| dt $$ %% @end tex %% @ifnottex %% @example %% inf %% ITAE = INT t |e(t)| dt %% 0 %% @end example %% @end ifnottex %% and the maximum overshoot %% @tex %% $$ y_{max} - 1 = || y(t) ||_{\infty} - 1 $$ %% @end tex %% @ifnottex %% @example %% y - 1 = ||y(t)|| - 1 %% max inf %% @end example %% @end ifnottex %% to a unity reference step %% @tex %% \(r(t) = \varepsilon (t)\) %% @end tex %% in the time domain. In the frequency domain, the sensitivity %% @tex %% \(M_s = ||S(jw)||_{\infty}\) %% @end tex %% @ifnottex %% @example %% Ms = ||S(jw)|| %% inf %% @end example %% @end ifnottex %% is minimized for good robustness, where S(s) denotes the @emph{sensitivity} transfer function %% @tex %% $$ S(s) = \frac{1}{1 + L(s)} = \frac{1}{1 + P(s)\,C(s)} $$ %% @end tex %% @ifnottex %% @example %% 1 1 %% S(s) = -------- = ------------- %% 1 + L(s) 1 + P(s) C(s) %% @end example %% @end ifnottex %% The constants %% @tex %% \(\mu_1,\, \mu_2 \mbox{ and } \mu_3\) %% @end tex %% @ifnottex %% mu1, mu2 and mu3 %% @end ifnottex %% are @emph{relative weighting factors} or @guillemetleft{}tuning knobs@guillemetright{} %% which reflect the importance of the different design goals. Varying these factors %% corresponds to changing the emphasis from, say, high performance to good robustness. %% The main advantage of this approach is the possibility to explore the tradeoffs of %% the design problem in a systematic way. %% In a first approach, all three design objectives are weigthed equally. %% In subsequent iterations, the parameters %% @tex %% \(\mu_1 = 1,\, \mu_2 = 10 \mbox{ and } \mu_3 = 20\) %% @end tex %% @ifnottex %% mu1 = 1, mu2 = 10 and mu3 = 20 %% @end ifnottex %% are found to yield satisfactory closed-loop performance. This controller results %% in a system with virtually no overshoot and a phase margin of 64 degrees. %% %% @*@strong{References}@* %% [1] Guzzella, L. %% @cite{Analysis and Design of SISO Control Systems}, %% VDF Hochschulverlag, ETH Zurich, 2007@* %% [2] Astroem, K. and Haegglund, T. %% @cite{PID Controllers: Theory, Design and Tuning}, %% Second Edition, %% Instrument Society of America, 1995 %% @end deftypefn % =============================================================================== % optiPID Lukas Reichlin July 2009 % =============================================================================== % Numerical Optimization of an A/H PID Controller % Required OCTAVE Packages: control % Required MATLAB Toolboxes: Control, Optimization % =============================================================================== % Tabula Rasa clear all, close all, clc; % Global Variables global P t dt mu_1 mu_2 mu_3 % Plant numP = [1]; denP = conv ([1, 1, 1], [1, 4, 6, 4, 1]); P = tf (numP, denP); % Relative Weighting Factors: PLAY AROUND WITH THESE! mu_1 = 1; % Minimize ITAE Criterion mu_2 = 10; % Minimize Max Overshoot mu_3 = 20; % Minimize Sensitivity Ms % Simulation Settings: PLANT-DEPENDENT! t_sim = 30; % Simulation Time [s] dt = 0.05; % Sampling Time [s] t = 0 : dt : t_sim; % Time Vector [s] % A/H PID Controller: Ms = 2.0 [gamma, phi, w_gamma, w_phi] = margin (P); ku = gamma; Tu = 2*pi / w_gamma; kappa = inv (dcgain (P)); disp ('optiPID: Astrom/Hagglund PID controller parameters:'); kp_AH = ku * 0.72 * exp ( -1.60 * kappa + 1.20 * kappa^2 ) Ti_AH = Tu * 0.59 * exp ( -1.30 * kappa + 0.38 * kappa^2 ) Td_AH = Tu * 0.15 * exp ( -1.40 * kappa + 0.56 * kappa^2 ) C_AH = optiPIDctrl (kp_AH, Ti_AH, Td_AH); % Initial Values C_par_0 = [kp_AH; Ti_AH; Td_AH]; % Optimization warning ('optiPID: optimization starts, please be patient ...\n'); C_par_opt = fminsearch (@optiPIDfun, C_par_0); % Optimized Controller disp ('optiPID: optimized PID controller parameters:'); kp_opt = C_par_opt(1) Ti_opt = C_par_opt(2) Td_opt = C_par_opt(3) C_opt = optiPIDctrl (kp_opt, Ti_opt, Td_opt); % Open Loop L_AH = P * C_AH; L_opt = P * C_opt; % Closed Loop T_AH = feedback (L_AH, 1); T_opt = feedback (L_opt, 1); % A Posteriori Stability Check disp ('optiPID: closed-loop stability check:'); st_AH = isstable (T_AH) st_opt = isstable (T_opt) % Stability Margins disp ('optiPID: gain margin gamma [-] and phase margin phi [deg]:'); [gamma_AH, phi_AH] = margin (L_AH) [gamma_opt, phi_opt] = margin (L_opt) % Plot Step Response figure (1) step (T_AH, 'b', T_opt, 'r', t) legend ('Astroem/Haegglund PID', 'Optimized PID', 'Location', 'SouthEast') % ===============================================================================control-4.1.2/inst/PaxHeaders/esort.m0000644000000000000000000000007415012430645014550 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/esort.m0000644000175000017500000000425315012430645015743 0ustar00lilgelilge00000000000000## Copyright (C) 2016 Mark Bronsfeld ## ## This program is free software: you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation, either version 3 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{s} =} esort(@var{p}) ## @deftypefnx {Function File} {[@var{s}, @var{ndx}] =} esort(@var{p}) ## Sort continuous-time poles by real part (in decreasing order). ## ## @strong{Inputs} ## @table @var ## @item p ## Input vector containing continuous-time poles. ## @end table ## ## @strong{Outputs} ## @table @var ## @item s ## Vector with sorted eigenvalues. ## @item ndx ## Vector containing the indices used in the sort. ## @end table ## ## @seealso{dsort, eig, pole, pzmap, sort, zero} ## @end deftypefn ## Author: Mark Bronsfeld ## Created: December 2016 ## Version: 0.2 function [s, ndx] = esort(p) if(nargin == 1) if(!isvector(p)) error("esort: argument must be a vector"); endif else print_usage(); endif [p_sorted, ndx] = sort(real(p), 'descend'); % unused variable "p_sorted" not replaced with "~" because of backwards compatibility (<2009) s = p(ndx); endfunction %!shared s_exp, ndx_exp, s_obs, ndx_obs %! p = [-0.2410+0.5573i; %! -0.2410-0.5573i; %! 0.1503; %! -0.0972; %! -0.2590]; %! s_exp = [ 0.1503; %! -0.0972; %! -0.2410+0.5573i; %! -0.2410-0.5573i; %! -0.2590]; %! ndx_exp = [ 3; %! 4; %! 1; %! 2; %! 5]; %! [s_obs, ndx_obs] = esort(p); %!assert(s_obs, s_exp, 0); %!assert(ndx_obs, ndx_exp, 0); control-4.1.2/inst/PaxHeaders/__axis_margin__.m0000644000000000000000000000007415012430645016511 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__axis_margin__.m0000644000175000017500000000362415012430645017705 0ustar00lilgelilge00000000000000## Copyright (C) 1998, 2000, 2004, 2005, 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} {} __axis_margin__ (@var{axdata}) ## Determine axis limits for 2-D data (column vectors); leaves a 10% ## margin around the plots. ## Inserts margins of +/- 0.1 if data is one-dimensional ## (or a single point). ## ## @strong{Input} ## @table @var ## @item axdata ## @var{n} by 2 matrix of data [@var{x}, @var{y}]. ## @end table ## ## @strong{Output} ## @table @var ## @item axvec ## Vector of axis limits appropriate for call to @command{axis} function. ## @end table ## @end deftypefn function axvec = __axis_margin__ (axdata) ## compute axis limits minv = axdata(1); maxv = axdata(2); delv = (maxv-minv)/2; # breadth of the plot midv = (minv + maxv)/2; # midpoint of the plot axmid = [midv, midv]; axdel = [-0.1, 0.1]; # default plot width (if less than 2-d data) if (delv == 0) if (midv != 0) axdel = [-0.1*midv, 0.1*midv]; endif else ## they're at least one-dimensional tolv = max(1e-8, 1e-8*abs(midv)); if (abs (delv) >= tolv) axdel = 1.1*[-delv,delv]; endif endif axvec = axmid + axdel; endfunction control-4.1.2/inst/PaxHeaders/pole.m0000644000000000000000000000007415012430645014353 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/pole.m0000644000175000017500000001006615012430645015545 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{p} =} pole (@var{sys}) ## Compute poles of @acronym{LTI} system. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @end table ## ## @strong{Outputs} ## @table @var ## @item p ## Poles of @var{sys}. ## @end table ## ## @strong{Algorithm}@* ## For (descriptor) state-space models and system/state matrices, @command{pole} ## relies on Octave's @command{eig}. ## For @acronym{SISO} transfer functions, @command{pole} ## uses Octave's @command{roots}. ## @acronym{MIMO} transfer functions are converted to ## a @emph{minimal} state-space representation for the ## computation of the poles. ## ## @end deftypefn ## Author: Lukas Reichlin ## Contributor: Mark Bronsfeld ## Created: October 2009 ## Version: 0.2 function pol = pole (sys) if(nargin == 1) # pole(sys) if(!(isa(sys, "lti")) && issquare(sys)) pol = eig(sys); elseif(isa(sys, "lti")) pol = __pole__(sys); else error("pole: argument must be an LTI system"); endif else print_usage(); endif endfunction %!shared pol_exp, pol_obs %! A = [-1, 0, 0; %! 0, -2, 0; %! 0, 0, -3]; %! pol_exp = [-3; %! -2; %! -1]; %! pol_obs = pole(A); %!assert(pol_obs, pol_exp, 0); ## Poles of descriptor state-space model %!shared pol, pol_exp, infp, kronr, kronl, infp_exp, kronr_exp, kronl_exp %! A = [ 1 0 0 0 0 0 0 0 0 %! 0 1 0 0 0 0 0 0 0 %! 0 0 1 0 0 0 0 0 0 %! 0 0 0 1 0 0 0 0 0 %! 0 0 0 0 1 0 0 0 0 %! 0 0 0 0 0 1 0 0 0 %! 0 0 0 0 0 0 1 0 0 %! 0 0 0 0 0 0 0 1 0 %! 0 0 0 0 0 0 0 0 1 ]; %! %! E = [ 0 0 0 0 0 0 0 0 0 %! 1 0 0 0 0 0 0 0 0 %! 0 1 0 0 0 0 0 0 0 %! 0 0 0 0 0 0 0 0 0 %! 0 0 0 1 0 0 0 0 0 %! 0 0 0 0 1 0 0 0 0 %! 0 0 0 0 0 0 0 0 0 %! 0 0 0 0 0 0 1 0 0 %! 0 0 0 0 0 0 0 1 0 ]; %! %! B = [ -1 0 0 %! 0 0 0 %! 0 0 0 %! 0 -1 0 %! 0 0 0 %! 0 0 0 %! 0 0 -1 %! 0 0 0 %! 0 0 0 ]; %! %! C = [ 0 1 1 0 3 4 0 0 2 %! 0 1 0 0 4 0 0 2 0 %! 0 0 1 0 -1 4 0 -2 2 ]; %! %! D = [ 1 2 -2 %! 0 -1 -2 %! 0 0 0 ]; %! %! sys = dss (A, B, C, D, E, "scaled", true); %! [pol, ~, infp, kronr, kronl] = __sl_ag08bd__ (A, E, [], [], [], true); %! %! pol_exp = zeros (0,1); %! %! infp_exp = [0, 3]; %! kronr_exp = zeros (1,0); %! kronl_exp = zeros (1,0); %! %!assert (pol, pol_exp, 1e-4); %!assert (infp, infp_exp); %!assert (kronr, kronr_exp); %!assert (kronl, kronl_exp); control-4.1.2/inst/PaxHeaders/hinfsyn.m0000644000000000000000000000007415012430645015072 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/hinfsyn.m0000644000175000017500000004165415012430645016273 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{K}, @var{N}, @var{gamma}, @var{info}] =} hinfsyn (@var{P}, @var{nmeas}, @var{ncon}) ## @deftypefnx{Function File} {[@var{K}, @var{N}, @var{gamma}, @var{info}] =} hinfsyn (@var{P}, @var{nmeas}, @var{ncon}, @dots{}) ## @deftypefnx{Function File} {[@var{K}, @var{N}, @var{gamma}, @var{info}] =} hinfsyn (@var{P}, @var{nmeas}, @var{ncon}, @var{opt}, @dots{}) ## @deftypefnx{Function File} {[@var{K}, @var{N}, @var{gamma}, @var{info}] =} hinfsyn (@var{P}, @dots{}) ## @deftypefnx{Function File} {[@var{K}, @var{N}, @var{gamma}, @var{info}] =} hinfsyn (@var{P}, @var{opt}, @dots{}) ## H-infinity control synthesis for @acronym{LTI} plant. ## ## @strong{Inputs} ## @table @var ## @item P ## Generalized plant. Must be a proper/realizable @acronym{LTI} model. ## If @var{P} is constructed with @command{mktito} or @command{augw}, ## arguments @var{nmeas} and @var{ncon} can be omitted. ## @item nmeas ## Number of measured outputs v. The last @var{nmeas} outputs of @var{P} are connected to the ## inputs of controller @var{K}. The remaining outputs z (indices 1 to p-nmeas) are used ## to calculate the H-infinity norm. ## @item ncon ## Number of controlled inputs u. The last @var{ncon} inputs of @var{P} are connected to the ## outputs of controller @var{K}. The remaining inputs w (indices 1 to m-ncon) are excited ## by a harmonic test signal. ## @item @dots{} ## Optional pairs of keys and values. @code{'key1', value1, 'key2', value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## @strong{Outputs} ## @table @var ## @item K ## State-space model of the H-infinity (sub-)optimal controller. ## @item N ## State-space model of the resulting closed loop system with inputs w and outputs z. ## It is the lower linear transformation (LFT) of @var{P} and @var{K} (see function @code{lft}). ## @item info ## Structure containing additional information. ## @item info.gamma ## L-infinity norm of @var{N}. ## @item info.rcond ## Vector @var{rcond} contains estimates of the reciprocal condition ## numbers of the matrices which are to be inverted and ## estimates of the reciprocal condition numbers of the ## Riccati equations which have to be solved during the ## computation of the controller @var{K}. For details, ## see the description of the corresponding SLICOT routine. ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'method' ## String specifying the desired kind of controller: ## @table @var ## @item 'optimal', 'opt', 'o' ## Compute optimal controller using gamma iteration. ## Default selection for compatibility reasons. ## @item 'suboptimal', 'sub', 's' ## Compute (sub-)optimal controller. For stability reasons, ## suboptimal controllers are to be preferred over optimal ones. ## @end table ## @item 'gmax' ## The maximum value of the H-infinity norm of @var{N}. ## It is assumed that @var{gmax} is sufficiently large ## so that the controller is admissible. Default value is 1e15. ## @item 'gmin' ## Initial lower bound for gamma iteration. Default value is 0. ## @var{gmin} is only meaningful for optimal discrete-time controllers. ## @item 'tolgam' ## Tolerance used for controlling the accuracy of @var{gamma} ## and its distance to the estimated minimal possible ## value of @var{gamma}. Default value is 0.01. ## If @var{tolgam} = 0, then a default value equal to @code{sqrt(eps)} ## is used, where @var{eps} is the relative machine precision. ## For suboptimal controllers, @var{tolgam} is ignored. ## @item 'actol' ## Upper bound for the poles of the closed-loop system @var{N} ## used for determining if it is stable. ## @var{actol} >= 0 for stable systems. ## For suboptimal controllers, @var{actol} is ignored. ## @end table ## ## @strong{Block Diagram} ## @example ## @group ## ## gamma = min||N(K)|| N = lft (P, K) ## K inf ## ## +--------+ ## w ----->| |-----> z ## | P(s) | ## u +---->| |-----+ v ## | +--------+ | ## | | ## | +--------+ | ## +-----| K(s) |<----+ ## +--------+ ## ## +--------+ ## w ----->| N(s) |-----> z ## +--------+ ## @end group ## @end example ## ## The signals have the following meanings: ## ## @table @asis ## @item w(t): exogenous input (reference, disturbance, ...) ## @item u(t): control input ## @item z(t): performance outputs (control error, control input, ...) ## @item v(t): measured output (input of the controller) ## @end table ## ## The transfer matrix P(s) can be partitioned corresponding to the input ## and output signals: ## @example ## @group ## ## Z(s) = P11(s) W(s) + P12(s) U(s) ## V(s) = P21(s) W(s) + P22(s) U(s) ## ## | P11(s) : P12(s) | ## P(s) = |------- :--------| ## | P21(s) : P22(s) | ## -1 ## N(S) = P11(s) + P12(s)K(s)(I - P22(s)K(s)) P21(s) ## ## @end group ## @end example ## ## The state-space representation of P is given by ## @example ## @group ## ## . ## x(t) = A x(t) + B1 w(t) + B2 u(t) ## z(t) = C1 x(t) + D11 w(t) + D12 u(t) ## v(t) = C2 x(t) + D21 w(t) + D22 u(t) ## ## | C1 | | D11 : D12 | ## A, B = | B1 : B2 |, C = |----|, D = |-----:-----| ## | C2 | | D21 : D22 | ## ## @end group ## @end example ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB10FD, SB10DD and SB10AD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @seealso{augw, mixsyn, lft} ## @end deftypefn ## Author: Lukas Reichlin ## Created: December 2009 ## Version: 0.3 function [K, varargout] = hinfsyn (P, varargin) ## check input arguments if (nargin == 0) print_usage (); endif if (! isa (P, "lti")) error ("hinfsyn: first argument must be an LTI system"); endif if (nargin == 1 || (nargin > 1 && ! is_real_scalar (varargin{1}))) # hinfsyn (P, ...) [nmeas, ncon] = __tito_dim__ (P, "hinfsyn"); elseif (nargin >= 3) # hinfsyn (P, nmeas, ncon, ...) nmeas = varargin{1}; ncon = varargin{2}; varargin = varargin(3:end); else print_usage (); endif if (! is_real_scalar (nmeas)) error ("hinfsyn: second argument 'nmeas' invalid"); endif if (! is_real_scalar (ncon)) error ("hinfsyn: third argument 'ncon' invalid"); endif if (numel (varargin) > 0 && isstruct (varargin{1})) # hinfsyn (P, nmeas, ncon, opt, ...), hinfsyn (P, opt, ...) varargin = horzcat (__opt2cell__ (varargin{1}), varargin(2:end)); endif nkv = numel (varargin); # number of keys and values if (rem (nkv, 2)) error ("hinfsyn: keys and values must come in pairs"); endif ## default arguments gmax = 1e15; gmin = 0; tolgam = 0.01; actol = eps; # tolerance for stability margin method = "opt"; ## handle keys and values for k = 1 : 2 : nkv key = lower (varargin{k}); val = varargin{k+1}; switch (key) case "gmax" if (! is_real_scalar (val) || val < 0) error ("hinfsyn: 'gmax' must be a real-valued, non-negative scalar"); endif gmax = val; case "gmin" if (! is_real_scalar (val) || val < 0) error ("hinfsyn: 'gmin' must be a real-valued, non-negative scalar"); endif gmin = val; case "tolgam" if (! is_real_scalar (val) || val < 0) error ("hinfsyn: 'tolgam' must be a real-valued, non-negative scalar"); endif tolgam = val; case "actol" if (! is_real_scalar (val) || val < 0) error ("hinfsyn: 'actol' must be a real-valued, non-negative scalar"); endif actol = val; case "method" ## NOTE: I called this "method" because of the dark side, ## maybe something like "type" would make more sense ... if (strncmpi (val, "s", 1)) method = "sub"; # sub-optimal elseif (strncmpi (val, "o", 1) || strncmpi (val, "ric", 1)) method = "opt"; # optimal else error ("hinfsyn: invalid method '%s'", val); endif otherwise warning ("hinfsyn: invalid property name '%s' ignored\n", key); endswitch endfor [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: (C2, A) must be detectable"); endif ## H-infinity synthesis switch (method) case "sub" # sub-optimal controller if (isct (P)) # continuous-time plant [ak, bk, ck, dk, rcond] = __sl_sb10fd__ (a, b, c, d, ncon, nmeas, gmax); else # discrete-time plant [ak, bk, ck, dk, rcond] = __sl_sb10dd__ (a, b, c, d, ncon, nmeas, gmax); endif case "opt" # optimal controller if (isct (P)) # continuous-time plant [ak, bk, ck, dk, ~, ~, ~, ~, ~, rcond] = __sl_sb10ad__ (a, b, c, d, ncon, nmeas, gmax, tolgam, -actol); else # discrete-time plant ## NOTE: check whether it is an alternative to compute the bilinear transformation ## of P, use __sl_sb10ad__ for a continuous-time controller and then ## discretize the controller. ## estimate gamma Pt = d2c (P, "tustin"); [at, bt, ct, dt] = ssdata (Pt); [~, ~, ~, ~, ~, ~, ~, ~, gamma] = __sl_sb10ad__ (at, bt, ct, dt, ncon, nmeas, gmax, tolgam, -actol); ## gamma iteration - bisection method using __sl_sb10dd__ gmax = 1.2*gamma; while (gmax > eps && (gmax - gmin)/gmax > tolgam) gmid = (gmax + gmin)/2; try [ak, bk, ck, dk, rcond] = __sl_sb10dd__ (a, b, c, d, ncon, nmeas, gmid); ## check for stability K = ss (ak, bk, ck, dk, tsam); N = lft (P, K); if (isstable (N, actol)) gmax = norm (N, inf); else gmin = gmid; endif catch # cannot find solution gmin = gmid; end_try_catch endwhile endif otherwise error ("hinfsyn: this should never happen"); endswitch ## controller K = ss (ak, bk, ck, dk, tsam); if (nargout > 1) N = lft (P, K); varargout{1} = N; if (nargout > 2) gamma = norm (N, inf); varargout{2} = gamma; if (nargout > 3) varargout{3} = struct ("gamma", gamma, "rcond", rcond); endif endif endif endfunction ## sub-optimal controller, 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, "method", "sub", "gmax", 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); ## sub-optimal controller, 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, "method", "sub", "gmax", 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); ## optimal controller, discrete-time case??? -- test for bisection method %!shared M, M_exp, GAM_exp, GAM %! 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); %! [K, ~, GAM] = hinfsyn (P, 2, 2, "gmax", 1000, "tolgam", 1e-4); %! 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]; %! GAM_exp = 111.294; %! %!assert (M, M_exp, 1e-1); %!assert (GAM, GAM_exp, 1e-3); control-4.1.2/inst/PaxHeaders/moesp.m0000644000000000000000000000007415012430645014537 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/moesp.m0000644000175000017500000001676115012430645015741 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{sys}, @var{x0}, @var{info}] =} moesp (@var{dat}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}, @var{info}] =} moesp (@var{dat}, @var{n}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}, @var{info}] =} moesp (@var{dat}, @var{opt}, @dots{}) ## @deftypefnx {Function File} {[@var{sys}, @var{x0}, @var{info}] =} moesp (@var{dat}, @var{n}, @var{opt}, @dots{}) ## Estimate state-space model using @acronym{MOESP} algorithm. ## @acronym{MOESP}: Multivariable Output Error State sPace. ## If no output arguments are given, the singular values are ## plotted on the screen in order to estimate the system order. ## ## @strong{Inputs} ## @table @var ## @item dat ## iddata set containing the measurements, i.e. time-domain signals. ## @item n ## The desired order of the resulting state-space system @var{sys}. ## If not specified, @var{n} is chosen automatically according ## to the singular values and tolerances. ## @item @dots{} ## Optional pairs of keys and values. @code{'key1', value1, 'key2', value2}. ## @item opt ## Optional struct with keys as field names. ## Struct @var{opt} can be created directly or ## by function @command{options}. @code{opt.key1 = value1, opt.key2 = value2}. ## @end table ## ## ## @strong{Outputs} ## @table @var ## @item sys ## Discrete-time state-space model. ## @item x0 ## Initial state vector. If @var{dat} is a multi-experiment dataset, ## @var{x0} becomes a cell vector containing an initial state vector ## for each experiment. ## @item info ## Struct containing additional information. ## @table @var ## @item info.K ## Kalman gain matrix. ## @item info.Q ## State covariance matrix. ## @item info.Ry ## Output covariance matrix. ## @item info.S ## State-output cross-covariance matrix. ## @item info.L ## Noise variance matrix factor. LL'=Ry. ## @end table ## @end table ## ## ## ## @strong{Option Keys and Values} ## @table @var ## @item 'n' ## The desired order of the resulting state-space system @var{sys}. ## @var{s} > @var{n} > 0. ## ## @item 's' ## The number of block rows @var{s} in the input and output ## block Hankel matrices to be processed. @var{s} > 0. ## In the MOESP theory, @var{s} should be larger than @var{n}, ## the estimated dimension of state vector. ## ## @item 'alg', 'algorithm' ## Specifies the algorithm for computing the triangular ## factor R, as follows: ## @table @var ## @item 'C' ## Cholesky algorithm applied to the correlation ## matrix of the input-output data. Default method. ## @item 'F' ## Fast QR algorithm. ## @item 'Q' ## QR algorithm applied to the concatenated block ## Hankel matrices. ## @end table ## ## @item 'tol' ## Absolute tolerance used for determining an estimate of ## the system order. If @var{tol} >= 0, the estimate is ## indicated by the index of the last singular value greater ## than or equal to @var{tol}. (Singular values less than @var{tol} ## are considered as zero.) When @var{tol} = 0, an internally ## computed default value, @var{tol} = @var{s}*@var{eps}*SV(1), is used, ## where SV(1) is the maximal singular value, and @var{eps} is ## the relative machine precision. ## When @var{tol} < 0, the estimate is indicated by the ## index of the singular value that has the largest ## logarithmic gap to its successor. Default value is 0. ## ## @item 'rcond' ## The tolerance to be used for estimating the rank of ## matrices. If the user sets @var{rcond} > 0, the given value ## of @var{rcond} is used as a lower bound for the reciprocal ## condition number; an m-by-n matrix whose estimated ## condition number is less than 1/@var{rcond} is considered to ## be of full rank. If the user sets @var{rcond} <= 0, then an ## implicitly computed, default tolerance, defined by ## @var{rcond} = m*n*@var{eps}, is used instead, where @var{eps} is the ## relative machine precision. Default value is 0. ## ## @item 'confirm' ## Specifies whether or not the user's confirmation of the ## system order estimate is desired, as follows: ## @table @var ## @item true ## User's confirmation. ## @item false ## No confirmation. Default value. ## @end table ## ## @item 'noiseinput' ## The desired type of noise input channels. ## @table @var ## @item 'n' ## No error inputs. Default value. ## @iftex ## @tex ## $$ x_{k+1} = A x_k + B u_k $$ ## $$ y_k = C x_k + D u_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## x[k+1] = A x[k] + B u[k] ## y[k] = C x[k] + D u[k] ## @end example ## @end ifnottex ## ## @item 'e' ## Return @var{sys} as a (p-by-m+p) state-space model with ## both measured input channels u and noise channels e ## with covariance matrix @var{Ry}. ## @iftex ## @tex ## $$ x_{k+1} = A x_k + B u_k + K e_k $$ ## $$ y_k = C x_k + D u_k + e_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## x[k+1] = A x[k] + B u[k] + K e[k] ## y[k] = C x[k] + D u[k] + e[k] ## @end example ## @end ifnottex ## ## @item 'v' ## Return @var{sys} as a (p-by-m+p) state-space model with ## both measured input channels u and white noise channels v ## with identity covariance matrix. ## @iftex ## @tex ## $$ x_{k+1} = A x_k + B u_k + K L v_k $$ ## $$ y_k = C x_k + D u_k + L v_k $$ ## $$ e = L v, \\ L L^T = R_y $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## x[k+1] = A x[k] + B u[k] + K L v[k] ## y[k] = C x[k] + D u[k] + L v[k] ## e = L v, L L' = Ry ## @end example ## @end ifnottex ## ## @item 'k' ## Return @var{sys} as a Kalman predictor for simulation. ## @iftex ## @tex ## $$ \\widehat{x}_{k+1} = A \\widehat{x}_k + B u_k + K (y_k - \\widehat{y}_k) $$ ## $$ \\widehat{y}_k = C \\widehat{x}_k + D u_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## ^ ^ ^ ## x[k+1] = A x[k] + B u[k] + K(y[k] - y[k]) ## ^ ^ ## y[k] = C x[k] + D u[k] ## @end example ## @end ifnottex ## ## @iftex ## @tex ## $$ \\widehat{x}_{k+1} = (A-KC) \\widehat{x}_k + (B-KD) u_k + K y_k $$ ## $$ \\widehat{y}_k = C \\widehat{x}_k + D u_k + 0 y_k $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## ^ ^ ## x[k+1] = (A-KC) x[k] + (B-KD) u[k] + K y[k] ## ^ ^ ## y[k] = C x[k] + D u[k] + 0 y[k] ## @end example ## @end ifnottex ## @end table ## @end table ## ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT IB01AD, IB01BD and IB01CD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: May 2012 ## Version: 0.1 function [sys, x0, info] = moesp (varargin) if (nargin == 0) print_usage (); endif if (nargout == 0) __slicot_identification__ ("moesp", nargout, varargin{:}); else [sys, x0, info] = __slicot_identification__ ("moesp", nargout, varargin{:}); endif endfunction control-4.1.2/inst/PaxHeaders/lyap.m0000644000000000000000000000007415012430645014361 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/lyap.m0000644000175000017500000001317615012430645015560 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{x} =} lyap (@var{a}, @var{b}) ## @deftypefnx{Function File} {@var{x} =} lyap (@var{a}, @var{b}, @var{c}) ## @deftypefnx{Function File} {@var{x} =} lyap (@var{a}, @var{b}, @var{[]}, @var{e}) ## Solve continuous-time Lyapunov or Sylvester equations. ## ## @strong{Equations} ## @example ## @group ## AX + XA' + B = 0 (Lyapunov Equation) ## ## AX + XB + C = 0 (Sylvester Equation) ## ## AXE' + EXA' + B = 0 (Generalized Lyapunov Equation) ## @end group ## @end example ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT SB03MD SB04MD and SG03AD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @seealso{lyapchol, dlyap, dlyapchol} ## @end deftypefn ## Author: Lukas Reichlin ## Created: January 2010 ## Version: 0.2.1 function [x, scale] = lyap (a, b, c, e) scale = 1; switch (nargin) case 2 # Lyapunov equation if (! issymmetric (b)) ## b not symmetric, ## use Sylvester equation a*x + x*b + c = 0 with b = a' [x, scale] = lyap (a, a', b); return; endif if (! is_real_square_matrix (a, b)) ## error ("lyap: a, b must be real and square"); error ("lyap: %s, %s must be real and square", ... inputname (1), inputname (2)); endif if (rows (a) != rows (b)) ## error ("lyap: a, b must have the same number of rows"); error ("lyap: %s, %s must have the same number of rows", ... inputname (1), inputname (2)); endif [x, scale] = __sl_sb03md__ (a, -b, false); # AX + XA' = -B ## x /= scale; # 0 < scale <= 1 case 3 # Sylvester equation if (! is_real_square_matrix (a, b)) ## error ("lyap: a, b must be real and square"); error ("lyap: %s, %s must be real and square", ... inputname (1), inputname (2)); endif if (! is_real_matrix (c) || rows (c) != rows (a) || columns (c) != columns (b)) ## error ("lyap: c must be a real (%dx%d) matrix", rows (a), columns (b)); error ("lyap: %s must be a real (%dx%d) matrix", ... rows (a), columns (b), inputname (3)); endif x = __sl_sb04md__ (a, b, -c); # AX + XB = -C case 4 # generalized Lyapunov equation if (! isempty (c)) print_usage (); endif if (! is_real_square_matrix (a, b, e)) ## error ("lyap: a, b, e must be real and square"); error ("lyap: %s, %s, %s must be real and square", ... inputname (1), inputname (2), inputname (4)); endif if (rows (b) != rows (a) || rows (e) != rows (a)) ## error ("lyap: a, b, e must have the same number of rows"); error ("lyap: %s, %s, %s must have the same number of rows", ... inputname (1), inputname (2), inputname (4)); endif if (! issymmetric (b)) ## error ("lyap: b must be symmetric"); error ("lyap: %s must be symmetric", ... inputname (2)); endif [x, scale] = __sl_sg03ad__ (a, e, -b, false); # AXE' + EXA' = -B ## x /= scale; # 0 < scale <= 1 otherwise print_usage (); endswitch if (scale < 1) warning ("lyap: solution scaled by %g to prevent overflow\n", scale); endif endfunction ## Lyapunov %!shared M, Me %! A = [2.0 1.0 3.0 %! 0.0 2.0 1.0 %! 6.0 1.0 2.0]; %! Q = [3 1 1 %! 1 1 -1 %! 1 -1 0]; %! X = lyap (A, Q); %! M = A*X + X*A' + Q; %! Me = zeros (3,3); %!assert (M, Me, 1e-4); ## Lyapunov with non-symmetric Q %!shared M, Me %! A = [2.0 1.0 3.0 %! 0.0 2.0 1.0 %! 6.0 1.0 2.0]; %! Q = [3 1 -3 %! 0 1 -2 %! 1 1 0]; %! X = lyap (A, Q); %! M = A*X + X*A' + Q; %! Me = zeros (3,3); %!assert (M, Me, 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); ## 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); control-4.1.2/inst/PaxHeaders/obsvf.m0000644000000000000000000000007415012430645014533 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/obsvf.m0000644000175000017500000000516315012430645015727 0ustar00lilgelilge00000000000000## Copyright (C) 2010 Benjamin Fernandez ## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {[@var{sysbar}, @var{T}, @var{K}] =} obsvf (@var{sys}) ## @deftypefnx{Function File} {[@var{sysbar}, @var{T}, @var{K}] =} obsvf (@var{sys}, @var{tol}) ## @deftypefnx{Function File} {[@var{Abar}, @var{Bbar}, @var{Cbar}, @var{T}, @var{K}] =} obsvf (@var{A}, @var{B}, @var{C}) ## @deftypefnx{Function File} {[@var{Abar}, @var{Bbar}, @var{Cbar}, @var{T}, @var{K}] =} obsvf (@var{A}, @var{B}, @var{C}, @var{TOL}) ## If Ob=obsv(A,C) has rank r <= n = SIZE(A,1), then there is a ## similarity transformation Tc such that To = [t1;t2] where t1 is c ## and t2 is orthogonal to t1 ## ## @example ## @group ## Abar = To \\ A * To , Bbar = To \\ B , Cbar = C * To ## @end group ## @end example ## ## and the transformed system has the form ## ## @example ## @group ## | Ao 0 | | Bo | ## Abar = |----------|, Bbar = | --- |, Cbar = [Co | 0 ]. ## | A21 Ano| | Bno | ## @end group ## @end example ## ## where (Ao,Bo) is observable, and Co(sI-Ao)^(-1)Bo = C(sI-A)^(-1)B. And ## system is detectable if Ano has no eigenvalues in the right ## half plane. The last output K is a vector of length n containing the ## number of observable states. ## @end deftypefn ## Author: Benjamin Fernandez ## Created: 2010-05-02 ## Version: 0.1 function [ac, bc, cc, z, ncont] = obsvf (a, b = [], c, tol = []) if (nargin < 1 || nargin > 4) print_usage (); endif if (isa (a, "lti")) if (nargin > 2) print_usage (); endif [ac, bc, cc] = ctrbf (a.', b); # [sysbar, z, ncont] = ctrbf (sys.', tol); ac = ac.'; z = ncont = []; else if (nargin < 3) print_usage (); endif [ac, tmp, cc, z, ncont] = ctrbf (a.', c.', b.', tol); ac = ac.'; bc = cc.'; cc = tmp.'; endif endfunction control-4.1.2/inst/PaxHeaders/@tfpoly0000644000000000000000000000007415012430645014576 xustar0030 atime=1747595720.873132883 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/0000755000175000017500000000000015012430645016042 5ustar00lilgelilge00000000000000control-4.1.2/inst/@tfpoly/PaxHeaders/__remove_leading_zeros__.m0000644000000000000000000000007415012430645022027 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/__remove_leading_zeros__.m0000644000175000017500000000223115012430645023214 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Remove leading zeros from a polynomial, except for polynomials ## which are of length 1. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function p = __remove_leading_zeros__ (p) idx = find (p.poly != 0); if (isempty (idx)) p.poly = 0; else p.poly = p.poly(idx(1) : end); # p.poly(idx) would remove all zeros endif endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/get.m0000644000000000000000000000007415012430645015610 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/get.m0000644000175000017500000000171415012430645017002 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Return coefficients as a row vector. For internal use only. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.1 function coeffs = get (p) coeffs = p.poly; endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/conj_ct.m0000644000000000000000000000007415012430645016450 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/conj_ct.m0000644000175000017500000000215015012430645017635 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Conjugate of continuous-time polynomial. Replace s by -s. ## For internal use only. ## Author: Lukas Reichlin ## Created: May 2012 ## Version: 0.1 function p = conj_ct (p) if (mod(numel(p.poly),2) == 0) #even powers of s p.poly(2:2:end) = -p.poly(2:2:end); else #odd p.poly(1:2:end) = -p.poly(1:2:end); endif endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/subsref.m0000644000000000000000000000007415012430645016502 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/subsref.m0000644000175000017500000000237715012430645017702 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Evaluate polynomial. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function b = subsref (a, s) if (isempty (s)) error ("tfpoly: missing index"); endif switch (s(1).type) case "()" idx = s(1).subs; if (numel (idx) == 1) b = polyval (a.poly, idx{1}); else error ("tfpoly: need exactly one index"); endif otherwise error ("tfpoly: invalid subscript type"); endswitch endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/roots.m0000644000000000000000000000007415012430645016177 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/roots.m0000644000175000017500000000166515012430645017376 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Compute the roots of a TFPOLY object. ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.1 function r = roots (p) r = roots (p.poly); endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/uplus.m0000644000000000000000000000007415012430645016201 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/uplus.m0000644000175000017500000000167615012430645017402 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Unitary plus operator. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function a = uplus (a) a.poly = +a.poly; endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/conj_dt.m0000644000000000000000000000007415012430645016451 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/conj_dt.m0000644000175000017500000000174715012430645017651 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Conjugate of discrete-time polynomial. Replace z by 1/z. ## For internal use only. ## Author: Lukas Reichlin ## Created: May 2012 ## Version: 0.1 function p = conj_dt (p) p.poly = fliplr (p.poly); endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/tfpoly2str.m0000644000000000000000000000007415012430645017161 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/tfpoly2str.m0000644000175000017500000000473015012430645020354 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{str} =} tfpoly2str (@var{p}) ## @deftypefnx {Function File} {@var{str} =} tfpoly2str (@var{p}, @var{tfvar}) ## Return the string of a polynomial with string @var{tfvar} as variable. ## @end deftypefn ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function str = tfpoly2str (p, tfvar = "x") str = ""; lp = numel (p.poly); if (lp > 0) ## first element (highest order) a = p.poly(1); if (a < 0) cs = "-"; else cs = ""; endif if (lp == 1) str = [cs, num2str(abs (a), 4)]; else if (abs (a) == 1) str = [cs, __variable__(tfvar, lp-1)]; else str = [cs, __coefficient__(a), " ", __variable__(tfvar, lp-1)]; endif endif if (lp > 1) ## elements in the middle for k = 2 : lp-1 a = p.poly(k); if (a != 0) if (a < 0) cs = " - "; else cs = " + "; endif if (abs (a) == 1) str = [str, cs, __variable__(tfvar, lp-k)]; else str = [str, cs, __coefficient__(a), " ", __variable__(tfvar, lp-k)]; endif endif endfor ## last element (lowest order) a = p.poly(lp); if (a != 0) if (a < 0) cs = " - "; else cs = " + "; endif str = [str, cs, num2str(abs (a), 4)]; endif endif endif endfunction function str = __coefficient__ (a) b = abs (a); if (b == 1) str = ""; else str = num2str (b, 4); endif endfunction function str = __variable__ (tfvar, n) if (n == 1) str = tfvar; else str = [tfvar, "^", num2str(n)]; endif endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/is_zero.m0000644000000000000000000000007415012430645016503 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/is_zero.m0000644000175000017500000000171715012430645017700 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Check whether tfpoly is zero. For internal use only. ## Author: Lukas Reichlin ## Created: September 2013 ## Version: 0.1 function bool = is_zero (p) bool = ! any (p.poly); endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/mtimes.m0000644000000000000000000000007415012430645016327 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/mtimes.m0000644000175000017500000000211415012430645017514 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Multiplication of two polynomials. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function a = mtimes (a, b) if (! isa (a, "tfpoly")) a = tfpoly (a); endif if (! isa (b, "tfpoly")) b = tfpoly (b); endif a.poly = conv (a.poly, b.poly); endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/eq.m0000644000000000000000000000007415012430645015436 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/eq.m0000644000175000017500000000202715012430645016626 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Test for equal coefficients. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function bool = eq (a, b) a = tfpoly (a); b = tfpoly (b); bool = (length (a) == length (b)) && all (a.poly == b.poly); endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/tfpoly.m0000644000000000000000000000007415012430645016346 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/tfpoly.m0000644000175000017500000000260015012430645017533 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Class constructor. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.2 function p = tfpoly (a) superiorto ("double"); switch (nargin) case 0 p = struct ("poly", []); p = class (p, "tfpoly"); case 1 if (isa (a, "tfpoly")) p = a; return; elseif (is_real_vector (a)) p.poly = reshape (a, 1, []); p = class (p, "tfpoly"); p = __remove_leading_zeros__ (p); else error ("tfpoly: argument must be a real-valued vector"); endif otherwise print_usage (); endswitch endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/mpower.m0000644000000000000000000000007415012430645016342 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/mpower.m0000644000175000017500000000242415012430645017533 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Power of a polynomial. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function p = mpower (a, b) if (! isa (b, "double") && ! is_real_scalar (b)) error ("tfpoly: mpower: power must be a natural number"); endif c = uint64 (b); if (c != b) error ("tfpoly: mpower: power must be a positive integer"); endif if (c == 0) p = tfpoly (1); return; endif p = a; for k = 1 : (c-1) p.poly = conv (p.poly, a.poly); endfor endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/numel.m0000644000000000000000000000007415012430645016151 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/numel.m0000644000175000017500000000170115012430645017337 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Number of coefficients. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function n = numel (p) n = numel (p.poly); endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/uminus.m0000644000000000000000000000007415012430645016351 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/uminus.m0000644000175000017500000000170015012430645017536 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Unitary minus operator. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function a = uminus (a) a.poly = -a.poly; endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/__make_equally_long__.m0000644000000000000000000000007415012430645021315 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/__make_equally_long__.m0000644000175000017500000000222415012430645022504 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Make two polynomials equally long by adding leading zeros ## to the shorter one. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function [a, b] = __make_equally_long__ (a, b) la = length (a.poly); lb = length (b.poly); lmax = max (la, lb); a.poly = [zeros(1, lmax-la), a.poly]; b.poly = [zeros(1, lmax-lb), b.poly]; endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/display.m0000644000000000000000000000007415012430645016476 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/display.m0000644000175000017500000000167015012430645017671 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Display routine. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function display (p) tfpoly2str (p, "s") endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/minus.m0000644000000000000000000000007415012430645016164 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/minus.m0000644000175000017500000000222115012430645017350 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Subtraction of two polynomials. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function a = minus (a, b) if (! isa (a, "tfpoly")) a = tfpoly (a); endif if (! isa (b, "tfpoly")) b = tfpoly (b); endif [a, b] = __make_equally_long__ (a, b); a.poly = a.poly - b.poly; a = __remove_leading_zeros__ (a); endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/plus.m0000644000000000000000000000007415012430645016014 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/plus.m0000644000175000017500000000221515012430645017203 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Addition of two polynomials. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function a = plus (a, b) if (! isa (a, "tfpoly")) a = tfpoly (a); endif if (! isa (b, "tfpoly")) b = tfpoly (b); endif [a, b] = __make_equally_long__ (a, b); a.poly = a.poly + b.poly; a = __remove_leading_zeros__ (a); endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/length.m0000644000000000000000000000007415012430645016312 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/length.m0000644000175000017500000000170315012430645017502 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Number of coefficients. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function l = length (p) l = length (p.poly); endfunction control-4.1.2/inst/@tfpoly/PaxHeaders/ne.m0000644000000000000000000000007415012430645015433 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/@tfpoly/ne.m0000644000175000017500000000204415012430645016622 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Return true if polynomials are not equal. For internal use only. ## Author: Lukas Reichlin ## Created: September 2009 ## Version: 0.1 function bool = ne (a, b) a = tfpoly (a); b = tfpoly (b); bool = (length (a) != length (b)) || any (a.poly != b.poly); endfunction control-4.1.2/inst/PaxHeaders/gram.m0000644000000000000000000000007415012430645014342 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/gram.m0000644000175000017500000000754615012430645015545 0ustar00lilgelilge00000000000000## Copyright (C) 1996, 2000, 2003, 2004, 2005, 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 ## . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{W} =} gram (@var{sys}, @var{mode}) ## @deftypefnx {Function File} {@var{Wc} =} gram (@var{a}, @var{b}) ## @code{gram (@var{sys}, "c")} returns the controllability gramian of ## the (continuous- or discrete-time) system @var{sys}. ## @code{gram (@var{sys}, "o")} returns the observability gramian of the ## (continuous- or discrete-time) system @var{sys}. ## @code{gram (@var{a}, @var{b})} returns the controllability gramian ## @var{Wc} of the continuous-time system @math{dx/dt = a x + b u}; ## i.e., @var{Wc} satisfies @math{a Wc + m Wc' + b b' = 0}. ## ## @end deftypefn ## Author: A. S. Hodel ## Adapted-By: Lukas Reichlin ## Date: October 2009 ## Version: 0.2 function W = gram (argin1, argin2) if (nargin != 2) print_usage (); endif if (ischar (argin2)) # the function was called as "gram (sys, mode)" sys = argin1; if (! isa (sys, "lti")) error ("gram: first argument must be an LTI model"); endif [a, b, c] = ssdata (sys); if (strncmpi (argin2, "o", 1)) a = a.'; b = c.'; elseif (! strncmpi (argin2, "c", 1)) print_usage (); endif else # the function was called as "gram (a, b)" a = argin1; b = argin2; ## assume that a and b are matrices of continuous-time system ## values of b, c and d are irrelevant for system stability sys = ss (a, b, zeros (1, columns (a)), zeros (1, columns (b))); endif if (! isstable (sys)) error ("gram: system matrix a must be stable"); endif if (isct (sys)) 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 endfunction %!test %! a = [-1 0 0; 1/2 -1 0; 1/2 0 -1]; %! b = [1 0; 0 -1; 0 1]; %! c = [0 0 1; 1 1 0]; ## it doesn't matter what the value of c is %! Wc = gram (ss (a, b, c), "c"); %! assert (a * Wc + Wc * a.' + b * b.', zeros (size (a))) %!test %! a = [-1 0 0; 1/2 -1 0; 1/2 0 -1]; %! b = [1 0; 0 -1; 0 1]; ## it doesn't matter what the value of b is %! c = [0 0 1; 1 1 0]; %! Wo = gram (ss (a, b, c), "o"); %! assert (a.' * Wo + Wo * a + c.' * c, zeros (size (a))) %!test %! a = [-1 0 0; 1/2 -1 0; 1/2 0 -1]; %! b = [1 0; 0 -1; 0 1]; %! Wc = gram (a, b); %! assert (a * Wc + Wc * a.' + b * b.', zeros (size (a))) %!test %! a = [-1 0 0; 1/2 1 0; 1/2 0 -1] / 2; %! b = [1 0; 0 -1; 0 1]; %! c = [0 0 1; 1 1 0]; ## it doesn't matter what the value of c is %! d = zeros (rows (c), columns (b)); ## it doesn't matter what the value of d is %! Ts = 0.1; ## Ts != 0 %! Wc = gram (ss (a, b, c, d, Ts), "c"); %! assert (a * Wc * a.' - Wc + b * b.', zeros (size (a)), 1e-12) %!test %! a = [-1 0 0; 1/2 1 0; 1/2 0 -1] / 2; %! b = [1 0; 0 -1; 0 1]; ## it doesn't matter what the value of b is %! c = [0 0 1; 1 1 0]; %! d = zeros (rows (c), columns (b)); ## it doesn't matter what the value of d is %! Ts = 0.1; ## Ts != 0 %! Wo = gram (ss (a, b, c, d, Ts), "o"); %! assert (a.' * Wo * a - Wo + c.' * c, zeros (size (a)), 1e-12) control-4.1.2/inst/PaxHeaders/imp_invar.m0000644000000000000000000000007415012430645015400 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/imp_invar.m0000644000175000017500000001475115012430645016577 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2015 Lukas F. Reichlin ## Copyright (C) 2016 Douglas A. Stewart ## Copyright (C) 2024 Torsten Lilge ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{b_out}, @var{a_out}] =} imp_invar (@var{b}, @var{a}, @var{fs}, @var{tol}) ## @deftypefnx {Function File} {[@var{b_out}, @var{a_out}] =} imp_invar (@var{b}, @var{a}, @var{fs}) ## @deftypefnx {Function File} {[@var{b_out}, @var{a_out}] =} imp_invar (@var{b}, @var{a}) ## @deftypefnx {Function File} {[@var{sys_out}] =} imp_invar (@var{b}, @var{a}, @var{fs}. @var{tol}) ## @deftypefnx {Function File} {[@var{sys_out}] =} imp_invar (@var{sys_in}, @var{fs}, @var{tol}) ## Converts analog filter with coefficients @var{b} and @var{a} and/or @var{sys_in} to digital, ## conserving impulse response. ## ## MIMO systems are only supported with @var{sys_in} as input argument. ## ## @strong{Inputs} ## @table @var ## @item b ## Numerator coefficients of continuous-time LTI system. ## @item a ## Denominator coefficients of continuous-time LTI system. ## @item fs ## Sampling frequency. If @var{fs} is not specified, or is an empty vector, ## it defaults to 1Hz. ## tol ## Tolerance of the internally used function minreal for canceling identical ## poles and zeros. If @var{tol} is not specified, it defaults to 0.0001 (0.1%). ## @item sys_in ## System definition of the continuous-time LTI system. This can also be ## a MIMO system. ## @end table ## ## @strong{Outputs} ## @table @var ## @item b_out ## Numerator coefficients of the discrete-time impulse invariant LTI system. ## @item a_out ## Denominator coefficients of the discrete-time impulse invariant LTI system. ## @item sys_out ## Discrete-time impulse invaraiant LTI system. If @var{sys_in} is given as ## state space representation, @var{sys_out} is also returned in state space, ## otherwise as transfer function. ## @end table ## ## @strong{Algorithm} ## ## The step equivalent discretization of G(s) (zoh) results in ## G_zoh(z) = (z-1)/z * Z@{G(s)/s@} where Z@{@} is the z-transformation. ## The transfer function of the impulse equivalent discretization ## is given by T*Z@{G(s)@}. Therefore, the zoh discretizaiton method for ## s*G(s) multipled by T*z/(z-1) leads to the desired result. ## ## @strong{Remark} ## ## For the impulse response of a discrete-time system, the input ## sequence @{1/T,0,0,0,...@} and not the unit impulse is considered. ## For this reason, the factor T is required for the impulse invaraint ## discretizaiton (see Algorithm). ## ## @seealso{c2d} ## @end deftypefn function [bz az] = imp_invar (b , a , fs , tol = 1e-4) ## This funtion will accept both a ## sys variable as input and/or ## numerator, denominator as input. if (nargin < 1) print_usage; endif if (isa (b, "lti")) ## the input is an LTI object, therefore inputs are (sys,fs,tol) ## so b is sys, a is fs, and fs is tol ## in this case, MIMO systems are allowed if (exist("fs","var") != 0) tol = fs; else tol=0.0001; endif if (exist ("a") == 1) fs=a; else fs=1; endif ## lti system given in state space and nargout == 1? ## if yes, just return discretized system in state space if ( isa (b,"ss") && (nargout == 1) ) bz = c2d (b, 1/fs, "imp"); return; endif ## get all polynomials in a cell array [ny, nu] = size (b); [bcell, acell] = tfdata (b); else ## some internal functions call imp_invar with polynomials in cells if (iscell (b)) b = b{1,1}; endif if (iscell (a)) a = a{1,1}; endif ## the input is vectors if (! (ismatrix (b) && ismatrix (a))) || ... ((min (size (b)) != 1) && (min (size (a)) != 1)) error ("imp_invar: first two arguments must be vectors\n"); endif if (exist ("fs") == 0) fs = 1; endif ny = nu = 1; bcell = cell (); acell = cell (); bcell{1,1} = b; acell{1,1} = a; endif if (isempty (fs)) fs = 1; endif if (isempty (tol)) tol = 1e-4; endif T = 1/fs; bz = cell (ny,nu); az = bz; for iy = 1:ny for iu = 1:nu b = remove_leading_zeros (bcell{iy,iu}); a = remove_leading_zeros (acell{iy,iu}); if (length (b) >= length (a)) error("Order numerator >= order denominator"); endif ## Apply zoh method for s*G(s) and multiply the result by z/(z-1). b = conv (b, [1 0]); # multiply by s G_zoh = c2d (tf (b,a), T, 'zoh'); # zoh method for s*G(s) [bzz,azz] = tfdata (G_zoh, 'v'); # get polynomials of result bzz = remove_leading_zeros (bzz); bzz = conv (bzz, [T 0]); # multiply numerator by T*z azz = conv (azz, [1 -1]); # multiply denominator by z-1 sys1 = tf (bzz, azz, T); sys2 = minreal (sys1, tol); # Use this to remove the common roots. [bz{iy,iu}, az{iy,iu}] = tfdata (sys2, "v"); endfor endfor if (nargout() < 2) bz = tf (bz, az, T); else if (ny*nu == 1) bz = bz{1,1}; az = az{1,1}; endif endif endfunction function x_clean = remove_leading_zeros (x) nonzero = find (x); if length (nonzero) == 0 x_clean = 0; else x_clean = x(nonzero(1):end); endif endfunction ## Tests ## %!shared bz1, az1, bz2, az2, bz1_e, az1_e, bz2_e, az2_e %! %! s = tf ('s'); %! Gs = (s-2)*(s-1)*(s+5)/s/(s+1)/(s+2)^3/(s+3)/(s+4); %! [b,a] = tfdata (Gs, 'v'); %! [bz1,az1] = imp_invar (Gs, 2); %! [bz2,az2] = imp_invar (b, a, 5); %! %! bz1_e = 1/2*[-0.0000 0.0036 -0.0128 0.0039 0.0125 -0.0001 -0.0001 0.0000]; %! az1_e = [ 1.0000 -3.0686 3.7873 -2.4518 0.9020 -0.1886 0.0207 -0.0009]; %! %! bz2_e = 1/5*[-0.0000 0.0007 -0.0007 -0.0025 0.0032 -0.0004 -0.0001 0.0000]; %! az2_e = [ 1.0000 -4.8278 9.8933 -11.1569 7.4787 -2.9798 0.6534 -0.0608]; %! %!assert (az1, az1_e, 1e-4); %!assert (bz1, bz1_e, 1e-4); %!assert (az2, az2_e, 1e-4); %!assert (bz2, bz2_e, 1e-4); control-4.1.2/inst/PaxHeaders/__opt2cell__.m0000644000000000000000000000007415012430645015734 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__opt2cell__.m0000644000175000017500000000225615012430645017130 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Convert option struct to a cell with field names as keys and ## field values as values. ## Author: Lukas Reichlin ## Created: November 2011 ## Version: 0.1 function c = __opt2cell__ (opt) if (! isstruct (opt)) error ("opt2cell: argument must be a struct"); endif key = fieldnames (opt); val = struct2cell (opt); c = [key.'; val.'](:).'; # reshape to {key1, val1, key2, val2, ...} endfunction control-4.1.2/inst/PaxHeaders/__adjust_ss_data__.m0000644000000000000000000000007415012430645017200 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__adjust_ss_data__.m0000644000175000017500000000321315012430645020366 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Common code for adjusting SS model data. ## Used by @ss/ss.m, others possibly follow. ## Author: Lukas Reichlin ## Created: October 2010 ## Version: 0.3 function [a, b, c, d, tsam] = __adjust_ss_data__ (a, b, c, d, tsam); if (isempty (d)) if (all (size (c) == 0)) # ss (a, b), ss (a, b, [], [], ...), but allow c(0xn) and d(0xm) c = eye (size (a)); d = zeros (rows (a), columns (b)); else # ss (a, b, c), ss (a, b, c, [], ...) d = zeros (rows (c), columns (b)); endif endif if (isempty (b) && isempty (c)) # sys = ss ([], [], [], d) b = zeros (0, columns (d)); c = zeros (rows (d), 0); endif if (is_real_scalar (d) && d == 0) # ss (a, b, c, 0) (for matlab compatibility) d = zeros (rows (c), columns (b)); # test d == 0 to avoid ss (0) returning 0x0 model endif endfunction control-4.1.2/inst/PaxHeaders/initial.m0000644000000000000000000000007415012430645015045 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/initial.m0000644000175000017500000001212315012430645016233 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {} initial (@var{sys}, @var{x0}) ## @deftypefnx{Function File} {} initial (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}, @var{x0}) ## @deftypefnx{Function File} {} initial (@var{sys1}, @var{'style1'}, @dots{}, @var{sysN}, @var{'styleN'}, @var{x0}) ## @deftypefnx{Function File} {} initial (@var{sys1}, @dots{}, @var{x0}, @var{t}) ## @deftypefnx{Function File} {} initial (@var{sys1}, @dots{}, @var{x0}, @var{tfinal}) ## @deftypefnx{Function File} {} initial (@var{sys1}, @dots{}, @var{x0}, @var{tfinal}, @var{dt}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} initial (@var{sys}, @var{x0}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} initial (@var{sys}, @var{x0}, @var{t}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} initial (@var{sys}, @var{x0}, @var{tfinal}) ## @deftypefnx{Function File} {[@var{y}, @var{t}, @var{x}] =} initial (@var{sys}, @var{x0}, @var{tfinal}, @var{dt}) ## Initial condition response of state-space model. ## If no output arguments are given, the response is printed on the screen. ## ## @strong{Inputs} ## @table @var ## @item sys ## State-space model. ## @item x0 ## Vector of initial conditions for each state. ## @item t ## Optional time vector. Should be evenly spaced. If not specified, it is calculated ## by the poles of the system to reflect adequately the response transients. ## @item tfinal ## Optional simulation horizon. If not specified, it is calculated by ## the poles of the system to reflect adequately the response transients. ## @item dt ## Optional sampling time. Be sure to choose it small enough to capture transient ## phenomena. If not specified, it is calculated by the poles of the system. ## @item 'style' ## Line style and color, e.g. 'r' for a solid red line or '-.k' for a dash-dotted ## black line. See @command{help plot} for details. ## @end table ## ## @strong{Outputs} ## @table @var ## @item y ## Output response array. Has as many rows as time samples (length of t) ## and as many columns as outputs. ## @item t ## Time row vector. ## @item x ## State trajectories array. Has @code{length (t)} rows and as many columns as states. ## @end table ## ## @strong{Example} ## @example ## @group ## . ## Continuous Time: x = A x , y = C x , x(0) = x0 ## ## Discrete Time: x[k+1] = A x[k] , y[k] = C x[k] , x[0] = x0 ## @end group ## @end example ## ## @seealso{impulse, lsim, step} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 1.0 function [y_r, t_r, x_r] = initial (varargin) if (nargin < 2) print_usage (); endif names = cell (1,nargin); for i = 1:nargin names{i} = inputname (i); end [y, t, x] = __time_response__ ("initial", varargin, names, nargout); if (nargout) y_r = y{1}; t_r = t{1}; x_r = x{1}; endif endfunction %!shared initial_c, initial_c_exp, initial_d, initial_d_exp %! %! A = [ -2.8 2.0 -1.8 %! -2.4 -2.0 0.8 %! 1.1 1.7 -1.0 ]; %! %! B = [ -0.8 0.5 0 %! 0 0.7 2.3 %! -0.3 -0.1 0.5 ]; %! %! C = [ -0.1 0 -0.3 %! 0.9 0.5 1.2 %! 0.1 -0.1 1.9 ]; %! %! D = [ -0.5 0 0 %! 0.1 0 0.3 %! -0.8 0 0 ]; %! %! x_0 = [1, 2, 3]; %! %! sysc = ss (A, B, C, D); %! %! [yc, tc, xc] = initial (sysc, x_0, 0.2, 0.1); %! initial_c = [yc, tc, xc]; %! %! sysd = c2d (sysc, 2); %! %! [yd, td, xd] = initial (sysd, x_0, 4); %! initial_d = [yd, td, xd]; %! %! ## expected values computed by the "dark side" %! %! yc_exp = [ -1.0000 5.5000 5.6000 %! -0.9872 5.0898 5.7671 %! -0.9536 4.6931 5.7598 ]; %! %! tc_exp = [ 0.0000 %! 0.1000 %! 0.2000 ]; %! %! xc_exp = [ 1.0000 2.0000 3.0000 %! 0.5937 1.6879 3.0929 %! 0.2390 1.5187 3.0988 ]; %! %! initial_c_exp = [yc_exp, tc_exp, xc_exp]; %! %! yd_exp = [ -1.0000 5.5000 5.6000 %! -0.6550 3.1673 4.2228 %! -0.5421 2.6186 3.4968 ]; %! %! td_exp = [ 0 %! 2 %! 4 ]; %! %! xd_exp = [ 1.0000 2.0000 3.0000 %! -0.4247 1.5194 2.3249 %! -0.3538 1.2540 1.9250 ]; %! %! initial_d_exp = [yd_exp, td_exp, xd_exp]; %! %!assert (initial_c, initial_c_exp, 1e-4) %!assert (initial_d, initial_d_exp, 1e-4) control-4.1.2/inst/PaxHeaders/isdetectable.m0000644000000000000000000000007415012430645016044 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/isdetectable.m0000644000175000017500000000704115012430645017235 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{bool} =} isdetectable (@var{sys}) ## @deftypefnx {Function File} {@var{bool} =} isdetectable (@var{sys}, @var{tol}) ## @deftypefnx {Function File} {@var{bool} =} isdetectable (@var{a}, @var{c}) ## @deftypefnx {Function File} {@var{bool} =} isdetectable (@var{a}, @var{c}, @var{e}) ## @deftypefnx {Function File} {@var{bool} =} isdetectable (@var{a}, @var{c}, @var{[]}, @var{tol}) ## @deftypefnx {Function File} {@var{bool} =} isdetectable (@var{a}, @var{c}, @var{e}, @var{tol}) ## @deftypefnx {Function File} {@var{bool} =} isdetectable (@var{a}, @var{c}, @var{[]}, @var{[]}, @var{dflg}) ## @deftypefnx {Function File} {@var{bool} =} isdetectable (@var{a}, @var{c}, @var{e}, @var{[]}, @var{dflg}) ## @deftypefnx {Function File} {@var{bool} =} isdetectable (@var{a}, @var{c}, @var{[]}, @var{tol}, @var{dflg}) ## @deftypefnx {Function File} {@var{bool} =} isdetectable (@var{a}, @var{c}, @var{e}, @var{tol}, @var{dflg}) ## Logical test for system detectability. ## All unstable modes must be observable or all unobservable states must be stable. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. ## @item a ## State transition matrix. ## @item c ## Measurement matrix. ## @item e ## Descriptor matrix. ## If @var{e} is empty @code{[]} or not specified, an identity matrix is assumed. ## @item tol ## Optional tolerance for stability. Default value is 0. ## @item dflg = 0 ## Matrices (@var{a}, @var{c}) are part of a continuous-time system. Default Value. ## @item dflg = 1 ## Matrices (@var{a}, @var{c}) are part of a discrete-time system. ## @end table ## ## @strong{Outputs} ## @table @var ## @item bool = 0 ## System is not detectable. ## @item bool = 1 ## System is detectable. ## @end table ## ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB01OD and TG01HD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## See @command{isstabilizable} for description of computational method. ## @seealso{isstabilizable, isstable, isctrb, isobsv} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.3 function bool = isdetectable (a, c = [], e = [], tol = [], dflg = 0) if (nargin == 0) print_usage (); elseif (isa (a, "lti")) # isdetectable (sys), isdetectable (sys, tol) if (nargin > 2) print_usage (); endif bool = isstabilizable (a.', c); # transpose is overloaded elseif (nargin < 2 || nargin > 5) print_usage (); else # isdetectable (a, c, ...) bool = isstabilizable (a.', c.', e.', tol, dflg); # arguments checked inside endif endfunction control-4.1.2/inst/PaxHeaders/isobsv.m0000644000000000000000000000007415012430645014721 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/isobsv.m0000644000175000017500000000560615012430645016117 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{bool}, @var{nobs}] =} isobsv (@var{sys}) ## @deftypefnx {Function File} {[@var{bool}, @var{nobs}] =} isobsv (@var{sys}, @var{tol}) ## @deftypefnx {Function File} {[@var{bool}, @var{nobs}] =} isobsv (@var{a}, @var{c}) ## @deftypefnx {Function File} {[@var{bool}, @var{nobs}] =} isobsv (@var{a}, @var{c}, @var{e}) ## @deftypefnx {Function File} {[@var{bool}, @var{nobs}] =} isobsv (@var{a}, @var{c}, @var{[]}, @var{tol}) ## @deftypefnx {Function File} {[@var{bool}, @var{nobs}] =} isobsv (@var{a}, @var{c}, @var{e}, @var{tol}) ## Logical check for system observability. ## For numerical reasons, @code{isobsv (sys)} ## should be used instead of @code{rank (obsv (sys))}. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. Descriptor state-space models are possible. ## @item a ## State matrix (n-by-n). ## @item c ## Measurement matrix (p-by-n). ## @item e ## Descriptor matrix (n-by-n). ## If @var{e} is empty @code{[]} or not specified, an identity matrix is assumed. ## @item tol ## Optional roundoff parameter. Default value is 0. ## @end table ## ## @strong{Outputs} ## @table @var ## @item bool = 0 ## System is not observable. ## @item bool = 1 ## System is observable. ## @item nobs ## Number of observable states. ## @end table ## ## @strong{Algorithm}@* ## Uses @uref{https://github.com/SLICOT/SLICOT-Reference, SLICOT AB01OD and TG01HD}, ## Copyright (c) 2020, SLICOT, available under the BSD 3-Clause ## (@uref{https://github.com/SLICOT/SLICOT-Reference/blob/main/LICENSE, License and Disclaimer}). ## ## @seealso{isctrb} ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.4 function [bool, nobs] = isobsv (a, c = [], e = [], tol = []) if (nargin == 0) print_usage (); elseif (isa (a, "lti")) # isobsv (sys), isobsv (sys, tol) if (nargin > 2) print_usage (); endif [bool, nobs] = isctrb (a.', c); # transpose is overloaded elseif (nargin < 2 || nargin > 4) print_usage (); else # isobsv (a, c), isobsv (a, c, e), ... [bool, nobs] = isctrb (a.', c.', e.', tol); endif endfunction control-4.1.2/inst/PaxHeaders/@iddata0000644000000000000000000000007415012430645014507 xustar0030 atime=1747595720.873132883 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/0000755000175000017500000000000015012430645015753 5ustar00lilgelilge00000000000000control-4.1.2/inst/@iddata/PaxHeaders/detrend.m0000644000000000000000000000007415012430645016367 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/detrend.m0000644000175000017500000000441115012430645017556 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{dat} =} detrend (@var{dat}) ## @deftypefnx {Function File} {@var{dat} =} detrend (@var{dat}, @var{ord}) ## Detrend outputs and inputs of dataset @var{dat} by ## removing the best fit of a polynomial of order @var{ord}. ## If @var{ord} is not specified, default value 0 is taken. ## This corresponds to removing a constant. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: April 2012 ## Version: 0.1 function dat = detrend (dat, ord = 0) if (nargin > 2) # no need to test nargin == 0, this is handled by built-in detrend print_usage (); endif if ((! is_real_scalar (ord) || fix (ord) != ord) && ! ischar (ord)) # chars are handled by built-in detrend error ("iddata: detrend: second argument must be a positve integer"); endif [n, p, m] = size (dat); dat.y = cellfun (@detrend, dat.y, {ord}, "uniformoutput", false); dat.u = cellfun (@detrend, dat.u, {ord}, "uniformoutput", false); ## if a MIMO experiment has only 1 sample, detrend works ## row-wisely instead of column-wisely ## therefore we set these experiments to zero idx = (n == 1); dat.y(idx) = zeros (1, p); dat.u(idx) = zeros (1, m); endfunction %!shared DATD, Z %! DAT = iddata ({[(1:10).', (1:2:20).'], [(10:-1:1).', (20:-2:1).']}, {[(41:50).', (46:55).'], [(61:70).', (-66:-1:-75).']}); %! DATD = detrend (DAT, "linear"); %! Z = zeros (10, 2); %!assert (DATD.y{1}, Z, 1e-10); %!assert (DATD.y{2}, Z, 1e-10); %!assert (DATD.u{1}, Z, 1e-10); %!assert (DATD.u{2}, Z, 1e-10); control-4.1.2/inst/@iddata/PaxHeaders/get.m0000644000000000000000000000007415012430645015521 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/get.m0000644000175000017500000000530315012430645016711 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} get (@var{dat}) ## @deftypefnx {Function File} {@var{value} =} get (@var{dat}, @var{'key'}) ## @deftypefnx {Function File} {[@var{val1}, @var{val2}, @dots{}] =} get (@var{dat}, @var{'key1'}, @var{'key2'}, @dots{}) ## Access key values of iddata objects. ## Type @command{get(dat)} to display a list of available keys. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: February 2012 ## Version: 0.2 function varargout = get (dat, varargin) if (nargin == 1) [keys, vals] = __iddata_keys__ (dat); nrows = numel (keys); str = strjust (strvcat (keys), "right"); str = horzcat (repmat (" ", nrows, 1), str, repmat (": ", nrows, 1), strvcat (vals)); disp (str); else if (! isa (dat, "iddata")) print_usage (); endif keys = __iddata_keys__ (dat, true); for k = 1 : (nargin-1) key = __match_key__ (varargin{k}, keys, "iddata: get"); switch (key) case {"y", "outdata", "outputdata"} val = dat.y; case {"u", "indata", "inputdata"} val = dat.u; case {"outname", "outputname"} val = dat.outname; case {"inname", "inputname"} val = dat.inname; case {"outunit", "outputunit"} val = dat.outunit; case {"inunit", "inputunit"} val = dat.inunit; case {"tsam"} val = dat.tsam; case {"timeunit"} val = dat.timeunit; case {"expname", "experimentname"} val = dat.expname; case "name" val = dat.name; case "notes" val = dat.notes; case "userdata" val = dat.userdata; case {"domain", "timedomain"} val = dat.timedomain; case {"w", "frequency", "samplinginstants"} val = dat.w; otherwise error ("iddata: get: invalid key name '%s'", varargin{k}); endswitch varargout{k} = val; endfor endif endfunctioncontrol-4.1.2/inst/@iddata/PaxHeaders/__iddata_keys__.m0000644000000000000000000000007415012430645020017 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/__iddata_keys__.m0000644000175000017500000000455215012430645021214 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {[@var{keys}, @var{vals}] =} __iddata_keys__ (@var{dat}) ## Return the list of keys as well as the assignable values for an iddata set. ## @end deftypefn ## Author: Lukas Reichlin ## Created: February 2012 ## Version: 0.2 function [keys, vals] = __iddata_keys__ (dat, aliases = false) [n, p, m, e] = size (dat); ## cell vector of iddata-specific keys keys = {"y"; "outname"; "outunit"; "u"; "inname"; "inunit"; "tsam"; "timeunit"; "expname"; "name"; "notes"; "userdata"}; ## cell vector of iddata-specific assignable values vals = {sprintf("(%dx1) cell vector of (nx%d) matrices", e, p); sprintf("(%dx1) cell vector of strings", p); sprintf("(%dx1) cell vector of strings", p); sprintf("(%dx1) cell vector of (nx%d) matrices", e, m); sprintf("(%dx1) cell vector of strings", m); sprintf("(%dx1) cell vector of strings", m); sprintf("(%dx1) cell vector of scalars", e); "string"; sprintf("(%dx1) cell vector of strings", e); "string"; "string or cell of strings"; "any data type"}; if (aliases) ka = {"outdata"; "outputdata"; "outputname"; "outputunit"; "indata"; "inputdata"; "inputname"; "inputunit"; "experimentname"; "w"; "frequency"; "samplinginstants"; "domain"; "timedomain"}; keys = [keys; ka]; endif endfunction control-4.1.2/inst/@iddata/PaxHeaders/set.m0000644000000000000000000000007415012430645015535 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/set.m0000644000175000017500000001303515012430645016726 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} set (@var{dat}) ## @deftypefnx {Function File} {} set (@var{dat}, @var{'key'}, @var{value}, @dots{}) ## @deftypefnx {Function File} {@var{dat} =} set (@var{dat}, @var{'key'}, @var{value}, @dots{}) ## Set or modify keys of iddata objects. ## If no return argument @var{dat} is specified, the modified @acronym{IDDATA} object is stored ## in input argument @var{dat}. @command{set} can handle multiple keys in one call: ## @code{set (dat, 'key1', val1, 'key2', val2, 'key3', val3)}. ## @code{set (dat)} prints a list of the object's key names. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: February 2012 ## Version: 0.4 function retdat = set (dat, varargin) if (nargin == 1) # set (dat), dat = set (dat) [keys, vals] = __iddata_keys__ (dat); nrows = numel (keys); str = strjust (strvcat (keys), "right"); str = horzcat (repmat (" ", nrows, 1), str, repmat (": ", nrows, 1), strvcat (vals)); disp (str); if (nargout != 0) # function dat = set (dat, varargin) retdat = dat; # would lead to unwanted output when using endif # set (dat) else # set (dat, 'key', val1, ...), dat = set (dat, 'key1', val1, ...) if (! isa (dat, "iddata")) print_usage (); endif if (rem (nargin-1, 2)) error ("iddata: set: keys and values must come in pairs"); endif [n, p, m, e] = size (dat); keys = __iddata_keys__ (dat, true); for k = 1 : 2 : (nargin-1) key = __match_key__ (varargin{k}, keys, "iddata: set"); val = varargin{k+1}; switch (key) case {"y", "outdata", "outputdata"} val = __adjust_iddata__ (val, dat.u); [pval, ~, eval] = __iddata_dim__ (val, dat.u); if (pval != p) error ("iddata: set: argument '%s' has %d instead of %d outputs", key, pval, p); endif if (eval != e) # iddata_dim is not sufficient if dat.u = [] error ("iddata: set: argument '%s' has %d instead of %d experiments", key, eval, e); endif if (dat.timedomain && ! is_real_matrix (val{:})) error ("iddata: set: require real-valued output signals for time domain datasets"); endif dat.y = val; case {"u", "indata", "inputdata"} [~, val] = __adjust_iddata__ (dat.y, val); [~, mval] = __iddata_dim__ (dat.y, val); if (mval != m) error ("iddata: set: argument '%s' has %d instead of %d inputs", key, mval, m); endif if (dat.timedomain && ! is_real_matrix (val{:})) error ("iddata: set: require real-valued input signals for time domain datasets"); endif dat.u = val; case {"outname", "outputname"} dat.outname = __adjust_labels__ (val, p); case {"inname", "inputname"} dat.inname = __adjust_labels__ (val, m); case {"outunit", "outputunit"} dat.outunit = __adjust_labels__ (val, p); case {"inunit", "inputunit"} dat.inunit = __adjust_labels__ (val, m); case {"timeunit"} if (ischar (val)) dat.timeunit = val; else error ("iddata: set: key 'timeunit' requires a string"); endif case {"expname", "experimentname"} dat.expname = __adjust_labels__ (val, e); case {"tsam"} dat.tsam = __adjust_iddata_tsam__ (val, e); case {"w", "frequency"} if (! iscell (val)) val = {val}; endif if (any (cellfun (@(w) ! isempty (w) && (! is_real_vector (w) || any (w < 0) ... || ! issorted (w) || w(1) > w(end) ... || length (unique (w)) != length (w)), val))) error ("iddata: set: argument '%s' must be a vector of positive real values in ascending order", key); endif dat.w = val; dat.timedomain = false; case "name" if (ischar (val)) dat.name = val; else error ("iddata: set: key 'name' requires a string"); endif case "notes" if (iscellstr (val)) dat.notes = val; elseif (ischar (val)) dat.notes = {val}; else error ("lti: set: key 'notes' requires string or cell of strings"); endif case "userdata" dat.userdata = val; otherwise error ("iddata: set: invalid key name '%s'", varargin{k}); endswitch endfor if (nargout == 0) # set (dat, 'key1', val1, ...) assignin ("caller", inputname (1), dat); else # dat = set (dat, 'key1', val1, ...) retdat = dat; endif endif endfunction control-4.1.2/inst/@iddata/PaxHeaders/subsref.m0000644000000000000000000000007415012430645016413 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/subsref.m0000644000175000017500000000530515012430645017605 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} subsref ## Subscripted reference for iddata objects. ## Used by Octave for "dat = dat(2:4, :)" or "val = dat.prop". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: February 2012 ## Version: 0.3 function a = subsref (a, s) if (numel (s) == 0) return; endif switch (s(1).type) case "()" idx = s(1).subs; if (numel (idx) > 4) error ("iddata: subsref: need four or less indices"); else a = __dat_prune__ (a, idx{:}); endif case "." fld = s(1).subs; a = get (a, fld); otherwise error ("iddata: subsref: invalid subscript type"); endswitch a = subsref (a, s(2:end)); endfunction function dat = __dat_prune__ (dat, spl_idx = ":", out_idx = ":", in_idx = ":", exp_idx = ":") out_idx = __handle_idx__ (dat.outname, out_idx, "outname"); in_idx = __handle_idx__ (dat.inname, in_idx, "inname"); exp_idx = __handle_idx__ (dat.expname, exp_idx, "expname"); dat.y = dat.y(exp_idx); dat.y = cellfun (@(y) y(spl_idx, out_idx), dat.y, "uniformoutput", false); dat.outname = dat.outname(out_idx); dat.outunit = dat.outunit(out_idx); if (! isempty (dat.u)) dat.u = dat.u(exp_idx); dat.u = cellfun (@(u) u(spl_idx, in_idx), dat.u, "uniformoutput", false); dat.inname = dat.inname(in_idx); dat.inunit = dat.inunit(in_idx); endif dat.expname = dat.expname(exp_idx); dat.tsam = dat.tsam(exp_idx); endfunction function idx = __handle_idx__ (name, idx, id) if (ischar (idx) && ! strcmp (idx, ":")) idx = {idx}; endif if (iscell (idx)) idx = cellfun (@(x) __str2idx__ (name, x, id), idx); endif endfunction function idx = __str2idx__ (name, str, id) tmp = strcmp (name, str)(:); switch (nnz (tmp)) case 1 idx = find (tmp); case 0 error ("iddata: %s '%s' not found", id, str); otherwise error ("iddata: %s '%s' is ambiguous", id, str); endswitch endfunction control-4.1.2/inst/@iddata/PaxHeaders/vertcat.m0000644000000000000000000000007415012430645016412 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/vertcat.m0000644000175000017500000000253415012430645017605 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{dat} =} vertcat (@var{dat1}, @var{dat2}, @dots{}) ## Vertical concatenation of iddata datasets. ## The samples are concatenated in the following way: ## @code{dat.y@{e@} = [dat1.y@{e@}; dat2.y@{e@}; @dots{}]} ## @code{dat.u@{e@} = [dat1.u@{e@}; dat2.u@{e@}; @dots{}]} ## where @var{e} denotes the experiment. ## The number of experiments, outputs and inputs must be equal for all datasets. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: March 2012 ## Version: 0.1 function dat = vertcat (varargin) dat = cat (1, varargin{:}); endfunction control-4.1.2/inst/@iddata/PaxHeaders/merge.m0000644000000000000000000000007415012430645016041 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/merge.m0000644000175000017500000000241115012430645017226 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{dat} =} merge (@var{dat1}, @var{dat2}, @dots{}) ## Concatenate experiments of iddata datasets. ## The experiments are concatenated in the following way: ## @code{dat.y = [dat1.y; dat2.y; @dots{}]} ## @code{dat.u = [dat1.u; dat2.u; @dots{}]} ## The number of outputs and inputs must be equal for all datasets. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: March 2012 ## Version: 0.1 function dat = merge (varargin) dat = cat (3, varargin{:}); endfunction control-4.1.2/inst/@iddata/PaxHeaders/resample.m0000644000000000000000000000007415012430645016552 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/resample.m0000644000175000017500000000567115012430645017752 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{dat} =} resample (@var{dat}, @var{p}, @var{q}) ## @deftypefnx {Function File} {@var{dat} =} resample (@var{dat}, @var{p}, @var{q}, @var{n}) ## @deftypefnx {Function File} {@var{dat} =} resample (@var{dat}, @var{p}, @var{q}, @var{h}) ## Change the sample rate of the output and input signals in dataset @var{dat} ## by a factor of @code{p/q}. This is performed using a polyphase algorithm. ## The anti-aliasing @acronym{FIR} filter can be specified as follows: ## Either by order @var{n} (scalar) with default value 0. The band edges ## are then chosen automatically. Or by impulse response @var{h} (vector). ## Requires the signal package to be installed. ## ## @strong{Algorithm}@* ## Uses functions @command{fir1} and @command{resample} ## from the signal package. ## ## @strong{References}@* ## [1] J. G. Proakis and D. G. Manolakis, ## Digital Signal Processing: Principles, Algorithms, and Applications, ## 4th ed., Prentice Hall, 2007. Chap. 6 ## ## [2] A. V. Oppenheim, R. W. Schafer and J. R. Buck, ## Discrete-time signal processing, Signal processing series, ## Prentice-Hall, 1999 ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: June 2012 ## Version: 0.3 function dat = resample (dat, p, q, n = 0) if (nargin < 3 || nargin > 4) print_usage (); endif ## requires signal package try pkg load signal; catch error ("iddata: resample: please install signal package to proceed"); end_try_catch if (is_real_scalar (n)) # fourth scalar argument n is the order of the anti-aliasing filter h = fir1 (n, 1/q); elseif (is_real_vector (n)) # fourth vector argument is the (impulse response of the) anti-aliasing filter h = n; else error ("iddata: resample: fourth argument invalid"); endif dat.y = cellfun (@resample, dat.y, {p}, {q}, {h}, "uniformoutput", false); dat.u = cellfun (@resample, dat.u, {p}, {q}, {h}, "uniformoutput", false); dat.tsam = cellfun (@sampling_time, dat.tsam, {p}, {q}, "uniformoutput", false); endfunction function tsam = sampling_time (tsam, p, q) if (issample (tsam, 1)) # unspecified sampling times (-1) are left untouched tsam = (tsam*q)/p; endif endfunction control-4.1.2/inst/@iddata/PaxHeaders/subsasgn.m0000644000000000000000000000007415012430645016567 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/subsasgn.m0000644000175000017500000000400615012430645017756 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} subsasgn ## Subscripted assignment for iddata objects. ## Used by Octave for "dat.property = value". ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: February 2012 ## Version: 0.1 function dat = subsasgn (dat, idx, val) switch (idx(1).type) case "()" # dat(...) = val if (length (idx(1).subs) == 1 && isa (val, "iddata")) # dat(x) = dat, required by cat for ... dat(idx.subs{:}) = val; # dat = cellfun (@iddata, varargin) else # dat(...) = val, general case error ("iddata: subsasgn type not implemented yet"); endif case "." # dat.y... = val if (length (idx) == 1) # dat.y = val dat = set (dat, idx.subs, val); else # dat.y(...) = val, dat.expname{3} = val key = idx(1).subs; dat = set (dat, key, subsasgn (get (dat, key), idx(2:end), val)); endif otherwise error ("iddata: subsasgn: invalid subscripted assignment type"); endswitch endfunctioncontrol-4.1.2/inst/@iddata/PaxHeaders/fft.m0000644000000000000000000000007415012430645015521 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/fft.m0000644000175000017500000000662015012430645016714 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{dat} =} fft (@var{dat}) ## @deftypefnx {Function File} {@var{dat} =} fft (@var{dat}, @var{n}) ## Transform iddata objects from time to frequency domain ## using a Fast Fourier Transform (FFT) algorithm. ## ## @strong{Inputs} ## @table @var ## @item dat ## iddata set containing signals in time-domain. ## @item n ## Length of the FFT transformations. If @var{n} does not match ## the signal length, the signals in @var{dat} are shortened or ## padded with zeros. @var{n} is a vector with as many elements ## as there are experiments in @var{dat} or a scalar with a common ## length for all experiments. ## If not specified, the signal lengths are taken as default values. ## @end table ## ## @strong{Outputs} ## @table @var ## @item dat ## iddata identification dataset in frequency-domain. ## In order to preserve signal power and noise level, ## the FFTs are normalized by dividing each transform ## by the square root of the signal length. ## The frequency values are distributed equally from 0 ## to the Nyquist frequency. The Nyquist frequency is ## only included for even signal lengths. ## @end table ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: April 2012 ## Version: 0.1 function dat = fft (dat, n = []) if (nargin > 2 || ! isa (dat, "iddata")) # no need to test nargin == 0, this is handled by built-in fft print_usage (); endif if (! dat.timedomain) return; endif [x, ~, ~, e] = size (dat); if (isempty (n)) # default case, n not specified n = num2cell (x(:)); elseif (is_real_vector (n) && length (n) == e && fix (n) == n) # individual n for each experiment n = num2cell (n(:)); elseif (is_real_scalar (n) && fix (n) == n) # common n for all experiments n = num2cell (repmat (n, e, 1)); else error ("iddata: fft: second argument invalid"); endif dat.y = cellfun (@(y, n) fft (y, n, 1)(1:fix(n/2)+1, :) / sqrt (n), dat.y, n, "uniformoutput", false); dat.u = cellfun (@(u, n) fft (u, n, 1)(1:fix(n/2)+1, :) / sqrt (n), dat.u, n, "uniformoutput", false); ## fft (x, n, dim=1) because x could be a row vector (n=1) dat.w = cellfun (@(n, tsam) (0:fix(n/2)).' * (2*pi/abs(tsam)/n), n, dat.tsam, "uniformoutput", false); ## abs(tsam) because of -1 for undefined sampling times dat.timedomain = false; endfunction %!shared DATD, Y, U %! Y = 1:10; %! U = 20:-2:1; %! W = warning ("query", "iddata:transpose"); %! warning ("off", W.identifier); %! DAT = iddata (Y, U); %! DATD = fft (DAT); %! warning (W.identifier, W.state); %!assert (DATD.y{1}, Y, 1e-10); %!assert (DATD.u{1}, U, 1e-10); control-4.1.2/inst/@iddata/PaxHeaders/size.m0000644000000000000000000000007415012430645015714 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/size.m0000644000175000017500000000657315012430645017116 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{nvec} =} size (@var{dat}) ## @deftypefnx {Function File} {@var{ndim} =} size (@var{dat}, @var{dim}) ## @deftypefnx {Function File} {[@var{n}, @var{p}, @var{m}, @var{e}] =} size (@var{dat}) ## Return dimensions of iddata set @var{dat}. ## ## @strong{Inputs} ## @table @var ## @item dat ## iddata set. ## @item dim ## If given a second argument, @command{size} will return the size of the ## corresponding dimension. ## @end table ## ## @strong{Outputs} ## @table @var ## @item nvec ## Row vector. The first element is the total number of samples (rows of dat.y and dat.u). ## The second element is the number of outputs (columns of dat.y) and the third element ## the number of inputs (columns of dat.u). The fourth element is the number of experiments. ## @item ndim ## Scalar value. The size of the dimension @var{dim}. ## @item n ## Row vector containing the number of samples of each experiment. ## @item p ## Number of outputs. ## @item m ## Number of inputs. ## @item e ## Number of experiments. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2011 ## Version: 0.1 function [x, p, m, e] = size (dat, dim = 0) if (nargin > 2) print_usage (); endif n = cellfun (@rows, dat.y).'; # number of samples p = numel (dat.outname); # number of output channels m = numel (dat.inname); # number of input channels e = numel (dat.y); # number of experiments switch (dim) case 0 # ... size (dat) switch (nargout) case 0 # size (dat) stry = stru = stre = ""; if (p != 1) stry = "s"; endif if (m != 1) stru = "s"; endif if (e != 1) stre = "s"; endif printf ("IDDATA set with [%s] samples, %d output%s, %d input%s and %d experiment%s.\n", ... num2str (n, "%d "), p, stry, m, stru, e, stre); case 1 # x = size (dat) x = [sum(n), p, m, e]; case {2, 3, 4} # [n, p, m, e] = size (dat) x = n; otherwise # more than 4 return values print_usage (); endswitch case 1 # nvec = size (dat, 1) x = n; case 2 # p = size (dat, 2) x = p; case 3 # m = size (dat, 3) x = m; case 4 # e = size (dat, 4) x = e; otherwise # invalid dimension print_usage (); endswitch endfunction control-4.1.2/inst/@iddata/PaxHeaders/nkshift.m0000644000000000000000000000007415012430645016410 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/nkshift.m0000644000175000017500000000474315012430645017607 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{dat} =} nkshift (@var{dat}, @var{nk}) ## @deftypefnx {Function File} {@var{dat} =} nkshift (@var{dat}, @var{nk}, @var{'append'}) ## Shift input channels of dataset @var{dat} according to integer @var{nk}. ## A positive value of @var{nk} means that the input channels are delayed ## @var{nk} samples. By default, both input and output signals are shortened ## by @var{nk} samples. ## If a third argument @var{'append'} is passed, the output signals are left ## untouched while @var{nk} zeros are appended to the (shortened) input signals ## such that the number of samples in @var{dat} remains constant. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: July 2012 ## Version: 0.1 function dat = nkshift (dat, nk = 0) if (nargin > 3) print_usage (); endif if (! is_real_scalar (nk)) error ("iddata: nkshift: 'nk' must be a scalar integer"); endif ## TODO: - nk per inputs ## - frequency-domain data snk = sign (nk); nk = abs (nk); if (nargin == 2) # default: shortening y and u by nk if (snk >= 0) dat.y = cellfun (@(y) y(nk+1:end, :), dat.y, "uniformoutput", false); dat.u = cellfun (@(u) u(1:end-nk, :), dat.u, "uniformoutput", false); else dat.y = cellfun (@(y) y(1:end-nk, :), dat.y, "uniformoutput", false); dat.u = cellfun (@(u) u(nk+1:end, :), dat.u, "uniformoutput", false); endif else # append: keep y, padding u with nk zeros [~, ~, m] = size (dat); if (snk >= 0) dat.u = cellfun (@(u) [zeros(nk, m), u(1:end-nk, :)], dat.u, "uniformoutput", false); else dat.u = cellfun (@(u) [u(nk+1:end, :), zeros(nk, m)], dat.u, "uniformoutput", false); endif endif endfunction control-4.1.2/inst/@iddata/PaxHeaders/end.m0000644000000000000000000000007415012430645015510 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/end.m0000644000175000017500000000311615012430645016700 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Overloaded Operator} {} end ## End indexing for @acronym{IDDATA} objects. ## Used by Octave for "dat(1:end)". ## @end deftypefn ## Author: Lukas Reichlin ## Created: December 2013 ## Version: 0.1 function ret = end (dat, k, n) if (n > 4) error ("iddata: end: require at most 4 indices in the expression"); endif switch (k) case 1 # selecting samples ret = size (dat, 1); if (numel (ret) != 1 && ! isequal (num2cell (ret){:})) error ("iddata: end: for multi-experiment datasets, require equal number of samples when selecting samples with 'end'"); endif ret = ret(1); case {2, 3, 4} # selecting outputs, inputs or experiments ret = size (dat, k); otherwise error ("iddata: end: invalid expression index k = %d", k); endswitch endfunction control-4.1.2/inst/@iddata/PaxHeaders/display.m0000644000000000000000000000007415012430645016407 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/display.m0000644000175000017500000000574515012430645017611 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Display routine for iddata objects. ## Author: Lukas Reichlin ## Created: February 2012 ## Version: 0.1 function display (dat) datname = inputname (1); [outname, p] = __labels__ (dat.outname, "y"); [inname, m] = __labels__ (dat.inname, "u"); [expname, e] = __labels__ (dat.expname, "exp"); [n, p, m, e] = size (dat); if (dat.timedomain) domain = "Time"; sf = "Samples"; else domain = "Frequency"; sf = "Frequencies"; endif str = [domain, " domain dataset '", datname, "' containing ", num2str(sum(n)), " ", lower(sf)]; disp (""); disp (str); disp (""); disp (__horzcat__ (__col2str__ (expname, "Experiment"), ... __vec2str__ (n, sf), ... __vec2str__ (cell2mat (dat.tsam), "Sampling Interval"))); disp (""); disp (__horzcat__ (__col2str__ (outname, "Outputs"), ... __col2str__ (dat.outunit, "Unit (if specified)"))); disp (""); disp (__horzcat__ (__col2str__ (inname, "Inputs"), ... __col2str__ (dat.inunit, "Unit (if specified)"))); disp (""); endfunction function str = __horzcat__ (col, varargin) len = rows (col); sp2 = repmat (" ", len, 1); sp4 = repmat (" ", len, 1); str = [sp2, col]; for k = 2 : nargin str = [str, sp4, varargin{k-1}]; endfor endfunction function str = __col2str__ (col, title) len = rows (col); str = strjust (strvcat (col), "left"); if (columns (str) == 0) str = repmat (" ", len, 1); endif line = repmat ("-", 1, max (columns (str), columns (title))); str = strvcat (title, line, str); endfunction function str = __vec2str__ (vec, title) vec = vec(:); tmp = isfinite (vec); tmp = abs (vec(tmp & vec != 0)); if (isempty (tmp) || min (tmp) < 1e-3 || max (tmp) > 1e4) str = arrayfun (@(x) sprintf ("%.3e", x), vec, "uniformoutput", false); elseif (all (floor (tmp) == tmp)) str = arrayfun (@(x) sprintf ("%d", x), vec, "uniformoutput", false); else str = arrayfun (@(x) sprintf ("%.4f", x), vec, "uniformoutput", false); endif str = strjust (char (str), "right"); line = repmat ("-", 1, max (columns (str), columns (title))); %str = strvcat (title, str) str = strvcat (title, line, str); endfunction control-4.1.2/inst/@iddata/PaxHeaders/filter.m0000644000000000000000000000007415012430645016227 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/filter.m0000644000175000017500000000716515012430645017427 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{dat} =} filter (@var{dat}, @var{sys}) ## @deftypefnx {Function File} {@var{dat} =} filter (@var{dat}, @var{b}, @var{a}) ## Filter output and input signals of dataset @var{dat}. ## The filter is specified either by @acronym{LTI} system @var{sys} ## or by transfer function polynomials @var{b} and @var{a} as described ## in the help text of Octave's built-in filter function. Type @code{help filter} ## for more information. ## ## @strong{Inputs} ## @table @var ## @item dat ## iddata identification dataset containing signals in time-domain. ## @item sys ## @acronym{LTI} object containing the discrete-time filter. ## @item b ## Numerator polynomial of the discrete-time filter. ## Must be a row vector containing the coefficients ## of the polynomial in ascending powers of z^-1. ## @item a ## Denominator polynomial of the discrete-time filter. ## Must be a row vector containing the coefficients ## of the polynomial in ascending powers of z^-1. ## @end table ## ## @strong{Outputs} ## @table @var ## @item dat ## iddata identification dataset with filtered ## output and input signals. ## @end table ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: August 2012 ## Version: 0.1 function dat = filter (dat, b, a = [], si = []) if (nargin < 2 || nargin > 4) print_usage (); endif if (! isa (dat, "iddata")) # there's at least one iddata set, but not as the first argument error ("iddata: filter: first argument must be an iddata set"); endif if (! dat.timedomain) error ("iddata: filter: require iddata set in time-domain"); endif if (isa (b, "lti")) # filter (dat, sys) if (nargin > 3) # filter (dat, sys, si) has at most 3 inputs print_usage (); endif if (! issiso (b)) error ("iddata: filter: second argument must be a SISO LTI system"); endif si = a; # filter (dat, sys, si) if (isct (b)) # sys is continuous-time b = c2d (b, dat.tsam{1}); # does this discretization/tsam make sense? endif [b, a] = filtdata (b, "vector"); # convert LTI system to transfer function elseif (nargin < 3) print_usage (); endif ## use Octave's filter function for each experiment ## the fifth argument '1' specifies the dimension in case of datasets with only 1 sample dat.y = cellfun (@(y) filter (b, a, y, si, 1), dat.y, "uniformoutput", false); dat.u = cellfun (@(u) filter (b, a, u, si, 1), dat.u, "uniformoutput", false); endfunction ## TODO: adapt test %!shared DATD, Z %! DAT = iddata ({[(1:10).', (1:2:20).'], [(10:-1:1).', (20:-2:1).']}, {[(41:50).', (46:55).'], [(61:70).', (-66:-1:-75).']}); %! DATD = detrend (DAT, "linear"); %! Z = zeros (10, 2); %!assert (DATD.y{1}, Z, 1e-10); %!assert (DATD.y{2}, Z, 1e-10); %!assert (DATD.u{1}, Z, 1e-10); %!assert (DATD.u{2}, Z, 1e-10); control-4.1.2/inst/@iddata/PaxHeaders/plot.m0000644000000000000000000000007415012430645015720 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/plot.m0000644000175000017500000000712215012430645017111 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} plot (@var{dat}) ## @deftypefnx {Function File} {} plot (@var{dat}, @var{exp}) ## Plot signals of iddata identification datasets on the screen. ## The signals are plotted experiment-wise, either in time- or ## frequency-domain. For multi-experiment datasets, ## press any key to switch to the next experiment. ## If the plot of a single experiment should be saved by the ## @command{print} command, use @code{plot(dat,exp)}, ## where @var{exp} denotes the desired experiment. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: February 2012 ## Version: 0.2 function plot (dat, exp = ":") if (nargin > 2) # nargin == 0 is handled by built-in plot print_usage (); endif if (nargin == 2 && ! is_real_vector (exp)) error ("iddata: plot: second argument must be a vector of indices"); endif expname = __labels__ (dat.expname, "exp"); expname = expname(exp); idx = substruct ("()", {":", ":", ":", exp}); dat = subsref (dat, idx); [n, p, m, e] = size (dat); if (dat.timedomain) if (m == 0) # time series for k = 1 : e if (k > 1) pause endif plot (dat.y{k}) title (expname{k}) legend (__labels__ (dat.outname, "y"){:}) xlabel ("Time") ylabel ("Output Signal") endfor else # inputs present for k = 1 : e if (k > 1) pause endif subplot (2, 1, 1) plot (dat.y{k}) title (expname{k}) legend (__labels__ (dat.outname, "y"){:}) ylabel ("Output Signal") subplot (2, 1, 2) stairs (dat.u{k}) legend (__labels__ (dat.inname, "u"){:}) xlabel ("Time") ylabel ("Input Signal") endfor endif else # frequency domain if (m == 0) # time series for k = 1 : e if (k > 1) pause endif bar (dat.w{k}, 20*log10 (abs (dat.y{k}))) xlim ([dat.w{k}(1), dat.w{k}(end)]) title (expname{k}) legend (__labels__ (dat.outname, "y"){:}) xlabel ("Frequency") ylabel ("Output Magnitude [dB]") endfor else # inputs present for k = 1 : e if (k > 1) pause endif subplot (2, 1, 1) bar (dat.w{k}, 20*log10 (abs (dat.y{k}))) xlim ([dat.w{k}(1), dat.w{k}(end)]) title (expname{k}) legend (__labels__ (dat.outname, "y"){:}) ylabel ("Output Magnitude [dB]") subplot (2, 1, 2) bar (dat.w{k}, 20*log10(abs (dat.u{k}))) xlim ([dat.w{k}(1), dat.w{k}(end)]) legend (__labels__ (dat.inname, "u"){:}) xlabel ("Frequency") ylabel ("Input Magnitude [dB]") endfor endif endif ## TODO: think about the 20*log10 and the bars in general endfunction control-4.1.2/inst/@iddata/PaxHeaders/diff.m0000644000000000000000000000007415012430645015652 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/diff.m0000644000175000017500000000263215012430645017044 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{dat} =} diff (@var{dat}) ## @deftypefnx {Function File} {@var{dat} =} diff (@var{dat}, @var{k}) ## Return @var{k}-th difference of outputs and inputs of dataset @var{dat}. ## If @var{k} is not specified, default value 1 is taken. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: March 2012 ## Version: 0.1 function dat = diff (dat, k = 1) if (nargin > 2) # no need to test nargin == 0, this is handled by built-in diff print_usage (); endif dat.y = cellfun (@diff, dat.y, {k}, {1}, "uniformoutput", false); dat.u = cellfun (@diff, dat.u, {k}, {1}, "uniformoutput", false); endfunction control-4.1.2/inst/@iddata/PaxHeaders/iddata.m0000644000000000000000000000007415012430645016170 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/iddata.m0000644000175000017500000001171015012430645017357 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn{Function File} {@var{dat} =} iddata (@var{y}) ## @deftypefnx{Function File} {@var{dat} =} iddata (@var{y}, @var{u}) ## @deftypefnx{Function File} {@var{dat} =} iddata (@var{y}, @var{u}, @var{tsam}, @dots{}) ## @deftypefnx{Function File} {@var{dat} =} iddata (@var{y}, @var{u}, @var{[]}, @dots{}) ## Create identification dataset of output and input signals. ## ## @strong{Inputs} ## @table @var ## @item y ## Real matrix containing the output signal in time-domain. ## For a system with @var{p} outputs and @var{n} samples, ## @var{y} is a n-by-p matrix. ## For data from multiple experiments, @var{y} becomes a ## e-by-1 or 1-by-e cell vector of n(i)-by-p matrices, ## where @var{e} denotes the number of experiments ## and n(i) the individual number of samples for each experiment. ## @item u ## Real matrix containing the input signal in time-domain. ## For a system with @var{m} inputs and @var{n} samples, ## @var{u} is a n-by-m matrix. ## For data from multiple experiments, @var{u} becomes a ## e-by-1 or 1-by-e cell vector of n(i)-by-m matrices, ## where @var{e} denotes the number of experiments ## and n(i) the individual number of samples for each experiment. ## If @var{u} is not specified or an empty element @code{[]} is passed, ## @var{dat} becomes a time series dataset. ## @item tsam ## Sampling time. If not specified, default value -1 (unspecified) is taken. ## For multi-experiment data, @var{tsam} becomes a ## e-by-1 or 1-by-e cell vector containing individual ## sampling times for each experiment. If a scalar @var{tsam} ## is provided, then all experiments have the same sampling time. ## @item @dots{} ## Optional pairs of properties and values. ## @end table ## ## @strong{Outputs} ## @table @var ## @item dat ## iddata identification dataset. ## @end table ## ## @strong{Option Keys and Values} ## @table @var ## @item 'expname' ## The name of the experiments in @var{dat}. ## Cell vector of length e containing strings. ## Default names are @code{@{'exp1', 'exp2', ...@}} ## ## @item 'y' ## Output signals. See 'Inputs' for details. ## ## @item 'outname' ## The name of the output channels in @var{dat}. ## Cell vector of length p containing strings. ## Default names are @code{@{'y1', 'y2', ...@}} ## ## @item 'outunit' ## The units of the output channels in @var{dat}. ## Cell vector of length p containing strings. ## ## @item 'u' ## Input signals. See 'Inputs' for details. ## ## @item 'inname' ## The name of the input channels in @var{dat}. ## Cell vector of length m containing strings. ## Default names are @code{@{'u1', 'u2', ...@}} ## ## @item 'inunit' ## The units of the input channels in @var{dat}. ## Cell vector of length m containing strings. ## ## @item 'tsam' ## Sampling time. See 'Inputs' for details. ## ## @item 'timeunit' ## The units of the sampling times in @var{dat}. ## Cell vector of length e containing strings. ## ## @item 'name' ## String containing the name of the dataset. ## ## @item 'notes' ## String or cell of string containing comments. ## ## @item 'userdata' ## Any data type. ## @end table ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2011 ## Version: 0.1 function dat = iddata (y = {}, u = {}, tsam = {}, varargin) if (nargin == 1 && isa (y, "iddata")) dat = y; return; elseif (nargin < 1) print_usage (); endif [y, u] = __adjust_iddata__ (y, u); [p, m, e] = __iddata_dim__ (y, u); tsam = __adjust_iddata_tsam__ (tsam, e); outname = repmat ({""}, p, 1); inname = repmat ({""}, m, 1); expname = repmat ({""}, e, 1); dat = struct ("y", {y}, "outname", {outname}, "outunit", {outname}, "u", {u}, "inname", {inname}, "inunit", {inname}, "tsam", {tsam}, "timeunit", {""}, "timedomain", true, "w", {{}}, "expname", {expname}, "name", "", "notes", {{}}, "userdata", []); dat = class (dat, "iddata"); if (nargin > 3) dat = set (dat, varargin{:}); endif if (dat.timedomain && ! is_real_matrix (dat.y{:}, dat.u{:})) error ("iddata: require real-valued input and output signals for time domain datasets"); endif endfunction %!error (iddata); %!error (iddata ((1:10).', (1:11).')); %!warning (iddata (1:10)); %!warning (iddata (1:10, 1:10)); control-4.1.2/inst/@iddata/PaxHeaders/cat.m0000644000000000000000000000007415012430645015511 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/cat.m0000644000175000017500000001602115012430645016700 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{dat} =} cat (@var{dim}, @var{dat1}, @var{dat2}, @dots{}) ## Concatenate iddata sets along dimension @var{dim}. ## ## @strong{Inputs} ## @table @var ## @item dim ## Dimension along which the concatenation takes place. ## @table @var ## @item 1 ## Concatenate samples. ## The samples are concatenated in the following way: ## @code{dat.y@{e@} = [dat1.y@{e@}; dat2.y@{e@}; @dots{}]} ## @code{dat.u@{e@} = [dat1.u@{e@}; dat2.u@{e@}; @dots{}]} ## where @var{e} denotes the experiment. ## The number of experiments, outputs and inputs must be equal for all datasets. ## Equivalent to @command{vertcat}. ## ## @item 2 ## Concatenate inputs and outputs. ## The outputs and inputs are concatenated in the following way: ## @code{dat.y@{e@} = [dat1.y@{e@}, dat2.y@{e@}, @dots{}]} ## @code{dat.u@{e@} = [dat1.u@{e@}, dat2.u@{e@}, @dots{}]} ## where @var{e} denotes the experiment. ## The number of experiments and samples must be equal for all datasets. ## Equivalent to @command{horzcat}. ## ## @item 3 ## Concatenate experiments. ## The experiments are concatenated in the following way: ## @code{dat.y = [dat1.y; dat2.y; @dots{}]} ## @code{dat.u = [dat1.u; dat2.u; @dots{}]} ## The number of outputs and inputs must be equal for all datasets. ## Equivalent to @command{merge}. ## @end table ## ## @item dat1, dat2, @dots{} ## iddata sets to be concatenated. ## @end table ## ## @strong{Outputs} ## @table @var ## @item dat ## Concatenated iddata set. ## @end table ## ## @seealso{horzcat, merge, vertcat} ## @end deftypefn ## Author: Lukas Reichlin ## Created: March 2012 ## Version: 0.1 function dat = cat (dim, varargin) ## I think this code is pretty elegant because it works for ## any number of arguments and without a single for-loop :-) ## if this overloaded cat method is called, it is guaranteed that ## * nargin > 0 ## * at least one argument is an iddata object if (! is_real_scalar (dim)) print_usage (); endif ## store all datasets in a single struct 'tmp' ## tmp is not a valid iddata set anymore, ## but it doesn't matter, we want just a ## temporary struct containing all the data tmp = cellfun (@iddata, varargin); [n, p, m, e] = cellfun (@size, varargin, "uniformoutput", false); ## TODO: dat = iddata (ones (100, 3)); ## dat = cat (1, dat, zeros (4, 3), dat) ## default values for metadata ## some of them are overwritten in the switch statement below tsam = tmp(1).tsam; expname = tmp(1).expname; outname = tmp(1).outname; outunit = tmp(1).outunit; inname = tmp(1).inname; inunit = tmp(1).inunit; check_domain (tmp, e); switch (dim) case 1 # vertcat - catenate samples check_experiments (tmp, e); check_outputs (tmp, p); check_inputs (tmp, m); y = cellfun (@vertcat, tmp.y, "uniformoutput", false); u = cellfun (@vertcat, tmp.u, "uniformoutput", false); ## note that this also works for time series (u = {}) case 2 # horzcat - catenate channels check_experiments (tmp, e); check_samples (n); y = cellfun (@horzcat, tmp.y, "uniformoutput", false); u = cellfun (@horzcat, tmp.u, "uniformoutput", false); outname = vertcat (tmp.outname); outunit = vertcat (tmp.outunit); inname = vertcat (tmp.inname); inunit = vertcat (tmp.inunit); case 3 # merge - catenate experiments check_outputs (tmp, p); check_inputs (tmp, m); y = vertcat (tmp.y); u = vertcat (tmp.u); tsam = vertcat (tmp.tsam); expname = vertcat (tmp.expname); otherwise error ("iddata: cat: '%d' is an invalid dimension", dim); endswitch dat = iddata (y, u, tsam); ## copy metadata dat.expname = expname; dat.outname = outname; dat.outunit = outunit; dat.inname = inname; dat.inunit = inunit; % TODO: handle w endfunction function check_experiments (tmp, e) if (numel (e) > 1 && ! isequal (e{:})) # isequal doesn't work with less than 2 arguments error ("iddata: cat: number of experiments don't match [%s]", ... num2str (cell2mat (e), "%d ")); endif if (! compare_strings (tmp.expname)) warning ("iddata: cat: experiment names don't match\n") endif if (numel (e) > 1 && ! isequal (tmp.tsam)) warning ("iddata: cat: sampling times don't match\n"); endif endfunction function check_outputs (tmp, p) if (numel (p) > 1 && ! isequal (p{:})) error ("iddata: cat: number of outputs don't match [%s]", ... num2str (cell2mat (p), "%d ")); endif if (! compare_strings (tmp.outname)) warning ("iddata: cat: output names don't match\n") endif if (! compare_strings (tmp.outunit)) warning ("iddata: cat: output units don't match\n") endif endfunction function check_inputs (tmp, m) if (numel (m) > 1 && ! isequal (m{:})) error ("iddata: cat: number of inputs don't match [%s]", ... num2str (cell2mat (m), "%d ")); endif if (! compare_strings (tmp.inname)) warning ("iddata: cat: input names don't match\n") endif if (! compare_strings (tmp.inunit)) warning ("iddata: cat: input units don't match\n") endif endfunction function check_samples (n) if (numel (n) > 1 && ! isequal (n{:})) error ("iddata: cat: number of samples don't match %s", ... mat2str (vertcat (n{:}), 10)); endif endfunction function check_domain (tmp, e) if (numel (e) > 1 && ! isequal (tmp.timedomain)) # isequal doesn't work with less than 2 arguments error ("iddata: cat: can't mix time- and frequency-domain datasets"); endif endfunction ## kind of strcmp for more than two arguments ## return true if all cells of strings are equal ## and false otherwise function bool = compare_strings (str, varargin) if (nargin > 1) ## compare n-th string of first cell with n-th string of remaining cells tmp = cellfun (@strcmp, {str}, varargin, "uniformoutput", false); ## check whether all strings of each pair are equal tmp = cellfun (@all, tmp); ## check whether all pairs are equal bool = all (tmp); else ## one or no cell at all is always equal to itself bool = true; endif endfunction %!error (cat (1, iddata (1, 1), iddata ({2, 3}, {2, 3}))); control-4.1.2/inst/@iddata/PaxHeaders/ifft.m0000644000000000000000000000007415012430645015672 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/ifft.m0000644000175000017500000000505315012430645017064 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{dat} =} ifft (@var{dat}) ## Transform iddata objects from frequency to time domain. ## ## @strong{Inputs} ## @table @var ## @item dat ## iddata set containing signals in frequency domain. ## The frequency values must be distributed equally from 0 ## to the Nyquist frequency. The Nyquist frequency is ## only included for even signal lengths. ## @end table ## ## @strong{Outputs} ## @table @var ## @item dat ## iddata identification dataset in time domain. ## In order to preserve signal power and noise level, ## the FFTs are normalized by multiplying each transform ## by the square root of the signal length. ## @end table ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: April 2012 ## Version: 0.2 function dat = ifft (dat) if (nargin > 1) # no need to test nargin == 0, this is handled by built-in ifft print_usage (); endif if (dat.timedomain) # dat is always an iddata set, otherwise built-in ifft would be called return; endif if (any (cellfun (@(w) w(1) >= eps, dat.w))) error ("iddata: ifft: first frequency must be zero"); endif if (any (cellfun (@(w) any (abs (diff (w, 2)) > 1e-4*w(2:end-1)), dat.w))) error ("iddata: ifft: require linearly spaced frequency vectors"); endif [x, ~, ~, e] = size (dat); x = x(:); n = num2cell (x); nconj = num2cell (x - rem (x, 2)); dat.y = cellfun (@(y, n, nconj) real (ifft ([y; conj(y(nconj:-1:2, :))], [], 1)) * sqrt (n+nconj), dat.y, n, nconj, "uniformoutput", false); dat.u = cellfun (@(u, n, nconj) real (ifft ([u; conj(u(nconj:-1:2, :))], [], 1)) * sqrt (n+nconj), dat.u, n, nconj, "uniformoutput", false); ## ifft (x, n, dim=1) because x could be a row vector (n=1) dat.w = {}; % dat.w = repmat ({[]}, e, 1); ??? dat.timedomain = true; endfunction control-4.1.2/inst/@iddata/PaxHeaders/horzcat.m0000644000000000000000000000007415012430645016414 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/inst/@iddata/horzcat.m0000644000175000017500000000254415012430645017610 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{dat} =} horzcat (@var{dat1}, @var{dat2}, @dots{}) ## Horizontal concatenation of iddata datasets. ## ## The outputs and inputs are concatenated in the following way: ## @code{dat.y@{e@} = [dat1.y@{e@}, dat2.y@{e@}, @dots{}]} ## @code{dat.u@{e@} = [dat1.u@{e@}, dat2.u@{e@}, @dots{}]} ## where @var{e} denotes the experiment. ## The number of experiments and samples must be equal for all datasets. ## ## @end deftypefn ## Author: Lukas Reichlin ## Created: March 2012 ## Version: 0.1 function dat = horzcat (varargin) dat = cat (2, varargin{:}); endfunction control-4.1.2/inst/PaxHeaders/__adjust_iddata_tsam__.m0000644000000000000000000000007415012430645020034 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/__adjust_iddata_tsam__.m0000644000175000017500000000302015012430645021216 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## Check whether tsam is a e-by-1 cell array of valid sampling times. ## If not, it tries to convert tsam accordingly. ## Empty tsam are filled with default value -1. ## Author: Lukas Reichlin ## Created: February 2012 ## Version: 0.1 function tsam = __adjust_iddata_tsam__ (tsam, e) if (isempty (tsam)) tsam = num2cell (-ones (e, 1)); elseif (iscell (tsam)) tsam = reshape (tsam, [], 1); else tsam = {tsam}; endif tmp = cellfun (@issample, tsam, {-1}); if (any (! tmp)) error ("iddata: invalid sampling time"); endif nt = numel (tsam); if (nt == 1 && e > 1) tsam = repmat (tsam, e, 1); elseif (nt != e) error ("iddata: there are %d experiments, but only %d sampling times", ... e, nt); endif endfunction control-4.1.2/inst/PaxHeaders/bodemag.m0000644000000000000000000000007415012430645015012 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/bodemag.m0000644000175000017500000000646115012430645016210 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} bodemag (@var{sys}) ## @deftypefnx {Function File} {} bodemag (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}) ## @deftypefnx {Function File} {} bodemag (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}, @var{w}) ## @deftypefnx {Function File} {} bodemag (@var{sys1}, @var{'style1'}, @dots{}, @var{sysN}, @var{'styleN'}) ## @deftypefnx {Function File} {[@var{mag}, @var{w}] =} bodemag (@var{sys}) ## @deftypefnx {Function File} {[@var{mag}, @var{w}] =} bodemag (@var{sys}, @var{w}) ## Bode magnitude diagram of frequency response. If no output arguments are given, ## the response is printed on the screen. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. Must be a single-input and single-output (SISO) system. ## @item w ## Optional vector of frequency values. If @var{w} is not specified, ## it is calculated by the zeros and poles of the system. ## Alternatively, the cell @code{@{wmin, wmax@}} specifies a frequency range, ## where @var{wmin} and @var{wmax} denote minimum and maximum frequencies ## in rad/s. ## @item 'style' ## Line style and color, e.g. 'r' for a solid red line or '-.k' for a dash-dotted ## black line. See @command{help plot} for details. ## @end table ## ## @strong{Outputs} ## @table @var ## @item mag ## Vector of magnitude. Has length of frequency vector @var{w}. ## @item w ## Vector of frequency values used. ## @end table ## ## @seealso{bode, nichols, nyquist, sigma} ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 1.0 function [mag_r, w_r] = bodemag (varargin) if (nargin == 0) print_usage (); endif [H, w, sty, sys_idx] = __frequency_response__ ("bodemag", varargin, nargout); numsys = length (sys_idx); H = cellfun (@reshape, H, {[]}, {1}, "uniformoutput", false); mag = cellfun (@abs, H, "uniformoutput", false); if (! nargout) ## get system names and create the legend leg = cell (1, numsys); for k = 1:numsys leg{k} = inputname (sys_idx(k)); endfor ## plot mag_db = cellfun (@mag2db, mag, "uniformoutput", false); mag_args = horzcat (cellfun (@horzcat, w, mag_db, sty, "uniformoutput", false){:}); semilogx (mag_args{:}) axis ("tight") ylim (__axis_margin__ (ylim)) grid ("on") title ("Bode Magnitude Diagram") xlabel ("Frequency [rad/s]") ylabel ("Magnitude [dB]") legend (leg) else ## no plotting, assign values to the output parameters mag_r = mag{1}; w_r = w{1}; endif endfunction %!demo %! s = tf('s'); %! g = 1/(2*s^2+3*s+4); %! bodemag(g); control-4.1.2/inst/PaxHeaders/WestlandLynx.m0000644000000000000000000000007415012430645016050 xustar0030 atime=1747595719.941099231 30 ctime=1747595720.873132883 control-4.1.2/inst/WestlandLynx.m0000644000175000017500000001052315012430645017240 0ustar00lilgelilge00000000000000## -*- 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 [rad] ## roll attitude phi [rad] ## roll rate (body-axis) p [rad/s] ## pitch rate (body-axis) q [rad/s] ## yaw rate xi [rad/s] ## forward velocity v_x [ft/s] ## lateral velocity v_y [ft/s] ## vertical velocity v_z [ft/s] ## ## OUTPUTS ## heave velocity H_dot [ft/s] ## pitch attitude theta [rad] ## roll attitude phi [rad] ## heading rate psi_dot [rad/s] ## roll rate p [rad/s] ## pitch rate q [rad/s] ## @end group ## @end example ## ## @strong{References}@* ## [1] Skogestad, S. and Postlethwaite I. (2005) ## @cite{Multivariable Feedback Control: Analysis and Design: ## Second Edition}. Wiley. ## @url{http://www.nt.ntnu.no/users/skoge/book/2nd_edition/matlab_m/matfiles.html} ## ## @end deftypefn ## Author: Lukas Reichlin ## 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 rotor collective", "longitudinal cyclic", "lateral cyclic", "tail rotor collective"}; 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 control-4.1.2/inst/PaxHeaders/nyquist.m0000644000000000000000000000007415012430645015130 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/nyquist.m0000644000175000017500000001002115012430645016311 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {} nyquist (@var{sys}) ## @deftypefnx {Function File} {} nyquist (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}) ## @deftypefnx {Function File} {} nyquist (@var{sys1}, @var{sys2}, @dots{}, @var{sysN}, @var{w}) ## @deftypefnx {Function File} {} nyquist (@var{sys1}, @var{'style1'}, @dots{}, @var{sysN}, @var{'styleN'}) ## @deftypefnx {Function File} {[@var{re}, @var{im}, @var{w}] =} nyquist (@var{sys}) ## @deftypefnx {Function File} {[@var{re}, @var{im}, @var{w}] =} nyquist (@var{sys}, @var{w}) ## Nyquist diagram of frequency response. If no output arguments are given, ## the response is printed on the screen. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} system. Must be a single-input and single-output (SISO) system. ## @item w ## Optional vector of frequency values. If @var{w} is not specified, ## it is calculated by the zeros and poles of the system. ## Alternatively, the cell @code{@{wmin, wmax@}} specifies a frequency range, ## where @var{wmin} and @var{wmax} denote minimum and maximum frequencies ## in rad/s. ## @item 'style' ## Line style and color, e.g. 'r' for a solid red line or '-.k' for a dash-dotted ## black line. See @command{help plot} for details. ## @end table ## ## @strong{Outputs} ## @table @var ## @item re ## Vector of real parts. Has length of frequency vector @var{w}. ## @item im ## Vector of imaginary parts. Has length of frequency vector @var{w}. ## @item w ## Vector of frequency values used. ## @end table ## ## @seealso{bode, nichols, sigma} ## @end deftypefn ## Author: Lukas Reichlin ## Created: November 2009 ## Version: 1.0 function [re_r, im_r, w_r] = nyquist (varargin) if (nargin == 0) print_usage (); endif [H, w, sty, sys_idx] = __frequency_response__ ("nyquist", varargin, nargout); numsys = length (sys_idx); H = cellfun (@reshape, H, {[]}, {1}, "uniformoutput", false); re = cellfun (@real, H, "uniformoutput", false); im = cellfun (@imag, H, "uniformoutput", false); if (! nargout) ## get system names and create the legend leg = cell (1, numsys); for k = 1:numsys leg{k} = inputname (sys_idx(k)); endfor ## plot len = numel (H); colororder = get (gca, "colororder"); rc = rows (colororder); def_pos = arrayfun (@(k) {"-", "color", colororder(1+rem (k-1, rc), :)}, 1:len, "uniformoutput", false); def_neg = arrayfun (@(k) {"-.", "color", colororder(1+rem (k-1, rc), :)}, 1:len, "uniformoutput", false); idx = cellfun (@isempty, sty); sty_pos = sty_neg = sty; sty_pos(idx) = def_pos(idx); sty_neg(idx) = def_neg(idx); imn = cellfun (@uminus, im, "uniformoutput", false); pos_args = horzcat (cellfun (@horzcat, re, im, sty_pos, "uniformoutput", false){:}); neg_args = horzcat (cellfun (@horzcat, re, imn, sty_neg, "uniformoutput", false){:}); h = plot (pos_args{:}, neg_args{:},-1,0,'r+'); axis ("tight") xlim (__axis_margin__ (xlim)) ylim (__axis_margin__ (ylim)) grid ("on") title ("Nyquist Diagram") xlabel ("Real Axis") ylabel ("Imaginary Axis") legend (h(1:len), leg) else ## no plotting, assign values to the output parameters re_r = re{1}; im_r = im{1}; w_r = w{1}; endif endfunction %!demo %! s = tf('s'); %! g = 1/(2*s^2+3*s+4); %! nyquist(g); control-4.1.2/inst/PaxHeaders/obsv.m0000644000000000000000000000007415012430645014365 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/obsv.m0000644000175000017500000000416715012430645015564 0ustar00lilgelilge00000000000000## Copyright (C) 2009-2016 Lukas F. Reichlin ## Copyright (C) 2009 Luca Favatella ## ## 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 LTI Syncope. If not, see . ## -*- texinfo -*- ## @deftypefn {Function File} {@var{ob} =} obsv (@var{sys}) ## @deftypefnx {Function File} {@var{ob} =} obsv (@var{a}, @var{c}) ## Return observability matrix. ## ## @strong{Inputs} ## @table @var ## @item sys ## @acronym{LTI} model. ## @item a ## State matrix (n-by-n). ## @item c ## Measurement matrix (p-by-n). ## @end table ## ## @strong{Outputs} ## @table @var ## @item ob ## Observability matrix. ## @end table ## ## @strong{Equation} ## @iftex ## @tex ## $$ O_b = \\left[ \\matrix{ C \\cr ## CA \\cr ## CA^2 \\cr ## \\vdots \\cr ## CA^{n-1} } \\right ] $$ ## @end tex ## @end iftex ## @ifnottex ## @example ## @group ## | C | ## | CA | ## Ob = | CA^2 | ## | ... | ## | CA^(n-1) | ## @end group ## @end example ## @end ifnottex ## @end deftypefn ## Author: Lukas Reichlin ## Created: October 2009 ## Version: 0.2 function ob = obsv (a, c) if (nargin == 1) # obsv (sys) ob = ctrb (a.').'; # transpose is overloaded for lti models elseif (nargin == 2) # obsv (a, c) ob = ctrb (a.', c.').'; # size checked inside else print_usage (); endif endfunction %!assert (obsv ([1, 0; 0, -0.5], [8, 8]), [8, 8; 8, -4]); control-4.1.2/inst/PaxHeaders/optiPIDfun.m0000644000000000000000000000007415012430645015435 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/inst/optiPIDfun.m0000644000175000017500000000310315012430645016621 0ustar00lilgelilge00000000000000% =============================================================================== % optiPIDfun Lukas Reichlin July 2009 % =============================================================================== % Objective Function % Reference: Guzzella, L. (2007) Analysis and Synthesis of SISO Control Systems. % vdf Hochschulverlag, Zurich % =============================================================================== function J = optiPIDfun (C_par) % Global Variables global P t dt mu_1 mu_2 mu_3 % Function Argument -> Controller Parameters kp = C_par(1); Ti = C_par(2); Td = C_par(3); % PID Controller with Roll-Off C = optiPIDctrl (kp, Ti, Td); % Open Loop L = P * C; % Sum Block: e = r - y SUM = ss ([1, -1]); % Matlab converts to SS (and back) for MIMO TF connections % Group Sum Block and Open Loop SUML = append (SUM, L); % Build System Interconnections CM = [3, 1; % Controller Input with Sum Block Output 2, 2]; % Sum Block Negative Input with Plant Output inputs = [1]; % Input 1: reference r(t) outputs = [1, 2]; % Output 1: error e(t), Output 2: output y(t) SUML = connect (SUML, CM, inputs, outputs); % Simulation [y, t_y] = step (SUML, t); % ITAE Criterion itae = dt * (t_y.' * abs (y(:, 1))); % Sensitivity S = inv (1 + L); Ms = norm (S, inf); % Objective Function J = mu_1 * itae + mu_2 * (max (y(:, 2)) - 1) + mu_3 * Ms; end % function % =============================================================================== control-4.1.2/PaxHeaders/NEWS0000644000000000000000000000007415012430645012760 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/NEWS0000644000175000017500000003502615012430645014155 0ustar00lilgelilge00000000000000 Summary of important user-visible changes for releases of the control package =============================================================================== control-4.1.2 Release date 2025-05-18 =============================================================================== ** estim: new input argument 'type' for a delayed or current version of a discrete-time estimator using last or current output measurements for current state estimation ** kalman: adding 'type' input argument for discrete-time filters (see estim), consistent default values for input arguments ** added more test, like, e.g. estim, kalman and ssdata ** hinfsyn: more comprehensive help text ** margin: fix of wrong phase margin if outside +/- 180 degree ** rlocusx: improved colors =============================================================================== control-4.1.1 Release date 2025-02-09 =============================================================================== ** more robust test in impulse and cfconred ** fix possibly missing deprecated LAPACK routine DGEGS ** input parameter checking for NaN and Inf in oct-files in order to prevent Octave from hanging (bug #66669) ** ss: state space from MIMO transfer function 'tfsys' numerically more robust (bug #66651) ** lyap (A,Q) also for non-symmetric Q (bug #66567) ** fix time responses (step, impulse, ...) if requested for multiple systems and on Octave versions prior to Octave 8 ** minor fixes in the build system =============================================================================== control-4.1.0 Release date 2024-12-06 =============================================================================== ** lqg, lqgtrack, lqgreg, reg: new functions for linear dynamic output feedback design including estimator and state feedback ** lqry, lqi: new linear quadratic regulator design function, output weighting and with integral part ** c2d: impulse invariant discrete-time models for MIMO systems and state space representations ** New algorithm for imp_invar, also allowing MIMO systems ** tfdata: returning coefficient lists of same length for numerator and denominator (bug #43947) ** allow time responses for several systems with different sizes =============================================================================== control-4.0.1 Release date 2024-03-24 =============================================================================== ** warning messages do not include trace information anymore ** mktito: changed name of inputs and outputs for compatibility (bug #63736) ** more robust test using Markov parameters for several model reduction routines (bug #65218) ** fix graphic styles in pzmap (bug #57716) ** bode: fixed format of the 'phase' output argument ** doc_control ('license') displays license and copyright information =============================================================================== control-4.0.0 Release date 2024-01-04 =============================================================================== ** use current version of the SLICOT-Reference routines v5.8 from Github (https://github.com/SLICOT/SLICOT-Reference/tree/main) ** fixed phase in bode plot for system with poles/zeros at the origin (credits to Juan, see bug bug #61355, comment #10) ** fixed duration of time responses like step for systems with oscillations ans improved graphical output =============================================================================== control-3.6.1 Release date 2023-07-10 =============================================================================== ** fix bug #64374: numeric constants are converted into proper lti systems before being interconnected to discrete time-systems =============================================================================== control-3.6.0 Release date 2023-05-20 =============================================================================== ** zgrid: new function for grid lines with constant eigenfrequency and damping for discrete-time pole/zero maps ** pzamp: added unit circle (for discrete-time) systems and axes to the pole/zero maps ** allow discrete-time purely static gain systems with a sampling time ** added metainfo file octave-control.metainfo.xml =============================================================================== control-3.5.2 Release date 2023-04-05 =============================================================================== ** fix build errors when installing in Octave 6 =============================================================================== control-3.5.1 Release date 2023-03-21 =============================================================================== ** fix build errors when installing in Octave 9 ** more robust tests for some model reduction and identification functions =============================================================================== control-3.5.0 Release date 2023-02-04 =============================================================================== ** c2d: allow mimo systems for impulse invariant discretization ** impulse: allow systems with feedthrough ** acker: Checking length of vector with desired poles (bug #62053), compacter and faster code, fix bug resulting from Octave 8 zeros() function (bug #63744) ** fix freq. vector for bode etc. for systems with very small zeros or poles (bug #62186) ** isdt: treat static gain as ct due to missing sampling time ** tf: improve detection of static gain systems (bug #63661) =============================================================================== control-3.4.0 Release Date: 2022-01-16 =============================================================================== ** Fix lyapunov equ. in dlyap if B is non-symmetric (bug #49801) ** Declare tf([1],[1]) as static gain ** Returned num and den of tfdate have same length (bug #43947) ** Fixes for Octave 7.1.0: removed deprecated .+ operator and unsupported plot style =============================================================================== control-3.3.1 Release Date: 2021-07-05 =============================================================================== ** Fixed time response for first order systems =============================================================================== control-3.3.0 Release Date: 2021-06-19 =============================================================================== ** new function rlocusx providing gain, damping and frequency for selected poles together with the possibility to generate open loop bode plots and simulations of the closed loop for selected closed loop poles ** Fixed several issues in bode, c2d, lsim and step ** Fixed issues in legends of time and frequency responses when requested for multiple systems ** Fixed usage of deprecated LAPACK routines ** Added discretization method 'foh' to c2d ** Added tests for c2d with 'foh' and to dlyapchol ** Fixed transposing a tfploy =============================================================================== control-3.2.0 Release Date: 2019-04-01 =============================================================================== ** new function sgrid ** New function: ss2ss ** Fixed many warnings ** added demos to rlocus, pzmap, bode, nichols, nyquist, impulse, lsim, ramp and step ** improved pzmap to plot with only zeros =============================================================================== control-3.1.0 Release Date: 2018-03-11 =============================================================================== ** New function: damp ** Changed nelem to numel and length to numel to remove the warnings during installation. ** The Impulse section has been rewritten, and a new file -- imp_invar.m -- added. The old system tried to use the "zoh" to get an impulse response but that is impossible. ** The new function "imp_invar.m" converts a Laplace tranfer function to a discrete tranfer function. ** New functions: acker, dsort, esort. ** Function lsim now plots inputs as well. ** Class 'ss' should now work with complex inputs. ** Extend nyquist plots. ** Fixed warnings with newer Octave versions. =============================================================================== control-3.0.0 Release Date: 2015-10-30 Release Manager: Lukas Reichlin =============================================================================== ** Substantial parts of the most vital internals have been rewritten and streamlined in order to improve compatibility and reliability. These changes to the codebase also result in better error handling in many situations and facilitate the integration of new features in upcoming releases. ** While many issues and pitfalls existing in previous releases of the control package have been fixed, the author isn't aware (at release date) of any regressions one might expect from a x.0.0 release. Note that the absence of regressions doesn't mean the absence of bugs. Especially it doesn't mean that *all* bugs from control-2.8.5 have been fixed. Also note that to err is human, and software is written by humans. Therefore, any larger piece of software is likely to contain bugs. But the author is confident that he squashed considerably more bugs than he introduced in this release. So if you waver between updating now and waiting for control-3.0.x, the author's suggestion is definitely to update now. ** As always, your feedback is highly appreciated! Even if you think that the control package is "fubar". If you just follow the German saying "gesehen, gelacht, geloescht" - which roughly translates into "seen it, laughed at it, deleted it" - there's only little chance for improvement! So if you think you've found a bug, please take the time to report your findings on Octave's bugtracker: See the link below for more information about how to report problems: ** Your help is welcome! There are many ways you can help the project fix the remaining problems, complete the documentation, and improve the overall user experience for both novices and experts alike. The author is aware of the fact that the documentation still leaves a lot to be desired. As it is often the case with developers, writing documentation and tutorials is neither his key skill nor his favorite occupation. After all, the author wrote the control package due to his personal interest in the field of control systems and not to make a living out of it. The developer's profits are the insights and experience he obtained from his work. Consequently, the control project doesn't ask you for money. In case you like the control package and should feel like donating, then consider donating to GNU Octave or the Free Software Foundation according to the information on their websites. Thank you! ** LTI models in general Improved handling of key-value pairs in all constructors for LTI models: tf (matrix, 'key1', val1, ...), ss (a, b, 'key1', val1, ...) Support inheritance of LTI properties in many variations: tf (num, den, ltisys), ss (a, b, ltisys, 'key1', val1, ...) sys.lti = ltisys, zpk (z, p, k, Ts, 'var', 'q', 'lti', ltisys, ...) Accept [] as an alias for unspecified sampling time (Ts = -1): filt ('q^-1', []), ss (a, b, c, d, []), sys.Ts = [] Automatic vector expansion for input and output names: sys.inname = 'str', sys.outname = '' (for MIMO systems) ** dss Fixed a long-standing but undiscovered bug where 'dss (sys)' overwrites sys.e with an identity matrix even if sys.e was not empty. D'oh! ** ss Support for the following special cases has been added: ss (sys, 'explicit') % convert descriptor system to regular one ss (sys, 'minimal') % equivalent to minreal (ss (sys)) ** tf, zpk, filt Restrict transfer function variable to the candidates 's', 'p' for continuous-time and 'z', 'q', 'z^-1', 'q^-1' for discrete-time models. s = tf ('s'), z = tf ('z^-1', Ts), tf (num, den, Ts, 'var', 'q') Previous control versions supported any string, which could be quite misleading, see bug #45371. ** bode, bodemag, nichols, nyquist, sigma Fixed bug #42495. It is now possible to specify a frequency vector of length 1, e.g. [mag, phase] = bode (sys, 1) Furthermore, the functions raise an error or warning if invalid arguments are passed to them. Previously, invalid arguments were simply ignored, which could be confusing. ** step, impulse, initial, ramp The time response functions now raise an error or warning if invalid arguments are passed to them. As it was the case for frequency response functions, they used to simply ignore invalid arguments. ** lsim Fixed bug #46247. (Reported by Lutz Mager and Piet Wertelaers) Support logical arrays as input signal. Before, logical arrays were simply ignored without notice, which could lead to unexpected results. Additionally, lsim received the same improvements as the other time and frequency response functions regarding invalid arguments. ** pzmap Improved argument checks. ** augstate New function for state-space models. Adds the state vector to the output vector. ** connect The function no longer raises an error for name-based interconnections if some systems have common input names and one of these inputs are to be kept. ** estim Add input/output/state names to the returned system. Support name-based selection of inputs (arguments 'sensors' and 'known'). ** sumblk Add signal names as input/output groups if argument n > 1. ** minreal If state-space models already have a minimal realization, then no state transformations are applied to the returned model. In other words, if the number of states cannot be reduced (with the chosen tolerance), the model is returned unchanged. Note that if the user sets the tolerance to the maximum value of 1, every state-space model will be reduced to zero states. There's nothing wrong with that, it's just how numerical computation works. A Summary of important user-visible changes for older releases of the control package can be found in the file ONEWS. control-4.1.2/PaxHeaders/DESCRIPTION0000644000000000000000000000007415012430645013767 xustar0030 atime=1747595719.937099086 30 ctime=1747595720.873132883 control-4.1.2/DESCRIPTION0000644000175000017500000000106715012430645015162 0ustar00lilgelilge00000000000000Name: control Version: 4.1.2 Date: 2025-05-18 Author: Lukas Reichlin Maintainer: Doug Stewart , Torsten Lilge Title: Control Package Description: Control package for GNU Octave including system analysis and control synthesis. The package uses routines of the SLICOT-Reference library. Depends: octave (>= 5.2.0) Autoload: no License: GPLv3-or-later, BSD 3-Clause License (SLICOT files) Url: https://github.com/gnu-octave/pkg-control Tracker: https://github.com/gnu-octave/pkg-control/issues control-4.1.2/PaxHeaders/io.github.gnu_octave.pkg-control.metainfo.xml0000644000000000000000000000007415012430645023063 xustar0030 atime=1747595719.945099375 30 ctime=1747595720.873132883 control-4.1.2/io.github.gnu_octave.pkg-control.metainfo.xml0000644000175000017500000000314415012430645024254 0ustar00lilgelilge00000000000000 io.github.gnu_octave.pkg-control org.octave.Octave Control Design and Analysis The control package for GNU Octave Octave Control Linear Time Invariant Models Time Domain Analysis Frequency Domain Analysis Pole Placement Optimal Control Robust Control Matrix Equation Solvers Model and Controller Reduction System Identification

The Control package for GNU Octave is a collection of functions for system analysis and control synthesis. The package uses routines of the SLICOT-Reference library.

https://gnu-octave.github.io/packages/control https://github.com/gnu-octave/pkg-control/issues FSFAP GPL-3.0-or-later and BSD-3-Clause Octave Community octave-maintainers@gnu.org